Derive SOFA score

derive_sofa.R

gen.sofa.c <- function(bpsys, bpdia, rxcvs_drug=NULL, rxcvs_dose=NULL) {

    rx1 <- c("Adrenaline", "Noradrenaline")
    rx2 <- c("Dopamine")
    rx3 <- c("Vasopressin")
    rx  <- c(rx1, rx2, rx3, "Other")

    # Print these descriptions so you know what you have passed to the function
    bpmap <- round(bpdia + (bpsys - bpdia) / 3)

    # Work out if SOFA score can be calculated
    chk.possible <- ifelse( !is.na(bpsys), TRUE,FALSE)

    # SOFA via blood pressure
    sofa.c <- ifelse(is.na(bpmap) & bpsys >= 90, 0, NA)
    sofa.c <- ifelse(bpmap >= 70 | bpsys >= 90, 0, NA)
    sofa.c <- ifelse(bpsys < 90, 1, sofa.c)
    sofa.c <- ifelse(bpmap < 70, 1, sofa.c)

    # SOFA via drugs
    if (all(!is.null(rxcvs_drug), !is.null(rxcvs_dose))) {

        chk.possible <- ifelse(!is.na(bpsys) | rxcvs_drug %in% rx, TRUE,FALSE)

        rx_ok <- ifelse(!is.na(rxcvs_drug), TRUE, FALSE)
        # Any vasoactive drug score 2
        sofa.c <- ifelse(rx_ok & rxcvs_drug %in% rx, 2, sofa.c)
        # Arbitrary decision to encode vasopressin to SOFA 4
        sofa.c <- ifelse(rx_ok & rxcvs_drug == rx3, 4, sofa.c)

        rx_ok <- ifelse(!is.na(rxcvs_drug) & !is.na(rxcvs_dose), TRUE, FALSE)
        # Drug and dose
        sofa.c <- ifelse(rx_ok & rxcvs_drug == rx2 & rxcvs_dose <= 5, 2, sofa.c)
        sofa.c <- ifelse(rx_ok & rxcvs_drug == rx2 & rxcvs_dose > 5, 3, sofa.c)
        sofa.c <- ifelse(rx_ok & rxcvs_drug %in% rx1 & rxcvs_dose <= 0.1, 3, sofa.c)
        sofa.c <- ifelse(rx_ok & rxcvs_drug %in% rx1 & rxcvs_dose > 0.1, 4, sofa.c)
        sofa.c

    }
    print(describe(sofa.c))
    return(sofa.c)
}

gen.sofa.r <- function(pf, rxfio2, sf=NULL) {
    # attach(wdt.long)
    # Print these descriptions so you know what you have passed to the function
    print(describe(pf))
    print(describe(sf))
    print(describe(rxfio2))
    mv <- c("IPPV", "NIV", "CPAP")
    # Generate a vector of responses
    # Handle missing data by updating in 2 stages
    # Stage 1 test for the condition with default NA
    # Stage 2 update if not NA
    sofa.r <- ifelse(is.na(pf), NA, 0) # pf available then zero else NA
    update <- ifelse(pf < 100/7.6 & rxfio2 %in% mv, 4, NA)
    sofa.r <- ifelse(!is.na(update), update, sofa.r)
    update <- ifelse(pf >= 100/7.6 & pf < 200/7.6 & rxfio2 %in% mv, 3, NA)
    sofa.r <- ifelse(!is.na(update), update, sofa.r)
    update <- ifelse(pf >=200/7.6 & pf < 300/7.6, 2, NA)
    sofa.r <- ifelse(!is.na(update), update, sofa.r)
    update <- ifelse(pf >= 300/7.6 & pf < 400/7.6, 1, NA)
    sofa.r <- ifelse(!is.na(update), update, sofa.r)
    print(describe(sofa.r))

    # Use SF ratio if available for scores
    # PF takes priority and update only if not available
    if (!is.null(sf)) {
        update <- ifelse(is.na(pf) & sf < 115 & rxfio2 %in% mv, 4, NA)
        sofa.r <- ifelse(!is.na(update), update, sofa.r)
        update <- ifelse(is.na(pf) & sf >= 115 & sf < 240 & rxfio2 %in% mv, 3, NA)
        sofa.r <- ifelse(!is.na(update), update, sofa.r)

        # SF < 240 and not IPPV/NIV then assign two points
        update <- ifelse(is.na(pf) & sf < 240 & (!(rxfio2 %in% mv) | is.na(rxfio2)), 2, NA)
        sofa.r <- ifelse(!is.na(update), update, sofa.r)
        update <- ifelse(is.na(pf) & sf >= 240 & sf < 370, 2, NA)
        sofa.r <- ifelse(!is.na(update), update, sofa.r)
        update <- ifelse(is.na(pf) & sf >= 370 & sf < 440, 1, NA)
        sofa.r <- ifelse(!is.na(update), update, sofa.r)
        # Do not assign zero if ventilated
        update <- ifelse(is.na(pf) & sf >= 440 & !(rxfio2 %in% mv), 0, NA)
        sofa.r <- ifelse(!is.na(update), update, sofa.r)
        print(describe(sofa.r))
    }
    # Test if PF != NA then sofa.r exists
    assert_that(sum(is.na(sofa.r)) <= sum(is.na(pf)))
    return(sofa.r)
    # detach(wdt.long)
}

gen.fio2pct <- function(value, unit) {
    # Convert FiO2 to percent
    # Uses ICNARC CMPD recommended conversion
    fio2.pct <- ifelse(unit == "percent", value,
        ifelse(unit == "litres per min" & value >= 8 & value <= 30 , 50,
        ifelse(unit == "litres per min" & value >= 7 & value < 8 , 45,
        ifelse(unit == "litres per min" & value >= 6 & value < 7 , 40,
        ifelse(unit == "litres per min" & value >= 5 & value < 6 , 35,
        ifelse(unit == "litres per min" & value >= 4 & value < 5 , 30,
        ifelse(unit == "litres per min" & value >= 3 & value < 4 , 27,
        ifelse(unit == "litres per min" & value >= 2 & value < 3 , 25, 21
            ))))))))
    return(fio2.pct)
}


gen.pf <- function(pao2, fio2.pct) {
    assert_that(is.na(fio2.pct) || fio2.pct >= 21)
    assert_that(is.na(fio2.pct) || fio2.pct <= 100)
    assert_that(is.na(pao2) || pao2 <= 101)
    pf <- NA
    pf <- pao2 / fio2.pct * 100
    return(pf)
}

gen.sf <- function(spo2, fio2.pct) {
    assert_that(is.na(fio2.pct) || fio2.pct >= 21)
    assert_that(is.na(fio2.pct) || fio2.pct <= 100)
    assert_that(is.na(spo2) || spo2 <= 100)
    sf <- NA
    sf <- spo2 / fio2.pct * 100
    return(sf)
}

gen.sofa.p <- function(platelets, rxplat=NULL) {
    '
    Defines SOFA coagulation score based on platelet count
    In addition, if platelets have been administered then
    automatically assumes SOFA >= 2
    '
    print(describe(platelets))
    print(describe(rxplat))
    assert_that(identical(names(table(wdt.long$rxplat)),c("FALSE","TRUE")))
    # NB cut ranges are (a,b] i.e. a<x<=y
    sofa.p <- cut(
        platelets,
        c(-Inf,19,49,99,149,+Inf),
        labels= c(4,3,2,1,0))
    # Cut returns a factor unless labels = FALSE
    sofa.p <- as.numeric(levels(sofa.p))[sofa.p]
    if (!is.null(rxplat)) {
        update <- ifelse(
            rxplat %in% c("TRUE", "True", TRUE) &
            platelets >= 150 , 2, NA)
        sofa.p <- ifelse(!is.na(update), update, sofa.p)
    }
    print(describe(sofa.p))
    return(sofa.p)
}


gen.sofa.h <- function(bili) {
    '
    Defines SOFA liver score based on bilirubin
    '
    attach(wdt.long)
    print(describe(bili))
    # NB cut ranges are (a,b] i.e. a<x<=y
    sofa.h <- cut(
        bili,
        c(-Inf,19,32,101,204,+Inf),
        labels=c(0,1,2,3,4))
    # Cut returns a factor unless labels = FALSE
    sofa.h <- as.numeric(levels(sofa.h))[sofa.h]
    print(describe(sofa.h))
    return(sofa.h)
}

gen.sofa.n <- function(gcst, avpu=NULL, rxsed=NULL) {
    attach(wdt.long)
    # Print these descriptions so you know what you have passed to the function
    print(describe(gcst))
    sofa.n <- cut(
        gcst,
        c(2,6,9,12,14,15),
        labels=c(4,3,2,1,0))
    sofa.n <- as.numeric(levels(sofa.n))[sofa.n]

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

    # Now use AVPU if provided
    if (!is.null(avpu)) {
        print(describe(avpu))
        update <- ifelse(avpu %in% c("Alert - not confused"), 0, NA)
        sofa.n <- ifelse(!is.na(update), update, sofa.n)

        update <- ifelse(avpu %in% c("Alert - new confusion"), 1, NA)
        sofa.n <- ifelse(!is.na(update), update, sofa.n)

        update <- ifelse(avpu %in% c("Verbal response"), 2, NA)
        sofa.n <- ifelse(!is.na(update), update, sofa.n)

        update <- ifelse(avpu %in% c("Response to pain"), 3, NA)
        sofa.n <- ifelse(!is.na(update), update, sofa.n)

        update <- ifelse(avpu %in% c("Unresponsive"), 4, NA)
        sofa.n <- ifelse(!is.na(update), update, sofa.n)
    }

    print(describe(sofa.n))
    return(sofa.n)
}

gen.sofa.k <- function(creatinine, urine24, urine1=NULL, rxrrt=NULL) {

    print(creatinine)
    print(urine24)
    # NB cut ranges are (a,b] i.e. a<x<=y
    sofa.k <- cut(
        creatinine,
        c(-Inf,109,170,300,440,+Inf),
        labels= c(0,1,2,3,4))
    sofa.k
    sofa.k <- as.numeric(levels(sofa.k))[sofa.k]
    print(describe(sofa.k))

    # If RRT information provided
    if (!is.null(rxrrt)) {
        update <- ifelse(
            rxrrt %in% c("TRUE", "True", TRUE), 4, NA)
        sofa.k <- ifelse(!is.na(update), update, sofa.k)
    }
    print(describe(sofa.k))

    # Don't use hourly urines for now - not part of SOFA definition
    if (is.null(urine1)) {
        urine.sofa <- urine24
    } else {
        # Prioritise 24h urine over hourly measures
        urine.sofa <- ifelse(!is.na(urine24), urine24, 24 * urine1)
    }

    update <- ifelse(urine.sofa >=200 & urine.sofa < 500, 3, NA)
    sofa.k <- ifelse(!is.na(update), max(update,sofa.k,na.rm=TRUE), sofa.k)
    update <- ifelse(urine.sofa >=0 & urine.sofa < 200, 4, NA)
    sofa.k <- ifelse(!is.na(update), max(update,sofa.k,na.rm=TRUE), sofa.k)

    print(describe((sofa.k)))
    return(sofa.k)
}