Merge branch 'main' of github.com:ratschlab/ricu into gh-actions

R/callback-itm.R

@@ -43,6 +43,25 @@ mimic_sampling <- function(x, val_var, aux_time, ...) {
   set(x, j = val_var, value = !is.na(x[[val_var]]))
 }
 
+picdb_sampling <- function(x, val_var, aux_time, ...) {
+  x <- combine_date_time(x, aux_time, hours(12L))
+
+  # These identifiers indicate that the culture showed no growth
+  # of the respective organism
+  no_growth_identifiers <- c('MIC1008', 'MIC2123', 'MIC2287', 'MIC2291', 'MIC2293',
+    'MIC2370', 'MIC2408', 'MIC2421', 'MIC575',
+    'MIC585', 'MIC593', 'MIC629', 'MIC631',
+    'MIC635', 'MIC637', 'MIC645', 'MIC648',
+    'MIC874', 'MIC941', 'MIC979'
+  )
+
+  # Assign:
+  # - 0 if NA or in no_growth_identifiers
+  # - 1 otherwise, indicating growth
+  bool_value <- !is.na(x[[val_var]]) & !(x[[val_var]] %in% no_growth_identifiers)
+  set(x, j = val_var, value = bool_value)
+}
+
 #' Item callback utilities
 #'
 #' For concept loading, item callback functions are used in order to handle
@@ -610,18 +629,24 @@ aumc_rate_units <- function(mcg_to_units) {
 }
 
 sic_dur <- function (x, val_var, stop_var, grp_var = NULL, ...) {
-
   calc_dur(x, val_var, index_var(x), stop_var, grp_var)
 }
 
-sic_rate_kg <- function (x, val_var, stop_var, env, ...) {
-
-  res <- add_weight(x, env, "weight")
-  wgh_var <- "weight"
-  res[, c(val_var) := get(val_var) * 10^3 / get(wgh_var)]
-  expand(res, index_var(x), stop_var, keep_vars = c(id_vars(x), val_var))
+sic_rate_kg <- function(x, val_var, unit_var, stop_var, env, ...) {
+
+  g_to_mcg <- convert_unit(binary_op(`*`, 1000000), "mcg", "g")
+
+  res <- g_to_mcg(x, val_var, unit_var)
+  res <- add_weight(res, env, "weight")
+
+  res <- res[, c(val_var) := get(val_var) / get("weight")]
+  res <- res[, c(unit_var) := paste(get(unit_var), "min", sep = "/kg/")]
+
+  expand(res, index_var(x), stop_var,
+         keep_vars = c(id_vars(x), val_var, unit_var))
 }
 
+
 eicu_duration <- function(gap_length) {
 
   assert_that(is_interval(gap_length), is_scalar(gap_length))
@@ -643,6 +668,15 @@ aumc_dur <- function(x, val_var, stop_var, grp_var, ...) {
   calc_dur(x, val_var, index_var(x), stop_var, grp_var)
 }
 
+default_duration <- function(x, val_var, stop_var, grp_var, ...) {
+  calc_dur(x, val_var, index_var(x), stop_var, grp_var)
+}
+
+no_duration <- function(x, val_var, grp_var, ...) {
+  calc_dur(x, val_var, index_var(x), index_var(x), grp_var)
+}
+
+
 #' Used for determining vasopressor durations, `calc_dur()` will calculate
 #' durations by taking either per ID or per combination of ID and `grp_var`
 #' the minimum for `min_var` and the maximum of `max_var` and returning the
@@ -759,6 +793,13 @@ aumc_death <- function(x, val_var, ...) {
   x
 }
 
+sic_death <- function(x, val_var, adm_time, ...) {
+  idx <- index_var(x)
+
+  x <- x[, c(val_var) := is_true(get(idx) - (get(adm_time) + secs(get(val_var))) < hours(72L))]
+  x
+}
+
 aumc_bxs <- function(x, val_var, dir_var, ...) {
   x <- x[get(dir_var) == "-", c(val_var) := -1L * get(val_var)]
   x

R/callback-tbl.R

@@ -0,0 +1,36 @@
+
+sic_data_float_h <- function(dat, ...) {
+
+   hexstring_to_float <- function(x) {
+     if (is.na(x)) {
+       return(NA_real_)
+     }
+     hexstring <- substring(x, seq(1, 482, 2), seq(2, 482, 2))
+     bytes <- as.raw(strtoi(hexstring[-1], base = 16))
+     floats <- readBin(bytes, numeric(), length(bytes) %/% 4, 4, endian = "little")
+     ifelse(floats == 0, NA_real_, floats)
+   }
+
+   setDT(dat)
+
+   # TODO: remove hard coding of rawdata and derive from JSON config
+   dat[, c("rawdata") := lapply(get("rawdata"), hexstring_to_float)]
+   dat <- dat[, .(
+       Offset = Offset + 60 * (0:(sapply(rawdata, length)-1)),
+       Val = Val,
+       cnt = cnt,
+       rawdata = unlist(rawdata),
+       rawdata_present = !is.na(rawdata)
+     ),
+     by = .(id, CaseID, DataID)
+   ]
+
+    # Fix measurements that only have one value
+   dat[rawdata_present == FALSE, rawdata := Val]
+   dat[, rawdata_present := NULL]
+
+   return(dat)
+
+}
+
+

R/concept-utils.R

@@ -199,6 +199,30 @@ get_hirid_ids <- function(x, ids) {
   load_id("variables", x, .data$id %in% .env$ids, cols = "unit", id_var = "id")
 }
 
+#' @rdname data_items
+#' @export
+init_itm.sic_itm <- function(x, table, sub_var, ids,
+                             callback = "identity_callback", ...) {
+
+  assert_that(is.string(table), has_length(ids),
+              is.character(ids) || is_intish(ids))
+
+  x[["table"]] <- table
+
+  units <- get_sic_ids(x, ids)
+  units <- rename_cols(rm_na(units), sub_var, "referenceglobalid")
+
+  todo <- c("ids", "units")
+  x[todo] <- mget(todo)
+
+  complete_tbl_itm(x, callback, sub_var, ...)
+}
+
+get_sic_ids <- function(x, ids) {
+  load_id("d_references", x, .data$referenceglobalid %in% .env$ids, cols = "referenceunit", id_var = "referenceglobalid")
+}
+
+
 #' @param unit_val String valued unit to be used in case no `unit_var` is
 #' available for the given table
 #'
@@ -330,6 +354,10 @@ prepare_query.sel_itm <- prep_sel
 #' @export
 prepare_query.hrd_itm <- prep_sel
 
+#' @keywords internal
+#' @export
+prepare_query.sic_itm <- prep_sel
+
 #' @keywords internal
 #' @export
 prepare_query.rgx_itm <- function(x) {
@@ -546,6 +574,28 @@ do_callback.hrd_itm <- function(x, ...) {
   NextMethod()
 }
 
+#' @keywords internal
+ #' @export
+ do_callback.sic_itm <- function(x, ...) {
+  # TODO: generalise and combine with do_callback.hrd_itm
+  if (is.null(get_itm_var(x, "unit_var"))) {
+    x <- try_add_vars(x, unit_var = "referenceunit")
+  }
+
+  NextMethod()
+}
+
+#' @keywords internal
+#' @export
+do_callback.sic_itm <- function(x, ...) {
+  # TODO: generalise and combine with do_callback.hrd_itm
+  if (is.null(get_itm_var(x, "unit_var"))) {
+    x <- try_add_vars(x, unit_var = "referenceunit")
+  }
+
+  NextMethod()
+}
+
 #' @keywords internal
 #' @export
 do_callback.col_itm <- function(x, ...) {
@@ -604,6 +654,19 @@ do_itm_load.hrd_itm <- function(x, id_type = "icustay", interval = hours(1L)) {
   res
 }
 
+#' @export
+do_itm_load.sic_itm <- function(x, id_type = "icustay", interval = hours(1L)) {
+
+  res <- NextMethod()
+
+  if (is.null(get_itm_var(x, "unit_var"))) {
+    unt <- x[["units"]]
+    res <- merge(res, unt, by = get_itm_var(x, "sub_var"), all.x = TRUE)
+  }
+
+  res
+}
+
 #' @export
 do_itm_load.col_itm <- function(x, id_type = "icustay", interval = hours(1L)) {
 

R/config-utils.R

@@ -386,6 +386,34 @@ partition_col <- function(x, orig_names = FALSE) {
   col
 }
 
+tbl_callback <- function(x){
+   x <- as_tbl_cfg(x)
+   assert_that(length(x) == 1L)
+
+    if (!("callback" %in% vctrs::fields(x))) {
+      return(identity_callback)
+    }
+
+    callback_field <- vctrs::field(x, "callback")
+    if (is.character(callback_field)) {
+      msg_ricu(paste("[tbl_callback] Using callback function: ", callback_field))
+      return(str_to_fun(callback_field))
+    }
+
+    if (!is.null(callback_field) && !is.list(callback_field)) {
+      return(identity_callback)
+    }
+
+    callback_value <- callback_field[[1]]
+    if (is.character(callback_value)) {
+      msg_ricu(paste("[tbl_callback] Using callback function: ", callback_value))
+      return(str_to_fun(callback_value))
+    }
+
+    return(identity_callback)
+ }
+
+
 #' @export
 n_tick.tbl_cfg <- function(x) {
 

R/data-load.R

@@ -178,6 +178,17 @@ load_difftime.sic_tbl <- function(x, rows, cols = colnames(x),
   load_eiau(x, {{ rows }}, cols, id_hint, time_vars, sec_as_mins)
 }
 
+#' @rdname load_src
+#' @export
+# copy-pasted from mimic_tbl
+load_difftime.picdb_tbl <- function(x, rows, cols = colnames(x),
+                                   id_hint = id_vars(x),
+                                   time_vars = ricu::time_vars(x), ...) {
+
+  warn_dots(...)
+  load_mihi(x, {{ rows }}, cols, id_hint, time_vars)
+}
+
 #' @rdname load_src
 #' @export
 load_difftime.character <- function(x, src, ...) {

R/data-utils.R

@@ -128,6 +128,28 @@ id_orig_helper.miiv_env <- function(x, id) {
   as_id_tbl(res, id, by_ref = TRUE)
 }
 
+#' @rdname data_utils
+#' @export
+id_orig_helper.sic_env <- function(x, id) {
+
+  if (!identical(id, "patientid")) {
+    return(NextMethod())
+  }
+
+  cfg <- as_id_cfg(x)[id == id_var_opts(x)]
+
+  assert_that(length(cfg) == 1L)
+
+  sta <- field(cfg, "start")
+  age <- "admissionyear"
+
+  res <- as_src_tbl(x, field(cfg, "table"))
+  res <- res[, c(id, sta, age)]
+  res <- res[, c(sta, age) := shift_year(get(sta), get(age))]
+
+  as_id_tbl(res, id, by_ref = TRUE)
+}
+
 #' @export
 id_orig_helper.default <- function(x, ...) stop_generic(x, .Generic)
 
@@ -228,33 +250,32 @@ id_win_helper.eicu_env <- function(x) {
   order_rename(res, ids, sta, end)
 }
 
-#' @rdname data_utils
-#' @export
-id_win_helper.sic_env <- function(x) {
-
-  sec_as_mins <- function(x) min_as_mins(as.integer(x / 60))
-
+
+ #' @rdname data_utils
+ #' @export
+ id_win_helper.sic_env <- function(x) {
   cfg <- sort(as_id_cfg(x), decreasing = TRUE)
-  
+
   ids <- field(cfg, "id")
-  sta <- c(unique(field(cfg, "start")), "HospAdmTime")
+  sta <- field(cfg, "start")
   end <- field(cfg, "end")
-  
+
   tbl <- as_src_tbl(x, unique(field(cfg, "table")))
-  
+
   mis <- setdiff(sta, colnames(tbl))
-  
+
   res <- load_src(tbl, cols = c(ids, intersect(sta, colnames(tbl)), end))
-
-  if (length(mis) > 0L) {
-    res[, c(mis) := 0L]
-  }
-
-  res <- res[, c(sta, end) := lapply(.SD, sec_as_mins), .SDcols = c(sta, end)]
+
+  assert_that(length(mis) == 1L)
+  res[, firstadmission := 0L]
+
+  res <- res[, c(sta, end) := lapply(.SD, s_as_mins), .SDcols = c(sta, end)]
+  res[, timeofstay := offsetafterfirstadmission + timeofstay]
+
   res <- setcolorder(res, c(ids, sta, end))
   res <- rename_cols(res, c(ids, paste0(ids, "_start"),
                             paste0(ids, "_end")), by_ref = TRUE)
-  
+
   as_id_tbl(res, ids[2L], by_ref = TRUE)
 }
 
@@ -361,6 +382,35 @@ id_win_helper.miiv_env <- function(x) {
   order_rename(res, ids, sta, end)
 }
 
+#' @rdname data_utils
+#' @export
+# copy-pasted from mimic
+id_win_helper.picdb_env <- function(x) {
+
+  merge_inter <- function(x, y) {
+    merge(x, y, by = intersect(colnames(x), colnames(y)))
+  }
+
+  get_id_tbl <- function(tbl, id, start, end, aux) {
+    as_src_tbl(x, tbl)[, c(id, start, end, aux)]
+  }
+
+  cfg <- sort(as_id_cfg(x), decreasing = TRUE)
+
+  ids  <- field(cfg, "id")
+  sta <- field(cfg, "start")
+  end  <- field(cfg, "end")
+
+  res <- Map(get_id_tbl, field(cfg, "table"), ids, sta,
+             end, c(as.list(ids[-1L]), list(NULL)))
+  res <- Reduce(merge_inter, res)
+
+  res <- res[, c(sta, end) := lapply(.SD, as_dt_min, get(sta[1L])),
+             .SDcols = c(sta, end)]
+
+  order_rename(res, ids, sta, end)
+}
+
 #' @export
 id_win_helper.default <- function(x) stop_generic(x, .Generic)