diff --git a/DESCRIPTION b/DESCRIPTION
index 1dfdd366..32c86901 100644
--- a/DESCRIPTION
+++ b/DESCRIPTION
@@ -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"),
diff --git a/NEWS.md b/NEWS.md
index 0cb707aa..5f4b3cf9 100755
--- a/NEWS.md
+++ b/NEWS.md
@@ -1,5 +1,5 @@
-# AMR 1.2.0.9033
-## Last updated: 12-Jul-2020
+# AMR 1.2.0.9034
+## Last updated: 13-Jul-2020
### 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
diff --git a/R/aa_helper_functions.R b/R/aa_helper_functions.R
index 9751fb9f..8574bcd3 100755
--- a/R/aa_helper_functions.R
+++ b/R/aa_helper_functions.R
@@ -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)) {
diff --git a/R/ab.R b/R/ab.R
index 72364e17..81dcc956 100755
--- a/R/ab.R
+++ b/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"))
}
diff --git a/R/ab_from_text.R b/R/ab_from_text.R
index bb36b6a6..bb34451a 100644
--- a/R/ab_from_text.R
+++ b/R/ab_from_text.R
@@ -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)])
- ),
- ...)
+ ),
+ ...)
)
})
}
diff --git a/R/ab_property.R b/R/ab_property.R
index 5bec0b32..882e4181 100644
--- a/R/ab_property.R
+++ b/R/ab_property.R
@@ -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)
}
diff --git a/R/age.R b/R/age.R
index 953d689d..60191f37 100755
--- a/R/age.R
+++ b/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)) {
diff --git a/R/atc_online.R b/R/atc_online.R
index f5133348..a72728af 100644
--- a/R/atc_online.R
+++ b/R/atc_online.R
@@ -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
}
diff --git a/R/availability.R b/R/availability.R
index 09156586..7a8a77cf 100644
--- a/R/availability.R
+++ b/R/availability.R
@@ -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, "|"),
diff --git a/R/bug_drug_combinations.R b/R/bug_drug_combinations.R
index 0d7aca38..9d3a6253 100644
--- a/R/bug_drug_combinations.R
+++ b/R/bug_drug_combinations.R
@@ -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) %>%
diff --git a/R/catalogue_of_life.R b/R/catalogue_of_life.R
index 53f666be..100b5af5 100755
--- a/R/catalogue_of_life.R
+++ b/R/catalogue_of_life.R
@@ -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",
diff --git a/R/count.R b/R/count.R
index 86088ba3..068c825b 100755
--- a/R/count.R
+++ b/R/count.R
@@ -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,
diff --git a/R/disk.R b/R/disk.R
index 617d19eb..595cb3e2 100644
--- a/R/disk.R
+++ b/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() %>%
diff --git a/R/eucast_rules.R b/R/eucast_rules.R
index 68373aa5..aa993396 100755
--- a/R/eucast_rules.R
+++ b/R/eucast_rules.R
@@ -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 %>%
diff --git a/R/ggplot_rsi.R b/R/ggplot_rsi.R
index e6b00af8..dcf4e072 100755
--- a/R/ggplot_rsi.R
+++ b/R/ggplot_rsi.R
@@ -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) %>%
diff --git a/R/guess_ab_col.R b/R/guess_ab_col.R
index 964b15fd..06d1b46f 100755
--- a/R/guess_ab_col.R
+++ b/R/guess_ab_col.R
@@ -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))
}
diff --git a/R/key_antibiotics.R b/R/key_antibiotics.R
index 967ed338..5acdce79 100755
--- a/R/key_antibiotics.R
+++ b/R/key_antibiotics.R
@@ -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')
}
diff --git a/R/like.R b/R/like.R
index 8b6c13de..daf4b9d9 100755
--- a/R/like.R
+++ b/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)
diff --git a/R/mdro.R b/R/mdro.R
index fd972a0c..9414bd4a 100755
--- a/R/mdro.R
+++ b/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"
}
diff --git a/R/mic.R b/R/mic.R
index 2f493951..32c64ad4 100755
--- a/R/mic.R
+++ b/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"))
}
diff --git a/R/mo.R b/R/mo.R
index 98ac0c0e..2f644a31 100755
--- a/R/mo.R
+++ b/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())
}
diff --git a/R/mo_property.R b/R/mo_property.R
index 83db2252..ef2211af 100755
--- a/R/mo_property.R
+++ b/R/mo_property.R
@@ -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],
diff --git a/R/mo_source.R b/R/mo_source.R
index 6a736b84..fc16819c 100644
--- a/R/mo_source.R
+++ b/R/mo_source.R
@@ -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"
diff --git a/R/p_symbol.R b/R/p_symbol.R
index 4254d15c..be4054d7 100755
--- a/R/p_symbol.R
+++ b/R/p_symbol.R
@@ -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] <- "*"
diff --git a/R/resistance_predict.R b/R/resistance_predict.R
index 1a7bef03..04b05fcc 100755
--- a/R/resistance_predict.R
+++ b/R/resistance_predict.R
@@ -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 {
diff --git a/R/rsi.R b/R/rsi.R
index 010ab632..c39d95cb 100755
--- a/R/rsi.R
+++ b/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))
}
diff --git a/R/rsi_calc.R b/R/rsi_calc.R
index dfc7acdb..7eb9fb0c 100755
--- a/R/rsi_calc.R
+++ b/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
diff --git a/codecov.yml b/codecov.yml
index 90034b66..2e550ab0 100644
--- a/codecov.yml
+++ b/codecov.yml
@@ -21,6 +21,7 @@
codecov:
require_ci_to_pass: no # allow fail
+ branch: master
comment: no
diff --git a/docs/404.html b/docs/404.html
index 5a1087c6..957e8dba 100644
--- a/docs/404.html
+++ b/docs/404.html
@@ -81,7 +81,7 @@
AMR (for R)
- 1.2.0.9033
+ 1.2.0.9034
diff --git a/docs/LICENSE-text.html b/docs/LICENSE-text.html
index 4acc9648..7c94fc60 100644
--- a/docs/LICENSE-text.html
+++ b/docs/LICENSE-text.html
@@ -81,7 +81,7 @@
AMR (for R)
- 1.2.0.9033
+ 1.2.0.9034
diff --git a/docs/articles/index.html b/docs/articles/index.html
index 3d18eab4..37a60b14 100644
--- a/docs/articles/index.html
+++ b/docs/articles/index.html
@@ -81,7 +81,7 @@
AMR (for R)
- 1.2.0.9033
+ 1.2.0.9034
diff --git a/docs/authors.html b/docs/authors.html
index 70b287a3..1326325d 100644
--- a/docs/authors.html
+++ b/docs/authors.html
@@ -81,7 +81,7 @@
AMR (for R)
- 1.2.0.9033
+ 1.2.0.9034
diff --git a/docs/index.html b/docs/index.html
index 53a85d4b..b3f81ac0 100644
--- a/docs/index.html
+++ b/docs/index.html
@@ -43,7 +43,7 @@
AMR (for R)
- 1.2.0.9033
+ 1.2.0.9034
diff --git a/docs/news/index.html b/docs/news/index.html
index 550b2693..5f8225cf 100644
--- a/docs/news/index.html
+++ b/docs/news/index.html
@@ -81,7 +81,7 @@
AMR (for R)
- 1.2.0.9033
+ 1.2.0.9034
@@ -229,13 +229,13 @@
Source: NEWS.md
-
-