diff --git a/.Rbuildignore b/.Rbuildignore index e2e1dfe2..2d3998c0 100755 --- a/.Rbuildignore +++ b/.Rbuildignore @@ -22,3 +22,4 @@ ^public$ ^data-raw$ R/aa_test.R$ +^\.lintr$ diff --git a/.gitignore b/.gitignore index 8dc45f26..81344b27 100755 --- a/.gitignore +++ b/.gitignore @@ -22,4 +22,3 @@ packrat/lib*/ packrat/src/ data-raw/taxon.tab data-raw/DSMZ_bactnames.xlsx -R/aa_test.R diff --git a/.gitlab-ci.R b/.gitlab-ci.R index 4a2628c5..aea195d1 100644 --- a/.gitlab-ci.R +++ b/.gitlab-ci.R @@ -29,7 +29,8 @@ install_if_needed <- function(pkg, repos, quiet) { gl_update_pkg_all <- function(repos = "https://cran.rstudio.com", quiet = TRUE, - install_pkgdown = FALSE) { + install_pkgdown = FALSE, + install_lintr = FALSE) { # update existing update.packages(ask = FALSE, repos = repos, quiet = quiet) @@ -37,7 +38,10 @@ gl_update_pkg_all <- function(repos = "https://cran.rstudio.com", if (install_pkgdown == TRUE) { install_if_needed(pkg = "pkgdown", repos = repos, quiet = quiet) } - + if (install_lintr == TRUE) { + install_if_needed(pkg = "lintr", repos = repos, quiet = quiet) + } + devtools::install_dev_deps(repos = repos, quiet = quiet, upgrade = TRUE) cat("INSTALLED:\n") diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index bcb8cfd5..356bbc8b 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -26,6 +26,7 @@ stages: - build - test - deploy + - lint image: rocker/r-base @@ -131,3 +132,12 @@ pages: artifacts: paths: - public + +lintr: + stage: lint + when: on_success + script: + # install missing and outdated packages + - Rscript -e 'source(".gitlab-ci.R"); gl_update_pkg_all(repos = "https://cran.rstudio.com", quiet = TRUE, install_pkgdown = FALSE, install_lintr = TRUE)' + # check all syntax with lintr + - Rscript -e 'lintr::lint_package()' diff --git a/.lintr b/.lintr new file mode 100644 index 00000000..7f972d62 --- /dev/null +++ b/.lintr @@ -0,0 +1,2 @@ +linters: with_defaults(line_length_linter = NULL, trailing_whitespace_linter = NULL, object_name_linter = NULL, cyclocomp_linter = NULL, object_usage_linter = NULL, object_length_linter(length = 50L)) +exclusions: list("R/mo_history.R", "tests/testthat/test-mo_history.R") diff --git a/DESCRIPTION b/DESCRIPTION index 8047d1ee..b480b8fc 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,6 +1,6 @@ Package: AMR -Version: 0.7.1.9101 -Date: 2019-10-09 +Version: 0.7.1.9102 +Date: 2019-10-11 Title: Antimicrobial Resistance Analysis Authors@R: c( person(role = c("aut", "cre"), @@ -48,6 +48,7 @@ Suggests: covr (>= 3.0.1), curl, readxl, + rmarkdown, rstudioapi, rvest (>= 0.3.2), testthat (>= 1.0.2), diff --git a/NAMESPACE b/NAMESPACE index f288e834..eed558a9 100755 --- a/NAMESPACE +++ b/NAMESPACE @@ -300,6 +300,7 @@ importFrom(graphics,par) importFrom(graphics,plot) importFrom(graphics,points) importFrom(graphics,text) +importFrom(knitr,kable) importFrom(microbenchmark,microbenchmark) importFrom(pillar,pillar_shaft) importFrom(pillar,type_sum) diff --git a/NEWS.md b/NEWS.md index 31370ec2..0dc01b35 100755 --- a/NEWS.md +++ b/NEWS.md @@ -1,5 +1,5 @@ -# AMR 0.7.1.9101 -Last updated: 09-Oct-2019 +# AMR 0.7.1.9102 +Last updated: 11-Oct-2019 ### Breaking * Determination of first isolates now **excludes** all 'unknown' microorganisms at default, i.e. microbial code `"UNKNOWN"`. They can be included with the new parameter `include_unknown`: @@ -126,6 +126,7 @@ #### Other * Added Prof. Dr. Casper Albers as doctoral advisor and added Dr. Judith Fonville, Eric Hazenberg, Dr. Bart Meijer, Dr. Dennis Souverein and Annick Lenglet as contributors +* Cleaned the coding style of every single syntax line in this package with the help of the `lintr` package # AMR 0.7.1 diff --git a/R/ab.R b/R/ab.R index 0f4872ca..e682e242 100755 --- a/R/ab.R +++ b/R/ab.R @@ -79,8 +79,6 @@ as.ab <- function(x, ...) { x_bak_clean <- gsub("_[A-Z]{2}[0-9_]{0,3}$", "", x_bak_clean, ignore.case = TRUE) # remove part between brackets if that's followed by another string x_bak_clean <- gsub("(.*)+ [(].*[)]", "\\1", x_bak_clean) - # keep only a-Z, 0-9, space, slash and dash - # x_bak_clean <- gsub("[^A-Z0-9 /-]", "", x_bak_clean, ignore.case = TRUE) # keep only max 1 space x_bak_clean <- trimws(gsub(" +", " ", x_bak_clean, ignore.case = TRUE)) # non-character, space or number should be a slash @@ -93,7 +91,7 @@ as.ab <- function(x, ...) { x_new <- rep(NA_character_, length(x)) x_unknown <- character(0) - for (i in 1:length(x)) { + for (i in seq_len(length(x))) { if (is.na(x[i]) | is.null(x[i])) { next } @@ -108,28 +106,28 @@ as.ab <- function(x, ...) { } # exact AB code - found <- AMR::antibiotics[which(AMR::antibiotics$ab == toupper(x[i])),]$ab + found <- AMR::antibiotics[which(AMR::antibiotics$ab == toupper(x[i])), ]$ab if (length(found) > 0) { x_new[i] <- found[1L] next } # exact ATC code - found <- AMR::antibiotics[which(AMR::antibiotics$atc == toupper(x[i])),]$ab + found <- AMR::antibiotics[which(AMR::antibiotics$atc == toupper(x[i])), ]$ab if (length(found) > 0) { x_new[i] <- found[1L] next } # exact CID code - found <- AMR::antibiotics[which(AMR::antibiotics$cid == x[i]),]$ab + found <- AMR::antibiotics[which(AMR::antibiotics$cid == x[i]), ]$ab if (length(found) > 0) { x_new[i] <- found[1L] next } # exact name - found <- AMR::antibiotics[which(toupper(AMR::antibiotics$name) == toupper(x[i])),]$ab + found <- AMR::antibiotics[which(toupper(AMR::antibiotics$name) == toupper(x[i])), ]$ab if (length(found) > 0) { x_new[i] <- found[1L] next @@ -163,7 +161,7 @@ as.ab <- function(x, ...) { # first >=4 characters of name if (nchar(x[i]) >= 4) { - found <- AMR::antibiotics[which(toupper(AMR::antibiotics$name) %like% paste0("^", x[i])),]$ab + found <- AMR::antibiotics[which(toupper(AMR::antibiotics$name) %like% paste0("^", x[i])), ]$ab if (length(found) > 0) { x_new[i] <- found[1L] next @@ -193,7 +191,7 @@ as.ab <- function(x, ...) { x_spelling <- gsub("(.)\\1+", "\\1+", x_spelling) # try if name starts with it - found <- AMR::antibiotics[which(AMR::antibiotics$name %like% paste0("^", x_spelling)),]$ab + found <- AMR::antibiotics[which(AMR::antibiotics$name %like% paste0("^", x_spelling)), ]$ab if (length(found) > 0) { x_new[i] <- found[1L] next @@ -233,7 +231,7 @@ as.ab <- function(x, ...) { # transform back from other languages and try again x_translated <- paste(lapply(strsplit(x[i], "[^a-zA-Z0-9 ]"), function(y) { - for (i in 1:length(y)) { + for (i in seq_len(length(y))) { y[i] <- ifelse(tolower(y[i]) %in% tolower(translations_file$replacement), translations_file[which(tolower(translations_file$replacement) == tolower(y[i]) & !isFALSE(translations_file$fixed)), "pattern"], @@ -252,7 +250,7 @@ as.ab <- function(x, ...) { # now also try to coerce brandname combinations like "Amoxy/clavulanic acid" x_translated <- paste(lapply(strsplit(x_translated, "[^a-zA-Z0-9 ]"), function(y) { - for (i in 1:length(y)) { + for (i in seq_len(length(y))) { y_name <- suppressWarnings(ab_name(y[i], language = NULL, initial_search = FALSE, initial_search2 = FALSE)) y[i] <- ifelse(!is.na(y_name), y_name, @@ -278,14 +276,14 @@ as.ab <- function(x, ...) { x_unknown <- x_unknown[!x_unknown %in% x_unknown_ATCs] if (length(x_unknown_ATCs) > 0) { warning("These ATC codes are not (yet) in the antibiotics data set: ", - paste('"', sort(unique(x_unknown_ATCs)), '"', sep = "", collapse = ', '), + paste('"', sort(unique(x_unknown_ATCs)), '"', sep = "", collapse = ", "), ".", call. = FALSE) } if (length(x_unknown) > 0) { warning("These values could not be coerced to a valid antimicrobial ID: ", - paste('"', sort(unique(x_unknown)), '"', sep = "", collapse = ', '), + paste('"', sort(unique(x_unknown)), '"', sep = "", collapse = ", "), ".", call. = FALSE) } @@ -319,7 +317,7 @@ print.ab <- function(x, ...) { #' @exportMethod as.data.frame.ab #' @export #' @noRd -as.data.frame.ab <- function (x, ...) { +as.data.frame.ab <- function(x, ...) { # same as as.data.frame.character but with removed stringsAsFactors nm <- paste(deparse(substitute(x), width.cutoff = 500L), collapse = " ") diff --git a/R/ab_property.R b/R/ab_property.R index b62e2acb..50cbaf50 100644 --- a/R/ab_property.R +++ b/R/ab_property.R @@ -165,7 +165,7 @@ ab_info <- function(x, language = get_locale(), ...) { #' @rdname ab_property #' @export -ab_property <- function(x, property = 'name', language = get_locale(), ...) { +ab_property <- function(x, property = "name", language = get_locale(), ...) { if (length(property) != 1L) { stop("'property' must be of length 1.") } diff --git a/R/age.R b/R/age.R index fb92d4c8..4ebcb70e 100755 --- a/R/age.R +++ b/R/age.R @@ -175,7 +175,7 @@ age_groups <- function(x, split_at = c(12, 25, 55, 75), na.rm = FALSE) { # turn input values to 'split_at' indices y <- x labs <- split_at - for (i in 1:length(split_at)) { + for (i in seq_len(length(split_at))) { y[x >= split_at[i]] <- i # create labels labs[i - 1] <- paste0(unique(c(split_at[i - 1], split_at[i] - 1)), collapse = "-") diff --git a/R/amr.R b/R/amr.R index 5351cf9d..17f8a0b6 100644 --- a/R/amr.R +++ b/R/amr.R @@ -65,6 +65,6 @@ #' \url{https://gitlab.com/msberends/AMR/issues} #' @name AMR #' @rdname AMR -# # prevent NOTE on R >= 3.6 #' @importFrom microbenchmark microbenchmark +#' @importFrom knitr kable NULL diff --git a/R/atc_online.R b/R/atc_online.R index c7f26160..cb422c01 100644 --- a/R/atc_online.R +++ b/R/atc_online.R @@ -73,8 +73,8 @@ #' } atc_online_property <- function(atc_code, property, - administration = 'O', - url = 'https://www.whocc.no/atc_ddd_index/?code=%s&showdescription=no') { + administration = "O", + url = "https://www.whocc.no/atc_ddd_index/?code=%s&showdescription=no") { if (!all(c("curl", "rvest", "xml2") %in% rownames(utils::installed.packages()))) { stop("Packages 'xml2', 'rvest' and 'curl' are required for this function") @@ -90,15 +90,15 @@ atc_online_property <- function(atc_code, } if (length(property) != 1L) { - stop('`property` must be of length 1', call. = FALSE) + stop("`property` must be of length 1", call. = FALSE) } if (length(administration) != 1L) { - stop('`administration` must be of length 1', call. = FALSE) + stop("`administration` must be of length 1", call. = FALSE) } # also allow unit as property - if (property %like% 'unit') { - property <- 'U' + if (property %like% "unit") { + property <- "U" } # validation of properties @@ -109,12 +109,12 @@ atc_online_property <- function(atc_code, valid_properties <- tolower(valid_properties) if (!property %in% valid_properties) { - stop('Invalid `property`, use one of ', paste(valid_properties.bak, collapse = ", "), '.') + stop("Invalid `property`, use one of ", paste(valid_properties.bak, collapse = ", "), ".") } - if (property == 'ddd') { + if (property == "ddd") { returnvalue <- rep(NA_real_, length(atc_code)) - } else if (property == 'groups') { + } else if (property == "groups") { returnvalue <- list() } else { returnvalue <- rep(NA_character_, length(atc_code)) @@ -122,11 +122,11 @@ atc_online_property <- function(atc_code, progress <- progress_estimated(n = length(atc_code)) - for (i in 1:length(atc_code)) { + for (i in seq_len(length(atc_code))) { progress$tick()$print() - atc_url <- sub('%s', atc_code[i], url, fixed = TRUE) + atc_url <- sub("%s", atc_code[i], url, fixed = TRUE) if (property == "groups") { tbl <- xml2::read_html(atc_url) %>% @@ -141,34 +141,34 @@ atc_online_property <- function(atc_code, # select only text items where URL like "code=" texts <- texts[grepl("?code=", tolower(hrefs), fixed = TRUE)] # last one is antibiotics, skip it - texts <- texts[1:length(texts) - 1] + texts <- texts[seq_len(length(texts)) - 1] returnvalue <- c(list(texts), returnvalue) } else { tbl <- xml2::read_html(atc_url) %>% - rvest::html_nodes('table') %>% + rvest::html_nodes("table") %>% rvest::html_table(header = TRUE) %>% as.data.frame(stringsAsFactors = FALSE) # case insensitive column names - colnames(tbl) <- tolower(colnames(tbl)) %>% gsub('^atc.*', 'atc', .) + colnames(tbl) <- tolower(colnames(tbl)) %>% gsub("^atc.*", "atc", .) 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 next } - if (property %in% c('atc', 'name')) { + if (property %in% c("atc", "name")) { # ATC and name are only in first row returnvalue[i] <- tbl[1, property] } else { - if (!'adm.r' %in% colnames(tbl) | is.na(tbl[1, 'adm.r'])) { + if (!"adm.r" %in% colnames(tbl) | is.na(tbl[1, "adm.r"])) { returnvalue[i] <- NA next } else { - for (j in 1:nrow(tbl)) { - if (tbl[j, 'adm.r'] == administration) { + for (j in seq_len(length(tbl))) { + if (tbl[j, "adm.r"] == administration) { returnvalue[i] <- tbl[j, property] } } @@ -195,4 +195,3 @@ atc_online_groups <- function(atc_code, ...) { atc_online_ddd <- function(atc_code, ...) { atc_online_property(atc_code = atc_code, property = "ddd", ...) } - diff --git a/R/availability.R b/R/availability.R index a5df554f..a05cb2d2 100644 --- a/R/availability.R +++ b/R/availability.R @@ -44,7 +44,9 @@ #' select_if(is.rsi) %>% #' availability() availability <- function(tbl, width = NULL) { - x <- base::sapply(tbl, function(x) { 1 - base::sum(base::is.na(x)) / base::length(x) }) + x <- base::sapply(tbl, function(x) { + 1 - base::sum(base::is.na(x)) / base::length(x) + }) n <- base::sapply(tbl, function(x) base::length(x[!base::is.na(x)])) R <- base::sapply(tbl, function(x) base::ifelse(is.rsi(x), portion_R(x, minimum = 0), NA)) R_print <- character(length(R)) @@ -83,7 +85,7 @@ availability <- function(tbl, width = NULL) { resistant = R_print, visual_resistance = vis_resistance) if (length(R[is.na(R)]) == ncol(tbl)) { - df[,1:3] + df[, 1:3] } else { df } diff --git a/R/bug_drug_combinations.R b/R/bug_drug_combinations.R index 26430d6e..3921b54c 100644 --- a/R/bug_drug_combinations.R +++ b/R/bug_drug_combinations.R @@ -31,7 +31,7 @@ #' @param ... arguments passed on to \code{FUN} #' @inheritParams rsi_df #' @inheritParams base::formatC -#' @importFrom dplyr %>% rename group_by select mutate filter pull +#' @importFrom dplyr %>% rename group_by select mutate filter summarise ungroup #' @importFrom tidyr spread # @importFrom clean freq percentage #' @details The function \code{format} calculates the resistance per bug-drug combination. Use \code{combine_IR = FALSE} (default) to test R vs. S+I and \code{combine_IR = TRUE} to test R+I vs. S. @@ -46,7 +46,7 @@ #' \donttest{ #' x <- bug_drug_combinations(example_isolates) #' x -#' format(x) +#' format(x, translate_ab = "name (atc)") #' #' # Use FUN to change to transformation of microorganism codes #' x <- bug_drug_combinations(example_isolates, @@ -76,7 +76,9 @@ bug_drug_combinations <- function(x, x <- x %>% as.data.frame(stringsAsFactors = FALSE) %>% - mutate(mo = x %>% pull(col_mo) %>% FUN(...)) %>% + mutate(mo = x %>% + pull(col_mo) %>% + FUN(...)) %>% group_by(mo) %>% select_if(is.rsi) %>% gather("ab", "value", -mo) %>% @@ -112,7 +114,7 @@ format.bug_drug_combinations <- function(x, if (remove_intrinsic_resistant == TRUE) { x <- x %>% filter(R != total) } - if (combine_IR == FALSE | combine_SI == TRUE) { + if (combine_SI == TRUE | combine_IR == FALSE) { x$isolates <- x$R } else { x$isolates <- x$R + x$I @@ -121,7 +123,7 @@ format.bug_drug_combinations <- function(x, give_ab_name <- function(ab, format, language) { format <- tolower(format) ab_txt <- rep(format, length(ab)) - for (i in 1:length(ab_txt)) { + for (i in seq_len(length(ab_txt))) { ab_txt[i] <- gsub("ab", ab[i], ab_txt[i]) ab_txt[i] <- gsub("cid", ab_cid(ab[i]), ab_txt[i]) ab_txt[i] <- gsub("group", ab_group(ab[i], language = language), ab_txt[i]) diff --git a/R/count.R b/R/count.R index 7bcbf626..00c794ac 100755 --- a/R/count.R +++ b/R/count.R @@ -154,7 +154,7 @@ count_all <- function(..., only_all_tested = FALSE) { #' @rdname count #' @export -n_rsi<- count_all +n_rsi <- count_all #' @rdname count #' @export diff --git a/R/data.R b/R/data.R index 755cff3b..77f1b794 100755 --- a/R/data.R +++ b/R/data.R @@ -203,10 +203,10 @@ dataset_UTF8_to_ASCII <- function(df) { iconv(vect, from = "UTF-8", to = "ASCII//TRANSLIT") } df <- as.data.frame(df, stringsAsFactors = FALSE) - for (i in 1:NCOL(df)) { + for (i in seq_len(NCOL(df))) { col <- df[, i] if (is.list(col)) { - for (j in 1:length(col)) { + for (j in seq_len(length(col))) { col[[j]] <- trans(col[[j]]) } df[, i] <- list(col) diff --git a/R/disk.R b/R/disk.R index 7effc3a6..42689644 100644 --- a/R/disk.R +++ b/R/disk.R @@ -64,14 +64,14 @@ as.disk <- function(x, na.rm = FALSE) { list_missing <- x.bak[is.na(x) & !is.na(x.bak)] %>% unique() %>% sort() - list_missing <- paste0('"', list_missing , '"', collapse = ", ") - warning(na_after - na_before, ' results truncated (', + list_missing <- paste0('"', list_missing, '"', collapse = ", ") + warning(na_after - na_before, " results truncated (", round(((na_after - na_before) / length(x)) * 100), - '%) that were invalid disk zones: ', + "%) that were invalid disk zones: ", list_missing, call. = FALSE) } - class(x) <- c('disk', 'integer') + class(x) <- c("disk", "integer") x } } @@ -80,7 +80,7 @@ as.disk <- function(x, na.rm = FALSE) { #' @export #' @importFrom dplyr %>% is.disk <- function(x) { - class(x) %>% identical(c('disk', 'integer')) + class(x) %>% identical(c("disk", "integer")) } #' @exportMethod print.disk diff --git a/R/eucast_rules.R b/R/eucast_rules.R index 70c6acde..0564d4a9 100755 --- a/R/eucast_rules.R +++ b/R/eucast_rules.R @@ -233,8 +233,15 @@ eucast_rules <- function(x, warned <- FALSE - txt_error <- function() { cat("", bgRed(white(" ERROR ")), "\n\n") } - txt_warning <- function() { if (warned == FALSE) { cat("", bgYellow(black(" WARNING "))) }; warned <<- TRUE } + txt_error <- function() { + cat("", bgRed(white(" ERROR ")), "\n\n") + } + txt_warning <- function() { + if (warned == FALSE) { + cat("", bgYellow(black(" WARNING "))) + } + warned <<- TRUE + } txt_ok <- function(no_added, no_changed) { if (warned == FALSE) { if (no_added + no_changed == 0) { @@ -337,69 +344,69 @@ eucast_rules <- function(x, verbose = verbose, ...) - AMC <- cols_ab['AMC'] - AMK <- cols_ab['AMK'] - AMP <- cols_ab['AMP'] - AMX <- cols_ab['AMX'] - ATM <- cols_ab['ATM'] - AZL <- cols_ab['AZL'] - AZM <- cols_ab['AZM'] - CAZ <- cols_ab['CAZ'] - CED <- cols_ab['CED'] - CHL <- cols_ab['CHL'] - CIP <- cols_ab['CIP'] - CLI <- cols_ab['CLI'] - CLR <- cols_ab['CLR'] - COL <- cols_ab['COL'] - CRO <- cols_ab['CRO'] - CTX <- cols_ab['CTX'] - CXM <- cols_ab['CXM'] - CZO <- cols_ab['CZO'] - DAP <- cols_ab['DAP'] - DOX <- cols_ab['DOX'] - ERY <- cols_ab['ERY'] - ETP <- cols_ab['ETP'] - FEP <- cols_ab['FEP'] - FLC <- cols_ab['FLC'] - FOS <- cols_ab['FOS'] - FOX <- cols_ab['FOX'] - FUS <- cols_ab['FUS'] - GEN <- cols_ab['GEN'] - IPM <- cols_ab['IPM'] - KAN <- cols_ab['KAN'] - LIN <- cols_ab['LIN'] - LNZ <- cols_ab['LNZ'] - LVX <- cols_ab['LVX'] - MEM <- cols_ab['MEM'] - MEZ <- cols_ab['MEZ'] - MFX <- cols_ab['MFX'] - MNO <- cols_ab['MNO'] - NAL <- cols_ab['NAL'] - NEO <- cols_ab['NEO'] - NET <- cols_ab['NET'] - NIT <- cols_ab['NIT'] - NOR <- cols_ab['NOR'] - NOV <- cols_ab['NOV'] - OFX <- cols_ab['OFX'] - OXA <- cols_ab['OXA'] - PEN <- cols_ab['PEN'] - PIP <- cols_ab['PIP'] - PLB <- cols_ab['PLB'] - PRI <- cols_ab['PRI'] - QDA <- cols_ab['QDA'] - RID <- cols_ab['RID'] - RIF <- cols_ab['RIF'] - RXT <- cols_ab['RXT'] - SIS <- cols_ab['SIS'] - SXT <- cols_ab['SXT'] - TCY <- cols_ab['TCY'] - TEC <- cols_ab['TEC'] - TGC <- cols_ab['TGC'] - TIC <- cols_ab['TIC'] - TMP <- cols_ab['TMP'] - TOB <- cols_ab['TOB'] - TZP <- cols_ab['TZP'] - VAN <- cols_ab['VAN'] + AMC <- cols_ab["AMC"] + AMK <- cols_ab["AMK"] + AMP <- cols_ab["AMP"] + AMX <- cols_ab["AMX"] + ATM <- cols_ab["ATM"] + AZL <- cols_ab["AZL"] + AZM <- cols_ab["AZM"] + CAZ <- cols_ab["CAZ"] + CED <- cols_ab["CED"] + CHL <- cols_ab["CHL"] + CIP <- cols_ab["CIP"] + CLI <- cols_ab["CLI"] + CLR <- cols_ab["CLR"] + COL <- cols_ab["COL"] + CRO <- cols_ab["CRO"] + CTX <- cols_ab["CTX"] + CXM <- cols_ab["CXM"] + CZO <- cols_ab["CZO"] + DAP <- cols_ab["DAP"] + DOX <- cols_ab["DOX"] + ERY <- cols_ab["ERY"] + ETP <- cols_ab["ETP"] + FEP <- cols_ab["FEP"] + FLC <- cols_ab["FLC"] + FOS <- cols_ab["FOS"] + FOX <- cols_ab["FOX"] + FUS <- cols_ab["FUS"] + GEN <- cols_ab["GEN"] + IPM <- cols_ab["IPM"] + KAN <- cols_ab["KAN"] + LIN <- cols_ab["LIN"] + LNZ <- cols_ab["LNZ"] + LVX <- cols_ab["LVX"] + MEM <- cols_ab["MEM"] + MEZ <- cols_ab["MEZ"] + MFX <- cols_ab["MFX"] + MNO <- cols_ab["MNO"] + NAL <- cols_ab["NAL"] + NEO <- cols_ab["NEO"] + NET <- cols_ab["NET"] + NIT <- cols_ab["NIT"] + NOR <- cols_ab["NOR"] + NOV <- cols_ab["NOV"] + OFX <- cols_ab["OFX"] + OXA <- cols_ab["OXA"] + PEN <- cols_ab["PEN"] + PIP <- cols_ab["PIP"] + PLB <- cols_ab["PLB"] + PRI <- cols_ab["PRI"] + QDA <- cols_ab["QDA"] + RID <- cols_ab["RID"] + RIF <- cols_ab["RIF"] + RXT <- cols_ab["RXT"] + SIS <- cols_ab["SIS"] + SXT <- cols_ab["SXT"] + TCY <- cols_ab["TCY"] + TEC <- cols_ab["TEC"] + TGC <- cols_ab["TGC"] + TIC <- cols_ab["TIC"] + TMP <- cols_ab["TMP"] + TOB <- cols_ab["TOB"] + TZP <- cols_ab["TZP"] + VAN <- cols_ab["VAN"] ab_missing <- function(ab) { all(ab %in% c(NULL, NA)) @@ -425,11 +432,11 @@ eucast_rules <- function(x, # insert into original table x_original[rows, cols] <<- to, warning = function(w) { - if (w$message %like% 'invalid factor level') { + if (w$message %like% "invalid factor level") { x_original <<- x_original %>% mutate_at(vars(cols), ~factor(x = as.character(.), levels = c(to, levels(.)))) x <<- x %>% mutate_at(vars(cols), ~factor(x = as.character(.), levels = c(to, levels(.)))) x_original[rows, cols] <<- to - warning('Value "', to, '" added to the factor levels of column(s) `', paste(cols, collapse = '`, `'), '` because this value was not an existing factor level.\nA better way is to use as.rsi() on beforehand on antimicrobial columns to guarantee the right structure.', call. = FALSE) + warning('Value "', to, '" added to the factor levels of column(s) `', paste(cols, collapse = "`, `"), "` because this value was not an existing factor level.\nA better way is to use as.rsi() on beforehand on antimicrobial columns to guarantee the right structure.", call. = FALSE) txt_warning() warned <<- FALSE } else { @@ -442,8 +449,8 @@ eucast_rules <- function(x, txt_error() stop(paste0("In row(s) ", paste(rows[1:min(length(rows), 10)], collapse = ","), ifelse(length(rows) > 10, "...", ""), - ' while writing value "', to, - '" to column(s) `', paste(cols, collapse = "`, `"), + " while writing value '", to, + "' to column(s) `", paste(cols, collapse = "`, `"), "`:\n", e$message), call. = FALSE) } @@ -453,17 +460,17 @@ eucast_rules <- function(x, x[rows, cols] <<- x_original[rows, cols], error = function(e) { stop(paste0("In row(s) ", paste(rows[1:min(length(rows), 10)], collapse = ","), - '... while writing value "', to, - '" to column(s) `', paste(cols, collapse = "`, `"), + "... while writing value '", to, + "' to column(s) `", paste(cols, collapse = "`, `"), "`:\n", e$message), call. = FALSE) } ) # before_df might not be a data.frame, but a tibble or data.table instead - old <- as.data.frame(before_df, stringsAsFactors = FALSE)[rows,] + old <- as.data.frame(before_df, stringsAsFactors = FALSE)[rows, ] track_changes <- list(added = 0, changed = 0) - for (i in 1:length(cols)) { + for (i in seq_len(length(cols))) { verbose_new <- data.frame(row = rows, col = cols[i], mo_fullname = x[rows, "fullname"], @@ -530,6 +537,7 @@ eucast_rules <- function(x, AMP <- AMX } + # nolint start # antibiotic classes aminoglycosides <- c(TOB, GEN, KAN, NEO, NET, SIS) tetracyclines <- c(DOX, MNO, TCY) # since EUCAST v3.1 tigecycline (TGC) is set apart @@ -544,12 +552,13 @@ eucast_rules <- function(x, ureidopenicillins <- c(PIP, TZP, AZL, MEZ) all_betalactams <- c(aminopenicillins, cephalosporins, carbapenems, ureidopenicillins, AMC, OXA, FLC, PEN) fluoroquinolones <- c(OFX, CIP, NOR, LVX, MFX) + # nolint end # Help function to get available antibiotic column names ------------------ get_antibiotic_columns <- function(x, df) { x <- trimws(unlist(strsplit(x, ",", fixed = TRUE))) y <- character(0) - for (i in 1:length(x)) { + for (i in seq_len(length(x))) { if (is.function(get(x[i]))) { stop("Column ", x[i], " is also a function. Please create an issue on github.com/msberends/AMR/issues.") } @@ -562,7 +571,7 @@ eucast_rules <- function(x, strsplit(",") %>% unlist() %>% trimws() %>% - sapply(function(x) if(x %in% AMR::antibiotics$ab) ab_name(x, language = NULL, tolower = TRUE) else x) %>% + sapply(function(x) if (x %in% AMR::antibiotics$ab) ab_name(x, language = NULL, tolower = TRUE) else x) %>% sort() %>% paste(collapse = ", ") } @@ -598,14 +607,13 @@ eucast_rules <- function(x, eucast_rules_df <- eucast_rules_file # internal data file no_added <- 0 no_changed <- 0 - for (i in 1:nrow(eucast_rules_df)) { + for (i in seq_len(nrow(eucast_rules_df))) { rule_previous <- eucast_rules_df[max(1, i - 1), "reference.rule"] rule_current <- eucast_rules_df[i, "reference.rule"] rule_next <- eucast_rules_df[min(nrow(eucast_rules_df), i + 1), "reference.rule"] rule_group_previous <- eucast_rules_df[max(1, i - 1), "reference.rule_group"] rule_group_current <- eucast_rules_df[i, "reference.rule_group"] - rule_group_next <- eucast_rules_df[min(nrow(eucast_rules_df), i + 1), "reference.rule_group"] if (is.na(eucast_rules_df[i, 4])) { rule_text <- paste0("always report as '", eucast_rules_df[i, 7], "': ", get_antibiotic_names(eucast_rules_df[i, 6])) } else { @@ -620,7 +628,6 @@ eucast_rules <- function(x, } if (i == nrow(eucast_rules_df)) { rule_next <- "" - rule_group_next <- "" } # don't apply rules if user doesn't want to apply them @@ -695,7 +702,7 @@ eucast_rules <- function(x, if (like_is_one_of == "is") { mo_value <- paste0("^", eucast_rules_df[i, 3], "$") } else if (like_is_one_of == "one_of") { - # "Clostridium, Actinomyces, ..." -> "^(Clostridium|Actinomyces|...)$" + # so 'Clostridium, Actinomyces, ...' will turn into '^(Clostridium|Actinomyces|...)$' mo_value <- paste0("^(", paste(trimws(unlist(strsplit(eucast_rules_df[i, 3], ",", fixed = TRUE))), collapse = "|"), @@ -774,10 +781,10 @@ eucast_rules <- function(x, arrange(row, rule_group, rule_name, col) cat(paste0("\n", grey(strrep("-", options()$width - 1)), "\n")) - cat(bold(paste('EUCAST rules', paste0(wouldve, 'affected'), + cat(bold(paste("EUCAST 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'))) + "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() @@ -847,4 +854,3 @@ eucast_rules <- function(x, x_original } } - diff --git a/R/first_isolate.R b/R/first_isolate.R index 3e2aa3d9..fc9c24af 100755 --- a/R/first_isolate.R +++ b/R/first_isolate.R @@ -124,39 +124,11 @@ #' # set key antibiotics to a new variable #' x$keyab <- key_antibiotics(x) #' -#' x$first_isolate <- -#' first_isolate(x) +#' x$first_isolate <- first_isolate(x) #' -#' x$first_isolate_weighed <- -#' first_isolate(x, -#' col_keyantibiotics = 'keyab') +#' x$first_isolate_weighed <- first_isolate(x, col_keyantibiotics = 'keyab') #' -#' x$first_blood_isolate <- -#' first_isolate(x, -#' specimen_group = 'Blood') -#' -#' x$first_blood_isolate_weighed <- -#' first_isolate(x, -#' specimen_group = 'Blood', -#' col_keyantibiotics = 'keyab') -#' -#' x$first_urine_isolate <- -#' first_isolate(x, -#' specimen_group = 'Urine') -#' -#' x$first_urine_isolate_weighed <- -#' first_isolate(x, -#' specimen_group = 'Urine', -#' col_keyantibiotics = 'keyab') -#' -#' x$first_resp_isolate <- -#' first_isolate(x, -#' specimen_group = 'Respiratory') -#' -#' x$first_resp_isolate_weighed <- -#' first_isolate(x, -#' specimen_group = 'Respiratory', -#' col_keyantibiotics = 'keyab') +#' x$first_blood_isolate <- first_isolate(x, specimen_group = "Blood") #' } first_isolate <- function(x, col_date = NULL, @@ -176,23 +148,23 @@ first_isolate <- function(x, info = TRUE, include_unknown = FALSE, ...) { - + if (!is.data.frame(x)) { stop("`x` must be a data.frame.", call. = FALSE) } - + dots <- unlist(list(...)) if (length(dots) != 0) { # backwards compatibility with old parameters dots.names <- dots %>% names() - if ('filter_specimen' %in% dots.names) { - specimen_group <- dots[which(dots.names == 'filter_specimen')] + if ("filter_specimen" %in% dots.names) { + specimen_group <- dots[which(dots.names == "filter_specimen")] } - if ('tbl' %in% dots.names) { - x <- dots[which(dots.names == 'tbl')] + if ("tbl" %in% dots.names) { + x <- dots[which(dots.names == "tbl")] } } - + # try to find columns based on type # -- mo if (is.null(col_mo)) { @@ -201,7 +173,7 @@ first_isolate <- function(x, if (is.null(col_mo)) { stop("`col_mo` must be set.", call. = FALSE) } - + # -- date if (is.null(col_date)) { col_date <- search_type_in_df(x = x, type = "date") @@ -213,14 +185,14 @@ first_isolate <- function(x, dates <- x %>% pull(col_date) %>% as.Date() dates[is.na(dates)] <- as.Date("1970-01-01") x[, col_date] <- dates - + # -- patient id if (is.null(col_patient_id)) { - if (all(c("First name", "Last name", "Sex", "Identification number") %in% colnames(x))) { + if (all(c("First name", "Last name", "Sex") %in% colnames(x))) { # WHONET support x <- x %>% mutate(patient_id = paste(`First name`, `Last name`, Sex)) col_patient_id <- "patient_id" - message(blue(paste0("NOTE: Using combined columns `", bold("First name"), "`, `", bold("Last name"), "` and `", bold("Sex"), "` as input for `col_patient_id`."))) + message(blue(paste0("NOTE: Using combined columns `", bold("First name"), "`, `", bold("Last name"), "` and `", bold("Sex"), "` as input for `col_patient_id`"))) } else { col_patient_id <- search_type_in_df(x = x, type = "patient_id") } @@ -228,7 +200,7 @@ first_isolate <- function(x, if (is.null(col_patient_id)) { stop("`col_patient_id` must be set.", call. = FALSE) } - + # -- key antibiotics if (is.null(col_keyantibiotics)) { col_keyantibiotics <- search_type_in_df(x = x, type = "keyantibiotics") @@ -236,7 +208,7 @@ first_isolate <- function(x, if (isFALSE(col_keyantibiotics)) { col_keyantibiotics <- NULL } - + # -- specimen if (is.null(col_specimen) & !is.null(specimen_group)) { col_specimen <- search_type_in_df(x = x, type = "specimen") @@ -244,30 +216,30 @@ first_isolate <- function(x, if (isFALSE(col_specimen)) { col_specimen <- NULL } - + # check if columns exist check_columns_existance <- function(column, tblname = x) { if (NROW(tblname) <= 1 | NCOL(tblname) <= 1) { - stop('Please check tbl for existance.') + stop("Please check tbl for existance.") } - + if (!is.null(column)) { if (!(column %in% colnames(tblname))) { - stop('Column `', column, '` not found.') + stop("Column `", column, "` not found.") } } } - + check_columns_existance(col_date) check_columns_existance(col_patient_id) check_columns_existance(col_mo) check_columns_existance(col_testcode) check_columns_existance(col_icu) check_columns_existance(col_keyantibiotics) - + # create new dataframe with original row index x <- x %>% - mutate(newvar_row_index = 1:nrow(x), + mutate(newvar_row_index = seq_len(nrow(x)), newvar_mo = x %>% pull(col_mo) %>% as.mo(), newvar_genus_species = paste(mo_genus(newvar_mo), mo_species(newvar_mo)), newvar_date = x %>% pull(col_date), @@ -278,41 +250,41 @@ first_isolate <- function(x, } # remove testcodes if (!is.null(testcodes_exclude) & info == TRUE) { - cat('[Criterion] Excluded test codes:\n', toString(testcodes_exclude), '\n') + message(blue(paste0("[Criterion] Excluded test codes: ", toString(testcodes_exclude)))) } - + if (is.null(col_icu)) { icu_exclude <- FALSE } else { x <- x %>% mutate(col_icu = x %>% pull(col_icu) %>% as.logical()) } - + if (is.null(col_specimen)) { specimen_group <- NULL } - + # filter on specimen group and keyantibiotics when they are filled in if (!is.null(specimen_group)) { check_columns_existance(col_specimen, x) if (info == TRUE) { - cat('[Criterion] Excluded other than specimen group \'', specimen_group, '\'\n', sep = '') + message(blue(paste0("[Criterion] Excluded other than specimen group '", specimen_group, "'"))) } } if (!is.null(col_keyantibiotics)) { x <- x %>% mutate(key_ab = x %>% pull(col_keyantibiotics)) } - + if (is.null(testcodes_exclude)) { - testcodes_exclude <- '' + testcodes_exclude <- "" } - + # arrange data to the right sorting if (is.null(specimen_group)) { # not filtering on specimen if (icu_exclude == FALSE) { if (info == TRUE & !is.null(col_icu)) { - cat('[Criterion] Included isolates from ICU.\n') + message(blue("[Criterion] Included isolates from ICU")) } x <- x %>% arrange(newvar_patient_id, @@ -322,14 +294,14 @@ first_isolate <- function(x, row.end <- nrow(x) } else { if (info == TRUE) { - cat('[Criterion] Excluded isolates from ICU.\n') + message(blue("[Criterion] Excluded isolates from ICU")) } x <- x %>% arrange_at(c(col_icu, "newvar_patient_id", "newvar_genus_species", "newvar_date")) - + suppressWarnings( row.start <- which(x %>% pull(col_icu) == FALSE) %>% min(na.rm = TRUE) ) @@ -337,12 +309,12 @@ first_isolate <- function(x, row.end <- which(x %>% pull(col_icu) == FALSE) %>% max(na.rm = TRUE) ) } - + } else { # filtering on specimen and only analyse these row to save time if (icu_exclude == FALSE) { if (info == TRUE & !is.null(col_icu)) { - cat('[Criterion] Included isolates from ICU.\n') + message(blue("[Criterion] Included isolates from ICU.\n")) } x <- x %>% arrange_at(c(col_specimen, @@ -357,7 +329,7 @@ first_isolate <- function(x, ) } else { if (info == TRUE) { - cat('[Criterion] Excluded isolates from ICU.\n') + message(blue("[Criterion] Excluded isolates from ICU")) } x <- x %>% arrange_at(c(col_icu, @@ -366,17 +338,19 @@ first_isolate <- function(x, "newvar_genus_species", "newvar_date")) suppressWarnings( - row.start <- which(x %>% pull(col_specimen) == specimen_group - & x %>% pull(col_icu) == FALSE) %>% min(na.rm = TRUE) + row.start <- min(which(x %>% pull(col_specimen) == specimen_group + & x %>% pull(col_icu) == FALSE), + na.rm = TRUE) ) suppressWarnings( - row.end <- which(x %>% pull(col_specimen) == specimen_group - & x %>% pull(col_icu) == FALSE) %>% max(na.rm = TRUE) + row.end <- max(which(x %>% pull(col_specimen) == specimen_group & + x %>% pull(col_icu) == FALSE), + na.rm = TRUE) ) } - + } - + # no isolates found if (abs(row.start) == Inf | abs(row.end) == Inf) { if (info == TRUE) { @@ -386,21 +360,11 @@ first_isolate <- function(x, } # did find some isolates - add new index numbers of rows - x <- x %>% mutate(newvar_row_index_sorted = 1:nrow(.)) - - # suppress warnings because dplyr wants us to use library(dplyr) when using filter(row_number()) - #suppressWarnings( - scope.size <- row.end - row.start + 1 - # x %>% - # filter( - # row_number() %>% between(row.start, - # row.end), - # newvar_genus != "", - # newvar_species != "") %>% - # nrow() - # ) - - identify_new_year = function(x, episode_days) { + x <- x %>% mutate(newvar_row_index_sorted = seq_len(nrow(.))) + + scope.size <- row.end - row.start + 1 + + identify_new_year <- function(x, episode_days) { # I asked on StackOverflow: # https://stackoverflow.com/questions/42122245/filter-one-row-every-year if (length(x) == 1) { @@ -421,7 +385,7 @@ first_isolate <- function(x, result[indices] <- TRUE return(result) } - + # Analysis of first isolate ---- all_first <- x %>% mutate(other_pat_or_mo = if_else(newvar_patient_id == lag(newvar_patient_id) @@ -433,21 +397,19 @@ first_isolate <- function(x, mutate(more_than_episode_ago = identify_new_year(x = newvar_date, episode_days = episode_days)) %>% ungroup() - - weighted.notice <- '' + + weighted.notice <- "" if (!is.null(col_keyantibiotics)) { - weighted.notice <- 'weighted ' + weighted.notice <- "weighted " if (info == TRUE) { - if (type == 'keyantibiotics') { - cat('[Criterion] Inclusion based on key antibiotics, ') - if (ignore_I == FALSE) { - cat('not ') - } - cat('ignoring I.\n') + if (type == "keyantibiotics") { + message(blue(paste0("[Criterion] Inclusion based on key antibiotics, ", + ifelse(ignore_I == FALSE, "not ", ""), + "ignoring I"))) } - if (type == 'points') { - cat(paste0('[Criterion] Inclusion based on key antibiotics, using points threshold of ' - , points_threshold, '.\n')) + if (type == "points") { + message(blue(paste0("[Criterion] Inclusion based on key antibiotics, using points threshold of " + , points_threshold))) } } type_param <- type @@ -473,24 +435,24 @@ first_isolate <- function(x, # no key antibiotics all_first <- all_first %>% mutate( - real_first_isolate = - if_else( - newvar_row_index_sorted %>% between(row.start, row.end) - & newvar_genus_species != "" - & (other_pat_or_mo | more_than_episode_ago), - TRUE, - FALSE)) + real_first_isolate = + if_else( + newvar_row_index_sorted %>% between(row.start, row.end) + & newvar_genus_species != "" + & (other_pat_or_mo | more_than_episode_ago), + TRUE, + FALSE)) } - + # first one as TRUE - all_first[row.start, 'real_first_isolate'] <- TRUE + all_first[row.start, "real_first_isolate"] <- TRUE # no tests that should be included, or ICU if (!is.null(col_testcode)) { - all_first[which(all_first[, col_testcode] %in% tolower(testcodes_exclude)), 'real_first_isolate'] <- FALSE + all_first[which(all_first[, col_testcode] %in% tolower(testcodes_exclude)), "real_first_isolate"] <- FALSE } if (icu_exclude == TRUE) { - all_first[which(all_first[, col_icu] == TRUE), 'real_first_isolate'] <- FALSE + all_first[which(all_first[, col_icu] == TRUE), "real_first_isolate"] <- FALSE } decimal.mark <- getOption("OutDec") @@ -498,26 +460,20 @@ first_isolate <- function(x, # handle empty microorganisms if (any(all_first$newvar_mo == "UNKNOWN", na.rm = TRUE) & info == TRUE) { - if (include_unknown == TRUE) { - message(blue(paste0("NOTE: Included ", format(sum(all_first$newvar_mo == "UNKNOWN"), - decimal.mark = decimal.mark, big.mark = big.mark), - ' isolates with a microbial ID "UNKNOWN" (column `', bold(col_mo), '`).'))) - } else { - message(blue(paste0("NOTE: Excluded ", format(sum(all_first$newvar_mo == "UNKNOWN"), - decimal.mark = decimal.mark, big.mark = big.mark), - ' isolates with a microbial ID "UNKNOWN" (column `', bold(col_mo), '`).'))) - - } + message(blue(paste0("NOTE: ", ifelse(include_unknown == TRUE, "Included ", "Excluded "), + format(sum(all_first$newvar_mo == "UNKNOWN"), + decimal.mark = decimal.mark, big.mark = big.mark), + " isolates with a microbial ID 'UNKNOWN' (column `", bold(col_mo), "`)"))) } - all_first[which(all_first$newvar_mo == "UNKNOWN"), 'real_first_isolate'] <- include_unknown + all_first[which(all_first$newvar_mo == "UNKNOWN"), "real_first_isolate"] <- include_unknown # exclude all NAs if (any(is.na(all_first$newvar_mo)) & info == TRUE) { message(blue(paste0("NOTE: Excluded ", format(sum(is.na(all_first$newvar_mo)), decimal.mark = decimal.mark, big.mark = big.mark), - ' isolates with a microbial ID "NA" (column `', bold(col_mo), '`).'))) + " isolates with a microbial ID 'NA' (column `", bold(col_mo), "`)"))) } - all_first[which(is.na(all_first$newvar_mo)), 'real_first_isolate'] <- FALSE + all_first[which(is.na(all_first$newvar_mo)), "real_first_isolate"] <- FALSE # arrange back according to original sorting again all_first <- all_first %>% @@ -541,9 +497,9 @@ first_isolate <- function(x, } base::message(msg_txt) } - + all_first - + } #' @rdname first_isolate @@ -580,5 +536,5 @@ filter_first_weighted_isolate <- function(x, col_mo = col_mo, col_keyantibiotics = "keyab", ...)) - x[which(tbl_keyab$firsts == TRUE),] + x[which(tbl_keyab$firsts == TRUE), ] } diff --git a/R/g.test.R b/R/g.test.R index 10a70572..adf6db01 100755 --- a/R/g.test.R +++ b/R/g.test.R @@ -107,10 +107,10 @@ #' # Meaning: there are significantly more left-billed birds. #' g.test <- function(x, - y = NULL, - # correct = TRUE, - p = rep(1/length(x), length(x)), - rescale.p = FALSE) { + y = NULL, + # correct = TRUE, + p = rep(1 / length(x), length(x)), + rescale.p = FALSE) { DNAME <- deparse(substitute(x)) if (is.data.frame(x)) x <- as.matrix(x) @@ -144,11 +144,8 @@ g.test <- function(x, stop("all entries of 'x' must be nonnegative and finite") if ((n <- sum(x)) == 0) stop("at least one entry of 'x' must be positive") - # if (simulate.p.value) { - # setMETH <- function() METHOD <<- paste(METHOD, "with simulated p-value\n\t (based on", - # B, "replicates)") - # almost.1 <- 1 - 64 * .Machine$double.eps - # } + + if (is.matrix(x)) { METHOD <- "G-test of independence" nr <- as.integer(nrow(x)) @@ -157,34 +154,18 @@ g.test <- function(x, stop("invalid nrow(x) or ncol(x)", domain = NA) # add fisher.test suggestion if (nr == 2 && nc == 2) - warning("`fisher.test()` is always more reliable for 2x2 tables and although must slower, often only takes seconds.") + warning("`fisher.test()` is always more reliable for 2x2 tables and although much slower, often only takes seconds.") sr <- rowSums(x) sc <- colSums(x) - E <- outer(sr, sc, "*")/n - v <- function(r, c, n) c * r * (n - r) * (n - c)/n^3 + E <- outer(sr, sc, "*") / n + v <- function(r, c, n) c * r * (n - r) * (n - c) / n ^ 3 V <- outer(sr, sc, v, n) dimnames(E) <- dimnames(x) - # if (simulate.p.value && all(sr > 0) && all(sc > 0)) { - # setMETH() - # tmp <- .Call(chisq_sim, sr, sc, B, E, PACKAGE = "stats") - # STATISTIC <- 2 * sum(x * log(x / E)) # sum(sort((x - E)^2/E, decreasing = TRUE)) for chisq.test - # PARAMETER <- NA - # PVAL <- (1 + sum(tmp >= almost.1 * STATISTIC))/(B + - # 1) - # } - # else { - # if (simulate.p.value) - # warning("cannot compute simulated p-value with zero marginals") - # if (correct && nrow(x) == 2L && ncol(x) == 2L) { - # YATES <- min(0.5, abs(x - E)) - # if (YATES > 0) - # METHOD <- paste(METHOD, "with Yates' continuity correction") - # } - # else YATES <- 0 - STATISTIC <- 2 * sum(x * log(x / E)) # sum((abs(x - E) - YATES)^2/E) for chisq.test - PARAMETER <- (nr - 1L) * (nc - 1L) - PVAL <- pchisq(STATISTIC, PARAMETER, lower.tail = FALSE) - # } + + STATISTIC <- 2 * sum(x * log(x / E)) # sum((abs(x - E) - YATES)^2/E) for chisq.test + PARAMETER <- (nr - 1L) * (nc - 1L) + PVAL <- pchisq(STATISTIC, PARAMETER, lower.tail = FALSE) + } else { if (length(dim(x)) > 2L) @@ -197,7 +178,7 @@ g.test <- function(x, stop("probabilities must be non-negative.") if (abs(sum(p) - 1) > sqrt(.Machine$double.eps)) { if (rescale.p) - p <- p/sum(p) + p <- p / sum(p) else stop("probabilities must sum to 1.") } METHOD <- "G-test of goodness-of-fit (likelihood ratio test)" @@ -205,30 +186,18 @@ g.test <- function(x, V <- n * p * (1 - p) STATISTIC <- 2 * sum(x * log(x / E)) # sum((x - E)^2/E) for chisq.test names(E) <- names(x) - # if (simulate.p.value) { - # setMETH() - # nx <- length(x) - # sm <- matrix(sample.int(nx, B * n, TRUE, prob = p), - # nrow = n) - # ss <- apply(sm, 2L, function(x, E, k) { - # sum((table(factor(x, levels = 1L:k)) - E)^2/E) - # }, E = E, k = nx) - # PARAMETER <- NA - # PVAL <- (1 + sum(ss >= almost.1 * STATISTIC))/(B + - # 1) - # } - # else { - PARAMETER <- length(x) - 1 - PVAL <- pchisq(STATISTIC, PARAMETER, lower.tail = FALSE) - # } + + PARAMETER <- length(x) - 1 + PVAL <- pchisq(STATISTIC, PARAMETER, lower.tail = FALSE) + } names(STATISTIC) <- "X-squared" names(PARAMETER) <- "df" if (any(E < 5) && is.finite(PARAMETER)) warning("G-statistic approximation may be incorrect due to E < 5") - + structure(list(statistic = STATISTIC, parameter = PARAMETER, p.value = PVAL, method = METHOD, data.name = DNAME, - observed = x, expected = E, residuals = (x - E)/sqrt(E), - stdres = (x - E)/sqrt(V)), class = "htest") + observed = x, expected = E, residuals = (x - E) / sqrt(E), + stdres = (x - E) / sqrt(V)), class = "htest") } diff --git a/R/ggplot_rsi.R b/R/ggplot_rsi.R index fca3c869..06b8a199 100755 --- a/R/ggplot_rsi.R +++ b/R/ggplot_rsi.R @@ -292,9 +292,9 @@ geom_rsi <- function(position = NULL, x <- substr(x, 2, nchar(x) - 1) } - if (tolower(x) %in% tolower(c('ab', 'abx', 'antibiotics'))) { + if (tolower(x) %in% tolower(c("ab", "abx", "antibiotics"))) { x <- "antibiotic" - } else if (tolower(x) %in% tolower(c('SIR', 'RSI', 'interpretations', 'result'))) { + } else if (tolower(x) %in% tolower(c("SIR", "RSI", "interpretations", "result"))) { x <- "interpretation" } @@ -327,9 +327,9 @@ facet_rsi <- function(facet = c("interpretation", "antibiotic"), nrow = NULL) { facet <- substr(facet, 2, nchar(facet) - 1) } - if (tolower(facet) %in% tolower(c('SIR', 'RSI', 'interpretations', 'result'))) { + if (tolower(facet) %in% tolower(c("SIR", "RSI", "interpretations", "result"))) { facet <- "interpretation" - } else if (tolower(facet) %in% tolower(c('ab', 'abx', 'antibiotics'))) { + } else if (tolower(facet) %in% tolower(c("ab", "abx", "antibiotics"))) { facet <- "antibiotic" } @@ -358,8 +358,8 @@ scale_rsi_colours <- function(colours = c(S = "#61a8ff", IR = "#ff6961", R = "#ff6961")) { stopifnot_installed_package("ggplot2") - #ggplot2::scale_fill_brewer(palette = "RdYlGn") - #ggplot2::scale_fill_manual(values = c("#b22222", "#ae9c20", "#7cfc00")) + # previous colour: palette = "RdYlGn" + # previous colours: values = c("#b22222", "#ae9c20", "#7cfc00") if (!identical(colours, FALSE)) { original_cols <- c(S = "#61a8ff", diff --git a/R/guess_ab_col.R b/R/guess_ab_col.R index 35a7c170..41a20189 100755 --- a/R/guess_ab_col.R +++ b/R/guess_ab_col.R @@ -83,9 +83,6 @@ guess_ab_col <- function(x = NULL, search_string = NULL, verbose = FALSE) { } else if (any(tolower(colnames(x)) %in% tolower(unlist(ab_property(search_string.ab, "abbreviations"))))) { ab_result <- colnames(x)[tolower(colnames(x)) %in% tolower(unlist(ab_property(search_string.ab, "abbreviations")))][1L] - # } else if (any(tolower(colnames(x)) %in% tolower(ab_tradenames(search_string.ab)))) { - # ab_result <- colnames(x)[tolower(colnames(x)) %in% tolower(ab_tradenames(search_string.ab))][1L] - } else { # sort colnames on length - longest first cols <- colnames(x[, x %>% colnames() %>% nchar() %>% order() %>% rev()]) @@ -128,7 +125,7 @@ get_column_abx <- function(x, # only check columns that are a valid AB code, ATC code, name, abbreviation or synonym, # or already have the rsi class (as.rsi) # and that have no more than 50% invalid values - vectr_antibiotics <- unique(toupper(unlist(AMR::antibiotics[,c("ab", "atc", "name", "abbreviations", "synonyms")]))) + vectr_antibiotics <- unique(toupper(unlist(AMR::antibiotics[, c("ab", "atc", "name", "abbreviations", "synonyms")]))) vectr_antibiotics <- vectr_antibiotics[!is.na(vectr_antibiotics) & nchar(vectr_antibiotics) >= 3] x_columns <- sapply(colnames(x), function(col, df = x_bak) { if (toupper(col) %in% vectr_antibiotics | @@ -144,12 +141,12 @@ get_column_abx <- function(x, df_trans <- data.frame(colnames = 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) names(x) <- df_trans$abcode # add from self-defined dots (...): - # get_column_abx(example_isolates %>% rename(thisone = AMX), amox = "thisone") + # such as get_column_abx(example_isolates %>% rename(thisone = AMX), amox = "thisone") dots <- list(...) if (length(dots) > 0) { newnames <- suppressWarnings(as.ab(names(dots))) @@ -173,12 +170,12 @@ get_column_abx <- function(x, x <- x[!names(x) %in% names(duplicates)] if (verbose == TRUE) { - for (i in 1:length(x)) { + for (i in seq_len(length(x))) { message(blue(paste0("NOTE: Using column `", bold(x[i]), "` as input for `", names(x)[i], "` (", ab_name(names(x)[i], tolower = TRUE), ")."))) } } else if (length(duplicates) > 0) { - for (i in 1:length(duplicates)) { + for (i in seq_len(length(duplicates))) { warning(red(paste0("Using column `", bold(duplicates[i]), "` as input for `", names(x[which(x == duplicates[i])]), "` (", ab_name(names(x[names(which(x == duplicates))[i]]), tolower = TRUE), "), although it was matched for multiple antibiotics or columns.")), call. = FALSE) @@ -203,7 +200,7 @@ get_column_abx <- function(x, mutate(txt = paste0(bold(missing), " (", missing_names, ")")) %>% arrange(missing_names) %>% pull(txt) - message(blue('NOTE: Reliability might be improved if these antimicrobial results would be available too:', + message(blue("NOTE: Reliability might be improved if these antimicrobial results would be available too:", paste(missing_txt, collapse = ", "))) } } diff --git a/R/join_microorganisms.R b/R/join_microorganisms.R index fb5a6001..d504bea0 100755 --- a/R/join_microorganisms.R +++ b/R/join_microorganisms.R @@ -56,7 +56,7 @@ inner_join_microorganisms <- function(x, by = NULL, suffix = c("2", ""), ...) { dplyr::inner_join(x = x, y = AMR::microorganisms, by = by, suffix = suffix, ...) ) if (nrow(join) > nrow(x)) { - warning('The newly joined tbl contains ', nrow(join) - nrow(x), ' rows more that its original.') + warning("The newly joined tbl contains ", nrow(join) - nrow(x), " rows more that its original.") } join } @@ -71,7 +71,7 @@ left_join_microorganisms <- function(x, by = NULL, suffix = c("2", ""), ...) { dplyr::left_join(x = x, y = AMR::microorganisms, by = by, suffix = suffix, ...) ) if (nrow(join) > nrow(x)) { - warning('The newly joined tbl contains ', nrow(join) - nrow(x), ' rows more that its original.') + warning("The newly joined tbl contains ", nrow(join) - nrow(x), " rows more that its original.") } join } @@ -86,7 +86,7 @@ right_join_microorganisms <- function(x, by = NULL, suffix = c("2", ""), ...) { dplyr::right_join(x = x, y = AMR::microorganisms, by = by, suffix = suffix, ...) ) if (nrow(join) > nrow(x)) { - warning('The newly joined tbl contains ', nrow(join) - nrow(x), ' rows more that its original.') + warning("The newly joined tbl contains ", nrow(join) - nrow(x), " rows more that its original.") } join } @@ -101,7 +101,7 @@ full_join_microorganisms <- function(x, by = NULL, suffix = c("2", ""), ...) { dplyr::full_join(x = x, y = AMR::microorganisms, by = by, suffix = suffix, ...) ) if (nrow(join) > nrow(x)) { - warning('The newly joined tbl contains ', nrow(join) - nrow(x), ' rows more that its original.') + warning("The newly joined tbl contains ", nrow(join) - nrow(x), " rows more that its original.") } join } diff --git a/R/key_antibiotics.R b/R/key_antibiotics.R index 81d12899..a62a9da0 100755 --- a/R/key_antibiotics.R +++ b/R/key_antibiotics.R @@ -118,7 +118,7 @@ key_antibiotics <- function(x, names(col.list) <- col.list col.list.bak <- col.list # are they available as upper case or lower case then? - for (i in 1:length(col.list)) { + for (i in seq_len(length(col.list))) { if (is.null(col.list[i]) | isTRUE(is.na(col.list[i]))) { col.list[i] <- NA } else if (toupper(col.list[i]) %in% colnames(x)) { @@ -131,9 +131,9 @@ key_antibiotics <- function(x, } if (!all(col.list %in% colnames(x))) { if (info == TRUE) { - warning('Some columns do not exist and will be ignored: ', + warning("Some columns do not exist and will be ignored: ", col.list.bak[!(col.list %in% colnames(x))] %>% toString(), - '.\nTHIS MAY STRONGLY INFLUENCE THE OUTCOME.', + ".\nTHIS MAY STRONGLY INFLUENCE THE OUTCOME.", immediate. = TRUE, call. = FALSE) } @@ -164,7 +164,7 @@ key_antibiotics <- function(x, universal <- c(universal_1, universal_2, universal_3, universal_4, universal_5, universal_6) - gram_positive = c(universal, + gram_positive <- c(universal, GramPos_1, GramPos_2, GramPos_3, GramPos_4, GramPos_5, GramPos_6) gram_positive <- gram_positive[!is.null(gram_positive)] @@ -173,7 +173,7 @@ key_antibiotics <- function(x, 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_4, GramNeg_5, GramNeg_6) gram_negative <- gram_negative[!is.null(gram_negative)] @@ -211,8 +211,8 @@ key_antibiotics <- function(x, # format key_abs <- x %>% pull(key_ab) %>% - gsub('(NA|NULL)', '.', .) %>% - gsub('[^SIR]', '.', ., ignore.case = TRUE) %>% + gsub("(NA|NULL)", ".", .) %>% + gsub("[^SIR]", ".", ., ignore.case = TRUE) %>% toupper() if (n_distinct(key_abs) == 1) { @@ -239,7 +239,7 @@ key_antibiotics_equal <- function(y, type <- type[1] if (length(x) != length(y)) { - stop('Length of `x` and `y` must be equal.') + stop("Length of `x` and `y` must be equal.") } # only show progress bar on points or when at least 5000 isolates @@ -251,17 +251,17 @@ key_antibiotics_equal <- function(y, p <- dplyr::progress_estimated(length(x)) } - for (i in 1:length(x)) { + for (i in seq_len(length(x))) { if (info_needed == TRUE) { p$tick()$print() } if (is.na(x[i])) { - x[i] <- '' + x[i] <- "" } if (is.na(y[i])) { - y[i] <- '' + y[i] <- "" } if (x[i] == y[i]) { @@ -277,7 +277,7 @@ key_antibiotics_equal <- function(y, x_split <- strsplit(x[i], "")[[1]] y_split <- strsplit(y[i], "")[[1]] - if (type == 'keyantibiotics') { + if (type == "keyantibiotics") { if (ignore_I == TRUE) { x_split[x_split == "I"] <- "." @@ -289,7 +289,7 @@ key_antibiotics_equal <- function(y, result[i] <- all(x_split == y_split) - } else if (type == 'points') { + } else if (type == "points") { # count points for every single character: # - no change is 0 points # - I <-> S|R is 0.5 point @@ -303,12 +303,12 @@ key_antibiotics_equal <- function(y, result[i] <- points >= points_threshold } 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') } } } if (info_needed == TRUE) { - cat('\n') + cat("\n") } result } diff --git a/R/kurtosis.R b/R/kurtosis.R index cc715be6..aa0f4150 100755 --- a/R/kurtosis.R +++ b/R/kurtosis.R @@ -37,7 +37,7 @@ kurtosis <- function(x, na.rm = FALSE) { #' @exportMethod kurtosis.default #' @rdname kurtosis #' @export -kurtosis.default <- function (x, na.rm = FALSE) { +kurtosis.default <- function(x, na.rm = FALSE) { x <- as.vector(x) if (na.rm == TRUE) { x <- x[!is.na(x)] @@ -50,13 +50,13 @@ kurtosis.default <- function (x, na.rm = FALSE) { #' @exportMethod kurtosis.matrix #' @rdname kurtosis #' @export -kurtosis.matrix <- function (x, na.rm = FALSE) { +kurtosis.matrix <- function(x, na.rm = FALSE) { base::apply(x, 2, kurtosis.default, na.rm = na.rm) } #' @exportMethod kurtosis.data.frame #' @rdname kurtosis #' @export -kurtosis.data.frame <- function (x, na.rm = FALSE) { +kurtosis.data.frame <- function(x, na.rm = FALSE) { base::sapply(x, kurtosis.default, na.rm = na.rm) } diff --git a/R/like.R b/R/like.R index eb4836c7..eedfd210 100755 --- a/R/like.R +++ b/R/like.R @@ -69,7 +69,7 @@ like <- function(x, pattern, ignore.case = TRUE) { } else { # x and pattern are of same length, so items with each other res <- vector(length = length(pattern)) - for (i in 1:length(res)) { + for (i in seq_len(length(res))) { if (is.factor(x[i])) { res[i] <- as.integer(x[i]) %in% base::grep(pattern[i], levels(x[i]), ignore.case = ignore.case) } else { diff --git a/R/mdro.R b/R/mdro.R index 5e3b749c..06aa2642 100755 --- a/R/mdro.R +++ b/R/mdro.R @@ -272,7 +272,7 @@ mdro <- function(x, row_filter <- which(x[, cols] == "R") } else if (any_all == "all") { row_filter <- x %>% - mutate(index = 1:nrow(.)) %>% + mutate(index = seq_len(nrow(.))) %>% filter_at(vars(cols), all_vars(. == "R")) %>% pull((index)) } @@ -452,7 +452,7 @@ mdro <- function(x, & !ab_missing(GEN) & !ab_missing(TOB) & !ab_missing(CIP) & !ab_missing(CAZ) - & !ab_missing(TZP) ) { + & !ab_missing(TZP)) { x$psae <- 0 x[which(x[, MEM] == "R" | x[, IPM] == "R"), "psae"] <- 1 + x[which(x[, MEM] == "R" | x[, IPM] == "R"), "psae"] x[which(x[, GEN] == "R" & x[, TOB] == "R"), "psae"] <- 1 + x[which(x[, GEN] == "R" & x[, TOB] == "R"), "psae"] diff --git a/R/mic.R b/R/mic.R index 56d60b56..4dbf0b60 100755 --- a/R/mic.R +++ b/R/mic.R @@ -65,29 +65,29 @@ as.mic <- function(x, na.rm = FALSE) { x.bak <- x # comma to period - x <- gsub(',', '.', x, fixed = TRUE) + x <- gsub(",", ".", x, fixed = TRUE) # remove space between operator and number ("<= 0.002" -> "<=0.002") - x <- gsub('(<|=|>) +', '\\1', x) + x <- gsub("(<|=|>) +", "\\1", x) # transform => to >= and =< to <= - x <- gsub('=>', '>=', x, fixed = TRUE) - x <- gsub('=<', '<=', x, fixed = TRUE) + x <- gsub("=>", ">=", x, fixed = TRUE) + x <- gsub("=<", "<=", x, fixed = TRUE) # starting dots must start with 0 - x <- gsub('^[.]+', '0.', x) + x <- gsub("^[.]+", "0.", x) # <=0.2560.512 should be 0.512 - x <- gsub('.*[.].*[.]', '0.', x) + x <- gsub(".*[.].*[.]", "0.", x) # remove ending .0 - x <- gsub('[.]+0$', '', x) + x <- gsub("[.]+0$", "", x) # remove all after last digit - x <- gsub('[^0-9]+$', '', x) + x <- gsub("[^0-9]+$", "", x) # keep only one zero before dot x <- gsub("0+[.]", "0.", x) # starting 00 is probably 0.0 if there's no dot yet x[!x %like% "[.]"] <- gsub("^00", "0.0", x[!x %like% "[.]"]) # remove last zeroes - x <- gsub('([.].?)0+$', '\\1', x) - x <- gsub('(.*[.])0+$', '\\10', x) + x <- gsub("([.].?)0+$", "\\1", x) + x <- gsub("(.*[.])0+$", "\\10", x) # remove ending .0 again - x[x %like% "[.]"] <- gsub('0+$', '', x[x %like% "[.]"]) + x[x %like% "[.]"] <- gsub("0+$", "", x[x %like% "[.]"]) # force to be character x <- as.character(x) # trim it @@ -190,23 +190,23 @@ as.mic <- function(x, na.rm = FALSE) { "<1024", "<=1024", "1024", ">=1024", ">1024", "1025") - na_before <- x[is.na(x) | x == ''] %>% length() + na_before <- x[is.na(x) | x == ""] %>% length() 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) { - 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() %>% sort() - list_missing <- paste0('"', list_missing , '"', collapse = ", ") - warning(na_after - na_before, ' results truncated (', + list_missing <- paste0('"', list_missing, '"', collapse = ", ") + warning(na_after - na_before, " results truncated (", round(((na_after - na_before) / length(x)) * 100), - '%) that were invalid MICs: ', + "%) that were invalid MICs: ", list_missing, call. = FALSE) } structure(.Data = factor(x, levels = lvls, ordered = TRUE), - class = c('mic', 'ordered', 'factor')) + class = c("mic", "ordered", "factor")) } } @@ -214,36 +214,36 @@ as.mic <- function(x, na.rm = FALSE) { #' @export #' @importFrom dplyr %>% is.mic <- function(x) { - class(x) %>% identical(c('mic', 'ordered', 'factor')) + class(x) %>% identical(c("mic", "ordered", "factor")) } #' @exportMethod as.double.mic #' @export #' @noRd as.double.mic <- function(x, ...) { - as.double(gsub('(<|=|>)+', '', as.character(x))) + as.double(gsub("(<|=|>)+", "", as.character(x))) } #' @exportMethod as.integer.mic #' @export #' @noRd as.integer.mic <- function(x, ...) { - as.integer(gsub('(<|=|>)+', '', as.character(x))) + as.integer(gsub("(<|=|>)+", "", as.character(x))) } #' @exportMethod as.numeric.mic #' @export #' @noRd as.numeric.mic <- function(x, ...) { - as.numeric(gsub('(<|=|>)+', '', as.character(x))) + as.numeric(gsub("(<|=|>)+", "", as.character(x))) } #' @exportMethod droplevels.mic #' @export #' @noRd -droplevels.mic <- function(x, exclude = if(anyNA(levels(x))) NULL else NA, ...) { +droplevels.mic <- function(x, exclude = ifelse(anyNA(levels(x)), NULL, NA), ...) { x <- droplevels.factor(x, exclude = exclude, ...) - class(x) <- c('mic', 'ordered', 'factor') + class(x) <- c("mic", "ordered", "factor") x } @@ -266,7 +266,7 @@ summary.mic <- function(object, ...) { x <- x[!is.na(x)] n <- x %>% length() c( - "Class" = 'mic', + "Class" = "mic", "" = n_total - n, "Min." = sort(x)[1] %>% as.character(), "Max." = sort(x)[n] %>% as.character() @@ -278,9 +278,9 @@ summary.mic <- function(object, ...) { #' @importFrom graphics barplot axis par #' @noRd plot.mic <- function(x, - main = paste('MIC values of', deparse(substitute(x))), - ylab = 'Frequency', - xlab = 'MIC value', + main = paste("MIC values of", deparse(substitute(x))), + ylab = "Frequency", + xlab = "MIC value", axes = FALSE, ...) { barplot(table(droplevels.factor(x)), @@ -297,9 +297,9 @@ plot.mic <- function(x, #' @importFrom graphics barplot axis #' @noRd barplot.mic <- function(height, - main = paste('MIC values of', deparse(substitute(height))), - ylab = 'Frequency', - xlab = 'MIC value', + main = paste("MIC values of", deparse(substitute(height))), + ylab = "Frequency", + xlab = "MIC value", axes = FALSE, ...) { barplot(table(droplevels.factor(height)), diff --git a/R/misc.R b/R/misc.R index 0f53d59e..4bd874c3 100755 --- a/R/misc.R +++ b/R/misc.R @@ -67,7 +67,7 @@ search_type_in_df <- function(x, type) { call. = FALSE) } } else { - for (i in 1:ncol(x)) { + for (i in seq_len(ncol(x))) { if (any(class(x %>% pull(i)) %in% c("Date", "POSIXct"))) { found <- colnames(x)[i] break @@ -141,7 +141,7 @@ getdecimalplaces <- function(x, minimum = 0, maximum = 3) { if (minimum > maximum) { minimum <- maximum } - max_places <- max(unlist(lapply(strsplit(sub('0+$', '', + max_places <- max(unlist(lapply(strsplit(sub("0+$", "", as.character(x * 100)), ".", fixed = TRUE), function(y) ifelse(length(y) == 2, nchar(y[2]), 0))), na.rm = TRUE) max(min(max_places, diff --git a/R/mo.R b/R/mo.R index 524d19a1..cc6e9427 100755 --- a/R/mo.R +++ b/R/mo.R @@ -197,7 +197,7 @@ as.mo <- function(x, Becker = FALSE, Lancefield = FALSE, allow_uncertain = TRUE, & isFALSE(Becker) & isFALSE(Lancefield) & !is.null(reference_df) - & all(x %in% reference_df[,1][[1]])) { + & all(x %in% reference_df[, 1][[1]])) { # has valid own reference_df # (data.table not faster here) @@ -308,13 +308,13 @@ exec_as.mo <- function(x, # support tidyverse selection like: df %>% select(colA, colB) # paste these columns together x_vector <- vector("character", NROW(x)) - for (i in 1:NROW(x)) { - x_vector[i] <- paste(pull(x[i,], 1), pull(x[i,], 2), sep = " ") + for (i in seq_len(NROW(x))) { + x_vector[i] <- paste(pull(x[i, ], 1), pull(x[i, ], 2), sep = " ") } x <- x_vector } else { if (NCOL(x) > 2) { - stop('`x` can be 2 columns at most', call. = FALSE) + stop("`x` can be 2 columns at most", call. = FALSE) } x[is.null(x)] <- NA @@ -544,7 +544,7 @@ exec_as.mo <- function(x, # if the input is longer than 10 characters, allow any constant between all characters, as some might have forgotten a character # this will allow "Pasteurella damatis" to be correctly read as "Pasteurella dagmatis". constants <- paste(letters[!letters %in% c("a", "e", "i", "o", "u")], collapse = "") - #x[nchar(x_backup_without_spp) > 10] <- gsub("([a-z])([a-z])", paste0("\\1[", constants, "]?\\2"), x[nchar(x_backup_without_spp) > 10]) + x[nchar(x_backup_without_spp) > 10] <- gsub("[+]", paste0("+[", constants, "]?"), x[nchar(x_backup_without_spp) > 10]) } x <- strip_whitespace(x, dyslexia_mode) @@ -558,11 +558,11 @@ exec_as.mo <- function(x, x_withspaces <- gsub("[ .]+", ".* ", x) x <- gsub("[ .]+", ".*", x) # add start en stop regex - x <- paste0('^', x, '$') + x <- paste0("^", x, "$") - x_withspaces_start_only <- paste0('^', x_withspaces) - x_withspaces_end_only <- paste0(x_withspaces, '$') - x_withspaces_start_end <- paste0('^', x_withspaces, '$') + x_withspaces_start_only <- paste0("^", x_withspaces) + x_withspaces_end_only <- paste0(x_withspaces, "$") + x_withspaces_start_end <- paste0("^", x_withspaces, "$") if (isTRUE(debug)) { cat(paste0('x "', x, '"\n')) @@ -579,7 +579,7 @@ exec_as.mo <- function(x, progress <- progress_estimated(n = length(x), min_time = 3) - for (i in 1:length(x)) { + for (i in seq_len(length(x))) { progress$tick()$print() @@ -681,23 +681,6 @@ exec_as.mo <- function(x, # check for very small input, but ignore the O antigens of E. coli if (nchar(gsub("[^a-zA-Z]", "", x_trimmed[i])) < 3 & !x_backup_without_spp[i] %like_case% "[Oo]?(26|103|104|104|111|121|145|157)") { - # check if search term was like "A. species", then return first genus found with ^A - # if (x_backup[i] %like% "[a-z]+ species" | x_backup[i] %like% "[a-z] spp[.]?") { - # # get mo code of first hit - # found <- microorganismsDT[fullname %like% x_withspaces_start_only[i], mo] - # if (length(found) > 0) { - # mo_code <- found[1L] %>% strsplit("_") %>% unlist() %>% .[1:2] %>% paste(collapse = "_") - # found <- microorganismsDT[mo == mo_code, ..property][[1]] - # # return first genus that begins with x_trimmed, e.g. when "E. spp." - # if (length(found) > 0) { - # x[i] <- found[1L] - # if (initial_search == TRUE) { - # set_mo_history(x_backup[i], get_mo_code(x[i], property), 0, force = force_mo_history, disable = disable_mo_history) - # } - # next - # } - # } - # } # fewer than 3 chars and not looked for species, add as failure x[i] <- microorganismsDT[mo == "UNKNOWN", ..property][[1]] if (initial_search == TRUE) { @@ -715,17 +698,17 @@ exec_as.mo <- function(x, # translate known trivial abbreviations to genus + species ---- if (!is.na(x_trimmed[i])) { - if (toupper(x_backup_without_spp[i]) %in% c('MRSA', 'MSSA', 'VISA', 'VRSA') + if (toupper(x_backup_without_spp[i]) %in% c("MRSA", "MSSA", "VISA", "VRSA") | x_backup_without_spp[i] %like_case% " (mrsa|mssa|visa|vrsa) ") { - x[i] <- microorganismsDT[mo == 'B_STPHY_AURS', ..property][[1]][1L] + x[i] <- microorganismsDT[mo == "B_STPHY_AURS", ..property][[1]][1L] if (initial_search == TRUE) { set_mo_history(x_backup[i], get_mo_code(x[i], property), 0, force = force_mo_history, disable = disable_mo_history) } next } - if (toupper(x_backup_without_spp[i]) %in% c('MRSE', 'MSSE') + if (toupper(x_backup_without_spp[i]) %in% c("MRSE", "MSSE") | x_backup_without_spp[i] %like_case% " (mrse|msse) ") { - x[i] <- microorganismsDT[mo == 'B_STPHY_EPDR', ..property][[1]][1L] + x[i] <- microorganismsDT[mo == "B_STPHY_EPDR", ..property][[1]][1L] if (initial_search == TRUE) { set_mo_history(x_backup[i], get_mo_code(x[i], property), 0, force = force_mo_history, disable = disable_mo_history) } @@ -733,8 +716,8 @@ exec_as.mo <- function(x, } if (toupper(x_backup_without_spp[i]) == "VRE" | x_backup_without_spp[i] %like_case% " vre " - | x_backup_without_spp[i] %like_case% '(enterococci|enterokok|enterococo)[a-z]*?$') { - x[i] <- microorganismsDT[mo == 'B_ENTRC', ..property][[1]][1L] + | x_backup_without_spp[i] %like_case% "(enterococci|enterokok|enterococo)[a-z]*?$") { + x[i] <- microorganismsDT[mo == "B_ENTRC", ..property][[1]][1L] if (initial_search == TRUE) { set_mo_history(x_backup[i], get_mo_code(x[i], property), 0, force = force_mo_history, disable = disable_mo_history) } @@ -755,39 +738,39 @@ exec_as.mo <- function(x, if (toupper(x_backup_without_spp[i]) %in% c("AIEC", "ATEC", "DAEC", "EAEC", "EHEC", "EIEC", "EPEC", "ETEC", "NMEC", "STEC", "UPEC") # also support O-antigens of E. coli: O26, O103, O104, O111, O121, O145, O157 | x_backup_without_spp[i] %like_case% "o?(26|103|104|111|121|145|157)") { - x[i] <- microorganismsDT[mo == 'B_ESCHR_COLI', ..property][[1]][1L] + x[i] <- microorganismsDT[mo == "B_ESCHR_COLI", ..property][[1]][1L] if (initial_search == TRUE) { set_mo_history(x_backup[i], get_mo_code(x[i], property), 0, force = force_mo_history, disable = disable_mo_history) } next } - if (toupper(x_backup_without_spp[i]) == 'MRPA' + if (toupper(x_backup_without_spp[i]) == "MRPA" | x_backup_without_spp[i] %like_case% " mrpa ") { # multi resistant P. aeruginosa - x[i] <- microorganismsDT[mo == 'B_PSDMN_ARGN', ..property][[1]][1L] + x[i] <- microorganismsDT[mo == "B_PSDMN_ARGN", ..property][[1]][1L] if (initial_search == TRUE) { set_mo_history(x_backup[i], get_mo_code(x[i], property), 0, force = force_mo_history, disable = disable_mo_history) } next } - if (toupper(x_backup_without_spp[i]) == 'CRSM') { + if (toupper(x_backup_without_spp[i]) == "CRSM") { # co-trim resistant S. maltophilia - x[i] <- microorganismsDT[mo == 'B_STNTR_MLTP', ..property][[1]][1L] + x[i] <- microorganismsDT[mo == "B_STNTR_MLTP", ..property][[1]][1L] if (initial_search == TRUE) { set_mo_history(x_backup[i], get_mo_code(x[i], property), 0, force = force_mo_history, disable = disable_mo_history) } next } - if (toupper(x_backup_without_spp[i]) %in% c('PISP', 'PRSP', 'VISP', 'VRSP') + if (toupper(x_backup_without_spp[i]) %in% c("PISP", "PRSP", "VISP", "VRSP") | x_backup_without_spp[i] %like_case% " (pisp|prsp|visp|vrsp) ") { # peni I, peni R, vanco I, vanco R: S. pneumoniae - x[i] <- microorganismsDT[mo == 'B_STRPT_PNMN', ..property][[1]][1L] + x[i] <- microorganismsDT[mo == "B_STRPT_PNMN", ..property][[1]][1L] if (initial_search == TRUE) { set_mo_history(x_backup[i], get_mo_code(x[i], property), 0, force = force_mo_history, disable = disable_mo_history) } next } - if (x_backup_without_spp[i] %like_case% '^g[abcdfghk]s$') { + if (x_backup_without_spp[i] %like_case% "^g[abcdfghk]s$") { # Streptococci, like GBS = Group B Streptococci (B_STRPT_GRPB) x[i] <- microorganismsDT[mo == toupper(gsub("g([abcdfghk])s", "B_STRPT_GRP\\1", x_backup_without_spp[i])), ..property][[1]][1L] if (initial_search == TRUE) { @@ -795,7 +778,7 @@ exec_as.mo <- function(x, } next } - if (x_backup_without_spp[i] %like_case% '(streptococ|streptokok).* [abcdfghk]$') { + if (x_backup_without_spp[i] %like_case% "(streptococ|streptokok).* [abcdfghk]$") { # Streptococci in different languages, like "estreptococos grupo B" x[i] <- microorganismsDT[mo == toupper(gsub(".*(streptococ|streptokok|estreptococ).* ([abcdfghk])$", "B_STRPT_GRP\\2", x_backup_without_spp[i])), ..property][[1]][1L] if (initial_search == TRUE) { @@ -803,7 +786,7 @@ exec_as.mo <- function(x, } next } - if (x_backup_without_spp[i] %like_case% 'group [abcdfghk] (streptococ|streptokok|estreptococ)') { + if (x_backup_without_spp[i] %like_case% "group [abcdfghk] (streptococ|streptokok|estreptococ)") { # Streptococci in different languages, like "Group A Streptococci" x[i] <- microorganismsDT[mo == toupper(gsub(".*group ([abcdfghk]) (streptococ|streptokok|estreptococ).*", "B_STRPT_GRP\\1", x_backup_without_spp[i])), ..property][[1]][1L] if (initial_search == TRUE) { @@ -811,79 +794,79 @@ exec_as.mo <- function(x, } next } - if (x_backup_without_spp[i] %like_case% 'haemoly.*strept') { + if (x_backup_without_spp[i] %like_case% "haemoly.*strept") { # Haemolytic streptococci in different languages - x[i] <- microorganismsDT[mo == 'B_STRPT_HAEM', ..property][[1]][1L] + x[i] <- microorganismsDT[mo == "B_STRPT_HAEM", ..property][[1]][1L] if (initial_search == TRUE) { set_mo_history(x_backup[i], get_mo_code(x[i], property), 0, force = force_mo_history, disable = disable_mo_history) } next } # CoNS/CoPS in different languages (support for German, Dutch, Spanish, Portuguese) ---- - if (x_backup_without_spp[i] %like_case% '[ck]oagulas[ea] negatie?[vf]' - | x_trimmed[i] %like_case% '[ck]oagulas[ea] negatie?[vf]' - | x_backup_without_spp[i] %like_case% '[ck]o?ns[^a-z]?$') { + if (x_backup_without_spp[i] %like_case% "[ck]oagulas[ea] negatie?[vf]" + | x_trimmed[i] %like_case% "[ck]oagulas[ea] negatie?[vf]" + | x_backup_without_spp[i] %like_case% "[ck]o?ns[^a-z]?$") { # coerce S. coagulase negative - x[i] <- microorganismsDT[mo == 'B_STPHY_CONS', ..property][[1]][1L] + x[i] <- microorganismsDT[mo == "B_STPHY_CONS", ..property][[1]][1L] if (initial_search == TRUE) { set_mo_history(x_backup[i], get_mo_code(x[i], property), 0, force = force_mo_history, disable = disable_mo_history) } next } - if (x_backup_without_spp[i] %like_case% '[ck]oagulas[ea] positie?[vf]' - | x_trimmed[i] %like_case% '[ck]oagulas[ea] positie?[vf]' - | x_backup_without_spp[i] %like_case% '[ck]o?ps[^a-z]?$') { + if (x_backup_without_spp[i] %like_case% "[ck]oagulas[ea] positie?[vf]" + | x_trimmed[i] %like_case% "[ck]oagulas[ea] positie?[vf]" + | x_backup_without_spp[i] %like_case% "[ck]o?ps[^a-z]?$") { # coerce S. coagulase positive - x[i] <- microorganismsDT[mo == 'B_STPHY_COPS', ..property][[1]][1L] + x[i] <- microorganismsDT[mo == "B_STPHY_COPS", ..property][[1]][1L] if (initial_search == TRUE) { set_mo_history(x_backup[i], get_mo_code(x[i], property), 0, force = force_mo_history, disable = disable_mo_history) } next } # streptococcal groups: milleri and viridans - if (x_trimmed[i] %like_case% 'strepto.* milleri' - | x_backup_without_spp[i] %like_case% 'strepto.* milleri' - | x_backup_without_spp[i] %like_case% 'mgs[^a-z]?$') { + if (x_trimmed[i] %like_case% "strepto.* milleri" + | x_backup_without_spp[i] %like_case% "strepto.* milleri" + | x_backup_without_spp[i] %like_case% "mgs[^a-z]?$") { # Milleri Group Streptococcus (MGS) - x[i] <- microorganismsDT[mo == 'B_STRPT_MILL', ..property][[1]][1L] + x[i] <- microorganismsDT[mo == "B_STRPT_MILL", ..property][[1]][1L] if (initial_search == TRUE) { set_mo_history(x_backup[i], get_mo_code(x[i], property), 0, force = force_mo_history, disable = disable_mo_history) } next } - if (x_trimmed[i] %like_case% 'strepto.* viridans' - | x_backup_without_spp[i] %like_case% 'strepto.* viridans' - | x_backup_without_spp[i] %like_case% 'vgs[^a-z]?$') { + if (x_trimmed[i] %like_case% "strepto.* viridans" + | x_backup_without_spp[i] %like_case% "strepto.* viridans" + | x_backup_without_spp[i] %like_case% "vgs[^a-z]?$") { # Viridans Group Streptococcus (VGS) - x[i] <- microorganismsDT[mo == 'B_STRPT_VIRI', ..property][[1]][1L] + x[i] <- microorganismsDT[mo == "B_STRPT_VIRI", ..property][[1]][1L] if (initial_search == TRUE) { set_mo_history(x_backup[i], get_mo_code(x[i], property), 0, force = force_mo_history, disable = disable_mo_history) } next } - if (x_backup_without_spp[i] %like_case% 'gram[ -]?neg.*' - | x_backup_without_spp[i] %like_case% 'negatie?[vf]' - | x_trimmed[i] %like_case% 'gram[ -]?neg.*') { + if (x_backup_without_spp[i] %like_case% "gram[ -]?neg.*" + | x_backup_without_spp[i] %like_case% "negatie?[vf]" + | x_trimmed[i] %like_case% "gram[ -]?neg.*") { # coerce Gram negatives - x[i] <- microorganismsDT[mo == 'B_GRAMN', ..property][[1]][1L] + x[i] <- microorganismsDT[mo == "B_GRAMN", ..property][[1]][1L] if (initial_search == TRUE) { set_mo_history(x_backup[i], get_mo_code(x[i], property), 0, force = force_mo_history, disable = disable_mo_history) } next } - if (x_backup_without_spp[i] %like_case% 'gram[ -]?pos.*' - | x_backup_without_spp[i] %like_case% 'positie?[vf]' - | x_trimmed[i] %like_case% 'gram[ -]?pos.*') { + if (x_backup_without_spp[i] %like_case% "gram[ -]?pos.*" + | x_backup_without_spp[i] %like_case% "positie?[vf]" + | x_trimmed[i] %like_case% "gram[ -]?pos.*") { # coerce Gram positives - x[i] <- microorganismsDT[mo == 'B_GRAMP', ..property][[1]][1L] + x[i] <- microorganismsDT[mo == "B_GRAMP", ..property][[1]][1L] if (initial_search == TRUE) { set_mo_history(x_backup[i], get_mo_code(x[i], property), 0, force = force_mo_history, disable = disable_mo_history) } next } - if (x_backup_without_spp[i] %like_case% 'mycoba[ck]teri.[nm]?$') { + if (x_backup_without_spp[i] %like_case% "mycoba[ck]teri.[nm]?$") { # coerce Gram positives - x[i] <- microorganismsDT[mo == 'B_MYCBC', ..property][[1]][1L] + x[i] <- microorganismsDT[mo == "B_MYCBC", ..property][[1]][1L] if (initial_search == TRUE) { set_mo_history(x_backup[i], get_mo_code(x[i], property), 0, force = force_mo_history, disable = disable_mo_history) } @@ -893,14 +876,14 @@ exec_as.mo <- function(x, if (x_backup_without_spp[i] %like_case% "salmonella [a-z]+ ?.*") { if (x_backup_without_spp[i] %like_case% "salmonella group") { # Salmonella Group A to Z, just return S. species for now - x[i] <- microorganismsDT[mo == 'B_SLMNL', ..property][[1]][1L] + x[i] <- microorganismsDT[mo == "B_SLMNL", ..property][[1]][1L] if (initial_search == TRUE) { set_mo_history(x_backup[i], get_mo_code(x[i], property), 0, force = force_mo_history, disable = disable_mo_history) } next } else if (grepl("[sS]almonella [A-Z][a-z]+ ?.*", x_backup[i], ignore.case = FALSE)) { # Salmonella with capital letter species like "Salmonella Goettingen" - they're all S. enterica - x[i] <- microorganismsDT[mo == 'B_SLMNL_ENTR', ..property][[1]][1L] + x[i] <- microorganismsDT[mo == "B_SLMNL_ENTR", ..property][[1]][1L] if (initial_search == TRUE) { set_mo_history(x_backup[i], get_mo_code(x[i], property), 0, force = force_mo_history, disable = disable_mo_history) } @@ -915,7 +898,7 @@ exec_as.mo <- function(x, # trivial names known to the field: if ("meningococcus" %like_case% x_trimmed[i]) { # coerce Neisseria meningitidis - x[i] <- microorganismsDT[mo == 'B_NESSR_MNNG', ..property][[1]][1L] + x[i] <- microorganismsDT[mo == "B_NESSR_MNNG", ..property][[1]][1L] if (initial_search == TRUE) { set_mo_history(x_backup[i], get_mo_code(x[i], property), 0, force = force_mo_history, disable = disable_mo_history) } @@ -923,7 +906,7 @@ exec_as.mo <- function(x, } if ("gonococcus" %like_case% x_trimmed[i]) { # coerce Neisseria gonorrhoeae - x[i] <- microorganismsDT[mo == 'B_NESSR_GNRR', ..property][[1]][1L] + x[i] <- microorganismsDT[mo == "B_NESSR_GNRR", ..property][[1]][1L] if (initial_search == TRUE) { set_mo_history(x_backup[i], get_mo_code(x[i], property), 0, force = force_mo_history, disable = disable_mo_history) } @@ -931,7 +914,7 @@ exec_as.mo <- function(x, } if ("pneumococcus" %like_case% x_trimmed[i]) { # coerce Streptococcus penumoniae - x[i] <- microorganismsDT[mo == 'B_STRPT_PNMN', ..property][[1]][1L] + x[i] <- microorganismsDT[mo == "B_STRPT_PNMN", ..property][[1]][1L] if (initial_search == TRUE) { set_mo_history(x_backup[i], get_mo_code(x[i], property), 0, force = force_mo_history, disable = disable_mo_history) } @@ -1030,7 +1013,7 @@ exec_as.mo <- function(x, x_length <- nchar(g.x_backup_without_spp) x_split <- paste0("^", g.x_backup_without_spp %>% substr(1, x_length / 2), - '.* ', + ".* ", g.x_backup_without_spp %>% substr((x_length / 2) + 1, x_length)) found <- data_to_check[fullname_lower %like_case% x_split, ..property][[1]] if (length(found) > 0) { @@ -1050,12 +1033,12 @@ exec_as.mo <- function(x, # look for old taxonomic names ---- # wait until prevalence == 2 to run the old taxonomic results on both prevalence == 1 and prevalence == 2 found <- data.old_to_check[fullname_lower == tolower(a.x_backup) - | fullname_lower %like_case% d.x_withspaces_start_end,] + | fullname_lower %like_case% d.x_withspaces_start_end, ] if (NROW(found) > 0) { col_id_new <- found[1, col_id_new] # when property is "ref" (which is the case in mo_ref, mo_authors and mo_year), return the old value, so: - # mo_ref("Chlamydia psittaci") = "Page, 1968" (with warning) - # mo_ref("Chlamydophila psittaci") = "Everett et al., 1999" + # mo_ref() of "Chlamydia psittaci" will be "Page, 1968" (with warning) + # mo_ref() of "Chlamydophila psittaci" will be "Everett et al., 1999" if (property == "ref") { x[i] <- found[1, ref] } else { @@ -1067,9 +1050,7 @@ exec_as.mo <- function(x, ref_old = found[1, ref], ref_new = microorganismsDT[col_id == found[1, col_id_new], ref], mo = microorganismsDT[col_id == found[1, col_id_new], mo]) - # if (initial_search == TRUE) { - # set_mo_history(a.x_backup, get_mo_code(x[i], property), 0, force = force_mo_history, disable = disable_mo_history) - # } + # no set history on renames return(x[i]) } @@ -1119,9 +1100,7 @@ exec_as.mo <- function(x, format_uncertainty_as_df(uncertainty_level = now_checks_for_uncertainty_level, input = a.x_backup, result_mo = microorganismsDT[col_id == found[1, col_id_new], mo])) - # if (initial_search == TRUE) { - # set_mo_history(a.x_backup, get_mo_code(x, property), 1, force = force_mo_history, disable = disable_mo_history) - # } + # no set history on renames return(x) } @@ -1243,11 +1222,11 @@ exec_as.mo <- function(x, } x_strip <- a.x_backup %>% strsplit(" ") %>% unlist() if (length(x_strip) > 1) { - for (i in 1:(length(x_strip) - 1)) { + for (i in seq_len(length(x_strip) - 1)) { lastword <- x_strip[length(x_strip) - i + 1] lastword_half <- substr(lastword, 1, as.integer(nchar(lastword) / 2)) # remove last half of the second term - x_strip_collapsed <- paste(c(x_strip[1:(length(x_strip) - i)], lastword_half), collapse = " ") + x_strip_collapsed <- paste(c(x_strip[seq_len(length(x_strip) - i)], lastword_half), collapse = " ") if (nchar(x_strip_collapsed) >= 4 & nchar(lastword_half) > 2) { if (isTRUE(debug)) { message("Running '", x_strip_collapsed, "'") @@ -1278,8 +1257,8 @@ exec_as.mo <- function(x, cat("\n[ UNCERTAINTY LEVEL", now_checks_for_uncertainty_level, "] (7) try to strip off one element from end and check the remains\n") } if (length(x_strip) > 1) { - for (i in 1:(length(x_strip) - 1)) { - x_strip_collapsed <- paste(x_strip[1:(length(x_strip) - i)], collapse = " ") + for (i in seq_len(length(x_strip) - 1)) { + x_strip_collapsed <- paste(x_strip[seq_len(length(x_strip) - i)], collapse = " ") if (nchar(x_strip_collapsed) >= 6) { if (isTRUE(debug)) { message("Running '", x_strip_collapsed, "'") @@ -1412,8 +1391,8 @@ exec_as.mo <- function(x, cat("\n[ UNCERTAINTY LEVEL", now_checks_for_uncertainty_level, "] (11) try to strip off one element from end and check the remains (any text size)\n") } if (length(x_strip) > 1) { - for (i in 1:(length(x_strip) - 1)) { - x_strip_collapsed <- paste(x_strip[1:(length(x_strip) - i)], collapse = " ") + for (i in seq_len(length(x_strip) - 1)) { + x_strip_collapsed <- paste(x_strip[seq_len(length(x_strip) - i)], collapse = " ") if (isTRUE(debug)) { message("Running '", x_strip_collapsed, "'") } @@ -1579,7 +1558,7 @@ exec_as.mo <- function(x, " (covering ", percentage(total_failures / total_n), ") could not be coerced and ", plural[3], " considered 'unknown'") if (n_distinct(failures) <= 10) { - msg <- paste0(msg, ": ", paste('"', unique(failures), '"', sep = "", collapse = ', ')) + msg <- paste0(msg, ": ", paste('"', unique(failures), '"', sep = "", collapse = ", ")) } msg <- paste0(msg, ". Use mo_failures() to review ", plural[2], ". Edit the `allow_uncertain` parameter if needed (see ?as.mo).") warning(red(msg), @@ -1639,35 +1618,35 @@ exec_as.mo <- function(x, immediate. = TRUE) } - x[x %in% CoNS] <- microorganismsDT[mo == 'B_STPHY_CONS', ..property][[1]][1L] - x[x %in% CoPS] <- microorganismsDT[mo == 'B_STPHY_COPS', ..property][[1]][1L] + x[x %in% CoNS] <- microorganismsDT[mo == "B_STPHY_CONS", ..property][[1]][1L] + x[x %in% CoPS] <- microorganismsDT[mo == "B_STPHY_COPS", ..property][[1]][1L] if (Becker == "all") { - x[x %in% microorganismsDT[mo %like_case% '^B_STPHY_AURS', ..property][[1]]] <- microorganismsDT[mo == 'B_STPHY_COPS', ..property][[1]][1L] + x[x %in% microorganismsDT[mo %like_case% "^B_STPHY_AURS", ..property][[1]]] <- microorganismsDT[mo == "B_STPHY_COPS", ..property][[1]][1L] } } # Lancefield ---- if (Lancefield == TRUE | Lancefield == "all") { # group A - S. pyogenes - x[x == microorganismsDT[mo == 'B_STRPT_PYGN', ..property][[1]][1L]] <- microorganismsDT[mo == 'B_STRPT_GRPA', ..property][[1]][1L] + x[x == microorganismsDT[mo == "B_STRPT_PYGN", ..property][[1]][1L]] <- microorganismsDT[mo == "B_STRPT_GRPA", ..property][[1]][1L] # group B - S. agalactiae - x[x == microorganismsDT[mo == 'B_STRPT_AGLC', ..property][[1]][1L]] <- microorganismsDT[mo == 'B_STRPT_GRPB', ..property][[1]][1L] + x[x == microorganismsDT[mo == "B_STRPT_AGLC", ..property][[1]][1L]] <- microorganismsDT[mo == "B_STRPT_GRPB", ..property][[1]][1L] # group C S_groupC <- microorganismsDT %>% filter(genus == "Streptococcus", species %in% c("equisimilis", "equi", "zooepidemicus", "dysgalactiae")) %>% pull(property) - x[x %in% S_groupC] <- microorganismsDT[mo == 'B_STRPT_GRPC', ..property][[1]][1L] + x[x %in% S_groupC] <- microorganismsDT[mo == "B_STRPT_GRPC", ..property][[1]][1L] if (Lancefield == "all") { # all Enterococci - x[x %like% "^(Enterococcus|B_ENTRC)"] <- microorganismsDT[mo == 'B_STRPT_GRPD', ..property][[1]][1L] + x[x %like% "^(Enterococcus|B_ENTRC)"] <- microorganismsDT[mo == "B_STRPT_GRPD", ..property][[1]][1L] } # group F - S. anginosus - x[x == microorganismsDT[mo == 'B_STRPT_ANGN', ..property][[1]][1L]] <- microorganismsDT[mo == 'B_STRPT_GRPF', ..property][[1]][1L] + x[x == microorganismsDT[mo == "B_STRPT_ANGN", ..property][[1]][1L]] <- microorganismsDT[mo == "B_STRPT_GRPF", ..property][[1]][1L] # group H - S. sanguinis - x[x == microorganismsDT[mo == 'B_STRPT_SNGN', ..property][[1]][1L]] <- microorganismsDT[mo == 'B_STRPT_GRPH', ..property][[1]][1L] + x[x == microorganismsDT[mo == "B_STRPT_SNGN", ..property][[1]][1L]] <- microorganismsDT[mo == "B_STRPT_GRPH", ..property][[1]][1L] # group K - S. salivarius - x[x == microorganismsDT[mo == 'B_STRPT_SLVR', ..property][[1]][1L]] <- microorganismsDT[mo == 'B_STRPT_GRPK', ..property][[1]][1L] + x[x == microorganismsDT[mo == "B_STRPT_SLVR", ..property][[1]][1L]] <- microorganismsDT[mo == "B_STRPT_GRPK", ..property][[1]][1L] } # Wrap up ---------------------------------------------------------------- @@ -1886,7 +1865,7 @@ print.mo_uncertainties <- function(x, ...) { ", 3 = ", red("very uncertain"), ")\n")) msg <- "" - for (i in 1:nrow(x)) { + for (i in seq_len(nrow(x))) { if (x[i, "uncertainty"] == 1) { colour1 <- green colour2 <- function(...) bgGreen(white(...)) @@ -1929,7 +1908,7 @@ print.mo_renamed <- function(x, ...) { if (NROW(x) == 0) { return(invisible()) } - for (i in 1:nrow(x)) { + for (i in seq_len(nrow(x))) { message(blue(paste0("NOTE: ", italic(x$old_name[i]), ifelse(x$old_ref[i] %in% c("", NA), "", paste0(" (", gsub("et al.", italic("et al."), x$old_ref[i]), ")")), @@ -1955,15 +1934,10 @@ unregex <- function(x) { } get_mo_code <- function(x, property) { - # don't use right now - # return(NULL) - if (property == "mo") { unique(x) } else { microorganismsDT[get(property) == x, "mo"][[1]] - # which is ~2.5 times faster than: - # AMR::microorganisms[base::which(AMR::microorganisms[, property] %in% x),]$mo } } diff --git a/R/mo_history.R b/R/mo_history.R index 57f671db..13e3f0a1 100644 --- a/R/mo_history.R +++ b/R/mo_history.R @@ -43,11 +43,11 @@ set_mo_history <- function(x, mo, uncertainty_level, force = FALSE, disable = FA } x <- toupper(df$x) mo <- df$mo - for (i in 1:length(x)) { + for (i in seq_len(length(x))) { # save package version too, as both the as.mo() algorithm and the reference data set may change if (NROW(mo_hist[base::which(mo_hist$x == x[i] & mo_hist$uncertainty_level >= uncertainty_level & - mo_hist$package_version == utils::packageVersion("AMR")),]) == 0) { + mo_hist$package_version == utils::packageVersion("AMR")), ]) == 0) { # # Not using the file system: # tryCatch(options(mo_remembered_results = rbind(mo_hist, # data.frame( @@ -73,7 +73,9 @@ set_mo_history <- function(x, mo, uncertainty_level, force = FALSE, disable = FA stringsAsFactors = FALSE)), row.names = FALSE, file = mo_history_file()), - error = function(e) { warning_new_write <- FALSE; base::invisible()}) + error = function(e) { + warning_new_write <- FALSE; base::invisible() + }) } } } @@ -87,7 +89,7 @@ get_mo_history <- function(x, uncertainty_level, force = FALSE, disable = FALSE) if (isTRUE(disable)) { return(to_class_mo(NA)) } - + history <- read_mo_history(uncertainty_level = uncertainty_level, force = force) if (base::is.null(history)) { result <- NA @@ -105,7 +107,7 @@ read_mo_history <- function(uncertainty_level = 2, force = FALSE, unfiltered = F if (isTRUE(disable)) { return(NULL) } - + if ((!base::interactive() & force == FALSE)) { return(NULL) } @@ -123,7 +125,7 @@ read_mo_history <- function(uncertainty_level = 2, force = FALSE, unfiltered = F # Below: filter on current package version. # Even current fullnames may be replaced by new taxonomic names, so new versions of # the Catalogue of Life must not lead to data corruption. - + if (unfiltered == FALSE) { history <- history %>% filter(package_version == as.character(utils::packageVersion("AMR")), @@ -133,7 +135,7 @@ read_mo_history <- function(uncertainty_level = 2, force = FALSE, unfiltered = F arrange(desc(uncertainty_level)) %>% distinct(x, mo, .keep_all = TRUE) } - + if (nrow(history) == 0) { NULL } else { diff --git a/R/mo_property.R b/R/mo_property.R index aa45ea2e..c88b75eb 100755 --- a/R/mo_property.R +++ b/R/mo_property.R @@ -158,8 +158,8 @@ mo_shortname <- function(x, language = get_locale(), ...) { 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" + 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") @@ -384,7 +384,7 @@ mo_url <- function(x, open = FALSE, ...) { #' @rdname mo_property #' @importFrom data.table data.table as.data.table setkey #' @export -mo_property <- function(x, property = 'fullname', language = get_locale(), ...) { +mo_property <- function(x, property = "fullname", language = get_locale(), ...) { if (length(property) != 1L) { stop("'property' must be of length 1.") } diff --git a/R/mo_source.R b/R/mo_source.R index 28659607..96b75dfc 100644 --- a/R/mo_source.R +++ b/R/mo_source.R @@ -99,7 +99,7 @@ #' @inheritSection AMR Read more on our website! set_mo_source <- function(path) { - file_location <- path.expand('~/mo_source.rds') + file_location <- path.expand("~/mo_source.rds") if (!is.character(path) | length(path) > 1) { stop("`path` must be a character of length 1.") @@ -119,17 +119,17 @@ set_mo_source <- function(path) { stop("File not found: ", path) } - if (path %like% '[.]rds$') { + if (path %like% "[.]rds$") { df <- readRDS(path) - } else if (path %like% '[.]xlsx?$') { + } else if (path %like% "[.]xlsx?$") { # is Excel file (old or new) if (!"readxl" %in% utils::installed.packages()) { stop("Install the 'readxl' package first.") } df <- readxl::read_excel(path) - } else if (path %like% '[.]tsv$') { + } else if (path %like% "[.]tsv$") { df <- utils::read.table(header = TRUE, sep = "\t", stringsAsFactors = FALSE) } else { @@ -196,7 +196,7 @@ get_mo_source <- function() { # set updated source set_mo_source(getOption("mo_source")) } - file_location <- path.expand('~/mo_source.rds') + file_location <- path.expand("~/mo_source.rds") readRDS(file_location) } } diff --git a/R/read.4d.R b/R/read.4d.R index 693a32d6..22802b65 100755 --- a/R/read.4d.R +++ b/R/read.4d.R @@ -154,7 +154,7 @@ read.4D <- function(file, if (info == TRUE) { message("OK\nSetting original column names as label... ", appendLF = FALSE) } - for (i in 1:ncol(data_4D)) { + for (i in seq_len(ncol(data_4D))) { if (!is.na(colnames.bak[i])) { attr(data_4D[, i], "label") <- colnames.bak[i] } @@ -163,7 +163,7 @@ read.4D <- function(file, if (info == TRUE) { message("OK\nSetting query as label to data.frame... ", appendLF = FALSE) } - qry <- readLines(con <- file(file, open="r"))[1] + qry <- readLines(con <- file(file, open = "r"))[1] close(con) attr(data_4D, "label") <- qry @@ -173,4 +173,3 @@ read.4D <- function(file, data_4D } - diff --git a/R/resistance_predict.R b/R/resistance_predict.R index d769a26e..b8c9faad 100755 --- a/R/resistance_predict.R +++ b/R/resistance_predict.R @@ -120,7 +120,7 @@ resistance_predict <- function(x, ...) { if (nrow(x) == 0) { - stop('This table does not contain any observations.') + stop("This table does not contain any observations.") } if (is.null(model)) { @@ -128,17 +128,17 @@ resistance_predict <- function(x, } if (!col_ab %in% colnames(x)) { - stop('Column ', col_ab, ' not found.') + stop("Column ", col_ab, " not found.") } dots <- unlist(list(...)) if (length(dots) != 0) { # backwards compatibility with old parameters dots.names <- dots %>% names() - if ('tbl' %in% dots.names) { - x <- dots[which(dots.names == 'tbl')] + if ("tbl" %in% dots.names) { + x <- dots[which(dots.names == "tbl")] } - if ('I_as_R' %in% dots.names) { + if ("I_as_R" %in% dots.names) { warning("`I_as_R is deprecated - use I_as_S instead.", call. = FALSE) } } @@ -152,7 +152,7 @@ resistance_predict <- function(x, } if (!col_date %in% colnames(x)) { - stop('Column ', col_date, ' not found.') + stop("Column ", col_date, " not found.") } if (n_groups(x) > 1) { @@ -161,10 +161,10 @@ resistance_predict <- function(x, } year <- function(x) { - if (all(grepl('^[0-9]{4}$', x))) { + if (all(grepl("^[0-9]{4}$", x))) { x } else { - as.integer(format(as.Date(x), '%Y')) + as.integer(format(as.Date(x), "%Y")) } } @@ -181,8 +181,8 @@ resistance_predict <- function(x, } df <- df %>% filter_at(col_ab, all_vars(!is.na(.))) %>% - mutate(year = pull(., col_date) %>% year()) %>% - group_by_at(c('year', col_ab)) %>% + mutate(year = year(pull(., col_date))) %>% + group_by_at(c("year", col_ab)) %>% summarise(n()) if (df %>% pull(col_ab) %>% n_distinct(na.rm = TRUE) < 2) { @@ -191,7 +191,7 @@ resistance_predict <- function(x, call. = FALSE) } - colnames(df) <- c('year', 'antibiotic', 'observations') + colnames(df) <- c("year", "antibiotic", "observations") df <- df %>% filter(!is.na(antibiotic)) %>% tidyr::spread(antibiotic, observations, fill = 0) %>% @@ -202,7 +202,7 @@ resistance_predict <- function(x, as.matrix() if (NROW(df) == 0) { - stop('There are no observations.') + stop("There are no observations.") } year_lowest <- min(df$year) @@ -217,12 +217,12 @@ resistance_predict <- function(x, 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_lm <- with(df, glm(df_matrix ~ year, family = binomial)) if (info == TRUE) { - cat('\nLogistic regression model (logit) with binomial distribution') - cat('\n------------------------------------------------------------\n') + cat("\nLogistic regression model (logit) with binomial distribution") + cat("\n------------------------------------------------------------\n") print(summary(model_lm)) } @@ -230,12 +230,12 @@ resistance_predict <- function(x, prediction <- predictmodel$fit se <- predictmodel$se.fit - } else if (model %in% c('loglin', 'poisson')) { + } else if (model %in% c("loglin", "poisson")) { model <- "poisson" model_lm <- with(df, glm(R ~ year, family = poisson)) if (info == TRUE) { - cat('\nLog-linear regression model (loglin) with poisson distribution') - cat('\n--------------------------------------------------------------\n') + cat("\nLog-linear regression model (loglin) with poisson distribution") + cat("\n--------------------------------------------------------------\n") print(summary(model_lm)) } @@ -243,12 +243,12 @@ resistance_predict <- function(x, prediction <- predictmodel$fit se <- predictmodel$se.fit - } else if (model %in% c('lin', 'linear')) { + } else if (model %in% c("lin", "linear")) { model <- "linear" model_lm <- with(df, lm((R / (R + S)) ~ year)) if (info == TRUE) { - cat('\nLinear regression model') - cat('\n-----------------------\n') + cat("\nLinear regression model") + cat("\n-----------------------\n") print(summary(model_lm)) } @@ -257,7 +257,7 @@ resistance_predict <- function(x, se <- predictmodel$se.fit } else { - stop('No valid model selected. See ?resistance_predict.') + stop("No valid model selected. See ?resistance_predict.") } # prepare the output dataframe @@ -268,7 +268,7 @@ resistance_predict <- function(x, mutate(se_min = value - se, se_max = value + se) - if (model == 'poisson') { + if (model == "poisson") { df_prediction <- df_prediction %>% mutate(value = value %>% format(scientific = FALSE) %>% diff --git a/R/rsi.R b/R/rsi.R index 0a7f78ad..73f814b8 100755 --- a/R/rsi.R +++ b/R/rsi.R @@ -100,20 +100,17 @@ as.rsi.default <- function(x, ...) { if (is.rsi(x)) { x } else if (identical(levels(x), c("S", "I", "R"))) { - structure(x, class = c('rsi', 'ordered', 'factor')) + structure(x, class = c("rsi", "ordered", "factor")) } else { - # if (input_resembles_mic(x) > 0.5) { - # warning("`as.rsi` is intended to clean antimicrobial interpretations - not to interpret MIC values.", call. = FALSE) - # } x <- x %>% unlist() x.bak <- x - na_before <- x[is.na(x) | x == ''] %>% length() + na_before <- x[is.na(x) | x == ""] %>% length() # remove all spaces - x <- gsub(' +', '', x) + x <- gsub(" +", "", x) # remove all MIC-like values: numbers, operators and periods - x <- gsub('[0-9.,;:<=>]+', '', x) + x <- gsub("[0-9.,;:<=>]+", "", x) # remove everything between brackets, and 'high' and 'low' x <- gsub("([(].*[)])", "", x) x <- gsub("(high|low)", "", x, ignore.case = TRUE) @@ -122,29 +119,29 @@ as.rsi.default <- function(x, ...) { # set to capitals x <- toupper(x) # remove all invalid characters - x <- gsub('[^RSI]+', '', x) + x <- gsub("[^RSI]+", "", x) # in cases of "S;S" keep S, but in case of "S;I" make it NA - x <- gsub('^S+$', 'S', x) - x <- gsub('^I+$', 'I', x) - x <- gsub('^R+$', 'R', x) - x[!x %in% c('S', 'I', 'R')] <- NA - na_after <- x[is.na(x) | x == ''] %>% length() + x <- gsub("^S+$", "S", x) + x <- gsub("^I+$", "I", x) + x <- gsub("^R+$", "R", x) + x[!x %in% c("S", "I", "R")] <- NA + na_after <- x[is.na(x) | x == ""] %>% length() if (!isFALSE(list(...)$warn)) { # so as.rsi(..., warn = FALSE) will never throw a warning 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() %>% sort() - list_missing <- paste0('"', list_missing , '"', collapse = ", ") - warning(na_after - na_before, ' results truncated (', + list_missing <- paste0('"', list_missing, '"', collapse = ", ") + warning(na_after - na_before, " results truncated (", round(((na_after - na_before) / length(x)) * 100), - '%) that were invalid antimicrobial interpretations: ', + "%) that were invalid antimicrobial interpretations: ", list_missing, call. = FALSE) } } structure(.Data = factor(x, levels = c("S", "I", "R"), ordered = TRUE), - class = c('rsi', 'ordered', 'factor')) + class = c("rsi", "ordered", "factor")) } } @@ -226,7 +223,7 @@ exec_as.rsi <- function(method, x, mo, ab, guideline) { lookup_becker <- paste(mo_becker, ab) lookup_lancefield <- paste(mo_lancefield, ab) - for (i in 1:length(x)) { + for (i in seq_len(length(x))) { get_record <- trans %>% filter(lookup %in% c(lookup_mo[i], lookup_genus[i], @@ -236,7 +233,7 @@ exec_as.rsi <- function(method, x, mo, ab, guideline) { lookup_lancefield[i])) %>% # be as specific as possible (i.e. prefer species over genus): arrange(desc(nchar(mo))) %>% - .[1L,] + .[1L, ] if (NROW(get_record) > 0) { if (method == "mic") { @@ -254,7 +251,7 @@ exec_as.rsi <- function(method, x, mo, ab, guideline) { } } structure(.Data = factor(new_rsi, levels = c("S", "I", "R"), ordered = TRUE), - class = c('rsi', 'ordered', 'factor')) + class = c("rsi", "ordered", "factor")) } #' @rdname as.rsi @@ -280,7 +277,7 @@ as.rsi.data.frame <- function(x, col_mo = NULL, guideline = "EUCAST", ...) { # transform all MICs ab_cols <- colnames(x)[sapply(x, is.mic)] if (length(ab_cols) > 0) { - for (i in 1:length(ab_cols)) { + for (i in seq_len(length(ab_cols))) { if (is.na(suppressWarnings(as.ab(ab_cols[i])))) { message(red(paste0("Unknown drug: `", bold(ab_cols[i]), "`. Rename this column to a drug name or code, and check the output with as.ab()."))) next @@ -297,7 +294,7 @@ as.rsi.data.frame <- function(x, col_mo = NULL, guideline = "EUCAST", ...) { # transform all disks ab_cols <- colnames(x)[sapply(x, is.disk)] if (length(ab_cols) > 0) { - for (i in 1:length(ab_cols)) { + for (i in seq_len(length(ab_cols))) { if (is.na(suppressWarnings(as.ab(ab_cols[i])))) { message(red(paste0("Unknown drug: `", bold(ab_cols[i]), "`. Rename this column to a drug name or code, and check the output with as.ab()."))) next @@ -319,14 +316,14 @@ as.rsi.data.frame <- function(x, col_mo = NULL, guideline = "EUCAST", ...) { #' @export is.rsi <- function(x) { identical(class(x), - c('rsi', 'ordered', 'factor')) + c("rsi", "ordered", "factor")) } #' @rdname as.rsi #' @export is.rsi.eligible <- function(x, threshold = 0.05) { if (NCOL(x) > 1) { - stop('`x` must be a one-dimensional vector.') + stop("`x` must be a one-dimensional vector.") } if (any(c("logical", "numeric", @@ -363,9 +360,9 @@ print.rsi <- function(x, ...) { #' @exportMethod droplevels.rsi #' @export #' @noRd -droplevels.rsi <- function(x, exclude = if(anyNA(levels(x))) NULL else NA, ...) { +droplevels.rsi <- function(x, exclude = if (anyNA(levels(x))) NULL else NA, ...) { x <- droplevels.factor(x, exclude = exclude, ...) - class(x) <- c('rsi', 'ordered', 'factor') + class(x) <- c("rsi", "ordered", "factor") x } @@ -375,7 +372,7 @@ droplevels.rsi <- function(x, exclude = if(anyNA(levels(x))) NULL else NA, ...) summary.rsi <- function(object, ...) { x <- object c( - "Class" = 'rsi', + "Class" = "rsi", "" = sum(is.na(x)), "Sum S" = sum(x == "S", na.rm = TRUE), "Sum IR" = sum(x %in% c("I", "R"), na.rm = TRUE), @@ -392,9 +389,9 @@ summary.rsi <- function(object, ...) { plot.rsi <- function(x, lwd = 2, ylim = NULL, - ylab = 'Percentage', - xlab = 'Antimicrobial Interpretation', - main = paste('Susceptibility Analysis of', deparse(substitute(x))), + ylab = "Percentage", + xlab = "Antimicrobial Interpretation", + main = paste("Susceptibility Analysis of", deparse(substitute(x))), axes = FALSE, ...) { suppressWarnings( @@ -416,7 +413,7 @@ plot.rsi <- function(x, data <- rbind(data, data.frame(x = "R", n = 0, s = 0)) } - data$x <- factor(data$x, levels = c('S', 'I', 'R'), ordered = TRUE) + data$x <- factor(data$x, levels = c("S", "I", "R"), ordered = TRUE) ymax <- if_else(max(data$s) > 95, 105, 100) @@ -436,7 +433,7 @@ plot.rsi <- function(x, text(x = data$x, y = data$s + 4, - labels = paste0(data$s, '% (n = ', data$n, ')')) + labels = paste0(data$s, "% (n = ", data$n, ")")) } @@ -446,10 +443,10 @@ plot.rsi <- function(x, #' @importFrom graphics barplot axis par #' @noRd barplot.rsi <- function(height, - col = c('green3', 'orange2', 'red3'), - xlab = ifelse(beside, 'Antimicrobial Interpretation', ''), - main = paste('Susceptibility Analysis of', deparse(substitute(height))), - ylab = 'Frequency', + col = c("green3", "orange2", "red3"), + xlab = ifelse(beside, "Antimicrobial Interpretation", ""), + main = paste("Susceptibility Analysis of", deparse(substitute(height))), + ylab = "Frequency", beside = TRUE, axes = beside, ...) { diff --git a/R/rsi_calc.R b/R/rsi_calc.R index 673fbcc6..6f631bc1 100755 --- a/R/rsi_calc.R +++ b/R/rsi_calc.R @@ -50,13 +50,13 @@ rsi_calc <- function(..., data_vars <- dots2vars(...) if (!is.numeric(minimum)) { - stop('`minimum` must be numeric', call. = FALSE) + stop("`minimum` must be numeric", call. = FALSE) } if (!is.logical(as_percent)) { - stop('`as_percent` must be logical', call. = FALSE) + stop("`as_percent` must be logical", call. = FALSE) } if (!is.logical(only_all_tested)) { - stop('`only_all_tested` must be logical', call. = FALSE) + stop("`only_all_tested` must be logical", call. = FALSE) } dots_df <- ...elt(1) # it needs this evaluation @@ -67,8 +67,7 @@ rsi_calc <- function(..., ndots <- length(dots) if ("data.frame" %in% class(dots_df)) { - # data.frame passed with other columns, like: - # example_isolates %>% portion_S(amcl, gent) + # data.frame passed with other columns, like: example_isolates %>% portion_S(amcl, gent) dots <- as.character(dots) dots <- dots[dots != "."] if (length(dots) == 0 | all(dots == "df")) { @@ -79,13 +78,10 @@ rsi_calc <- function(..., x <- dots_df[, dots] } } else if (ndots == 1) { - # only 1 variable passed (can also be data.frame), like: - # portion_S(example_isolates$amcl) - # example_isolates$amcl %>% portion_S() + # only 1 variable passed (can also be data.frame), like: portion_S(example_isolates$amcl) and example_isolates$amcl %>% portion_S() x <- dots_df } else { - # multiple variables passed without pipe, like: - # portion_S(example_isolates$amcl, example_isolates$gent) + # multiple variables passed without pipe, like: portion_S(example_isolates$amcl, example_isolates$gent) x <- NULL try(x <- as.data.frame(dots), silent = TRUE) if (is.null(x)) { @@ -105,7 +101,7 @@ rsi_calc <- function(..., if (is.data.frame(x)) { rsi_integrity_check <- character(0) - for (i in 1:ncol(x)) { + for (i in seq_len(ncol(x))) { # check integrity of columns: force rsi class if (!is.rsi(x %>% pull(i))) { rsi_integrity_check <- c(rsi_integrity_check, x %>% pull(i) %>% as.character()) @@ -125,11 +121,13 @@ rsi_calc <- function(..., FUN = base::min) numerator <- sum(as.integer(x) %in% as.integer(ab_result), na.rm = TRUE) denominator <- length(x) - sum(is.na(x)) - + } else { # THE NUMBER OF ISOLATES WHERE *ANY* ABx IS S/I/R other_values <- base::setdiff(c(NA, levels(ab_result)), ab_result) - other_values_filter <- base::apply(x, 1, function(y) { base::all(y %in% other_values) & base::any(is.na(y)) }) + other_values_filter <- base::apply(x, 1, function(y) { + base::all(y %in% other_values) & base::any(is.na(y)) + }) numerator <- x %>% filter_all(any_vars(. %in% ab_result)) %>% nrow() denominator <- x %>% filter(!other_values_filter) %>% nrow() } diff --git a/R/skewness.R b/R/skewness.R index b3cad0a0..bcd3522d 100755 --- a/R/skewness.R +++ b/R/skewness.R @@ -38,25 +38,25 @@ skewness <- function(x, na.rm = FALSE) { #' @exportMethod skewness.default #' @rdname skewness #' @export -skewness.default <- function (x, na.rm = FALSE) { +skewness.default <- function(x, na.rm = FALSE) { x <- as.vector(x) if (na.rm == TRUE) { x <- x[!is.na(x)] } n <- length(x) - (base::sum((x - base::mean(x))^3) / n) / (base::sum((x - base::mean(x))^2) / n)^(3/2) + (base::sum((x - base::mean(x))^3) / n) / (base::sum((x - base::mean(x)) ^ 2) / n) ^ (3 / 2) } #' @exportMethod skewness.matrix #' @rdname skewness #' @export -skewness.matrix <- function (x, na.rm = FALSE) { +skewness.matrix <- function(x, na.rm = FALSE) { base::apply(x, 2, skewness.default, na.rm = na.rm) } #' @exportMethod skewness.data.frame #' @rdname skewness #' @export -skewness.data.frame <- function (x, na.rm = FALSE) { +skewness.data.frame <- function(x, na.rm = FALSE) { base::sapply(x, skewness.default, na.rm = na.rm) } diff --git a/R/translate.R b/R/translate.R index d0fe61fe..c4578d0b 100755 --- a/R/translate.R +++ b/R/translate.R @@ -134,7 +134,7 @@ translate_AMR <- function(from, language = get_locale(), only_unknown = FALSE) { return(from) } - for (i in 1:nrow(df_trans)) { + for (i in seq_len(nrow(df_trans))) { from <- gsub(x = from, pattern = df_trans$pattern[i], replacement = df_trans$replacement[i], diff --git a/R/zzz.R b/R/zzz.R index be3be7f4..03233e24 100755 --- a/R/zzz.R +++ b/R/zzz.R @@ -42,42 +42,9 @@ value = make_trans_tbl(), envir = asNamespace("AMR")) -# assign(x = "mo_history", -# value = data.frame(x = character(0), -# mo = character(0), -# uncertainty_level = integer(0), -# package_v = character(0), -# stringsAsFactors = FALSE), -# envir = asNamespace("AMR")) - } - -.onAttach <- function(...) { - # if (interactive() & !isFALSE(getOption("AMR_survey"))) { - # options(AMR_survey = FALSE) - # console_width <- options()$width - 1 - # url <- "https://www.surveymonkey.com/r/AMR_for_R" - # txt <- paste0("Thanks for using the AMR package! ", - # "As researchers, we are interested in how and why you use this package and if there are things you're missing from it. ", - # "Please fill in our 2-minute survey at: ", url, ". ", - # "This message can be turned off with: options(AMR_survey = FALSE)") - # - # # make it honour new lines bases on console width: - # txt <- unlist(strsplit(txt, " ")) - # txt_new <- "" - # total_chars <- 0 - # for (i in 1:length(txt)) { - # total_chars <- total_chars + nchar(txt[i]) + 1 - # if (total_chars > console_width) { - # txt_new <- paste0(txt_new, "\n") - # total_chars <- 0 - # } - # txt_new <- paste0(txt_new, txt[i], " ") - # } - # # packageStartupMessage(txt_new) - # } -} +# maybe add survey later: "https://www.surveymonkey.com/r/AMR_for_R" #' @importFrom data.table as.data.table setkey make_DT <- function() { diff --git a/docs/404.html b/docs/404.html index ad667066..88fba41a 100644 --- a/docs/404.html +++ b/docs/404.html @@ -84,7 +84,7 @@ AMR (for R) - 0.7.1.9101 + 0.7.1.9102 diff --git a/docs/LICENSE-text.html b/docs/LICENSE-text.html index 231ac608..40cb0929 100644 --- a/docs/LICENSE-text.html +++ b/docs/LICENSE-text.html @@ -84,7 +84,7 @@ AMR (for R) - 0.7.1.9100 + 0.7.1.9102 diff --git a/docs/articles/index.html b/docs/articles/index.html index b444a759..0f541830 100644 --- a/docs/articles/index.html +++ b/docs/articles/index.html @@ -84,7 +84,7 @@ AMR (for R) - 0.7.1.9100 + 0.7.1.9102 diff --git a/docs/authors.html b/docs/authors.html index 65206c15..11e7a8fb 100644 --- a/docs/authors.html +++ b/docs/authors.html @@ -84,7 +84,7 @@ AMR (for R) - 0.7.1.9101 + 0.7.1.9102 diff --git a/docs/index.html b/docs/index.html index 13c45dbf..4adf543d 100644 --- a/docs/index.html +++ b/docs/index.html @@ -43,7 +43,7 @@ AMR (for R) - 0.7.1.9100 + 0.7.1.9102 diff --git a/docs/news/index.html b/docs/news/index.html index 68e37b17..371c8785 100644 --- a/docs/news/index.html +++ b/docs/news/index.html @@ -84,7 +84,7 @@ AMR (for R) - 0.7.1.9100 + 0.7.1.9102 @@ -231,11 +231,11 @@ -
+

-AMR 0.7.1.9100 Unreleased +AMR 0.7.1.9102 Unreleased

-

Last updated: 08-Oct-2019

+

Last updated: 11-Oct-2019

Breaking

@@ -267,31 +267,32 @@ This is important, because a value like "testvalue" could never be New

You can format this to a printable format, ready for reporting or exporting to e.g. Excel with the base R format() function:

format(x, combine_IR = FALSE)
  • -

    Additional way to calculate co-resistance, i.e. when using multiple antimicrobials as input for portion_* functions or count_* functions. This can be used to determine the empiric susceptibily of a combination therapy. A new parameter only_all_tested (which defaults to FALSE) replaces the old also_single_tested and can be used to select one of the two methods to count isolates and calculate portions. The difference can be seen in this example table (which is also on the portion and count help pages), where the %SI is being determined:

    +

    Additional way to calculate co-resistance, i.e. when using multiple antimicrobials as input for portion_* functions or count_* functions. This can be used to determine the empiric susceptibility of a combination therapy. A new parameter only_all_tested (which defaults to FALSE) replaces the old also_single_tested and can be used to select one of the two methods to count isolates and calculate portions. The difference can be seen in this example table (which is also on the portion and count help pages), where the %SI is being determined:

    # --------------------------------------------------------------------
     #                     only_all_tested = FALSE  only_all_tested = TRUE
     #                     -----------------------  -----------------------
    @@ -377,6 +378,7 @@ Since this is a major change, usage of the old also_single_tested w
     Other
     
    • Added Prof. Dr. Casper Albers as doctoral advisor and added Dr. Judith Fonville, Eric Hazenberg, Dr. Bart Meijer, Dr. Dennis Souverein and Annick Lenglet as contributors
    • +
    • Cleaned the coding style of every single syntax line in this package with the help of the lintr package
  • @@ -1290,7 +1292,7 @@ Using as.mo(..., allow_uncertain = 3)

    Contents

    @@ -327,7 +327,7 @@
    # \donttest{
     x <- bug_drug_combinations(example_isolates)
     x
    -format(x)
    +format(x, translate_ab = "name (atc)")
     
     # Use FUN to change to transformation of microorganism codes
     x <- bug_drug_combinations(example_isolates,
    diff --git a/docs/reference/first_isolate.html b/docs/reference/first_isolate.html
    index 49a6b735..d70d5d72 100644
    --- a/docs/reference/first_isolate.html
    +++ b/docs/reference/first_isolate.html
    @@ -15,21 +15,25 @@
     
     
     
    +
     
     
     
     
     
    +
     
     
     
    -
    +
    +
     
     
     
     
    -
    -
    +
    +
    +
     
     
     
    @@ -45,15 +49,15 @@
     
       
       
    +
     
    -
     
    -
     
     
     
     
     
    +
     
     
     
    @@ -64,6 +68,7 @@
     
     
     
    +
       
     
       
    @@ -80,7 +85,7 @@
           
           
             AMR (for R)
    -        0.7.1.9067
    +        0.7.1.9102
           
         
     
    @@ -189,7 +194,6 @@
       
     
           
    -      
           
           
    -      
    - +

    Key antibiotics

    -

    There are two ways to determine whether isolates can be included as first weighted isolates which will give generally the same results:

    + +

    There are two ways to determine whether isolates can be included as first weighted isolates which will give generally the same results:

    1. Using type = "keyantibiotics" and parameter ignore_I
    Any difference from S to R (or vice versa) will (re)select an isolate as a first weighted isolate. With ignore_I = FALSE, also differences from I to S|R (or vice versa) will lead to this. This is a reliable method and 30-35 times faster than method 2. Read more about this in the key_antibiotics function.

    2. Using type = "points" and parameter points_threshold
    A difference from I to S|R (or vice versa) means 0.5 points, a difference from S to R (or vice versa) means 1 point. When the sum of points exceeds points_threshold, which default to 2, an isolate will be (re)selected as a first weighted isolate.

    -

    Read more on our website!

    -

    On our website https://msberends.gitlab.io/AMR you can find a tutorial about how to conduct AMR analysis, the complete documentation of all functions (which reads a lot easier than here in R) and an example analysis using WHONET data.

    - + +

    On our website https://msberends.gitlab.io/AMR you can find a tutorial about how to conduct AMR analysis, the complete documentation of all functions (which reads a lot easier than here in R) and an example analysis using WHONET data.

    See also

    -

    Examples

    -
    # NOT RUN {
    -# `example_isolates` is a dataset available in the AMR package.
    +    
    # `example_isolates` is a dataset available in the AMR package.
     # See ?example_isolates.
     
    -library(dplyr)
    +library(dplyr)
     # Filter on first isolates:
     example_isolates %>%
       mutate(first_isolate = first_isolate(.,
    @@ -412,76 +411,44 @@ To conduct an analysis of antimicrobial resistance, you should only include the
     
     ## OTHER EXAMPLES:
     
    -# }# NOT RUN {
    +if (FALSE) {
    +
     # set key antibiotics to a new variable
     x$keyab <- key_antibiotics(x)
     
    -x$first_isolate <-
    -  first_isolate(x)
    +x$first_isolate <- first_isolate(x)
     
    -x$first_isolate_weighed <-
    -  first_isolate(x,
    -                col_keyantibiotics = 'keyab')
    +x$first_isolate_weighed <- first_isolate(x, col_keyantibiotics = 'keyab')
     
    -x$first_blood_isolate <-
    -  first_isolate(x,
    -                specimen_group = 'Blood')
    -
    -x$first_blood_isolate_weighed <-
    -  first_isolate(x,
    -                specimen_group = 'Blood',
    -                col_keyantibiotics = 'keyab')
    -
    -x$first_urine_isolate <-
    -  first_isolate(x,
    -                specimen_group = 'Urine')
    -
    -x$first_urine_isolate_weighed <-
    -  first_isolate(x,
    -                specimen_group = 'Urine',
    -                col_keyantibiotics = 'keyab')
    -
    -x$first_resp_isolate <-
    -  first_isolate(x,
    -                specimen_group = 'Respiratory')
    -
    -x$first_resp_isolate_weighed <-
    -  first_isolate(x,
    -                specimen_group = 'Respiratory',
    -                col_keyantibiotics = 'keyab')
    -# }
    +x$first_blood_isolate <- first_isolate(x, specimen_group = "Blood") +}
    + @@ -504,6 +471,8 @@ To conduct an analysis of antimicrobial resistance, you should only include the + + diff --git a/docs/reference/index.html b/docs/reference/index.html index b7b7926a..c2304aa4 100644 --- a/docs/reference/index.html +++ b/docs/reference/index.html @@ -84,7 +84,7 @@ AMR (for R) - 0.7.1.9100 + 0.7.1.9102 diff --git a/man/bug_drug_combinations.Rd b/man/bug_drug_combinations.Rd index 6913a452..64c83ebb 100644 --- a/man/bug_drug_combinations.Rd +++ b/man/bug_drug_combinations.Rd @@ -67,7 +67,7 @@ On our website \url{https://msberends.gitlab.io/AMR} you can find \href{https:// \donttest{ x <- bug_drug_combinations(example_isolates) x -format(x) +format(x, translate_ab = "name (atc)") # Use FUN to change to transformation of microorganism codes x <- bug_drug_combinations(example_isolates, diff --git a/man/first_isolate.Rd b/man/first_isolate.Rd index 1c875f49..3cad54fd 100755 --- a/man/first_isolate.Rd +++ b/man/first_isolate.Rd @@ -150,39 +150,11 @@ B <- example_isolates \%>\% # set key antibiotics to a new variable x$keyab <- key_antibiotics(x) -x$first_isolate <- - first_isolate(x) +x$first_isolate <- first_isolate(x) -x$first_isolate_weighed <- - first_isolate(x, - col_keyantibiotics = 'keyab') +x$first_isolate_weighed <- first_isolate(x, col_keyantibiotics = 'keyab') -x$first_blood_isolate <- - first_isolate(x, - specimen_group = 'Blood') - -x$first_blood_isolate_weighed <- - first_isolate(x, - specimen_group = 'Blood', - col_keyantibiotics = 'keyab') - -x$first_urine_isolate <- - first_isolate(x, - specimen_group = 'Urine') - -x$first_urine_isolate_weighed <- - first_isolate(x, - specimen_group = 'Urine', - col_keyantibiotics = 'keyab') - -x$first_resp_isolate <- - first_isolate(x, - specimen_group = 'Respiratory') - -x$first_resp_isolate_weighed <- - first_isolate(x, - specimen_group = 'Respiratory', - col_keyantibiotics = 'keyab') +x$first_blood_isolate <- first_isolate(x, specimen_group = "Blood") } } \seealso{ diff --git a/tests/testthat/test-ab_property.R b/tests/testthat/test-ab_property.R index 529950f4..d01370fa 100644 --- a/tests/testthat/test-ab_property.R +++ b/tests/testthat/test-ab_property.R @@ -37,13 +37,13 @@ test_that("ab_property works", { expect_identical(ab_name("Fluclox"), "Flucloxacillin") expect_identical(ab_name("fluklox"), "Flucloxacillin") expect_identical(ab_name("floxapen"), "Flucloxacillin") - expect_identical(ab_name(21319) , "Flucloxacillin") + expect_identical(ab_name(21319), "Flucloxacillin") expect_identical(ab_name("J01CF05"), "Flucloxacillin") expect_identical(ab_ddd("AMX", "oral"), 1) - expect_identical(ab_ddd("AMX", "oral", units = TRUE) , "g") + expect_identical(ab_ddd("AMX", "oral", units = TRUE), "g") expect_identical(ab_ddd("AMX", "iv"), 1) - expect_identical(ab_ddd("AMX", "iv", units = TRUE) , "g") + expect_identical(ab_ddd("AMX", "iv", units = TRUE), "g") expect_identical(ab_name(x = c("AMC", "PLB")), c("Amoxicillin/clavulanic acid", "Polymyxin B")) expect_identical(ab_name(x = c("AMC", "PLB"), tolower = TRUE), diff --git a/tests/testthat/test-count.R b/tests/testthat/test-count.R index a3dd0ce7..a85d88a1 100644 --- a/tests/testthat/test-count.R +++ b/tests/testthat/test-count.R @@ -85,6 +85,6 @@ test_that("counts work", { expect_error(count_S("test", as_percent = "test")) expect_error(count_df(c("A", "B", "C"))) - expect_error(count_df(example_isolates[,"date"])) + expect_error(count_df(example_isolates[, "date"])) }) diff --git a/tests/testthat/test-data.R b/tests/testthat/test-data.R index 2ed7e488..462d61e9 100644 --- a/tests/testthat/test-data.R +++ b/tests/testthat/test-data.R @@ -41,9 +41,8 @@ test_that("data sets are valid", { # there should be no diacritics (i.e. non ASCII) characters in the datasets (CRAN policy) datasets <- data(package = "AMR", envir = asNamespace("AMR"))$results[, "Item"] - for (i in 1:length(datasets)) { + for (i in seq_len(length(datasets))) { dataset <- get(datasets[i], envir = asNamespace("AMR")) - #print(paste("testing data set", datasets[i])) expect_identical(dataset_UTF8_to_ASCII(dataset), dataset) } }) diff --git a/tests/testthat/test-first_isolate.R b/tests/testthat/test-first_isolate.R index e3640ef7..47ae3c89 100755 --- a/tests/testthat/test-first_isolate.R +++ b/tests/testthat/test-first_isolate.R @@ -33,16 +33,12 @@ test_that("first isolates work", { na.rm = TRUE), 1317) - # first *weighted* isolates + # first weighted isolates expect_equal( suppressWarnings( sum( first_isolate(x = example_isolates %>% mutate(keyab = key_antibiotics(.)), - # let syntax determine these automatically: - # col_date = "date", - # col_patient_id = "patient_id", - # col_mo = "mo", - # col_keyantibiotics = "keyab", + # let syntax determine arguments automatically type = "keyantibiotics", info = TRUE), na.rm = TRUE)), @@ -145,7 +141,7 @@ test_that("first isolates work", { filter_specimen = "something_unexisting"))) # printing of exclusion message - expect_output(example_isolates %>% + expect_message(example_isolates %>% first_isolate(col_date = "date", col_mo = "mo", col_patient_id = "patient_id", diff --git a/tests/testthat/test-freq.R b/tests/testthat/test-freq.R index c115db54..5dd39359 100755 --- a/tests/testthat/test-freq.R +++ b/tests/testthat/test-freq.R @@ -34,4 +34,3 @@ test_that("frequency table works", { library(dplyr) expect_true(is.freq(example_isolates %>% freq(AMX))) }) - diff --git a/tests/testthat/test-g.test.R b/tests/testthat/test-g.test.R index 1f3e6185..63d33e2c 100644 --- a/tests/testthat/test-g.test.R +++ b/tests/testthat/test-g.test.R @@ -60,7 +60,7 @@ test_that("G-test works", { y = c(780, 1560, 780), rescale.p = TRUE)) - expect_error(g.test(matrix(data = c(-1, -2, -3 , -4), ncol = 2, byrow = TRUE))) + expect_error(g.test(matrix(data = c(-1, -2, -3, -4), ncol = 2, byrow = TRUE))) expect_error(g.test(matrix(data = c(0, 0, 0, 0), ncol = 2, byrow = TRUE))) }) diff --git a/tests/testthat/test-get_locale.R b/tests/testthat/test-get_locale.R index 1daee661..de3bd9d8 100644 --- a/tests/testthat/test-get_locale.R +++ b/tests/testthat/test-get_locale.R @@ -30,7 +30,6 @@ test_that("get_locale works", { expect_identical(mo_fullname("CoNS", "nl"), "Coagulase-negatieve Staphylococcus (CNS)") expect_identical(mo_fullname("CoNS", "es"), "Staphylococcus coagulasa negativo (SCN)") expect_identical(mo_fullname("CoNS", "it"), "Staphylococcus negativo coagulasi (CoNS)") - # expect_identical(mo_fullname("CoNS", "fr"), "Staphylococcus \u00e0 coagulase n\u00e9gative (CoNS)") expect_identical(mo_fullname("CoNS", "pt"), "Staphylococcus coagulase negativo (CoNS)") }) diff --git a/tests/testthat/test-ggplot_rsi.R b/tests/testthat/test-ggplot_rsi.R index 025ee7d5..d9ce89ad 100644 --- a/tests/testthat/test-ggplot_rsi.R +++ b/tests/testthat/test-ggplot_rsi.R @@ -30,35 +30,26 @@ test_that("ggplot_rsi works", { # data should be equal expect_equal( - (example_isolates %>% select(AMC, CIP) %>% ggplot_rsi())$data %>% - summarise_all(portion_IR) %>% as.double(), - example_isolates %>% select(AMC, CIP) %>% - summarise_all(portion_IR) %>% as.double() + (example_isolates %>% select(AMC, CIP) %>% ggplot_rsi())$data %>% summarise_all(portion_IR) %>% as.double(), + example_isolates %>% select(AMC, CIP) %>% summarise_all(portion_IR) %>% as.double() ) print(example_isolates %>% select(AMC, CIP) %>% ggplot_rsi(x = "interpretation", facet = "antibiotic")) print(example_isolates %>% select(AMC, CIP) %>% ggplot_rsi(x = "antibiotic", facet = "interpretation")) expect_equal( - (example_isolates %>% select(AMC, CIP) %>% ggplot_rsi(x = "interpretation", facet = "antibiotic"))$data %>% - summarise_all(portion_IR) %>% as.double(), - example_isolates %>% select(AMC, CIP) %>% - summarise_all(portion_IR) %>% as.double() + (example_isolates %>% select(AMC, CIP) %>% ggplot_rsi(x = "interpretation", facet = "antibiotic"))$data %>% summarise_all(portion_IR) %>% as.double(), + example_isolates %>% select(AMC, CIP) %>% summarise_all(portion_IR) %>% as.double() ) expect_equal( - (example_isolates %>% select(AMC, CIP) %>% ggplot_rsi(x = "antibiotic", facet = "interpretation"))$data %>% - summarise_all(portion_IR) %>% as.double(), - example_isolates %>% select(AMC, CIP) %>% - summarise_all(portion_IR) %>% as.double() + (example_isolates %>% select(AMC, CIP) %>% ggplot_rsi(x = "antibiotic", facet = "interpretation"))$data %>% summarise_all(portion_IR) %>% as.double(), + example_isolates %>% select(AMC, CIP) %>% summarise_all(portion_IR) %>% as.double() ) expect_equal( - (example_isolates %>% select(AMC, CIP) %>% ggplot_rsi(x = "antibiotic", - facet = "interpretation"))$data %>% - summarise_all(count_IR) %>% as.double(), - example_isolates %>% select(AMC, CIP) %>% - summarise_all(count_IR) %>% as.double() + (example_isolates %>% select(AMC, CIP) %>% ggplot_rsi(x = "antibiotic", facet = "interpretation"))$data %>% summarise_all(count_IR) %>% as.double(), + example_isolates %>% select(AMC, CIP) %>% summarise_all(count_IR) %>% as.double() ) # support for scale_type ab and mo diff --git a/tests/testthat/test-mdro.R b/tests/testthat/test-mdro.R index 7aa60a7d..2282721f 100755 --- a/tests/testthat/test-mdro.R +++ b/tests/testthat/test-mdro.R @@ -32,11 +32,11 @@ test_that("mdro works", { outcome <- mdro(example_isolates) outcome <- eucast_exceptional_phenotypes(example_isolates, info = TRUE) # check class - expect_equal(outcome %>% class(), c('ordered', 'factor')) + expect_equal(outcome %>% class(), c("ordered", "factor")) outcome <- mdro(example_isolates, "nl", info = TRUE) # check class - expect_equal(outcome %>% class(), c('ordered', 'factor')) + expect_equal(outcome %>% class(), c("ordered", "factor")) # example_isolates should have these finding using Dutch guidelines expect_equal(outcome %>% freq() %>% pull(count), diff --git a/tests/testthat/test-mo.R b/tests/testthat/test-mo.R index 8e646623..ffc54b87 100644 --- a/tests/testthat/test-mo.R +++ b/tests/testthat/test-mo.R @@ -94,7 +94,7 @@ test_that("as.mo works", { rep("B_STPHY_AURS", 9)) expect_identical( as.character( - as.mo(c('EHEC', 'EPEC', 'EIEC', 'STEC', 'ATEC', 'UPEC'))), + as.mo(c("EHEC", "EPEC", "EIEC", "STEC", "ATEC", "UPEC"))), rep("B_ESCHR_COLI", 6)) # unprevalent MO expect_identical( @@ -114,13 +114,13 @@ test_that("as.mo works", { c("UNKNOWN", NA_character_, "B_STNTR_MLTP", "B_KLBSL_PNMN_RHNS", "B_ESCHR_COLI")) # check for Becker classification - expect_identical(as.character(as.mo("S. epidermidis", Becker = FALSE)), "B_STPHY_EPDR") - expect_identical(as.character(as.mo("S. epidermidis", Becker = TRUE)), "B_STPHY_CONS") - expect_identical(as.character(as.mo("STAEPI", Becker = TRUE)), "B_STPHY_CONS") - expect_identical(as.character(as.mo("S. intermedius", Becker = FALSE)), "B_STPHY_INTR") - expect_identical(as.character(as.mo("Sta intermedius",Becker = FALSE)), "B_STPHY_INTR") - expect_identical(as.character(as.mo("Sta intermedius",Becker = TRUE)), "B_STPHY_COPS") - expect_identical(as.character(as.mo("STAINT", Becker = TRUE)), "B_STPHY_COPS") + expect_identical(as.character(as.mo("S. epidermidis", Becker = FALSE)), "B_STPHY_EPDR") + expect_identical(as.character(as.mo("S. epidermidis", Becker = TRUE)), "B_STPHY_CONS") + expect_identical(as.character(as.mo("STAEPI", Becker = TRUE)), "B_STPHY_CONS") + expect_identical(as.character(as.mo("S. intermedius", Becker = FALSE)), "B_STPHY_INTR") + expect_identical(as.character(as.mo("Sta intermedius", Becker = FALSE)), "B_STPHY_INTR") + expect_identical(as.character(as.mo("Sta intermedius", Becker = TRUE)), "B_STPHY_COPS") + expect_identical(as.character(as.mo("STAINT", Becker = TRUE)), "B_STPHY_COPS") # aureus must only be influenced if Becker = "all" expect_identical(as.character(as.mo("STAAUR", Becker = FALSE)), "B_STPHY_AURS") expect_identical(as.character(as.mo("STAAUR", Becker = TRUE)), "B_STPHY_AURS") @@ -150,7 +150,7 @@ test_that("as.mo works", { # select with one column expect_identical( - example_isolates[1:10,] %>% + example_isolates[1:10, ] %>% left_join_microorganisms() %>% select(genus) %>% as.mo() %>% @@ -160,9 +160,9 @@ test_that("as.mo works", { # select with two columns expect_identical( - example_isolates[1:10,] %>% + example_isolates[1:10, ] %>% pull(mo), - example_isolates[1:10,] %>% + example_isolates[1:10, ] %>% left_join_microorganisms() %>% select(genus, species) %>% as.mo()) @@ -260,10 +260,6 @@ test_that("as.mo works", { expect_null(mo_failures()) expect_true(example_isolates %>% pull(mo) %>% is.mo()) - # expect_equal(get_mo_code("test", "mo"), "test") - # expect_equal(length(get_mo_code("Escherichia", "genus")), - # nrow(AMR::microorganisms[base::which(AMR::microorganisms[, "genus"] %in% "Escherichia"),])) - expect_error(translate_allow_uncertain(5)) # very old MO codes (<= v0.5.0) diff --git a/tests/testthat/test-mo_property.R b/tests/testthat/test-mo_property.R index 4682b157..0efd4458 100644 --- a/tests/testthat/test-mo_property.R +++ b/tests/testthat/test-mo_property.R @@ -57,7 +57,7 @@ test_that("mo_property works", { expect_equal(mo_shortname("Streptococcus agalactiae"), "S. agalactiae") expect_equal(mo_shortname("Streptococcus agalactiae", Lancefield = TRUE), "GBS") - #expect_true(mo_url("Escherichia coli") %like% "www.catalogueoflife.org") + expect_true(mo_url("Escherichia coli") %like% "www.catalogueoflife.org") # test integrity MOs <- AMR::microorganisms diff --git a/tests/testthat/test-portion.R b/tests/testthat/test-portion.R index 4db83d7a..2c9ab72d 100755 --- a/tests/testthat/test-portion.R +++ b/tests/testthat/test-portion.R @@ -117,5 +117,5 @@ test_that("portions works", { ) expect_error(portion_df(c("A", "B", "C"))) - expect_error(portion_df(example_isolates[,"date"])) + expect_error(portion_df(example_isolates[, "date"])) })