From d25628d85de8a3c2b41af3975a8764e71e862fb1 Mon Sep 17 00:00:00 2001 From: prockenschaub Date: Thu, 29 Sep 2022 15:41:23 +0200 Subject: [PATCH 1/7] Allow collect_dots to accept non-concepts --- R/callback-cncpt.R | 30 +++--------------------------- 1 file changed, 3 insertions(+), 27 deletions(-) diff --git a/R/callback-cncpt.R b/R/callback-cncpt.R index fd2bdc5d..e8fabb65 100644 --- a/R/callback-cncpt.R +++ b/R/callback-cncpt.R @@ -5,37 +5,11 @@ collect_dots <- function(concepts, interval, ..., merge_dat = FALSE) { dots <- list(...) - if (length(concepts) == 1L) { - - assert_that(identical(length(dots), 1L)) - - res <- dots[[1L]] - - if (is_ts_tbl(res)) { - ival <- coalesce(interval, interval(res)) - assert_that(has_interval(res, ival)) - } else { - assert_that(is_df(res)) - } - - return(res) - } - - if (length(dots) == 1L) { - dots <- dots[[1L]] - } - - if (is.null(names(dots))) { - names(dots) <- concepts - } - if (not_null(names(concepts))) { concepts <- chr_ply(concepts, grep, names(dots), value = TRUE, use_names = TRUE) } - assert_that(setequal(names(dots), concepts)) - res <- dots[concepts] assert_that(all_map(has_col, res, concepts)) @@ -46,7 +20,9 @@ collect_dots <- function(concepts, interval, ..., merge_dat = FALSE) { ival <- check_interval(res, interval) - if (merge_dat) { + if (length(res) == 1) { + res <- res[[1]] + } else if (merge_dat) { res <- reduce(merge, res, all = TRUE) } else { attr(res, "ival_checked") <- ival From 1b5741780a347df18d061fdeabbc86a750fa70b1 Mon Sep 17 00:00:00 2001 From: prockenschaub Date: Thu, 29 Sep 2022 16:23:57 +0200 Subject: [PATCH 2/7] Pass arguments to lower-level concepts Note: this currently needs to remove a warning from load_concepts.itm, which may not be desired. Maybe there is another way to prevent unnecessary warnings in the case of additional arguments to load_concepts? --- R/concept-load.R | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/R/concept-load.R b/R/concept-load.R index 2f2c6d7e..7ae7d016 100644 --- a/R/concept-load.R +++ b/R/concept-load.R @@ -495,7 +495,7 @@ load_concepts.rec_cncpt <- function(x, aggregate = NULL, patient_ids = NULL, ext <- list(patient_ids = patient_ids, id_type = id_type, interval = coalesce(x[["interval"]], interval), - progress = progress) + ..., progress = progress) sub <- x[["items"]] agg <- x[["aggregate"]] @@ -554,8 +554,6 @@ load_concepts.item <- function(x, patient_ids = NULL, id_type = "icustay", load_concepts.itm <- function(x, patient_ids = NULL, id_type = "icustay", interval = hours(1L), ...) { - warn_dots(..., ok_args = "keep_components") - res <- do_itm_load(x, id_type, interval = interval) res <- merge_patid(res, patient_ids) res <- do_callback(x, res) From 253e4189a3fb0493328bb8e0c3e3d71b83e72053 Mon Sep 17 00:00:00 2001 From: prockenschaub Date: Thu, 29 Sep 2022 16:24:35 +0200 Subject: [PATCH 3/7] Use named args in tests to pass --- tests/testthat/test-callback.R | 2 +- tests/testthat/test-scores.R | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/tests/testthat/test-callback.R b/tests/testthat/test-callback.R index b144e639..3aa90af3 100644 --- a/tests/testthat/test-callback.R +++ b/tests/testthat/test-callback.R @@ -269,5 +269,5 @@ test_that("susp_inf", { 57, 61, 70)), susp_inf = rep(TRUE, 6L), interval = hours(1L) ) - expect_identical(susp_inf(abx, samp), expected) + expect_identical(susp_inf(abx = abx, samp = samp), expected) }) diff --git a/tests/testthat/test-scores.R b/tests/testthat/test-scores.R index db79d72f..512c20d9 100644 --- a/tests/testthat/test-scores.R +++ b/tests/testthat/test-scores.R @@ -43,7 +43,7 @@ test_that("suspicion of infection", { expect_equal(interval(si_ei), hours(1L)) }) -sep3 <- sep3(so_mi, si_mi) +sep3 <- sep3(sofa = so_mi, susp_inf = si_mi) test_that("sepsis 3", { From 4a9f1699b4a439ef14a65815ebc3641195c65e62 Mon Sep 17 00:00:00 2001 From: prockenschaub Date: Mon, 10 Oct 2022 17:12:09 +0200 Subject: [PATCH 4/7] Remove unneeded keep_components from sep3 --- inst/extdata/config/concept-dict.R | 1 - inst/extdata/config/concept-dict.json | 4 ---- 2 files changed, 5 deletions(-) diff --git a/inst/extdata/config/concept-dict.R b/inst/extdata/config/concept-dict.R index 09a70863..db177652 100644 --- a/inst/extdata/config/concept-dict.R +++ b/inst/extdata/config/concept-dict.R @@ -2676,7 +2676,6 @@ cfg <- list( description = "sepsis-3 criterion", category = "outcome", callback = "sep3", - keep_components = c(FALSE, TRUE), class = "rec_cncpt" ), bnd = list( diff --git a/inst/extdata/config/concept-dict.json b/inst/extdata/config/concept-dict.json index e7a582da..4cd19bd1 100644 --- a/inst/extdata/config/concept-dict.json +++ b/inst/extdata/config/concept-dict.json @@ -5172,10 +5172,6 @@ "description": "sepsis-3 criterion", "category": "outcome", "callback": "sep3", - "keep_components": [ - false, - true - ], "class": "rec_cncpt" }, "sex": { From f582793f991d7d1b24e9e8338f487e45b1a7bc8a Mon Sep 17 00:00:00 2001 From: prockenschaub Date: Mon, 10 Oct 2022 17:12:09 +0200 Subject: [PATCH 5/7] Remove unneeded keep_components from sep3 --- inst/extdata/config/concept-dict.json | 1 - 1 file changed, 1 deletion(-) diff --git a/inst/extdata/config/concept-dict.json b/inst/extdata/config/concept-dict.json index 10fd7f3c..d80e1880 100644 --- a/inst/extdata/config/concept-dict.json +++ b/inst/extdata/config/concept-dict.json @@ -5254,7 +5254,6 @@ "omopid": 132797, "category": "outcome", "callback": "sep3", - "keep_components": [false, true], "class": "rec_cncpt" }, "sex": { From 4215d5d9a3fb46639f2d22a081cfcf78bdd539be Mon Sep 17 00:00:00 2001 From: prockenschaub Date: Tue, 4 Oct 2022 15:02:34 +0200 Subject: [PATCH 6/7] Fix AUMC difftime calculation --- R/data-load.R | 37 ++++++++++++++++++++++++++++++++++--- 1 file changed, 34 insertions(+), 3 deletions(-) diff --git a/R/data-load.R b/R/data-load.R index 53187a3c..ff1432d0 100644 --- a/R/data-load.R +++ b/R/data-load.R @@ -131,7 +131,7 @@ load_difftime.eicu_tbl <- function(x, rows, cols = colnames(x), warn_dots(...) - load_eiau(x, {{ rows }}, cols, id_hint, time_vars, min_as_mins) + load_ei(x, {{ rows }}, cols, id_hint, time_vars, min_as_mins) } #' @rdname load_src @@ -153,7 +153,7 @@ load_difftime.aumc_tbl <- function(x, rows, cols = colnames(x), warn_dots(...) - load_eiau(x, {{ rows }}, cols, id_hint, time_vars, ms_as_mins) + load_au(x, {{ rows }}, cols, id_hint, time_vars) } #' @rdname load_src @@ -226,7 +226,38 @@ load_mihi <- function(x, rows, cols, id_hint, time_vars) { as_id_tbl(dat, id_vars = id_col, by_ref = TRUE) } -load_eiau <- function(x, rows, cols, id_hint, time_vars, mins_fun) { +load_au <- function(x, rows, cols, id_hint, time_vars) { + # TODO: this is closely related to load_mihi, extract common functionality + # and remove code duplication + dt_round_min <- function(x, y) round_to(ms_as_mins(x - y)) + + id_col <- resolve_id_hint(x, id_hint) + + assert_that(is.string(id_col), id_col %in% colnames(x)) + + if (!id_col %in% cols) { + cols <- c(cols, id_col) + } + + time_vars <- intersect(time_vars, cols) + + dat <- load_src(x, {{ rows }}, cols) + + if (length(time_vars)) { + + dat <- merge(dat, id_origin(x, id_col, origin_name = "origin"), + by = id_col) + dat <- dat[, + c(time_vars) := lapply(.SD, dt_round_min, get("origin")), + .SDcols = time_vars + ] + dat <- dat[, c("origin") := NULL] + } + + as_id_tbl(dat, id_vars = id_col, by_ref = TRUE) +} + +load_ei <- function(x, rows, cols, id_hint, time_vars, mins_fun) { id_col <- resolve_id_hint(x, id_hint) From 7a1575d9caa5b1b120ba3c23b72d945232f6d355 Mon Sep 17 00:00:00 2001 From: prockenschaub Date: Wed, 11 Oct 2023 22:39:52 +0200 Subject: [PATCH 7/7] simplify load_difftime to a single function load_mihi, load_au, and load_ei only differ in the rounding function they apply (and the fact that eicu strictly speaking doesn't require merging of origin). They can thus all be replaced with a single function that receives the rounding function as a parameter. --- R/data-load.R | 81 +++++++++------------------------------------------ 1 file changed, 13 insertions(+), 68 deletions(-) diff --git a/R/data-load.R b/R/data-load.R index ff1432d0..52f04c5d 100644 --- a/R/data-load.R +++ b/R/data-load.R @@ -119,8 +119,8 @@ load_difftime.mimic_tbl <- function(x, rows, cols = colnames(x), time_vars = ricu::time_vars(x), ...) { warn_dots(...) - - load_mihi(x, {{ rows }}, cols, id_hint, time_vars) + dt_round_min <- function(x, y) round_to(difftime(x, y, units = "mins")) + do_load_difftime(x, {{ rows }}, cols, id_hint, time_vars, dt_round_min) } #' @rdname load_src @@ -130,8 +130,8 @@ load_difftime.eicu_tbl <- function(x, rows, cols = colnames(x), time_vars = ricu::time_vars(x), ...) { warn_dots(...) - - load_ei(x, {{ rows }}, cols, id_hint, time_vars, min_as_mins) + dt_round_min <- function(x, y) min_as_mins(x) + do_load_difftime(x, {{ rows }}, cols, id_hint, time_vars, dt_round_min) } #' @rdname load_src @@ -141,8 +141,8 @@ load_difftime.hirid_tbl <- function(x, rows, cols = colnames(x), time_vars = ricu::time_vars(x), ...) { warn_dots(...) - - load_mihi(x, {{ rows }}, cols, id_hint, time_vars) + dt_round_min <- function(x, y) round_to(difftime(x, y, units = "mins")) + do_load_difftime(x, {{ rows }}, cols, id_hint, time_vars, dt_round_min) } #' @rdname load_src @@ -152,8 +152,8 @@ load_difftime.aumc_tbl <- function(x, rows, cols = colnames(x), time_vars = ricu::time_vars(x), ...) { warn_dots(...) - - load_au(x, {{ rows }}, cols, id_hint, time_vars) + dt_round_min <- function(x, y) round_to(ms_as_mins(x - y)) + do_load_difftime(x, {{ rows }}, cols, id_hint, time_vars, dt_round_min) } #' @rdname load_src @@ -163,8 +163,8 @@ load_difftime.miiv_tbl <- function(x, rows, cols = colnames(x), time_vars = ricu::time_vars(x), ...) { warn_dots(...) - - load_mihi(x, {{ rows }}, cols, id_hint, time_vars) + dt_round_min <- function(x, y) round_to(difftime(x, y, units = "mins")) + do_load_difftime(x, {{ rows }}, cols, id_hint, time_vars, dt_round_min) } #' @rdname load_src @@ -195,41 +195,7 @@ resolve_id_hint <- function(tbl, hint) { id_vars(opts[hits]) } -load_mihi <- function(x, rows, cols, id_hint, time_vars) { - - dt_round_min <- function(x, y) round_to(difftime(x, y, units = "mins")) - - id_col <- resolve_id_hint(x, id_hint) - - assert_that(is.string(id_col), id_col %in% colnames(x)) - - if (!id_col %in% cols) { - cols <- c(cols, id_col) - } - - time_vars <- intersect(time_vars, cols) - - dat <- load_src(x, {{ rows }}, cols) - - if (length(time_vars)) { - - dat <- merge(dat, id_origin(x, id_col, origin_name = "origin"), - by = id_col) - - dat <- dat[, - c(time_vars) := lapply(.SD, dt_round_min, get("origin")), - .SDcols = time_vars - ] - dat <- dat[, c("origin") := NULL] - } - - as_id_tbl(dat, id_vars = id_col, by_ref = TRUE) -} - -load_au <- function(x, rows, cols, id_hint, time_vars) { - # TODO: this is closely related to load_mihi, extract common functionality - # and remove code duplication - dt_round_min <- function(x, y) round_to(ms_as_mins(x - y)) +do_load_difftime <- function(x, rows, cols, id_hint, time_vars, time_fn) { id_col <- resolve_id_hint(x, id_hint) @@ -247,35 +213,14 @@ load_au <- function(x, rows, cols, id_hint, time_vars) { dat <- merge(dat, id_origin(x, id_col, origin_name = "origin"), by = id_col) + dat <- dat[, - c(time_vars) := lapply(.SD, dt_round_min, get("origin")), + c(time_vars) := lapply(.SD, time_fn, get("origin")), .SDcols = time_vars ] dat <- dat[, c("origin") := NULL] } - as_id_tbl(dat, id_vars = id_col, by_ref = TRUE) -} - -load_ei <- function(x, rows, cols, id_hint, time_vars, mins_fun) { - - id_col <- resolve_id_hint(x, id_hint) - - if (!id_col %in% cols) { - cols <- c(id_col, cols) - } - - time_vars <- intersect(time_vars, cols) - - dat <- load_src(x, {{ rows }}, cols) - - if (length(time_vars)) { - - assert_that(has_col(dat, id_col)) - - dat <- dat[, c(time_vars) := lapply(.SD, mins_fun), .SDcols = time_vars] - } - as_id_tbl(dat, id_vars = id_col, by_ref = TRUE) }