mirror of
https://github.com/msberends/AMR.git
synced 2024-12-25 06:06:12 +01:00
bind_rows
This commit is contained in:
parent
03294c7901
commit
2007c3eef3
@ -1,5 +1,5 @@
|
|||||||
Package: AMR
|
Package: AMR
|
||||||
Version: 1.8.2.9115
|
Version: 1.8.2.9116
|
||||||
Date: 2023-02-10
|
Date: 2023-02-10
|
||||||
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)
|
||||||
|
2
NEWS.md
2
NEWS.md
@ -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!)*
|
*(this beta version will eventually become v2.0! We're happy to reach a new major milestone soon!)*
|
||||||
|
|
||||||
|
@ -107,7 +107,6 @@ globalVariables(c(
|
|||||||
"atc_group1",
|
"atc_group1",
|
||||||
"atc_group2",
|
"atc_group2",
|
||||||
"base_ab",
|
"base_ab",
|
||||||
"bind_rows",
|
|
||||||
"ci_max",
|
"ci_max",
|
||||||
"ci_min",
|
"ci_min",
|
||||||
"clinical_breakpoints",
|
"clinical_breakpoints",
|
||||||
|
@ -64,20 +64,26 @@ pm_left_join <- function(x, y, by = NULL, suffix = c(".x", ".y")) {
|
|||||||
}
|
}
|
||||||
|
|
||||||
# support where() like tidyverse:
|
# support where() like tidyverse:
|
||||||
# adapted from https://github.com/nathaneastwood/poorman/blob/52eb6947e0b4430cd588976ed8820013eddf955f/R/where.R#L17-L32
|
|
||||||
where <- function(fn) {
|
where <- function(fn) {
|
||||||
|
# adapted from https://github.com/nathaneastwood/poorman/blob/52eb6947e0b4430cd588976ed8820013eddf955f/R/where.R#L17-L32
|
||||||
if (!is.function(fn)) {
|
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(
|
preds <- unlist(lapply(
|
||||||
pm_select_env$.data,
|
df,
|
||||||
function(x, fn) {
|
function(x, fn) {
|
||||||
do.call("fn", list(x))
|
do.call("fn", list(x))
|
||||||
},
|
},
|
||||||
fn
|
fn
|
||||||
))
|
))
|
||||||
if (!is.logical(preds)) stop("`where()` must be used with functions that return `TRUE` or `FALSE`.")
|
if (!is.logical(preds)) stop_("`where()` must be used with functions that return `TRUE` or `FALSE`.")
|
||||||
data_cols <- pm_select_env$get_colnames()
|
data_cols <- cols
|
||||||
cols <- data_cols[preds]
|
cols <- data_cols[preds]
|
||||||
which(data_cols %in% cols)
|
which(data_cols %in% cols)
|
||||||
}
|
}
|
||||||
@ -156,6 +162,20 @@ quick_case_when <- function(...) {
|
|||||||
out
|
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
|
# No export, no Rd
|
||||||
addin_insert_in <- function() {
|
addin_insert_in <- function() {
|
||||||
import_fn("insertText", "rstudioapi")(" %in% ")
|
import_fn("insertText", "rstudioapi")(" %in% ")
|
||||||
|
2
R/ab.R
2
R/ab.R
@ -495,7 +495,7 @@ as.ab <- function(x, flag_multiple_results = TRUE, info = interactive(), ...) {
|
|||||||
# save to package env to save time for next time
|
# save to package env to save time for next time
|
||||||
if (isTRUE(initial_search)) {
|
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 <- 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(
|
data.frame(
|
||||||
x = x,
|
x = x,
|
||||||
ab = x_new,
|
ab = x_new,
|
||||||
|
@ -404,8 +404,8 @@ antibiogram <- function(x,
|
|||||||
if (i == 1) {
|
if (i == 1) {
|
||||||
new_df <- long_to_wide(out[which(out$syndromic_group == grp), , drop = FALSE], digs = digits)
|
new_df <- long_to_wide(out[which(out$syndromic_group == grp), , drop = FALSE], digs = digits)
|
||||||
} else {
|
} else {
|
||||||
new_df <- bind_rows(new_df,
|
new_df <- bind_rows2(new_df,
|
||||||
long_to_wide(out[which(out$syndromic_group == grp), , drop = FALSE], digs = digits))
|
long_to_wide(out[which(out$syndromic_group == grp), , drop = FALSE], digs = digits))
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
# sort rows
|
# sort rows
|
||||||
|
2
R/av.R
2
R/av.R
@ -461,7 +461,7 @@ as.av <- function(x, flag_multiple_results = TRUE, info = interactive(), ...) {
|
|||||||
# save to package env to save time for next time
|
# save to package env to save time for next time
|
||||||
if (isTRUE(initial_search)) {
|
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 <- 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(
|
data.frame(
|
||||||
x = x,
|
x = x,
|
||||||
av = x_new,
|
av = x_new,
|
||||||
|
@ -124,7 +124,7 @@ bug_drug_combinations <- function(x,
|
|||||||
m <- as.matrix(table(x))
|
m <- as.matrix(table(x))
|
||||||
data.frame(S = m["S", ], I = m["I", ], R = m["R", ], stringsAsFactors = FALSE)
|
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(
|
out_group <- data.frame(
|
||||||
mo = rep(unique_mo[i], NROW(merged)),
|
mo = rep(unique_mo[i], NROW(merged)),
|
||||||
ab = rownames(merged),
|
ab = rownames(merged),
|
||||||
@ -144,14 +144,14 @@ bug_drug_combinations <- function(x,
|
|||||||
}
|
}
|
||||||
out_group <- cbind(group_values, out_group)
|
out_group <- cbind(group_values, out_group)
|
||||||
}
|
}
|
||||||
out <- rbind(out, out_group, stringsAsFactors = FALSE)
|
out <- bind_rows2(out, out_group)
|
||||||
}
|
}
|
||||||
out
|
out
|
||||||
}
|
}
|
||||||
# based on pm_apply_grouped_function
|
# based on pm_apply_grouped_function
|
||||||
apply_group <- function(.data, fn, groups, drop = FALSE, ...) {
|
apply_group <- function(.data, fn, groups, drop = FALSE, ...) {
|
||||||
grouped <- pm_split_into_groups(.data, groups, drop)
|
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))) {
|
if (any(groups %in% colnames(res))) {
|
||||||
class(res) <- c("grouped_data", class(res))
|
class(res) <- c("grouped_data", class(res))
|
||||||
res <- pm_set_groups(res, groups[groups %in% colnames(res)])
|
res <- pm_set_groups(res, groups[groups %in% colnames(res)])
|
||||||
|
@ -153,7 +153,7 @@ add_custom_antimicrobials <- function(x) {
|
|||||||
# assign new values
|
# assign new values
|
||||||
new_df[, col] <- x[, col, drop = TRUE]
|
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]
|
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")
|
class(AMR_env$AB_lookup$ab) <- c("ab", "character")
|
||||||
|
@ -279,7 +279,7 @@ add_custom_microorganisms <- function(x) {
|
|||||||
# clear previous coercions
|
# clear previous coercions
|
||||||
suppressMessages(mo_reset_session())
|
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")
|
class(AMR_env$MO_lookup$mo) <- c("mo", "character")
|
||||||
if (nrow(x) <= 3) {
|
if (nrow(x) <= 3) {
|
||||||
message_("Added ", vector_and(italicise(x$fullname), quotes = FALSE), " to the internal `microorganisms` data set.")
|
message_("Added ", vector_and(italicise(x$fullname), quotes = FALSE), " to the internal `microorganisms` data set.")
|
||||||
|
@ -475,7 +475,7 @@ eucast_rules <- function(x,
|
|||||||
amox$base_ab <- "AMX"
|
amox$base_ab <- "AMX"
|
||||||
amox$base_name <- ab_name("AMX", language = NULL)
|
amox$base_name <- ab_name("AMX", language = NULL)
|
||||||
# merge and sort
|
# 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]
|
ab_enzyme <- ab_enzyme[order(ab_enzyme$enzyme_name), , drop = FALSE]
|
||||||
|
|
||||||
for (i in seq_len(nrow(ab_enzyme))) {
|
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))
|
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'
|
# save changes to data set 'verbose_info'
|
||||||
track_changes$verbose_info <- rbind(track_changes$verbose_info,
|
track_changes$verbose_info <- bind_rows2(track_changes$verbose_info,
|
||||||
verbose_new,
|
verbose_new)
|
||||||
stringsAsFactors = FALSE
|
|
||||||
)
|
|
||||||
# count adds and changes
|
# count adds and changes
|
||||||
track_changes$added <- track_changes$added + verbose_new %pm>%
|
track_changes$added <- track_changes$added + verbose_new %pm>%
|
||||||
pm_filter(is.na(old)) %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
|
rownames(out) <- NULL
|
||||||
out$ab <- ab
|
out$ab <- ab
|
||||||
out$name <- ab_name(ab, language = NULL)
|
out$name <- ab_name(ab, language = NULL)
|
||||||
|
4
R/mo.R
4
R/mo.R
@ -325,7 +325,7 @@ as.mo <- function(x,
|
|||||||
result_mo <- NA_character_
|
result_mo <- NA_character_
|
||||||
} else {
|
} else {
|
||||||
result_mo <- AMR_env$MO_lookup$mo[match(top_hits[1], AMR_env$MO_lookup$fullname)]
|
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(
|
data.frame(
|
||||||
original_input = x_search,
|
original_input = x_search,
|
||||||
input = x_search_cleaned,
|
input = x_search_cleaned,
|
||||||
@ -339,7 +339,7 @@ as.mo <- function(x,
|
|||||||
stringsAsFactors = FALSE
|
stringsAsFactors = FALSE
|
||||||
)
|
)
|
||||||
# save to package env to save time for next time
|
# 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(
|
data.frame(
|
||||||
x = paste(x_search, minimum_matching_score),
|
x = paste(x_search, minimum_matching_score),
|
||||||
mo = result_mo,
|
mo = result_mo,
|
||||||
|
6
R/plot.R
6
R/plot.R
@ -585,17 +585,17 @@ plot.sir <- function(x,
|
|||||||
data$s <- round((data$n / sum(data$n)) * 100, 1)
|
data$s <- round((data$n / sum(data$n)) * 100, 1)
|
||||||
|
|
||||||
if (!"S" %in% data$x) {
|
if (!"S" %in% data$x) {
|
||||||
data <- rbind(data, data.frame(x = "S", n = 0, s = 0, stringsAsFactors = FALSE),
|
data <- bind_rows2(data, data.frame(x = "S", n = 0, s = 0, stringsAsFactors = FALSE),
|
||||||
stringsAsFactors = FALSE
|
stringsAsFactors = FALSE
|
||||||
)
|
)
|
||||||
}
|
}
|
||||||
if (!"I" %in% data$x) {
|
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
|
stringsAsFactors = FALSE
|
||||||
)
|
)
|
||||||
}
|
}
|
||||||
if (!"R" %in% data$x) {
|
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
|
stringsAsFactors = FALSE
|
||||||
)
|
)
|
||||||
}
|
}
|
||||||
|
2
R/sir.R
2
R/sir.R
@ -998,7 +998,7 @@ as_sir_method <- function(method_short,
|
|||||||
}
|
}
|
||||||
|
|
||||||
# write to verbose output
|
# write to verbose output
|
||||||
AMR_env$sir_interpretation_history <- rbind(
|
AMR_env$sir_interpretation_history <- bind_rows2(
|
||||||
AMR_env$sir_interpretation_history,
|
AMR_env$sir_interpretation_history,
|
||||||
# recycling 1 to 2 rows does not seem to work, which is why rep() was added
|
# recycling 1 to 2 rows does not seem to work, which is why rep() was added
|
||||||
data.frame(
|
data.frame(
|
||||||
|
@ -322,7 +322,7 @@ sir_calc_df <- function(type, # "proportion", "count" or "both"
|
|||||||
}
|
}
|
||||||
out_new <- cbind(group_values, out_new)
|
out_new <- cbind(group_values, out_new)
|
||||||
}
|
}
|
||||||
out <- rbind(out, out_new, stringsAsFactors = FALSE)
|
out <- bind_rows2(out, out_new)
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
out
|
out
|
||||||
@ -331,7 +331,7 @@ sir_calc_df <- function(type, # "proportion", "count" or "both"
|
|||||||
# based on pm_apply_grouped_function
|
# based on pm_apply_grouped_function
|
||||||
apply_group <- function(.data, fn, groups, drop = FALSE, ...) {
|
apply_group <- function(.data, fn, groups, drop = FALSE, ...) {
|
||||||
grouped <- pm_split_into_groups(.data, groups, drop)
|
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))) {
|
if (any(groups %in% colnames(res))) {
|
||||||
class(res) <- c("grouped_data", class(res))
|
class(res) <- c("grouped_data", class(res))
|
||||||
res <- pm_set_groups(res, groups[groups %in% colnames(res)])
|
res <- pm_set_groups(res, groups[groups %in% colnames(res)])
|
||||||
|
Loading…
Reference in New Issue
Block a user