mirror of
https://github.com/msberends/AMR.git
synced 2025-07-08 11:51:59 +02:00
(v1.1.0.9011) lose dependencies
This commit is contained in:
@ -338,12 +338,6 @@ font_stripstyle <- function(x) {
|
||||
}
|
||||
|
||||
progress_estimated <- function(n = 1, n_min = 0, ...) {
|
||||
# initiate with:
|
||||
# progress <- progressbar(n)
|
||||
# on.exit(close(progress))
|
||||
#
|
||||
# update with:
|
||||
# progress$tick()
|
||||
if (n >= n_min) {
|
||||
pb <- utils::txtProgressBar(max = n, style = 3)
|
||||
pb$tick <- function() {
|
||||
@ -431,3 +425,29 @@ percentage <- function(x, digits = NULL, ...) {
|
||||
class = c("percentage", "numeric")),
|
||||
digits = digits, ...)
|
||||
}
|
||||
|
||||
# prevent dependency on package 'backports'
|
||||
strrep = function(x, times) {
|
||||
x = as.character(x)
|
||||
if (length(x) == 0L)
|
||||
return(x)
|
||||
unlist(.mapply(function(x, times) {
|
||||
if (is.na(x) || is.na(times))
|
||||
return(NA_character_)
|
||||
if (times <= 0L)
|
||||
return("")
|
||||
paste0(replicate(times, x), collapse = "")
|
||||
}, list(x = x, times = times), MoreArgs = list()), use.names = FALSE)
|
||||
}
|
||||
trimws <- function (x, which = c("both", "left", "right")) {
|
||||
which = match.arg(which)
|
||||
mysub = function(re, x) sub(re, "", x, perl = TRUE)
|
||||
if (which == "left")
|
||||
return(mysub("^[ \t\r\n]+", x))
|
||||
if (which == "right")
|
||||
return(mysub("[ \t\r\n]+$", x))
|
||||
mysub("[ \t\r\n]+$", mysub("^[ \t\r\n]+", x))
|
||||
}
|
||||
isFALSE <- function (x) {
|
||||
is.logical(x) && length(x) == 1L && !is.na(x) && !x
|
||||
}
|
||||
|
||||
@ -129,7 +129,8 @@ atc_online_property <- function(atc_code,
|
||||
}
|
||||
|
||||
progress <- progress_estimated(n = length(atc_code))
|
||||
|
||||
on.exit(close(progress))
|
||||
|
||||
for (i in seq_len(length(atc_code))) {
|
||||
|
||||
progress$tick()
|
||||
|
||||
@ -32,7 +32,6 @@
|
||||
#' @param ... arguments passed on to `FUN`
|
||||
#' @inheritParams rsi_df
|
||||
#' @inheritParams base::formatC
|
||||
#' @importFrom tidyr pivot_longer
|
||||
#' @details The function [format()] calculates the resistance per bug-drug combination. Use `combine_IR = FALSE` (default) to test R vs. S+I and `combine_IR = TRUE` to test R+I vs. S.
|
||||
#'
|
||||
#' The language of the output can be overwritten with `options(AMR_locale)`, please see [translate].
|
||||
@ -73,28 +72,41 @@ bug_drug_combinations <- function(x,
|
||||
stop("`col_mo` must be set.", call. = FALSE)
|
||||
}
|
||||
|
||||
select_rsi <- function(.data) {
|
||||
.data[, c(col_mo, names(which(sapply(.data, is.rsi))))]
|
||||
x <- as.data.frame(x, stringsAsFactors = FALSE)
|
||||
x[, col_mo] <- FUN(x[, col_mo, drop = TRUE])
|
||||
x <- x[, c(col_mo, names(which(sapply(x, is.rsi))))]
|
||||
|
||||
unique_mo <- sort(unique(x[, col_mo, drop = TRUE]))
|
||||
|
||||
out <- data.frame(
|
||||
mo = character(0),
|
||||
ab = character(0),
|
||||
S = integer(0),
|
||||
I = integer(0),
|
||||
R = integer(0),
|
||||
total = integer(0))
|
||||
|
||||
for (i in seq_len(length(unique_mo))) {
|
||||
# filter on MO group and only select R/SI columns
|
||||
x_mo_filter <- x[which(x[, col_mo, drop = TRUE] == unique_mo[i]), names(which(sapply(x, is.rsi)))]
|
||||
# turn and merge everything
|
||||
pivot <- lapply(x_mo_filter, function(x) {
|
||||
m <- as.matrix(table(x))
|
||||
data.frame(S = m["S", ], I = m["I", ], R = m["R", ], stringsAsFactors = FALSE)
|
||||
})
|
||||
merged <- do.call(rbind, pivot)
|
||||
out_group <- data.frame(mo = unique_mo[i],
|
||||
ab = rownames(merged),
|
||||
S = merged$S,
|
||||
I = merged$I,
|
||||
R = merged$R,
|
||||
total = merged$S + merged$I + merged$R)
|
||||
out <- rbind(out, out_group)
|
||||
}
|
||||
|
||||
x <- x %>% as.data.frame(stringsAsFactors = FALSE)
|
||||
x$mo <- FUN(x[, col_mo, drop = TRUE])
|
||||
|
||||
x <- x %>%
|
||||
select_rsi() %>%
|
||||
pivot_longer(-mo, names_to = "ab") %>%
|
||||
group_by(mo, ab) %>%
|
||||
summarise(S = sum(value == "S", na.rm = TRUE),
|
||||
I = sum(value == "I", na.rm = TRUE),
|
||||
R = sum(value == "R", na.rm = TRUE)) %>%
|
||||
ungroup() %>%
|
||||
mutate(total = S + I + R) %>%
|
||||
as.data.frame(stringsAsFactors = FALSE)
|
||||
|
||||
structure(.Data = x, class = c("bug_drug_combinations", class(x)))
|
||||
structure(.Data = out, class = c("bug_drug_combinations", class(x)))
|
||||
}
|
||||
|
||||
#' @importFrom tidyr pivot_wider
|
||||
#' @exportMethod format.bug_drug_combinations
|
||||
#' @export
|
||||
#' @rdname bug_drug_combinations
|
||||
@ -109,10 +121,10 @@ format.bug_drug_combinations <- function(x,
|
||||
decimal.mark = getOption("OutDec"),
|
||||
big.mark = ifelse(decimal.mark == ",", ".", ","),
|
||||
...) {
|
||||
x <- x %>% subset(total >= minimum)
|
||||
x <- subset(x, total >= minimum)
|
||||
|
||||
if (remove_intrinsic_resistant == TRUE) {
|
||||
x <- x %>% subset(R != total)
|
||||
x <- subset(x, R != total)
|
||||
}
|
||||
if (combine_SI == TRUE | combine_IR == FALSE) {
|
||||
x$isolates <- x$R
|
||||
@ -137,7 +149,10 @@ format.bug_drug_combinations <- function(x,
|
||||
}
|
||||
|
||||
remove_NAs <- function(.data) {
|
||||
as.data.frame(sapply(.data, function(x) ifelse(is.na(x), "", x), simplify = FALSE))
|
||||
cols <- colnames(.data)
|
||||
.data <- as.data.frame(sapply(.data, function(x) ifelse(is.na(x), "", x), simplify = FALSE))
|
||||
colnames(.data) <- cols
|
||||
.data
|
||||
}
|
||||
|
||||
create_var <- function(.data, ...) {
|
||||
@ -161,14 +176,26 @@ format.bug_drug_combinations <- function(x,
|
||||
" (", trimws(format(y$isolates, big.mark = big.mark)), "/",
|
||||
trimws(format(y$total, big.mark = big.mark)), ")")) %>%
|
||||
select(ab, ab_txt, mo, txt) %>%
|
||||
arrange(mo) %>%
|
||||
pivot_wider(names_from = mo, values_from = txt) %>%
|
||||
arrange(mo)
|
||||
|
||||
# replace tidyr::pivot_wider() from here
|
||||
for (i in unique(y$mo)) {
|
||||
mo_group <- y[which(y$mo == i), c("ab", "txt")]
|
||||
colnames(mo_group) <- c("ab", i)
|
||||
rownames(mo_group) <- NULL
|
||||
y <- y %>%
|
||||
left_join(mo_group, by = "ab")
|
||||
}
|
||||
y <- y %>%
|
||||
distinct(ab, .keep_all = TRUE) %>%
|
||||
select(-mo, -txt) %>%
|
||||
# replace tidyr::pivot_wider() until here
|
||||
remove_NAs()
|
||||
|
||||
select_ab_vars <- function(.data) {
|
||||
.data[, c("ab_group", "ab_txt", colnames(.data)[!colnames(.data) %in% c("ab_group", "ab_txt", "ab")])]
|
||||
}
|
||||
|
||||
|
||||
y <- y %>%
|
||||
create_var(ab_group = ab_group(y$ab, language = language)) %>%
|
||||
select_ab_vars() %>%
|
||||
@ -177,13 +204,17 @@ format.bug_drug_combinations <- function(x,
|
||||
create_var(ab_group = ifelse(y$ab_group != lag(y$ab_group) | is.na(lag(y$ab_group)), y$ab_group, ""))
|
||||
|
||||
if (add_ab_group == FALSE) {
|
||||
y <- y %>% select(-ab_group) %>% rename("Drug" = ab_txt)
|
||||
y <- y %>%
|
||||
select(-ab_group) %>%
|
||||
rename("Drug" = ab_txt)
|
||||
colnames(y)[1] <- translate_AMR(colnames(y)[1], language = get_locale(), only_unknown = FALSE)
|
||||
} else {
|
||||
y <- y %>% rename("Group" = ab_group,
|
||||
"Drug" = ab_txt)
|
||||
colnames(y)[1:2] <- translate_AMR(colnames(y)[1:2], language = get_locale(), only_unknown = FALSE)
|
||||
}
|
||||
|
||||
rownames(y) <- NULL
|
||||
y
|
||||
}
|
||||
|
||||
|
||||
@ -45,7 +45,7 @@ rsi_calc <- function(...,
|
||||
stop("`only_all_tested` must be logical", call. = FALSE)
|
||||
}
|
||||
|
||||
dots_df <- ...elt(1) # it needs this evaluation
|
||||
dots_df <- switch(1, ...) # it needs this evaluation
|
||||
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)
|
||||
|
||||
10
R/zzz.R
10
R/zzz.R
@ -20,9 +20,6 @@
|
||||
# ==================================================================== #
|
||||
|
||||
.onLoad <- function(libname, pkgname) {
|
||||
# get new functions not available in older versions of R
|
||||
backports::import(pkgname)
|
||||
|
||||
assign(x = "MO_lookup",
|
||||
value = create_MO_lookup(),
|
||||
envir = asNamespace("AMR"))
|
||||
@ -34,7 +31,6 @@
|
||||
assign(x = "mo_codes_v0.5.0",
|
||||
value = make_trans_tbl(),
|
||||
envir = asNamespace("AMR"))
|
||||
|
||||
}
|
||||
|
||||
# maybe add survey later: "https://www.surveymonkey.com/r/AMR_for_R"
|
||||
@ -55,13 +51,13 @@ create_MO_lookup <- function() {
|
||||
MO_lookup$subspecies)))
|
||||
MO_lookup[MO_lookup$genus == "" | grepl("^[(]unknown ", MO_lookup$fullname), "fullname_lower"] <- tolower(trimws(MO_lookup[MO_lookup$genus == "" | grepl("^[(]unknown ", MO_lookup$fullname),
|
||||
"fullname"]))
|
||||
MO_lookup$fullname_lower <- gsub("[^.a-z0-9/ \\-]+", "",MO_lookup$fullname_lower)
|
||||
MO_lookup$fullname_lower <- gsub("[^.a-z0-9/ \\-]+", "", MO_lookup$fullname_lower)
|
||||
|
||||
# add a column with only "e coli" like combinations
|
||||
MO_lookup$g_species <- gsub("^([a-z])[a-z]+ ([a-z]+) ?.*", "\\1 \\2", MO_lookup$fullname_lower)
|
||||
|
||||
# so arrange data on prevalence first, then kingdom, then full name
|
||||
MO_lookup[order(MO_lookup$prevalence, MO_lookup$kingdom_index, MO_lookup$fullname_lower),]
|
||||
MO_lookup[order(MO_lookup$prevalence, MO_lookup$kingdom_index, MO_lookup$fullname_lower), ]
|
||||
}
|
||||
|
||||
create_MO.old_lookup <- function() {
|
||||
@ -75,7 +71,7 @@ create_MO.old_lookup <- function() {
|
||||
MO.old_lookup$g_species <- gsub("^([a-z])[a-z]+ ([a-z]+) ?.*", "\\1 \\2", MO.old_lookup$fullname_lower)
|
||||
|
||||
# so arrange data on prevalence first, then full name
|
||||
MO.old_lookup[order(MO.old_lookup$prevalence, MO.old_lookup$fullname_lower),]
|
||||
MO.old_lookup[order(MO.old_lookup$prevalence, MO.old_lookup$fullname_lower), ]
|
||||
}
|
||||
|
||||
make_trans_tbl <- function() {
|
||||
|
||||
Reference in New Issue
Block a user