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

bind_rows

Browse Source
This commit is contained in:
dr. M.S. (Matthijs) Berends 2023-02-10 17:09:48 +01:00
parent 03294c7901
commit 2007c3eef3
15 changed files with 48 additions and 31 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
DESCRIPTION
View File

@ -1,5 +1,5 @@
Package: AMR
Version: 1.8.2.9115
Version: 1.8.2.9116
Date: 2023-02-10
Title: Antimicrobial Resistance Data Analysis
Description: Functions to simplify and standardise antimicrobial resistance (AMR)

2
NEWS.md
View File

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

1
R/aa_globals.R
View File

@ -107,7 +107,6 @@ globalVariables(c(
"atc_group1",
"atc_group2",
"base_ab",
"bind_rows",
"ci_max",
"ci_min",
"clinical_breakpoints",

30
R/aa_helper_functions.R
View File

@ -64,20 +64,26 @@ pm_left_join <- function(x, y, by = NULL, suffix = c(".x", ".y")) {
}
# support where() like tidyverse:
# adapted from https://github.com/nathaneastwood/poorman/blob/52eb6947e0b4430cd588976ed8820013eddf955f/R/where.R#L17-L32
where <- function(fn) {
# adapted from https://github.com/nathaneastwood/poorman/blob/52eb6947e0b4430cd588976ed8820013eddf955f/R/where.R#L17-L32
if (!is.function(fn)) {
stop(pm_deparse_var(fn), " is not a valid predicate function.")
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(
pm_select_env$.data,
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 <- pm_select_env$get_colnames()
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)
}
@ -156,6 +162,20 @@ quick_case_when <- function(...) {
out
}
bind_rows2 <- 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)
}
# No export, no Rd
addin_insert_in <- function() {
import_fn("insertText", "rstudioapi")(" %in% ")

2
R/ab.R
View File

@ -495,7 +495,7 @@ as.ab <- function(x, flag_multiple_results = TRUE, info = interactive(), ...) {
# save to package env to save time for next time
if (isTRUE(initial_search)) {
AMR_env$ab_previously_coerced <- AMR_env$ab_previously_coerced[which(!AMR_env$ab_previously_coerced$x %in% x), , drop = FALSE]
AMR_env$ab_previously_coerced <- unique(rbind(AMR_env$ab_previously_coerced,
AMR_env$ab_previously_coerced <- unique(bind_rows2(AMR_env$ab_previously_coerced,
data.frame(
x = x,
ab = x_new,

4
R/antibiogram.R
View File

@ -404,8 +404,8 @@ antibiogram <- function(x,
if (i == 1) {
new_df <- long_to_wide(out[which(out$syndromic_group == grp), , drop = FALSE], digs = digits)
} else {
new_df <- bind_rows(new_df,
long_to_wide(out[which(out$syndromic_group == grp), , drop = FALSE], digs = digits))
new_df <- bind_rows2(new_df,
long_to_wide(out[which(out$syndromic_group == grp), , drop = FALSE], digs = digits))
}
}
# sort rows

2
R/av.R
View File

@ -461,7 +461,7 @@ as.av <- function(x, flag_multiple_results = TRUE, info = interactive(), ...) {
# save to package env to save time for next time
if (isTRUE(initial_search)) {
AMR_env$av_previously_coerced <- AMR_env$av_previously_coerced[which(!AMR_env$av_previously_coerced$x %in% x), , drop = FALSE]
AMR_env$av_previously_coerced <- unique(rbind(AMR_env$av_previously_coerced,
AMR_env$av_previously_coerced <- unique(bind_rows2(AMR_env$av_previously_coerced,
data.frame(
x = x,
av = x_new,

6
R/bug_drug_combinations.R
View File

@ -124,7 +124,7 @@ bug_drug_combinations <- function(x,
m <- as.matrix(table(x))
data.frame(S = m["S", ], I = m["I", ], R = m["R", ], stringsAsFactors = FALSE)
})
merged <- do.call(rbind, pivot)
merged <- do.call(bind_rows2, pivot)
out_group <- data.frame(
mo = rep(unique_mo[i], NROW(merged)),
ab = rownames(merged),
@ -144,14 +144,14 @@ bug_drug_combinations <- function(x,
}
out_group <- cbind(group_values, out_group)
}
out <- rbind(out, out_group, stringsAsFactors = FALSE)
out <- bind_rows2(out, out_group)
}
out
}
# based on pm_apply_grouped_function
apply_group <- function(.data, fn, groups, drop = FALSE, ...) {
grouped <- pm_split_into_groups(.data, groups, drop)
res <- do.call(rbind, unname(lapply(grouped, fn, ...)))
res <- do.call(bind_rows2, unname(lapply(grouped, fn, ...)))
if (any(groups %in% colnames(res))) {
class(res) <- c("grouped_data", class(res))
res <- pm_set_groups(res, groups[groups %in% colnames(res)])

2
R/custom_antimicrobials.R
View File

@ -153,7 +153,7 @@ add_custom_antimicrobials <- function(x) {
# assign new values
new_df[, col] <- x[, col, drop = TRUE]
}
AMR_env$AB_lookup <- unique(rbind(AMR_env$AB_lookup, new_df))
AMR_env$AB_lookup <- unique(bind_rows2(AMR_env$AB_lookup, new_df))
AMR_env$ab_previously_coerced <- AMR_env$ab_previously_coerced[which(!AMR_env$ab_previously_coerced$ab %in% x$ab), , drop = FALSE]
class(AMR_env$AB_lookup$ab) <- c("ab", "character")

2
R/custom_microorganisms.R
View File

@ -279,7 +279,7 @@ add_custom_microorganisms <- function(x) {
# clear previous coercions
suppressMessages(mo_reset_session())
AMR_env$MO_lookup <- unique(rbind(AMR_env$MO_lookup, new_df))
AMR_env$MO_lookup <- unique(bind_rows2(AMR_env$MO_lookup, new_df))
class(AMR_env$MO_lookup$mo) <- c("mo", "character")
if (nrow(x) <= 3) {
message_("Added ", vector_and(italicise(x$fullname), quotes = FALSE), " to the internal `microorganisms` data set.")

10
R/eucast_rules.R
View File

@ -475,7 +475,7 @@ eucast_rules <- function(x,
amox$base_ab <- "AMX"
amox$base_name <- ab_name("AMX", language = NULL)
# merge and sort
ab_enzyme <- rbind(ab_enzyme, ampi, amox)
ab_enzyme <- bind_rows2(ab_enzyme, ampi, amox)
ab_enzyme <- ab_enzyme[order(ab_enzyme$enzyme_name), , drop = FALSE]
for (i in seq_len(nrow(ab_enzyme))) {
@ -1161,10 +1161,8 @@ edit_sir <- function(x,
)
verbose_new <- verbose_new %pm>% pm_filter(old != new | is.na(old) | is.na(new) & !is.na(old))
# save changes to data set 'verbose_info'
track_changes$verbose_info <- rbind(track_changes$verbose_info,
verbose_new,
stringsAsFactors = FALSE
)
track_changes$verbose_info <- bind_rows2(track_changes$verbose_info,
verbose_new)
# count adds and changes
track_changes$added <- track_changes$added + verbose_new %pm>%
pm_filter(is.na(old)) %pm>%
@ -1215,7 +1213,7 @@ eucast_dosage <- function(ab, administration = "iv", version_breakpoints = 12.0)
)
)
}
out <- do.call("rbind", lapply(lst, as.data.frame, stringsAsFactors = FALSE))
out <- do.call("bind_rows2", lapply(lst, as.data.frame, stringsAsFactors = FALSE))
rownames(out) <- NULL
out$ab <- ab
out$name <- ab_name(ab, language = NULL)

4
R/mo.R
View File

@ -325,7 +325,7 @@ as.mo <- function(x,
result_mo <- NA_character_
} else {
result_mo <- AMR_env$MO_lookup$mo[match(top_hits[1], AMR_env$MO_lookup$fullname)]
AMR_env$mo_uncertainties <- rbind(AMR_env$mo_uncertainties,
AMR_env$mo_uncertainties <- bind_rows2(AMR_env$mo_uncertainties,
data.frame(
original_input = x_search,
input = x_search_cleaned,
@ -339,7 +339,7 @@ as.mo <- function(x,
stringsAsFactors = FALSE
)
# save to package env to save time for next time
AMR_env$mo_previously_coerced <- unique(rbind(AMR_env$mo_previously_coerced,
AMR_env$mo_previously_coerced <- unique(bind_rows2(AMR_env$mo_previously_coerced,
data.frame(
x = paste(x_search, minimum_matching_score),
mo = result_mo,

6
R/plot.R
View File

@ -585,17 +585,17 @@ plot.sir <- function(x,
data$s <- round((data$n / sum(data$n)) * 100, 1)
if (!"S" %in% data$x) {
data <- rbind(data, data.frame(x = "S", n = 0, s = 0, stringsAsFactors = FALSE),
data <- bind_rows2(data, data.frame(x = "S", n = 0, s = 0, stringsAsFactors = FALSE),
stringsAsFactors = FALSE
)
}
if (!"I" %in% data$x) {
data <- rbind(data, data.frame(x = "I", n = 0, s = 0, stringsAsFactors = FALSE),
data <- bind_rows2(data, data.frame(x = "I", n = 0, s = 0, stringsAsFactors = FALSE),
stringsAsFactors = FALSE
)
}
if (!"R" %in% data$x) {
data <- rbind(data, data.frame(x = "R", n = 0, s = 0, stringsAsFactors = FALSE),
data <- bind_rows2(data, data.frame(x = "R", n = 0, s = 0, stringsAsFactors = FALSE),
stringsAsFactors = FALSE
)
}

2
R/sir.R
View File

@ -998,7 +998,7 @@ as_sir_method <- function(method_short,
}
# write to verbose output
AMR_env$sir_interpretation_history <- rbind(
AMR_env$sir_interpretation_history <- bind_rows2(
AMR_env$sir_interpretation_history,
# recycling 1 to 2 rows does not seem to work, which is why rep() was added
data.frame(

4
R/sir_calc.R
View File

@ -322,7 +322,7 @@ sir_calc_df <- function(type, # "proportion", "count" or "both"
}
out_new <- cbind(group_values, out_new)
}
out <- rbind(out, out_new, stringsAsFactors = FALSE)
out <- bind_rows2(out, out_new)
}
}
out
@ -331,7 +331,7 @@ sir_calc_df <- function(type, # "proportion", "count" or "both"
# based on pm_apply_grouped_function
apply_group <- function(.data, fn, groups, drop = FALSE, ...) {
grouped <- pm_split_into_groups(.data, groups, drop)
res <- do.call(rbind, unname(lapply(grouped, fn, ...)))
res <- do.call(bind_rows2, unname(lapply(grouped, fn, ...)))
if (any(groups %in% colnames(res))) {
class(res) <- c("grouped_data", class(res))
res <- pm_set_groups(res, groups[groups %in% colnames(res)])