mirror of
https://github.com/msberends/AMR.git
synced 2025-07-08 13:21:50 +02:00
(v1.0.1.9004) Support dplyr 1.0.0
This commit is contained in:
10
R/ab.R
10
R/ab.R
@ -396,9 +396,15 @@ c.ab <- function(x, ...) {
|
||||
class_integrity_check(y, "antimicrobial code", antibiotics$ab)
|
||||
}
|
||||
|
||||
#' @importFrom pillar type_sum
|
||||
#' @importFrom vctrs vec_ptype_abbr
|
||||
#' @export
|
||||
type_sum.ab <- function(x) {
|
||||
vec_ptype_abbr.ab <- function(x, ...) {
|
||||
"ab"
|
||||
}
|
||||
|
||||
#' @importFrom vctrs vec_ptype_full
|
||||
#' @export
|
||||
vec_ptype_full.ab <- function(x, ...) {
|
||||
"ab"
|
||||
}
|
||||
|
||||
|
||||
1
R/amr.R
1
R/amr.R
@ -41,6 +41,7 @@
|
||||
#' - Getting SNOMED codes of a microorganism, or get its name associated with a SNOMED code
|
||||
#' - Getting LOINC codes of an antibiotic, or get its name associated with a LOINC code
|
||||
#' - Machine reading the EUCAST and CLSI guidelines from 2011-2020 to translate MIC values and disk diffusion diameters to R/SI
|
||||
#' - Principal component analysis for AMR
|
||||
|
||||
#' @section Read more on our website!:
|
||||
#' On our website <https://msberends.gitlab.io/AMR> you can find [a comprehensive tutorial](https://msberends.gitlab.io/AMR/articles/AMR.html) about how to conduct AMR analysis, the [complete documentation of all functions](https://msberends.gitlab.io/AMR/reference) (which reads a lot easier than here in R) and [an example analysis using WHONET data](https://msberends.gitlab.io/AMR/articles/WHONET.html).
|
||||
|
||||
@ -56,7 +56,7 @@
|
||||
#' - `"ml"` = milliliter (e.g. eyedrops)
|
||||
#' @export
|
||||
#' @rdname atc_online
|
||||
#' @importFrom dplyr %>% progress_estimated
|
||||
#' @importFrom dplyr %>%
|
||||
#' @inheritSection AMR Read more on our website!
|
||||
#' @source <https://www.whocc.no/atc_ddd_alterations__cumulative/ddd_alterations/abbrevations/>
|
||||
#' @examples
|
||||
|
||||
75
R/disk.R
75
R/disk.R
@ -80,7 +80,7 @@ as.disk <- function(x, na.rm = FALSE) {
|
||||
list_missing, call. = FALSE)
|
||||
}
|
||||
|
||||
class(x) <- c("disk", "integer")
|
||||
class(x) <- "disk"
|
||||
x
|
||||
}
|
||||
}
|
||||
@ -97,6 +97,20 @@ 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
|
||||
@ -105,12 +119,6 @@ print.disk <- function(x, ...) {
|
||||
print(as.integer(x), quote = FALSE)
|
||||
}
|
||||
|
||||
#' @importFrom pillar type_sum
|
||||
#' @export
|
||||
type_sum.disk <- function(x) {
|
||||
"disk"
|
||||
}
|
||||
|
||||
#' @importFrom pillar pillar_shaft
|
||||
#' @export
|
||||
pillar_shaft.disk <- function(x, ...) {
|
||||
@ -118,3 +126,56 @@ pillar_shaft.disk <- function(x, ...) {
|
||||
out[is.na(x)] <- pillar::style_na(NA)
|
||||
pillar::new_pillar_shaft_simple(out, align = "right", min_width = 3)
|
||||
}
|
||||
|
||||
#' @importFrom vctrs vec_ptype_abbr
|
||||
#' @export
|
||||
vec_ptype_abbr.disk <- function(x, ...) {
|
||||
"disk"
|
||||
}
|
||||
|
||||
#' @importFrom vctrs vec_ptype_full
|
||||
#' @export
|
||||
vec_ptype_full.disk <- function(x, ...) {
|
||||
"disk"
|
||||
}
|
||||
|
||||
#' @exportMethod [.disk
|
||||
#' @export
|
||||
#' @noRd
|
||||
"[.disk" <- function(x, ...) {
|
||||
y <- NextMethod()
|
||||
attributes(y) <- attributes(x)
|
||||
y
|
||||
}
|
||||
#' @exportMethod [[.disk
|
||||
#' @export
|
||||
#' @noRd
|
||||
"[[.disk" <- function(x, ...) {
|
||||
y <- NextMethod()
|
||||
attributes(y) <- attributes(x)
|
||||
y
|
||||
}
|
||||
#' @exportMethod [<-.disk
|
||||
#' @export
|
||||
#' @noRd
|
||||
"[<-.disk" <- function(i, j, ..., value) {
|
||||
y <- NextMethod()
|
||||
attributes(y) <- attributes(i)
|
||||
y
|
||||
}
|
||||
#' @exportMethod [[<-.disk
|
||||
#' @export
|
||||
#' @noRd
|
||||
"[[<-.disk" <- function(i, j, ..., value) {
|
||||
y <- NextMethod()
|
||||
attributes(y) <- attributes(i)
|
||||
y
|
||||
}
|
||||
#' @exportMethod c.disk
|
||||
#' @export
|
||||
#' @noRd
|
||||
c.disk <- function(x, ...) {
|
||||
y <- NextMethod()
|
||||
attributes(y) <- attributes(x)
|
||||
y
|
||||
}
|
||||
|
||||
@ -50,13 +50,14 @@
|
||||
#' df_joined <- left_join_microorganisms(df, "bacteria")
|
||||
#' colnames(df_joined)
|
||||
inner_join_microorganisms <- function(x, by = NULL, suffix = c("2", ""), ...) {
|
||||
check_dataset_integrity()
|
||||
checked <- joins_check_df(x, by)
|
||||
x <- checked$x
|
||||
by <- checked$by
|
||||
join <- suppressWarnings(
|
||||
dplyr::inner_join(x = x, y = microorganisms, by = by, suffix = suffix, ...)
|
||||
)
|
||||
if (nrow(join) > nrow(x)) {
|
||||
if (NROW(join) > NROW(x)) {
|
||||
warning("The newly joined tbl contains ", nrow(join) - nrow(x), " rows more that its original.")
|
||||
}
|
||||
join
|
||||
@ -65,13 +66,14 @@ inner_join_microorganisms <- function(x, by = NULL, suffix = c("2", ""), ...) {
|
||||
#' @rdname join
|
||||
#' @export
|
||||
left_join_microorganisms <- function(x, by = NULL, suffix = c("2", ""), ...) {
|
||||
check_dataset_integrity()
|
||||
checked <- joins_check_df(x, by)
|
||||
x <- checked$x
|
||||
by <- checked$by
|
||||
join <- suppressWarnings(
|
||||
dplyr::left_join(x = x, y = microorganisms, by = by, suffix = suffix, ...)
|
||||
)
|
||||
if (nrow(join) > nrow(x)) {
|
||||
if (NROW(join) > NROW(x)) {
|
||||
warning("The newly joined tbl contains ", nrow(join) - nrow(x), " rows more that its original.")
|
||||
}
|
||||
join
|
||||
@ -80,13 +82,14 @@ left_join_microorganisms <- function(x, by = NULL, suffix = c("2", ""), ...) {
|
||||
#' @rdname join
|
||||
#' @export
|
||||
right_join_microorganisms <- function(x, by = NULL, suffix = c("2", ""), ...) {
|
||||
check_dataset_integrity()
|
||||
checked <- joins_check_df(x, by)
|
||||
x <- checked$x
|
||||
by <- checked$by
|
||||
join <- suppressWarnings(
|
||||
dplyr::right_join(x = x, y = microorganisms, by = by, suffix = suffix, ...)
|
||||
)
|
||||
if (nrow(join) > nrow(x)) {
|
||||
if (NROW(join) > NROW(x)) {
|
||||
warning("The newly joined tbl contains ", nrow(join) - nrow(x), " rows more that its original.")
|
||||
}
|
||||
join
|
||||
@ -95,13 +98,14 @@ right_join_microorganisms <- function(x, by = NULL, suffix = c("2", ""), ...) {
|
||||
#' @rdname join
|
||||
#' @export
|
||||
full_join_microorganisms <- function(x, by = NULL, suffix = c("2", ""), ...) {
|
||||
check_dataset_integrity()
|
||||
checked <- joins_check_df(x, by)
|
||||
x <- checked$x
|
||||
by <- checked$by
|
||||
join <- suppressWarnings(
|
||||
dplyr::full_join(x = x, y = microorganisms, by = by, suffix = suffix, ...)
|
||||
)
|
||||
if (nrow(join) > nrow(x)) {
|
||||
if (NROW(join) > NROW(x)) {
|
||||
warning("The newly joined tbl contains ", nrow(join) - nrow(x), " rows more that its original.")
|
||||
}
|
||||
join
|
||||
@ -110,6 +114,7 @@ full_join_microorganisms <- function(x, by = NULL, suffix = c("2", ""), ...) {
|
||||
#' @rdname join
|
||||
#' @export
|
||||
semi_join_microorganisms <- function(x, by = NULL, ...) {
|
||||
check_dataset_integrity()
|
||||
checked <- joins_check_df(x, by)
|
||||
x <- checked$x
|
||||
by <- checked$by
|
||||
@ -121,6 +126,7 @@ semi_join_microorganisms <- function(x, by = NULL, ...) {
|
||||
#' @rdname join
|
||||
#' @export
|
||||
anti_join_microorganisms <- function(x, by = NULL, ...) {
|
||||
check_dataset_integrity()
|
||||
checked <- joins_check_df(x, by)
|
||||
x <- checked$x
|
||||
by <- checked$by
|
||||
@ -131,7 +137,7 @@ anti_join_microorganisms <- function(x, by = NULL, ...) {
|
||||
|
||||
joins_check_df <- function(x, by) {
|
||||
if (!any(class(x) %in% c("data.frame", "matrix"))) {
|
||||
x <- data.frame(mo = as.character(x), stringsAsFactors = FALSE)
|
||||
x <- data.frame(mo = as.mo(x), stringsAsFactors = FALSE)
|
||||
if (is.null(by)) {
|
||||
by <- "mo"
|
||||
}
|
||||
@ -142,6 +148,7 @@ joins_check_df <- function(x, by) {
|
||||
if (is.na(by)) {
|
||||
if ("mo" %in% colnames(x)) {
|
||||
by <- "mo"
|
||||
x[, "mo"] <- as.mo(x[, "mo"])
|
||||
} else {
|
||||
stop("Cannot join - no column found with name or class `mo`.", call. = FALSE)
|
||||
}
|
||||
|
||||
@ -245,7 +245,7 @@ key_antibiotics <- function(x,
|
||||
|
||||
}
|
||||
|
||||
#' @importFrom dplyr progress_estimated %>%
|
||||
#' @importFrom dplyr %>%
|
||||
#' @rdname key_antibiotics
|
||||
#' @export
|
||||
key_antibiotics_equal <- function(y,
|
||||
@ -270,7 +270,7 @@ key_antibiotics_equal <- function(y,
|
||||
result <- logical(length(x))
|
||||
|
||||
if (info_needed == TRUE) {
|
||||
p <- dplyr::progress_estimated(length(x))
|
||||
p <- progress_estimated(length(x))
|
||||
}
|
||||
|
||||
for (i in seq_len(length(x))) {
|
||||
|
||||
10
R/mic.R
10
R/mic.R
@ -235,9 +235,15 @@ barplot.mic <- function(height,
|
||||
axis(2, seq(0, max(table(droplevels.factor(height)))))
|
||||
}
|
||||
|
||||
#' @importFrom pillar type_sum
|
||||
#' @importFrom vctrs vec_ptype_abbr
|
||||
#' @export
|
||||
type_sum.mic <- function(x) {
|
||||
vec_ptype_abbr.mic <- function(x, ...) {
|
||||
"mic"
|
||||
}
|
||||
|
||||
#' @importFrom vctrs vec_ptype_full
|
||||
#' @export
|
||||
vec_ptype_full.mic <- function(x, ...) {
|
||||
"mic"
|
||||
}
|
||||
|
||||
|
||||
48
R/mo.R
48
R/mo.R
@ -78,9 +78,9 @@
|
||||
#' - Uncertainty level 3: allow all of level 1 and 2, strip off text elements from the end, allow any part of a taxonomic name.
|
||||
#'
|
||||
#' This leads to e.g.:
|
||||
#' - `"Streptococcus group B (known as S. agalactiae)"`. The text between brackets will be removed and a warning will be thrown that the result *Streptococcus group B* (`B_STRPT_GRPB`) needs review.
|
||||
#' - `"S. aureus - please mind: MRSA"`. The last word will be stripped, after which the function will try to find a match. If it does not, the second last word will be stripped, etc. Again, a warning will be thrown that the result *Staphylococcus aureus* (`B_STPHY_AURS`) needs review.
|
||||
#' - `"Fluoroquinolone-resistant Neisseria gonorrhoeae"`. The first word will be stripped, after which the function will try to find a match. A warning will be thrown that the result *Neisseria gonorrhoeae* (`B_NESSR_GNRR`) needs review.
|
||||
#' - `"Streptococcus group B (known as S. agalactiae)"`. The text between brackets will be removed and a warning will be thrown that the result *Streptococcus group B* (``r as.mo("Streptococcus group B")``) needs review.
|
||||
#' - `"S. aureus - please mind: MRSA"`. The last word will be stripped, after which the function will try to find a match. If it does not, the second last word will be stripped, etc. Again, a warning will be thrown that the result *Staphylococcus aureus* (``r as.mo("Staphylococcus aureus")``) needs review.
|
||||
#' - `"Fluoroquinolone-resistant Neisseria gonorrhoeae"`. The first word will be stripped, after which the function will try to find a match. A warning will be thrown that the result *Neisseria gonorrhoeae* (``r as.mo("Neisseria gonorrhoeae")``) needs review.
|
||||
#'
|
||||
#' The level of uncertainty can be set using the argument `allow_uncertain`. The default is `allow_uncertain = TRUE`, which is equal to uncertainty level 2. Using `allow_uncertain = FALSE` is equal to uncertainty level 0 and will skip all rules. You can also use e.g. `as.mo(..., allow_uncertain = 1)` to only allow up to level 1 uncertainty.
|
||||
#'
|
||||
@ -234,7 +234,7 @@ is.mo <- function(x) {
|
||||
inherits(x, "mo")
|
||||
}
|
||||
|
||||
#' @importFrom dplyr %>% pull left_join n_distinct progress_estimated filter distinct
|
||||
#' @importFrom dplyr %>% pull left_join n_distinct filter distinct
|
||||
#' @importFrom data.table data.table as.data.table setkey
|
||||
#' @importFrom crayon magenta red blue silver italic
|
||||
#' @importFrom cleaner percentage
|
||||
@ -1675,12 +1675,48 @@ print.mo <- function(x, ...) {
|
||||
print.default(x, quote = FALSE)
|
||||
}
|
||||
|
||||
#' @importFrom pillar type_sum
|
||||
#' @importFrom vctrs vec_ptype_abbr
|
||||
#' @export
|
||||
type_sum.mo <- function(x) {
|
||||
vec_ptype_abbr.mo <- function(x, ...) {
|
||||
"mo"
|
||||
}
|
||||
|
||||
#' @importFrom vctrs vec_ptype_full
|
||||
#' @export
|
||||
vec_ptype_full.mo <- function(x, ...) {
|
||||
"mo"
|
||||
}
|
||||
|
||||
#' @importFrom vctrs vec_ptype2
|
||||
#' @export
|
||||
vec_ptype2.mo <- function(x, y, ...) {
|
||||
vctrs::vec_ptype2(x = as.character(x), y = as.character(y), ...)
|
||||
}
|
||||
|
||||
#' @importFrom vctrs vec_cast
|
||||
#' @export
|
||||
vec_cast.mo <- function(x, to, ...) {
|
||||
as.mo(vctrs::vec_cast(x = as.character(x), to = as.character(to), ...))
|
||||
}
|
||||
|
||||
#' @importFrom vctrs vec_cast
|
||||
#' @export
|
||||
vec_cast.mo.mo <- function(x, to, ...) {
|
||||
as.mo(vctrs::vec_cast(x = as.character(x), to = as.character(to), ...))
|
||||
}
|
||||
|
||||
#' @importFrom vctrs vec_cast
|
||||
#' @export
|
||||
vec_cast.mo.character <- function(x, to, ...) {
|
||||
vctrs::vec_cast(x = as.character(x), to = as.character(to), ...)
|
||||
}
|
||||
|
||||
#' @importFrom vctrs vec_cast
|
||||
#' @export
|
||||
vec_cast.character.mo <- function(x, to, ...) {
|
||||
as.mo(vctrs::vec_cast(x = as.character(x), to = as.character(to), ...))
|
||||
}
|
||||
|
||||
#' @importFrom pillar pillar_shaft
|
||||
#' @export
|
||||
pillar_shaft.mo <- function(x, ...) {
|
||||
|
||||
2
R/pca.R
2
R/pca.R
@ -22,7 +22,7 @@
|
||||
#' Principal Component Analysis (for AMR)
|
||||
#'
|
||||
#' Performs a principal component analysis (PCA) based on a data set with automatic determination for afterwards plotting the groups and labels, and automatic filtering on only suitable (i.e. non-empty and numeric) variables.
|
||||
#' @inheritSection lifecycle Experimental lifecycle
|
||||
#' @inheritSection lifecycle Maturing lifecycle
|
||||
#' @param x a [data.frame] containing numeric columns
|
||||
#' @param ... columns of `x` to be selected for PCA
|
||||
#' @inheritParams stats::prcomp
|
||||
|
||||
142
R/progress_estimated.R
Normal file
142
R/progress_estimated.R
Normal file
@ -0,0 +1,142 @@
|
||||
# ==================================================================== #
|
||||
# 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. #
|
||||
# ==================================================================== #
|
||||
|
||||
# taken from https://github.com/tidyverse/dplyr/blob/f306d8da8f27c2e6abbd3c70f219fef7ca61fbb5/R/progress.R
|
||||
# when it was still in the dplyr package
|
||||
|
||||
progress_estimated <- function(n, min_time = 0) {
|
||||
Progress$new(n, min_time = min_time)
|
||||
}
|
||||
|
||||
#' @importFrom R6 R6Class
|
||||
Progress <- R6::R6Class("Progress",
|
||||
public = list(
|
||||
n = NULL,
|
||||
i = 0,
|
||||
init_time = NULL,
|
||||
stopped = FALSE,
|
||||
stop_time = NULL,
|
||||
min_time = NULL,
|
||||
last_update = NULL,
|
||||
|
||||
initialize = function(n, min_time = 0, ...) {
|
||||
self$n <- n
|
||||
self$min_time <- min_time
|
||||
self$begin()
|
||||
},
|
||||
|
||||
begin = function() {
|
||||
"Initialise timer. Call this before beginning timing."
|
||||
self$i <- 0
|
||||
self$last_update <- self$init_time <- now()
|
||||
self$stopped <- FALSE
|
||||
self
|
||||
},
|
||||
|
||||
pause = function(x) {
|
||||
"Sleep for x seconds. Useful for testing."
|
||||
Sys.sleep(x)
|
||||
self
|
||||
},
|
||||
|
||||
width = function() {
|
||||
getOption("width") - nchar("|100% ~ 99.9 h remaining") - 2
|
||||
},
|
||||
|
||||
tick = function() {
|
||||
"Process one element"
|
||||
if (self$stopped) return(self)
|
||||
|
||||
if (self$i == self$n) stop("No more ticks")
|
||||
self$i <- self$i + 1
|
||||
self
|
||||
},
|
||||
|
||||
stop = function() {
|
||||
if (self$stopped) return(self)
|
||||
|
||||
self$stopped <- TRUE
|
||||
self$stop_time <- now()
|
||||
self
|
||||
},
|
||||
|
||||
print = function(...) {
|
||||
if (!isTRUE(getOption("dplyr.show_progress")) || # user sepecifies no progress
|
||||
!interactive() || # not an interactive session
|
||||
!is.null(getOption("knitr.in.progress"))) { # dplyr used within knitr document
|
||||
return(invisible(self))
|
||||
}
|
||||
|
||||
now_ <- now()
|
||||
if (now_ - self$init_time < self$min_time || now_ - self$last_update < 0.05) {
|
||||
return(invisible(self))
|
||||
}
|
||||
self$last_update <- now_
|
||||
|
||||
if (self$stopped) {
|
||||
overall <- show_time(self$stop_time - self$init_time)
|
||||
if (self$i == self$n) {
|
||||
cat_line("Completed after ", overall)
|
||||
cat("\n")
|
||||
} else {
|
||||
cat_line("Killed after ", overall)
|
||||
cat("\n")
|
||||
}
|
||||
return(invisible(self))
|
||||
}
|
||||
|
||||
avg <- (now() - self$init_time) / self$i
|
||||
time_left <- (self$n - self$i) * avg
|
||||
nbars <- trunc(self$i / self$n * self$width())
|
||||
|
||||
cat_line(
|
||||
"|", str_rep("=", nbars), str_rep(" ", self$width() - nbars), "|",
|
||||
format(round(self$i / self$n * 100), width = 3), "% ",
|
||||
"~", show_time(time_left), " remaining"
|
||||
)
|
||||
|
||||
invisible(self)
|
||||
}
|
||||
)
|
||||
)
|
||||
|
||||
cat_line <- function(...) {
|
||||
msg <- paste(..., sep = "", collapse = "")
|
||||
gap <- max(c(0, getOption("width") - nchar(msg, "width")))
|
||||
cat("\r", msg, rep.int(" ", gap), sep = "")
|
||||
utils::flush.console()
|
||||
}
|
||||
|
||||
str_rep <- function(x, i) {
|
||||
paste(rep.int(x, i), collapse = "")
|
||||
}
|
||||
|
||||
show_time <- function(x) {
|
||||
if (x < 60) {
|
||||
paste(round(x), "s")
|
||||
} else if (x < 60 * 60) {
|
||||
paste(round(x / 60), "m")
|
||||
} else {
|
||||
paste(round(x / (60 * 60)), "h")
|
||||
}
|
||||
}
|
||||
|
||||
now <- function() proc.time()[[3]]
|
||||
10
R/rsi.R
10
R/rsi.R
@ -659,9 +659,15 @@ barplot.rsi <- function(height,
|
||||
}
|
||||
}
|
||||
|
||||
#' @importFrom pillar type_sum
|
||||
#' @importFrom vctrs vec_ptype_abbr
|
||||
#' @export
|
||||
type_sum.rsi <- function(x) {
|
||||
vec_ptype_abbr.rsi <- function(x, ...) {
|
||||
"rsi"
|
||||
}
|
||||
|
||||
#' @importFrom vctrs vec_ptype_full
|
||||
#' @export
|
||||
vec_ptype_full.rsi <- function(x, ...) {
|
||||
"rsi"
|
||||
}
|
||||
|
||||
|
||||
BIN
R/sysdata.rda
BIN
R/sysdata.rda
Binary file not shown.
Reference in New Issue
Block a user