Add utility functions proposed by prockenschaub here: https://githu…

…b.com/eth-mds/ricu/pull/30/files

R/concept-utils.R

@@ -199,6 +199,29 @@ 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 +353,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 +573,17 @@ 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.col_itm <- function(x, ...) {
@@ -604,6 +642,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/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)
 }