inst/doc/missing.R

In simstudy: Simulation of Study Data

## ----chunkname, echo=-1-------------------------------------------------------
data.table::setDTthreads(2)

## ----echo = FALSE, message = FALSE--------------------------------------------
library(simstudy)
library(ggplot2)
library(scales)
library(grid)
library(gridExtra)
library(survival)
library(gee)
library(data.table)

ggmissing <- function(dtPlot,varSelect=NULL,varLevel=NULL, idvar = "id",
                      periodvar = "period", missvar,
                      pcolor="#738e75", title = NULL) {

  dtP <- copy(dtPlot)

  if (! is.null(varSelect)) dtP <- dtP[eval(parse(text=varSelect)) == varLevel]

  xp <- ggplot(data=dtP, aes(y = factor(eval(parse(text=idvar))),
                             x = eval(parse(text=periodvar)))) +
    geom_tile(aes(fill=factor(eval(parse(text=missvar)))),
                  color="white") +
    ggtheme()+
    theme(axis.text=element_blank(),
          axis.ticks=element_blank(),
          axis.title=element_blank(),
          legend.position="none",
          plot.title=element_text(size=8)
    ) +
    scale_fill_manual(values=c("grey80",pcolor))

  if (is.null(title)) {
    return(xp)
  } else {
    return(xp + ggtitle(title))
  }
}
plotcolors <- c("#B84226", "#1B8445", "#1C5974")

cbbPalette <- c("#B84226","#B88F26", "#A5B435", "#1B8446",
                "#B87326","#B8A526", "#6CA723", "#1C5974") 

ggtheme <- function(panelback = "white") {
  
  ggplot2::theme(
    panel.background = element_rect(fill = panelback),
    panel.grid = element_blank(),
    axis.ticks =  element_line(colour = "black"),
    panel.spacing =unit(0.25, "lines"),  # requires package grid
    panel.border = element_rect(fill = NA, colour="gray90"), 
    plot.title = element_text(size = 8,vjust=.5,hjust=0),
    axis.text = element_text(size=8),
    axis.title = element_text(size = 8)
  )  
  
}

## ----tidy = TRUE--------------------------------------------------------------
def1 <- defData(varname = "m", dist = "binary", formula = .5)
def1 <- defData(def1, "u", dist = "binary", formula = .5)
def1 <- defData(def1, "x1", dist="normal", formula = "20*m + 20*u", variance = 2)
def1 <- defData(def1, "x2", dist="normal", formula = "20*m + 20*u", variance = 2)
def1 <- defData(def1, "x3", dist="normal", formula = "20*m + 20*u", variance = 2)

dtAct <- genData(1000, def1)

## ----tidy = TRUE--------------------------------------------------------------
defM <- defMiss(varname = "x1", formula = .15, logit.link = FALSE)
defM <- defMiss(defM, varname = "x2", formula = ".05 + m * 0.25", logit.link = FALSE)
defM <- defMiss(defM, varname = "x3", formula = ".05 + u * 0.25", logit.link = FALSE)
defM <- defMiss(defM, varname = "u", formula = 1, logit.link = FALSE) # not observed

set.seed(283726)

missMat <- genMiss(dtAct, defM, idvars = "id")
dtObs <- genObs(dtAct, missMat, idvars = "id")

## ----tidy = TRUE--------------------------------------------------------------
missMat
dtObs

## ----tidy=TRUE----------------------------------------------------------------
# Two functions to calculate means and compare them

rmean <- function(var, digits = 1) {
  round(mean(var, na.rm=TRUE), digits)
}

showDif <- function(dt1, dt2, rowName = c("Actual", "Observed", "Difference")) {
  dt <- data.frame(rbind(dt1, dt2, dt1 - dt2))
  rownames(dt) <- rowName
  return(dt)
}

# data.table functionality to estimate means for each data set

meanAct <- dtAct[,.(x1 = rmean(x1), x2 = rmean(x2), x3 = rmean(x3))]
meanObs <- dtObs[,.(x1 = rmean(x1), x2 = rmean(x2), x3 = rmean(x3))]

showDif(meanAct, meanObs)

## ----tidy=TRUE----------------------------------------------------------------
meanActm <- dtAct[,.(x1 = rmean(x1), x2 = rmean(x2), x3 = rmean(x3)), keyby = m]
meanObsm <- dtObs[,.(x1 = rmean(x1), x2 = rmean(x2), x3 = rmean(x3)), keyby = m]

## ----tidy = TRUE--------------------------------------------------------------
# compare observed and actual when m = 0

showDif(meanActm[m==0, .(x1, x2, x3)], meanObsm[m==0, .(x1, x2, x3)])

# compare observed and actual when m = 1

showDif(meanActm[m==1, .(x1, x2, x3)], meanObsm[m==1, .(x1, x2, x3)])

## ----tidy = TRUE--------------------------------------------------------------

# use baseline definitions from the previous example

dtAct <- genData(120, def1)
dtAct <- trtObserve(dtAct, formulas = .5, logit.link = FALSE, grpName = "rx")

# add longitudinal data

defLong <- defDataAdd(varname = "y", dist = "normal", formula = "10 + period*2 + 2 * rx", variance = 2)

dtTime <- addPeriods(dtAct, nPeriods = 4)
dtTime <- addColumns(defLong, dtTime)

## ----tidy = TRUE--------------------------------------------------------------

# missingness for y is not monotonic

defMlong <- defMiss(varname = "x1", formula = .20, baseline = TRUE)
defMlong <- defMiss(defMlong,varname = "y", formula = "-1.5 - 1.5 * rx + .25*period", logit.link = TRUE, baseline = FALSE, monotonic = FALSE)

missMatLong <- genMiss(dtTime, defMlong, idvars = c("id","rx"), repeated = TRUE, periodvar = "period")

## ----tidy=TRUE, echo=FALSE, fig.width = 7, fig.height = 6---------------------
xp10 <- ggmissing(missMatLong, varSelect="rx", varLevel = 0, idvar = "id",
                 periodvar = "period", missvar="x1", pcolor="#1C5974",
                 title = "x1: baseline (control)")

xp11 <- ggmissing(missMatLong, varSelect="rx", varLevel = 1, idvar = "id",
                 periodvar = "period", missvar="x1", pcolor="#B84226",
                 title = "x1: baseline (exposed)")

xp20 <- ggmissing(missMatLong, varSelect="rx", varLevel = 0, idvar = "id",
                 periodvar = "period", missvar="y", pcolor="#1C5974",
                 title = "y: not monotonic (control)")

xp21 <- ggmissing(missMatLong, varSelect="rx", varLevel = 1, idvar = "id",
                 periodvar = "period", missvar="y", pcolor="#B84226",
                 title = "y: not monotonic (exposed)")

grid.arrange(xp10, xp20, xp11, xp21,
             nrow = 2,
             bottom = textGrob("Periods", gp = gpar(cex=.8)) #,
#             left = textGrob("ID", gp = gpar(cex = .8), rot = 90)
)



## ----tidy=TRUE----------------------------------------------------------------
# missingness for y is monotonic

defMlong <- defMiss(varname = "x1", formula = .20, baseline = TRUE)
defMlong <- defMiss(defMlong,varname = "y", formula = "-1.8 - 1.5 * rx + .25*period", logit.link = TRUE, baseline = FALSE, monotonic = TRUE)

missMatLong <- genMiss(dtTime, defMlong, idvars = c("id","rx"), repeated = TRUE, periodvar = "period")

## ----tidy=TRUE, echo=FALSE, fig.width = 7, fig.height = 6---------------------
xp10 <- ggmissing(missMatLong, varSelect="rx", varLevel = 0, idvar = "id",
                 periodvar = "period", missvar="x1", pcolor="#1C5974",
                 title = "x1: baseline (control)")

xp11 <- ggmissing(missMatLong, varSelect="rx", varLevel = 1, idvar = "id",
                 periodvar = "period", missvar="x1", pcolor="#B84226",
                 title = "x1: baseline (exposed)")

xp20 <- ggmissing(missMatLong, varSelect="rx", varLevel = 0, idvar = "id",
                 periodvar = "period", missvar="y", pcolor="#1C5974",
                 title = "y: monotonic (control)")

xp21 <- ggmissing(missMatLong, varSelect="rx", varLevel = 1, idvar = "id",
                 periodvar = "period", missvar="y", pcolor="#B84226",
                 title = "y: monotonic (exposed)")

grid.arrange(xp10, xp20, xp11, xp21,
             nrow = 2,
             bottom = textGrob("Periods", gp = gpar(cex=.8)) #,
#             left = textGrob("ID", gp = gpar(cex = .8), rot = 90)
)