Added a couple of experimental functions

.Rbuildignore

@@ -0,0 +1,2 @@
+^.*\.Rproj$
+^\.Rproj\.user$

DESCRIPTION

@@ -18,4 +18,4 @@ Suggests:
     ggplot2,
     dplyr,
     testthat
-RoxygenNote: 5.0.1
+RoxygenNote: 6.0.1

NAMESPACE

@@ -7,11 +7,13 @@ export(convert_numeric)
 export(find_NHIC)
 export(gen_admx.cat)
 export(gen_age)
+export(gen_apache_hr)
 export(gen_los.hosp)
 export(gen_los.icu)
 export(gen_male)
 export(gen_map)
 export(gen_mortality)
+export(gen_neuro)
 export(gen_pmhx.sum)
 export(gen_ppv)
 export(gen_sofa_c)

R/gen_apache_hr.R

@@ -0,0 +1,69 @@
+#' @title Generates the APACHE Heart Rate score
+#'
+#' @description
+#' Generates the APACHE Heart Rate score;
+#'
+#' @import data.table
+#' @param dt data.table containing physiology data
+#' @param h_rate_ numeric variable containing the heart rate
+#' @param hours_ numeric variable containg the number of hours since ICU admission
+#' @param id_ unique patient identifier
+#' @param window_ Numerical.Vector delimiting boundaries for time-window.
+#' 
+#'@examples
+#' ddata <- NULL
+#' hr <- "Heart rate"
+#' ddata$"time" <- sample(seq(1,72,1), 200, replace = T)
+#' ddata <- as.data.table(ddata)
+#' ddata[, ("site") := sample(c("XX", "ZZ", "YY"), 200, replace = T)]
+#' ddata[, ("episode_id") := sample(seq(1,250,1), 200, replace = T)]
+#' ddata[, ("Heart rate") := sample(seq(30,120,1), 200, replace = T)]
+#' system.time(gen_apache_hr(ddata, window = c(0,24)))
+#' ddata[time %between% c(0,24), .N, by = c("site","episode_id", "apache_hr")]
+#'
+#' @export
+
+
+gen_apache_hr <- function(dt, h_rate_, hours_, id_, window_ = c(0,24)) {
+        #  =============================
+        #  = APACHE - Heart Rate =
+        #  =============================
+        # appending _ to var names for readability and to ensure uses scoped version
+
+        # Non-standard evaluation
+        pars <- as.list(match.call()[-1])
+
+        h_rate_ <- as.character(pars$h_rate_)
+        hours_ <- as.character(pars$hours_)
+        id_ <- as.character(pars$id_)
+
+
+        # library(data.table)
+        # data.table changes the object in place unless you use dt1 <- copy(dt)
+        # so passing data.tables via function is actually just passing a reference
+
+        # Naming  the apache_hr
+        apache_hr <- "apache_hr"
+
+        # Update based on conditions
+        # Order of conditions is IMPORTANT
+
+        dt[, (apache_hr) := as.numeric(NA)]
+
+        # APACHE = 0
+        dt[get(h_rate_) %between% c(70,109), (apache_hr) := 0]
+
+        # APACHE = 2
+        dt[(get(h_rate_) %between% c(55,69)) | (get(h_rate_) %between% c(110,139)), (apache_hr) := 2]
+
+        # APACHE = 3
+        dt[(get(h_rate_) %between% c(40,54)) | (get(h_rate_) %between% c(140,179)), (apache_hr) := 3]
+
+        # APACHE = 4
+        dt[(get(h_rate_) < c(40)) | (get(h_rate_) > c(179)), (apache_hr) := 4]
+
+        # Calculate APACHE score for time window
+        dt[get(hours_) %between% window_, (apache_hr) := max(apache_hr, na.rm = T), by = get(id_)]             [apache_hr == -Inf, apache_hr := NA]
+
+
+}

R/gen_neuro.R

@@ -0,0 +1,111 @@
+#' @title Generates the neuro score for various scoring systems
+#'
+#' @description
+#' Generates the neuro score; requires GCS
+#'
+#' @import data.table
+#' @param dt data.table containing physiology data
+#' @param score score that the nero component is to be calculated for
+#' @param gcs_ GCS total score
+#' @param hours_ hours since ICU admission
+#' @param id_ unique id for each patient
+#' 
+#' @examples
+#' # gen_neuro(ddata,sofa, gcs_ = gcs)
+#' # table(ddata$sofa_n, useNA="always")
+#' # ddata[gcs<=15][sample(nrow(ddata[gcs<=15]),20), .(gcs, sofa_n)]
+
+#' @export
+gen_neuro <- function(dt, score, gcs_, hours_, id_) {
+
+        #Checking that the score argument is valid so that the function is not trying to calculate
+        #an impossible score.
+
+        if (score != "sofa" & score != "apache ii") {
+          stop("score must be a string containing either 'sofa' or 'apache ii'", call. = FALSE)      
+
+
+
+         #Choosing which score to calculate based on the score argument.        
+        } else if (score == "sofa") {
+                #  ==============
+                #  = SOFA - GCS =
+                #  ==============
+
+                # appending _ to var names for readability and to ensure uses scoped version
+
+                # library(data.table)
+                # data.table changes the object in place unless you use dt1 <- copy(dt)
+                # so passing data.tables via function is actually just passing a reference
+
+                # Non-standard evaluation
+                pars <- as.list(match.call()[-1])
+
+                gcs_ <- as.character(pars$gcs_)
+
+                # Set to NA by default (numeric)
+                dt[, `:=`(sofa_n = as.numeric(NA))]
+
+                # Update based on conditions
+                # Order of conditions is IMPORTANT
+
+                # SOFA = 0
+                dt[get(gcs_) == 15, "sofa_n" := 0]
+
+                # SOFA = 1
+                dt[get(gcs_) <= 14, "sofa_n" := 1]
+
+                # SOFA = 2
+                dt[get(gcs_) <= 12, "sofa_n" := 2]
+
+                # SOFA = 3
+                dt[get(gcs_) <=  9, "sofa_n" := 3]
+
+                # SOFA = 4
+                dt[get(gcs_) <=  5, "sofa_n" := 4]
+
+                # - [ ] TODO(2016-05-21):  Now set to NA if patient sedated
+                # if (!is.null(rxsed)) {
+                #     print(describe(rxsed))
+                #     update <- ifelse(rxsed %in% c("True", "TRUE", TRUE), NA, sofa.n)
+                #     describe(update)
+                #     sofa.n <- ifelse(is.na(update), NA, update)
+                #     print(describe(sofa.n))
+                # }
+
+        } else if (score == "apache ii") {
+
+                #  ==============
+                #  = APACHE II - GCS =
+                #  ==============
+
+                # appending _ to var names for readability and to ensure uses scoped version
+
+                 # Non-standard evaluation
+                pars <- as.list(match.call()[-1])
+
+                gcs_ <- as.character(pars$gcs_)
+                hours_ <- as.character(pars$hours_)
+                id_ <- as.character(pars$id_)
+
+                # Set to NA by default (numeric)
+                dt[, `:=`(apache_n = as.numeric(NA))]
+
+                #apache ii gcs component is based on the lowest score in the first 24 hours 
+                #after admission.
+                #So, we select the lowest gcs score in the first 24 hours after admission. This is the second pipe.
+                #The third pipe replaces values that were recorded as -Inf into NAs. This happenes if there is no gcs score recorded in the first 24 hours after admission.
+
+                #Function generates warnings when patientes have no non missing gcs scores in the first 
+                #24 hours following admssion. 
+                dt[get(hours_) <= 24, "apache_n" := 15 - get(gcs_)][, apache_n := max(apache_n, na.rm =                 T), by = (get(id_))][apache_n == -Inf, apache_n := NA]
+
+
+
+        }
+
+}
+
+
+
+

tests/testthat/test_apache_ii.R

@@ -0,0 +1,17 @@
+context("Testing APACHE II score generating functions")
+
+# First arg = description of function
+# Subsequent args = function for testing e.g. expect_equal
+
+
+
+test_that("Check neuro score generator apache ii component.", {
+        dd <- data.table(
+                gcs   = c(10, 12, 13, 15, 3, 5, 5, 7, 15, 15),
+                time = c(0,30,0, 24,0,0,0, 22, 26, 70),
+                id  = c(1,1,2, 3, 4, 5, 6, 7,7, 8) )
+        # print(dd)
+        gen_neuro(dd, "apache ii", gcs_ = gcs, hours_=time, id_=id)
+        expect_equivalent(dd$apache_n, c(5, 5, 2, 0, 12, 10, 10, 8, 8, NA))
+        expect_error(suppressWarnings(gen_neuro(dd,"apache iii")))
+})