Add callbacks and sic support for urine_rate

R/callback-icu-mortality.R

@@ -0,0 +1,63 @@
+# ==============================================================================
+# 
+# Refined ICU mortality callbacks
+#
+# based on YAIB: https://github.com/rvandewater/YAIB-cohorts/tree/main/ricu-extensions/callbacks
+# ==============================================================================
+
+aumc_death_icu <- function (x, val_var, death_date, ...) {
+  # Identify ICU mortality in AUMCdb via the discharge destination field. Use
+  # discharge time from the ICU as death time, as date of death sometimes only
+  # contain the date part and no time (i.e., 00:00:00).
+  #
+  # See discussions here:
+  # https://github.com/AmsterdamUMC/AmsterdamUMCdb/issues/56
+  # https://github.com/AmsterdamUMC/AmsterdamUMCdb/issues/61
+  idx <- index_var(x)
+  x[, `:=`(c(val_var), ricu:::is_true(get(val_var) == "Overleden"))]
+  x[get(death_date) - get(idx) > hours(24L), `:=`(c(val_var), FALSE)]
+  x
+}
+
+hirid_death_icu <- function (x, val_var, sub_var, env, ...) {
+  dis <- "discharge_status"
+  idx <- index_var(x)
+  idc <- id_vars(x)
+  res <- dt_gforce(x, "last", by = idc, vars = idx)
+  tmp <- load_id(env[["general"]], cols = dis)
+  res <- merge(res, tmp[ricu:::is_true(get(dis) == "dead"), ])
+  res <- res[, `:=`(c(val_var, dis), list(TRUE, NULL))]
+  res
+}
+
+mi_death_icu <- function(x, transfers, icu_wards, ...) {
+  # Look for all hospital deaths in which the last careunit was an ICU.
+  # See discussion here: https://github.com/MIT-LCP/mimic-code/issues/874
+  id <- id_vars(transfers)
+  lead <- function(x) data.table:::shift(x, type = "lead")
+
+  transfers[, is_last := ricu:::is_true(lead(eventtype) == "discharge")]
+  last_ward <- transfers[, .(ward = ward[is_last]), by = c(id)]
+  last_ward[, "is_icu" := .(ricu:::is_true(ward %in% icu_wards))]
+
+  dat <- data_var(x)
+  x[(last_ward[is_icu == FALSE]), c(dat) := 0L]
+  x[, c(dat) := ricu:::is_true(get(dat) == 1L)]
+  x
+}
+
+mimic_death_icu <- function(x, env, ...){
+  icu_wards <- sort(unique(env[["icustays"]]$first_careunit))
+  transfers <- load_ts(env[["transfers"]], id_var = "hadm_id", index_var = "intime", interval = mins(1L))
+  transfers <- change_id(transfers, "icustay", as_src_cfg(env), id_type = TRUE)
+  rename_cols(transfers, "ward", "curr_careunit", by_ref = TRUE)
+  mi_death_icu(x, transfers, icu_wards, ...)
+}
+
+miiv_death_icu <- function(x, env, ...){
+  icu_wards <- sort(unique(env[["icustays"]]$first_careunit))
+  transfers <- load_ts(env[["transfers"]], index_var = "intime")
+  rename_cols(transfers, "ward", "careunit", by_ref = TRUE)
+  mi_death_icu(x, transfers, icu_wards, ...)
+}
+

R/callback-kdigo.R

@@ -0,0 +1,140 @@
+# ==============================================================================
+# 
+# KDIGO Callbacks
+#
+# based on YAIB: https://github.com/rvandewater/YAIB-cohorts/tree/main/ricu-extensions/callbacks
+# ==============================================================================
+kdigo_crea <- function(..., keep_components = FALSE, interval = NULL) {
+  cnc <- c("crea")
+  crea <- ricu:::collect_dots(cnc, interval, ...)
+
+  id <- id_vars(crea)
+  ind <- index_var(crea)
+
+  min_over_period <- function(dur = hours(1L)) {
+    cdur <- as.character(dur)
+    summ <- slide(
+      crea,
+      list(crea = min(get("crea"), na.rm = TRUE)),
+      dur,
+      left_closed = FALSE
+    )
+    rename_cols(summ, paste0("crea_", cdur, "hr"), "crea")
+  }
+
+  res <- lapply(hours(2 * 24, 7 * 24), min_over_period)
+  res <- merge_lst(c(list(crea), res))
+  res[, kdigo_crea := data.table::fcase(
+      crea >= 3 * crea_168hr                         , 3L,
+      crea >= 4 &
+        (crea - crea_48hr >= 0.3 |
+         crea >= 1.5 * crea_168hr)                   , 3L,
+      crea >= 2 * crea_168hr                         , 2L,
+      crea >= crea_48hr + 0.3                        , 1L,
+      crea >= 1.5 * crea_168hr                       , 1L,
+      default = 0L
+  )]
+
+  cols_rm <- c("crea_48hr", "crea_168hr")
+  if (!keep_components) {
+    cols_rm <- c(cols_rm, "crea")
+  }
+  res <- rm_cols(res, cols_rm, skip_absent = TRUE, by_ref = TRUE)
+  res
+}
+
+
+urine_rate <- function(x, max_gap = hours(24L), interval = NULL, id_type = "icustay") {
+  # TODO: Does not currently work as a rec_cncpt. For example, currently keep_components = TRUE would lead to
+  #       a situation in which `urine` and not `urine_rate` is passed back. This is likely because `fun_itm`,
+  #       which is currently expects a table with a single column. If multiple are present, it chooses the first,
+  #       which in this case is `urine`. Unhelpfully, this is then renamed to `urine_rate`, hiding this
+  #       behaviour.
+  #       Solution: remove keep_components for now and use only as `fun_itm`
+  id <- id_var(x)
+  ind <- index_var(x)
+
+  res <- rename_cols(x, "urine", old = data_var(x))
+
+  res[, tm := get(ind) - data.table::shift(get(ind)) + 1L, by = c(id)]
+  res[, tm := ifelse(is.na(tm) | tm > max_gap, 1, tm)]
+  res[, val_var := urine / tm]
+
+  cols_rm <- c("tm", "urine")
+  res <- rm_cols(res, cols_rm, skip_absent = TRUE, by_ref = TRUE)
+  res
+}
+
+
+kdigo_urine <- function(..., keep_components = FALSE, interval = NULL) {
+  cnc <- c("urine_rate", "weight")
+  res <- ricu:::collect_dots(cnc, interval, ...)
+  urine_rate <- res[["urine_rate"]]
+  weight <- res[["weight"]]
+
+  id <- id_vars(urine_rate)
+  ind <- index_var(urine_rate)
+
+  rate_over_period <- function(dur = hours(1L)) {
+    name <- paste0("urine_rate_", as.character(dur), "hr")
+    summ <- slide(urine_rate, list(urine_h = sum(get("urine_rate"), na.rm = TRUE)), dur, left_closed = FALSE)
+    summ[weight, urine_h := urine_h / ifelse(is.na(weight), 75, weight), on = c(id)]
+    summ <- rename_cols(summ, name, "urine_h")
+    summ[, .SD, .SDcols = c(id, ind, name)]
+  }
+
+  res <- lapply(hours(6L, 12L, 24L), rate_over_period)
+  res <- merge_lst(c(list(urine_rate, weight), res))
+  res[, kdigo_urine := data.table::fcase( # TODO: make work with intervals other than
+    get(ind) >= hours(24L) & urine_rate_24hr < 0.3, 3L,
+    get(ind) >= hours(12L) & urine_rate_12hr == 0 , 3L,
+    get(ind) >= hours(12L) & urine_rate_12hr < 0.5, 2L,
+    get(ind) >= hours(6L)  & urine_rate_6hr  < 0.5, 1L,
+    default = 0L
+  )]
+
+  cols_rm <- c(
+    "urine_rate_6hr", "urine_rate_12hr", "urine_rate_24hr"
+  )
+  if (!keep_components) {
+    cols_rm <- c(cols_rm, "urine_rate", "weight")
+  }
+  res <- rm_cols(res, cols_rm, skip_absent = TRUE, by_ref = TRUE)
+  res
+}
+
+
+kdigo <- function(..., keep_components = FALSE, interval = NULL) {
+  cnc <- c("kdigo_crea", "kdigo_urine")
+  res <- ricu:::collect_dots(cnc, interval, ...)
+  kdigo_crea <- res[["kdigo_crea"]]
+  kdigo_urine <- res[["kdigo_urine"]]
+
+  idc <- id_vars(kdigo_crea)
+  indc <- index_var(kdigo_crea)
+  idu <- id_vars(kdigo_urine)
+  indu <- index_var(kdigo_urine)
+
+  res <- merge(kdigo_crea, kdigo_urine, by.x = c(idc, indc), by.y = c(idu, indu), all = TRUE)
+  res[, kdigo := pmax(kdigo_crea, kdigo_urine, na.rm = TRUE)]
+
+  if (!keep_components) {
+    cols_rm <- c("kdigo_crea", "kdigo_urine")
+    res <- rm_cols(res, cols_rm, skip_absent = TRUE, by_ref = TRUE)
+  }
+  res
+}
+
+
+aki <- function(..., threshold = 1L, interval = NULL, keep_components = FALSE) {
+
+  cnc <- c("kdigo")
+  res <- ricu:::collect_dots(cnc, interval, ...)
+  res[, aki := kdigo >= threshold]
+
+  if (!keep_components) {
+    res <- rm_cols(res, "kdigo", skip_absent = TRUE, by_ref = TRUE)
+  }
+
+  res[aki == TRUE]
+}

R/callback-sep3.R

@@ -432,3 +432,131 @@ si_or <- function(abx, samp, abx_win, samp_win, keep) {
 
   res
 }
+
+
+# ==============================================================================
+# Alternative sepsis3 implementations
+# based on: https://github.com/rvandewater/YAIB-cohorts/tree/main/ricu-extensions/callbacks
+# ==============================================================================
+cummax_difftime <- function(x){
+  # TODO: change to allow other intervals than hours
+  as.difftime(cummax(as.numeric(x)), units = "hours")
+}
+lead <- function(x) {
+  data.table::shift(x, type="lead")
+}
+
+abx_cont <- function(..., abx_win = hours(72L), abx_max_gap = hours(24L), keep_components = FALSE, interval = NULL) {
+  cnc <- c("abx_duration", "death_icu")
+  res <- ricu:::collect_dots(cnc, interval, ...)
+  abx <- res[["abx_duration"]]
+  death_icu <- res[["death_icu"]]
+
+  aid <- id_vars(abx)
+  aind <- index_var(abx)
+  adur <- dur_var(abx)
+  did <- id_vars(death_icu)
+  dind <- index_var(death_icu)
+
+  abx <- as_ts_tbl(abx)
+  abx <- abx[, .(dur_var = max(get(adur))), by = c(aid, aind)]
+  death_icu <- death_icu[death_icu == TRUE]
+  abx_death <- merge(abx, death_icu, by.x = aid, by.y = did, all.x = TRUE)
+
+  res <- slide(
+    # Only look at antibiotic records that are recorded before the time of death
+    abx_death[is.na(get(dind)) | get(aind) <= get(dind)],
+    .(
+    # Calculate the maximum gap between two administrations for the next `abx_win` hours
+    # as follows:
+    #
+    # 1. get the administration time of the next antibiotic:
+    #        lead(get(aind))
+    # 2. this isn't defined for the last (.N-th) time within the window, so remove that
+    #        lead(get(aind))[-.N]:
+    # 3. replace the last time with either
+    #   a) the time of death:
+    #        get(dind)
+    #   b) the first antibiotic time in the window (=current antibiotic we are looking at)
+    #      plus the window lenght
+    #        get(aind)[1] + abx_win
+    #    whichever is earlier
+    # 4. subtract from it the latest time that any previous antibiotic was stopped
+    #        cummax_difftime(get(aind) + dur_var)
+    #    this is the gap
+    # 5. take the maximum gap calculated this way for this window
+    # 6. repeat for all possible windows
+      max_gap = max(
+        c(lead(get(aind))[-.N], min(c(get(dind), get(aind)[1] + abx_win), na.rm = TRUE)) -
+        cummax_difftime(get(aind) + dur_var)
+      )
+    ),
+    before = hours(0L), # we always start from the current antibiotic and look `abx_win` in the future
+    after = abx_win
+  )
+
+  res <- res[max_gap <= abx_max_gap]
+  res[, c("abx_cont", "max_gap") := .(TRUE, NULL)]
+  res
+}
+
+
+susp_inf_abx_cont <- function(..., abx_count_win = hours(24L), abx_min_count = 1L,
+              positive_cultures = FALSE, si_mode = c("and", "or", "abx", "samp"),
+              abx_win = hours(24L), samp_win = hours(72L),
+              by_ref = TRUE, keep_components = FALSE, interval = NULL)
+{
+  cnc <- c("abx_cont", "samp")
+  res <- ricu:::collect_dots(cnc, interval, ...)
+  abx_cont <- res[["abx_cont"]]
+  samp <- res[['samp']]
+
+  # make `abx_cont` look like abx to pass on to the original ricu::susp_inf
+  rename_cols(abx_cont, "abx", "abx_cont", by_ref = TRUE)
+
+  # pass the rest of the calculations to ricu::susp_inf
+  res <- ricu::susp_inf(
+    abx = abx_cont,
+    samp = samp,
+    abx_count_win = abx_count_win,
+    abx_min_count = abx_min_count,
+    positive_cultures = positive_cultures,
+    si_mode = si_mode,
+    abx_win = abx_win,
+    samp_win = samp_win,
+    by_ref = by_ref,
+    keep_components = keep_components,
+    interval = interval
+  )
+  rename_cols(res, "susp_inf_alt", "susp_inf", by_ref = TRUE)
+  res
+}
+
+
+sep3_abx_cont <- function (..., si_window = c("first", "last", "any"), delta_fun = delta_cummin,
+          sofa_thresh = 2L, si_lwr = hours(48L), si_upr = hours(24L),
+          keep_components = FALSE, interval = NULL)
+{
+  cnc <- c("sofa", "susp_inf_alt")
+  res <- ricu:::collect_dots(cnc, interval, ...)
+  sofa <- res[["sofa"]]
+  susp <- res[["susp_inf_alt"]]
+
+  # make `susp_inf_alt` look like susp_inf to pass on to the original ricu::sep3
+  rename_cols(susp, "susp_inf", "susp_inf_alt", by_ref = TRUE)
+
+  # pass the rest of the calculations to ricu::susp_inf
+  res <- ricu::sep3(
+    sofa = sofa,
+    susp_inf = susp,
+    si_window = si_window,
+    delta_fun = delta_fun,
+    sofa_thresh = sofa_thresh,
+    si_lwr = si_lwr,
+    si_upr = si_upr,
+    keep_components = keep_components,
+    interval = interval
+  )
+  rename_cols(res, "sep3_alt", "sep3", by_ref = TRUE)
+  res
+}

inst/extdata/config/concept-dict/circulatory.json

@@ -16,4 +16,4 @@
         ]
       }
     }
-  }
+}

inst/extdata/config/concept-dict/output.json

@@ -2,7 +2,7 @@
     "urine": {
         "unit": "mL",
         "min": 0,
-        "max": 4000,
+        "max": 7000,
         "aggregate": "sum",
         "description": "urine output",
         "omopid": 4264378,
@@ -167,7 +167,7 @@
     "urine_rate": {
         "unit": "mL/h",
         "min": 0,
-        "max": 2000,
+        "max": 3000,
         "aggregate": "max",
         "description": "urine rate per hour",
         "category": "output",
@@ -215,6 +215,12 @@
               "class": "fun_itm",
               "callback": "combine_callbacks(fwd_concept('urine'), urine_rate)"
             }
+          ],
+          "sic": [
+            {
+              "class": "fun_itm",
+              "callback": "combine_callbacks(fwd_concept('urine'), urine_rate)"
+            }
           ]
         }
     },