mirror of
https://github.com/msberends/AMR.git
synced 2025-07-08 23:21:56 +02:00
(v1.1.0.9012) lose dependencies
This commit is contained in:
@ -427,6 +427,8 @@ percentage <- function(x, digits = NULL, ...) {
|
||||
}
|
||||
|
||||
# prevent dependency on package 'backports'
|
||||
# these functions were not available in previous versions of R (last checked: R 4.0.0)
|
||||
# see here for the full list: https://github.com/r-lib/backports
|
||||
strrep = function(x, times) {
|
||||
x = as.character(x)
|
||||
if (length(x) == 0L)
|
||||
@ -451,3 +453,6 @@ trimws <- function (x, which = c("both", "left", "right")) {
|
||||
isFALSE <- function (x) {
|
||||
is.logical(x) && length(x) == 1L && !is.na(x) && !x
|
||||
}
|
||||
deparse1 = function (expr, collapse = " ", width.cutoff = 500L, ...) {
|
||||
paste(deparse(expr, width.cutoff, ...), collapse = collapse)
|
||||
}
|
||||
|
||||
23
R/ab.R
23
R/ab.R
@ -75,7 +75,7 @@ as.ab <- function(x, ...) {
|
||||
if (all(toupper(x) %in% antibiotics$ab)) {
|
||||
# valid AB code, but not yet right class
|
||||
return(structure(.Data = toupper(x),
|
||||
class = "ab"))
|
||||
class = c("ab", "character")))
|
||||
}
|
||||
|
||||
x_bak <- x
|
||||
@ -332,7 +332,7 @@ as.ab <- function(x, ...) {
|
||||
}
|
||||
|
||||
structure(.Data = x_result,
|
||||
class = "ab")
|
||||
class = c("ab", "character"))
|
||||
}
|
||||
|
||||
#' @rdname as.ab
|
||||
@ -352,17 +352,14 @@ print.ab <- function(x, ...) {
|
||||
#' @exportMethod as.data.frame.ab
|
||||
#' @export
|
||||
#' @noRd
|
||||
as.data.frame.ab <- function(x, ...) {
|
||||
# same as as.data.frame.character but with removed stringsAsFactors
|
||||
nm <- paste(deparse(substitute(x), width.cutoff = 500L),
|
||||
collapse = " ")
|
||||
as.data.frame.ab <- function (x, ...) {
|
||||
nm <- deparse1(substitute(x))
|
||||
if (!"nm" %in% names(list(...))) {
|
||||
as.data.frame.vector(x, ..., nm = nm)
|
||||
as.data.frame.vector(as.ab(x), ..., nm = nm)
|
||||
} else {
|
||||
as.data.frame.vector(x, ...)
|
||||
as.data.frame.vector(as.ab(x), ...)
|
||||
}
|
||||
}
|
||||
|
||||
#' @exportMethod [.ab
|
||||
#' @export
|
||||
#' @noRd
|
||||
@ -403,11 +400,3 @@ c.ab <- function(x, ...) {
|
||||
attributes(y) <- attributes(x)
|
||||
class_integrity_check(y, "antimicrobial code", antibiotics$ab)
|
||||
}
|
||||
|
||||
#' @importFrom pillar pillar_shaft
|
||||
#' @export
|
||||
pillar_shaft.ab <- function(x, ...) {
|
||||
out <- format(x)
|
||||
out[is.na(x)] <- font_red("NA")
|
||||
pillar::new_pillar_shaft_simple(out, align = "left", min_width = 4)
|
||||
}
|
||||
|
||||
31
R/disk.R
31
R/disk.R
@ -53,9 +53,7 @@
|
||||
#' as.rsi(df)
|
||||
#' }
|
||||
as.disk <- function(x, na.rm = FALSE) {
|
||||
if (is.disk(x)) {
|
||||
x
|
||||
} else {
|
||||
if (!is.disk(x)) {
|
||||
x <- x %>% unlist()
|
||||
if (na.rm == TRUE) {
|
||||
x <- x[!is.na(x)]
|
||||
@ -81,10 +79,9 @@ as.disk <- function(x, na.rm = FALSE) {
|
||||
"%) that were invalid disk zones: ",
|
||||
list_missing, call. = FALSE)
|
||||
}
|
||||
|
||||
class(x) <- "disk"
|
||||
x
|
||||
}
|
||||
structure(as.integer(x),
|
||||
class = c("disk", "integer"))
|
||||
}
|
||||
|
||||
all_valid_disks <- function(x) {
|
||||
@ -98,20 +95,6 @@ is.disk <- function(x) {
|
||||
inherits(x, "disk")
|
||||
}
|
||||
|
||||
#' @exportMethod as.data.frame.disk
|
||||
#' @export
|
||||
#' @noRd
|
||||
as.data.frame.disk <- function(x, ...) {
|
||||
# same as as.data.frame.integer but with removed stringsAsFactors, since it will be class "disk"
|
||||
nm <- paste(deparse(substitute(x), width.cutoff = 500L),
|
||||
collapse = " ")
|
||||
if (!"nm" %in% names(list(...))) {
|
||||
as.data.frame.vector(x, ..., nm = nm)
|
||||
} else {
|
||||
as.data.frame.vector(x, ...)
|
||||
}
|
||||
}
|
||||
|
||||
#' @exportMethod print.disk
|
||||
#' @export
|
||||
#' @noRd
|
||||
@ -120,14 +103,6 @@ print.disk <- function(x, ...) {
|
||||
print(as.integer(x), quote = FALSE)
|
||||
}
|
||||
|
||||
#' @importFrom pillar pillar_shaft
|
||||
#' @export
|
||||
pillar_shaft.disk <- function(x, ...) {
|
||||
out <- trimws(format(x))
|
||||
out[is.na(x)] <- font_red(NA)
|
||||
pillar::new_pillar_shaft_simple(out, align = "right", min_width = 3)
|
||||
}
|
||||
|
||||
#' @exportMethod [.disk
|
||||
#' @export
|
||||
#' @noRd
|
||||
|
||||
18
R/freq.R
18
R/freq.R
@ -19,12 +19,15 @@
|
||||
# Visit our website for more info: https://msberends.gitlab.io/AMR. #
|
||||
# ==================================================================== #
|
||||
|
||||
#' @importFrom cleaner freq
|
||||
#' @export
|
||||
cleaner::freq
|
||||
if ("cleaner" %in% rownames(utils::installed.packages())) {
|
||||
freq <- get("freq", envir = asNamespace("cleaner"))
|
||||
freq.default <- get("freq.default", envir = asNamespace("cleaner"))
|
||||
} else {
|
||||
freq <- ""
|
||||
freq.default <- ""
|
||||
}
|
||||
|
||||
#' @exportMethod freq.mo
|
||||
#' @importFrom cleaner freq.default
|
||||
#' @method freq mo
|
||||
#' @export
|
||||
#' @noRd
|
||||
freq.mo <- function(x, ...) {
|
||||
@ -47,11 +50,10 @@ freq.mo <- function(x, ...) {
|
||||
")"),
|
||||
`No of genera` = n_distinct(mo_genus(x_noNA, language = NULL)),
|
||||
`No of species` = n_distinct(paste(mo_genus(x_noNA, language = NULL),
|
||||
mo_species(x_noNA, language = NULL)))))
|
||||
mo_species(x_noNA, language = NULL)))))
|
||||
}
|
||||
|
||||
#' @exportMethod freq.rsi
|
||||
#' @importFrom cleaner freq.default
|
||||
#' @method freq rsi
|
||||
#' @export
|
||||
#' @noRd
|
||||
freq.rsi <- function(x, ...) {
|
||||
|
||||
8
R/mic.R
8
R/mic.R
@ -232,14 +232,6 @@ barplot.mic <- function(height,
|
||||
axis(2, seq(0, max(table(droplevels.factor(height)))))
|
||||
}
|
||||
|
||||
#' @importFrom pillar pillar_shaft
|
||||
#' @export
|
||||
pillar_shaft.mic <- function(x, ...) {
|
||||
out <- trimws(format(x))
|
||||
out[is.na(x)] <- font_red(NA)
|
||||
pillar::new_pillar_shaft_simple(out, align = "right", min_width = 4)
|
||||
}
|
||||
|
||||
#' @exportMethod [.mic
|
||||
#' @export
|
||||
#' @noRd
|
||||
|
||||
34
R/mo.R
34
R/mo.R
@ -230,7 +230,8 @@ as.mo <- function(x,
|
||||
}
|
||||
|
||||
to_class_mo <- function(x) {
|
||||
structure(.Data = x, class = "mo")
|
||||
structure(.Data = x,
|
||||
class = c("mo", "character"))
|
||||
}
|
||||
|
||||
#' @rdname as.mo
|
||||
@ -1558,27 +1559,6 @@ print.mo <- function(x, ...) {
|
||||
print.default(x, quote = FALSE)
|
||||
}
|
||||
|
||||
#' @importFrom pillar pillar_shaft
|
||||
#' @export
|
||||
pillar_shaft.mo <- function(x, ...) {
|
||||
out <- format(x)
|
||||
# grey out the kingdom (part until first "_")
|
||||
out[!is.na(x)] <- gsub("^([A-Z]+_)(.*)", paste0(font_subtle("\\1"), "\\2"), out[!is.na(x)])
|
||||
# and grey out every _
|
||||
out[!is.na(x)] <- gsub("_", font_subtle("_"), out[!is.na(x)])
|
||||
|
||||
# markup NA and UNKNOWN
|
||||
out[is.na(x)] <- font_red(" NA")
|
||||
out[x == "UNKNOWN"] <- font_red(" UNKNOWN")
|
||||
|
||||
# make it always fit exactly
|
||||
pillar::new_pillar_shaft_simple(out,
|
||||
align = "left",
|
||||
width = max(nchar(x)) + ifelse(length(x[x %in% c(NA, "UNKNOWN")]) > 0,
|
||||
2,
|
||||
0))
|
||||
}
|
||||
|
||||
#' @exportMethod summary.mo
|
||||
#' @export
|
||||
#' @noRd
|
||||
@ -1598,14 +1578,12 @@ summary.mo <- function(object, ...) {
|
||||
#' @exportMethod as.data.frame.mo
|
||||
#' @export
|
||||
#' @noRd
|
||||
as.data.frame.mo <- function(x, ...) {
|
||||
# same as as.data.frame.character but with removed stringsAsFactors, since it will be class "mo"
|
||||
nm <- paste(deparse(substitute(x), width.cutoff = 500L),
|
||||
collapse = " ")
|
||||
as.data.frame.mo <- function (x, ...) {
|
||||
nm <- deparse1(substitute(x))
|
||||
if (!"nm" %in% names(list(...))) {
|
||||
as.data.frame.vector(x, ..., nm = nm)
|
||||
as.data.frame.vector(as.mo(x), ..., nm = nm)
|
||||
} else {
|
||||
as.data.frame.vector(x, ...)
|
||||
as.data.frame.vector(as.mo(x), ...)
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
11
R/rsi.R
11
R/rsi.R
@ -650,17 +650,6 @@ barplot.rsi <- function(height,
|
||||
}
|
||||
}
|
||||
|
||||
#' @importFrom pillar pillar_shaft
|
||||
#' @export
|
||||
pillar_shaft.rsi <- function(x, ...) {
|
||||
out <- trimws(format(x))
|
||||
out[is.na(x)] <- font_subtle(" NA")
|
||||
out[x == "S"] <- font_green_bg(font_white(" S "))
|
||||
out[x == "I"] <- font_yellow_bg(font_black(" I "))
|
||||
out[x == "R"] <- font_red_bg(font_white(" R "))
|
||||
pillar::new_pillar_shaft_simple(out, align = "left", width = 3)
|
||||
}
|
||||
|
||||
#' @exportMethod [<-.rsi
|
||||
#' @export
|
||||
#' @noRd
|
||||
|
||||
10
R/rsi_calc.R
10
R/rsi_calc.R
@ -45,7 +45,7 @@ rsi_calc <- function(...,
|
||||
stop("`only_all_tested` must be logical", call. = FALSE)
|
||||
}
|
||||
|
||||
dots_df <- switch(1, ...) # it needs this evaluation
|
||||
dots_df <- switch(1, ...)
|
||||
dots <- base::eval(base::substitute(base::alist(...)))
|
||||
if ("also_single_tested" %in% names(dots)) {
|
||||
stop("`also_single_tested` was replaced by `only_all_tested`. Please read Details in the help page (`?proportion`) as this may have a considerable impact on your analysis.", call. = FALSE)
|
||||
@ -53,21 +53,21 @@ rsi_calc <- function(...,
|
||||
ndots <- length(dots)
|
||||
|
||||
if ("data.frame" %in% class(dots_df)) {
|
||||
# data.frame passed with other columns, like: example_isolates %>% proportion_S(amcl, gent)
|
||||
# data.frame passed with other columns, like: example_isolates %>% proportion_S(AMC, GEN)
|
||||
dots <- as.character(dots)
|
||||
dots <- dots[dots != "."]
|
||||
if (length(dots) == 0 | all(dots == "df")) {
|
||||
# for complete data.frames, like example_isolates %>% select(amcl, gent) %>% proportion_S()
|
||||
# for complete data.frames, like example_isolates %>% select(AMC, GEN) %>% proportion_S()
|
||||
# and the old rsi function, which has "df" as name of the first parameter
|
||||
x <- dots_df
|
||||
} else {
|
||||
x <- dots_df[, dots[dots %in% colnames(dots_df)]]
|
||||
}
|
||||
} else if (ndots == 1) {
|
||||
# only 1 variable passed (can also be data.frame), like: proportion_S(example_isolates$amcl) and example_isolates$amcl %>% proportion_S()
|
||||
# only 1 variable passed (can also be data.frame), like: proportion_S(example_isolates$AMC) and example_isolates$AMC %>% proportion_S()
|
||||
x <- dots_df
|
||||
} else {
|
||||
# multiple variables passed without pipe, like: proportion_S(example_isolates$amcl, example_isolates$gent)
|
||||
# multiple variables passed without pipe, like: proportion_S(example_isolates$AMC, example_isolates$GEN)
|
||||
x <- NULL
|
||||
try(x <- as.data.frame(dots), silent = TRUE)
|
||||
if (is.null(x)) {
|
||||
|
||||
BIN
R/sysdata.rda
BIN
R/sysdata.rda
Binary file not shown.
257
R/tidyverse.R
257
R/tidyverse.R
@ -1,257 +0,0 @@
|
||||
# ==================================================================== #
|
||||
# TITLE #
|
||||
# Antimicrobial Resistance (AMR) Analysis #
|
||||
# #
|
||||
# SOURCE #
|
||||
# https://gitlab.com/msberends/AMR #
|
||||
# #
|
||||
# LICENCE #
|
||||
# (c) 2018-2020 Berends MS, Luz CF et al. #
|
||||
# #
|
||||
# This R package is free software; you can freely use and distribute #
|
||||
# it for both personal and commercial purposes under the terms of the #
|
||||
# GNU General Public License version 2.0 (GNU GPL-2), as published by #
|
||||
# the Free Software Foundation. #
|
||||
# #
|
||||
# We created this package for both routine data analysis and academic #
|
||||
# research and it was publicly released in the hope that it will be #
|
||||
# useful, but it comes WITHOUT ANY WARRANTY OR LIABILITY. #
|
||||
# Visit our website for more info: https://msberends.gitlab.io/AMR. #
|
||||
# ==================================================================== #
|
||||
|
||||
#' Methods for tidyverse
|
||||
#'
|
||||
#' These methods are needed to support methods used by the tidyverse, like joining and transforming data, with new classes that come with this package.
|
||||
#' @inheritSection lifecycle Stable lifecycle
|
||||
#' @inheritSection AMR Read more on our website!
|
||||
#' @keywords internal
|
||||
#' @name AMR-tidyverse
|
||||
NULL
|
||||
|
||||
#' @rdname AMR-tidyverse
|
||||
#' @exportMethod scale_type.mo
|
||||
#' @export
|
||||
scale_type.mo <- function(x) {
|
||||
# fix for:
|
||||
# "Don't know how to automatically pick scale for object of type mo. Defaulting to continuous."
|
||||
# "Error: Discrete value supplied to continuous scale"
|
||||
"discrete"
|
||||
}
|
||||
|
||||
#' @rdname AMR-tidyverse
|
||||
#' @exportMethod scale_type.ab
|
||||
#' @export
|
||||
scale_type.ab <- function(x) {
|
||||
# fix for:
|
||||
# "Don't know how to automatically pick scale for object of type mo. Defaulting to continuous."
|
||||
# "Error: Discrete value supplied to continuous scale"
|
||||
"discrete"
|
||||
}
|
||||
|
||||
|
||||
# Class mo ----------------------------------------------------------------
|
||||
|
||||
|
||||
#' @exportMethod vec_ptype_abbr.mo
|
||||
#' @importFrom vctrs vec_ptype_abbr
|
||||
#' @export
|
||||
vec_ptype_abbr.mo <- function(x, ...) {
|
||||
"mo"
|
||||
}
|
||||
|
||||
#' @exportMethod vec_ptype_full.mo
|
||||
#' @importFrom vctrs vec_ptype_full
|
||||
#' @export
|
||||
vec_ptype_full.mo <- function(x, ...) {
|
||||
"mo"
|
||||
}
|
||||
|
||||
#' @rdname AMR-tidyverse
|
||||
#' @export
|
||||
vec_ptype2.mo <- function(x, y, ...) {
|
||||
UseMethod("vec_ptype2.mo", y)
|
||||
}
|
||||
|
||||
#' @method vec_ptype2.mo default
|
||||
#' @export
|
||||
vec_ptype2.mo.default <- function(x, y, ..., x_arg = "x", y_arg = "y") {
|
||||
vctrs::vec_default_ptype2(x, y, x_arg = x_arg, y_arg = y_arg)
|
||||
}
|
||||
|
||||
#' @method vec_ptype2.mo character
|
||||
#' @export
|
||||
vec_ptype2.mo.character <- function(x, y, ...) {
|
||||
x
|
||||
}
|
||||
|
||||
#' @method vec_ptype2.character mo
|
||||
#' @exportMethod vec_ptype2.character.mo
|
||||
#' @importFrom vctrs vec_ptype2.character
|
||||
#' @export
|
||||
vec_ptype2.character.mo <- function(x, y, ...) {
|
||||
y
|
||||
}
|
||||
|
||||
#' @rdname AMR-tidyverse
|
||||
#' @export
|
||||
vec_cast.mo <- function(x, to, ...) {
|
||||
UseMethod("vec_cast.mo")
|
||||
}
|
||||
|
||||
#' @method vec_cast.mo mo
|
||||
#' @export
|
||||
vec_cast.mo.mo <- function(x, to, ...) {
|
||||
as.mo(x)
|
||||
}
|
||||
|
||||
#' @method vec_cast.mo character
|
||||
#' @export
|
||||
vec_cast.mo.character <- function(x, to, ...) {
|
||||
as.mo(x)
|
||||
}
|
||||
|
||||
#' @method vec_cast.mo default
|
||||
#' @importFrom vctrs vec_default_cast
|
||||
#' @export
|
||||
vec_cast.mo.default <- function(x, to, ...) {
|
||||
vec_default_cast(x, to)
|
||||
}
|
||||
|
||||
#' @method vec_cast.character mo
|
||||
#' @exportMethod vec_cast.character.mo
|
||||
#' @importFrom vctrs vec_cast vec_cast.character
|
||||
#' @export
|
||||
vec_cast.character.mo <- function(x, to, ...) {
|
||||
unclass(x)
|
||||
}
|
||||
|
||||
|
||||
# Class ab ----------------------------------------------------------------
|
||||
|
||||
|
||||
#' @exportMethod vec_ptype_abbr.ab
|
||||
#' @importFrom vctrs vec_ptype_abbr
|
||||
#' @export
|
||||
vec_ptype_abbr.ab <- function(x, ...) {
|
||||
"ab"
|
||||
}
|
||||
|
||||
#' @exportMethod vec_ptype_full.ab
|
||||
#' @importFrom vctrs vec_ptype_full
|
||||
#' @export
|
||||
vec_ptype_full.ab <- function(x, ...) {
|
||||
"ab"
|
||||
}
|
||||
|
||||
#' @rdname AMR-tidyverse
|
||||
#' @export
|
||||
vec_ptype2.ab <- function(x, y, ...) {
|
||||
UseMethod("vec_ptype2.ab", y)
|
||||
}
|
||||
|
||||
#' @method vec_ptype2.ab default
|
||||
#' @export
|
||||
vec_ptype2.ab.default <- function(x, y, ..., x_arg = "x", y_arg = "y") {
|
||||
vctrs::vec_default_ptype2(x, y, x_arg = x_arg, y_arg = y_arg)
|
||||
}
|
||||
|
||||
#' @method vec_ptype2.ab character
|
||||
#' @export
|
||||
vec_ptype2.ab.character <- function(x, y, ...) {
|
||||
x
|
||||
}
|
||||
|
||||
#' @method vec_ptype2.character ab
|
||||
#' @exportMethod vec_ptype2.character.ab
|
||||
#' @importFrom vctrs vec_ptype2.character
|
||||
#' @export
|
||||
vec_ptype2.character.ab <- function(x, y, ...) {
|
||||
y
|
||||
}
|
||||
|
||||
#' @rdname AMR-tidyverse
|
||||
#' @export
|
||||
vec_cast.ab <- function(x, to, ...) {
|
||||
UseMethod("vec_cast.ab")
|
||||
}
|
||||
|
||||
#' @method vec_cast.ab ab
|
||||
#' @export
|
||||
vec_cast.ab.ab <- function(x, to, ...) {
|
||||
as.ab(x)
|
||||
}
|
||||
|
||||
#' @method vec_cast.ab character
|
||||
#' @export
|
||||
vec_cast.ab.character <- function(x, to, ...) {
|
||||
as.ab(x)
|
||||
}
|
||||
|
||||
#' @method vec_cast.ab default
|
||||
#' @importFrom vctrs vec_default_cast
|
||||
#' @export
|
||||
vec_cast.ab.default <- function(x, to, ...) {
|
||||
vec_default_cast(x, to)
|
||||
}
|
||||
|
||||
#' @method vec_cast.character ab
|
||||
#' @exportMethod vec_cast.character.ab
|
||||
#' @importFrom vctrs vec_cast vec_cast.character
|
||||
#' @export
|
||||
vec_cast.character.ab <- function(x, to, ...) {
|
||||
unclass(x)
|
||||
}
|
||||
|
||||
|
||||
# Class disk --------------------------------------------------------------
|
||||
|
||||
|
||||
#' @exportMethod vec_ptype_abbr.disk
|
||||
#' @importFrom vctrs vec_ptype_abbr
|
||||
#' @export
|
||||
vec_ptype_abbr.disk <- function(x, ...) {
|
||||
"disk"
|
||||
}
|
||||
|
||||
#' @exportMethod vec_ptype_full.disk
|
||||
#' @importFrom vctrs vec_ptype_full
|
||||
#' @export
|
||||
vec_ptype_full.disk <- function(x, ...) {
|
||||
"disk"
|
||||
}
|
||||
|
||||
|
||||
# Class rsi --------------------------------------------------------------
|
||||
|
||||
|
||||
#' @exportMethod vec_ptype_abbr.rsi
|
||||
#' @importFrom vctrs vec_ptype_abbr
|
||||
#' @export
|
||||
vec_ptype_abbr.rsi <- function(x, ...) {
|
||||
"rsi"
|
||||
}
|
||||
|
||||
#' @exportMethod vec_ptype_full.rsi
|
||||
#' @importFrom vctrs vec_ptype_full
|
||||
#' @export
|
||||
vec_ptype_full.rsi <- function(x, ...) {
|
||||
"rsi"
|
||||
}
|
||||
|
||||
|
||||
# Class mic --------------------------------------------------------------
|
||||
|
||||
|
||||
#' @exportMethod vec_ptype_abbr.mic
|
||||
#' @importFrom vctrs vec_ptype_abbr
|
||||
#' @export
|
||||
vec_ptype_abbr.mic <- function(x, ...) {
|
||||
"mic"
|
||||
}
|
||||
|
||||
#' @exportMethod vec_ptype_full.mic
|
||||
#' @importFrom vctrs vec_ptype_full
|
||||
#' @export
|
||||
vec_ptype_full.mic <- function(x, ...) {
|
||||
"mic"
|
||||
}
|
||||
Reference in New Issue
Block a user