Sic bugfixes (#10)

* define SIC data structure

* add SIC to auto attach

* add SIC loading helpers

* add callback hooks to postprocess tbls on import

* add callback to deserialise sicdb data_float_h

* add missing tbl_callback function

* add sic_itm inspired by hrd_itm

* adjust data_float_h config to recent changes

* add hr and crea as examples for sicdb

* add sex and death concepts for sic

* add vitals, labs, height, and weight concepts for sic

* add age and los_icu concepts

* add most medication concepts for sic

* fix preproc for data_float_h

some values are only taken once during the hour and thus have a cnt=1 and rawdata=NA. The actual data is stored in Val, which otherwise holds the average. Since after expansion, rawdata is the main data field, the value from Val needs to be moved to rawdata in this case.

* add OMR to miiv

* add miiv omr

* load_concepts() concepts arg doc fix

* load_concepts.integer() src NULL fix

* Fix sic config

* Properly support full rawdata found in sic

* Remove print

* Add utility functions proposed by `prockenschaub` here: https://github.com/eth-mds/ricu/pull/30/files

* Fix configs for `sic` based on `prockenschaub`

* Fix `sic` configs based on https://github.com/prockenschaub/ricu-package/tree/sicdb

* Remove prints and use ricu msg

* Remove redundant `report_probolems`

* Add prints and tempdir arg

* Cleanup prints

* Fix blood_gas config

* Fix sic table config

* Use finer resolution rawdata where available

* Pass tbl callback correctly

* Fix missing callback application

* Apply callback before split_write

* Config updates:
- Fix sic bugs
- Slack temp range

* Fix configs

* Fix callback

* Use `apply_map` for `sic` `sex`

---------

Co-authored-by: prockenschaub <rockenschaub.patrick@gmail.com>
Co-authored-by: Drago <www.plecko@gmail.com>

R/callback-itm.R

@@ -629,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))
@@ -662,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
@@ -778,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

@@ -186,7 +186,6 @@ load_difftime.picdb_tbl <- function(x, rows, cols = colnames(x),
                                    time_vars = ricu::time_vars(x), ...) {
 
   warn_dots(...)
-
   load_mihi(x, {{ rows }}, cols, id_hint, time_vars)
 }
 

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)
 }