mirror of
https://github.com/msberends/AMR.git
synced 2024-12-25 06:46:11 +01:00
(v1.2.0.9034) code cleaning
This commit is contained in:
parent
c0cf7ab02b
commit
6ab468362d
@ -1,6 +1,6 @@
|
||||
Package: AMR
|
||||
Version: 1.2.0.9033
|
||||
Date: 2020-07-12
|
||||
Version: 1.2.0.9034
|
||||
Date: 2020-07-13
|
||||
Title: Antimicrobial Resistance Analysis
|
||||
Authors@R: c(
|
||||
person(role = c("aut", "cre"),
|
||||
|
||||
4
NEWS.md
4
NEWS.md
@ -1,5 +1,5 @@
|
||||
# AMR 1.2.0.9033
|
||||
## <small>Last updated: 12-Jul-2020</small>
|
||||
# AMR 1.2.0.9034
|
||||
## <small>Last updated: 13-Jul-2020</small>
|
||||
|
||||
### New
|
||||
* Function `ab_from_text()` to retrieve antimicrobial drug names, doses and forms of administration from clinical texts in e.g. health care records, which also corrects for misspelling since it uses `as.ab()` internally
|
||||
|
||||
@ -493,7 +493,7 @@ percentage <- function(x, digits = NULL, ...) {
|
||||
x_formatted[!grepl(pattern = "^[0-9.,e-]+$", x = x)] <- NA_character_
|
||||
x_formatted
|
||||
}
|
||||
|
||||
|
||||
# the actual working part
|
||||
x <- as.double(x)
|
||||
if (is.null(digits)) {
|
||||
|
||||
40
R/ab.R
40
R/ab.R
@ -82,16 +82,16 @@ as.ab <- function(x, flag_multiple_results = TRUE, ...) {
|
||||
if (is.ab(x)) {
|
||||
return(x)
|
||||
}
|
||||
|
||||
|
||||
initial_search <- is.null(list(...)$initial_search)
|
||||
already_regex <- isTRUE(list(...)$already_regex)
|
||||
|
||||
|
||||
if (all(toupper(x) %in% antibiotics$ab)) {
|
||||
# valid AB code, but not yet right class
|
||||
return(structure(.Data = toupper(x),
|
||||
class = c("ab", "character")))
|
||||
}
|
||||
|
||||
|
||||
x_bak <- x
|
||||
x <- toupper(x)
|
||||
# remove diacritics
|
||||
@ -117,7 +117,7 @@ as.ab <- function(x, flag_multiple_results = TRUE, ...) {
|
||||
# replace text 'and' with a slash
|
||||
x_bak_clean <- gsub(" AND ", "/", x_bak_clean)
|
||||
}
|
||||
|
||||
|
||||
x <- unique(x_bak_clean)
|
||||
x_new <- rep(NA_character_, length(x))
|
||||
x_unknown <- character(0)
|
||||
@ -164,21 +164,21 @@ as.ab <- function(x, flag_multiple_results = TRUE, ...) {
|
||||
x_new[i] <- note_if_more_than_one_found(found, i, from_text)
|
||||
next
|
||||
}
|
||||
|
||||
|
||||
# exact ATC code
|
||||
found <- antibiotics[which(antibiotics$atc == x[i]), ]$ab
|
||||
if (length(found) > 0) {
|
||||
x_new[i] <- note_if_more_than_one_found(found, i, from_text)
|
||||
next
|
||||
}
|
||||
|
||||
|
||||
# exact CID code
|
||||
found <- antibiotics[which(antibiotics$cid == x[i]), ]$ab
|
||||
if (length(found) > 0) {
|
||||
x_new[i] <- note_if_more_than_one_found(found, i, from_text)
|
||||
next
|
||||
}
|
||||
|
||||
|
||||
# exact name
|
||||
found <- antibiotics[which(toupper(antibiotics$name) == x[i]), ]$ab
|
||||
if (length(found) > 0) {
|
||||
@ -188,13 +188,13 @@ as.ab <- function(x, flag_multiple_results = TRUE, ...) {
|
||||
|
||||
# exact LOINC code
|
||||
loinc_found <- unlist(lapply(antibiotics$loinc,
|
||||
function(s) x[i] %in% s))
|
||||
function(s) x[i] %in% s))
|
||||
found <- antibiotics$ab[loinc_found == TRUE]
|
||||
if (length(found) > 0) {
|
||||
x_new[i] <- note_if_more_than_one_found(found, i, from_text)
|
||||
next
|
||||
}
|
||||
|
||||
|
||||
# exact synonym
|
||||
synonym_found <- unlist(lapply(antibiotics$synonyms,
|
||||
function(s) x[i] %in% toupper(s)))
|
||||
@ -203,7 +203,7 @@ as.ab <- function(x, flag_multiple_results = TRUE, ...) {
|
||||
x_new[i] <- note_if_more_than_one_found(found, i, from_text)
|
||||
next
|
||||
}
|
||||
|
||||
|
||||
# exact abbreviation
|
||||
abbr_found <- unlist(lapply(antibiotics$abbreviations,
|
||||
function(a) x[i] %in% toupper(a)))
|
||||
@ -212,7 +212,7 @@ as.ab <- function(x, flag_multiple_results = TRUE, ...) {
|
||||
x_new[i] <- note_if_more_than_one_found(found, i, from_text)
|
||||
next
|
||||
}
|
||||
|
||||
|
||||
# allow characters that resemble others, but only continue when having more than 3 characters
|
||||
if (nchar(x[i]) <= 3) {
|
||||
x_unknown <- c(x_unknown, x_bak[x[i] == x_bak_clean][1])
|
||||
@ -242,7 +242,7 @@ as.ab <- function(x, flag_multiple_results = TRUE, ...) {
|
||||
x_spelling <- gsub("(O|0)", "(O|0)+", x_spelling)
|
||||
x_spelling <- gsub("++", "+", x_spelling, fixed = TRUE)
|
||||
}
|
||||
|
||||
|
||||
# try if name starts with it
|
||||
found <- antibiotics[which(antibiotics$name %like% paste0("^", x_spelling)), ]$ab
|
||||
if (length(found) > 0) {
|
||||
@ -255,7 +255,7 @@ as.ab <- function(x, flag_multiple_results = TRUE, ...) {
|
||||
x_new[i] <- note_if_more_than_one_found(found, i, from_text)
|
||||
next
|
||||
}
|
||||
|
||||
|
||||
# and try if any synonym starts with it
|
||||
synonym_found <- unlist(lapply(antibiotics$synonyms,
|
||||
function(s) any(s %like% paste0("^", x_spelling))))
|
||||
@ -264,7 +264,7 @@ as.ab <- function(x, flag_multiple_results = TRUE, ...) {
|
||||
x_new[i] <- note_if_more_than_one_found(found, i, from_text)
|
||||
next
|
||||
}
|
||||
|
||||
|
||||
# INITIAL SEARCH - More uncertain results ----
|
||||
|
||||
if (initial_search == TRUE) {
|
||||
@ -351,7 +351,7 @@ as.ab <- function(x, flag_multiple_results = TRUE, ...) {
|
||||
x_new[i] <- note_if_more_than_one_found(found, i, from_text)
|
||||
next
|
||||
}
|
||||
|
||||
|
||||
# first 5 except for cephalosporins, then first 7 (those cephalosporins all start quite the same!)
|
||||
found <- suppressWarnings(as.ab(substr(x[i], 1, 5), initial_search = FALSE))
|
||||
if (!is.na(found) && !ab_group(found, initial_search = FALSE) %like% "cephalosporins") {
|
||||
@ -375,7 +375,7 @@ as.ab <- function(x, flag_multiple_results = TRUE, ...) {
|
||||
x_new[i] <- note_if_more_than_one_found(found, i, from_text)
|
||||
next
|
||||
}
|
||||
|
||||
|
||||
# make all vowels facultative
|
||||
search_str <- gsub("([AEIOUY])", "\\1*", x[i])
|
||||
found <- suppressWarnings(as.ab(search_str, initial_search = FALSE, already_regex = TRUE))
|
||||
@ -429,7 +429,7 @@ as.ab <- function(x, flag_multiple_results = TRUE, ...) {
|
||||
if (initial_search == TRUE) {
|
||||
close(progress)
|
||||
}
|
||||
|
||||
|
||||
# take failed ATC codes apart from rest
|
||||
x_unknown_ATCs <- x_unknown[x_unknown %like% "[A-Z][0-9][0-9][A-Z][A-Z][0-9][0-9]"]
|
||||
x_unknown <- x_unknown[!x_unknown %in% x_unknown_ATCs]
|
||||
@ -446,15 +446,15 @@ as.ab <- function(x, flag_multiple_results = TRUE, ...) {
|
||||
".",
|
||||
call. = FALSE)
|
||||
}
|
||||
|
||||
|
||||
x_result <- data.frame(x = x_bak_clean, stringsAsFactors = FALSE) %>%
|
||||
left_join(data.frame(x = x, x_new = x_new, stringsAsFactors = FALSE), by = "x") %>%
|
||||
pull(x_new)
|
||||
|
||||
|
||||
if (length(x_result) == 0) {
|
||||
x_result <- NA_character_
|
||||
}
|
||||
|
||||
|
||||
structure(.Data = x_result,
|
||||
class = c("ab", "character"))
|
||||
}
|
||||
|
||||
@ -136,8 +136,8 @@ ab_from_text <- function(text,
|
||||
text_split[text_split %like_case% to_regex(names_atc)],
|
||||
text_split[text_split %like_case% to_regex(synonyms_part1)],
|
||||
text_split[text_split %like_case% to_regex(synonyms_part2)])
|
||||
),
|
||||
...)
|
||||
),
|
||||
...)
|
||||
)
|
||||
})
|
||||
}
|
||||
|
||||
@ -216,7 +216,7 @@ ab_property <- function(x, property = "name", language = get_locale(), ...) {
|
||||
stop_if(length(property) != 1L, "'property' must be of length 1.")
|
||||
stop_ifnot(property %in% colnames(antibiotics),
|
||||
"invalid property: '", property, "' - use a column name of the `antibiotics` data set")
|
||||
|
||||
|
||||
translate_AMR(ab_validate(x = x, property = property, ...), language = language)
|
||||
}
|
||||
|
||||
|
||||
18
R/age.R
18
R/age.R
@ -47,13 +47,13 @@ age <- function(x, reference = Sys.Date(), exact = FALSE, na.rm = FALSE) {
|
||||
}
|
||||
x <- as.POSIXlt(x)
|
||||
reference <- as.POSIXlt(reference)
|
||||
|
||||
|
||||
# from https://stackoverflow.com/a/25450756/4575331
|
||||
years_gap <- reference$year - x$year
|
||||
ages <- ifelse(reference$mon < x$mon | (reference$mon == x$mon & reference$mday < x$mday),
|
||||
as.integer(years_gap - 1),
|
||||
as.integer(years_gap))
|
||||
|
||||
as.integer(years_gap - 1),
|
||||
as.integer(years_gap))
|
||||
|
||||
# add decimals
|
||||
if (exact == TRUE) {
|
||||
# get dates of `x` when `x` would have the year of `reference`
|
||||
@ -69,7 +69,7 @@ age <- function(x, reference = Sys.Date(), exact = FALSE, na.rm = FALSE) {
|
||||
# and finally add to ages
|
||||
ages <- ages + mod
|
||||
}
|
||||
|
||||
|
||||
if (any(ages < 0, na.rm = TRUE)) {
|
||||
ages[ages < 0] <- NA
|
||||
warning("NAs introduced for ages below 0.")
|
||||
@ -81,7 +81,7 @@ age <- function(x, reference = Sys.Date(), exact = FALSE, na.rm = FALSE) {
|
||||
if (isTRUE(na.rm)) {
|
||||
ages <- ages[!is.na(ages)]
|
||||
}
|
||||
|
||||
|
||||
ages
|
||||
}
|
||||
|
||||
@ -162,7 +162,7 @@ age_groups <- function(x, split_at = c(12, 25, 55, 75), na.rm = FALSE) {
|
||||
}
|
||||
split_at <- split_at[!is.na(split_at)]
|
||||
stop_if(length(split_at) == 1, "invalid value for `split_at`") # only 0 is available
|
||||
|
||||
|
||||
# turn input values to 'split_at' indices
|
||||
y <- x
|
||||
labs <- split_at
|
||||
@ -171,10 +171,10 @@ age_groups <- function(x, split_at = c(12, 25, 55, 75), na.rm = FALSE) {
|
||||
# create labels
|
||||
labs[i - 1] <- paste0(unique(c(split_at[i - 1], split_at[i] - 1)), collapse = "-")
|
||||
}
|
||||
|
||||
|
||||
# last category
|
||||
labs[length(labs)] <- paste0(split_at[length(split_at)], "+")
|
||||
|
||||
|
||||
agegroups <- factor(labs[y], levels = labs, ordered = TRUE)
|
||||
|
||||
if (isTRUE(na.rm)) {
|
||||
|
||||
@ -84,7 +84,7 @@ atc_online_property <- function(atc_code,
|
||||
html_table <- import_fn("html_table", "rvest")
|
||||
html_text <- import_fn("html_text", "rvest")
|
||||
read_html <- import_fn("read_html", "xml2")
|
||||
|
||||
|
||||
check_dataset_integrity()
|
||||
|
||||
if (!all(atc_code %in% antibiotics)) {
|
||||
@ -95,25 +95,25 @@ atc_online_property <- function(atc_code,
|
||||
message("There appears to be no internet connection.")
|
||||
return(rep(NA, length(atc_code)))
|
||||
}
|
||||
|
||||
|
||||
stop_if(length(property) != 1L, "`property` must be of length 1")
|
||||
stop_if(length(administration) != 1L, "`administration` must be of length 1")
|
||||
|
||||
|
||||
# also allow unit as property
|
||||
if (property %like% "unit") {
|
||||
property <- "U"
|
||||
}
|
||||
|
||||
|
||||
# validation of properties
|
||||
valid_properties <- c("ATC", "Name", "DDD", "U", "Adm.R", "Note", "groups")
|
||||
valid_properties.bak <- valid_properties
|
||||
|
||||
|
||||
property <- tolower(property)
|
||||
valid_properties <- tolower(valid_properties)
|
||||
|
||||
|
||||
stop_ifnot(property %in% valid_properties,
|
||||
"Invalid `property`, use one of ", paste(valid_properties.bak, collapse = ", "))
|
||||
|
||||
|
||||
if (property == "ddd") {
|
||||
returnvalue <- rep(NA_real_, length(atc_code))
|
||||
} else if (property == "groups") {
|
||||
@ -121,22 +121,22 @@ atc_online_property <- function(atc_code,
|
||||
} else {
|
||||
returnvalue <- rep(NA_character_, length(atc_code))
|
||||
}
|
||||
|
||||
|
||||
progress <- progress_estimated(n = length(atc_code), 3)
|
||||
on.exit(close(progress))
|
||||
|
||||
for (i in seq_len(length(atc_code))) {
|
||||
|
||||
|
||||
progress$tick()
|
||||
|
||||
|
||||
atc_url <- sub("%s", atc_code[i], url, fixed = TRUE)
|
||||
|
||||
|
||||
if (property == "groups") {
|
||||
tbl <- read_html(atc_url) %>%
|
||||
html_node("#content") %>%
|
||||
html_children() %>%
|
||||
html_node("a")
|
||||
|
||||
|
||||
# get URLS of items
|
||||
hrefs <- tbl %>% html_attr("href")
|
||||
# get text of items
|
||||
@ -146,22 +146,22 @@ atc_online_property <- function(atc_code,
|
||||
# last one is antibiotics, skip it
|
||||
texts <- texts[seq_len(length(texts)) - 1]
|
||||
returnvalue <- c(list(texts), returnvalue)
|
||||
|
||||
|
||||
} else {
|
||||
tbl <- read_html(atc_url) %>%
|
||||
html_nodes("table") %>%
|
||||
html_table(header = TRUE) %>%
|
||||
as.data.frame(stringsAsFactors = FALSE)
|
||||
|
||||
|
||||
# case insensitive column names
|
||||
colnames(tbl) <- gsub("^atc.*", "atc", tolower(colnames(tbl)))
|
||||
|
||||
|
||||
if (length(tbl) == 0) {
|
||||
warning("ATC not found: ", atc_code[i], ". Please check ", atc_url, ".", call. = FALSE)
|
||||
returnvalue[i] <- NA
|
||||
next
|
||||
}
|
||||
|
||||
|
||||
if (property %in% c("atc", "name")) {
|
||||
# ATC and name are only in first row
|
||||
returnvalue[i] <- tbl[1, property]
|
||||
@ -179,11 +179,11 @@ atc_online_property <- function(atc_code,
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
if (property == "groups" & length(returnvalue) == 1) {
|
||||
returnvalue <- returnvalue[[1]]
|
||||
}
|
||||
|
||||
|
||||
returnvalue
|
||||
}
|
||||
|
||||
|
||||
@ -55,7 +55,7 @@ availability <- function(tbl, width = NULL) {
|
||||
R_print <- character(length(R))
|
||||
R_print[!is.na(R)] <- percentage(R[!is.na(R)])
|
||||
R_print[is.na(R)] <- ""
|
||||
|
||||
|
||||
if (is.null(width)) {
|
||||
width <- options()$width -
|
||||
(max(nchar(colnames(tbl))) +
|
||||
@ -69,19 +69,19 @@ availability <- function(tbl, width = NULL) {
|
||||
5)
|
||||
width <- width / 2
|
||||
}
|
||||
|
||||
|
||||
if (length(R[is.na(R)]) == ncol(tbl)) {
|
||||
width <- width * 2 + 10
|
||||
}
|
||||
|
||||
|
||||
x_chars_R <- strrep("#", round(width * R, digits = 2))
|
||||
x_chars_SI <- strrep("-", width - nchar(x_chars_R))
|
||||
vis_resistance <- paste0("|", x_chars_R, x_chars_SI, "|")
|
||||
vis_resistance[is.na(R)] <- ""
|
||||
|
||||
|
||||
x_chars <- strrep("#", round(x, digits = 2) / (1 / width))
|
||||
x_chars_empty <- strrep("-", width - nchar(x_chars))
|
||||
|
||||
|
||||
df <- data.frame(count = n,
|
||||
available = percentage(x),
|
||||
visual_availabilty = paste0("|", x_chars, x_chars_empty, "|"),
|
||||
|
||||
@ -75,7 +75,7 @@ bug_drug_combinations <- function(x,
|
||||
x <- x[, c(col_mo, names(which(sapply(x, is.rsi)))), drop = FALSE]
|
||||
|
||||
unique_mo <- sort(unique(x[, col_mo, drop = TRUE]))
|
||||
|
||||
|
||||
out <- data.frame(
|
||||
mo = character(0),
|
||||
ab = character(0),
|
||||
@ -83,7 +83,7 @@ bug_drug_combinations <- function(x,
|
||||
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))), drop = FALSE]
|
||||
@ -101,7 +101,7 @@ bug_drug_combinations <- function(x,
|
||||
total = merged$S + merged$I + merged$R)
|
||||
out <- rbind(out, out_group)
|
||||
}
|
||||
|
||||
|
||||
structure(.Data = out, class = c("bug_drug_combinations", x_class))
|
||||
}
|
||||
|
||||
@ -172,11 +172,11 @@ format.bug_drug_combinations <- function(x,
|
||||
|
||||
y <- y %>%
|
||||
create_var(txt = paste0(percentage(y$isolates / y$total, decimal.mark = decimal.mark, big.mark = big.mark),
|
||||
" (", trimws(format(y$isolates, big.mark = big.mark)), "/",
|
||||
trimws(format(y$total, big.mark = big.mark)), ")")) %>%
|
||||
" (", trimws(format(y$isolates, big.mark = big.mark)), "/",
|
||||
trimws(format(y$total, big.mark = big.mark)), ")")) %>%
|
||||
select(ab, ab_txt, mo, 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")]
|
||||
@ -194,14 +194,14 @@ format.bug_drug_combinations <- function(x,
|
||||
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() %>%
|
||||
arrange(ab_group, ab_txt)
|
||||
y <- y %>%
|
||||
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) %>%
|
||||
|
||||
@ -102,7 +102,7 @@ catalogue_of_life_version <- function() {
|
||||
list(
|
||||
n_total_species = nrow(microorganisms),
|
||||
n_total_synonyms = nrow(microorganisms.old)))
|
||||
|
||||
|
||||
structure(.Data = lst,
|
||||
class = c("catalogue_of_life_version", "list"))
|
||||
}
|
||||
@ -117,7 +117,7 @@ print.catalogue_of_life_version <- function(x, ...) {
|
||||
" Available at: ", lst$catalogue_of_life$url, "\n",
|
||||
" Number of included species: ", format(lst$catalogue_of_life$n, big.mark = ","), "\n",
|
||||
font_underline(paste0(lst$deutsche_sammlung_von_mikroorganismen_und_zellkulturen$version, " (",
|
||||
lst$deutsche_sammlung_von_mikroorganismen_und_zellkulturen$yearmonth, ")")), "\n",
|
||||
lst$deutsche_sammlung_von_mikroorganismen_und_zellkulturen$yearmonth, ")")), "\n",
|
||||
" Available at: ", lst$deutsche_sammlung_von_mikroorganismen_und_zellkulturen$url, "\n",
|
||||
" Number of included species: ", format(lst$deutsche_sammlung_von_mikroorganismen_und_zellkulturen$n, big.mark = ","), "\n\n",
|
||||
"=> Total number of species included: ", format(lst$total_included$n_total_species, big.mark = ","), "\n",
|
||||
|
||||
@ -185,7 +185,7 @@ count_df <- function(data,
|
||||
language = get_locale(),
|
||||
combine_SI = TRUE,
|
||||
combine_IR = FALSE) {
|
||||
|
||||
|
||||
rsi_calc_df(type = "count",
|
||||
data = data,
|
||||
translate_ab = translate_ab,
|
||||
|
||||
8
R/disk.R
8
R/disk.R
@ -59,16 +59,16 @@ as.disk <- function(x, na.rm = FALSE) {
|
||||
x <- x[!is.na(x)]
|
||||
}
|
||||
x.bak <- x
|
||||
|
||||
|
||||
na_before <- length(x[is.na(x)])
|
||||
|
||||
|
||||
# force it to be integer
|
||||
x <- suppressWarnings(as.integer(x))
|
||||
|
||||
|
||||
# disks can never be less than 6 mm (size of smallest disk) or more than 50 mm
|
||||
x[x < 6 | x > 50] <- NA_integer_
|
||||
na_after <- length(x[is.na(x)])
|
||||
|
||||
|
||||
if (na_before != na_after) {
|
||||
list_missing <- x.bak[is.na(x) & !is.na(x.bak)] %>%
|
||||
unique() %>%
|
||||
|
||||
@ -519,7 +519,7 @@ eucast_rules <- function(x,
|
||||
left_join_microorganisms(by = col_mo, suffix = c("_oldcols", ""))
|
||||
x$gramstain <- mo_gramstain(x[, col_mo, drop = TRUE], language = NULL)
|
||||
x$genus_species <- paste(x$genus, x$species)
|
||||
|
||||
|
||||
if (ab_missing(AMP) & !ab_missing(AMX)) {
|
||||
# ampicillin column is missing, but amoxicillin is available
|
||||
message(font_blue(paste0("NOTE: Using column `", font_bold(AMX), "` as input for ampicillin (J01CA01) since many EUCAST rules depend on it.")))
|
||||
@ -702,8 +702,8 @@ eucast_rules <- function(x,
|
||||
|
||||
if (info == TRUE & !rule_group_current %like% "other" & eucast_notification_shown == FALSE) {
|
||||
cat(paste0("\n", font_grey(strrep("-", options()$width - 1)),
|
||||
"\nRules by the ", font_bold("European Committee on Antimicrobial Susceptibility Testing (EUCAST)"),
|
||||
"\n", font_blue("http://eucast.org/"), "\n"))
|
||||
"\nRules by the ", font_bold("European Committee on Antimicrobial Susceptibility Testing (EUCAST)"),
|
||||
"\n", font_blue("http://eucast.org/"), "\n"))
|
||||
eucast_notification_shown <- TRUE
|
||||
}
|
||||
|
||||
@ -843,9 +843,9 @@ eucast_rules <- function(x,
|
||||
|
||||
cat(paste0("\n", font_grey(strrep("-", options()$width - 1)), "\n"))
|
||||
cat(font_bold(paste("The rules", paste0(wouldve, "affected"),
|
||||
formatnr(n_distinct(verbose_info$row)),
|
||||
"out of", formatnr(nrow(x_original)),
|
||||
"rows, making a total of", formatnr(nrow(verbose_info)), "edits\n")))
|
||||
formatnr(n_distinct(verbose_info$row)),
|
||||
"out of", formatnr(nrow(x_original)),
|
||||
"rows, making a total of", formatnr(nrow(verbose_info)), "edits\n")))
|
||||
|
||||
n_added <- verbose_info %>% filter(is.na(old)) %>% nrow()
|
||||
n_changed <- verbose_info %>% filter(!is.na(old)) %>% nrow()
|
||||
@ -858,8 +858,8 @@ eucast_rules <- function(x,
|
||||
}
|
||||
cat(colour(paste0("=> ", wouldve, "added ",
|
||||
font_bold(formatnr(verbose_info %>%
|
||||
filter(is.na(old)) %>%
|
||||
nrow()), "test results"),
|
||||
filter(is.na(old)) %>%
|
||||
nrow()), "test results"),
|
||||
"\n")))
|
||||
if (n_added > 0) {
|
||||
added_summary <- verbose_info %>%
|
||||
@ -882,8 +882,8 @@ eucast_rules <- function(x,
|
||||
}
|
||||
cat(colour(paste0("=> ", wouldve, "changed ",
|
||||
font_bold(formatnr(verbose_info %>%
|
||||
filter(!is.na(old)) %>%
|
||||
nrow()), "test results"),
|
||||
filter(!is.na(old)) %>%
|
||||
nrow()), "test results"),
|
||||
"\n")))
|
||||
if (n_changed > 0) {
|
||||
changed_summary <- verbose_info %>%
|
||||
|
||||
@ -387,9 +387,9 @@ labels_rsi_count <- function(position = NULL,
|
||||
lineheight = 0.75,
|
||||
data = function(x) {
|
||||
transformed <- rsi_df(data = x,
|
||||
translate_ab = translate_ab,
|
||||
combine_SI = combine_SI,
|
||||
combine_IR = combine_IR)
|
||||
translate_ab = translate_ab,
|
||||
combine_SI = combine_SI,
|
||||
combine_IR = combine_IR)
|
||||
transformed$gr <- transformed[, x_name, drop = TRUE]
|
||||
transformed %>%
|
||||
group_by(gr) %>%
|
||||
|
||||
@ -63,23 +63,23 @@ guess_ab_col <- function(x = NULL, search_string = NULL, verbose = FALSE) {
|
||||
return(as.name("guess_ab_col"))
|
||||
}
|
||||
stop_ifnot(is.data.frame(x), "`x` must be a data.frame")
|
||||
|
||||
|
||||
if (length(search_string) > 1) {
|
||||
warning("argument 'search_string' has length > 1 and only the first element will be used")
|
||||
search_string <- search_string[1]
|
||||
}
|
||||
search_string <- as.character(search_string)
|
||||
|
||||
|
||||
if (search_string %in% colnames(x)) {
|
||||
ab_result <- search_string
|
||||
} else {
|
||||
search_string.ab <- suppressWarnings(as.ab(search_string))
|
||||
if (search_string.ab %in% colnames(x)) {
|
||||
ab_result <- colnames(x)[colnames(x) == search_string.ab][1L]
|
||||
|
||||
|
||||
} else if (any(tolower(colnames(x)) %in% tolower(unlist(ab_property(search_string.ab, "abbreviations", language = NULL))))) {
|
||||
ab_result <- colnames(x)[tolower(colnames(x)) %in% tolower(unlist(ab_property(search_string.ab, "abbreviations", language = NULL)))][1L]
|
||||
|
||||
|
||||
} else {
|
||||
# sort colnames on length - longest first
|
||||
cols <- colnames(x[, x %>% colnames() %>% nchar() %>% order() %>% rev()])
|
||||
@ -90,7 +90,7 @@ guess_ab_col <- function(x = NULL, search_string = NULL, verbose = FALSE) {
|
||||
ab_result <- ab_result[!is.na(ab_result)][1L]
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
if (length(ab_result) == 0) {
|
||||
if (verbose == TRUE) {
|
||||
message(paste0("No column found as input for `", search_string,
|
||||
@ -100,7 +100,7 @@ guess_ab_col <- function(x = NULL, search_string = NULL, verbose = FALSE) {
|
||||
} else {
|
||||
if (verbose == TRUE) {
|
||||
message(font_blue(paste0("NOTE: Using column `", font_bold(ab_result), "` as input for `", search_string,
|
||||
"` (", ab_name(search_string, language = NULL, tolower = TRUE), ").")))
|
||||
"` (", ab_name(search_string, language = NULL, tolower = TRUE), ").")))
|
||||
}
|
||||
return(ab_result)
|
||||
}
|
||||
@ -111,7 +111,7 @@ get_column_abx <- function(x,
|
||||
hard_dependencies = NULL,
|
||||
verbose = FALSE,
|
||||
...) {
|
||||
|
||||
|
||||
message(font_blue("NOTE: Auto-guessing columns suitable for analysis"), appendLF = FALSE)
|
||||
|
||||
x <- as.data.frame(x, stringsAsFactors = FALSE)
|
||||
@ -139,13 +139,13 @@ get_column_abx <- function(x,
|
||||
})
|
||||
x_columns <- x_columns[!is.na(x_columns)]
|
||||
x <- x[, x_columns, drop = FALSE] # without drop = TRUE, x will become a vector when x_columns is length 1
|
||||
|
||||
|
||||
df_trans <- data.frame(colnames = colnames(x),
|
||||
abcode = suppressWarnings(as.ab(colnames(x))))
|
||||
df_trans <- df_trans[!is.na(df_trans$abcode), ]
|
||||
x <- as.character(df_trans$colnames)
|
||||
names(x) <- df_trans$abcode
|
||||
|
||||
|
||||
# add from self-defined dots (...):
|
||||
# such as get_column_abx(example_isolates %>% rename(thisone = AMX), amox = "thisone")
|
||||
dots <- list(...)
|
||||
@ -164,7 +164,7 @@ get_column_abx <- function(x,
|
||||
# delete NAs, this will make e.g. eucast_rules(... TMP = NULL) work to prevent TMP from being used
|
||||
x <- x[!is.na(x)]
|
||||
}
|
||||
|
||||
|
||||
if (length(x) == 0) {
|
||||
message(font_blue("No columns found."))
|
||||
return(x)
|
||||
@ -179,16 +179,16 @@ get_column_abx <- function(x,
|
||||
|
||||
# succeeded with auto-guessing
|
||||
message(font_blue("OK."))
|
||||
|
||||
|
||||
for (i in seq_len(length(x))) {
|
||||
if (verbose == TRUE & !names(x[i]) %in% names(duplicates)) {
|
||||
message(font_blue(paste0("NOTE: Using column `", font_bold(x[i]), "` as input for `", names(x)[i],
|
||||
"` (", ab_name(names(x)[i], tolower = TRUE, language = NULL), ").")))
|
||||
"` (", ab_name(names(x)[i], tolower = TRUE, language = NULL), ").")))
|
||||
}
|
||||
if (names(x[i]) %in% names(duplicates)) {
|
||||
warning(font_red(paste0("Using column `", font_bold(x[i]), "` as input for `", names(x)[i],
|
||||
"` (", ab_name(names(x)[i], tolower = TRUE, language = NULL),
|
||||
"), although it was matched for multiple antibiotics or columns.")),
|
||||
"` (", ab_name(names(x)[i], tolower = TRUE, language = NULL),
|
||||
"), although it was matched for multiple antibiotics or columns.")),
|
||||
call. = FALSE,
|
||||
immediate. = verbose)
|
||||
}
|
||||
@ -210,8 +210,8 @@ get_column_abx <- function(x,
|
||||
# missing a soft dependency may lower the reliability
|
||||
missing <- soft_dependencies[!soft_dependencies %in% names(x)]
|
||||
missing_txt <- paste(paste0(ab_name(missing, tolower = TRUE, language = NULL),
|
||||
" (", font_bold(missing, collapse = NULL), ")"),
|
||||
collapse = ", ")
|
||||
" (", font_bold(missing, collapse = NULL), ")"),
|
||||
collapse = ", ")
|
||||
message(font_blue("NOTE: Reliability would be improved if these antimicrobial results would be available too:",
|
||||
missing_txt))
|
||||
}
|
||||
|
||||
@ -130,14 +130,14 @@ key_antibiotics <- function(x,
|
||||
warnings <- dots[which(dots.names == "info")]
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
# try to find columns based on type
|
||||
# -- mo
|
||||
if (is.null(col_mo)) {
|
||||
col_mo <- search_type_in_df(x = x, type = "mo")
|
||||
}
|
||||
stop_if(is.null(col_mo), "`col_mo` must be set")
|
||||
|
||||
|
||||
# check columns
|
||||
col.list <- c(universal_1, universal_2, universal_3, universal_4, universal_5, universal_6,
|
||||
GramPos_1, GramPos_2, GramPos_3, GramPos_4, GramPos_5, GramPos_6,
|
||||
@ -170,7 +170,7 @@ key_antibiotics <- function(x,
|
||||
}
|
||||
col.list
|
||||
}
|
||||
|
||||
|
||||
col.list <- check_available_columns(x = x, col.list = col.list, warnings = warnings)
|
||||
universal_1 <- col.list[universal_1]
|
||||
universal_2 <- col.list[universal_2]
|
||||
@ -190,28 +190,28 @@ key_antibiotics <- function(x,
|
||||
GramNeg_4 <- col.list[GramNeg_4]
|
||||
GramNeg_5 <- col.list[GramNeg_5]
|
||||
GramNeg_6 <- col.list[GramNeg_6]
|
||||
|
||||
|
||||
universal <- c(universal_1, universal_2, universal_3,
|
||||
universal_4, universal_5, universal_6)
|
||||
|
||||
|
||||
gram_positive <- c(universal,
|
||||
GramPos_1, GramPos_2, GramPos_3,
|
||||
GramPos_4, GramPos_5, GramPos_6)
|
||||
GramPos_1, GramPos_2, GramPos_3,
|
||||
GramPos_4, GramPos_5, GramPos_6)
|
||||
gram_positive <- gram_positive[!is.null(gram_positive)]
|
||||
gram_positive <- gram_positive[!is.na(gram_positive)]
|
||||
if (length(gram_positive) < 12) {
|
||||
warning("only using ", length(gram_positive), " different antibiotics as key antibiotics for Gram-positives. See ?key_antibiotics.", call. = FALSE)
|
||||
}
|
||||
|
||||
|
||||
gram_negative <- c(universal,
|
||||
GramNeg_1, GramNeg_2, GramNeg_3,
|
||||
GramNeg_4, GramNeg_5, GramNeg_6)
|
||||
GramNeg_1, GramNeg_2, GramNeg_3,
|
||||
GramNeg_4, GramNeg_5, GramNeg_6)
|
||||
gram_negative <- gram_negative[!is.null(gram_negative)]
|
||||
gram_negative <- gram_negative[!is.na(gram_negative)]
|
||||
if (length(gram_negative) < 12) {
|
||||
warning("only using ", length(gram_negative), " different antibiotics as key antibiotics for Gram-negatives. See ?key_antibiotics.", call. = FALSE)
|
||||
}
|
||||
|
||||
|
||||
x <- as.data.frame(x, stringsAsFactors = FALSE)
|
||||
x[, col_mo] <- as.mo(x[, col_mo, drop = TRUE])
|
||||
x$gramstain <- mo_gramstain(x[, col_mo, drop = TRUE], language = NULL)
|
||||
@ -232,16 +232,16 @@ key_antibiotics <- function(x,
|
||||
FUN = function(x) paste(x, collapse = "")),
|
||||
error = function(e) paste0(rep(".", 12), collapse = "")),
|
||||
x$key_ab)
|
||||
|
||||
|
||||
# format
|
||||
key_abs <- toupper(gsub("[^SIR]", ".", gsub("(NA|NULL)", ".", x$key_ab)))
|
||||
|
||||
if (n_distinct(key_abs) == 1) {
|
||||
warning("No distinct key antibiotics determined.", call. = FALSE)
|
||||
}
|
||||
|
||||
|
||||
key_abs
|
||||
|
||||
|
||||
}
|
||||
|
||||
#' @rdname key_antibiotics
|
||||
@ -255,72 +255,72 @@ key_antibiotics_equal <- function(y,
|
||||
# y is active row, z is lag
|
||||
x <- y
|
||||
y <- z
|
||||
|
||||
|
||||
type <- type[1]
|
||||
|
||||
|
||||
stop_ifnot(length(x) == length(y), "length of `x` and `y` must be equal")
|
||||
|
||||
|
||||
# only show progress bar on points or when at least 5000 isolates
|
||||
info_needed <- info == TRUE & (type == "points" | length(x) > 5000)
|
||||
|
||||
|
||||
result <- logical(length(x))
|
||||
|
||||
|
||||
if (info_needed == TRUE) {
|
||||
p <- progress_estimated(length(x))
|
||||
on.exit(close(p))
|
||||
}
|
||||
|
||||
|
||||
for (i in seq_len(length(x))) {
|
||||
|
||||
|
||||
if (info_needed == TRUE) {
|
||||
p$tick()
|
||||
}
|
||||
|
||||
|
||||
if (is.na(x[i])) {
|
||||
x[i] <- ""
|
||||
}
|
||||
if (is.na(y[i])) {
|
||||
y[i] <- ""
|
||||
}
|
||||
|
||||
|
||||
if (x[i] == y[i]) {
|
||||
|
||||
|
||||
result[i] <- TRUE
|
||||
|
||||
|
||||
} else if (nchar(x[i]) != nchar(y[i])) {
|
||||
|
||||
|
||||
result[i] <- FALSE
|
||||
|
||||
|
||||
} else {
|
||||
|
||||
|
||||
x_split <- strsplit(x[i], "")[[1]]
|
||||
y_split <- strsplit(y[i], "")[[1]]
|
||||
|
||||
|
||||
if (type == "keyantibiotics") {
|
||||
|
||||
|
||||
if (ignore_I == TRUE) {
|
||||
x_split[x_split == "I"] <- "."
|
||||
y_split[y_split == "I"] <- "."
|
||||
}
|
||||
|
||||
|
||||
y_split[x_split == "."] <- "."
|
||||
x_split[y_split == "."] <- "."
|
||||
|
||||
|
||||
result[i] <- all(x_split == y_split)
|
||||
|
||||
|
||||
} else if (type == "points") {
|
||||
# count points for every single character:
|
||||
# - no change is 0 points
|
||||
# - I <-> S|R is 0.5 point
|
||||
# - S|R <-> R|S is 1 point
|
||||
# use the levels of as.rsi (S = 1, I = 2, R = 3)
|
||||
|
||||
|
||||
suppressWarnings(x_split <- x_split %>% as.rsi() %>% as.double())
|
||||
suppressWarnings(y_split <- y_split %>% as.rsi() %>% as.double())
|
||||
|
||||
|
||||
points <- (x_split - y_split) %>% abs() %>% sum(na.rm = TRUE) / 2
|
||||
result[i] <- points >= points_threshold
|
||||
|
||||
|
||||
} else {
|
||||
stop("`", type, '` is not a valid value for type, must be "points" or "keyantibiotics". See ?key_antibiotics')
|
||||
}
|
||||
|
||||
2
R/like.R
2
R/like.R
@ -96,7 +96,7 @@ like <- function(x, pattern, ignore.case = TRUE) {
|
||||
return(res)
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
# the regular way how grepl works; just one pattern against one or more x
|
||||
if (is.factor(x)) {
|
||||
as.integer(x) %in% base::grep(pattern, levels(x), ignore.case = FALSE, fixed = fixed)
|
||||
|
||||
38
R/mdro.R
38
R/mdro.R
@ -117,7 +117,7 @@ mdro <- function(x,
|
||||
# allow pct_required_classes = 75 -> pct_required_classes = 0.75
|
||||
pct_required_classes <- pct_required_classes / 100
|
||||
}
|
||||
|
||||
|
||||
if (!is.null(list(...)$country)) {
|
||||
warning("Using `country` is deprecated, use `guideline` instead. Please see ?mdro.", call. = FALSE)
|
||||
guideline <- list(...)$country
|
||||
@ -145,7 +145,7 @@ mdro <- function(x,
|
||||
}
|
||||
if (is.null(col_mo) & guideline$code == "tb") {
|
||||
message(font_blue("NOTE: No column found as input for `col_mo`,",
|
||||
font_bold("assuming all records contain", font_italic("Mycobacterium tuberculosis."))))
|
||||
font_bold("assuming all records contain", font_italic("Mycobacterium tuberculosis."))))
|
||||
x$mo <- as.mo("Mycobacterium tuberculosis")
|
||||
col_mo <- "mo"
|
||||
}
|
||||
@ -470,7 +470,7 @@ mdro <- function(x,
|
||||
}
|
||||
x_transposed <- as.list(as.data.frame(t(x[, cols, drop = FALSE])))
|
||||
row_filter <- sapply(x_transposed, function(y) search_function(y %in% search_result, na.rm = TRUE))
|
||||
row_filter <- x[row_filter, "row_number", drop = TRUE]
|
||||
row_filter <- x[which(row_filter), "row_number", drop = TRUE]
|
||||
rows <- rows[rows %in% row_filter]
|
||||
x[rows, "MDRO"] <<- to
|
||||
x[rows, "reason"] <<- paste0(any_all, " of the required antibiotics ", ifelse(any_all == "any", "is", "are"), " R")
|
||||
@ -492,23 +492,23 @@ mdro <- function(x,
|
||||
|
||||
if (verbose == TRUE) {
|
||||
x[rows, "columns_nonsusceptible"] <<- sapply(rows,
|
||||
function(row, group_vct = lst_vector) {
|
||||
cols_nonsus <- sapply(x[row, group_vct, drop = FALSE], function(y) y %in% search_result)
|
||||
paste(sort(names(cols_nonsus)[cols_nonsus]), collapse = ", ")
|
||||
})
|
||||
function(row, group_vct = lst_vector) {
|
||||
cols_nonsus <- sapply(x[row, group_vct, drop = FALSE], function(y) y %in% search_result)
|
||||
paste(sort(names(cols_nonsus)[cols_nonsus]), collapse = ", ")
|
||||
})
|
||||
}
|
||||
x[rows, "classes_affected"] <<- sapply(rows,
|
||||
function(row, group_tbl = lst) {
|
||||
sum(sapply(group_tbl,
|
||||
function(group) {
|
||||
any(unlist(x[row, group[!is.na(group)], drop = TRUE]) %in% search_result, na.rm = TRUE)
|
||||
}),
|
||||
na.rm = TRUE)
|
||||
})
|
||||
function(row, group_tbl = lst) {
|
||||
sum(sapply(group_tbl,
|
||||
function(group) {
|
||||
any(unlist(x[row, group[!is.na(group)], drop = TRUE]) %in% search_result, na.rm = TRUE)
|
||||
}),
|
||||
na.rm = TRUE)
|
||||
})
|
||||
# for PDR; all agents are R (or I if combine_SI = FALSE)
|
||||
x_transposed <- as.list(as.data.frame(t(x[rows, lst_vector, drop = FALSE])))
|
||||
row_filter <- sapply(x_transposed, function(y) all(y %in% search_result, na.rm = TRUE))
|
||||
x[row_filter, "classes_affected"] <<- 999
|
||||
x[which(row_filter), "classes_affected"] <<- 999
|
||||
}
|
||||
|
||||
if (info == TRUE) {
|
||||
@ -523,7 +523,7 @@ mdro <- function(x,
|
||||
x$row_number <- seq_len(nrow(x))
|
||||
x$reason <- paste0("not covered by ", toupper(guideline$code), " guideline")
|
||||
x$columns_nonsusceptible <- ""
|
||||
|
||||
|
||||
if (guideline$code == "cmi2012") {
|
||||
# CMI, 2012 ---------------------------------------------------------------
|
||||
# Non-susceptible = R and I
|
||||
@ -718,7 +718,7 @@ mdro <- function(x,
|
||||
x[which((x$classes_in_guideline - x$classes_affected) <= 2), "MDRO"] <- 3
|
||||
if (verbose == TRUE) {
|
||||
x[which(x$MDRO == 3), "reason"] <- paste0("less than 3 classes remain susceptible (", x$classes_in_guideline[which((x$classes_in_guideline - x$classes_affected) <= 2)] - x$classes_affected[which(x$MDRO == 3)],
|
||||
" out of ", x$classes_in_guideline[which(x$MDRO == 3)], " classes)")
|
||||
" out of ", x$classes_in_guideline[which(x$MDRO == 3)], " classes)")
|
||||
}
|
||||
|
||||
# PDR (=4): all agents are R
|
||||
@ -966,7 +966,7 @@ mdro <- function(x,
|
||||
ab != "R"
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
x$mono_count <- 0
|
||||
x[drug_is_R(INH), "mono_count"] <- x[drug_is_R(INH), "mono_count"] + 1
|
||||
x[drug_is_R(RIF), "mono_count"] <- x[drug_is_R(RIF), "mono_count"] + 1
|
||||
@ -1002,7 +1002,7 @@ mdro <- function(x,
|
||||
# some more info on negative results
|
||||
if (verbose == TRUE) {
|
||||
if (guideline$code == "cmi2012") {
|
||||
x[which(x$MDRO == 1 & !is.na(x$classes_affected)), "reason"] <- paste0(x$classes_affected[which(x$MDRO == 1 & !is.na(x$classes_affected))], " of ", x$classes_available[which(x$MDRO == 1 & !is.na(x$classes_affected))], " available classes contain R or I (3 required for MDR)")
|
||||
x[which(x$MDRO == 1 & !is.na(x$classes_affected)), "reason"] <- paste0(x$classes_affected[which(x$MDRO == 1 & !is.na(x$classes_affected))], " of ", x$classes_available[which(x$MDRO == 1 & !is.na(x$classes_affected))], " available classes contain R or I (3 required for MDR)")
|
||||
} else {
|
||||
x[which(x$MDRO == 1), "reason"] <- "too few antibiotics are R"
|
||||
}
|
||||
|
||||
10
R/mic.R
10
R/mic.R
@ -60,7 +60,7 @@ as.mic <- function(x, na.rm = FALSE) {
|
||||
x <- x[!is.na(x)]
|
||||
}
|
||||
x.bak <- x
|
||||
|
||||
|
||||
# comma to period
|
||||
x <- gsub(",", ".", x, fixed = TRUE)
|
||||
# transform Unicode for >= and <=
|
||||
@ -97,7 +97,7 @@ as.mic <- function(x, na.rm = FALSE) {
|
||||
|
||||
## previously unempty values now empty - should return a warning later on
|
||||
x[x.bak != "" & x == ""] <- "invalid"
|
||||
|
||||
|
||||
# these are allowed MIC values and will become factor levels
|
||||
ops <- c("<", "<=", "", ">=", ">")
|
||||
lvls <- c(c(t(sapply(ops, function(x) paste0(x, "0.00", 1:9)))),
|
||||
@ -108,11 +108,11 @@ as.mic <- function(x, na.rm = FALSE) {
|
||||
c(t(sapply(ops, function(x) paste0(x, sort(c(1:9, 1.5)))))),
|
||||
c(t(sapply(ops, function(x) paste0(x, c(10:98)[9:98 %% 2 == TRUE])))),
|
||||
c(t(sapply(ops, function(x) paste0(x, sort(c(2 ^ c(7:10), 80 * c(2:12))))))))
|
||||
|
||||
|
||||
na_before <- x[is.na(x) | x == ""] %>% length()
|
||||
x[!x %in% lvls] <- NA
|
||||
na_after <- x[is.na(x) | x == ""] %>% length()
|
||||
|
||||
|
||||
if (na_before != na_after) {
|
||||
list_missing <- x.bak[is.na(x) & !is.na(x.bak) & x.bak != ""] %>%
|
||||
unique() %>%
|
||||
@ -123,7 +123,7 @@ as.mic <- function(x, na.rm = FALSE) {
|
||||
"%) that were invalid MICs: ",
|
||||
list_missing, call. = FALSE)
|
||||
}
|
||||
|
||||
|
||||
structure(.Data = factor(x, levels = lvls, ordered = TRUE),
|
||||
class = c("mic", "ordered", "factor"))
|
||||
}
|
||||
|
||||
4
R/mo.R
4
R/mo.R
@ -554,7 +554,7 @@ exec_as.mo <- function(x,
|
||||
if (initial_search == TRUE) {
|
||||
progress$tick()
|
||||
}
|
||||
|
||||
|
||||
# valid MO code ----
|
||||
found <- lookup(mo == toupper(x_backup[i]))
|
||||
if (!is.na(found)) {
|
||||
@ -1511,7 +1511,7 @@ exec_as.mo <- function(x,
|
||||
if (property == "mo") {
|
||||
x <- to_class_mo(x)
|
||||
}
|
||||
|
||||
|
||||
if (length(mo_renamed()) > 0) {
|
||||
print(mo_renamed())
|
||||
}
|
||||
|
||||
@ -151,9 +151,9 @@ mo_fullname <- mo_name
|
||||
#' @export
|
||||
mo_shortname <- function(x, language = get_locale(), ...) {
|
||||
x.mo <- as.mo(x, ...)
|
||||
|
||||
|
||||
metadata <- get_mo_failures_uncertainties_renamed()
|
||||
|
||||
|
||||
replace_empty <- function(x) {
|
||||
x[x == ""] <- "spp."
|
||||
x
|
||||
@ -161,13 +161,13 @@ mo_shortname <- function(x, language = get_locale(), ...) {
|
||||
|
||||
# get first char of genus and complete species in English
|
||||
shortnames <- paste0(substr(mo_genus(x.mo, language = NULL), 1, 1), ". ", replace_empty(mo_species(x.mo, language = NULL)))
|
||||
|
||||
|
||||
# exceptions for Staphylococci
|
||||
shortnames[shortnames == "S. coagulase-negative"] <- "CoNS"
|
||||
shortnames[shortnames == "S. coagulase-positive"] <- "CoPS"
|
||||
# exceptions for Streptococci: Streptococcus Group A -> GAS
|
||||
shortnames[shortnames %like% "S. group [ABCDFGHK]"] <- paste0("G", gsub("S. group ([ABCDFGHK])", "\\1", shortnames[shortnames %like% "S. group [ABCDFGHK]"]), "S")
|
||||
|
||||
|
||||
load_mo_failures_uncertainties_renamed(metadata)
|
||||
translate_AMR(shortnames, language = language, only_unknown = FALSE)
|
||||
}
|
||||
@ -235,7 +235,7 @@ mo_type <- function(x, language = get_locale(), ...) {
|
||||
mo_gramstain <- function(x, language = get_locale(), ...) {
|
||||
x.mo <- as.mo(x, ...)
|
||||
metadata <- get_mo_failures_uncertainties_renamed()
|
||||
|
||||
|
||||
x.phylum <- mo_phylum(x.mo)
|
||||
# DETERMINE GRAM STAIN FOR BACTERIA
|
||||
# Source: https://itis.gov/servlet/SingleRpt/SingleRpt?search_topic=TSN&search_value=956097
|
||||
@ -256,7 +256,7 @@ mo_gramstain <- function(x, language = get_locale(), ...) {
|
||||
"Firmicutes",
|
||||
"Tenericutes")
|
||||
| x.mo == "B_GRAMP"] <- "Gram-positive"
|
||||
|
||||
|
||||
load_mo_failures_uncertainties_renamed(metadata)
|
||||
translate_AMR(x, language = language, only_unknown = FALSE)
|
||||
}
|
||||
@ -302,16 +302,16 @@ mo_rank <- function(x, ...) {
|
||||
mo_taxonomy <- function(x, language = get_locale(), ...) {
|
||||
x <- as.mo(x, ...)
|
||||
metadata <- get_mo_failures_uncertainties_renamed()
|
||||
|
||||
|
||||
result <- base::list(kingdom = mo_kingdom(x, language = language),
|
||||
phylum = mo_phylum(x, language = language),
|
||||
class = mo_class(x, language = language),
|
||||
order = mo_order(x, language = language),
|
||||
family = mo_family(x, language = language),
|
||||
genus = mo_genus(x, language = language),
|
||||
species = mo_species(x, language = language),
|
||||
subspecies = mo_subspecies(x, language = language))
|
||||
|
||||
phylum = mo_phylum(x, language = language),
|
||||
class = mo_class(x, language = language),
|
||||
order = mo_order(x, language = language),
|
||||
family = mo_family(x, language = language),
|
||||
genus = mo_genus(x, language = language),
|
||||
species = mo_species(x, language = language),
|
||||
subspecies = mo_subspecies(x, language = language))
|
||||
|
||||
load_mo_failures_uncertainties_renamed(metadata)
|
||||
result
|
||||
}
|
||||
@ -321,7 +321,7 @@ mo_taxonomy <- function(x, language = get_locale(), ...) {
|
||||
mo_synonyms <- function(x, ...) {
|
||||
x <- as.mo(x, ...)
|
||||
metadata <- get_mo_failures_uncertainties_renamed()
|
||||
|
||||
|
||||
IDs <- mo_name(x = x, language = NULL)
|
||||
syns <- lapply(IDs, function(newname) {
|
||||
res <- sort(microorganisms.old[which(microorganisms.old$fullname_new == newname), "fullname"])
|
||||
@ -337,7 +337,7 @@ mo_synonyms <- function(x, ...) {
|
||||
} else {
|
||||
result <- unlist(syns)
|
||||
}
|
||||
|
||||
|
||||
load_mo_failures_uncertainties_renamed(metadata)
|
||||
result
|
||||
}
|
||||
@ -347,7 +347,7 @@ mo_synonyms <- function(x, ...) {
|
||||
mo_info <- function(x, language = get_locale(), ...) {
|
||||
x <- as.mo(x, ...)
|
||||
metadata <- get_mo_failures_uncertainties_renamed()
|
||||
|
||||
|
||||
info <- lapply(x, function(y)
|
||||
c(mo_taxonomy(y, language = language),
|
||||
list(synonyms = mo_synonyms(y),
|
||||
@ -360,7 +360,7 @@ mo_info <- function(x, language = get_locale(), ...) {
|
||||
} else {
|
||||
result <- info[[1L]]
|
||||
}
|
||||
|
||||
|
||||
load_mo_failures_uncertainties_renamed(metadata)
|
||||
result
|
||||
}
|
||||
@ -388,7 +388,7 @@ mo_url <- function(x, open = FALSE, ...) {
|
||||
}
|
||||
utils::browseURL(u[1L])
|
||||
}
|
||||
|
||||
|
||||
load_mo_failures_uncertainties_renamed(metadata)
|
||||
u
|
||||
}
|
||||
@ -400,14 +400,14 @@ mo_property <- function(x, property = "fullname", language = get_locale(), ...)
|
||||
stop_ifnot(length(property) == 1L, "'property' must be of length 1")
|
||||
stop_ifnot(property %in% colnames(microorganisms),
|
||||
"invalid property: '", property, "' - use a column name of the `microorganisms` data set")
|
||||
|
||||
|
||||
translate_AMR(mo_validate(x = x, property = property, ...), language = language, only_unknown = TRUE)
|
||||
}
|
||||
|
||||
mo_validate <- function(x, property, ...) {
|
||||
|
||||
check_dataset_integrity()
|
||||
|
||||
|
||||
dots <- list(...)
|
||||
Becker <- dots$Becker
|
||||
if (is.null(Becker)) {
|
||||
@ -417,7 +417,7 @@ mo_validate <- function(x, property, ...) {
|
||||
if (is.null(Lancefield)) {
|
||||
Lancefield <- FALSE
|
||||
}
|
||||
|
||||
|
||||
# try to catch an error when inputting an invalid parameter
|
||||
# so the 'call.' can be set to FALSE
|
||||
tryCatch(x[1L] %in% MO_lookup[1, property, drop = TRUE],
|
||||
|
||||
@ -109,11 +109,11 @@
|
||||
#' @export
|
||||
#' @inheritSection AMR Read more on our website!
|
||||
set_mo_source <- function(path) {
|
||||
|
||||
|
||||
file_location <- path.expand("~/mo_source.rds")
|
||||
|
||||
|
||||
stop_ifnot(length(path) == 1, "`path` must be of length 1")
|
||||
|
||||
|
||||
if (is.null(path) || path %in% c(FALSE, "")) {
|
||||
options(mo_source = NULL)
|
||||
options(mo_source_timestamp = NULL)
|
||||
@ -123,21 +123,21 @@ set_mo_source <- function(path) {
|
||||
}
|
||||
return(invisible())
|
||||
}
|
||||
|
||||
|
||||
stop_ifnot(file.exists(path),
|
||||
"file not found: ", path)
|
||||
|
||||
|
||||
if (path %like% "[.]rds$") {
|
||||
df <- readRDS(path)
|
||||
|
||||
|
||||
} else if (path %like% "[.]xlsx?$") {
|
||||
# is Excel file (old or new)
|
||||
read_excel <- import_fn("read_excel", "readxl")
|
||||
df <- read_excel(path)
|
||||
|
||||
|
||||
} else if (path %like% "[.]tsv$") {
|
||||
df <- utils::read.table(header = TRUE, sep = "\t", stringsAsFactors = FALSE)
|
||||
|
||||
|
||||
} else {
|
||||
# try comma first
|
||||
try(
|
||||
@ -156,21 +156,21 @@ set_mo_source <- function(path) {
|
||||
silent = TRUE)
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
# check integrity
|
||||
mo_source_isvalid(df)
|
||||
|
||||
|
||||
df <- subset(df, !is.na(mo))
|
||||
|
||||
|
||||
# keep only first two columns, second must be mo
|
||||
if (colnames(df)[1] == "mo") {
|
||||
df <- df[, c(colnames(df)[2], "mo")]
|
||||
} else {
|
||||
df <- df[, c(colnames(df)[1], "mo")]
|
||||
}
|
||||
|
||||
|
||||
df <- as.data.frame(df, stringAsFactors = FALSE)
|
||||
|
||||
|
||||
# success
|
||||
if (file.exists(file_location)) {
|
||||
action <- "Updated"
|
||||
|
||||
@ -29,10 +29,10 @@
|
||||
#' @inheritSection AMR Read more on our website!
|
||||
#' @export
|
||||
p_symbol <- function(p, emptychar = " ") {
|
||||
|
||||
|
||||
p <- as.double(p)
|
||||
s <- rep(NA_character_, length(p))
|
||||
|
||||
|
||||
s[p <= 1] <- emptychar
|
||||
s[p <= 0.100] <- "."
|
||||
s[p <= 0.050] <- "*"
|
||||
|
||||
@ -122,12 +122,12 @@ resistance_predict <- function(x,
|
||||
preserve_measurements = TRUE,
|
||||
info = interactive(),
|
||||
...) {
|
||||
|
||||
|
||||
stop_ifnot(is.data.frame(x), "`x` must be a data.frame")
|
||||
stop_if(any(dim(x) == 0), "`x` must contain rows and columns")
|
||||
stop_if(is.null(model), 'choose a regression model with the `model` parameter, e.g. resistance_predict(..., model = "binomial")')
|
||||
stop_ifnot(col_ab %in% colnames(x),
|
||||
"column `", col_ab, "` not found")
|
||||
"column `", col_ab, "` not found")
|
||||
|
||||
dots <- unlist(list(...))
|
||||
if (length(dots) != 0) {
|
||||
@ -140,7 +140,7 @@ resistance_predict <- function(x,
|
||||
warning("`I_as_R is deprecated - use I_as_S instead.", call. = FALSE)
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
# -- date
|
||||
if (is.null(col_date)) {
|
||||
col_date <- search_type_in_df(x = x, type = "date")
|
||||
@ -148,7 +148,7 @@ resistance_predict <- function(x,
|
||||
}
|
||||
stop_ifnot(col_date %in% colnames(x),
|
||||
"column `", col_date, "` not found")
|
||||
|
||||
|
||||
# no grouped tibbles
|
||||
x <- as.data.frame(x, stringsAsFactors = FALSE)
|
||||
|
||||
@ -178,7 +178,7 @@ resistance_predict <- function(x,
|
||||
df <- as.data.frame(rbind(table(df[, c("year", col_ab)])), stringsAsFactors = FALSE)
|
||||
df$year <- as.integer(rownames(df))
|
||||
rownames(df) <- NULL
|
||||
|
||||
|
||||
df <- subset(df, sum(df$R + df$S, na.rm = TRUE) >= minimum)
|
||||
df_matrix <- as.matrix(df[, c("R", "S"), drop = FALSE])
|
||||
|
||||
@ -193,9 +193,9 @@ resistance_predict <- function(x,
|
||||
if (is.null(year_max)) {
|
||||
year_max <- year(Sys.Date()) + 10
|
||||
}
|
||||
|
||||
|
||||
years <- list(year = seq(from = year_min, to = year_max, by = year_every))
|
||||
|
||||
|
||||
if (model %in% c("binomial", "binom", "logit")) {
|
||||
model <- "binomial"
|
||||
model_lm <- with(df, glm(df_matrix ~ year, family = binomial))
|
||||
@ -204,11 +204,11 @@ resistance_predict <- function(x,
|
||||
cat("\n------------------------------------------------------------\n")
|
||||
print(summary(model_lm))
|
||||
}
|
||||
|
||||
|
||||
predictmodel <- predict(model_lm, newdata = years, type = "response", se.fit = TRUE)
|
||||
prediction <- predictmodel$fit
|
||||
se <- predictmodel$se.fit
|
||||
|
||||
|
||||
} else if (model %in% c("loglin", "poisson")) {
|
||||
model <- "poisson"
|
||||
model_lm <- with(df, glm(R ~ year, family = poisson))
|
||||
@ -217,11 +217,11 @@ resistance_predict <- function(x,
|
||||
cat("\n--------------------------------------------------------------\n")
|
||||
print(summary(model_lm))
|
||||
}
|
||||
|
||||
|
||||
predictmodel <- predict(model_lm, newdata = years, type = "response", se.fit = TRUE)
|
||||
prediction <- predictmodel$fit
|
||||
se <- predictmodel$se.fit
|
||||
|
||||
|
||||
} else if (model %in% c("lin", "linear")) {
|
||||
model <- "linear"
|
||||
model_lm <- with(df, lm((R / (R + S)) ~ year))
|
||||
@ -230,22 +230,22 @@ resistance_predict <- function(x,
|
||||
cat("\n-----------------------\n")
|
||||
print(summary(model_lm))
|
||||
}
|
||||
|
||||
|
||||
predictmodel <- predict(model_lm, newdata = years, se.fit = TRUE)
|
||||
prediction <- predictmodel$fit
|
||||
se <- predictmodel$se.fit
|
||||
|
||||
|
||||
} else {
|
||||
stop("no valid model selected. See ?resistance_predict.")
|
||||
}
|
||||
|
||||
|
||||
# prepare the output dataframe
|
||||
df_prediction <- data.frame(year = unlist(years),
|
||||
value = prediction,
|
||||
se_min = prediction - se,
|
||||
se_max = prediction + se,
|
||||
stringsAsFactors = FALSE)
|
||||
|
||||
|
||||
if (model == "poisson") {
|
||||
df_prediction$value <- as.integer(format(df_prediction$value, scientific = FALSE))
|
||||
df_prediction$se_min <- as.integer(df_prediction$se_min)
|
||||
@ -257,7 +257,7 @@ resistance_predict <- function(x,
|
||||
}
|
||||
# se_min not below 0
|
||||
df_prediction$se_min <- ifelse(df_prediction$se_min < 0, 0, df_prediction$se_min)
|
||||
|
||||
|
||||
df_observations <- data.frame(year = df$year,
|
||||
observations = df$R + df$S,
|
||||
observed = df$R / (df$R + df$S),
|
||||
@ -265,17 +265,17 @@ resistance_predict <- function(x,
|
||||
df_prediction <- df_prediction %>%
|
||||
left_join(df_observations, by = "year")
|
||||
df_prediction$estimated <- df_prediction$value
|
||||
|
||||
|
||||
if (preserve_measurements == TRUE) {
|
||||
# replace estimated data by observed data
|
||||
df_prediction$value <- ifelse(!is.na(df_prediction$observed), df_prediction$observed, df_prediction$value)
|
||||
df_prediction$se_min <- ifelse(!is.na(df_prediction$observed), NA, df_prediction$se_min)
|
||||
df_prediction$se_max <- ifelse(!is.na(df_prediction$observed), NA, df_prediction$se_max)
|
||||
}
|
||||
|
||||
|
||||
df_prediction$value <- ifelse(df_prediction$value > 1, 1, ifelse(df_prediction$value < 0, 0, df_prediction$value))
|
||||
df_prediction <- df_prediction[order(df_prediction$year), ]
|
||||
|
||||
|
||||
structure(
|
||||
.Data = df_prediction,
|
||||
class = c("resistance_predict", "data.frame"),
|
||||
@ -296,7 +296,7 @@ rsi_predict <- resistance_predict
|
||||
#' @rdname resistance_predict
|
||||
plot.resistance_predict <- function(x, main = paste("Resistance Prediction of", x_name), ...) {
|
||||
x_name <- paste0(ab_name(attributes(x)$ab), " (", attributes(x)$ab, ")")
|
||||
|
||||
|
||||
if (attributes(x)$I_as_S == TRUE) {
|
||||
ylab <- "%R"
|
||||
} else {
|
||||
@ -319,17 +319,17 @@ plot.resistance_predict <- function(x, main = paste("Resistance Prediction of",
|
||||
sub = paste0("(n = ", sum(x$observations, na.rm = TRUE),
|
||||
", model: ", attributes(x)$model_title, ")"),
|
||||
cex.sub = 0.75)
|
||||
|
||||
|
||||
|
||||
|
||||
axis(side = 2, at = seq(0, 1, 0.1), labels = paste0(0:10 * 10, "%"))
|
||||
|
||||
|
||||
# hack for error bars: https://stackoverflow.com/a/22037078/4575331
|
||||
arrows(x0 = x$year,
|
||||
y0 = x$se_min,
|
||||
x1 = x$year,
|
||||
y1 = x$se_max,
|
||||
length = 0.05, angle = 90, code = 3, lwd = 1.5)
|
||||
|
||||
|
||||
# overlay grey points for prediction
|
||||
points(x = subset(x, is.na(observations))$year,
|
||||
y = subset(x, is.na(observations))$value,
|
||||
@ -346,15 +346,15 @@ ggplot_rsi_predict <- function(x,
|
||||
|
||||
stop_ifnot_installed("ggplot2")
|
||||
stop_ifnot(inherits(x, "resistance_predict"), "`x` must be a resistance prediction model created with resistance_predict()")
|
||||
|
||||
|
||||
x_name <- paste0(ab_name(attributes(x)$ab), " (", attributes(x)$ab, ")")
|
||||
|
||||
|
||||
if (attributes(x)$I_as_S == TRUE) {
|
||||
ylab <- "%R"
|
||||
} else {
|
||||
ylab <- "%IR"
|
||||
}
|
||||
|
||||
|
||||
p <- ggplot2::ggplot(x, ggplot2::aes(x = year, y = value)) +
|
||||
ggplot2::geom_point(data = subset(x, !is.na(observations)),
|
||||
size = 2) +
|
||||
@ -364,7 +364,7 @@ ggplot_rsi_predict <- function(x,
|
||||
x = "Year",
|
||||
caption = paste0("(n = ", sum(x$observations, na.rm = TRUE),
|
||||
", model: ", attributes(x)$model_title, ")"))
|
||||
|
||||
|
||||
if (ribbon == TRUE) {
|
||||
p <- p + ggplot2::geom_ribbon(ggplot2::aes(ymin = se_min, ymax = se_max), alpha = 0.25)
|
||||
} else {
|
||||
|
||||
28
R/rsi.R
28
R/rsi.R
@ -153,7 +153,7 @@ as.rsi.default <- function(x, ...) {
|
||||
structure(.Data = factor(x, levels = c("S", "I", "R"), ordered = TRUE),
|
||||
class = c("rsi", "ordered", "factor"))
|
||||
} else {
|
||||
|
||||
|
||||
ab <- deparse(substitute(x))
|
||||
if (!any(x %like% "(R|S|I)", na.rm = TRUE)) {
|
||||
if (!is.na(suppressWarnings(as.ab(ab)))) {
|
||||
@ -232,8 +232,8 @@ as.rsi.mic <- function(x, mo, ab = deparse(substitute(x)), guideline = "EUCAST",
|
||||
}
|
||||
|
||||
message(font_blue(paste0("=> Interpreting MIC values of `", font_bold(ab), "` (",
|
||||
ifelse(ab_coerced != ab, paste0(ab_coerced, ", "), ""),
|
||||
ab_name(ab_coerced, tolower = TRUE), ") using guideline ", font_bold(guideline_coerced), " ... ")),
|
||||
ifelse(ab_coerced != ab, paste0(ab_coerced, ", "), ""),
|
||||
ab_name(ab_coerced, tolower = TRUE), ") using guideline ", font_bold(guideline_coerced), " ... ")),
|
||||
appendLF = FALSE)
|
||||
result <- exec_as.rsi(method = "mic",
|
||||
x = x,
|
||||
@ -268,8 +268,8 @@ as.rsi.disk <- function(x, mo, ab = deparse(substitute(x)), guideline = "EUCAST"
|
||||
}
|
||||
|
||||
message(font_blue(paste0("=> Interpreting disk zones of `", font_bold(ab), "` (",
|
||||
ifelse(ab_coerced != ab, paste0(ab_coerced, ", "), ""),
|
||||
ab_name(ab_coerced, tolower = TRUE), ") using guideline ", font_bold(guideline_coerced), " ... ")),
|
||||
ifelse(ab_coerced != ab, paste0(ab_coerced, ", "), ""),
|
||||
ab_name(ab_coerced, tolower = TRUE), ") using guideline ", font_bold(guideline_coerced), " ... ")),
|
||||
appendLF = FALSE)
|
||||
result <- exec_as.rsi(method = "disk",
|
||||
x = x,
|
||||
@ -319,15 +319,15 @@ as.rsi.data.frame <- function(x, col_mo = NULL, guideline = "EUCAST", uti = NULL
|
||||
plural <- c("", "s", "a ")
|
||||
}
|
||||
message(font_blue(paste0("NOTE: Assuming value", plural[1], " ",
|
||||
paste(paste0('"', values, '"'), collapse = ", "),
|
||||
" in column `", font_bold(col_specimen),
|
||||
"` reflect", plural[2], " ", plural[3], "urinary tract infection", plural[1], ".\n Use `as.rsi(uti = FALSE)` to prevent this.")))
|
||||
paste(paste0('"', values, '"'), collapse = ", "),
|
||||
" in column `", font_bold(col_specimen),
|
||||
"` reflect", plural[2], " ", plural[3], "urinary tract infection", plural[1], ".\n Use `as.rsi(uti = FALSE)` to prevent this.")))
|
||||
} else {
|
||||
# no data about UTI's found
|
||||
uti <- FALSE
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
i <- 0
|
||||
ab_cols <- colnames(x)[sapply(x, function(y) {
|
||||
i <<- i + 1
|
||||
@ -339,13 +339,13 @@ as.rsi.data.frame <- function(x, col_mo = NULL, guideline = "EUCAST", uti = NULL
|
||||
return(FALSE)
|
||||
} else if (!check & all_valid_mics(y)) {
|
||||
message(font_blue(paste0("NOTE: Assuming column `", ab, "` (",
|
||||
ifelse(ab_coerced != ab, paste0(ab_coerced, ", "), ""),
|
||||
ab_name(ab_coerced, tolower = TRUE), ") contains MIC values.")))
|
||||
ifelse(ab_coerced != ab, paste0(ab_coerced, ", "), ""),
|
||||
ab_name(ab_coerced, tolower = TRUE), ") contains MIC values.")))
|
||||
return(TRUE)
|
||||
} else if (!check & all_valid_disks(y)) {
|
||||
message(font_blue(paste0("NOTE: Assuming column `", ab, "` (",
|
||||
ifelse(ab_coerced != ab, paste0(ab_coerced, ", "), ""),
|
||||
ab_name(ab_coerced, tolower = TRUE), ") contains disk zones.")))
|
||||
ifelse(ab_coerced != ab, paste0(ab_coerced, ", "), ""),
|
||||
ab_name(ab_coerced, tolower = TRUE), ") contains disk zones.")))
|
||||
return(TRUE)
|
||||
} else {
|
||||
return(check)
|
||||
@ -574,7 +574,7 @@ plot.rsi <- function(x,
|
||||
data <- as.data.frame(table(x), stringsAsFactors = FALSE)
|
||||
colnames(data) <- c("x", "n")
|
||||
data$s <- round((data$n / sum(data$n)) * 100, 1)
|
||||
|
||||
|
||||
if (!"S" %in% data$x) {
|
||||
data <- rbind(data, data.frame(x = "S", n = 0, s = 0))
|
||||
}
|
||||
|
||||
10
R/rsi_calc.R
10
R/rsi_calc.R
@ -38,7 +38,7 @@ rsi_calc <- function(...,
|
||||
stop_ifnot(is.logical(only_all_tested), "`only_all_tested` must be logical", call = -2)
|
||||
|
||||
data_vars <- dots2vars(...)
|
||||
|
||||
|
||||
dots_df <- switch(1, ...)
|
||||
if (is.data.frame(dots_df)) {
|
||||
# make sure to remove all other classes like tibbles, data.tables, etc
|
||||
@ -47,7 +47,7 @@ rsi_calc <- function(...,
|
||||
|
||||
dots <- base::eval(base::substitute(base::alist(...)))
|
||||
stop_if(length(dots) == 0, "no variables selected", call = -2)
|
||||
|
||||
|
||||
stop_if("also_single_tested" %in% names(dots),
|
||||
"`also_single_tested` was replaced by `only_all_tested`.\n",
|
||||
"Please read Details in the help page (`?proportion`) as this may have a considerable impact on your analysis.", call = -2)
|
||||
@ -55,7 +55,7 @@ rsi_calc <- function(...,
|
||||
|
||||
if (is.data.frame(dots_df)) {
|
||||
# data.frame passed with other columns, like: example_isolates %>% proportion_S(AMC, GEN)
|
||||
|
||||
|
||||
dots <- as.character(dots)
|
||||
# remove first element, it's the data.frame
|
||||
if (length(dots) == 1) {
|
||||
@ -112,7 +112,7 @@ rsi_calc <- function(...,
|
||||
# this will give a warning for invalid results, of all input columns (so only 1 warning)
|
||||
rsi_integrity_check <- as.rsi(rsi_integrity_check)
|
||||
}
|
||||
|
||||
|
||||
x_transposed <- as.list(as.data.frame(t(x)))
|
||||
if (only_all_tested == TRUE) {
|
||||
# no NAs in any column
|
||||
@ -185,7 +185,7 @@ rsi_calc_df <- function(type, # "proportion", "count" or "both"
|
||||
stop_ifnot(is.logical(as_percent), "`as_percent` must be logical", call = -2)
|
||||
|
||||
translate_ab <- get_translate_ab(translate_ab)
|
||||
|
||||
|
||||
# select only groups and antibiotics
|
||||
if (has_groups(data)) {
|
||||
data_has_groups <- TRUE
|
||||
|
||||
@ -21,6 +21,7 @@
|
||||
|
||||
codecov:
|
||||
require_ci_to_pass: no # allow fail
|
||||
branch: master
|
||||
|
||||
comment: no
|
||||
|
||||
|
||||
@ -81,7 +81,7 @@
|
||||
</button>
|
||||
<span class="navbar-brand">
|
||||
<a class="navbar-link" href="https://msberends.github.io/AMR/index.html">AMR (for R)</a>
|
||||
<span class="version label label-default" data-toggle="tooltip" data-placement="bottom" title="Latest development version">1.2.0.9033</span>
|
||||
<span class="version label label-default" data-toggle="tooltip" data-placement="bottom" title="Latest development version">1.2.0.9034</span>
|
||||
</span>
|
||||
</div>
|
||||
|
||||
|
||||
@ -81,7 +81,7 @@
|
||||
</button>
|
||||
<span class="navbar-brand">
|
||||
<a class="navbar-link" href="index.html">AMR (for R)</a>
|
||||
<span class="version label label-default" data-toggle="tooltip" data-placement="bottom" title="Latest development version">1.2.0.9033</span>
|
||||
<span class="version label label-default" data-toggle="tooltip" data-placement="bottom" title="Latest development version">1.2.0.9034</span>
|
||||
</span>
|
||||
</div>
|
||||
|
||||
|
||||
@ -81,7 +81,7 @@
|
||||
</button>
|
||||
<span class="navbar-brand">
|
||||
<a class="navbar-link" href="../index.html">AMR (for R)</a>
|
||||
<span class="version label label-default" data-toggle="tooltip" data-placement="bottom" title="Latest development version">1.2.0.9033</span>
|
||||
<span class="version label label-default" data-toggle="tooltip" data-placement="bottom" title="Latest development version">1.2.0.9034</span>
|
||||
</span>
|
||||
</div>
|
||||
|
||||
|
||||
@ -81,7 +81,7 @@
|
||||
</button>
|
||||
<span class="navbar-brand">
|
||||
<a class="navbar-link" href="index.html">AMR (for R)</a>
|
||||
<span class="version label label-default" data-toggle="tooltip" data-placement="bottom" title="Latest development version">1.2.0.9033</span>
|
||||
<span class="version label label-default" data-toggle="tooltip" data-placement="bottom" title="Latest development version">1.2.0.9034</span>
|
||||
</span>
|
||||
</div>
|
||||
|
||||
|
||||
@ -43,7 +43,7 @@
|
||||
</button>
|
||||
<span class="navbar-brand">
|
||||
<a class="navbar-link" href="index.html">AMR (for R)</a>
|
||||
<span class="version label label-default" data-toggle="tooltip" data-placement="bottom" title="Latest development version">1.2.0.9033</span>
|
||||
<span class="version label label-default" data-toggle="tooltip" data-placement="bottom" title="Latest development version">1.2.0.9034</span>
|
||||
</span>
|
||||
</div>
|
||||
|
||||
|
||||
@ -81,7 +81,7 @@
|
||||
</button>
|
||||
<span class="navbar-brand">
|
||||
<a class="navbar-link" href="../index.html">AMR (for R)</a>
|
||||
<span class="version label label-default" data-toggle="tooltip" data-placement="bottom" title="Latest development version">1.2.0.9033</span>
|
||||
<span class="version label label-default" data-toggle="tooltip" data-placement="bottom" title="Latest development version">1.2.0.9034</span>
|
||||
</span>
|
||||
</div>
|
||||
|
||||
@ -229,13 +229,13 @@
|
||||
<small>Source: <a href='https://github.com/msberends/AMR/blob/master/NEWS.md'><code>NEWS.md</code></a></small>
|
||||
</div>
|
||||
|
||||
<div id="amr-1209033" class="section level1">
|
||||
<h1 class="page-header" data-toc-text="1.2.0.9033">
|
||||
<a href="#amr-1209033" class="anchor"></a>AMR 1.2.0.9033<small> Unreleased </small>
|
||||
<div id="amr-1209034" class="section level1">
|
||||
<h1 class="page-header" data-toc-text="1.2.0.9034">
|
||||
<a href="#amr-1209034" class="anchor"></a>AMR 1.2.0.9034<small> Unreleased </small>
|
||||
</h1>
|
||||
<div id="last-updated-12-jul-2020" class="section level2">
|
||||
<div id="last-updated-13-jul-2020" class="section level2">
|
||||
<h2 class="hasAnchor">
|
||||
<a href="#last-updated-12-jul-2020" class="anchor"></a><small>Last updated: 12-Jul-2020</small>
|
||||
<a href="#last-updated-13-jul-2020" class="anchor"></a><small>Last updated: 13-Jul-2020</small>
|
||||
</h2>
|
||||
<div id="new" class="section level3">
|
||||
<h3 class="hasAnchor">
|
||||
|
||||
@ -10,7 +10,7 @@ articles:
|
||||
WHONET: WHONET.html
|
||||
benchmarks: benchmarks.html
|
||||
resistance_predict: resistance_predict.html
|
||||
last_built: 2020-07-12T09:42Z
|
||||
last_built: 2020-07-13T07:17Z
|
||||
urls:
|
||||
reference: https://msberends.github.io/AMR/reference
|
||||
article: https://msberends.github.io/AMR/articles
|
||||
|
||||
@ -81,7 +81,7 @@
|
||||
</button>
|
||||
<span class="navbar-brand">
|
||||
<a class="navbar-link" href="../index.html">AMR (for R)</a>
|
||||
<span class="version label label-default" data-toggle="tooltip" data-placement="bottom" title="Latest development version">1.2.0.9033</span>
|
||||
<span class="version label label-default" data-toggle="tooltip" data-placement="bottom" title="Latest development version">1.2.0.9034</span>
|
||||
</span>
|
||||
</div>
|
||||
|
||||
|
||||
Loading…
Reference in New Issue
Block a user