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

(v1.6.0.9022) unit test fix

Browse Source
This commit is contained in:
dr. M.S. (Matthijs) Berends 2021-05-13 15:56:12 +02:00
parent 29dbfa2f49
commit 655b813e99
19 changed files with 84 additions and 61 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
DESCRIPTION
View File

@ -1,6 +1,6 @@
Package: AMR
Version: 1.6.0.9021
Date: 2021-05-12
Version: 1.6.0.9022
Date: 2021-05-13
Title: Antimicrobial Resistance Data Analysis
Authors@R: c(
person(role = c("aut", "cre"),

4
NEWS.md
View File

@ -1,5 +1,5 @@
# `AMR` 1.6.0.9021
## <small>Last updated: 12 May 2021</small>
# `AMR` 1.6.0.9022
## <small>Last updated: 13 May 2021</small>
### New
* Function `custom_eucast_rules()` that brings support for custom AMR rules in `eucast_rules()`

44
R/eucast_rules.R
View File

@ -240,7 +240,13 @@ eucast_rules <- function(x,
cat(font_subtle(" (no changes)\n"))
} else {
# opening
if (n_added > 0 & n_changed == 0) {
cat(font_green(" ("))
} else if (n_added == 0 & n_changed > 0) {
cat(font_blue(" ("))
} else {
cat(font_grey(" ("))
}
# additions
if (n_added > 0) {
if (n_added == 1) {
@ -262,8 +268,14 @@ eucast_rules <- function(x,
}
}
# closing
if (n_added > 0 & n_changed == 0) {
cat(font_green(")\n"))
} else if (n_added == 0 & n_changed > 0) {
cat(font_blue(")\n"))
} else {
cat(font_grey(")\n"))
}
}
warned <<- FALSE
}
}
@ -398,7 +410,7 @@ eucast_rules <- function(x,
paste0(x, collapse = "")
})
# save original [table], with the new .rowid column
# save original table, with the new .rowid column
x.bak <- x
# keep only unique rows for MO and ABx
x <- x %pm>%
@ -413,7 +425,7 @@ eucast_rules <- function(x,
# join to microorganisms data set
x <- left_join_microorganisms(x, by = col_mo, suffix = c("_oldcols", ""))
x$gramstain <- mo_gramstain(x[, col_mo, drop = TRUE], language = NULL)
x$genus_species <- paste(x$genus, x$species)
x$genus_species <- trimws(paste(x$genus, x$species))
if (info == TRUE & NROW(x) > 10000) {
message_(" OK.", add_fn = list(font_green, font_bold), as_note = FALSE)
}
@ -902,21 +914,23 @@ eucast_rules <- function(x,
cat(paste0(font_grey(strrep("-", 0.95 * options()$width)), "\n"))
if (verbose == FALSE & total_n_added + total_n_changed > 0) {
cat("\n", word_wrap("Use ", font_bold("eucast_rules(..., verbose = TRUE)"), " (on your original data) to get a [data.frame] with all specified edits instead."), "\n\n", sep = "")
cat("\n", word_wrap("Use ", font_bold("eucast_rules(..., verbose = TRUE)"), " (on your original data) to get a data.frame with all specified edits instead."), "\n\n", sep = "")
} else if (verbose == TRUE) {
cat("\n", word_wrap("Used 'Verbose mode' (", font_bold("verbose = TRUE"), "), which returns a [data.frame] with all specified edits.\nUse ", font_bold("verbose = FALSE"), " to apply the rules on your data."), "\n\n", sep = "")
cat("\n", word_wrap("Used 'Verbose mode' (", font_bold("verbose = TRUE"), "), which returns a data.frame with all specified edits.\nUse ", font_bold("verbose = FALSE"), " to apply the rules on your data."), "\n\n", sep = "")
}
}
if (length(warn_lacking_rsi_class) > 0) {
warn_lacking_rsi_class <- unique(warn_lacking_rsi_class)
# take order from original data set
warn_lacking_rsi_class <- warn_lacking_rsi_class[order(colnames(x.bak))]
warn_lacking_rsi_class <- warn_lacking_rsi_class[!is.na(warn_lacking_rsi_class)]
warning_("Not all columns with antimicrobial results are of class <rsi>. Transform them on beforehand, with e.g.:\n",
" ", x_deparsed, " %>% mutate_if(is.rsi.eligible, as.rsi)\n",
" ", x_deparsed, " %>% mutate(across((is.rsi.eligible), as.rsi))\n",
" ", x_deparsed, " %>% as.rsi(", ifelse(length(warn_lacking_rsi_class) == 1,
" - ", x_deparsed, " %>% as.rsi(", ifelse(length(warn_lacking_rsi_class) == 1,
warn_lacking_rsi_class,
paste0(warn_lacking_rsi_class[1], ":", warn_lacking_rsi_class[length(warn_lacking_rsi_class)])),
")",
paste0(warn_lacking_rsi_class[1], ":", warn_lacking_rsi_class[length(warn_lacking_rsi_class)])), ")\n",
" - ", x_deparsed, " %>% mutate_if(is.rsi.eligible, as.rsi)\n",
" - ", x_deparsed, " %>% mutate(across(where(is.rsi.eligible), as.rsi))",
call = FALSE)
}
@ -936,7 +950,7 @@ eucast_rules <- function(x,
}
}
# helper function for editing the [table] ----
# helper function for editing the table ----
edit_rsi <- function(x,
to,
rule,
@ -961,7 +975,7 @@ edit_rsi <- function(x,
}
txt_warning <- function() {
if (warned == FALSE) {
if (info == TRUE) cat("", font_yellow_bg(font_black(" WARNING ")))
if (info == TRUE) cat(" ", font_rsi_I_bg(" WARNING "), sep = "")
}
warned <<- TRUE
}
@ -975,20 +989,22 @@ edit_rsi <- function(x,
# insert into original table
new_edits[rows, cols] <- to,
warning = function(w) {
if (w$message %like% "invalid [factor] level") {
if (w$message %like% "invalid factor level") {
xyz <- vapply(FUN.VALUE = logical(1), cols, function(col) {
new_edits[, col] <<- factor(x = as.character(pm_pull(new_edits, col)),
levels = unique(c(to, levels(pm_pull(new_edits, col)))))
TRUE
})
suppressWarnings(new_edits[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. A 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", ifelse(length(cols) == 1, "", "s"),
" ", vector_and(cols, quotes = "`", sort = FALSE),
" because this value was not an existing factor level.",
call = FALSE)
txt_warning()
warned <- FALSE
} else {
warning_(w$message, call = FALSE)
txt_warning()
cat("\n") # txt_warning() does not append a "\n" on itself
}
},
error = function(e) {

14
R/join_microorganisms.R
View File

@ -105,7 +105,7 @@ semi_join_microorganisms <- function(x, by = NULL, ...) {
meet_criteria(x, allow_class = c("data.frame", "character"))
meet_criteria(by, allow_class = "character", allow_NULL = TRUE)
join_microorganisms(type = "semi_join", x = x, by = by, suffix = suffix, ...)
join_microorganisms(type = "semi_join", x = x, by = by, ...)
}
#' @rdname join
@ -114,7 +114,7 @@ anti_join_microorganisms <- function(x, by = NULL, ...) {
meet_criteria(x, allow_class = c("data.frame", "character"))
meet_criteria(by, allow_class = "character", allow_NULL = TRUE)
join_microorganisms(type = "anti_join", x = x, by = by, suffix = suffix, ...)
join_microorganisms(type = "anti_join", x = x, by = by, ...)
}
join_microorganisms <- function(type, x, by, suffix, ...) {
@ -126,8 +126,12 @@ join_microorganisms <- function(type, x, by, suffix, ...) {
}
if (is.null(by)) {
by <- search_type_in_df(x, "mo", info = FALSE)
stop_if(is.null(by), "cannot join - no column with microorganism names or codes found")
# message_('Joining, by = "', by, '"', add_fn = font_black, as_note = FALSE) # message same as dplyr::join functions
if (is.null(by) && NCOL(x) == 1) {
by <- colnames(x)[1L]
} else {
stop_if(is.null(by), "no column with microorganism names or codes found, set this column with `by`", call = -2)
}
message_('Joining, by = "', by, '"', add_fn = font_black, as_note = FALSE) # message same as dplyr::join functions
}
if (!all(x[, by, drop = TRUE] %in% MO_lookup$mo, na.rm = TRUE)) {
x$join.mo <- as.mo(x[, by, drop = TRUE])
@ -166,7 +170,7 @@ join_microorganisms <- function(type, x, by, suffix, ...) {
}
if (type %like% "full|left|right|inner" && NROW(joined) > NROW(x)) {
warning_("The newly joined tbl contains ", nrow(joined) - nrow(x), " rows more that its original.", call = FALSE)
warning_("The newly joined data set contains ", nrow(joined) - nrow(x), " rows more than the number of rows of `x`.", call = FALSE)
}
joined

4
R/rsi.R
View File

@ -135,7 +135,7 @@
#' if (require("dplyr")) {
#' df %>% mutate_if(is.mic, as.rsi)
#' df %>% mutate_if(function(x) is.mic(x) | is.disk(x), as.rsi)
#' df %>% mutate(across((is.mic), as.rsi))
#' df %>% mutate(across(where(is.mic), as.rsi))
#' df %>% mutate_at(vars(AMP:TOB), as.rsi)
#' df %>% mutate(across(AMP:TOB, as.rsi))
#'
@ -181,7 +181,7 @@
#'
#' # note: from dplyr 1.0.0 on, this will be:
#' # example_isolates %>%
#' # mutate(across((is.rsi.eligible), as.rsi))
#' # mutate(across(where(is.rsi.eligible), as.rsi))
#' }
#' }
as.rsi <- function(x, ...) {

2
R/rsi_calc.R
View File

@ -150,7 +150,7 @@ rsi_calc <- function(...,
if (message_not_thrown_before("rsi_calc")) {
warning_("Increase speed by transforming to class <rsi> on beforehand:\n",
" your_data %>% mutate_if(is.rsi.eligible, as.rsi)\n",
" your_data %>% mutate(across((is.rsi.eligible), as.rsi))",
" your_data %>% mutate(across(where(is.rsi.eligible), as.rsi))",
call = FALSE)
remember_thrown_message("rsi_calc")
}

BIN
data-raw/AMR_latest.tar.gz
View File

Binary file not shown.

2
docs/404.html
View File

@ -81,7 +81,7 @@
</button>
<span class="navbar-brand">
<a class="navbar-link" href="https://msberends.github.io/AMR//index.html">AMR (for R)</a>
<span class="version label label-default" data-toggle="tooltip" data-placement="bottom" title="Latest development version">1.6.0.9021</span>
<span class="version label label-default" data-toggle="tooltip" data-placement="bottom" title="Latest development version">1.6.0.9022</span>
</span>
</div>

2
docs/LICENSE-text.html
View File

@ -81,7 +81,7 @@
</button>
<span class="navbar-brand">
<a class="navbar-link" href="index.html">AMR (for R)</a>
<span class="version label label-default" data-toggle="tooltip" data-placement="bottom" title="Latest development version">1.6.0.9021</span>
<span class="version label label-default" data-toggle="tooltip" data-placement="bottom" title="Latest development version">1.6.0.9022</span>
</span>
</div>

2
docs/articles/index.html
View File

@ -81,7 +81,7 @@
</button>
<span class="navbar-brand">
<a class="navbar-link" href="../index.html">AMR (for R)</a>
<span class="version label label-default" data-toggle="tooltip" data-placement="bottom" title="Latest development version">1.6.0.9021</span>
<span class="version label label-default" data-toggle="tooltip" data-placement="bottom" title="Latest development version">1.6.0.9022</span>
</span>
</div>

2
docs/authors.html
View File

@ -81,7 +81,7 @@
</button>
<span class="navbar-brand">
<a class="navbar-link" href="index.html">AMR (for R)</a>
<span class="version label label-default" data-toggle="tooltip" data-placement="bottom" title="Latest development version">1.6.0.9021</span>
<span class="version label label-default" data-toggle="tooltip" data-placement="bottom" title="Latest development version">1.6.0.9022</span>
</span>
</div>

2
docs/index.html
View File

@ -42,7 +42,7 @@
</button>
<span class="navbar-brand">
<a class="navbar-link" href="index.html">AMR (for R)</a>
<span class="version label label-default" data-toggle="tooltip" data-placement="bottom" title="Latest development version">1.6.0.9021</span>
<span class="version label label-default" data-toggle="tooltip" data-placement="bottom" title="Latest development version">1.6.0.9022</span>
</span>
</div>

16
docs/news/index.html
View File

@ -81,7 +81,7 @@
</button>
<span class="navbar-brand">
<a class="navbar-link" href="../index.html">AMR (for R)</a>
<span class="version label label-default" data-toggle="tooltip" data-placement="bottom" title="Latest development version">1.6.0.9021</span>
<span class="version label label-default" data-toggle="tooltip" data-placement="bottom" title="Latest development version">1.6.0.9022</span>
</span>
</div>
@ -236,12 +236,12 @@
<small>Source: <a href='https://github.com/msberends/AMR/blob/master/NEWS.md'><code>NEWS.md</code></a></small>
</div>
<div id="amr-1609021" class="section level1">
<h1 class="page-header" data-toc-text="1.6.0.9021">
<a href="#amr-1609021" class="anchor"></a><small> Unreleased </small><code>AMR</code> 1.6.0.9021</h1>
<div id="last-updated-12-may-2021" class="section level2">
<div id="amr-1609022" class="section level1">
<h1 class="page-header" data-toc-text="1.6.0.9022">
<a href="#amr-1609022" class="anchor"></a><small> Unreleased </small><code>AMR</code> 1.6.0.9022</h1>
<div id="last-updated-13-may-2021" class="section level2">
<h2 class="hasAnchor">
<a href="#last-updated-12-may-2021" class="anchor"></a><small>Last updated: 12 May 2021</small>
<a href="#last-updated-13-may-2021" class="anchor"></a><small>Last updated: 13 May 2021</small>
</h2>
<div id="new" class="section level3">
<h3 class="hasAnchor">
@ -346,7 +346,7 @@
<span class="co">#&gt; Filtering on oxazolidinones: value in column `LNZ` (linezolid) is either "R", "S" or "I"</span></code></pre></div>
</li>
<li><p>Support for custom MDRO guidelines, using the new <code><a href="../reference/mdro.html">custom_mdro_guideline()</a></code> function, please see <code><a href="../reference/mdro.html">mdro()</a></code> for additional info</p></li>
<li><p><code><a href="https://ggplot2.tidyverse.org/reference/ggplot.html">ggplot()</a></code> generics for classes <code>&lt;mic&gt;</code> and <code>&lt;disk&gt;</code></p></li>
<li><p><code>ggplot()</code> generics for classes <code>&lt;mic&gt;</code> and <code>&lt;disk&gt;</code></p></li>
<li>
<p>Function <code><a href="../reference/mo_property.html">mo_is_yeast()</a></code>, which determines whether a microorganism is a member of the taxonomic class Saccharomycetes or the taxonomic order Saccharomycetales:</p>
<div class="sourceCode" id="cb3"><pre class="downlit sourceCode r">
@ -403,7 +403,7 @@
<li>Plotting of MIC and disk diffusion values now support interpretation colouring if you supply the microorganism and antimicrobial agent</li>
<li>All colours were updated to colour-blind friendly versions for values R, S and I for all plot methods (also applies to tibble printing)</li>
<li>Interpretation of MIC and disk diffusion values to R/SI will now be translated if the system language is German, Dutch or Spanish (see <code>translate</code>)</li>
<li>Plotting is now possible with base R using <code><a href="../reference/plot.html">plot()</a></code> and with ggplot2 using <code><a href="https://ggplot2.tidyverse.org/reference/ggplot.html">ggplot()</a></code> on any vector of MIC and disk diffusion values</li>
<li>Plotting is now possible with base R using <code><a href="../reference/plot.html">plot()</a></code> and with ggplot2 using <code>ggplot()</code> on any vector of MIC and disk diffusion values</li>
</ul>
</li>
<li>Updated SNOMED codes to US Edition of SNOMED CT from 1 September 2020 and added the source to the help page of the <code>microorganisms</code> data set</li>

2
docs/pkgdown.yml
View File

@ -12,7 +12,7 @@ articles:
datasets: datasets.html
resistance_predict: resistance_predict.html
welcome_to_AMR: welcome_to_AMR.html
last_built: 2021-05-12T16:13Z
last_built: 2021-05-13T13:55Z
urls:
reference: https://msberends.github.io/AMR//reference
article: https://msberends.github.io/AMR//articles

6
docs/reference/as.rsi.html
View File

@ -82,7 +82,7 @@
</button>
<span class="navbar-brand">
<a class="navbar-link" href="../index.html">AMR (for R)</a>
<span class="version label label-default" data-toggle="tooltip" data-placement="bottom" title="Latest development version">1.6.0.9021</span>
<span class="version label label-default" data-toggle="tooltip" data-placement="bottom" title="Latest development version">1.6.0.9022</span>
</span>
</div>
@ -453,7 +453,7 @@ The <a href='lifecycle.html'>lifecycle</a> of this function is <strong>stable</s
<span class='kw'>if</span> <span class='op'>(</span><span class='kw'><a href='https://rdrr.io/r/base/library.html'>require</a></span><span class='op'>(</span><span class='st'><a href='https://dplyr.tidyverse.org'>"dplyr"</a></span><span class='op'>)</span><span class='op'>)</span> <span class='op'>{</span>
<span class='va'>df</span> <span class='op'>%&gt;%</span> <span class='fu'><a href='https://dplyr.tidyverse.org/reference/mutate_all.html'>mutate_if</a></span><span class='op'>(</span><span class='va'>is.mic</span>, <span class='va'>as.rsi</span><span class='op'>)</span>
<span class='va'>df</span> <span class='op'>%&gt;%</span> <span class='fu'><a href='https://dplyr.tidyverse.org/reference/mutate_all.html'>mutate_if</a></span><span class='op'>(</span><span class='kw'>function</span><span class='op'>(</span><span class='va'>x</span><span class='op'>)</span> <span class='fu'><a href='as.mic.html'>is.mic</a></span><span class='op'>(</span><span class='va'>x</span><span class='op'>)</span> <span class='op'>|</span> <span class='fu'><a href='as.disk.html'>is.disk</a></span><span class='op'>(</span><span class='va'>x</span><span class='op'>)</span>, <span class='va'>as.rsi</span><span class='op'>)</span>
<span class='va'>df</span> <span class='op'>%&gt;%</span> <span class='fu'><a href='https://dplyr.tidyverse.org/reference/mutate.html'>mutate</a></span><span class='op'>(</span><span class='fu'><a href='https://dplyr.tidyverse.org/reference/across.html'>across</a></span><span class='op'>(</span><span class='op'>(</span><span class='va'>is.mic</span><span class='op'>)</span>, <span class='va'>as.rsi</span><span class='op'>)</span><span class='op'>)</span>
<span class='va'>df</span> <span class='op'>%&gt;%</span> <span class='fu'><a href='https://dplyr.tidyverse.org/reference/mutate.html'>mutate</a></span><span class='op'>(</span><span class='fu'><a href='https://dplyr.tidyverse.org/reference/across.html'>across</a></span><span class='op'>(</span><span class='fu'>where</span><span class='op'>(</span><span class='va'>is.mic</span><span class='op'>)</span>, <span class='va'>as.rsi</span><span class='op'>)</span><span class='op'>)</span>
<span class='va'>df</span> <span class='op'>%&gt;%</span> <span class='fu'><a href='https://dplyr.tidyverse.org/reference/mutate_all.html'>mutate_at</a></span><span class='op'>(</span><span class='fu'><a href='https://dplyr.tidyverse.org/reference/vars.html'>vars</a></span><span class='op'>(</span><span class='va'>AMP</span><span class='op'>:</span><span class='va'>TOB</span><span class='op'>)</span>, <span class='va'>as.rsi</span><span class='op'>)</span>
<span class='va'>df</span> <span class='op'>%&gt;%</span> <span class='fu'><a href='https://dplyr.tidyverse.org/reference/mutate.html'>mutate</a></span><span class='op'>(</span><span class='fu'><a href='https://dplyr.tidyverse.org/reference/across.html'>across</a></span><span class='op'>(</span><span class='va'>AMP</span><span class='op'>:</span><span class='va'>TOB</span>, <span class='va'>as.rsi</span><span class='op'>)</span><span class='op'>)</span>
@ -498,7 +498,7 @@ The <a href='lifecycle.html'>lifecycle</a> of this function is <strong>stable</s
<span class='co'># note: from dplyr 1.0.0 on, this will be: </span>
<span class='co'># example_isolates %&gt;%</span>
<span class='co'># mutate(across((is.rsi.eligible), as.rsi))</span>
<span class='co'># mutate(across(where(is.rsi.eligible), as.rsi))</span>
<span class='op'>}</span>
<span class='co'># }</span>
</pre>

2
docs/reference/index.html
View File

@ -81,7 +81,7 @@
</button>
<span class="navbar-brand">
<a class="navbar-link" href="../index.html">AMR (for R)</a>
<span class="version label label-default" data-toggle="tooltip" data-placement="bottom" title="Latest development version">1.6.0.9021</span>
<span class="version label label-default" data-toggle="tooltip" data-placement="bottom" title="Latest development version">1.6.0.9022</span>
</span>
</div>

2
docs/survey.html
View File

@ -81,7 +81,7 @@
</button>
<span class="navbar-brand">
<a class="navbar-link" href="index.html">AMR (for R)</a>
<span class="version label label-default" data-toggle="tooltip" data-placement="bottom" title="Latest development version">1.6.0.9021</span>
<span class="version label label-default" data-toggle="tooltip" data-placement="bottom" title="Latest development version">1.6.0.9022</span>
</span>
</div>

4
man/as.rsi.Rd
View File

@ -195,7 +195,7 @@ as.rsi(x = as.disk(18),
if (require("dplyr")) {
df \%>\% mutate_if(is.mic, as.rsi)
df \%>\% mutate_if(function(x) is.mic(x) | is.disk(x), as.rsi)
df \%>\% mutate(across((is.mic), as.rsi))
df \%>\% mutate(across(where(is.mic), as.rsi))
df \%>\% mutate_at(vars(AMP:TOB), as.rsi)
df \%>\% mutate(across(AMP:TOB, as.rsi))
@ -240,7 +240,7 @@ if (require("dplyr")) {
# note: from dplyr 1.0.0 on, this will be:
# example_isolates \%>\%
# mutate(across((is.rsi.eligible), as.rsi))
# mutate(across(where(is.rsi.eligible), as.rsi))
}
}
}

5
tests/testthat/test-eucast_rules.R
View File

@ -77,7 +77,7 @@ test_that("EUCAST rules work", {
expect_equal(suppressWarnings(eucast_rules(a, "mo", info = FALSE)), b)
# piperacillin must be R in Enterobacteriaceae when tica is R
library(dplyr, warn.conflicts = FALSE)
if (require("dplyr")) {
expect_equal(suppressWarnings(
example_isolates %>%
filter(mo_family(mo) == "Enterobacteriaceae") %>%
@ -88,6 +88,7 @@ test_that("EUCAST rules work", {
unique() %>%
as.character()),
"R")
}
# Azithromycin and Clarythromycin must be equal to Erythromycin
a <- suppressWarnings(as.rsi(eucast_rules(data.frame(mo = example_isolates$mo,
@ -114,7 +115,9 @@ test_that("EUCAST rules work", {
"S")
# also test norf
if (require("dplyr")) {
expect_output(suppressWarnings(eucast_rules(example_isolates %>% mutate(NOR = "S", NAL = "S"), info = TRUE)))
}
# check verbose output
expect_output(suppressWarnings(eucast_rules(example_isolates, verbose = TRUE, rules = "all", info = TRUE)))