P281424/AMR
1
0
Fork 0
mirror of https://github.com/msberends/AMR.git synced 2024-12-25 18:46:11 +01:00
Code Releases Activity

(v1.2.0.9034) code cleaning

Browse Source
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 Package: AMR
Version: 1.2.0.9033 Version: 1.2.0.9034
Date: 2020-07-12 Date: 2020-07-13
Title: Antimicrobial Resistance Analysis Title: Antimicrobial Resistance Analysis
Authors@R: c( Authors@R: c(
person(role = c("aut", "cre"), person(role = c("aut", "cre"),

4
NEWS.md
View File

@ -1,5 +1,5 @@
# AMR 1.2.0.9033 # AMR 1.2.0.9034
## <small>Last updated: 12-Jul-2020</small> ## <small>Last updated: 13-Jul-2020</small>
### New ### 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 * 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[!grepl(pattern = "^[0-9.,e-]+$", x = x)] <- NA_character_
x_formatted x_formatted
} }
# the actual working part # the actual working part
x <- as.double(x) x <- as.double(x)
if (is.null(digits)) { 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)) { if (is.ab(x)) {
return(x) return(x)
} }
initial_search <- is.null(list(...)$initial_search) initial_search <- is.null(list(...)$initial_search)
already_regex <- isTRUE(list(...)$already_regex) already_regex <- isTRUE(list(...)$already_regex)
if (all(toupper(x) %in% antibiotics$ab)) { if (all(toupper(x) %in% antibiotics$ab)) {
# valid AB code, but not yet right class # valid AB code, but not yet right class
return(structure(.Data = toupper(x), return(structure(.Data = toupper(x),
class = c("ab", "character"))) class = c("ab", "character")))
} }
x_bak <- x x_bak <- x
x <- toupper(x) x <- toupper(x)
# remove diacritics # remove diacritics
@ -117,7 +117,7 @@ as.ab <- function(x, flag_multiple_results = TRUE, ...) {
# replace text 'and' with a slash # replace text 'and' with a slash
x_bak_clean <- gsub(" AND ", "/", x_bak_clean) x_bak_clean <- gsub(" AND ", "/", x_bak_clean)
} }
x <- unique(x_bak_clean) x <- unique(x_bak_clean)
x_new <- rep(NA_character_, length(x)) x_new <- rep(NA_character_, length(x))
x_unknown <- character(0) 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) x_new[i] <- note_if_more_than_one_found(found, i, from_text)
next next
} }
# exact ATC code # exact ATC code
found <- antibiotics[which(antibiotics$atc == x[i]), ]$ab found <- antibiotics[which(antibiotics$atc == x[i]), ]$ab
if (length(found) > 0) { if (length(found) > 0) {
x_new[i] <- note_if_more_than_one_found(found, i, from_text) x_new[i] <- note_if_more_than_one_found(found, i, from_text)
next next
} }
# exact CID code # exact CID code
found <- antibiotics[which(antibiotics$cid == x[i]), ]$ab found <- antibiotics[which(antibiotics$cid == x[i]), ]$ab
if (length(found) > 0) { if (length(found) > 0) {
x_new[i] <- note_if_more_than_one_found(found, i, from_text) x_new[i] <- note_if_more_than_one_found(found, i, from_text)
next next
} }
# exact name # exact name
found <- antibiotics[which(toupper(antibiotics$name) == x[i]), ]$ab found <- antibiotics[which(toupper(antibiotics$name) == x[i]), ]$ab
if (length(found) > 0) { if (length(found) > 0) {
@ -188,13 +188,13 @@ as.ab <- function(x, flag_multiple_results = TRUE, ...) {
# exact LOINC code # exact LOINC code
loinc_found <- unlist(lapply(antibiotics$loinc, loinc_found <- unlist(lapply(antibiotics$loinc,
function(s) x[i] %in% s)) function(s) x[i] %in% s))
found <- antibiotics$ab[loinc_found == TRUE] found <- antibiotics$ab[loinc_found == TRUE]
if (length(found) > 0) { if (length(found) > 0) {
x_new[i] <- note_if_more_than_one_found(found, i, from_text) x_new[i] <- note_if_more_than_one_found(found, i, from_text)
next next
} }
# exact synonym # exact synonym
synonym_found <- unlist(lapply(antibiotics$synonyms, synonym_found <- unlist(lapply(antibiotics$synonyms,
function(s) x[i] %in% toupper(s))) 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) x_new[i] <- note_if_more_than_one_found(found, i, from_text)
next next
} }
# exact abbreviation # exact abbreviation
abbr_found <- unlist(lapply(antibiotics$abbreviations, abbr_found <- unlist(lapply(antibiotics$abbreviations,
function(a) x[i] %in% toupper(a))) 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) x_new[i] <- note_if_more_than_one_found(found, i, from_text)
next next
} }
# allow characters that resemble others, but only continue when having more than 3 characters # allow characters that resemble others, but only continue when having more than 3 characters
if (nchar(x[i]) <= 3) { if (nchar(x[i]) <= 3) {
x_unknown <- c(x_unknown, x_bak[x[i] == x_bak_clean][1]) 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("(O|0)", "(O|0)+", x_spelling)
x_spelling <- gsub("++", "+", x_spelling, fixed = TRUE) x_spelling <- gsub("++", "+", x_spelling, fixed = TRUE)
} }
# try if name starts with it # try if name starts with it
found <- antibiotics[which(antibiotics$name %like% paste0("^", x_spelling)), ]$ab found <- antibiotics[which(antibiotics$name %like% paste0("^", x_spelling)), ]$ab
if (length(found) > 0) { 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) x_new[i] <- note_if_more_than_one_found(found, i, from_text)
next next
} }
# and try if any synonym starts with it # and try if any synonym starts with it
synonym_found <- unlist(lapply(antibiotics$synonyms, synonym_found <- unlist(lapply(antibiotics$synonyms,
function(s) any(s %like% paste0("^", x_spelling)))) 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) x_new[i] <- note_if_more_than_one_found(found, i, from_text)
next next
} }
# INITIAL SEARCH - More uncertain results ---- # INITIAL SEARCH - More uncertain results ----
if (initial_search == TRUE) { 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) x_new[i] <- note_if_more_than_one_found(found, i, from_text)
next next
} }
# first 5 except for cephalosporins, then first 7 (those cephalosporins all start quite the same!) # 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)) found <- suppressWarnings(as.ab(substr(x[i], 1, 5), initial_search = FALSE))
if (!is.na(found) && !ab_group(found, initial_search = FALSE) %like% "cephalosporins") { 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) x_new[i] <- note_if_more_than_one_found(found, i, from_text)
next next
} }
# make all vowels facultative # make all vowels facultative
search_str <- gsub("([AEIOUY])", "\\1*", x[i]) search_str <- gsub("([AEIOUY])", "\\1*", x[i])
found <- suppressWarnings(as.ab(search_str, initial_search = FALSE, already_regex = TRUE)) 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) { if (initial_search == TRUE) {
close(progress) close(progress)
} }
# take failed ATC codes apart from rest # 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_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] x_unknown <- x_unknown[!x_unknown %in% x_unknown_ATCs]
@ -446,15 +446,15 @@ as.ab <- function(x, flag_multiple_results = TRUE, ...) {
".", ".",
call. = FALSE) call. = FALSE)
} }
x_result <- data.frame(x = x_bak_clean, stringsAsFactors = 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") %>% left_join(data.frame(x = x, x_new = x_new, stringsAsFactors = FALSE), by = "x") %>%
pull(x_new) pull(x_new)
if (length(x_result) == 0) { if (length(x_result) == 0) {
x_result <- NA_character_ x_result <- NA_character_
} }
structure(.Data = x_result, structure(.Data = x_result,
class = c("ab", "character")) 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(names_atc)],
text_split[text_split %like_case% to_regex(synonyms_part1)], text_split[text_split %like_case% to_regex(synonyms_part1)],
text_split[text_split %like_case% to_regex(synonyms_part2)]) 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_if(length(property) != 1L, "'property' must be of length 1.")
stop_ifnot(property %in% colnames(antibiotics), stop_ifnot(property %in% colnames(antibiotics),
"invalid property: '", property, "' - use a column name of the `antibiotics` data set") "invalid property: '", property, "' - use a column name of the `antibiotics` data set")
translate_AMR(ab_validate(x = x, property = property, ...), language = language) 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) x <- as.POSIXlt(x)
reference <- as.POSIXlt(reference) reference <- as.POSIXlt(reference)
# from https://stackoverflow.com/a/25450756/4575331 # from https://stackoverflow.com/a/25450756/4575331
years_gap <- reference$year - x$year years_gap <- reference$year - x$year
ages <- ifelse(reference$mon < x$mon | (reference$mon == x$mon & reference$mday < x$mday), ages <- ifelse(reference$mon < x$mon | (reference$mon == x$mon & reference$mday < x$mday),
as.integer(years_gap - 1), as.integer(years_gap - 1),
as.integer(years_gap)) as.integer(years_gap))
# add decimals # add decimals
if (exact == TRUE) { if (exact == TRUE) {
# get dates of `x` when `x` would have the year of `reference` # 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 # and finally add to ages
ages <- ages + mod ages <- ages + mod
} }
if (any(ages < 0, na.rm = TRUE)) { if (any(ages < 0, na.rm = TRUE)) {
ages[ages < 0] <- NA ages[ages < 0] <- NA
warning("NAs introduced for ages below 0.") 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)) { if (isTRUE(na.rm)) {
ages <- ages[!is.na(ages)] ages <- ages[!is.na(ages)]
} }
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)] split_at <- split_at[!is.na(split_at)]
stop_if(length(split_at) == 1, "invalid value for `split_at`") # only 0 is available stop_if(length(split_at) == 1, "invalid value for `split_at`") # only 0 is available
# turn input values to 'split_at' indices # turn input values to 'split_at' indices
y <- x y <- x
labs <- split_at labs <- split_at
@ -171,10 +171,10 @@ age_groups <- function(x, split_at = c(12, 25, 55, 75), na.rm = FALSE) {
# create labels # create labels
labs[i - 1] <- paste0(unique(c(split_at[i - 1], split_at[i] - 1)), collapse = "-") labs[i - 1] <- paste0(unique(c(split_at[i - 1], split_at[i] - 1)), collapse = "-")
} }
# last category # last category
labs[length(labs)] <- paste0(split_at[length(split_at)], "+") labs[length(labs)] <- paste0(split_at[length(split_at)], "+")
agegroups <- factor(labs[y], levels = labs, ordered = TRUE) agegroups <- factor(labs[y], levels = labs, ordered = TRUE)
if (isTRUE(na.rm)) { 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_table <- import_fn("html_table", "rvest")
html_text <- import_fn("html_text", "rvest") html_text <- import_fn("html_text", "rvest")
read_html <- import_fn("read_html", "xml2") read_html <- import_fn("read_html", "xml2")
check_dataset_integrity() check_dataset_integrity()
if (!all(atc_code %in% antibiotics)) { if (!all(atc_code %in% antibiotics)) {
@ -95,25 +95,25 @@ atc_online_property <- function(atc_code,
message("There appears to be no internet connection.") message("There appears to be no internet connection.")
return(rep(NA, length(atc_code))) return(rep(NA, length(atc_code)))
} }
stop_if(length(property) != 1L, "`property` must be of length 1") stop_if(length(property) != 1L, "`property` must be of length 1")
stop_if(length(administration) != 1L, "`administration` must be of length 1") stop_if(length(administration) != 1L, "`administration` must be of length 1")
# also allow unit as property # also allow unit as property
if (property %like% "unit") { if (property %like% "unit") {
property <- "U" property <- "U"
} }
# validation of properties # validation of properties
valid_properties <- c("ATC", "Name", "DDD", "U", "Adm.R", "Note", "groups") valid_properties <- c("ATC", "Name", "DDD", "U", "Adm.R", "Note", "groups")
valid_properties.bak <- valid_properties valid_properties.bak <- valid_properties
property <- tolower(property) property <- tolower(property)
valid_properties <- tolower(valid_properties) valid_properties <- tolower(valid_properties)
stop_ifnot(property %in% valid_properties, stop_ifnot(property %in% valid_properties,
"Invalid `property`, use one of ", paste(valid_properties.bak, collapse = ", ")) "Invalid `property`, use one of ", paste(valid_properties.bak, collapse = ", "))
if (property == "ddd") { if (property == "ddd") {
returnvalue <- rep(NA_real_, length(atc_code)) returnvalue <- rep(NA_real_, length(atc_code))
} else if (property == "groups") { } else if (property == "groups") {
@ -121,22 +121,22 @@ atc_online_property <- function(atc_code,
} else { } else {
returnvalue <- rep(NA_character_, length(atc_code)) returnvalue <- rep(NA_character_, length(atc_code))
} }
progress <- progress_estimated(n = length(atc_code), 3) progress <- progress_estimated(n = length(atc_code), 3)
on.exit(close(progress)) on.exit(close(progress))
for (i in seq_len(length(atc_code))) { for (i in seq_len(length(atc_code))) {
progress$tick() progress$tick()
atc_url <- sub("%s", atc_code[i], url, fixed = TRUE) atc_url <- sub("%s", atc_code[i], url, fixed = TRUE)
if (property == "groups") { if (property == "groups") {
tbl <- read_html(atc_url) %>% tbl <- read_html(atc_url) %>%
html_node("#content") %>% html_node("#content") %>%
html_children() %>% html_children() %>%
html_node("a") html_node("a")
# get URLS of items # get URLS of items
hrefs <- tbl %>% html_attr("href") hrefs <- tbl %>% html_attr("href")
# get text of items # get text of items
@ -146,22 +146,22 @@ atc_online_property <- function(atc_code,
# last one is antibiotics, skip it # last one is antibiotics, skip it
texts <- texts[seq_len(length(texts)) - 1] texts <- texts[seq_len(length(texts)) - 1]
returnvalue <- c(list(texts), returnvalue) returnvalue <- c(list(texts), returnvalue)
} else { } else {
tbl <- read_html(atc_url) %>% tbl <- read_html(atc_url) %>%
html_nodes("table") %>% html_nodes("table") %>%
html_table(header = TRUE) %>% html_table(header = TRUE) %>%
as.data.frame(stringsAsFactors = FALSE) as.data.frame(stringsAsFactors = FALSE)
# case insensitive column names # case insensitive column names
colnames(tbl) <- gsub("^atc.*", "atc", tolower(colnames(tbl))) colnames(tbl) <- gsub("^atc.*", "atc", tolower(colnames(tbl)))
if (length(tbl) == 0) { if (length(tbl) == 0) {
warning("ATC not found: ", atc_code[i], ". Please check ", atc_url, ".", call. = FALSE) warning("ATC not found: ", atc_code[i], ". Please check ", atc_url, ".", call. = FALSE)
returnvalue[i] <- NA returnvalue[i] <- NA
next next
} }
if (property %in% c("atc", "name")) { if (property %in% c("atc", "name")) {
# ATC and name are only in first row # ATC and name are only in first row
returnvalue[i] <- tbl[1, property] returnvalue[i] <- tbl[1, property]
@ -179,11 +179,11 @@ atc_online_property <- function(atc_code,
} }
} }
} }
if (property == "groups" & length(returnvalue) == 1) { if (property == "groups" & length(returnvalue) == 1) {
returnvalue <- returnvalue[[1]] returnvalue <- returnvalue[[1]]
} }
returnvalue returnvalue
} }

10
R/availability.R
View File

@ -55,7 +55,7 @@ availability <- function(tbl, width = NULL) {
R_print <- character(length(R)) R_print <- character(length(R))
R_print[!is.na(R)] <- percentage(R[!is.na(R)]) R_print[!is.na(R)] <- percentage(R[!is.na(R)])
R_print[is.na(R)] <- "" R_print[is.na(R)] <- ""
if (is.null(width)) { if (is.null(width)) {
width <- options()$width - width <- options()$width -
(max(nchar(colnames(tbl))) + (max(nchar(colnames(tbl))) +
@ -69,19 +69,19 @@ availability <- function(tbl, width = NULL) {
5) 5)
width <- width / 2 width <- width / 2
} }
if (length(R[is.na(R)]) == ncol(tbl)) { if (length(R[is.na(R)]) == ncol(tbl)) {
width <- width * 2 + 10 width <- width * 2 + 10
} }
x_chars_R <- strrep("#", round(width * R, digits = 2)) x_chars_R <- strrep("#", round(width * R, digits = 2))
x_chars_SI <- strrep("-", width - nchar(x_chars_R)) x_chars_SI <- strrep("-", width - nchar(x_chars_R))
vis_resistance <- paste0("|", x_chars_R, x_chars_SI, "|") vis_resistance <- paste0("|", x_chars_R, x_chars_SI, "|")
vis_resistance[is.na(R)] <- "" vis_resistance[is.na(R)] <- ""
x_chars <- strrep("#", round(x, digits = 2) / (1 / width)) x_chars <- strrep("#", round(x, digits = 2) / (1 / width))
x_chars_empty <- strrep("-", width - nchar(x_chars)) x_chars_empty <- strrep("-", width - nchar(x_chars))
df <- data.frame(count = n, df <- data.frame(count = n,
available = percentage(x), available = percentage(x),
visual_availabilty = paste0("|", x_chars, x_chars_empty, "|"), 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] x <- x[, c(col_mo, names(which(sapply(x, is.rsi)))), drop = FALSE]
unique_mo <- sort(unique(x[, col_mo, drop = TRUE])) unique_mo <- sort(unique(x[, col_mo, drop = TRUE]))
out <- data.frame( out <- data.frame(
mo = character(0), mo = character(0),
ab = character(0), ab = character(0),
@ -83,7 +83,7 @@ bug_drug_combinations <- function(x,
I = integer(0), I = integer(0),
R = integer(0), R = integer(0),
total = integer(0)) total = integer(0))
for (i in seq_len(length(unique_mo))) { for (i in seq_len(length(unique_mo))) {
# filter on MO group and only select R/SI columns # 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] 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) total = merged$S + merged$I + merged$R)
out <- rbind(out, out_group) out <- rbind(out, out_group)
} }
structure(.Data = out, class = c("bug_drug_combinations", x_class)) structure(.Data = out, class = c("bug_drug_combinations", x_class))
} }
@ -172,11 +172,11 @@ format.bug_drug_combinations <- function(x,
y <- y %>% y <- y %>%
create_var(txt = paste0(percentage(y$isolates / y$total, decimal.mark = decimal.mark, big.mark = big.mark), 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$isolates, big.mark = big.mark)), "/",
trimws(format(y$total, big.mark = big.mark)), ")")) %>% trimws(format(y$total, big.mark = big.mark)), ")")) %>%
select(ab, ab_txt, mo, txt) %>% select(ab, ab_txt, mo, txt) %>%
arrange(mo) arrange(mo)
# replace tidyr::pivot_wider() from here # replace tidyr::pivot_wider() from here
for (i in unique(y$mo)) { for (i in unique(y$mo)) {
mo_group <- y[which(y$mo == i), c("ab", "txt")] 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) { select_ab_vars <- function(.data) {
.data[, c("ab_group", "ab_txt", colnames(.data)[!colnames(.data) %in% c("ab_group", "ab_txt", "ab")])] .data[, c("ab_group", "ab_txt", colnames(.data)[!colnames(.data) %in% c("ab_group", "ab_txt", "ab")])]
} }
y <- y %>% y <- y %>%
create_var(ab_group = ab_group(y$ab, language = language)) %>% create_var(ab_group = ab_group(y$ab, language = language)) %>%
select_ab_vars() %>% select_ab_vars() %>%
arrange(ab_group, ab_txt) arrange(ab_group, ab_txt)
y <- y %>% y <- y %>%
create_var(ab_group = ifelse(y$ab_group != lag(y$ab_group) | is.na(lag(y$ab_group)), y$ab_group, "")) 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) { if (add_ab_group == FALSE) {
y <- y %>% y <- y %>%
select(-ab_group) %>% select(-ab_group) %>%

4
R/catalogue_of_life.R
View File

@ -102,7 +102,7 @@ catalogue_of_life_version <- function() {
list( list(
n_total_species = nrow(microorganisms), n_total_species = nrow(microorganisms),
n_total_synonyms = nrow(microorganisms.old))) n_total_synonyms = nrow(microorganisms.old)))
structure(.Data = lst, structure(.Data = lst,
class = c("catalogue_of_life_version", "list")) 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", " Available at: ", lst$catalogue_of_life$url, "\n",
" Number of included species: ", format(lst$catalogue_of_life$n, big.mark = ","), "\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, " (", 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", " 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", " 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", "=> 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(), language = get_locale(),
combine_SI = TRUE, combine_SI = TRUE,
combine_IR = FALSE) { combine_IR = FALSE) {
rsi_calc_df(type = "count", rsi_calc_df(type = "count",
data = data, data = data,
translate_ab = translate_ab, 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 <- x[!is.na(x)]
} }
x.bak <- x x.bak <- x
na_before <- length(x[is.na(x)]) na_before <- length(x[is.na(x)])
# force it to be integer # force it to be integer
x <- suppressWarnings(as.integer(x)) x <- suppressWarnings(as.integer(x))
# disks can never be less than 6 mm (size of smallest disk) or more than 50 mm # disks can never be less than 6 mm (size of smallest disk) or more than 50 mm
x[x < 6 | x > 50] <- NA_integer_ x[x < 6 | x > 50] <- NA_integer_
na_after <- length(x[is.na(x)]) na_after <- length(x[is.na(x)])
if (na_before != na_after) { if (na_before != na_after) {
list_missing <- x.bak[is.na(x) & !is.na(x.bak)] %>% list_missing <- x.bak[is.na(x) & !is.na(x.bak)] %>%
unique() %>% 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", "")) left_join_microorganisms(by = col_mo, suffix = c("_oldcols", ""))
x$gramstain <- mo_gramstain(x[, col_mo, drop = TRUE], language = NULL) x$gramstain <- mo_gramstain(x[, col_mo, drop = TRUE], language = NULL)
x$genus_species <- paste(x$genus, x$species) x$genus_species <- paste(x$genus, x$species)
if (ab_missing(AMP) & !ab_missing(AMX)) { if (ab_missing(AMP) & !ab_missing(AMX)) {
# ampicillin column is missing, but amoxicillin is available # 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."))) 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) { if (info == TRUE & !rule_group_current %like% "other" & eucast_notification_shown == FALSE) {
cat(paste0("\n", font_grey(strrep("-", options()$width - 1)), cat(paste0("\n", font_grey(strrep("-", options()$width - 1)),
"\nRules by the ", font_bold("European Committee on Antimicrobial Susceptibility Testing (EUCAST)"), "\nRules by the ", font_bold("European Committee on Antimicrobial Susceptibility Testing (EUCAST)"),
"\n", font_blue("http://eucast.org/"), "\n")) "\n", font_blue("http://eucast.org/"), "\n"))
eucast_notification_shown <- TRUE eucast_notification_shown <- TRUE
} }
@ -843,9 +843,9 @@ eucast_rules <- function(x,
cat(paste0("\n", font_grey(strrep("-", options()$width - 1)), "\n")) cat(paste0("\n", font_grey(strrep("-", options()$width - 1)), "\n"))
cat(font_bold(paste("The rules", paste0(wouldve, "affected"), cat(font_bold(paste("The rules", paste0(wouldve, "affected"),
formatnr(n_distinct(verbose_info$row)), formatnr(n_distinct(verbose_info$row)),
"out of", formatnr(nrow(x_original)), "out of", formatnr(nrow(x_original)),
"rows, making a total of", formatnr(nrow(verbose_info)), "edits\n"))) "rows, making a total of", formatnr(nrow(verbose_info)), "edits\n")))
n_added <- verbose_info %>% filter(is.na(old)) %>% nrow() n_added <- verbose_info %>% filter(is.na(old)) %>% nrow()
n_changed <- 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 ", cat(colour(paste0("=> ", wouldve, "added ",
font_bold(formatnr(verbose_info %>% font_bold(formatnr(verbose_info %>%
filter(is.na(old)) %>% filter(is.na(old)) %>%
nrow()), "test results"), nrow()), "test results"),
"\n"))) "\n")))
if (n_added > 0) { if (n_added > 0) {
added_summary <- verbose_info %>% added_summary <- verbose_info %>%
@ -882,8 +882,8 @@ eucast_rules <- function(x,
} }
cat(colour(paste0("=> ", wouldve, "changed ", cat(colour(paste0("=> ", wouldve, "changed ",
font_bold(formatnr(verbose_info %>% font_bold(formatnr(verbose_info %>%
filter(!is.na(old)) %>% filter(!is.na(old)) %>%
nrow()), "test results"), nrow()), "test results"),
"\n"))) "\n")))
if (n_changed > 0) { if (n_changed > 0) {
changed_summary <- verbose_info %>% changed_summary <- verbose_info %>%

6
R/ggplot_rsi.R
View File

@ -387,9 +387,9 @@ labels_rsi_count <- function(position = NULL,
lineheight = 0.75, lineheight = 0.75,
data = function(x) { data = function(x) {
transformed <- rsi_df(data = x, transformed <- rsi_df(data = x,
translate_ab = translate_ab, translate_ab = translate_ab,
combine_SI = combine_SI, combine_SI = combine_SI,
combine_IR = combine_IR) combine_IR = combine_IR)
transformed$gr <- transformed[, x_name, drop = TRUE] transformed$gr <- transformed[, x_name, drop = TRUE]
transformed %>% transformed %>%
group_by(gr) %>% 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")) return(as.name("guess_ab_col"))
} }
stop_ifnot(is.data.frame(x), "`x` must be a data.frame") stop_ifnot(is.data.frame(x), "`x` must be a data.frame")
if (length(search_string) > 1) { if (length(search_string) > 1) {
warning("argument 'search_string' has length > 1 and only the first element will be used") warning("argument 'search_string' has length > 1 and only the first element will be used")
search_string <- search_string[1] search_string <- search_string[1]
} }
search_string <- as.character(search_string) search_string <- as.character(search_string)
if (search_string %in% colnames(x)) { if (search_string %in% colnames(x)) {
ab_result <- search_string ab_result <- search_string
} else { } else {
search_string.ab <- suppressWarnings(as.ab(search_string)) search_string.ab <- suppressWarnings(as.ab(search_string))
if (search_string.ab %in% colnames(x)) { if (search_string.ab %in% colnames(x)) {
ab_result <- colnames(x)[colnames(x) == search_string.ab][1L] 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))))) { } 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] ab_result <- colnames(x)[tolower(colnames(x)) %in% tolower(unlist(ab_property(search_string.ab, "abbreviations", language = NULL)))][1L]
} else { } else {
# sort colnames on length - longest first # sort colnames on length - longest first
cols <- colnames(x[, x %>% colnames() %>% nchar() %>% order() %>% rev()]) 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] ab_result <- ab_result[!is.na(ab_result)][1L]
} }
} }
if (length(ab_result) == 0) { if (length(ab_result) == 0) {
if (verbose == TRUE) { if (verbose == TRUE) {
message(paste0("No column found as input for `", search_string, 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 { } else {
if (verbose == TRUE) { if (verbose == TRUE) {
message(font_blue(paste0("NOTE: Using column `", font_bold(ab_result), "` as input for `", search_string, 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) return(ab_result)
} }
@ -111,7 +111,7 @@ get_column_abx <- function(x,
hard_dependencies = NULL, hard_dependencies = NULL,
verbose = FALSE, verbose = FALSE,
...) { ...) {
message(font_blue("NOTE: Auto-guessing columns suitable for analysis"), appendLF = FALSE) message(font_blue("NOTE: Auto-guessing columns suitable for analysis"), appendLF = FALSE)
x <- as.data.frame(x, stringsAsFactors = 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_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 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), df_trans <- data.frame(colnames = colnames(x),
abcode = suppressWarnings(as.ab(colnames(x)))) abcode = suppressWarnings(as.ab(colnames(x))))
df_trans <- df_trans[!is.na(df_trans$abcode), ] df_trans <- df_trans[!is.na(df_trans$abcode), ]
x <- as.character(df_trans$colnames) x <- as.character(df_trans$colnames)
names(x) <- df_trans$abcode names(x) <- df_trans$abcode
# add from self-defined dots (...): # add from self-defined dots (...):
# such as get_column_abx(example_isolates %>% rename(thisone = AMX), amox = "thisone") # such as get_column_abx(example_isolates %>% rename(thisone = AMX), amox = "thisone")
dots <- list(...) 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 # delete NAs, this will make e.g. eucast_rules(... TMP = NULL) work to prevent TMP from being used
x <- x[!is.na(x)] x <- x[!is.na(x)]
} }
if (length(x) == 0) { if (length(x) == 0) {
message(font_blue("No columns found.")) message(font_blue("No columns found."))
return(x) return(x)
@ -179,16 +179,16 @@ get_column_abx <- function(x,
# succeeded with auto-guessing # succeeded with auto-guessing
message(font_blue("OK.")) message(font_blue("OK."))
for (i in seq_len(length(x))) { for (i in seq_len(length(x))) {
if (verbose == TRUE & !names(x[i]) %in% names(duplicates)) { 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], 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)) { if (names(x[i]) %in% names(duplicates)) {
warning(font_red(paste0("Using column `", font_bold(x[i]), "` as input for `", names(x)[i], 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), "` (", ab_name(names(x)[i], tolower = TRUE, language = NULL),
"), although it was matched for multiple antibiotics or columns.")), "), although it was matched for multiple antibiotics or columns.")),
call. = FALSE, call. = FALSE,
immediate. = verbose) immediate. = verbose)
} }
@ -210,8 +210,8 @@ get_column_abx <- function(x,
# missing a soft dependency may lower the reliability # missing a soft dependency may lower the reliability
missing <- soft_dependencies[!soft_dependencies %in% names(x)] missing <- soft_dependencies[!soft_dependencies %in% names(x)]
missing_txt <- paste(paste0(ab_name(missing, tolower = TRUE, language = NULL), missing_txt <- paste(paste0(ab_name(missing, tolower = TRUE, language = NULL),
" (", font_bold(missing, collapse = NULL), ")"), " (", font_bold(missing, collapse = NULL), ")"),
collapse = ", ") collapse = ", ")
message(font_blue("NOTE: Reliability would be improved if these antimicrobial results would be available too:", message(font_blue("NOTE: Reliability would be improved if these antimicrobial results would be available too:",
missing_txt)) missing_txt))
} }

72
R/key_antibiotics.R
View File

@ -130,14 +130,14 @@ key_antibiotics <- function(x,
warnings <- dots[which(dots.names == "info")] warnings <- dots[which(dots.names == "info")]
} }
} }
# try to find columns based on type # try to find columns based on type
# -- mo # -- mo
if (is.null(col_mo)) { if (is.null(col_mo)) {
col_mo <- search_type_in_df(x = x, type = "mo") col_mo <- search_type_in_df(x = x, type = "mo")
} }
stop_if(is.null(col_mo), "`col_mo` must be set") stop_if(is.null(col_mo), "`col_mo` must be set")
# check columns # check columns
col.list <- c(universal_1, universal_2, universal_3, universal_4, universal_5, universal_6, 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, GramPos_1, GramPos_2, GramPos_3, GramPos_4, GramPos_5, GramPos_6,
@ -170,7 +170,7 @@ key_antibiotics <- function(x,
} }
col.list col.list
} }
col.list <- check_available_columns(x = x, col.list = col.list, warnings = warnings) col.list <- check_available_columns(x = x, col.list = col.list, warnings = warnings)
universal_1 <- col.list[universal_1] universal_1 <- col.list[universal_1]
universal_2 <- col.list[universal_2] universal_2 <- col.list[universal_2]
@ -190,28 +190,28 @@ key_antibiotics <- function(x,
GramNeg_4 <- col.list[GramNeg_4] GramNeg_4 <- col.list[GramNeg_4]
GramNeg_5 <- col.list[GramNeg_5] GramNeg_5 <- col.list[GramNeg_5]
GramNeg_6 <- col.list[GramNeg_6] GramNeg_6 <- col.list[GramNeg_6]
universal <- c(universal_1, universal_2, universal_3, universal <- c(universal_1, universal_2, universal_3,
universal_4, universal_5, universal_6) universal_4, universal_5, universal_6)
gram_positive <- c(universal, gram_positive <- c(universal,
GramPos_1, GramPos_2, GramPos_3, GramPos_1, GramPos_2, GramPos_3,
GramPos_4, GramPos_5, GramPos_6) GramPos_4, GramPos_5, GramPos_6)
gram_positive <- gram_positive[!is.null(gram_positive)] gram_positive <- gram_positive[!is.null(gram_positive)]
gram_positive <- gram_positive[!is.na(gram_positive)] gram_positive <- gram_positive[!is.na(gram_positive)]
if (length(gram_positive) < 12) { if (length(gram_positive) < 12) {
warning("only using ", length(gram_positive), " different antibiotics as key antibiotics for Gram-positives. See ?key_antibiotics.", call. = FALSE) warning("only using ", length(gram_positive), " different antibiotics as key antibiotics for Gram-positives. See ?key_antibiotics.", call. = FALSE)
} }
gram_negative <- c(universal, gram_negative <- c(universal,
GramNeg_1, GramNeg_2, GramNeg_3, GramNeg_1, GramNeg_2, GramNeg_3,
GramNeg_4, GramNeg_5, GramNeg_6) GramNeg_4, GramNeg_5, GramNeg_6)
gram_negative <- gram_negative[!is.null(gram_negative)] gram_negative <- gram_negative[!is.null(gram_negative)]
gram_negative <- gram_negative[!is.na(gram_negative)] gram_negative <- gram_negative[!is.na(gram_negative)]
if (length(gram_negative) < 12) { if (length(gram_negative) < 12) {
warning("only using ", length(gram_negative), " different antibiotics as key antibiotics for Gram-negatives. See ?key_antibiotics.", call. = FALSE) 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 <- as.data.frame(x, stringsAsFactors = FALSE)
x[, col_mo] <- as.mo(x[, col_mo, drop = TRUE]) x[, col_mo] <- as.mo(x[, col_mo, drop = TRUE])
x$gramstain <- mo_gramstain(x[, col_mo, drop = TRUE], language = NULL) 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 = "")), FUN = function(x) paste(x, collapse = "")),
error = function(e) paste0(rep(".", 12), collapse = "")), error = function(e) paste0(rep(".", 12), collapse = "")),
x$key_ab) x$key_ab)
# format # format
key_abs <- toupper(gsub("[^SIR]", ".", gsub("(NA|NULL)", ".", x$key_ab))) key_abs <- toupper(gsub("[^SIR]", ".", gsub("(NA|NULL)", ".", x$key_ab)))
if (n_distinct(key_abs) == 1) { if (n_distinct(key_abs) == 1) {
warning("No distinct key antibiotics determined.", call. = FALSE) warning("No distinct key antibiotics determined.", call. = FALSE)
} }
key_abs key_abs
} }
#' @rdname key_antibiotics #' @rdname key_antibiotics
@ -255,72 +255,72 @@ key_antibiotics_equal <- function(y,
# y is active row, z is lag # y is active row, z is lag
x <- y x <- y
y <- z y <- z
type <- type[1] type <- type[1]
stop_ifnot(length(x) == length(y), "length of `x` and `y` must be equal") 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 # only show progress bar on points or when at least 5000 isolates
info_needed <- info == TRUE & (type == "points" | length(x) > 5000) info_needed <- info == TRUE & (type == "points" | length(x) > 5000)
result <- logical(length(x)) result <- logical(length(x))
if (info_needed == TRUE) { if (info_needed == TRUE) {
p <- progress_estimated(length(x)) p <- progress_estimated(length(x))
on.exit(close(p)) on.exit(close(p))
} }
for (i in seq_len(length(x))) { for (i in seq_len(length(x))) {
if (info_needed == TRUE) { if (info_needed == TRUE) {
p$tick() p$tick()
} }
if (is.na(x[i])) { if (is.na(x[i])) {
x[i] <- "" x[i] <- ""
} }
if (is.na(y[i])) { if (is.na(y[i])) {
y[i] <- "" y[i] <- ""
} }
if (x[i] == y[i]) { if (x[i] == y[i]) {
result[i] <- TRUE result[i] <- TRUE
} else if (nchar(x[i]) != nchar(y[i])) { } else if (nchar(x[i]) != nchar(y[i])) {
result[i] <- FALSE result[i] <- FALSE
} else { } else {
x_split <- strsplit(x[i], "")[[1]] x_split <- strsplit(x[i], "")[[1]]
y_split <- strsplit(y[i], "")[[1]] y_split <- strsplit(y[i], "")[[1]]
if (type == "keyantibiotics") { if (type == "keyantibiotics") {
if (ignore_I == TRUE) { if (ignore_I == TRUE) {
x_split[x_split == "I"] <- "." x_split[x_split == "I"] <- "."
y_split[y_split == "I"] <- "." y_split[y_split == "I"] <- "."
} }
y_split[x_split == "."] <- "." y_split[x_split == "."] <- "."
x_split[y_split == "."] <- "." x_split[y_split == "."] <- "."
result[i] <- all(x_split == y_split) result[i] <- all(x_split == y_split)
} else if (type == "points") { } else if (type == "points") {
# count points for every single character: # count points for every single character:
# - no change is 0 points # - no change is 0 points
# - I <-> S|R is 0.5 point # - I <-> S|R is 0.5 point
# - S|R <-> R|S is 1 point # - S|R <-> R|S is 1 point
# use the levels of as.rsi (S = 1, I = 2, R = 3) # use the levels of as.rsi (S = 1, I = 2, R = 3)
suppressWarnings(x_split <- x_split %>% as.rsi() %>% as.double()) suppressWarnings(x_split <- x_split %>% as.rsi() %>% as.double())
suppressWarnings(y_split <- y_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 points <- (x_split - y_split) %>% abs() %>% sum(na.rm = TRUE) / 2
result[i] <- points >= points_threshold result[i] <- points >= points_threshold
} else { } else {
stop("`", type, '` is not a valid value for type, must be "points" or "keyantibiotics". See ?key_antibiotics') 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) return(res)
} }
} }
# the regular way how grepl works; just one pattern against one or more x # the regular way how grepl works; just one pattern against one or more x
if (is.factor(x)) { if (is.factor(x)) {
as.integer(x) %in% base::grep(pattern, levels(x), ignore.case = FALSE, fixed = fixed) 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 # allow pct_required_classes = 75 -> pct_required_classes = 0.75
pct_required_classes <- pct_required_classes / 100 pct_required_classes <- pct_required_classes / 100
} }
if (!is.null(list(...)$country)) { if (!is.null(list(...)$country)) {
warning("Using `country` is deprecated, use `guideline` instead. Please see ?mdro.", call. = FALSE) warning("Using `country` is deprecated, use `guideline` instead. Please see ?mdro.", call. = FALSE)
guideline <- list(...)$country guideline <- list(...)$country
@ -145,7 +145,7 @@ mdro <- function(x,
} }
if (is.null(col_mo) & guideline$code == "tb") { if (is.null(col_mo) & guideline$code == "tb") {
message(font_blue("NOTE: No column found as input for `col_mo`,", 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") x$mo <- as.mo("Mycobacterium tuberculosis")
col_mo <- "mo" col_mo <- "mo"
} }
@ -470,7 +470,7 @@ mdro <- function(x,
} }
x_transposed <- as.list(as.data.frame(t(x[, cols, drop = FALSE]))) 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 <- 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] rows <- rows[rows %in% row_filter]
x[rows, "MDRO"] <<- to x[rows, "MDRO"] <<- to
x[rows, "reason"] <<- paste0(any_all, " of the required antibiotics ", ifelse(any_all == "any", "is", "are"), " R") 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) { if (verbose == TRUE) {
x[rows, "columns_nonsusceptible"] <<- sapply(rows, x[rows, "columns_nonsusceptible"] <<- sapply(rows,
function(row, group_vct = lst_vector) { function(row, group_vct = lst_vector) {
cols_nonsus <- sapply(x[row, group_vct, drop = FALSE], function(y) y %in% search_result) cols_nonsus <- sapply(x[row, group_vct, drop = FALSE], function(y) y %in% search_result)
paste(sort(names(cols_nonsus)[cols_nonsus]), collapse = ", ") paste(sort(names(cols_nonsus)[cols_nonsus]), collapse = ", ")
}) })
} }
x[rows, "classes_affected"] <<- sapply(rows, x[rows, "classes_affected"] <<- sapply(rows,
function(row, group_tbl = lst) { function(row, group_tbl = lst) {
sum(sapply(group_tbl, sum(sapply(group_tbl,
function(group) { function(group) {
any(unlist(x[row, group[!is.na(group)], drop = TRUE]) %in% search_result, na.rm = TRUE) any(unlist(x[row, group[!is.na(group)], drop = TRUE]) %in% search_result, na.rm = TRUE)
}), }),
na.rm = TRUE) na.rm = TRUE)
}) })
# for PDR; all agents are R (or I if combine_SI = FALSE) # 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]))) 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)) 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) { if (info == TRUE) {
@ -523,7 +523,7 @@ mdro <- function(x,
x$row_number <- seq_len(nrow(x)) x$row_number <- seq_len(nrow(x))
x$reason <- paste0("not covered by ", toupper(guideline$code), " guideline") x$reason <- paste0("not covered by ", toupper(guideline$code), " guideline")
x$columns_nonsusceptible <- "" x$columns_nonsusceptible <- ""
if (guideline$code == "cmi2012") { if (guideline$code == "cmi2012") {
# CMI, 2012 --------------------------------------------------------------- # CMI, 2012 ---------------------------------------------------------------
# Non-susceptible = R and I # Non-susceptible = R and I
@ -718,7 +718,7 @@ mdro <- function(x,
x[which((x$classes_in_guideline - x$classes_affected) <= 2), "MDRO"] <- 3 x[which((x$classes_in_guideline - x$classes_affected) <= 2), "MDRO"] <- 3
if (verbose == TRUE) { 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)], 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 # PDR (=4): all agents are R
@ -966,7 +966,7 @@ mdro <- function(x,
ab != "R" ab != "R"
} }
} }
x$mono_count <- 0 x$mono_count <- 0
x[drug_is_R(INH), "mono_count"] <- x[drug_is_R(INH), "mono_count"] + 1 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 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 # some more info on negative results
if (verbose == TRUE) { if (verbose == TRUE) {
if (guideline$code == "cmi2012") { 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 { } else {
x[which(x$MDRO == 1), "reason"] <- "too few antibiotics are R" 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 <- x[!is.na(x)]
} }
x.bak <- x x.bak <- x
# comma to period # comma to period
x <- gsub(",", ".", x, fixed = TRUE) x <- gsub(",", ".", x, fixed = TRUE)
# transform Unicode for >= and <= # 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 ## previously unempty values now empty - should return a warning later on
x[x.bak != "" & x == ""] <- "invalid" x[x.bak != "" & x == ""] <- "invalid"
# these are allowed MIC values and will become factor levels # these are allowed MIC values and will become factor levels
ops <- c("<", "<=", "", ">=", ">") ops <- c("<", "<=", "", ">=", ">")
lvls <- c(c(t(sapply(ops, function(x) paste0(x, "0.00", 1:9)))), 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, 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, 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)))))))) 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() na_before <- x[is.na(x) | x == ""] %>% length()
x[!x %in% lvls] <- NA x[!x %in% lvls] <- NA
na_after <- x[is.na(x) | x == ""] %>% length() na_after <- x[is.na(x) | x == ""] %>% length()
if (na_before != na_after) { if (na_before != na_after) {
list_missing <- x.bak[is.na(x) & !is.na(x.bak) & x.bak != ""] %>% list_missing <- x.bak[is.na(x) & !is.na(x.bak) & x.bak != ""] %>%
unique() %>% unique() %>%
@ -123,7 +123,7 @@ as.mic <- function(x, na.rm = FALSE) {
"%) that were invalid MICs: ", "%) that were invalid MICs: ",
list_missing, call. = FALSE) list_missing, call. = FALSE)
} }
structure(.Data = factor(x, levels = lvls, ordered = TRUE), structure(.Data = factor(x, levels = lvls, ordered = TRUE),
class = c("mic", "ordered", "factor")) class = c("mic", "ordered", "factor"))
} }

4
R/mo.R
View File

@ -554,7 +554,7 @@ exec_as.mo <- function(x,
if (initial_search == TRUE) { if (initial_search == TRUE) {
progress$tick() progress$tick()
} }
# valid MO code ---- # valid MO code ----
found <- lookup(mo == toupper(x_backup[i])) found <- lookup(mo == toupper(x_backup[i]))
if (!is.na(found)) { if (!is.na(found)) {
@ -1511,7 +1511,7 @@ exec_as.mo <- function(x,
if (property == "mo") { if (property == "mo") {
x <- to_class_mo(x) x <- to_class_mo(x)
} }
if (length(mo_renamed()) > 0) { if (length(mo_renamed()) > 0) {
print(mo_renamed()) print(mo_renamed())
} }

46
R/mo_property.R
View File

@ -151,9 +151,9 @@ mo_fullname <- mo_name
#' @export #' @export
mo_shortname <- function(x, language = get_locale(), ...) { mo_shortname <- function(x, language = get_locale(), ...) {
x.mo <- as.mo(x, ...) x.mo <- as.mo(x, ...)
metadata <- get_mo_failures_uncertainties_renamed() metadata <- get_mo_failures_uncertainties_renamed()
replace_empty <- function(x) { replace_empty <- function(x) {
x[x == ""] <- "spp." x[x == ""] <- "spp."
x x
@ -161,13 +161,13 @@ mo_shortname <- function(x, language = get_locale(), ...) {
# get first char of genus and complete species in English # 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))) shortnames <- paste0(substr(mo_genus(x.mo, language = NULL), 1, 1), ". ", replace_empty(mo_species(x.mo, language = NULL)))
# exceptions for Staphylococci # exceptions for Staphylococci
shortnames[shortnames == "S. coagulase-negative"] <- "CoNS" shortnames[shortnames == "S. coagulase-negative"] <- "CoNS"
shortnames[shortnames == "S. coagulase-positive"] <- "CoPS" shortnames[shortnames == "S. coagulase-positive"] <- "CoPS"
# exceptions for Streptococci: Streptococcus Group A -> GAS # 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") 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) load_mo_failures_uncertainties_renamed(metadata)
translate_AMR(shortnames, language = language, only_unknown = FALSE) 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(), ...) { mo_gramstain <- function(x, language = get_locale(), ...) {
x.mo <- as.mo(x, ...) x.mo <- as.mo(x, ...)
metadata <- get_mo_failures_uncertainties_renamed() metadata <- get_mo_failures_uncertainties_renamed()
x.phylum <- mo_phylum(x.mo) x.phylum <- mo_phylum(x.mo)
# DETERMINE GRAM STAIN FOR BACTERIA # DETERMINE GRAM STAIN FOR BACTERIA
# Source: https://itis.gov/servlet/SingleRpt/SingleRpt?search_topic=TSN&search_value=956097 # 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", "Firmicutes",
"Tenericutes") "Tenericutes")
| x.mo == "B_GRAMP"] <- "Gram-positive" | x.mo == "B_GRAMP"] <- "Gram-positive"
load_mo_failures_uncertainties_renamed(metadata) load_mo_failures_uncertainties_renamed(metadata)
translate_AMR(x, language = language, only_unknown = FALSE) translate_AMR(x, language = language, only_unknown = FALSE)
} }
@ -302,16 +302,16 @@ mo_rank <- function(x, ...) {
mo_taxonomy <- function(x, language = get_locale(), ...) { mo_taxonomy <- function(x, language = get_locale(), ...) {
x <- as.mo(x, ...) x <- as.mo(x, ...)
metadata <- get_mo_failures_uncertainties_renamed() metadata <- get_mo_failures_uncertainties_renamed()
result <- base::list(kingdom = mo_kingdom(x, language = language), result <- base::list(kingdom = mo_kingdom(x, language = language),
phylum = mo_phylum(x, language = language), phylum = mo_phylum(x, language = language),
class = mo_class(x, language = language), class = mo_class(x, language = language),
order = mo_order(x, language = language), order = mo_order(x, language = language),
family = mo_family(x, language = language), family = mo_family(x, language = language),
genus = mo_genus(x, language = language), genus = mo_genus(x, language = language),
species = mo_species(x, language = language), species = mo_species(x, language = language),
subspecies = mo_subspecies(x, language = language)) subspecies = mo_subspecies(x, language = language))
load_mo_failures_uncertainties_renamed(metadata) load_mo_failures_uncertainties_renamed(metadata)
result result
} }
@ -321,7 +321,7 @@ mo_taxonomy <- function(x, language = get_locale(), ...) {
mo_synonyms <- function(x, ...) { mo_synonyms <- function(x, ...) {
x <- as.mo(x, ...) x <- as.mo(x, ...)
metadata <- get_mo_failures_uncertainties_renamed() metadata <- get_mo_failures_uncertainties_renamed()
IDs <- mo_name(x = x, language = NULL) IDs <- mo_name(x = x, language = NULL)
syns <- lapply(IDs, function(newname) { syns <- lapply(IDs, function(newname) {
res <- sort(microorganisms.old[which(microorganisms.old$fullname_new == newname), "fullname"]) res <- sort(microorganisms.old[which(microorganisms.old$fullname_new == newname), "fullname"])
@ -337,7 +337,7 @@ mo_synonyms <- function(x, ...) {
} else { } else {
result <- unlist(syns) result <- unlist(syns)
} }
load_mo_failures_uncertainties_renamed(metadata) load_mo_failures_uncertainties_renamed(metadata)
result result
} }
@ -347,7 +347,7 @@ mo_synonyms <- function(x, ...) {
mo_info <- function(x, language = get_locale(), ...) { mo_info <- function(x, language = get_locale(), ...) {
x <- as.mo(x, ...) x <- as.mo(x, ...)
metadata <- get_mo_failures_uncertainties_renamed() metadata <- get_mo_failures_uncertainties_renamed()
info <- lapply(x, function(y) info <- lapply(x, function(y)
c(mo_taxonomy(y, language = language), c(mo_taxonomy(y, language = language),
list(synonyms = mo_synonyms(y), list(synonyms = mo_synonyms(y),
@ -360,7 +360,7 @@ mo_info <- function(x, language = get_locale(), ...) {
} else { } else {
result <- info[[1L]] result <- info[[1L]]
} }
load_mo_failures_uncertainties_renamed(metadata) load_mo_failures_uncertainties_renamed(metadata)
result result
} }
@ -388,7 +388,7 @@ mo_url <- function(x, open = FALSE, ...) {
} }
utils::browseURL(u[1L]) utils::browseURL(u[1L])
} }
load_mo_failures_uncertainties_renamed(metadata) load_mo_failures_uncertainties_renamed(metadata)
u 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(length(property) == 1L, "'property' must be of length 1")
stop_ifnot(property %in% colnames(microorganisms), stop_ifnot(property %in% colnames(microorganisms),
"invalid property: '", property, "' - use a column name of the `microorganisms` data set") "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) translate_AMR(mo_validate(x = x, property = property, ...), language = language, only_unknown = TRUE)
} }
mo_validate <- function(x, property, ...) { mo_validate <- function(x, property, ...) {
check_dataset_integrity() check_dataset_integrity()
dots <- list(...) dots <- list(...)
Becker <- dots$Becker Becker <- dots$Becker
if (is.null(Becker)) { if (is.null(Becker)) {
@ -417,7 +417,7 @@ mo_validate <- function(x, property, ...) {
if (is.null(Lancefield)) { if (is.null(Lancefield)) {
Lancefield <- FALSE Lancefield <- FALSE
} }
# try to catch an error when inputting an invalid parameter # try to catch an error when inputting an invalid parameter
# so the 'call.' can be set to FALSE # so the 'call.' can be set to FALSE
tryCatch(x[1L] %in% MO_lookup[1, property, drop = TRUE], tryCatch(x[1L] %in% MO_lookup[1, property, drop = TRUE],

26
R/mo_source.R
View File

@ -109,11 +109,11 @@
#' @export #' @export
#' @inheritSection AMR Read more on our website! #' @inheritSection AMR Read more on our website!
set_mo_source <- function(path) { set_mo_source <- function(path) {
file_location <- path.expand("~/mo_source.rds") file_location <- path.expand("~/mo_source.rds")
stop_ifnot(length(path) == 1, "`path` must be of length 1") stop_ifnot(length(path) == 1, "`path` must be of length 1")
if (is.null(path) || path %in% c(FALSE, "")) { if (is.null(path) || path %in% c(FALSE, "")) {
options(mo_source = NULL) options(mo_source = NULL)
options(mo_source_timestamp = NULL) options(mo_source_timestamp = NULL)
@ -123,21 +123,21 @@ set_mo_source <- function(path) {
} }
return(invisible()) return(invisible())
} }
stop_ifnot(file.exists(path), stop_ifnot(file.exists(path),
"file not found: ", path) "file not found: ", path)
if (path %like% "[.]rds$") { if (path %like% "[.]rds$") {
df <- readRDS(path) df <- readRDS(path)
} else if (path %like% "[.]xlsx?$") { } else if (path %like% "[.]xlsx?$") {
# is Excel file (old or new) # is Excel file (old or new)
read_excel <- import_fn("read_excel", "readxl") read_excel <- import_fn("read_excel", "readxl")
df <- read_excel(path) df <- read_excel(path)
} else if (path %like% "[.]tsv$") { } else if (path %like% "[.]tsv$") {
df <- utils::read.table(header = TRUE, sep = "\t", stringsAsFactors = FALSE) df <- utils::read.table(header = TRUE, sep = "\t", stringsAsFactors = FALSE)
} else { } else {
# try comma first # try comma first
try( try(
@ -156,21 +156,21 @@ set_mo_source <- function(path) {
silent = TRUE) silent = TRUE)
} }
} }
# check integrity # check integrity
mo_source_isvalid(df) mo_source_isvalid(df)
df <- subset(df, !is.na(mo)) df <- subset(df, !is.na(mo))
# keep only first two columns, second must be mo # keep only first two columns, second must be mo
if (colnames(df)[1] == "mo") { if (colnames(df)[1] == "mo") {
df <- df[, c(colnames(df)[2], "mo")] df <- df[, c(colnames(df)[2], "mo")]
} else { } else {
df <- df[, c(colnames(df)[1], "mo")] df <- df[, c(colnames(df)[1], "mo")]
} }
df <- as.data.frame(df, stringAsFactors = FALSE) df <- as.data.frame(df, stringAsFactors = FALSE)
# success # success
if (file.exists(file_location)) { if (file.exists(file_location)) {
action <- "Updated" action <- "Updated"

4
R/p_symbol.R
View File

@ -29,10 +29,10 @@
#' @inheritSection AMR Read more on our website! #' @inheritSection AMR Read more on our website!
#' @export #' @export
p_symbol <- function(p, emptychar = " ") { p_symbol <- function(p, emptychar = " ") {
p <- as.double(p) p <- as.double(p)
s <- rep(NA_character_, length(p)) s <- rep(NA_character_, length(p))
s[p <= 1] <- emptychar s[p <= 1] <- emptychar
s[p <= 0.100] <- "." s[p <= 0.100] <- "."
s[p <= 0.050] <- "*" s[p <= 0.050] <- "*"

56
R/resistance_predict.R
View File

@ -122,12 +122,12 @@ resistance_predict <- function(x,
preserve_measurements = TRUE, preserve_measurements = TRUE,
info = interactive(), info = interactive(),
...) { ...) {
stop_ifnot(is.data.frame(x), "`x` must be a data.frame") 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(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_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), stop_ifnot(col_ab %in% colnames(x),
"column `", col_ab, "` not found") "column `", col_ab, "` not found")
dots <- unlist(list(...)) dots <- unlist(list(...))
if (length(dots) != 0) { 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) warning("`I_as_R is deprecated - use I_as_S instead.", call. = FALSE)
} }
} }
# -- date # -- date
if (is.null(col_date)) { if (is.null(col_date)) {
col_date <- search_type_in_df(x = x, type = "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), stop_ifnot(col_date %in% colnames(x),
"column `", col_date, "` not found") "column `", col_date, "` not found")
# no grouped tibbles # no grouped tibbles
x <- as.data.frame(x, stringsAsFactors = FALSE) 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 <- as.data.frame(rbind(table(df[, c("year", col_ab)])), stringsAsFactors = FALSE)
df$year <- as.integer(rownames(df)) df$year <- as.integer(rownames(df))
rownames(df) <- NULL rownames(df) <- NULL
df <- subset(df, sum(df$R + df$S, na.rm = TRUE) >= minimum) df <- subset(df, sum(df$R + df$S, na.rm = TRUE) >= minimum)
df_matrix <- as.matrix(df[, c("R", "S"), drop = FALSE]) df_matrix <- as.matrix(df[, c("R", "S"), drop = FALSE])
@ -193,9 +193,9 @@ resistance_predict <- function(x,
if (is.null(year_max)) { if (is.null(year_max)) {
year_max <- year(Sys.Date()) + 10 year_max <- year(Sys.Date()) + 10
} }
years <- list(year = seq(from = year_min, to = year_max, by = year_every)) years <- list(year = seq(from = year_min, to = year_max, by = year_every))
if (model %in% c("binomial", "binom", "logit")) { if (model %in% c("binomial", "binom", "logit")) {
model <- "binomial" model <- "binomial"
model_lm <- with(df, glm(df_matrix ~ year, family = binomial)) model_lm <- with(df, glm(df_matrix ~ year, family = binomial))
@ -204,11 +204,11 @@ resistance_predict <- function(x,
cat("\n------------------------------------------------------------\n") cat("\n------------------------------------------------------------\n")
print(summary(model_lm)) print(summary(model_lm))
} }
predictmodel <- predict(model_lm, newdata = years, type = "response", se.fit = TRUE) predictmodel <- predict(model_lm, newdata = years, type = "response", se.fit = TRUE)
prediction <- predictmodel$fit prediction <- predictmodel$fit
se <- predictmodel$se.fit se <- predictmodel$se.fit
} else if (model %in% c("loglin", "poisson")) { } else if (model %in% c("loglin", "poisson")) {
model <- "poisson" model <- "poisson"
model_lm <- with(df, glm(R ~ year, family = poisson)) model_lm <- with(df, glm(R ~ year, family = poisson))
@ -217,11 +217,11 @@ resistance_predict <- function(x,
cat("\n--------------------------------------------------------------\n") cat("\n--------------------------------------------------------------\n")
print(summary(model_lm)) print(summary(model_lm))
} }
predictmodel <- predict(model_lm, newdata = years, type = "response", se.fit = TRUE) predictmodel <- predict(model_lm, newdata = years, type = "response", se.fit = TRUE)
prediction <- predictmodel$fit prediction <- predictmodel$fit
se <- predictmodel$se.fit se <- predictmodel$se.fit
} else if (model %in% c("lin", "linear")) { } else if (model %in% c("lin", "linear")) {
model <- "linear" model <- "linear"
model_lm <- with(df, lm((R / (R + S)) ~ year)) model_lm <- with(df, lm((R / (R + S)) ~ year))
@ -230,22 +230,22 @@ resistance_predict <- function(x,
cat("\n-----------------------\n") cat("\n-----------------------\n")
print(summary(model_lm)) print(summary(model_lm))
} }
predictmodel <- predict(model_lm, newdata = years, se.fit = TRUE) predictmodel <- predict(model_lm, newdata = years, se.fit = TRUE)
prediction <- predictmodel$fit prediction <- predictmodel$fit
se <- predictmodel$se.fit se <- predictmodel$se.fit
} else { } else {
stop("no valid model selected. See ?resistance_predict.") stop("no valid model selected. See ?resistance_predict.")
} }
# prepare the output dataframe # prepare the output dataframe
df_prediction <- data.frame(year = unlist(years), df_prediction <- data.frame(year = unlist(years),
value = prediction, value = prediction,
se_min = prediction - se, se_min = prediction - se,
se_max = prediction + se, se_max = prediction + se,
stringsAsFactors = FALSE) stringsAsFactors = FALSE)
if (model == "poisson") { if (model == "poisson") {
df_prediction$value <- as.integer(format(df_prediction$value, scientific = FALSE)) df_prediction$value <- as.integer(format(df_prediction$value, scientific = FALSE))
df_prediction$se_min <- as.integer(df_prediction$se_min) df_prediction$se_min <- as.integer(df_prediction$se_min)
@ -257,7 +257,7 @@ resistance_predict <- function(x,
} }
# se_min not below 0 # se_min not below 0
df_prediction$se_min <- ifelse(df_prediction$se_min < 0, 0, df_prediction$se_min) df_prediction$se_min <- ifelse(df_prediction$se_min < 0, 0, df_prediction$se_min)
df_observations <- data.frame(year = df$year, df_observations <- data.frame(year = df$year,
observations = df$R + df$S, observations = df$R + df$S,
observed = df$R / (df$R + df$S), observed = df$R / (df$R + df$S),
@ -265,17 +265,17 @@ resistance_predict <- function(x,
df_prediction <- df_prediction %>% df_prediction <- df_prediction %>%
left_join(df_observations, by = "year") left_join(df_observations, by = "year")
df_prediction$estimated <- df_prediction$value df_prediction$estimated <- df_prediction$value
if (preserve_measurements == TRUE) { if (preserve_measurements == TRUE) {
# replace estimated data by observed data # replace estimated data by observed data
df_prediction$value <- ifelse(!is.na(df_prediction$observed), df_prediction$observed, df_prediction$value) 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_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$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$value <- ifelse(df_prediction$value > 1, 1, ifelse(df_prediction$value < 0, 0, df_prediction$value))
df_prediction <- df_prediction[order(df_prediction$year), ] df_prediction <- df_prediction[order(df_prediction$year), ]
structure( structure(
.Data = df_prediction, .Data = df_prediction,
class = c("resistance_predict", "data.frame"), class = c("resistance_predict", "data.frame"),
@ -296,7 +296,7 @@ rsi_predict <- resistance_predict
#' @rdname resistance_predict #' @rdname resistance_predict
plot.resistance_predict <- function(x, main = paste("Resistance Prediction of", x_name), ...) { plot.resistance_predict <- function(x, main = paste("Resistance Prediction of", x_name), ...) {
x_name <- paste0(ab_name(attributes(x)$ab), " (", attributes(x)$ab, ")") x_name <- paste0(ab_name(attributes(x)$ab), " (", attributes(x)$ab, ")")
if (attributes(x)$I_as_S == TRUE) { if (attributes(x)$I_as_S == TRUE) {
ylab <- "%R" ylab <- "%R"
} else { } else {
@ -319,17 +319,17 @@ plot.resistance_predict <- function(x, main = paste("Resistance Prediction of",
sub = paste0("(n = ", sum(x$observations, na.rm = TRUE), sub = paste0("(n = ", sum(x$observations, na.rm = TRUE),
", model: ", attributes(x)$model_title, ")"), ", model: ", attributes(x)$model_title, ")"),
cex.sub = 0.75) cex.sub = 0.75)
axis(side = 2, at = seq(0, 1, 0.1), labels = paste0(0:10 * 10, "%")) axis(side = 2, at = seq(0, 1, 0.1), labels = paste0(0:10 * 10, "%"))
# hack for error bars: https://stackoverflow.com/a/22037078/4575331 # hack for error bars: https://stackoverflow.com/a/22037078/4575331
arrows(x0 = x$year, arrows(x0 = x$year,
y0 = x$se_min, y0 = x$se_min,
x1 = x$year, x1 = x$year,
y1 = x$se_max, y1 = x$se_max,
length = 0.05, angle = 90, code = 3, lwd = 1.5) length = 0.05, angle = 90, code = 3, lwd = 1.5)
# overlay grey points for prediction # overlay grey points for prediction
points(x = subset(x, is.na(observations))$year, points(x = subset(x, is.na(observations))$year,
y = subset(x, is.na(observations))$value, y = subset(x, is.na(observations))$value,
@ -346,15 +346,15 @@ ggplot_rsi_predict <- function(x,
stop_ifnot_installed("ggplot2") stop_ifnot_installed("ggplot2")
stop_ifnot(inherits(x, "resistance_predict"), "`x` must be a resistance prediction model created with resistance_predict()") 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, ")") x_name <- paste0(ab_name(attributes(x)$ab), " (", attributes(x)$ab, ")")
if (attributes(x)$I_as_S == TRUE) { if (attributes(x)$I_as_S == TRUE) {
ylab <- "%R" ylab <- "%R"
} else { } else {
ylab <- "%IR" ylab <- "%IR"
} }
p <- ggplot2::ggplot(x, ggplot2::aes(x = year, y = value)) + p <- ggplot2::ggplot(x, ggplot2::aes(x = year, y = value)) +
ggplot2::geom_point(data = subset(x, !is.na(observations)), ggplot2::geom_point(data = subset(x, !is.na(observations)),
size = 2) + size = 2) +
@ -364,7 +364,7 @@ ggplot_rsi_predict <- function(x,
x = "Year", x = "Year",
caption = paste0("(n = ", sum(x$observations, na.rm = TRUE), caption = paste0("(n = ", sum(x$observations, na.rm = TRUE),
", model: ", attributes(x)$model_title, ")")) ", model: ", attributes(x)$model_title, ")"))
if (ribbon == TRUE) { if (ribbon == TRUE) {
p <- p + ggplot2::geom_ribbon(ggplot2::aes(ymin = se_min, ymax = se_max), alpha = 0.25) p <- p + ggplot2::geom_ribbon(ggplot2::aes(ymin = se_min, ymax = se_max), alpha = 0.25)
} else { } 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), structure(.Data = factor(x, levels = c("S", "I", "R"), ordered = TRUE),
class = c("rsi", "ordered", "factor")) class = c("rsi", "ordered", "factor"))
} else { } else {
ab <- deparse(substitute(x)) ab <- deparse(substitute(x))
if (!any(x %like% "(R|S|I)", na.rm = TRUE)) { if (!any(x %like% "(R|S|I)", na.rm = TRUE)) {
if (!is.na(suppressWarnings(as.ab(ab)))) { 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), "` (", message(font_blue(paste0("=> Interpreting MIC values of `", font_bold(ab), "` (",
ifelse(ab_coerced != ab, paste0(ab_coerced, ", "), ""), ifelse(ab_coerced != ab, paste0(ab_coerced, ", "), ""),
ab_name(ab_coerced, tolower = TRUE), ") using guideline ", font_bold(guideline_coerced), " ... ")), ab_name(ab_coerced, tolower = TRUE), ") using guideline ", font_bold(guideline_coerced), " ... ")),
appendLF = FALSE) appendLF = FALSE)
result <- exec_as.rsi(method = "mic", result <- exec_as.rsi(method = "mic",
x = x, 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), "` (", message(font_blue(paste0("=> Interpreting disk zones of `", font_bold(ab), "` (",
ifelse(ab_coerced != ab, paste0(ab_coerced, ", "), ""), ifelse(ab_coerced != ab, paste0(ab_coerced, ", "), ""),
ab_name(ab_coerced, tolower = TRUE), ") using guideline ", font_bold(guideline_coerced), " ... ")), ab_name(ab_coerced, tolower = TRUE), ") using guideline ", font_bold(guideline_coerced), " ... ")),
appendLF = FALSE) appendLF = FALSE)
result <- exec_as.rsi(method = "disk", result <- exec_as.rsi(method = "disk",
x = x, x = x,
@ -319,15 +319,15 @@ as.rsi.data.frame <- function(x, col_mo = NULL, guideline = "EUCAST", uti = NULL
plural <- c("", "s", "a ") plural <- c("", "s", "a ")
} }
message(font_blue(paste0("NOTE: Assuming value", plural[1], " ", message(font_blue(paste0("NOTE: Assuming value", plural[1], " ",
paste(paste0('"', values, '"'), collapse = ", "), paste(paste0('"', values, '"'), collapse = ", "),
" in column `", font_bold(col_specimen), " 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."))) "` reflect", plural[2], " ", plural[3], "urinary tract infection", plural[1], ".\n Use `as.rsi(uti = FALSE)` to prevent this.")))
} else { } else {
# no data about UTI's found # no data about UTI's found
uti <- FALSE uti <- FALSE
} }
} }
i <- 0 i <- 0
ab_cols <- colnames(x)[sapply(x, function(y) { ab_cols <- colnames(x)[sapply(x, function(y) {
i <<- i + 1 i <<- i + 1
@ -339,13 +339,13 @@ as.rsi.data.frame <- function(x, col_mo = NULL, guideline = "EUCAST", uti = NULL
return(FALSE) return(FALSE)
} else if (!check & all_valid_mics(y)) { } else if (!check & all_valid_mics(y)) {
message(font_blue(paste0("NOTE: Assuming column `", ab, "` (", message(font_blue(paste0("NOTE: Assuming column `", ab, "` (",
ifelse(ab_coerced != ab, paste0(ab_coerced, ", "), ""), ifelse(ab_coerced != ab, paste0(ab_coerced, ", "), ""),
ab_name(ab_coerced, tolower = TRUE), ") contains MIC values."))) ab_name(ab_coerced, tolower = TRUE), ") contains MIC values.")))
return(TRUE) return(TRUE)
} else if (!check & all_valid_disks(y)) { } else if (!check & all_valid_disks(y)) {
message(font_blue(paste0("NOTE: Assuming column `", ab, "` (", message(font_blue(paste0("NOTE: Assuming column `", ab, "` (",
ifelse(ab_coerced != ab, paste0(ab_coerced, ", "), ""), ifelse(ab_coerced != ab, paste0(ab_coerced, ", "), ""),
ab_name(ab_coerced, tolower = TRUE), ") contains disk zones."))) ab_name(ab_coerced, tolower = TRUE), ") contains disk zones.")))
return(TRUE) return(TRUE)
} else { } else {
return(check) return(check)
@ -574,7 +574,7 @@ plot.rsi <- function(x,
data <- as.data.frame(table(x), stringsAsFactors = FALSE) data <- as.data.frame(table(x), stringsAsFactors = FALSE)
colnames(data) <- c("x", "n") colnames(data) <- c("x", "n")
data$s <- round((data$n / sum(data$n)) * 100, 1) data$s <- round((data$n / sum(data$n)) * 100, 1)
if (!"S" %in% data$x) { if (!"S" %in% data$x) {
data <- rbind(data, data.frame(x = "S", n = 0, s = 0)) 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) stop_ifnot(is.logical(only_all_tested), "`only_all_tested` must be logical", call = -2)
data_vars <- dots2vars(...) data_vars <- dots2vars(...)
dots_df <- switch(1, ...) dots_df <- switch(1, ...)
if (is.data.frame(dots_df)) { if (is.data.frame(dots_df)) {
# make sure to remove all other classes like tibbles, data.tables, etc # 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(...))) dots <- base::eval(base::substitute(base::alist(...)))
stop_if(length(dots) == 0, "no variables selected", call = -2) stop_if(length(dots) == 0, "no variables selected", call = -2)
stop_if("also_single_tested" %in% names(dots), stop_if("also_single_tested" %in% names(dots),
"`also_single_tested` was replaced by `only_all_tested`.\n", "`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) "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)) { if (is.data.frame(dots_df)) {
# data.frame passed with other columns, like: example_isolates %>% proportion_S(AMC, GEN) # data.frame passed with other columns, like: example_isolates %>% proportion_S(AMC, GEN)
dots <- as.character(dots) dots <- as.character(dots)
# remove first element, it's the data.frame # remove first element, it's the data.frame
if (length(dots) == 1) { 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) # this will give a warning for invalid results, of all input columns (so only 1 warning)
rsi_integrity_check <- as.rsi(rsi_integrity_check) rsi_integrity_check <- as.rsi(rsi_integrity_check)
} }
x_transposed <- as.list(as.data.frame(t(x))) x_transposed <- as.list(as.data.frame(t(x)))
if (only_all_tested == TRUE) { if (only_all_tested == TRUE) {
# no NAs in any column # 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) stop_ifnot(is.logical(as_percent), "`as_percent` must be logical", call = -2)
translate_ab <- get_translate_ab(translate_ab) translate_ab <- get_translate_ab(translate_ab)
# select only groups and antibiotics # select only groups and antibiotics
if (has_groups(data)) { if (has_groups(data)) {
data_has_groups <- TRUE data_has_groups <- TRUE

1
codecov.yml
View File

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

2
docs/404.html
View File

@ -81,7 +81,7 @@
</button> </button>
<span class="navbar-brand"> <span class="navbar-brand">
<a class="navbar-link" href="https://msberends.github.io/AMR/index.html">AMR (for R)</a> <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> </span>
</div> </div>

2
docs/LICENSE-text.html
View File

@ -81,7 +81,7 @@
</button> </button>
<span class="navbar-brand"> <span class="navbar-brand">
<a class="navbar-link" href="index.html">AMR (for R)</a> <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> </span>
</div> </div>

2
docs/articles/index.html
View File

@ -81,7 +81,7 @@
</button> </button>
<span class="navbar-brand"> <span class="navbar-brand">
<a class="navbar-link" href="../index.html">AMR (for R)</a> <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> </span>
</div> </div>

2
docs/authors.html
View File

@ -81,7 +81,7 @@
</button> </button>
<span class="navbar-brand"> <span class="navbar-brand">
<a class="navbar-link" href="index.html">AMR (for R)</a> <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> </span>
</div> </div>

2
docs/index.html
View File

@ -43,7 +43,7 @@
</button> </button>
<span class="navbar-brand"> <span class="navbar-brand">
<a class="navbar-link" href="index.html">AMR (for R)</a> <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> </span>
</div> </div>

12
docs/news/index.html
View File

@ -81,7 +81,7 @@
</button> </button>
<span class="navbar-brand"> <span class="navbar-brand">
<a class="navbar-link" href="../index.html">AMR (for R)</a> <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> </span>
</div> </div>
@ -229,13 +229,13 @@
<small>Source: <a href='https://github.com/msberends/AMR/blob/master/NEWS.md'><code>NEWS.md</code></a></small> <small>Source: <a href='https://github.com/msberends/AMR/blob/master/NEWS.md'><code>NEWS.md</code></a></small>
</div> </div>
<div id="amr-1209033" class="section level1"> <div id="amr-1209034" class="section level1">
<h1 class="page-header" data-toc-text="1.2.0.9033"> <h1 class="page-header" data-toc-text="1.2.0.9034">
<a href="#amr-1209033" class="anchor"></a>AMR 1.2.0.9033<small> Unreleased </small> <a href="#amr-1209034" class="anchor"></a>AMR 1.2.0.9034<small> Unreleased </small>
</h1> </h1>
<div id="last-updated-12-jul-2020" class="section level2"> <div id="last-updated-13-jul-2020" class="section level2">
<h2 class="hasAnchor"> <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> </h2>
<div id="new" class="section level3"> <div id="new" class="section level3">
<h3 class="hasAnchor"> <h3 class="hasAnchor">

2
docs/pkgdown.yml
View File

@ -10,7 +10,7 @@ articles:
WHONET: WHONET.html WHONET: WHONET.html
benchmarks: benchmarks.html benchmarks: benchmarks.html
resistance_predict: resistance_predict.html resistance_predict: resistance_predict.html
last_built: 2020-07-12T09:42Z last_built: 2020-07-13T07:17Z
urls: urls:
reference: https://msberends.github.io/AMR/reference reference: https://msberends.github.io/AMR/reference
article: https://msberends.github.io/AMR/articles article: https://msberends.github.io/AMR/articles

2
docs/reference/index.html
View File

@ -81,7 +81,7 @@
</button> </button>
<span class="navbar-brand"> <span class="navbar-brand">
<a class="navbar-link" href="../index.html">AMR (for R)</a> <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> </span>
</div> </div>