P281424
/
AMR
mirror of https://github.com/msberends/AMR.git
1
0
Fork 0
Code Releases Activity

(v1.2.0.9034) code cleaning

This commit is contained in:
dr. M.S. (Matthijs) Berends 2020-07-13 09:17:24 +02:00
parent c0cf7ab02b
commit 6ab468362d
36 changed files with 266 additions and 265 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
DESCRIPTION
View File

@ -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
View File

@ -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

2
R/aa_helper_functions.R
View File

@ -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
View File

@ -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"))
}

4
R/ab_from_text.R
View File

@ -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)])
),
...)
),
...)
)
})
}

2
R/ab_property.R
View File

@ -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
View File

@ -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)) {

36
R/atc_online.R
View File

@ -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
}

10
R/availability.R
View File

@ -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, "|"),

16
R/bug_drug_combinations.R
View File

@ -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) %>%

4
R/catalogue_of_life.R
View File

@ -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",

2
R/count.R
View File

@ -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
View File

@ -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() %>%

20
R/eucast_rules.R
View File

@ -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 %>%

6
R/ggplot_rsi.R
View File

@ -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) %>%

32
R/guess_ab_col.R
View File

@ -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))
}

72
R/key_antibiotics.R
View File

@ -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
View File

@ -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
View File

@ -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
View File

@ -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
View File

@ -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())
}

46
R/mo_property.R
View File

@ -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],

26
R/mo_source.R
View File

@ -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"

4
R/p_symbol.R
View File

@ -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] <- "*"

56
R/resistance_predict.R
View File

@ -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
View File

@ -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
View File

@ -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

1
codecov.yml
View File

@ -21,6 +21,7 @@
codecov:
require_ci_to_pass: no # allow fail
branch: master
comment: no

2
docs/404.html
View File

@ -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>

2
docs/LICENSE-text.html
View File

@ -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>

2
docs/articles/index.html
View File

@ -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>

2
docs/authors.html
View File

@ -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>

2
docs/index.html
View File

@ -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>

12
docs/news/index.html
View File

@ -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">

2
docs/pkgdown.yml
View File

@ -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

2
docs/reference/index.html
View File

@ -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>