1
0
mirror of https://github.com/msberends/AMR.git synced 2024-12-25 17:26:12 +01:00

pm update, unit test fix?

This commit is contained in:
dr. M.S. (Matthijs) Berends 2023-02-08 13:48:06 +01:00
parent 4a54d59f70
commit 822e9de82c
13 changed files with 2118 additions and 720 deletions

View File

@ -1,6 +1,6 @@
Package: AMR Package: AMR
Version: 1.8.2.9109 Version: 1.8.2.9110
Date: 2023-02-06 Date: 2023-02-08
Title: Antimicrobial Resistance Data Analysis Title: Antimicrobial Resistance Data Analysis
Description: Functions to simplify and standardise antimicrobial resistance (AMR) Description: Functions to simplify and standardise antimicrobial resistance (AMR)
data analysis and to work with microbial and antimicrobial properties by data analysis and to work with microbial and antimicrobial properties by

View File

@ -1,4 +1,4 @@
# AMR 1.8.2.9109 # AMR 1.8.2.9110
*(this beta version will eventually become v2.0! We're happy to reach a new major milestone soon!)* *(this beta version will eventually become v2.0! We're happy to reach a new major milestone soon!)*

1739
R/aa_helper_pm_functions.R Executable file → Normal file

File diff suppressed because it is too large Load Diff

View File

@ -1425,13 +1425,15 @@ case_when <- function(...) {
} }
# dplyr implementations ---- # dplyr/tidyr implementations ----
# take {dplyr} functions if available, and the slower {poorman} functions otherwise # take {dplyr} and {tidyr} functions if available, and the slower {poorman} functions otherwise
if (pkg_is_available("dplyr", also_load = FALSE)) { if (pkg_is_available("dplyr", min_version = "1.0.0", also_load = FALSE)) {
`%>%` <- import_fn("%>%", "dplyr", error_on_fail = FALSE) `%>%` <- import_fn("%>%", "dplyr", error_on_fail = FALSE)
across <- import_fn("across", "dplyr", error_on_fail = FALSE)
anti_join <- import_fn("anti_join", "dplyr", error_on_fail = FALSE) anti_join <- import_fn("anti_join", "dplyr", error_on_fail = FALSE)
arrange <- import_fn("arrange", "dplyr", error_on_fail = FALSE) arrange <- import_fn("arrange", "dplyr", error_on_fail = FALSE)
bind_rows <- import_fn("bind_rows", "dplyr", error_on_fail = FALSE)
count <- import_fn("count", "dplyr", error_on_fail = FALSE) count <- import_fn("count", "dplyr", error_on_fail = FALSE)
desc <- import_fn("desc", "dplyr", error_on_fail = FALSE) desc <- import_fn("desc", "dplyr", error_on_fail = FALSE)
distinct <- import_fn("distinct", "dplyr", error_on_fail = FALSE) distinct <- import_fn("distinct", "dplyr", error_on_fail = FALSE)
@ -1443,22 +1445,22 @@ if (pkg_is_available("dplyr", also_load = FALSE)) {
inner_join <- import_fn("inner_join", "dplyr", error_on_fail = FALSE) inner_join <- import_fn("inner_join", "dplyr", error_on_fail = FALSE)
lag <- import_fn("lag", "dplyr", error_on_fail = FALSE) lag <- import_fn("lag", "dplyr", error_on_fail = FALSE)
left_join <- import_fn("left_join", "dplyr", error_on_fail = FALSE) left_join <- import_fn("left_join", "dplyr", error_on_fail = FALSE)
mutate <- import_fn("mutate", "dplyr", error_on_fail = FALSE)
n_distinct <- import_fn("n_distinct", "dplyr", error_on_fail = FALSE) n_distinct <- import_fn("n_distinct", "dplyr", error_on_fail = FALSE)
pull <- import_fn("pull", "dplyr", error_on_fail = FALSE) pull <- import_fn("pull", "dplyr", error_on_fail = FALSE)
rename <- import_fn("rename", "dplyr", error_on_fail = FALSE) rename <- import_fn("rename", "dplyr", error_on_fail = FALSE)
right_join <- import_fn("right_join", "dplyr", error_on_fail = FALSE) right_join <- import_fn("right_join", "dplyr", error_on_fail = FALSE)
row_number <- import_fn("row_number", "dplyr", error_on_fail = FALSE)
select <- import_fn("select", "dplyr", error_on_fail = FALSE) select <- import_fn("select", "dplyr", error_on_fail = FALSE)
semi_join <- import_fn("semi_join", "dplyr", error_on_fail = FALSE) semi_join <- import_fn("semi_join", "dplyr", error_on_fail = FALSE)
summarise <- import_fn("summarise", "dplyr", error_on_fail = FALSE) summarise <- import_fn("summarise", "dplyr", error_on_fail = FALSE)
ungroup <- import_fn("ungroup", "dplyr", error_on_fail = FALSE) ungroup <- import_fn("ungroup", "dplyr", error_on_fail = FALSE)
mutate <- import_fn("mutate", "dplyr", error_on_fail = FALSE)
bind_rows <- import_fn("bind_rows", "dplyr", error_on_fail = FALSE)
where <- import_fn("where", "dplyr", error_on_fail = FALSE) where <- import_fn("where", "dplyr", error_on_fail = FALSE)
} else { } else {
`%>%` <- `%pm>%` `%>%` <- `%pm>%`
across <- pm_across
anti_join <- pm_anti_join anti_join <- pm_anti_join
arrange <- pm_arrange arrange <- pm_arrange
bind_rows <- pm_bind_rows
count <- pm_count count <- pm_count
desc <- pm_desc desc <- pm_desc
distinct <- pm_distinct distinct <- pm_distinct
@ -1470,62 +1472,22 @@ if (pkg_is_available("dplyr", also_load = FALSE)) {
inner_join <- pm_inner_join inner_join <- pm_inner_join
lag <- pm_lag lag <- pm_lag
left_join <- pm_left_join left_join <- pm_left_join
mutate <- pm_mutate
n_distinct <- pm_n_distinct n_distinct <- pm_n_distinct
pull <- pm_pull pull <- pm_pull
rename <- pm_rename rename <- pm_rename
right_join <- pm_right_join right_join <- pm_right_join
row_number <- pm_row_number
select <- pm_select select <- pm_select
semi_join <- pm_semi_join semi_join <- pm_semi_join
summarise <- pm_summarise summarise <- pm_summarise
ungroup <- pm_ungroup ungroup <- pm_ungroup
mutate <- function(.data, ...) { where <- pm_where
# pm_mutate is buggy, use this simple alternative }
dots <- list(...) if (pkg_is_available("tidyr", min_version = "1.0.0", also_load = FALSE)) {
for (i in seq_len(length(dots))) { pivot_longer <- import_fn("pivot_longer", "tidyr", error_on_fail = FALSE)
.data[, names(dots)[i]] <- dots[[i]] } else {
} pivot_longer <- pm_pivot_longer
.data
}
bind_rows <- function(..., fill = NA) {
# this AMAZING code is from ChatGPT when I asked for a base R dplyr::bind_rows alternative
dfs <- list(...)
all_cols <- unique(unlist(lapply(dfs, colnames)))
mat_list <- lapply(dfs, function(x) {
mat <- matrix(NA, nrow = nrow(x), ncol = length(all_cols))
colnames(mat) <- all_cols
mat[, colnames(x)] <- as.matrix(x)
mat
})
mat <- do.call(rbind, mat_list)
as.data.frame(mat, stringsAsFactors = FALSE)
}
where <- function(fn) {
# adapted from https://github.com/nathaneastwood/poorman/blob/52eb6947e0b4430cd588976ed8820013eddf955f/R/where.R#L17-L32
if (!is.function(fn)) {
stop_("`", deparse(substitute(fn)), "()` is not a valid predicate function.")
}
df <- pm_select_env$.data
cols <- pm_select_env$get_colnames()
if (is.null(df)) {
df <- get_current_data("where", call = FALSE)
cols <- colnames(df)
}
preds <- unlist(lapply(
df,
function(x, fn) {
do.call("fn", list(x))
},
fn
))
if (!is.logical(preds)) stop_("`where()` must be used with functions that return `TRUE` or `FALSE`.")
data_cols <- cols
cols <- data_cols[preds]
which(data_cols %in% cols)
}
} }
# Faster data.table implementations ---- # Faster data.table implementations ----

View File

@ -49,7 +49,6 @@
#' @return (internally) a [character] vector of column names, with additional class `"ab_selector"` #' @return (internally) a [character] vector of column names, with additional class `"ab_selector"`
#' @export #' @export
#' @inheritSection AMR Reference Data Publicly Available #' @inheritSection AMR Reference Data Publicly Available
#' @examples #' @examples
#' # `example_isolates` is a data set available in the AMR package. #' # `example_isolates` is a data set available in the AMR package.
#' # See ?example_isolates. #' # See ?example_isolates.

View File

@ -85,10 +85,7 @@ bug_drug_combinations <- function(x,
} }
# use dplyr and tidyr if they are available, they are much faster! # use dplyr and tidyr if they are available, they are much faster!
if (pkg_is_available("dplyr", min_version = "1.0.0", also_load = FALSE) && if (identical(pivot_longer, import_fn("pivot_longer", "tidyr", error_on_fail = FALSE))) {
pkg_is_available("tidyr", min_version = "1.0.0", also_load = FALSE)) {
across <- import_fn("across", "dplyr")
pivot_longer <- import_fn("pivot_longer", "tidyr")
out <- x %>% out <- x %>%
ungroup() %>% ungroup() %>%
mutate(mo = FUN(ungroup(x)[, col_mo, drop = TRUE], ...)) %>% mutate(mo = FUN(ungroup(x)[, col_mo, drop = TRUE], ...)) %>%

View File

@ -926,7 +926,7 @@ eucast_rules <- function(x,
# Print overview ---------------------------------------------------------- # Print overview ----------------------------------------------------------
if (isTRUE(info) || isTRUE(verbose)) { if (isTRUE(info) || isTRUE(verbose)) {
verbose_info <- x.bak %>% verbose_info <- x.bak %>%
mutate(row = row_number()) %>% mutate(row = seq_len(NROW(x.bak))) %>%
select(`.rowid`, row) %>% select(`.rowid`, row) %>%
right_join(verbose_info, right_join(verbose_info,
by = c(".rowid" = "rowid") by = c(".rowid" = "rowid")

62
data-raw/antibiograms.Rmd Normal file
View File

@ -0,0 +1,62 @@
---
title: "Generating antibiograms with the AMR package"
author: "AMR package developers"
date: "`r Sys.Date()`"
output: html_document
---
```{r setup, include=FALSE}
knitr::opts_chunk$set(echo = TRUE, message = FALSE)
library(AMR)
```
This is an example R Markdown file to show the use of `antibiogram()` of the AMR package.
For starters, this is what our `example_isolates` data set looks like:
```{r}
example_isolates
```
### Traditional Antibiogram
```{r trad}
print(
antibiogram(example_isolates,
antibiotics = c(aminoglycosides(), carbapenems()))
)
```
### Combined Antibiogram
```{r comb}
print(
antibiogram(example_isolates,
antibiotics = c("TZP", "TZP+TOB", "TZP+GEN"))
)
```
### Syndromic Antibiogram
```{r synd}
print(
antibiogram(example_isolates,
antibiotics = c(aminoglycosides(), carbapenems()),
syndromic_group = "ward")
)
```
### Weighted-Incidence Syndromic Combination Antibiogram (WISCA)
```{r wisca}
print(
antibiogram(example_isolates,
antibiotics = c("AMC", "AMC+CIP", "TZP", "TZP+TOB"),
mo_transform = "gramstain",
minimum = 10, # this should be >= 30, but now just as example
syndromic_group = ifelse(example_isolates$age >= 65 &
example_isolates$gender == "M",
"WISCA Group 1", "WISCA Group 2"))
)
```

848
data-raw/antibiograms.html Normal file

File diff suppressed because one or more lines are too long

View File

@ -32,11 +32,11 @@
# Source file: data-raw/reproduction_of_poorman.R # Source file: data-raw/reproduction_of_poorman.R
# ------------------------------------------------ # ------------------------------------------------
# poorman: a package to replace all dplyr functions with base R so we can lose dependency on dplyr. # {poorman}: a package to replace all dplyr functions with base R so we can lose dependency on {dplyr}.
# These functions were downloaded from https://github.com/nathaneastwood/poorman, # These functions were downloaded from https://github.com/nathaneastwood/poorman,
# from this commit: https://github.com/nathaneastwood/poorman/tree/{commit}. # from this commit: https://github.com/nathaneastwood/poorman/tree/{commit}.
# #
# All functions are prefixed with 'pm_' to make it obvious that they are dplyr substitutes. # All functions are prefixed with 'pm_' to make it obvious that they are {dplyr} substitutes.
# #
# All code below was released under MIT license, that permits 'free of charge, to any person obtaining a # All code below was released under MIT license, that permits 'free of charge, to any person obtaining a
# copy of the software and associated documentation files (the "Software"), to deal in the Software # copy of the software and associated documentation files (the "Software"), to deal in the Software

View File

@ -1,22 +1,28 @@
# get complete filenames of all R files in the GitHub repository of nathaneastwood/poorman # get complete filenames of all R files in the GitHub repository of nathaneastwood/poorman
commit <- "52eb6947e0b4430cd588976ed8820013eddf955f" library(magrittr)
commit <- "3cc0a9920b1eb559dd166f548561244189586b3a"
files <- xml2::read_html(paste0("https://github.com/nathaneastwood/poorman/tree/", commit, "/R")) %>% files <- xml2::read_html(paste0("https://github.com/nathaneastwood/poorman/tree/", commit, "/R")) %>%
rvest::html_nodes("a") %>% rvest::html_nodes("a") %>%
rvest::html_attr("href") rvest::html_attr("href")
files <- files[files %like% "/blob/.*R$"]
# get full URLs of all raw R files # get full URLs of all raw R files
files <- sort(paste0("https://raw.githubusercontent.com", gsub("blob/", "", files[files %like% "/R/.*.R$"]))) files <- sort(paste0("https://raw.githubusercontent.com", gsub("blob/", "", files[files %like% "/R/.*.R$"])))
# remove files with only pkg specific code # remove files with only pkg specific code
files <- files[files %unlike% "(zzz|init)[.]R$"] files <- files[files %unlike% "(zzz|init)[.]R$"]
# also, there's a lot of functions we don't use # also, there's a lot of functions we don't use
files <- files[files %unlike% "(slice|glimpse|recode|replace_na|coalesce)[.]R$"] files <- files[files %unlike% "/(between|coalesce|cumulative|fill|glimpse|gluestick|group_cols|na_if|near|nest_by|poorman-package|print|recode|reconstruct|replace_na|replace_with|rownames|slice|union_all|unite|window_rank|with_groups)[.]R$"]
# add our prepend file, containing info about the source of the data # add our prepend file, containing info about the source of the data
intro <- readLines("data-raw/poorman_prepend.R") intro <- readLines("data-raw/poorman_prepend.R") %>%
# add commit to intro part
gsub("{commit}", commit, ., fixed = TRUE) %>%
# add date to intro part
gsub("{date}", trimws(format(Sys.Date(), "%e %B %Y")), ., fixed = TRUE)
# copyright info: # copyright info:
copyright <- paste0("# ", readLines("https://raw.githubusercontent.com/nathaneastwood/poorman/master/LICENSE")) copyright <- paste0("# ", readLines(paste0("https://raw.githubusercontent.com/nathaneastwood/poorman/", commit, "/LICENSE")))
# read all contents to a character vector # read all contents to a character vector
contents <- character(0) contents <- character(0)
@ -25,31 +31,35 @@ sapply(files, function(file) {
contents <<- c(contents, readLines(file)) contents <<- c(contents, readLines(file))
invisible() invisible()
}) })
contents <- c(
intro,
copyright,
"",
contents
)
# remove lines starting with "#'" and NULL and write to file # remove lines starting with "#'" and NULL and write to file
contents <- contents[!grepl("^(#'|NULL|\"_PACKAGE)", contents)] contents <- contents[!grepl("^(#'|NULL|\"_PACKAGE)", contents)]
contents.bak <- contents
# grouped attributes same as dplyr
contents <- gsub("grouped_data", "grouped_df", contents, fixed = TRUE)
# now make it independent on UseMethod, since we will not export these functions # now make it independent on UseMethod, since we will not export these functions
contents <- gsub('UseMethod[(]"(.*?)"[)]', has_usemethods <- gsub("^([a-z_]+).*", "\\1", contents[which(contents %like% "usemethod") - 1])
'if ("grouped_data" %in% class(.data)) {||| \\1.grouped_data(.data, ...)||| } else {||| \\1.default(.data, ...)||| }', for (use in has_usemethods) {
paste(contents, collapse = "|||"), relevant_row <- which(contents %like% paste0("^", use, " <- function")) + 1
perl = TRUE function_call <- trimws(gsub(".*function(.*)\\{.*", "\\1", contents[relevant_row - 1]))
) %>% function_call1 <- trimws(gsub("[()]", "", strsplit(function_call, ",")[[1]][1]))
# add commit to intro part if (any(contents %like% paste0(use, ".grouped_df"))) {
gsub("{commit}", commit, ., fixed = TRUE) %>% # this function will have methods for data.frame and grouped_df
# add date to intro part contents[relevant_row] <- paste0(" if (\"grouped_df\" %in% class(", function_call1, ")) ", use, ".grouped_df", function_call, " else ", use, ".data.frame", function_call)
gsub("{date}", format(Sys.Date(), "%e %B %Y"), ., fixed = TRUE) %>% } else {
strsplit(split = "|||", fixed = TRUE) %>% # this function will only have data.frame as method
unlist() %>% contents[relevant_row] <- paste0(" ", use, ".data.frame", function_call)
# add "pm_" as prefix to all functions }
gsub("^([a-z_.]+) <- function", "pm_\\1 <- function", .) # add pm_ prefix
contents[relevant_row - 1] <- paste0("pm_", contents[relevant_row - 1])
}
# correct for NextMethod
contents <- gsub("NextMethod\\(\"(.*)\"\\)", "\\1.data.frame(...)", contents)
# correct for 'default' method
contents <- gsub(".default <-", ".data.frame <-", contents, fixed = TRUE)
contents <- gsub("pm_group_by_drop.data.frame", "pm_group_by_drop", contents, fixed = TRUE)
# now get all those pm_* functions to replace all untransformed function name calls as well # now get all those pm_* functions to replace all untransformed function name calls as well
new_pm_names <- sort(gsub("pm_(.*?) <-.*", "\\1", contents[grepl("^pm_", contents)])) new_pm_names <- sort(gsub("pm_(.*?) <-.*", "\\1", contents[grepl("^pm_", contents)]))
for (i in seq_len(length(new_pm_names))) { for (i in seq_len(length(new_pm_names))) {
@ -57,29 +67,39 @@ for (i in seq_len(length(new_pm_names))) {
# starting with a space or a straight bracket or an opening parenthesis, ending with nothing or a non-character or a closing parenthesis # starting with a space or a straight bracket or an opening parenthesis, ending with nothing or a non-character or a closing parenthesis
contents <- gsub(paste0("( |\\[|\\()", new_pm_names[i], "($|[^a-z]|\\))"), paste0("\\1pm_", new_pm_names[i], "\\2"), contents) contents <- gsub(paste0("( |\\[|\\()", new_pm_names[i], "($|[^a-z]|\\))"), paste0("\\1pm_", new_pm_names[i], "\\2"), contents)
} }
# replace %>% with %pm>% # replace %>% with %pm>%
contents[which(contents %like% "^\\|\\|") - 1] <- paste0(contents[which(contents %like% "^\\|\\|") - 1], " ||")
contents[which(contents %like% "^\\|\\|")] <- gsub("^\\|\\|", "", contents[which(contents %like% "^\\|\\|")])
contents <- gsub("%>%", "%pm>%", contents, fixed = TRUE) contents <- gsub("%>%", "%pm>%", contents, fixed = TRUE)
# fix for new lines, since n() also existed # fix for new lines, since n() also existed
contents <- gsub("\\pm_n", "\\n", contents, fixed = TRUE) contents <- gsub("\\pm_n", "\\n", contents, fixed = TRUE)
# prefix other functions also with "pm_" # prefix other functions also with "pm_"
contents <- gsub("^([a-z_]+)(\\$|)", "pm_\\1\\2", contents) contents <- gsub("^([a-z_]+)(\\$|)", "pm_\\1\\2", contents)
# prefix environments # prefix environmental objects and functions
contents <- gsub("eval_env", "pm_eval_env", contents, fixed = TRUE) contents <- gsub("(eval_env|select_env|select_context|context|dotdotdot|as_symbols|insert_dot|deparse_|groups_set|apply_grouped_function|split_into_groups|calculate_groups|has_groups|eval_select_pos|select_positions|eval_expr|eval_call|add_group_columns|find_used|is_nested|setup_|select_|group_)", "pm_\\1", contents)
contents <- gsub("select_env", "pm_select_env", contents, fixed = TRUE)
contents <- gsub("context", "pm_context", contents, fixed = TRUE)
# now some items are overprefixed # now some items are overprefixed
contents <- gsub("(pm_)+", "pm_", contents) contents <- gsub("(pm_)+", "pm_", contents)
# special case for pm_distinct(), we need '.keep_all' to work contents <- gsub("pm_if (\"grouped_df", "if (\"grouped_df", contents, fixed = TRUE)
contents <- gsub("pm_distinct <- function(.data, ..., .keep_all = FALSE)", "pm_distinct <- function(.data, ...)", contents, fixed = TRUE) # remove comments and empty lines
# pm_pull does not correct for tibbles, misses the drop argument contents <- gsub("#.*", "", contents)
contents[contents == ".data[, var]"] <- ".data[, var, drop = TRUE]" contents <- contents[trimws(contents) != ""]
# fix for their relocate()
contents <- gsub("if (!missing(.before))", "if (!missing(.before) && !is.null(.before))", contents, fixed = TRUE)
contents <- gsub("if (!missing(.after))", "if (!missing(.after) && !is.null(.after))", contents, fixed = TRUE)
contents[which(contents %like% "reshape\\($") + 1] <- gsub("data", "as.data.frame(data, stringsAsFactors = FALSE)", contents[which(contents %like% "reshape\\($") + 1])
contents <- gsub('pm_relocate(.data = long, values_to, .after = -1)', 'pm_relocate(.data = long, "value", .after = -1)', contents, fixed = TRUE)
# who needs US spelling? # who needs US spelling?
contents <- contents[!grepl("summarize", contents)] contents <- contents[contents %unlike% "summarize"]
# add intro
contents <- c(
intro,
copyright,
"",
contents
)
writeLines(contents, "R/aa_helper_pm_functions.R") writeLines(contents, "R/aa_helper_pm_functions.R")
# after this, comment out: # note: pm_left_join() will be overwritten by aaa_helper_functions.R, which contains a faster implementation
# pm_left_join() since we use a faster version
# pm_group_split() since we don't use it and it relies on R 3.5.0 for the use of ...length(), which is hard to support without C++ code

View File

@ -68,7 +68,6 @@ import_functions <- c(
"read_html" = "xml2", "read_html" = "xml2",
"rename" = "dplyr", "rename" = "dplyr",
"right_join" = "dplyr", "right_join" = "dplyr",
"row_number" = "dplyr",
"select" = "dplyr", "select" = "dplyr",
"semi_join" = "dplyr", "semi_join" = "dplyr",
"showQuestion" = "rstudioapi", "showQuestion" = "rstudioapi",

View File

@ -40,11 +40,9 @@ if (tryCatch(isTRUE(AMR:::import_fn("isJob", "rstudioapi")()), error = function(
if (AMR:::pkg_is_available("tinytest", also_load = TRUE)) { if (AMR:::pkg_is_available("tinytest", also_load = TRUE)) {
library(AMR) library(AMR)
if (identical(AMR:::import_fn("select", "dplyr"), AMR:::select)) { if (identical(AMR:::import_fn("select", "dplyr"), AMR:::select)) {
print("This test will rely on {dplyr} verbs") message("\n\n------------------------------------\nThis test will rely on {dplyr} verbs\n------------------------------------\n\n")
message("This test will rely on {dplyr} verbs")
} else { } else {
print("This test will rely on {poorman} verbs") message("\n\n---------------------------------------------------------------------\nThis test will rely on {poorman} verbs (installed state dplyr: ", AMR:::pkg_is_available("dplyr", also_load = FALSE), ")\n---------------------------------------------------------------------\n\n")
message("This test will rely on {poorman} verbs")
} }
# set language # set language
set_AMR_locale("English") set_AMR_locale("English")