In NikKrieger/daps: Enables the Creation of Dynamically Adaptive Probabilistic Systems

knitr::opts_chunk$set(
  collapse = TRUE,
  comment = "#>",
  fig.path = "man/figures/README-",
  out.width = "100%"
)

daps

The goal of daps is to ...

Installation

You can install the development version of daps from GitHub with:

# install.packages("remotes")
remotes::install_github("NikKrieger/daps")

Create a daps object

Create a daps-class object and add a metastate model as well as individual variable models.

library(ordinal)
library(nnet)
library(tidyverse)
library(daps)

topological sorting: first do all the static variables and then temporal check for intra-timeslice dependencies.

For each variable:

#   (1) get model (models have binary flag that indicate intra-timeslice dependencies)
#       if max of flags is 1, go into subroutine in order to generate dag and topological sort

daps1 <-
  daps() %>% 

  add_models(

    diabetes(t) := glm(~sex + lag(dbp, 2) + lag(sbp) + lag(dbp) + lag(sbp, 2) + race + age, family = binomial),

    age(t) := lag(age) + 1,

    sbp(t) := list(
      lm(~ lag(sbp) + lag(dbp) + sex + race + age),
      lm(~ sex + race + age),
      lag(sbp),
      rnorm(1, 130, 15)
    ),

    dbp(t) := lm(~lag(sbp) + lag(dbp) + sex + race + age),
    dbp(t) := lm(~sex + race + age),

    dbp(t) := lm(~sbp),

    # Find a way to determine the intratimeslice variables each model is using.
    # During simulation, when you come across one that has at least one intraslice model, do the others first.

    diabetes(t) := glm(~sex + race + age + lag(sbp) + lag(dbp), family = binomial),
    diabetes(t) := glm(~sex + race + age, family = binomial),

    chd_risk(t) := list(
      clm(~ lag(sbp) + lag(dbp) + sex + race + age),
      multinom(~ lag(sbp) + slide_mean(dbp) + sex + race + age)
    ),

    glucose(t) := lm(~sbp + dbp + diabetes + age + sex + race),
    glucose(t) := lm(~sbp + dbp + age + sex + race),
    glucose(t) := lm(~diabetes + age + sex + race),
    glucose(t) := lm(~age + sex + race),
    glucose(t) := lag(glucose)

    # sex := categorical(c("M", "F"), M = .495),
    # sex := factor(rbinom(1, 1, .505), 0:1, c("Male", "Female")),
    # 
    # 
    # race := categorical(M = .495, F = .505),
    #   factor(
    #     1:3 %*% rmultinom(1, 1, c(.7, .25, .05)),
    #     1:3,
    #     c("White", "Black", "Other")
    #   )

  ) %>%

  add_metastate_model(
    metastate = c("state1", "state2", "state3"),
    nodes =
      list(
        c("age", "sbp", "dbp", "chd_risk", "diabetes"),
        c("age", "sbp", "dbp", "chd_risk", "diabetes"),
        c("age", "sbp", "dbp", "chd_risk", "diabetes", "glucose")
      ),
    transitions =
      list(
        ~case_when(
          lag(sbp) >= 135 | lag(dbp) >= 80                            ~ "state3",
          lag(chd_risk) == "elevated" | sex == "male" & lag(age) > 35 ~ "state2",
          TRUE                                                        ~ "state1"
        ),
        ~case_when(
          lag(sbp) >= 135 | lag(dbp) >= 80                            ~ "state3",
          TRUE                                                        ~ "state2"
        ),
        ~case_when(
          TRUE                                                        ~ "state3"
        )
      )
  )

daps1

teststatic <- 
  tribble(
    ~id, ~sex,     ~race,
    1,   "male",   "black",
    2,   "female", "white",
    3,   "male",   "black",
    4,   "male",   "white",
    6,   "female", "black"
  )

testtemporal <-
  tribble(
    ~id, ~t, ~sbp, ~dbp, ~age, ~diabetes, ~glucose, ~chd_risk,
    1,   1,  120,  65,   35,   FALSE,     NA,       "low",
    1,   2,  119,  66,   36,   FALSE,     NA,       "normal",
    1,   3,  118,  68,   50,   FALSE,     NA,       "normal",
    1,   4,  150,  100,  51,   TRUE,      NA,       "elevated",

    2,   1,  139,  81,   64,   FALSE,     NA,       "normal",
    2,   2,  140,  111,  66,   FALSE,     90,       "elevated",
    2,   3,  137,  85,   66,   TRUE,      100,      "elevated",
    2,   4,  155,  90,   66,   TRUE,      99,       "elevated",

    3,   1,  100,  40,   34,   TRUE,      NA,       "low",
    3,   2,  114,  45,   34,   FALSE,     NA,       "low",
    3,   3,  100,  50,   34,   FALSE,     NA,       "low",
    3,   4,  103,  56,   34,   FALSE,     NA,       "low",

    4,   1,  115,  110,  85,   FALSE,     125,      "elevated",
    4,   2,  140,  125,  86,   TRUE,      NA,       "elevated",
    4,   3,  NA,   NA,   87,   TRUE,      100,      "elevated",
    4,   4,  NA,   NA,   88,   TRUE,      NA,       "elevated",

    6,   1,  114,  111,  86,   FALSE,     99,       "normal"
  ) %>% 
  mutate_at("chd_risk", ordered, levels = c("low", "normal", "elevated"))

daps_trained <- daps1 %>% train(teststatic, testtemporal)

daps_trained

daps_trained %>% 
simulate(
  static = teststatic, 
  longitudinal = testtemporal, 
  h = NULL,
  from = "last",
  to = 10,
  impute = TRUE,
  seed = 20200123
)

daps_trained %>% 
simulate(
  static = teststatic, 
  longitudinal = testtemporal, 
  h = 1:3,
  from = "last",
  to = 3,
  impute = FALSE,
  seed = 20200123
)

daps_trained %>% 
  simulate(
    static = teststatic,
    longitudinal = testtemporal,
    h = NULL,
    from = 5,
    to = 7,
    impute = "locf"
  )

# Add in a count of patients/observations with incomplete predictions
# impute options:
#   - default: FALSE
#   - locf
#   - simulate at the preceding rows with missingness (cut it off if you have to back more than lookback_steps steps)

# daps() %>%
#   add_models() %>% 
#   add_metastate_model() %>%
#   train() %>%
#   simulate()

NikKrieger/daps documentation built on March 4, 2020, 1:28 p.m.