├── sim-ar1.RData ├── sim-omit.RData ├── sim-stable.RData ├── .gitignore ├── init.R ├── README.md ├── sim-stable.R ├── sim-ar1.R ├── sim-omit.R ├── xzoo.R ├── rsnmm.c ├── example.R ├── example_geepack.R ├── rsnmm.R ├── sim.R ├── example.Rout ├── example_geepack.Rout ├── sim-ar1.Rout ├── sim-stable.Rout ├── xgeepack.R └── sim-omit.Rout /sim-ar1.RData: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/dalmiral/mHealthModeration/HEAD/sim-ar1.RData -------------------------------------------------------------------------------- /sim-omit.RData: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/dalmiral/mHealthModeration/HEAD/sim-omit.RData -------------------------------------------------------------------------------- /sim-stable.RData: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/dalmiral/mHealthModeration/HEAD/sim-stable.RData -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | TAGS 2 | *~ 3 | *.o 4 | *.so 5 | *.dll 6 | *.fuse* 7 | *.bak 8 | .Rhistory 9 | .Rproj.user 10 | *.Rproj -------------------------------------------------------------------------------- /init.R: -------------------------------------------------------------------------------- 1 | library("geepack") 2 | library("zoo") 3 | 4 | source("xgeepack.R") 5 | source("xzoo.R") 6 | 7 | system("R CMD SHLIB rsnmm.c") 8 | dyn.load(if (Sys.info()["sysname"] == "Windows") "rsnmm.dll" else "rsnmm.so") 9 | source("rsnmm.R") 10 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | #### Numerical results for "Assessing time-varying causal effect moderation in mobile health" 2 | 3 | ##### Simulation studies 4 | 5 | The simulation results for each scenario are generated by the following R scripts. Running a script in batch mode from your system command line with, say, 6 | ```shell 7 | R CMD BATCH --vanilla sim-omit.R 8 | ``` 9 | will create R output and simulation data files by the same name; sim-omit.Rout and sim-omit.RData, respectively. 10 | 11 | File | Description 12 | ---- | ---- 13 | [sim-omit.R](sim-omit.R) | Averaging over an underlying moderator 14 | [sim-stable.R](sim-stable.R) | Weight stabilization 15 | [sim-ar1.R](sim-ar1.R) | Non-independence working correlation structure 16 | 17 | Each of these scripts call routines defined in the files below. 18 | 19 | File | Description 20 | ---- | ---- 21 | [rsnmm.c](rsnmm.c) | Data generator 22 | [rsnmm.R](rsnmm.R) | Data generator interface 23 | [sim.R](sim.R) | Simulation routine 24 | [init.R](init.R) | Loads required packages and reads source files 25 | [xgeepack.R](xgeepack.R) | Extensions for the geepack R package; extract, from a geepack model object, elements (e.g. working covariance, estimating function) needed for variance calculations 26 | [xzoo.R](xzoo.R) | Extensions for the zoo R package; apply lags, difference, rolling summaries to a sample of time series 27 | 28 | ##### Application to simulated data 29 | 30 | Instead of the application presented in the paper (which considers sensitive data), we provide an example using simulated data---both with and without use of the geepack R package. The zoo R package is used to easily define variables, but is not needed for estimation. 31 | 32 | File | Description 33 | ---- | ---- 34 | [example_geepack.R](example.R) | Loads geepack and zoo extensions, generates data and runs an analysis similar to the application presented in the paper 35 | [example_geepack.Rout](example.Rout) | Provides the output obtained by running the example in batch mode 36 | [example.R](example.R) | Loads zoo extensions, generates data and runs an analysis similar to the application presented in the paper 37 | [example.Rout](example.Rout) | Provides the output obtained by running the example in batch mode 38 | -------------------------------------------------------------------------------- /sim-stable.R: -------------------------------------------------------------------------------- 1 | library("foreach") 2 | library("doParallel") 3 | library("parallel") 4 | source("init.R") 5 | source("sim.R") 6 | 7 | ## set number of Monte Carlo replicates 8 | M <- 1000 9 | 10 | ## set number of threads to use for parallel processing and the random seed 11 | ## nb: these two values ensure that the results are replicable 12 | cores <- 2 13 | seed <- 0 14 | 15 | cl <- makeCluster(getOption("cl.cores", cores)) 16 | clusterEvalQ(cl, source("init.R")) 17 | registerDoParallel(cl) 18 | 19 | sim.stable <- function() { 20 | out <- NULL 21 | for (n in c(30,60)) { 22 | for (tmax in c(30,50)) { 23 | clusterSetRNGStream(cl, seed) 24 | out <- rbind(out, 25 | sim(n, tmax, M, 26 | ## regress response on proximal treatment, centered by a 27 | ## probability that is either (i) constant over time or 28 | ## (ii) time-varying 29 | y.formula = list(fixed = y ~ state + I(a - pfixed), 30 | vary = y ~ state + I(a - pvary)), 31 | y.names = c(fixed = "Constant in $t$ (i)", 32 | vary = "Depends on $S_t$ (ii)"), 33 | y.label = list(fixed = "I(a - pfixed)", 34 | vary = "I(a - pvary)"), 35 | ## weight regression using the true treatment probability 36 | ## in the denominator 37 | y.args = list(fixed = list(wn = "pfixed", wd = "prob"), 38 | vary = list(wn = "pvary", wd = "prob")), 39 | ## model numerator probability with (i) intercept only and 40 | ## (ii) state, which is time-varying 41 | a.formula = list(pfixed = a ~ 1, 42 | pvary = a ~ state), 43 | a.names = c(pfixed = "Constant in $t$ (i)", 44 | pvary = "Depends on $S_t$ (ii)"), 45 | ## use default generative model, but with medium level of 46 | ## moderation by state and an unmoderated delayed effect 47 | beta0 = c(-0.2, 0, 0, 0.5, 0), 48 | beta1 = c(-0.1, 0, 0, 0) 49 | )) 50 | } 51 | } 52 | out 53 | } 54 | 55 | stable <- sim.stable() 56 | save(stable, file = "sim-stable.RData") 57 | 58 | stopCluster(cl) 59 | -------------------------------------------------------------------------------- /sim-ar1.R: -------------------------------------------------------------------------------- 1 | library("foreach") 2 | library("doParallel") 3 | library("parallel") 4 | source("init.R") 5 | source("sim.R") 6 | 7 | ## set number of Monte Carlo replicates 8 | M <- 1000 9 | 10 | ## set number of threads to use for parallel processing and the random seed 11 | ## (nb: these two values ensure that the results are replicable) 12 | cores <- 2 13 | seed <- 0 14 | 15 | cl <- makeCluster(getOption("cl.cores", cores)) 16 | clusterEvalQ(cl, source("init.R")) 17 | registerDoParallel(cl) 18 | 19 | ## control parameters for the generative model 20 | beta0 <- c(-0.2, 0, 0, 0, 0) # unmoderated proximal effect 21 | beta1 <- c(-0.1, 0, 0, 0) # unmoderated delayed effect 22 | coef.state <- c(0, 0, 0, 0, 0.1) # state depends on past treatment 23 | eta <- rep(0, 5) # treatment probability = 1/2 24 | 25 | sim.ar1 <- function() { 26 | out <- NULL 27 | for (n in c(30, 60)) { 28 | for (tmax in c(30, 50)) { 29 | ## obtain true correlation matrix, trimmed down to effective size 30 | ## ("effective" observations avoid (lags of) initial values) 31 | attrib <- attributes(rsnmm(n, tmax, beta0 = beta0, beta1 = beta1, 32 | coef.state = coef.state, eta = eta)) 33 | ## by default the true correlation structure is AR(1) with (u, t)th error 34 | ## correlation sqrt(0.5)^abs(u - t) 35 | cormatrix <- attrib$cormatrix[1:(tmax - attrib$lag + 1), 36 | 1:(tmax - attrib$lag + 1)] 37 | clusterSetRNGStream(cl, seed) 38 | out <- rbind(out, 39 | sim(n, tmax, M, 40 | ## regress response on proximal treatment, centered by the 41 | ## true treatment probability 42 | y.formula = list(indep = y ~ state + I(a - prob), 43 | ar1 = y ~ state + I(a - prob)), 44 | y.names = c(indep = "Independence", 45 | ar1 = "AR(1)"), 46 | y.label = list(indep = "I(a - prob)", 47 | ar1 = "I(a - prob)"), 48 | ## employ different working correlation structures 49 | y.args = list(indep = list(), 50 | ar1 = list(corstr = "userdefined", 51 | wcor = cormatrix)), 52 | a.formula = NULL, a.names = NULL, 53 | beta0 = beta0, beta1 = beta1, coef.state = coef.state, 54 | eta = eta)) 55 | } 56 | } 57 | out 58 | } 59 | 60 | ar1 <- sim.ar1() 61 | save(ar1, file = "sim-ar1.RData") 62 | 63 | stopCluster(cl) 64 | -------------------------------------------------------------------------------- /sim-omit.R: -------------------------------------------------------------------------------- 1 | library("foreach") 2 | library("doParallel") 3 | library("parallel") 4 | source("init.R") 5 | source("sim.R") 6 | 7 | ## set number of Monte Carlo replicates 8 | M <- 1000 9 | 10 | ## set number of threads to use for parallel processing and the random seed 11 | ## (nb: these two values ensure that the results are replicable) 12 | cores <- 4 13 | seed <- 0 14 | 15 | cl <- makeCluster(getOption("cl.cores", cores)) 16 | clusterEvalQ(cl, source("init.R")) 17 | registerDoParallel(cl) 18 | 19 | sim.omit <- function() { 20 | out <- NULL 21 | ## low, medium and high degrees of moderation by state 22 | for (b in c(0.2, 0.5, 0.8)) { 23 | for (n in c(30, 60)) { 24 | for (tmax in c(30, 50)) { 25 | clusterSetRNGStream(cl, seed) 26 | out <- 27 | rbind(out, 28 | cbind(level = paste("$\\beta_{11}^* = ", b, "$", sep = ""), 29 | sim(n, tmax, M, 30 | ## regress response on state and proximal treatment, 31 | ## ignoring the underlying interaction between the two 32 | y.formula = list(w = y ~ state + I(a - pn), 33 | u.ind = y ~ state + a, 34 | u.ar1 = y ~ state + a, 35 | u.exch = y ~ state + a), 36 | y.names = c(w = "Weighted and centered", 37 | u.ind = "GEE independence", 38 | u.ar1 = "GEE AR(1)", 39 | u.exch = "GEE exchangeable"), 40 | ## term labels for proximal treatment 41 | y.label = list(w = "I(a - pn)", 42 | u.ind = "a", u.ar1 = "a", u.exch = "a"), 43 | ## specify weights and working correlation structure 44 | y.args = list(w = list(wn = "pn", wd = "prob"), 45 | u.ind = list(), 46 | u.ar1 = list(corstr = "ar1"), 47 | u.exch = list(corstr = "exch")), 48 | ## specify weight numerator model 49 | a.formula = list(pn = a ~ 1), 50 | a.names = c(pn = "Intercept-only"), 51 | ## use default generative model, but with the specified 52 | ## level of moderation by the time-varying state 53 | beta0 = c(-0.2, 0, 0, b, 0)))) 54 | } 55 | } 56 | } 57 | out 58 | } 59 | 60 | omit <- sim.omit() 61 | save(omit, file = "sim-omit.RData") 62 | 63 | stopCluster(cl) 64 | -------------------------------------------------------------------------------- /xzoo.R: -------------------------------------------------------------------------------- 1 | ## zoo extras 2 | 3 | ## take first recorded value 4 | baseline <- function(id, time, x) { 5 | s <- splitdata(id, time, x) 6 | u <- unlist(lapply(s, function(y) y[1, 1]), use.names = FALSE) 7 | b <- u <- u[attributes(s)$uid] 8 | b[attributes(s)$order] <- u 9 | ## restore factor class 10 | if (is.factor(x)) 11 | factor(levels(x)[b]) 12 | else 13 | b 14 | } 15 | 16 | ## center or (if sd = TRUE) standardize time-specific values 17 | center <- function(id, time, x, sd = FALSE, na.rm = TRUE) { 18 | z <- zoosplit(splitdata(id, time, x)) 19 | m <- apply(do.call(rbind, lapply(z, coredata)), 2, mean, na.rm = na.rm) 20 | c <- lapply(z, function(y) y - m) 21 | if (sd) { 22 | s <- apply(do.call(rbind, lapply(z, coredata)), 2, sd, na.rm = na.rm) 23 | c <- lapply(c, function(y) y / s) 24 | } 25 | attributes(c) <- attributes(z) 26 | unzoosplit(c) 27 | } 28 | 29 | ## current value minus lagged value, shifted back k time points 30 | ## if current time < k + 1, return fill.value 31 | change <- function(id, time, x, k = 1) { 32 | z <- zoosplit(splitdata(id, time, x)) 33 | d <- lapply(z, function(y) diff(y, lag = k, na.pad = TRUE)) 34 | attributes(d) <- attributes(z) 35 | d <- unzoosplit(d) 36 | d 37 | } 38 | 39 | ## return lagged value, shifted by k time points 40 | delay <- function(id, time, x, k = 1) { 41 | s <- splitdata(id, time, x) 42 | b <- unlist(lapply(s, function(y) y[1, 1]), use.names = FALSE) 43 | b <- b[attributes(s)$uid][attributes(s)$order] 44 | z <- zoosplit(s) 45 | l <- lapply(z, function(y) lag(y, k = -k, na.pad = TRUE)) 46 | attributes(l) <- attributes(z) 47 | l <- unzoosplit(l) 48 | l 49 | } 50 | 51 | ## rolling summary with given right-aligned window width 52 | roll <- function(id, time, x, width, FUN, ...) { 53 | z <- zoosplit(splitdata(id, time, x)) 54 | r <- lapply(z, function(y) 55 | rollapplyr(y, width = width, FUN = FUN, partial = TRUE, ...)) 56 | attributes(r) <- attributes(z) 57 | unzoosplit(r) 58 | } 59 | 60 | ## split data by id 61 | splitdata <- function(id, time, x) { 62 | s <- lapply(split(data.frame(x, order.by = time), id), 63 | function(y) y[order(y$order.by), ]) 64 | attributes(s)$order <- 65 | as.numeric(unlist(lapply(s, rownames), use.names = FALSE)) 66 | nid <- unlist(lapply(s, nrow)) 67 | attributes(s)$id <- as.numeric(rep(names(s), times = nid)) 68 | attributes(s)$uid <- rep(1:length(nid), times = nid) 69 | s 70 | } 71 | 72 | ## apply zoo to output from splitdata 73 | zoosplit <- function(s) { 74 | z <- lapply(s, function(y) do.call(zoo, y)) 75 | attributes(z) <- attributes(s) 76 | z 77 | } 78 | 79 | ## unsplit output from zoosplit 80 | unzoosplit <- function(z, indexed = FALSE) { 81 | x <- u <- unlist(z, use.names = FALSE) 82 | if (indexed) { 83 | x <- data.frame(id = attributes(z)$id, 84 | time = unlist(lapply(z, time), use.names = FALSE), x = x) 85 | x[attributes(z)$order, ] <- x 86 | } 87 | else x[attributes(z)$order] <- u 88 | class(x) <- attributes(z)$oclass 89 | levels(x) <- levels(z) 90 | x 91 | } 92 | -------------------------------------------------------------------------------- /rsnmm.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | #include 4 | 5 | #define expit(a) (exp(a) / (1 + exp(a))) 6 | 7 | void 8 | rsnmm(int *size, int *tmax, 9 | double *ty, double *tmod, double *tavail, double *tstate, 10 | double *beta, double *eta, double *mu, double *theta, 11 | double *coefavail, double *coefstate, double *coeferr, 12 | int *avail, double *base, int *state, int *a, double *prob, 13 | double *y, double *err, double *statec, double *ac, double *availc) 14 | { 15 | int i, j, n = *size, T = *tmax; 16 | double r, q, ym; 17 | GetRNGstate(); 18 | for (i = 0; i < n; i++) { 19 | for (j = 1; j < T; j++) { 20 | /* probability of availabilty */ 21 | r = expit(coefavail[0] 22 | + coefavail[1] * tavail[j] 23 | + coefavail[2] * a[i*T + j - 1] 24 | + coefavail[3] * y[i*T + j - 1]); 25 | /* availability - uncentered and centered */ 26 | avail[i*T + j] = (int) rbinom(1, r); 27 | availc[i*T + j] = avail[i*T + j] - r; 28 | /* probability that binary state is +1 */ 29 | q = expit(coefstate[0] 30 | + coefstate[1] * tstate[j] 31 | + coefstate[2] * base[i*T + j - 1] 32 | + coefstate[3] * state[i*T + j - 1] 33 | + coefstate[4] * a[i*T + j - 1]); 34 | /* binary state on {-1, 1} - uncentered and centered */ 35 | state[i*T + j] = rbinom(1, q) < 1 ? -1 : 1; 36 | statec[i*T + j] = state[i*T + j] - (q - (1 - q)); 37 | /* treatment probability */ 38 | prob[i*T + j] = avail[i*T + j] * expit(eta[0] 39 | + eta[1] * base[i*T + j] 40 | + eta[2] * state[i*T + j] 41 | + eta[3] * a[i*T + j - 1] 42 | + eta[4] * y[i*T + j - 1]); 43 | /* treatment indicator - uncentered and centered */ 44 | a[i*T + j] = (int) rbinom(1, prob[i*T + j]); 45 | ac[i*T + j] = a[i*T + j] - prob[i*T + j]; 46 | /* conditional mean response */ 47 | ym = mu[0] 48 | + mu[1] * ty[j] /* pre-evaluated time function */ 49 | + mu[2] * base[i*T + j] 50 | + ac[i*T + j] * (beta[0] 51 | + beta[1] * tmod[j] /* pre-evaluated time function */ 52 | + beta[2] * base[i*T + j] 53 | + beta[3] * state[i*T + j] 54 | + beta[4] * a[i*T + j - 1]) 55 | + ac[i*T + j - 1] * (beta[5] 56 | + beta[6] * tmod[j - 1] 57 | + beta[7] * base[i*T + j - 1] 58 | + beta[8] * state[i*T + j - 1]) 59 | + theta[0] * availc[i*T + j] 60 | + theta[1] * statec[i*T + j] 61 | + theta[2] * availc[i*T + j - 1] 62 | + theta[3] * statec[i*T + j - 1]; 63 | /* error */ 64 | err[i*T + j] += *coeferr * err[i*T + j - 1]; 65 | /* response */ 66 | y[i*T + j] = ym + err[i*T + j]; 67 | } 68 | } 69 | PutRNGstate(); 70 | return; 71 | } 72 | -------------------------------------------------------------------------------- /example.R: -------------------------------------------------------------------------------- 1 | ## demonstrate models for proximal and delayed treatment effects using model 2 | ## fitting functions from the standard 'stats' R package ('glm' and 'lm') 3 | 4 | ## load functions needed to generate some data 5 | system("R CMD SHLIB rsnmm.c") 6 | dyn.load(if (Sys.info()["sysname"] == "Windows") "rsnmm.dll" else "rsnmm.so") 7 | library("zoo") 8 | source("xzoo.R") 9 | source("rsnmm.R") 10 | 11 | set.seed(0) 12 | d <- rsnmm(n = 50, tmax = 200, beta1 = c(-0.1, 0, 0, 0), 13 | coef.avail = c(log(9), 0, 0, 0)) 14 | 15 | ## define extra variables, using functions from xzoo.R: 16 | ## - variation among current and up to the past 2 states 17 | d$varstate <- with(d, roll(id, time, state, width = 3, FUN = var)) 18 | ## - variation up to the past 3 states 19 | d$lag1varstate <- with(d, delay(id, time, varstate)) 20 | 21 | ## nb: for a given row in 'd'... 22 | ## 'time' indexes the treatment occasion 23 | ## 'a' is the corresponding treatment indicator 24 | ## 'y' is the corresponding proximal response 25 | ## (this is the same format often used for longitudinal data) 26 | d <- subset(d, time > 0) 27 | head(d) 28 | 29 | ## load functions needed for variance estimation 30 | source("xgeepack.R") 31 | 32 | ## --- treatment model (for the weight denominator) 33 | 34 | ## nb: in the 'data' argument, a data frame containing a subject identifer must 35 | ## be provided (although it need not be named 'id') 36 | system.time(fitpd <- glm(a ~ lag1a * state, weights = avail, 37 | family = "binomial", data = d, subset = time > 3)) 38 | 39 | ## make 'glm' output more like that of 'geeglm' 40 | ## nb: this step is necessary for variance estimation later on 41 | fitpd <- glm2gee(fitpd, id) 42 | ## nb: consider only the coefficients, as this fit ignores repeated measures 43 | fitpd$coefficients 44 | 45 | ## --- treatment probability model for weight numerator 46 | 47 | fitpn <- glm(a ~ 1, weights = avail, family = "binomial", data = d, 48 | subset = time > 2) 49 | fitpn <- glm2gee(fitpn, id) 50 | fitpn$coefficients 51 | 52 | ## --- calculate weights 53 | 54 | d$pd <- d$pn <- NA 55 | d[names(fitpd$fitted.values), "pd"] <- fitpd$fitted.values 56 | d[names(fitpn$fitted.values), "pn"] <- fitpn$fitted.values 57 | d[d$avail == 0, c("pd", "pn")] <- 0 58 | d$w <- with(d, ifelse(avail == 0, 0, ifelse(a == 1, pn/pd, (1 - pn)/(1 - pd)))) 59 | d$lag1pd <- with(d, delay(id, time, pd)) 60 | d$lag1pn <- with(d, delay(id, time, pn)) 61 | d$lag1w <- with(d, delay(id, time, w)) 62 | 63 | ## --- estimate the proximal treatment effect 64 | 65 | fit1 <- lm(y ~ I(time%%2) + varstate + lag1a + state * I(a - pn), 66 | weights = w, data = d, subset = time > 4) 67 | fit1 <- glm2gee(fit1, id) 68 | 69 | ## adjust variance estimates for estimation of treatment probabilities 70 | ## nb: - depending on the 'pn' and 'pd' arguments specified, 'vcov' can handle 71 | ## any combination of centering and weighting 72 | ## - here the 'label' argument is the term label corresponding to the main 73 | ## treatment effect 74 | fit1$vcov <- vcov(fit1, pn = fitpn, pd = fitpd, label = "I(a - pn)") 75 | 76 | ## summarize the model fit 77 | ## nb: 'estimate' can more generally consider linear combinations of regression 78 | ## coefficients, similar to the CONTRAST or ESTIMATE statements in SAS PROC 79 | ## GENMOD 80 | estimate(fit1) 81 | estimate(fit1, rbind("Proximal effect in state -1" = c(rep(0, 5), 1, -1), 82 | "Proximal in state 1" = c(rep(0, 5), 1, 1))) 83 | 84 | ## --- estimate the delayed treatment effect 85 | 86 | fit2 <- lm(y ~ I(time%%2) + lag1state + lag1varstate + I(lag1a - lag1pn), 87 | weights = lag1w, data = d, subset = time > 5) 88 | fit2 <- glm2gee(fit2, id) 89 | fit2$vcov <- vcov(fit2, pn = fitpn, pd = fitpd, 90 | label = "I(lag1a - lag1pn)") 91 | estimate(fit2) 92 | -------------------------------------------------------------------------------- /example_geepack.R: -------------------------------------------------------------------------------- 1 | ## demonstrate models for proximal and delayed treatment effects using 'geeglm', 2 | ## the model fitting function from the contributed 'geepack' R package 3 | 4 | ## load functions needed to generate some data 5 | system("R CMD SHLIB rsnmm.c") 6 | dyn.load(if (Sys.info()["sysname"] == "Windows") "rsnmm.dll" else "rsnmm.so") 7 | library("zoo") 8 | source("xzoo.R") 9 | source("rsnmm.R") 10 | 11 | set.seed(0) 12 | d <- rsnmm(n = 50, tmax = 200, beta1 = c(-0.1, 0, 0, 0), 13 | coef.avail = c(log(9), 0, 0, 0)) 14 | 15 | ## define extra variables, using functions from xzoo.R: 16 | ## - variation among current and up to the past 2 states 17 | d$varstate <- with(d, roll(id, time, state, width = 3, FUN = var)) 18 | ## - variation up to the past 3 states 19 | d$lag1varstate <- with(d, delay(id, time, varstate)) 20 | 21 | ## nb: for a given row in 'd'... 22 | ## 'time' indexes the treatment occasion 23 | ## 'a' is the corresponding treatment indicator 24 | ## 'y' is the corresponding proximal response 25 | ## (this is the same format often used for longitudinal data) 26 | d <- subset(d, time > 0) 27 | head(d) 28 | 29 | ## load functions needed for variance estimation 30 | library("geepack") 31 | source("xgeepack.R") 32 | 33 | ## --- treatment model (for the weight denominator) 34 | 35 | ## nb: - weight by availability status so that the variance estimation functions 36 | ## can easily recover the estimating function 37 | ## - omit earlier observations from the data to avoid using initial values 38 | ## in the lagged treatment status ('lag1a') 39 | ## - 'geeglm' approach will be very slow for a large number of subjects and 40 | ## treatment occasions; in this case use 'glm'/'lm' as follows... 41 | system.time(fitpd <- geeglm(a ~ lag1a * state, id = id, weights = avail, 42 | family = "binomial", data = d, subset = time > 3, 43 | scale.fix = TRUE)) 44 | summary(fitpd) 45 | 46 | ## nb: in the 'data' argument, a data frame containing a subject identifer must 47 | ## be provided (although it need not be named 'id') 48 | system.time(fitpd.glm <- glm(a ~ lag1a * state, weights = avail, 49 | family = "binomial", data = d, subset = time > 3)) 50 | 51 | ## --- treatment probability model for weight numerator 52 | 53 | fitpn <- geeglm(a ~ 1, id = id, weights = avail, family = "binomial", data = d, 54 | subset = time > 2, scale.fix = TRUE) 55 | summary(fitpn) 56 | 57 | ## --- calculate weights 58 | 59 | d$pd <- d$pn <- NA 60 | d[rownames(fitpd$fitted.values), "pd"] <- fitpd$fitted.values 61 | d[rownames(fitpn$fitted.values), "pn"] <- fitpn$fitted.values 62 | d[d$avail == 0, c("pd", "pn")] <- 0 63 | d$w <- with(d, ifelse(avail == 0, 0, ifelse(a == 1, pn/pd, (1 - pn)/(1 - pd)))) 64 | d$lag1pd <- with(d, delay(id, time, pd)) 65 | d$lag1pn <- with(d, delay(id, time, pn)) 66 | d$lag1w <- with(d, delay(id, time, w)) 67 | 68 | ## --- estimate the proximal treatment effect 69 | 70 | ## nb: - any moderators (like 'state') must be included in the regression model 71 | ## via the '*' or ':' *formula* operators 72 | ## - omit earlier observations from the data to avoid basing the state 73 | ## variance variable on initial values or too few values 74 | ## - any observations used to fit the treatment probability model(s), but not 75 | ## the proximal response model should correspond to *earlier* treatment 76 | ## occasions 77 | fit1 <- geeglm(y ~ I(time%%2) + varstate + lag1a + state * I(a - pn), 78 | id = id, weights = w, data = d, subset = time > 4, 79 | scale.fix = TRUE) 80 | 81 | ## adjust variance estimates for estimation of treatment probabilities 82 | ## nb: - depending on the 'pn' and 'pd' arguments specified, 'vcov' can handle 83 | ## any combination of centering and weighting 84 | ## - here the 'label' argument is the term label corresponding to the main 85 | ## treatment effect 86 | fit1$vcov <- vcov(fit1, pn = fitpn, pd = fitpd, label = "I(a - pn)") 87 | 88 | ## summarize the model fit 89 | ## nb: 'estimate' can more generally consider linear combinations of regression 90 | ## coefficients, similar to the CONTRAST or ESTIMATE statements in SAS PROC 91 | ## GENMOD 92 | estimate(fit1) 93 | estimate(fit1, rbind("Proximal effect in state -1" = c(rep(0, 5), 1, -1), 94 | "Proximal in state 1" = c(rep(0, 5), 1, 1))) 95 | 96 | ## --- estimate the delayed treatment effect 97 | 98 | fit2 <- geeglm(y ~ I(time%%2) + lag1state + lag1varstate + I(lag1a - lag1pn), 99 | weights = lag1w, id = id, data = d, subset = time > 5, 100 | scale.fix = TRUE) 101 | fit2$vcov <- vcov(fit2, pn = fitpn, pd = fitpd, label = "I(lag1a - lag1pn)") 102 | estimate(fit2) 103 | -------------------------------------------------------------------------------- /rsnmm.R: -------------------------------------------------------------------------------- 1 | rsnmm <- function(n, tmax, control, ...) { 2 | control <- if (missing(control)) rsnmm.control(...) 3 | else do.call("rsnmm.control", control) 4 | tmax <- tmax + (tmax %% 2) + 1 5 | time <- rep(0:(tmax - 1), n) 6 | tfun <- do.call("data.frame", lapply(control$tfun, function(f) f(time, tmax))) 7 | coef.err <- 0 8 | control$cormatrix <- matrix(control$coralpha, tmax, tmax) 9 | diag(control$cormatrix) <- 1 10 | if (control$corstr == "exchangeable") { 11 | err <- sqrt(control$coralpha) * rep(rnorm(n, sd = control$sd), each = tmax) 12 | err <- err + rnorm(n * tmax, sd = sqrt(with(control, sd^2 * (1 - coralpha)))) 13 | } 14 | else { 15 | ## provisional error 16 | err <- ifelse(time == 0, rnorm(n, sd = control$sd), 17 | rnorm(n * (tmax - 1), 18 | sd = sqrt(with(control, sd^2 * (1 - coralpha^2))))) 19 | err[time == 0] <- rnorm(n, sd = control$sd) 20 | coef.err <- control$coralpha 21 | control$cormatrix <- matrix(with(control, 22 | coralpha^(abs(row(cormatrix) - 23 | col(cormatrix)))), tmax, tmax) 24 | } 25 | d <- .C("rsnmm", 26 | n = as.integer(n), 27 | tmax = as.integer(tmax), 28 | ty = as.double(tfun$ty), 29 | tmod = as.double(tfun$tmod), 30 | tavail = as.double(tfun$tavail), 31 | tstate = as.double(tfun$tstate), 32 | beta = with(control, as.double(c(beta0, beta1))), 33 | eta = as.double(control$eta), 34 | mu = as.double(control$mu), 35 | theta = with(control, as.double(c(theta0, theta1))), 36 | coef.avail = as.double(control$coef.avail), 37 | coef.state = as.double(control$coef.state), 38 | coef.err = as.double(coef.err), 39 | avail = as.integer(rep(0, n * tmax)), 40 | base = as.double(rep(rnorm(n), each = tmax)), 41 | state = as.integer(rep(0, n * tmax)), 42 | a = as.integer(rep(0, n * tmax)), 43 | prob = as.double(rep(0, n * tmax)), 44 | y = as.double(rep(0, n * tmax)), 45 | err = as.double(err), 46 | state.center = as.double(rep(0, n*tmax)), 47 | a.center = as.double(rep(0, n*tmax)), 48 | avail.center = as.double(rep(0, n*tmax))) 49 | d <- data.frame(id = rep(1:n, each = tmax), time = time, 50 | ty = d$ty, tmod = d$tmod, tavail = d$tavail, tstate = d$tstate, 51 | base = d$base, state = d$state, a = d$a, y = d$y, err = d$err, 52 | avail = d$avail, prob = d$p, a.center = d$a.center, 53 | state.center = d$state.center, avail.center = d$avail.center, 54 | one = 1) 55 | ## nb: for a given row, y is the proximal response 56 | d$lag1y <- with(d, delay(id, time, y)) 57 | d$lag2y <- with(d, delay(id, time, y, 2)) 58 | d$lag1err <- with(d, delay(id, time, err)) 59 | d$lag1avail <- with(d, delay(id, time, avail)) 60 | d$lag1avail.center <- with(d, delay(id, time, avail.center)) 61 | d$lag2avail <- with(d, delay(id, time, avail, 2)) 62 | d$lag2avail.center <- with(d, delay(id, time, avail.center, 2)) 63 | d$lag1a <- with(d, delay(id, time, a)) 64 | d$lag2a <- with(d, delay(id, time, a, 2)) 65 | d$lag1prob <- with(d, delay(id, time, prob)) 66 | d$lag2prob <- with(d, delay(id, time, prob, 2)) 67 | d$lag1a.center <- with(d, delay(id, time, a.center)) 68 | d$lag2a.center <- with(d, delay(id, time, a.center, 2)) 69 | d$lag1tmod <- with(d, delay(id, time, tmod)) 70 | d$lag2tmod <- with(d, delay(id, time, tmod, 2)) 71 | d$lag1state <- with(d, delay(id, time, state)) 72 | d$lag1state.center <- with(d, delay(id, time, state.center)) 73 | rownames(d) <- NULL 74 | attributes(d) <- c(attributes(d), control) 75 | d 76 | } 77 | 78 | rsnmm.control <- function(origin = 1, sd = 1, 79 | coralpha = sqrt(0.5), 80 | corstr = c("ar1", "exchangeable"), 81 | beta0 = c(-0.2, 0, 0, 0.2, 0), beta1 = rep(0, 4), 82 | eta = c(0, 0, 0.8, -0.8, 0), mu = rep(0, 3), 83 | theta0 = c(0, 0.8), theta1 = c(0, 0), 84 | coef.avail = c(100, rep(0, 3)), coef.state = rep(0, 5), 85 | tfun = NULL, lag = 3 + any(beta1 != 0)) { 86 | corstr <- match.arg(corstr) 87 | if (is.null(tfun)) 88 | tfun <- rep(list(function(tcur, tmax) rep(0, length(tcur))), 4) 89 | list(origin = 1, lag = lag, 90 | ## error SD, correlation 91 | sd = sd, coralpha = coralpha, corstr = corstr, 92 | ## proximal effect coefficients 93 | beta0 = setNames(beta0, c("one", "tmod", "base", "state", "lag1a")), 94 | ## delayed effect coefficients 95 | beta1 = setNames(beta1, c("one", "lag1tmod", "base", "lag1state")), 96 | ## treatment probability model coefficients 97 | eta = setNames(eta, c("one", "base", "state", "lag1a", "lag1y")), 98 | ## exogenous or time-invariant main effects 99 | mu = setNames(mu, c("one", "ty", "base")), 100 | ## time-varying main effects, centered and proximal 101 | theta0 = setNames(theta0, c("avail", "state")), 102 | ## time-varying main effects, centered and delayed 103 | theta1 = setNames(theta1, c("lag1avail", "lag1state")), 104 | ## availability model coefficients 105 | coef.avail = setNames(coef.avail, c("one", "tavail", "lag1a", "lag1y")), 106 | ## binary state model coefficients 107 | coef.state = setNames(coef.state, 108 | c("one", "tstate", "base", "lag1state", "lag1a")), 109 | ## functions of time in the main effect, proximal effect, 110 | ## availability model, and binary state model 111 | tfun = setNames(tfun, c("ty", "tmod", "tavail", "tstate"))) 112 | } 113 | -------------------------------------------------------------------------------- /sim.R: -------------------------------------------------------------------------------- 1 | sim <- function(n = 30, tmax = 30, M = 1000, 2 | ## response regression models 3 | y.formula = list(w = y ~ I(a - pn) * (base + state), 4 | u = y ~ a * (base + state)), 5 | ## names for each regression model 6 | y.names = c(w = "Weighted and centered", 7 | u = "GEE AR(1)"), 8 | ## labels for regression terms of the treatment effect 9 | y.label = list(w = "I(a - pn)"), 10 | ## names of the treatment probability models or variables used 11 | ## for the weight numerator ('wn') or denominator ('wd') and 12 | ## arguments for the estimation routine 13 | y.args = list(w = list(wn = "pn", wd = "pd"), 14 | u = list(corstr = "ar1")), 15 | ## treatment probability models named in 'y.args' 16 | a.formula = list(pn = a ~ lag1a, 17 | pd = a ~ lag1a + state), 18 | ## names for each treatment probability model 19 | a.names = c(pn = "Last treatment", 20 | pd = "Last treatment and current state"), 21 | ## proximal (0) or delayed (1) treatment effect? 22 | lag = 0, 23 | ## print generative and analysis model details 24 | verbose = TRUE, 25 | ## control parameters for 'rsnmm' 26 | control, ...) { 27 | control <- if (missing(control)) rsnmm.control(...) 28 | else control <- do.call("rsnmm.control", control) 29 | ## times to use in the model fit 30 | runin.fita <- control$lag 31 | runin.fity <- control$lag + lag 32 | ## retrieve causal control parameter values 33 | ## nb: if the regression models 'y.formula' average over an underlying 34 | ## moderator these will not represent the true causal effect unless this 35 | ## moderator has conditional mean zero 36 | y.coef <- mapply(which.terms, x = y.formula, label = y.label, 37 | stripnames = TRUE, SIMPLIFY = FALSE) 38 | truth <- control[[paste0("beta", lag)]] 39 | truth <- truth[Reduce("intersect", lapply(y.coef, names))] 40 | y.coef <- lapply(y.coef, function(x) x[names(truth)]) 41 | ## corresponding treatment probability models 42 | ## nb: we avoid delayed evaluation in 'y.args' (e.g. passing a 'weights' 43 | ## argument directly) to avoid scoping issues in 'foreach' 44 | if (!is.null(a.formula)) { 45 | y.prob <- lapply(y.args, function(x) do.call("c", x[c("wn", "wd")])) 46 | y.prob <- lapply(y.prob, function(x) x[x %in% names(a.formula)]) 47 | } 48 | else y.prob <- lapply(y.formula, function(x) list()) 49 | ## print generative and analysis model properties 50 | if (verbose) { 51 | cat("\nGenerative model attributes\n\n") 52 | print(control) 53 | cat("Analysis models\n\n") 54 | mapply(function(f, nm) write.table(cbind(" ", nm, ": y ~ ", 55 | as.character(f)[3]), sep = "", 56 | row.names = FALSE, col.names = FALSE, 57 | quote = FALSE, eol = "\n\n"), 58 | f = y.formula, nm = y.names) 59 | cat("Treatment probability models\n\n") 60 | mapply(function(f, nm) write.table(cbind(" ", nm, ": a ~ ", 61 | as.character(f)[3]), sep = "", 62 | row.names = FALSE, col.names = FALSE, 63 | quote = FALSE, eol = "\n\n"), 64 | f = a.formula, nm = a.names) 65 | } 66 | ## general model fitter 67 | ## nb: d is the data frame for the replicate 68 | fitter <- function(formula, args, prob, coef, label, response = "y", 69 | addvar = NULL) { 70 | if (response == "a") { 71 | args$family <- binomial() 72 | runin <- runin.fita 73 | } 74 | else runin <- runin.fity 75 | r <- which(d$time >= runin) 76 | l <- list(x = model.matrix(formula, data = d[r, ]), y = d[r, response]) 77 | if (is.null(args$wn) & is.null(args$wn)) l$w <- rep(1, nrow(d)) 78 | else { 79 | l$w <- ifelse(d[, "a"] == 1, d[, args$wn] / d[, args$wd], 80 | (1 - d[, args$wn]) / (1 - d[, args$wd])) 81 | args[c("wn", "wd")] <- NULL 82 | } 83 | l$w <- l$w * d$avail 84 | if (lag) l$w <- delay(d$id, d$time, l$w, lag) 85 | l$w <- l$w[r] 86 | if (!is.null(args$corstr)) { 87 | fun <- "geese.glm" 88 | l$id <- d$id[r] 89 | } 90 | else if (!is.null(args$family)) fun <- "glm.fit" 91 | else fun <- "lm.wfit" 92 | fit <- do.call(fun, c(l, args)) 93 | if (!inherits(fit, "geeglm")) { 94 | fit <- glm2gee(fit, d$id[r]) 95 | fit$terms <- terms(formula) 96 | fit$geese$X <- l$x 97 | fit$y <- l$y 98 | } 99 | if (!is.null(addvar)) { 100 | newvar <- paste0(c("", "lag1"), addvar) 101 | d[, newvar] <<- NA 102 | d[r, newvar[1]] <<- fit$fitted.values 103 | d[, newvar[2]] <<- delay(d$id, d$time, d[, newvar[1]]) 104 | } 105 | else { 106 | ## usual variance sandwich estimator 107 | fit$vcov <- vcov.geeglm(fit) 108 | est <- estimate(fit)[coef, 1:4, drop = FALSE] 109 | ## correction for any estimates in weights 110 | l <- if (length(prob)) setNames(fita[prob], gsub("^w", "p", names(prob))) 111 | else NULL 112 | fit$vcov <- NULL 113 | fit$vcov <- do.call("vcov.geeglm", c(list(x = fit, label = label), l)) 114 | estc <- estimate(fit)[coef, 1:4, drop = FALSE] 115 | fit <- data.frame(moderator = names(coef), truth = truth, 116 | est = est[, "Estimate"], se = est[, "SE"], 117 | lcl = est[, "95% LCL"], ucl = est[, "95% UCL"], 118 | sec = estc[, "SE"], lclc = estc[, "95% LCL"], 119 | uclc = estc[, "95% UCL"], row.names = NULL) 120 | } 121 | fit 122 | } 123 | fita <- list() 124 | ## for each replicate... 125 | out <- foreach(m = 1:M, .combine = "rbind") %dopar% { 126 | ## ... generate data 127 | d <- rsnmm(n, tmax, control = control) 128 | d$pn <- d$pd <- d$prob 129 | ## ... fit treatment probability models 130 | if (!is.null(a.formula)) 131 | fita <- mapply(fitter, formula = a.formula, addvar = names(a.formula), 132 | MoreArgs = list(args = list(), prob = list(), 133 | coef = list(), label = list(), 134 | response = "a"), SIMPLIFY = FALSE) 135 | ## ... fit response models 136 | fity <- mapply(fitter, formula = y.formula, args = y.args, prob = y.prob, 137 | coef = y.coef, label = y.label, SIMPLIFY = FALSE) 138 | fity <- mapply(function(nm, d) data.frame(iter = m, method = nm, d, 139 | row.names = NULL), 140 | nm = y.names[names(fity)], d = fity, SIMPLIFY = FALSE) 141 | out <- do.call("rbind", setNames(fity, NULL)) 142 | } 143 | out <- data.frame(n, tmax, out) 144 | ## 95% CI coverage probability using uncorrected SEs 145 | out$cp <- with(out, lcl <= truth & truth <= ucl) 146 | ## coverage probability using SEs corrected for estimates in weights 147 | out$cpc <- with(out, lclc <= truth & truth <= uclc) 148 | ## root MSE 149 | out$rmse <- with(out, (est - truth)^2) 150 | ## mean and SD estimate, number of replicates 151 | out <- cbind(aggregate(cbind(est, se, sec, cp, cpc, rmse) ~ 152 | method + moderator + truth + n + tmax, 153 | data = out, FUN = mean), 154 | sd = aggregate(est ~ method + moderator + truth + n + tmax, 155 | data = out, FUN = sd)$est, 156 | iter = aggregate(iter ~ method + moderator + truth + n + tmax, 157 | data = out, 158 | FUN = function(x) length(unique(x)))$iter) 159 | out$rmse <- sqrt(out$rmse) 160 | out 161 | } 162 | -------------------------------------------------------------------------------- /example.Rout: -------------------------------------------------------------------------------- 1 | 2 | R version 3.6.1 (2019-07-05) -- "Action of the Toes" 3 | Copyright (C) 2019 The R Foundation for Statistical Computing 4 | Platform: x86_64-apple-darwin15.6.0 (64-bit) 5 | 6 | R is free software and comes with ABSOLUTELY NO WARRANTY. 7 | You are welcome to redistribute it under certain conditions. 8 | Type 'license()' or 'licence()' for distribution details. 9 | 10 | Natural language support but running in an English locale 11 | 12 | R is a collaborative project with many contributors. 13 | Type 'contributors()' for more information and 14 | 'citation()' on how to cite R or R packages in publications. 15 | 16 | Type 'demo()' for some demos, 'help()' for on-line help, or 17 | 'help.start()' for an HTML browser interface to help. 18 | Type 'q()' to quit R. 19 | 20 | > ## demonstrate models for proximal and delayed treatment effects using model 21 | > ## fitting functions from the standard 'stats' R package ('glm' and 'lm') 22 | > 23 | > ## load functions needed to generate some data 24 | > system("R CMD SHLIB rsnmm.c") 25 | make: Nothing to be done for `all'. 26 | > dyn.load(if (Sys.info()["sysname"] == "Windows") "rsnmm.dll" else "rsnmm.so") 27 | > library("zoo") 28 | 29 | Attaching package: ‘zoo’ 30 | 31 | The following objects are masked from ‘package:base’: 32 | 33 | as.Date, as.Date.numeric 34 | 35 | > source("xzoo.R") 36 | > source("rsnmm.R") 37 | > 38 | > set.seed(0) 39 | > d <- rsnmm(n = 50, tmax = 200, beta1 = c(-0.1, 0, 0, 0), 40 | + coef.avail = c(log(9), 0, 0, 0)) 41 | > 42 | > ## define extra variables, using functions from xzoo.R: 43 | > ## - variation among current and up to the past 2 states 44 | > d$varstate <- with(d, roll(id, time, state, width = 3, FUN = var)) 45 | > ## - variation up to the past 3 states 46 | > d$lag1varstate <- with(d, delay(id, time, varstate)) 47 | > 48 | > ## nb: for a given row in 'd'... 49 | > ## 'time' indexes the treatment occasion 50 | > ## 'a' is the corresponding treatment indicator 51 | > ## 'y' is the corresponding proximal response 52 | > ## (this is the same format often used for longitudinal data) 53 | > d <- subset(d, time > 0) 54 | > head(d) 55 | id time ty tmod tavail tstate base state a y err avail 56 | 2 1 1 0 0 0 0 0.6522909 -1 1 -1.6234748 -0.5474850 1 57 | 3 1 2 0 0 0 0 0.6522909 -1 0 0.5373703 1.3391751 1 58 | 4 1 3 0 0 0 0 0.6522909 1 0 1.2013483 0.3845501 1 59 | 5 1 4 0 0 0 0 0.6522909 -1 0 -0.3738786 0.2331138 1 60 | 6 1 5 0 0 0 0 0.6522909 -1 1 -0.7032743 0.3417129 1 61 | 7 1 6 0 0 0 0 0.6522909 1 0 1.4097941 0.6787916 1 62 | prob a.center state.center avail.center one lag1y lag2y 63 | 2 0.3100255 0.6899745 -1 0.1 1 0.0000000 NA 64 | 3 0.1679816 -0.1679816 -1 0.1 1 -1.6234748 0.0000000 65 | 4 0.6899745 -0.6899745 1 0.1 1 0.5373703 -1.6234748 66 | 5 0.3100255 -0.3100255 -1 0.1 1 1.2013483 0.5373703 67 | 6 0.3100255 0.6899745 -1 0.1 1 -0.3738786 1.2013483 68 | 7 0.5000000 -0.5000000 1 0.1 1 -0.7032743 -0.3738786 69 | lag1err lag1avail lag1avail.center lag2avail lag2avail.center lag1a lag2a 70 | 2 -0.3975580 0 0.0 NA NA 0 NA 71 | 3 -0.5474850 1 0.1 0 0.0 1 0 72 | 4 1.3391751 1 0.1 1 0.1 0 1 73 | 5 0.3845501 1 0.1 1 0.1 0 0 74 | 6 0.2331138 1 0.1 1 0.1 0 0 75 | 7 0.3417129 1 0.1 1 0.1 1 0 76 | lag1prob lag2prob lag1a.center lag2a.center lag1tmod lag2tmod lag1state 77 | 2 0.0000000 NA 0.0000000 NA 0 NA 0 78 | 3 0.3100255 0.0000000 0.6899745 0.0000000 0 0 -1 79 | 4 0.1679816 0.3100255 -0.1679816 0.6899745 0 0 -1 80 | 5 0.6899745 0.1679816 -0.6899745 -0.1679816 0 0 1 81 | 6 0.3100255 0.6899745 -0.3100255 -0.6899745 0 0 -1 82 | 7 0.3100255 0.3100255 0.6899745 -0.3100255 0 0 -1 83 | lag1state.center varstate lag1varstate 84 | 2 0 0.5000000 NA 85 | 3 -1 0.3333333 0.5000000 86 | 4 -1 1.3333333 0.3333333 87 | 5 1 1.3333333 1.3333333 88 | 6 -1 1.3333333 1.3333333 89 | 7 -1 1.3333333 1.3333333 90 | > 91 | > ## load functions needed for variance estimation 92 | > source("xgeepack.R") 93 | > 94 | > ## --- treatment model (for the weight denominator) 95 | > 96 | > ## nb: in the 'data' argument, a data frame containing a subject identifer must 97 | > ## be provided (although it need not be named 'id') 98 | > system.time(fitpd <- glm(a ~ lag1a * state, weights = avail, 99 | + family = "binomial", data = d, subset = time > 3)) 100 | user system elapsed 101 | 0.031 0.008 0.038 102 | > 103 | > ## make 'glm' output more like that of 'geeglm' 104 | > ## nb: this step is necessary for variance estimation later on 105 | > fitpd <- glm2gee(fitpd, id) 106 | > ## nb: consider only the coefficients, as this fit ignores repeated measures 107 | > fitpd$coefficients 108 | (Intercept) lag1a state lag1a:state 109 | 0.05350081 -0.83605510 0.79397362 0.03837450 110 | > 111 | > ## --- treatment probability model for weight numerator 112 | > 113 | > fitpn <- glm(a ~ 1, weights = avail, family = "binomial", data = d, 114 | + subset = time > 2) 115 | > fitpn <- glm2gee(fitpn, id) 116 | > fitpn$coefficients 117 | (Intercept) 118 | -0.2190782 119 | > 120 | > ## --- calculate weights 121 | > 122 | > d$pd <- d$pn <- NA 123 | > d[names(fitpd$fitted.values), "pd"] <- fitpd$fitted.values 124 | > d[names(fitpn$fitted.values), "pn"] <- fitpn$fitted.values 125 | > d[d$avail == 0, c("pd", "pn")] <- 0 126 | > d$w <- with(d, ifelse(avail == 0, 0, ifelse(a == 1, pn/pd, (1 - pn)/(1 - pd)))) 127 | > d$lag1pd <- with(d, delay(id, time, pd)) 128 | > d$lag1pn <- with(d, delay(id, time, pn)) 129 | > d$lag1w <- with(d, delay(id, time, w)) 130 | > 131 | > ## --- estimate the proximal treatment effect 132 | > 133 | > fit1 <- lm(y ~ I(time%%2) + varstate + lag1a + state * I(a - pn), 134 | + weights = w, data = d, subset = time > 4) 135 | > fit1 <- glm2gee(fit1, id) 136 | > 137 | > ## adjust variance estimates for estimation of treatment probabilities 138 | > ## nb: - depending on the 'pn' and 'pd' arguments specified, 'vcov' can handle 139 | > ## any combination of centering and weighting 140 | > ## - here the 'label' argument is the term label corresponding to the main 141 | > ## treatment effect 142 | > fit1$vcov <- vcov(fit1, pn = fitpn, pd = fitpd, label = "I(a - pn)") 143 | > 144 | > ## summarize the model fit 145 | > ## nb: 'estimate' can more generally consider linear combinations of regression 146 | > ## coefficients, similar to the CONTRAST or ESTIMATE statements in SAS PROC 147 | > ## GENMOD 148 | > estimate(fit1) 149 | Estimate 95% LCL 95% UCL SE Hotelling p-value 150 | (Intercept) 0.000351 -0.080117 0.080820 0.039901 0.000 0.99301 151 | I(time%%2) 0.033185 0.008242 0.058128 0.012368 7.199 0.01031 * 152 | varstate -0.000929 -0.050823 0.048965 0.024741 0.001 0.97022 153 | lag1a -0.086419 -0.149928 -0.022911 0.031492 7.531 0.00881 ** 154 | state 0.858799 0.832337 0.885260 0.013121 4283.958 < 1e-04 *** 155 | I(a - pn) -0.198920 -0.256687 -0.141152 0.028645 48.224 < 1e-04 *** 156 | state:I(a - pn) 0.188144 0.135870 0.240419 0.025921 52.685 < 1e-04 *** 157 | --- 158 | Signif. codes: 0 ‘***’ 0.001 ‘**’ 0.01 ‘*’ 0.05 ‘.’ 0.1 ‘ ’ 1 159 | > estimate(fit1, rbind("Proximal effect in state -1" = c(rep(0, 5), 1, -1), 160 | + "Proximal in state 1" = c(rep(0, 5), 1, 1))) 161 | Estimate 95% LCL 95% UCL SE Hotelling p-value 162 | Proximal effect in state -1 -0.3871 -0.4412 -0.3329 0.0432 80.198 <1e-04 163 | Proximal in state 1 -0.0108 -0.0527 0.0311 0.0334 0.104 0.809 164 | 165 | Proximal effect in state -1 *** 166 | Proximal in state 1 167 | --- 168 | Signif. codes: 0 ‘***’ 0.001 ‘**’ 0.01 ‘*’ 0.05 ‘.’ 0.1 ‘ ’ 1 169 | > 170 | > ## --- estimate the delayed treatment effect 171 | > 172 | > fit2 <- lm(y ~ I(time%%2) + lag1state + lag1varstate + I(lag1a - lag1pn), 173 | + weights = lag1w, data = d, subset = time > 5) 174 | > fit2 <- glm2gee(fit2, id) 175 | > fit2$vcov <- vcov(fit2, pn = fitpn, pd = fitpd, 176 | + label = "I(lag1a - lag1pn)") 177 | > estimate(fit2) 178 | Estimate 95% LCL 95% UCL SE Hotelling p-value 179 | (Intercept) 0.022410 -0.078882 0.123702 0.050291 0.199 0.6580 180 | I(time%%2) -0.018921 -0.066729 0.028887 0.023736 0.635 0.4296 181 | lag1state 0.038101 0.003842 0.072361 0.017010 5.017 0.0301 * 182 | lag1varstate 0.021931 -0.038860 0.082722 0.030183 0.528 0.4712 183 | I(lag1a - lag1pn) -0.075436 -0.151452 0.000579 0.037742 3.995 0.0517 . 184 | --- 185 | Signif. codes: 0 ‘***’ 0.001 ‘**’ 0.01 ‘*’ 0.05 ‘.’ 0.1 ‘ ’ 1 186 | > 187 | > proc.time() 188 | user system elapsed 189 | 14.193 1.210 20.531 190 | -------------------------------------------------------------------------------- /example_geepack.Rout: -------------------------------------------------------------------------------- 1 | 2 | R version 3.6.1 (2019-07-05) -- "Action of the Toes" 3 | Copyright (C) 2019 The R Foundation for Statistical Computing 4 | Platform: x86_64-apple-darwin15.6.0 (64-bit) 5 | 6 | R is free software and comes with ABSOLUTELY NO WARRANTY. 7 | You are welcome to redistribute it under certain conditions. 8 | Type 'license()' or 'licence()' for distribution details. 9 | 10 | Natural language support but running in an English locale 11 | 12 | R is a collaborative project with many contributors. 13 | Type 'contributors()' for more information and 14 | 'citation()' on how to cite R or R packages in publications. 15 | 16 | Type 'demo()' for some demos, 'help()' for on-line help, or 17 | 'help.start()' for an HTML browser interface to help. 18 | Type 'q()' to quit R. 19 | 20 | > ## demonstrate models for proximal and delayed treatment effects using 'geeglm', 21 | > ## the model fitting function from the contributed 'geepack' R package 22 | > 23 | > ## load functions needed to generate some data 24 | > system("R CMD SHLIB rsnmm.c") 25 | make: Nothing to be done for `all'. 26 | > dyn.load(if (Sys.info()["sysname"] == "Windows") "rsnmm.dll" else "rsnmm.so") 27 | > library("zoo") 28 | 29 | Attaching package: ‘zoo’ 30 | 31 | The following objects are masked from ‘package:base’: 32 | 33 | as.Date, as.Date.numeric 34 | 35 | > source("xzoo.R") 36 | > source("rsnmm.R") 37 | > 38 | > set.seed(0) 39 | > d <- rsnmm(n = 50, tmax = 200, beta1 = c(-0.1, 0, 0, 0), 40 | + coef.avail = c(log(9), 0, 0, 0)) 41 | > 42 | > ## define extra variables, using functions from xzoo.R: 43 | > ## - variation among current and up to the past 2 states 44 | > d$varstate <- with(d, roll(id, time, state, width = 3, FUN = var)) 45 | > ## - variation up to the past 3 states 46 | > d$lag1varstate <- with(d, delay(id, time, varstate)) 47 | > 48 | > ## nb: for a given row in 'd'... 49 | > ## 'time' indexes the treatment occasion 50 | > ## 'a' is the corresponding treatment indicator 51 | > ## 'y' is the corresponding proximal response 52 | > ## (this is the same format often used for longitudinal data) 53 | > d <- subset(d, time > 0) 54 | > head(d) 55 | id time ty tmod tavail tstate base state a y err avail 56 | 2 1 1 0 0 0 0 0.6522909 -1 1 -1.6234748 -0.5474850 1 57 | 3 1 2 0 0 0 0 0.6522909 -1 0 0.5373703 1.3391751 1 58 | 4 1 3 0 0 0 0 0.6522909 1 0 1.2013483 0.3845501 1 59 | 5 1 4 0 0 0 0 0.6522909 -1 0 -0.3738786 0.2331138 1 60 | 6 1 5 0 0 0 0 0.6522909 -1 1 -0.7032743 0.3417129 1 61 | 7 1 6 0 0 0 0 0.6522909 1 0 1.4097941 0.6787916 1 62 | prob a.center state.center avail.center one lag1y lag2y 63 | 2 0.3100255 0.6899745 -1 0.1 1 0.0000000 NA 64 | 3 0.1679816 -0.1679816 -1 0.1 1 -1.6234748 0.0000000 65 | 4 0.6899745 -0.6899745 1 0.1 1 0.5373703 -1.6234748 66 | 5 0.3100255 -0.3100255 -1 0.1 1 1.2013483 0.5373703 67 | 6 0.3100255 0.6899745 -1 0.1 1 -0.3738786 1.2013483 68 | 7 0.5000000 -0.5000000 1 0.1 1 -0.7032743 -0.3738786 69 | lag1err lag1avail lag1avail.center lag2avail lag2avail.center lag1a lag2a 70 | 2 -0.3975580 0 0.0 NA NA 0 NA 71 | 3 -0.5474850 1 0.1 0 0.0 1 0 72 | 4 1.3391751 1 0.1 1 0.1 0 1 73 | 5 0.3845501 1 0.1 1 0.1 0 0 74 | 6 0.2331138 1 0.1 1 0.1 0 0 75 | 7 0.3417129 1 0.1 1 0.1 1 0 76 | lag1prob lag2prob lag1a.center lag2a.center lag1tmod lag2tmod lag1state 77 | 2 0.0000000 NA 0.0000000 NA 0 NA 0 78 | 3 0.3100255 0.0000000 0.6899745 0.0000000 0 0 -1 79 | 4 0.1679816 0.3100255 -0.1679816 0.6899745 0 0 -1 80 | 5 0.6899745 0.1679816 -0.6899745 -0.1679816 0 0 1 81 | 6 0.3100255 0.6899745 -0.3100255 -0.6899745 0 0 -1 82 | 7 0.3100255 0.3100255 0.6899745 -0.3100255 0 0 -1 83 | lag1state.center varstate lag1varstate 84 | 2 0 0.5000000 NA 85 | 3 -1 0.3333333 0.5000000 86 | 4 -1 1.3333333 0.3333333 87 | 5 1 1.3333333 1.3333333 88 | 6 -1 1.3333333 1.3333333 89 | 7 -1 1.3333333 1.3333333 90 | > 91 | > ## load functions needed for variance estimation 92 | > library("geepack") 93 | > source("xgeepack.R") 94 | > 95 | > ## --- treatment model (for the weight denominator) 96 | > 97 | > ## nb: - weight by availability status so that the variance estimation functions 98 | > ## can easily recover the estimating function 99 | > ## - omit earlier observations from the data to avoid using initial values 100 | > ## in the lagged treatment status ('lag1a') 101 | > ## - 'geeglm' approach will be very slow for a large number of subjects and 102 | > ## treatment occasions; in this case use 'glm'/'lm' as follows... 103 | > system.time(fitpd <- geeglm(a ~ lag1a * state, id = id, weights = avail, 104 | + family = "binomial", data = d, subset = time > 3, 105 | + scale.fix = TRUE)) 106 | user system elapsed 107 | 3.387 0.055 4.198 108 | > summary(fitpd) 109 | 110 | Call: 111 | geeglm(formula = a ~ lag1a * state, family = "binomial", data = d, 112 | weights = avail, subset = time > 3, id = id, scale.fix = TRUE) 113 | 114 | Coefficients: 115 | Estimate Std.err Wald Pr(>|W|) 116 | (Intercept) 0.05350 0.03103 2.972 0.0847 . 117 | lag1a -0.83606 0.04577 333.650 <2e-16 *** 118 | state 0.79397 0.02739 840.462 <2e-16 *** 119 | lag1a:state 0.03837 0.05133 0.559 0.4547 120 | --- 121 | Signif. codes: 0 ‘***’ 0.001 ‘**’ 0.01 ‘*’ 0.05 ‘.’ 0.1 ‘ ’ 1 122 | 123 | Correlation structure = independence 124 | Scale is fixed. 125 | 126 | Number of clusters: 50 Maximum cluster size: 197 127 | > 128 | > ## nb: in the 'data' argument, a data frame containing a subject identifer must 129 | > ## be provided (although it need not be named 'id') 130 | > system.time(fitpd.glm <- glm(a ~ lag1a * state, weights = avail, 131 | + family = "binomial", data = d, subset = time > 3)) 132 | user system elapsed 133 | 0.016 0.005 0.022 134 | > 135 | > ## --- treatment probability model for weight numerator 136 | > 137 | > fitpn <- geeglm(a ~ 1, id = id, weights = avail, family = "binomial", data = d, 138 | + subset = time > 2, scale.fix = TRUE) 139 | > summary(fitpn) 140 | 141 | Call: 142 | geeglm(formula = a ~ 1, family = "binomial", data = d, weights = avail, 143 | subset = time > 2, id = id, scale.fix = TRUE) 144 | 145 | Coefficients: 146 | Estimate Std.err Wald Pr(>|W|) 147 | (Intercept) -0.2191 0.0206 113 <2e-16 *** 148 | --- 149 | Signif. codes: 0 ‘***’ 0.001 ‘**’ 0.01 ‘*’ 0.05 ‘.’ 0.1 ‘ ’ 1 150 | 151 | Correlation structure = independence 152 | Scale is fixed. 153 | 154 | Number of clusters: 50 Maximum cluster size: 198 155 | > 156 | > ## --- calculate weights 157 | > 158 | > d$pd <- d$pn <- NA 159 | > d[rownames(fitpd$fitted.values), "pd"] <- fitpd$fitted.values 160 | > d[rownames(fitpn$fitted.values), "pn"] <- fitpn$fitted.values 161 | > d[d$avail == 0, c("pd", "pn")] <- 0 162 | > d$w <- with(d, ifelse(avail == 0, 0, ifelse(a == 1, pn/pd, (1 - pn)/(1 - pd)))) 163 | > d$lag1pd <- with(d, delay(id, time, pd)) 164 | > d$lag1pn <- with(d, delay(id, time, pn)) 165 | > d$lag1w <- with(d, delay(id, time, w)) 166 | > 167 | > ## --- estimate the proximal treatment effect 168 | > 169 | > ## nb: - any moderators (like 'state') must be included in the regression model 170 | > ## via the '*' or ':' *formula* operators 171 | > ## - omit earlier observations from the data to avoid basing the state 172 | > ## variance variable on initial values or too few values 173 | > ## - any observations used to fit the treatment probability model(s), but not 174 | > ## the proximal response model should correspond to *earlier* treatment 175 | > ## occasions 176 | > fit1 <- geeglm(y ~ I(time%%2) + varstate + lag1a + state * I(a - pn), 177 | + id = id, weights = w, data = d, subset = time > 4, 178 | + scale.fix = TRUE) 179 | > 180 | > ## adjust variance estimates for estimation of treatment probabilities 181 | > ## nb: - depending on the 'pn' and 'pd' arguments specified, 'vcov' can handle 182 | > ## any combination of centering and weighting 183 | > ## - here the 'label' argument is the term label corresponding to the main 184 | > ## treatment effect 185 | > fit1$vcov <- vcov(fit1, pn = fitpn, pd = fitpd, label = "I(a - pn)") 186 | > 187 | > ## summarize the model fit 188 | > ## nb: 'estimate' can more generally consider linear combinations of regression 189 | > ## coefficients, similar to the CONTRAST or ESTIMATE statements in SAS PROC 190 | > ## GENMOD 191 | > estimate(fit1) 192 | Estimate 95% LCL 95% UCL SE Hotelling p-value 193 | (Intercept) 0.000351 -0.080117 0.080820 0.039901 0.000 0.99301 194 | I(time%%2) 0.033185 0.008242 0.058128 0.012368 7.199 0.01031 * 195 | varstate -0.000929 -0.050823 0.048965 0.024741 0.001 0.97022 196 | lag1a -0.086419 -0.149928 -0.022911 0.031492 7.531 0.00881 ** 197 | state 0.858799 0.832337 0.885260 0.013121 4283.958 < 1e-04 *** 198 | I(a - pn) -0.198920 -0.256687 -0.141152 0.028645 48.224 < 1e-04 *** 199 | state:I(a - pn) 0.188144 0.135870 0.240419 0.025921 52.685 < 1e-04 *** 200 | --- 201 | Signif. codes: 0 ‘***’ 0.001 ‘**’ 0.01 ‘*’ 0.05 ‘.’ 0.1 ‘ ’ 1 202 | > estimate(fit1, rbind("Proximal effect in state -1" = c(rep(0, 5), 1, -1), 203 | + "Proximal in state 1" = c(rep(0, 5), 1, 1))) 204 | Estimate 95% LCL 95% UCL SE Hotelling p-value 205 | Proximal effect in state -1 -0.3871 -0.4412 -0.3329 0.0432 80.198 <1e-04 206 | Proximal in state 1 -0.0108 -0.0527 0.0311 0.0334 0.104 0.809 207 | 208 | Proximal effect in state -1 *** 209 | Proximal in state 1 210 | --- 211 | Signif. codes: 0 ‘***’ 0.001 ‘**’ 0.01 ‘*’ 0.05 ‘.’ 0.1 ‘ ’ 1 212 | > 213 | > ## --- estimate the delayed treatment effect 214 | > 215 | > fit2 <- geeglm(y ~ I(time%%2) + lag1state + lag1varstate + I(lag1a - lag1pn), 216 | + weights = lag1w, id = id, data = d, subset = time > 5, 217 | + scale.fix = TRUE) 218 | > fit2$vcov <- vcov(fit2, pn = fitpn, pd = fitpd, label = "I(lag1a - lag1pn)") 219 | > estimate(fit2) 220 | Estimate 95% LCL 95% UCL SE Hotelling p-value 221 | (Intercept) 0.022410 -0.078882 0.123702 0.050291 0.199 0.6580 222 | I(time%%2) -0.018921 -0.066729 0.028887 0.023736 0.635 0.4296 223 | lag1state 0.038101 0.003842 0.072361 0.017010 5.017 0.0301 * 224 | lag1varstate 0.021931 -0.038860 0.082722 0.030183 0.528 0.4712 225 | I(lag1a - lag1pn) -0.075436 -0.151452 0.000579 0.037742 3.995 0.0517 . 226 | --- 227 | Signif. codes: 0 ‘***’ 0.001 ‘**’ 0.01 ‘*’ 0.05 ‘.’ 0.1 ‘ ’ 1 228 | > 229 | > proc.time() 230 | user system elapsed 231 | 23.55 1.07 26.38 232 | -------------------------------------------------------------------------------- /sim-ar1.Rout: -------------------------------------------------------------------------------- 1 | 2 | R version 3.3.1 (2016-06-21) -- "Bug in Your Hair" 3 | Copyright (C) 2016 The R Foundation for Statistical Computing 4 | Platform: x86_64-pc-linux-gnu (64-bit) 5 | 6 | R is free software and comes with ABSOLUTELY NO WARRANTY. 7 | You are welcome to redistribute it under certain conditions. 8 | Type 'license()' or 'licence()' for distribution details. 9 | 10 | Natural language support but running in an English locale 11 | 12 | R is a collaborative project with many contributors. 13 | Type 'contributors()' for more information and 14 | 'citation()' on how to cite R or R packages in publications. 15 | 16 | Type 'demo()' for some demos, 'help()' for on-line help, or 17 | 'help.start()' for an HTML browser interface to help. 18 | Type 'q()' to quit R. 19 | 20 | > library("foreach") 21 | > library("doParallel") 22 | Loading required package: iterators 23 | Loading required package: parallel 24 | > library("parallel") 25 | > source("init.R") 26 | 27 | Attaching package: ‘zoo’ 28 | 29 | The following objects are masked from ‘package:base’: 30 | 31 | as.Date, as.Date.numeric 32 | 33 | make: Nothing to be done for `all'. 34 | > source("sim.R") 35 | > 36 | > ## set number of Monte Carlo replicates 37 | > M <- 1000 38 | > 39 | > ## set number of threads to use for parallel processing and the random seed 40 | > ## (nb: these two values ensure that the results are replicable) 41 | > cores <- 2 42 | > seed <- 0 43 | > 44 | > cl <- makeCluster(getOption("cl.cores", cores)) 45 | > clusterEvalQ(cl, source("init.R")) 46 | make: Nothing to be done for `all'. 47 | make: Nothing to be done for `all'. 48 | [[1]] 49 | [[1]]$value 50 | [[1]]$value$value 51 | function (origin = 1, sd = 1, coralpha = sqrt(0.5), corstr = c("ar1", 52 | "exchangeable"), beta0 = c(-0.2, 0, 0, 0.2, 0), beta1 = rep(0, 53 | 4), eta = c(0, 0, 0.8, -0.8, 0), mu = rep(0, 3), theta0 = c(0, 54 | 0.8), theta1 = c(0, 0), coef.avail = c(100, rep(0, 3)), coef.state = rep(0, 55 | 5), tfun = NULL, lag = 3 + any(beta1 != 0)) 56 | { 57 | corstr <- match.arg(corstr) 58 | if (is.null(tfun)) 59 | tfun <- rep(list(function(tcur, tmax) rep(0, length(tcur))), 60 | 4) 61 | list(origin = 1, lag = lag, sd = sd, coralpha = coralpha, 62 | corstr = corstr, beta0 = setNames(beta0, c("one", "tmod", 63 | "base", "state", "lag1a")), beta1 = setNames(beta1, 64 | c("one", "lag1tmod", "base", "lag1state")), eta = setNames(eta, 65 | c("one", "base", "state", "lag1a", "lag1y")), mu = setNames(mu, 66 | c("one", "ty", "base")), theta0 = setNames(theta0, 67 | c("avail", "state")), theta1 = setNames(theta1, c("lag1avail", 68 | "lag1state")), coef.avail = setNames(coef.avail, 69 | c("one", "tavail", "lag1a", "lag1y")), coef.state = setNames(coef.state, 70 | c("one", "tstate", "base", "lag1state", "lag1a")), 71 | tfun = setNames(tfun, c("ty", "tmod", "tavail", "tstate"))) 72 | } 73 | 74 | [[1]]$value$visible 75 | [1] FALSE 76 | 77 | 78 | [[1]]$visible 79 | [1] FALSE 80 | 81 | 82 | [[2]] 83 | [[2]]$value 84 | [[2]]$value$value 85 | function (origin = 1, sd = 1, coralpha = sqrt(0.5), corstr = c("ar1", 86 | "exchangeable"), beta0 = c(-0.2, 0, 0, 0.2, 0), beta1 = rep(0, 87 | 4), eta = c(0, 0, 0.8, -0.8, 0), mu = rep(0, 3), theta0 = c(0, 88 | 0.8), theta1 = c(0, 0), coef.avail = c(100, rep(0, 3)), coef.state = rep(0, 89 | 5), tfun = NULL, lag = 3 + any(beta1 != 0)) 90 | { 91 | corstr <- match.arg(corstr) 92 | if (is.null(tfun)) 93 | tfun <- rep(list(function(tcur, tmax) rep(0, length(tcur))), 94 | 4) 95 | list(origin = 1, lag = lag, sd = sd, coralpha = coralpha, 96 | corstr = corstr, beta0 = setNames(beta0, c("one", "tmod", 97 | "base", "state", "lag1a")), beta1 = setNames(beta1, 98 | c("one", "lag1tmod", "base", "lag1state")), eta = setNames(eta, 99 | c("one", "base", "state", "lag1a", "lag1y")), mu = setNames(mu, 100 | c("one", "ty", "base")), theta0 = setNames(theta0, 101 | c("avail", "state")), theta1 = setNames(theta1, c("lag1avail", 102 | "lag1state")), coef.avail = setNames(coef.avail, 103 | c("one", "tavail", "lag1a", "lag1y")), coef.state = setNames(coef.state, 104 | c("one", "tstate", "base", "lag1state", "lag1a")), 105 | tfun = setNames(tfun, c("ty", "tmod", "tavail", "tstate"))) 106 | } 107 | 108 | [[2]]$value$visible 109 | [1] FALSE 110 | 111 | 112 | [[2]]$visible 113 | [1] FALSE 114 | 115 | 116 | > registerDoParallel(cl) 117 | > 118 | > ## control parameters for the generative model 119 | > beta0 <- c(-0.2, 0, 0, 0, 0) # unmoderated proximal effect 120 | > beta1 <- c(-0.1, 0, 0, 0) # unmoderated delayed effect 121 | > coef.state <- c(0, 0, 0, 0, 0.1) # state depends on past treatment 122 | > eta <- rep(0, 5) # treatment probability = 1/2 123 | > 124 | > sim.ar1 <- function() { 125 | + out <- NULL 126 | + for (n in c(30, 60)) { 127 | + for (tmax in c(30, 50)) { 128 | + ## obtain true correlation matrix, trimmed down to effective size 129 | + ## ("effective" observations avoid (lags of) initial values) 130 | + attrib <- attributes(rsnmm(n, tmax, beta0 = beta0, beta1 = beta1, 131 | + coef.state = coef.state, eta = eta)) 132 | + ## by default the true correlation structure is AR(1) with (u, t)th error 133 | + ## correlation sqrt(0.5)^abs(u - t) 134 | + cormatrix <- attrib$cormatrix[1:(tmax - attrib$lag + 1), 135 | + 1:(tmax - attrib$lag + 1)] 136 | + clusterSetRNGStream(cl, seed) 137 | + out <- rbind(out, 138 | + sim(n, tmax, M, 139 | + ## regress response on proximal treatment, centered by the 140 | + ## true treatment probability 141 | + y.formula = list(indep = y ~ state + I(a - prob), 142 | + ar1 = y ~ state + I(a - prob)), 143 | + y.names = c(indep = "Independence", 144 | + ar1 = "AR(1)"), 145 | + y.label = list(indep = "I(a - prob)", 146 | + ar1 = "I(a - prob)"), 147 | + ## employ different working correlation structures 148 | + y.args = list(indep = list(), 149 | + ar1 = list(corstr = "userdefined", 150 | + wcor = cormatrix)), 151 | + a.formula = NULL, a.names = NULL, 152 | + beta0 = beta0, beta1 = beta1, coef.state = coef.state, 153 | + eta = eta)) 154 | + } 155 | + } 156 | + out 157 | + } 158 | > 159 | > ar1 <- sim.ar1() 160 | 161 | Generative model attributes 162 | 163 | $origin 164 | [1] 1 165 | 166 | $lag 167 | [1] 4 168 | 169 | $sd 170 | [1] 1 171 | 172 | $coralpha 173 | [1] 0.7071068 174 | 175 | $corstr 176 | [1] "ar1" 177 | 178 | $beta0 179 | one tmod base state lag1a 180 | -0.2 0.0 0.0 0.0 0.0 181 | 182 | $beta1 183 | one lag1tmod base lag1state 184 | -0.1 0.0 0.0 0.0 185 | 186 | $eta 187 | one base state lag1a lag1y 188 | 0 0 0 0 0 189 | 190 | $mu 191 | one ty base 192 | 0 0 0 193 | 194 | $theta0 195 | avail state 196 | 0.0 0.8 197 | 198 | $theta1 199 | lag1avail lag1state 200 | 0 0 201 | 202 | $coef.avail 203 | one tavail lag1a lag1y 204 | 100 0 0 0 205 | 206 | $coef.state 207 | one tstate base lag1state lag1a 208 | 0.0 0.0 0.0 0.0 0.1 209 | 210 | $tfun 211 | $tfun$ty 212 | function (tcur, tmax) 213 | rep(0, length(tcur)) 214 | 215 | 216 | $tfun$tmod 217 | function (tcur, tmax) 218 | rep(0, length(tcur)) 219 | 220 | 221 | $tfun$tavail 222 | function (tcur, tmax) 223 | rep(0, length(tcur)) 224 | 225 | 226 | $tfun$tstate 227 | function (tcur, tmax) 228 | rep(0, length(tcur)) 229 | 230 | 231 | 232 | Analysis models 233 | 234 | Independence: y ~ state + I(a - prob) 235 | 236 | AR(1): y ~ state + I(a - prob) 237 | 238 | Treatment probability models 239 | 240 | 241 | Generative model attributes 242 | 243 | $origin 244 | [1] 1 245 | 246 | $lag 247 | [1] 4 248 | 249 | $sd 250 | [1] 1 251 | 252 | $coralpha 253 | [1] 0.7071068 254 | 255 | $corstr 256 | [1] "ar1" 257 | 258 | $beta0 259 | one tmod base state lag1a 260 | -0.2 0.0 0.0 0.0 0.0 261 | 262 | $beta1 263 | one lag1tmod base lag1state 264 | -0.1 0.0 0.0 0.0 265 | 266 | $eta 267 | one base state lag1a lag1y 268 | 0 0 0 0 0 269 | 270 | $mu 271 | one ty base 272 | 0 0 0 273 | 274 | $theta0 275 | avail state 276 | 0.0 0.8 277 | 278 | $theta1 279 | lag1avail lag1state 280 | 0 0 281 | 282 | $coef.avail 283 | one tavail lag1a lag1y 284 | 100 0 0 0 285 | 286 | $coef.state 287 | one tstate base lag1state lag1a 288 | 0.0 0.0 0.0 0.0 0.1 289 | 290 | $tfun 291 | $tfun$ty 292 | function (tcur, tmax) 293 | rep(0, length(tcur)) 294 | 295 | 296 | $tfun$tmod 297 | function (tcur, tmax) 298 | rep(0, length(tcur)) 299 | 300 | 301 | $tfun$tavail 302 | function (tcur, tmax) 303 | rep(0, length(tcur)) 304 | 305 | 306 | $tfun$tstate 307 | function (tcur, tmax) 308 | rep(0, length(tcur)) 309 | 310 | 311 | 312 | Analysis models 313 | 314 | Independence: y ~ state + I(a - prob) 315 | 316 | AR(1): y ~ state + I(a - prob) 317 | 318 | Treatment probability models 319 | 320 | 321 | Generative model attributes 322 | 323 | $origin 324 | [1] 1 325 | 326 | $lag 327 | [1] 4 328 | 329 | $sd 330 | [1] 1 331 | 332 | $coralpha 333 | [1] 0.7071068 334 | 335 | $corstr 336 | [1] "ar1" 337 | 338 | $beta0 339 | one tmod base state lag1a 340 | -0.2 0.0 0.0 0.0 0.0 341 | 342 | $beta1 343 | one lag1tmod base lag1state 344 | -0.1 0.0 0.0 0.0 345 | 346 | $eta 347 | one base state lag1a lag1y 348 | 0 0 0 0 0 349 | 350 | $mu 351 | one ty base 352 | 0 0 0 353 | 354 | $theta0 355 | avail state 356 | 0.0 0.8 357 | 358 | $theta1 359 | lag1avail lag1state 360 | 0 0 361 | 362 | $coef.avail 363 | one tavail lag1a lag1y 364 | 100 0 0 0 365 | 366 | $coef.state 367 | one tstate base lag1state lag1a 368 | 0.0 0.0 0.0 0.0 0.1 369 | 370 | $tfun 371 | $tfun$ty 372 | function (tcur, tmax) 373 | rep(0, length(tcur)) 374 | 375 | 376 | $tfun$tmod 377 | function (tcur, tmax) 378 | rep(0, length(tcur)) 379 | 380 | 381 | $tfun$tavail 382 | function (tcur, tmax) 383 | rep(0, length(tcur)) 384 | 385 | 386 | $tfun$tstate 387 | function (tcur, tmax) 388 | rep(0, length(tcur)) 389 | 390 | 391 | 392 | Analysis models 393 | 394 | Independence: y ~ state + I(a - prob) 395 | 396 | AR(1): y ~ state + I(a - prob) 397 | 398 | Treatment probability models 399 | 400 | 401 | Generative model attributes 402 | 403 | $origin 404 | [1] 1 405 | 406 | $lag 407 | [1] 4 408 | 409 | $sd 410 | [1] 1 411 | 412 | $coralpha 413 | [1] 0.7071068 414 | 415 | $corstr 416 | [1] "ar1" 417 | 418 | $beta0 419 | one tmod base state lag1a 420 | -0.2 0.0 0.0 0.0 0.0 421 | 422 | $beta1 423 | one lag1tmod base lag1state 424 | -0.1 0.0 0.0 0.0 425 | 426 | $eta 427 | one base state lag1a lag1y 428 | 0 0 0 0 0 429 | 430 | $mu 431 | one ty base 432 | 0 0 0 433 | 434 | $theta0 435 | avail state 436 | 0.0 0.8 437 | 438 | $theta1 439 | lag1avail lag1state 440 | 0 0 441 | 442 | $coef.avail 443 | one tavail lag1a lag1y 444 | 100 0 0 0 445 | 446 | $coef.state 447 | one tstate base lag1state lag1a 448 | 0.0 0.0 0.0 0.0 0.1 449 | 450 | $tfun 451 | $tfun$ty 452 | function (tcur, tmax) 453 | rep(0, length(tcur)) 454 | 455 | 456 | $tfun$tmod 457 | function (tcur, tmax) 458 | rep(0, length(tcur)) 459 | 460 | 461 | $tfun$tavail 462 | function (tcur, tmax) 463 | rep(0, length(tcur)) 464 | 465 | 466 | $tfun$tstate 467 | function (tcur, tmax) 468 | rep(0, length(tcur)) 469 | 470 | 471 | 472 | Analysis models 473 | 474 | Independence: y ~ state + I(a - prob) 475 | 476 | AR(1): y ~ state + I(a - prob) 477 | 478 | Treatment probability models 479 | 480 | > save(ar1, file = "sim-ar1.RData") 481 | > 482 | > stopCluster(cl) 483 | > 484 | > proc.time() 485 | user system elapsed 486 | 7.160 0.287 12534.663 487 | -------------------------------------------------------------------------------- /sim-stable.Rout: -------------------------------------------------------------------------------- 1 | 2 | R version 3.3.1 (2016-06-21) -- "Bug in Your Hair" 3 | Copyright (C) 2016 The R Foundation for Statistical Computing 4 | Platform: x86_64-pc-linux-gnu (64-bit) 5 | 6 | R is free software and comes with ABSOLUTELY NO WARRANTY. 7 | You are welcome to redistribute it under certain conditions. 8 | Type 'license()' or 'licence()' for distribution details. 9 | 10 | Natural language support but running in an English locale 11 | 12 | R is a collaborative project with many contributors. 13 | Type 'contributors()' for more information and 14 | 'citation()' on how to cite R or R packages in publications. 15 | 16 | Type 'demo()' for some demos, 'help()' for on-line help, or 17 | 'help.start()' for an HTML browser interface to help. 18 | Type 'q()' to quit R. 19 | 20 | > library("foreach") 21 | > library("doParallel") 22 | Loading required package: iterators 23 | Loading required package: parallel 24 | > library("parallel") 25 | > source("init.R") 26 | 27 | Attaching package: ‘zoo’ 28 | 29 | The following objects are masked from ‘package:base’: 30 | 31 | as.Date, as.Date.numeric 32 | 33 | make: Nothing to be done for `all'. 34 | > source("sim.R") 35 | > 36 | > ## set number of Monte Carlo replicates 37 | > M <- 1000 38 | > 39 | > ## set number of threads to use for parallel processing and the random seed 40 | > ## nb: these two values ensure that the results are replicable 41 | > cores <- 2 42 | > seed <- 0 43 | > 44 | > cl <- makeCluster(getOption("cl.cores", cores)) 45 | > clusterEvalQ(cl, source("init.R")) 46 | make: Nothing to be done for `all'. 47 | make: Nothing to be done for `all'. 48 | [[1]] 49 | [[1]]$value 50 | [[1]]$value$value 51 | function (origin = 1, sd = 1, coralpha = sqrt(0.5), corstr = c("ar1", 52 | "exchangeable"), beta0 = c(-0.2, 0, 0, 0.2, 0), beta1 = rep(0, 53 | 4), eta = c(0, 0, 0.8, -0.8, 0), mu = rep(0, 3), theta0 = c(0, 54 | 0.8), theta1 = c(0, 0), coef.avail = c(100, rep(0, 3)), coef.state = rep(0, 55 | 5), tfun = NULL, lag = 3 + any(beta1 != 0)) 56 | { 57 | corstr <- match.arg(corstr) 58 | if (is.null(tfun)) 59 | tfun <- rep(list(function(tcur, tmax) rep(0, length(tcur))), 60 | 4) 61 | list(origin = 1, lag = lag, sd = sd, coralpha = coralpha, 62 | corstr = corstr, beta0 = setNames(beta0, c("one", "tmod", 63 | "base", "state", "lag1a")), beta1 = setNames(beta1, 64 | c("one", "lag1tmod", "base", "lag1state")), eta = setNames(eta, 65 | c("one", "base", "state", "lag1a", "lag1y")), mu = setNames(mu, 66 | c("one", "ty", "base")), theta0 = setNames(theta0, 67 | c("avail", "state")), theta1 = setNames(theta1, c("lag1avail", 68 | "lag1state")), coef.avail = setNames(coef.avail, 69 | c("one", "tavail", "lag1a", "lag1y")), coef.state = setNames(coef.state, 70 | c("one", "tstate", "base", "lag1state", "lag1a")), 71 | tfun = setNames(tfun, c("ty", "tmod", "tavail", "tstate"))) 72 | } 73 | 74 | [[1]]$value$visible 75 | [1] FALSE 76 | 77 | 78 | [[1]]$visible 79 | [1] FALSE 80 | 81 | 82 | [[2]] 83 | [[2]]$value 84 | [[2]]$value$value 85 | function (origin = 1, sd = 1, coralpha = sqrt(0.5), corstr = c("ar1", 86 | "exchangeable"), beta0 = c(-0.2, 0, 0, 0.2, 0), beta1 = rep(0, 87 | 4), eta = c(0, 0, 0.8, -0.8, 0), mu = rep(0, 3), theta0 = c(0, 88 | 0.8), theta1 = c(0, 0), coef.avail = c(100, rep(0, 3)), coef.state = rep(0, 89 | 5), tfun = NULL, lag = 3 + any(beta1 != 0)) 90 | { 91 | corstr <- match.arg(corstr) 92 | if (is.null(tfun)) 93 | tfun <- rep(list(function(tcur, tmax) rep(0, length(tcur))), 94 | 4) 95 | list(origin = 1, lag = lag, sd = sd, coralpha = coralpha, 96 | corstr = corstr, beta0 = setNames(beta0, c("one", "tmod", 97 | "base", "state", "lag1a")), beta1 = setNames(beta1, 98 | c("one", "lag1tmod", "base", "lag1state")), eta = setNames(eta, 99 | c("one", "base", "state", "lag1a", "lag1y")), mu = setNames(mu, 100 | c("one", "ty", "base")), theta0 = setNames(theta0, 101 | c("avail", "state")), theta1 = setNames(theta1, c("lag1avail", 102 | "lag1state")), coef.avail = setNames(coef.avail, 103 | c("one", "tavail", "lag1a", "lag1y")), coef.state = setNames(coef.state, 104 | c("one", "tstate", "base", "lag1state", "lag1a")), 105 | tfun = setNames(tfun, c("ty", "tmod", "tavail", "tstate"))) 106 | } 107 | 108 | [[2]]$value$visible 109 | [1] FALSE 110 | 111 | 112 | [[2]]$visible 113 | [1] FALSE 114 | 115 | 116 | > registerDoParallel(cl) 117 | > 118 | > sim.stable <- function() { 119 | + out <- NULL 120 | + for (n in c(30,60)) { 121 | + for (tmax in c(30,50)) { 122 | + clusterSetRNGStream(cl, seed) 123 | + out <- rbind(out, 124 | + sim(n, tmax, M, 125 | + ## regress response on proximal treatment, centered by a 126 | + ## probability that is either (i) constant over time or 127 | + ## (ii) time-varying 128 | + y.formula = list(fixed = y ~ state + I(a - pfixed), 129 | + vary = y ~ state + I(a - pvary)), 130 | + y.names = c(fixed = "Constant in $t$ (i)", 131 | + vary = "Depends on $S_t$ (ii)"), 132 | + y.label = list(fixed = "I(a - pfixed)", 133 | + vary = "I(a - pvary)"), 134 | + ## weight regression using the true treatment probability 135 | + ## in the denominator 136 | + y.args = list(fixed = list(wn = "pfixed", wd = "prob"), 137 | + vary = list(wn = "pvary", wd = "prob")), 138 | + ## model numerator probability with (i) intercept only and 139 | + ## (ii) state, which is time-varying 140 | + a.formula = list(pfixed = a ~ 1, 141 | + pvary = a ~ state), 142 | + a.names = c(pfixed = "Constant in $t$ (i)", 143 | + pvary = "Depends on $S_t$ (ii)"), 144 | + ## use default generative model, but with medium level of 145 | + ## moderation by state and an unmoderated delayed effect 146 | + beta0 = c(-0.2, 0, 0, 0.5, 0), 147 | + beta1 = c(-0.1, 0, 0, 0) 148 | + )) 149 | + } 150 | + } 151 | + out 152 | + } 153 | > 154 | > stable <- sim.stable() 155 | 156 | Generative model attributes 157 | 158 | $origin 159 | [1] 1 160 | 161 | $lag 162 | [1] 4 163 | 164 | $sd 165 | [1] 1 166 | 167 | $coralpha 168 | [1] 0.7071068 169 | 170 | $corstr 171 | [1] "ar1" 172 | 173 | $beta0 174 | one tmod base state lag1a 175 | -0.2 0.0 0.0 0.5 0.0 176 | 177 | $beta1 178 | one lag1tmod base lag1state 179 | -0.1 0.0 0.0 0.0 180 | 181 | $eta 182 | one base state lag1a lag1y 183 | 0.0 0.0 0.8 -0.8 0.0 184 | 185 | $mu 186 | one ty base 187 | 0 0 0 188 | 189 | $theta0 190 | avail state 191 | 0.0 0.8 192 | 193 | $theta1 194 | lag1avail lag1state 195 | 0 0 196 | 197 | $coef.avail 198 | one tavail lag1a lag1y 199 | 100 0 0 0 200 | 201 | $coef.state 202 | one tstate base lag1state lag1a 203 | 0 0 0 0 0 204 | 205 | $tfun 206 | $tfun$ty 207 | function (tcur, tmax) 208 | rep(0, length(tcur)) 209 | 210 | 211 | $tfun$tmod 212 | function (tcur, tmax) 213 | rep(0, length(tcur)) 214 | 215 | 216 | $tfun$tavail 217 | function (tcur, tmax) 218 | rep(0, length(tcur)) 219 | 220 | 221 | $tfun$tstate 222 | function (tcur, tmax) 223 | rep(0, length(tcur)) 224 | 225 | 226 | 227 | Analysis models 228 | 229 | Constant in $t$ (i): y ~ state + I(a - pfixed) 230 | 231 | Depends on $S_t$ (ii): y ~ state + I(a - pvary) 232 | 233 | Treatment probability models 234 | 235 | Constant in $t$ (i): a ~ 1 236 | 237 | Depends on $S_t$ (ii): a ~ state 238 | 239 | 240 | Generative model attributes 241 | 242 | $origin 243 | [1] 1 244 | 245 | $lag 246 | [1] 4 247 | 248 | $sd 249 | [1] 1 250 | 251 | $coralpha 252 | [1] 0.7071068 253 | 254 | $corstr 255 | [1] "ar1" 256 | 257 | $beta0 258 | one tmod base state lag1a 259 | -0.2 0.0 0.0 0.5 0.0 260 | 261 | $beta1 262 | one lag1tmod base lag1state 263 | -0.1 0.0 0.0 0.0 264 | 265 | $eta 266 | one base state lag1a lag1y 267 | 0.0 0.0 0.8 -0.8 0.0 268 | 269 | $mu 270 | one ty base 271 | 0 0 0 272 | 273 | $theta0 274 | avail state 275 | 0.0 0.8 276 | 277 | $theta1 278 | lag1avail lag1state 279 | 0 0 280 | 281 | $coef.avail 282 | one tavail lag1a lag1y 283 | 100 0 0 0 284 | 285 | $coef.state 286 | one tstate base lag1state lag1a 287 | 0 0 0 0 0 288 | 289 | $tfun 290 | $tfun$ty 291 | function (tcur, tmax) 292 | rep(0, length(tcur)) 293 | 294 | 295 | $tfun$tmod 296 | function (tcur, tmax) 297 | rep(0, length(tcur)) 298 | 299 | 300 | $tfun$tavail 301 | function (tcur, tmax) 302 | rep(0, length(tcur)) 303 | 304 | 305 | $tfun$tstate 306 | function (tcur, tmax) 307 | rep(0, length(tcur)) 308 | 309 | 310 | 311 | Analysis models 312 | 313 | Constant in $t$ (i): y ~ state + I(a - pfixed) 314 | 315 | Depends on $S_t$ (ii): y ~ state + I(a - pvary) 316 | 317 | Treatment probability models 318 | 319 | Constant in $t$ (i): a ~ 1 320 | 321 | Depends on $S_t$ (ii): a ~ state 322 | 323 | 324 | Generative model attributes 325 | 326 | $origin 327 | [1] 1 328 | 329 | $lag 330 | [1] 4 331 | 332 | $sd 333 | [1] 1 334 | 335 | $coralpha 336 | [1] 0.7071068 337 | 338 | $corstr 339 | [1] "ar1" 340 | 341 | $beta0 342 | one tmod base state lag1a 343 | -0.2 0.0 0.0 0.5 0.0 344 | 345 | $beta1 346 | one lag1tmod base lag1state 347 | -0.1 0.0 0.0 0.0 348 | 349 | $eta 350 | one base state lag1a lag1y 351 | 0.0 0.0 0.8 -0.8 0.0 352 | 353 | $mu 354 | one ty base 355 | 0 0 0 356 | 357 | $theta0 358 | avail state 359 | 0.0 0.8 360 | 361 | $theta1 362 | lag1avail lag1state 363 | 0 0 364 | 365 | $coef.avail 366 | one tavail lag1a lag1y 367 | 100 0 0 0 368 | 369 | $coef.state 370 | one tstate base lag1state lag1a 371 | 0 0 0 0 0 372 | 373 | $tfun 374 | $tfun$ty 375 | function (tcur, tmax) 376 | rep(0, length(tcur)) 377 | 378 | 379 | $tfun$tmod 380 | function (tcur, tmax) 381 | rep(0, length(tcur)) 382 | 383 | 384 | $tfun$tavail 385 | function (tcur, tmax) 386 | rep(0, length(tcur)) 387 | 388 | 389 | $tfun$tstate 390 | function (tcur, tmax) 391 | rep(0, length(tcur)) 392 | 393 | 394 | 395 | Analysis models 396 | 397 | Constant in $t$ (i): y ~ state + I(a - pfixed) 398 | 399 | Depends on $S_t$ (ii): y ~ state + I(a - pvary) 400 | 401 | Treatment probability models 402 | 403 | Constant in $t$ (i): a ~ 1 404 | 405 | Depends on $S_t$ (ii): a ~ state 406 | 407 | 408 | Generative model attributes 409 | 410 | $origin 411 | [1] 1 412 | 413 | $lag 414 | [1] 4 415 | 416 | $sd 417 | [1] 1 418 | 419 | $coralpha 420 | [1] 0.7071068 421 | 422 | $corstr 423 | [1] "ar1" 424 | 425 | $beta0 426 | one tmod base state lag1a 427 | -0.2 0.0 0.0 0.5 0.0 428 | 429 | $beta1 430 | one lag1tmod base lag1state 431 | -0.1 0.0 0.0 0.0 432 | 433 | $eta 434 | one base state lag1a lag1y 435 | 0.0 0.0 0.8 -0.8 0.0 436 | 437 | $mu 438 | one ty base 439 | 0 0 0 440 | 441 | $theta0 442 | avail state 443 | 0.0 0.8 444 | 445 | $theta1 446 | lag1avail lag1state 447 | 0 0 448 | 449 | $coef.avail 450 | one tavail lag1a lag1y 451 | 100 0 0 0 452 | 453 | $coef.state 454 | one tstate base lag1state lag1a 455 | 0 0 0 0 0 456 | 457 | $tfun 458 | $tfun$ty 459 | function (tcur, tmax) 460 | rep(0, length(tcur)) 461 | 462 | 463 | $tfun$tmod 464 | function (tcur, tmax) 465 | rep(0, length(tcur)) 466 | 467 | 468 | $tfun$tavail 469 | function (tcur, tmax) 470 | rep(0, length(tcur)) 471 | 472 | 473 | $tfun$tstate 474 | function (tcur, tmax) 475 | rep(0, length(tcur)) 476 | 477 | 478 | 479 | Analysis models 480 | 481 | Constant in $t$ (i): y ~ state + I(a - pfixed) 482 | 483 | Depends on $S_t$ (ii): y ~ state + I(a - pvary) 484 | 485 | Treatment probability models 486 | 487 | Constant in $t$ (i): a ~ 1 488 | 489 | Depends on $S_t$ (ii): a ~ state 490 | 491 | > save(stable, file = "sim-stable.RData") 492 | > 493 | > stopCluster(cl) 494 | > 495 | > proc.time() 496 | user system elapsed 497 | 3.394 0.308 3771.066 498 | -------------------------------------------------------------------------------- /xgeepack.R: -------------------------------------------------------------------------------- 1 | ## geepack and sandwich extras 2 | 3 | ## like 'geese.fit', but dispense with scale estimation, limit correlation 4 | ## structures, and give output similar to 'geeglm' 5 | geese.glm <- function(x, y, w = rep(1, N), id, 6 | offset = rep(0, N), soffset = rep(0, N), 7 | waves = NULL, zsca = matrix(1, N, 1), 8 | wcor = NULL, zcor = NULL, corp = NULL, 9 | control = geese.control(...), 10 | b = NULL, alpha = NULL, gm = NULL, 11 | family = gaussian(), mean.link = NULL, 12 | variance = NULL, cor.link = "identity", 13 | sca.link = "identity", link.same = TRUE, 14 | scale.fix = TRUE, scale.value = 1, 15 | corstr = c("independence", "ar1", "exchangeable", 16 | "userdefined"), ...) { 17 | corstr <- match.arg(corstr) 18 | if (corstr == "userdefined" & !is.null(wcor)) 19 | zcor <- fixed2Zcor(wcor, id, 20 | 1 + unlist(lapply(split(duplicated(id), id), cumsum))) 21 | N <- length(id) 22 | z <- list() 23 | z$geese <- geese.fit(x = x, y = y, id = id, 24 | offset = offset, soffset = soffset, 25 | weights = w, 26 | waves = waves, zsca = zsca, 27 | zcor = zcor, corp = corp, 28 | control = control, 29 | b = b, alpha = alpha, gm = gm, 30 | family = family, mean.link = mean.link, 31 | variance = variance, cor.link = cor.link, 32 | sca.link = sca.link, link.same = link.same, 33 | scale.fix = scale.fix, scale.value = scale.value, 34 | corstr = corstr, ...) 35 | if (scale.fix) z$geese$gamma <- 1 36 | z$geese$X <- x 37 | z$y <- y 38 | z$family <- family 39 | ## second derivative of mean function (mu) wrt linear predictor (eta), 40 | z$family$mu.eta2 <- mu.eta2(family$link) 41 | z$id <- z$geese$id <- id 42 | z$offset <- offset 43 | z$prior.weights <- w 44 | z$coefficients <- z$geese$beta 45 | z$corstr <- corstr 46 | z$wcor <- wcor 47 | z <- gee.scalars(z) 48 | class(z$geese) <- "geese" 49 | class(z) <- c("geeglm", "gee", "glm") 50 | z 51 | } 52 | 53 | ## fix fact that 'geeglm' doesn't consistently return a vector for the linear 54 | ## predictor, fitted values and residuals (unlike 'lm' and 'glm') 55 | gee.scalars <- function(x) { 56 | if (is.null(x$scalars)) { 57 | x$linear.predictors <- if (is.null(x$offset)) x$geese$X %*% x$geese$beta 58 | else x$offset + x$geese$X %*% x$geese$beta 59 | x$linear.predictors <- as.vector(x$linear.predictors) 60 | x$fitted.values <- as.vector(x$family$linkinv(x$linear.predictors)) 61 | x$residuals <- as.vector(x$y - x$fitted.values) 62 | x$scalars <- TRUE 63 | } 64 | x 65 | } 66 | 67 | ## define function like 'family$mu.eta', but second derivative 68 | mu.eta2 <- function(link) 69 | switch(link, 70 | "identity" = function(eta) rep(0, length(eta)), 71 | "logit" = function(eta) (exp(eta) - exp(2 * eta)) / (1 + exp(eta))^3, 72 | function(eta) stop("Extend 'mu.eta2' to '", link, "' link function.")) 73 | 74 | ## evaluate derivative of mean link function mu wrt linear predictor eta 75 | dot.mu <- function(x, order = 1) { 76 | fun <- if (order == 1) x$family$mu.eta 77 | else if (is.null(x$family$mu.eta2)) mu.eta2(x$family$link) 78 | else x$family$mu.eta2 79 | as.vector(fun(x$linear.predictors)) 80 | } 81 | 82 | ## make an 'lm' or 'glm' object more like the 'geeglm' class 83 | glm2gee <- function(x, id) { 84 | if (missing(id)) x$id <- 1:length(x$fitted.values) 85 | else { 86 | if (!is.null(x$call)) { 87 | ids <- substitute(id) 88 | x$id <- if (exists(deparse(ids), envir = parent.frame())) id 89 | else eval(ids, eval(x$call$data)) 90 | if (!is.null(x$call$subset)) 91 | x$id <- x$id[eval(x$call$subset, eval(x$call$data))] 92 | } 93 | else x$id <- id 94 | } 95 | x$corstr <- "independence" 96 | x$std.err <- "san.se" 97 | if (is.null(x$y)) x$y <- x$model[, 1] 98 | if (is.null(x$linear.predictors)) x$linear.predictors <- x$fitted.values 99 | if (is.null(x$family)) x$family <- gaussian(link = "identity") 100 | x$family$mu.eta2 <- mu.eta2(x$family$link) 101 | z <- matrix(0, 1, 1) 102 | b <- coef(x) 103 | x$geese <- list(alpha = numeric(0), beta = b, gamma = 1, 104 | vbeta = z, vbeta.ajs = z, vbeta.j1s = z, vbeta.fij = z, 105 | valpha = z, valpha.ajs = z, valpha.j1s = z, valpha.fij = z, 106 | vgamma = z, vgamma.ajs = z, vgamma.j1s = z, vgamma.fij = z, 107 | clusz = as.vector(table(x$id)), 108 | model = list(scale.fix = TRUE, corstr = x$corstr), 109 | call = x$call, X = try(model.matrix(x), silent = TRUE)) 110 | if (inherits(x$geese$X, "try-error")) x$geese$X <- NULL 111 | if (inherits(x, "glm")) { 112 | s <- summary(x) 113 | x$geese$model$scale.fix <- FALSE 114 | x$geese$gamma <- 1 / s$dispersion 115 | } 116 | else if (!is.null(x$weights)) x$prior.weights <- x$weights 117 | else x$prior.weights <- rep(1, length(id)) 118 | class(x$geese) <- "geese" 119 | class(x) <- c("geeglm", "gee", "glm", "lm") 120 | x 121 | } 122 | 123 | ## return cluster sizes, with clusters identified via the 'id' argument 124 | cluster.size <- function(x) x$geese$clusz 125 | 126 | ## return (effective) number of clusters 127 | cluster.number <- function(x, overall = TRUE) { 128 | if (overall) length(x$geese$clusz) 129 | else length(unique(x$id[x$prior.weights != 0])) 130 | } 131 | 132 | if (!"package:sandwich" %in% search()) { 133 | bread <- function(x, ...) UseMethod("bread") 134 | estfun <- function(x, ...) UseMethod("estfun") 135 | } 136 | meat.default <- sandwich::meat 137 | meat <- function(x, ...) UseMethod("meat") 138 | 139 | model.matrix.geeglm <- function(x) x$geese$X 140 | 141 | ## extract bread from geeglm's sandwich variance estimator 142 | ## (i.e. the derivative of estimating function wrt regression coefficients) 143 | ## nb: under the non-identity link, the asymptotic approximation (last line in 144 | ## the Appendix of Liang and Zeger, 1986), is valid when the model is 145 | ## correctly specified 146 | bread.geeglm <- function(x, wcovinv = NULL, invert = TRUE, approx = TRUE, ...) { 147 | approx <- approx & x$family$link != "identity" 148 | if (is.null(wcovinv)) wcovinv <- working.covariance(x, invert = TRUE) 149 | g <- if (approx) function(D, V, r, X, k) 0 150 | else function(D, V, r, X, k) t(D) %*% V %*% diag(r, k) %*% X 151 | b <- mapply(function(D, DD, V, r, X, k) g(DD, V, r, X, k) - t(D) %*% V %*% D, 152 | D = split.data.frame(model.matrix(x) * dot.mu(x), x$id), 153 | DD = split.data.frame(model.matrix(x) * dot.mu(x, 2), x$id), 154 | V = wcovinv, 155 | r = split(x$y - x$fitted.values, x$id), 156 | X = split.data.frame(model.matrix(x), x$id), 157 | k = cluster.size(x), 158 | SIMPLIFY = FALSE) 159 | b <- Reduce("+", b) 160 | if (invert) b <- solve(b) 161 | b 162 | } 163 | 164 | ## extract projection matrices 165 | leverage <- function(x, wcovinv = NULL, invert = TRUE) { 166 | if (is.null(wcovinv)) wcovinv <- working.covariance(x, invert = TRUE) 167 | B <- -bread.geeglm(x, wcovinv) 168 | g <- if (invert) function(m) solve(diag(nrow(m)) - m) 169 | else identity 170 | mapply(function(D, V, k) g(D %*% B %*% t(D) %*% V), 171 | D = split.data.frame(model.matrix(x) * dot.mu(x), x$id), 172 | V = wcovinv, 173 | SIMPLIFY = FALSE) 174 | } 175 | 176 | ## extract geeglm's estimating function 177 | estfun.geeglm <- function(x, wcovinv = NULL, small = TRUE, res = FALSE, ...) { 178 | if (is.null(wcovinv)) wcovinv <- working.covariance(x, invert = TRUE) 179 | ## apply Mancl and DeRouen's (2001) small sample correction 180 | if (is.logical(small)) small <- small * 50 181 | n <- cluster.number(x, overall = FALSE) 182 | scale <- if (n <= small) leverage(x, wcovinv) 183 | else lapply(cluster.size(x), function(k) diag(1, k)) 184 | r <- mapply(function(S, r) S %*% r, 185 | S = scale, 186 | r = split(x$y - x$fitted.values, x$id), 187 | SIMPLIFY = FALSE) 188 | e <- mapply(function(D, V, r) t(D) %*% V %*% r, 189 | D = split.data.frame(model.matrix(x) * dot.mu(x), x$id), 190 | V = wcovinv, 191 | r = r, 192 | SIMPLIFY = FALSE) 193 | e <- do.call("rbind", lapply(e, t)) 194 | if (res) list(estfun = e, residuals = do.call("c", r), small = small) 195 | else e 196 | } 197 | 198 | ## extract meat from geeglm's sandwich variance estimator, where: 199 | ## 'x' is the model object for lagged effects (lag 0 is proximal) 200 | ## 'pd' gives "denominator" treatment probability 201 | ## 'pn' gives "numerator" treatment probability 202 | ## 'label' is the term label for the main treatment effect 203 | meat.geeglm <- function(x, pn = NULL, pd = pn, lag = 0, wcovinv = NULL, 204 | label = NULL, correct.all = TRUE, ...) { 205 | if (is.null(wcovinv)) wcovinv <- working.covariance(x, invert = TRUE) 206 | ## nb: small sample correction threshold can be set via '...' 207 | ## no correction is applied to the estimating functions from 'pd' and 'pn' 208 | u <- estfun.geeglm(x, wcovinv = wcovinv, res = TRUE, ...) 209 | res <- u$residuals 210 | small <- u$small 211 | u <- u$estfun 212 | ## any centering or weighting with estimated probabilities? 213 | if (inherits(pd, "geeglm")) { 214 | if (is.null(pn)) stop("Specify a non-NULL numerator probability 'pn'.") 215 | if (x$family$link != "identity") 216 | stop("Only the identity link is supported under centering or weighting.") 217 | ## centering? 218 | center <- inherits(pn, "geeglm") 219 | ## weighting? 220 | weight <- !identical(pd, pn) 221 | ## return cluster-level derivative (terms) of... 222 | ## ... effect estimating function wrt treatment probability 223 | Ux.p <- function(D, V, r, k, Dp, p = rep(1, nrow(Dp)), j) 224 | t(D) %*% diag(p[j]) %*% V %*% diag(r, k) %*% Dp[j, , drop = FALSE] 225 | ## ... (observed) treatment probability wrt its regression model coefficients 226 | Up.coef <- function(p, one = TRUE) 227 | model.matrix(p) * dot.mu(p) * 228 | ifelse(p$weights == 0, 0, 229 | 1 / ifelse(p$y == 1 | one, p$fitted.values, p$fitted.values - 1)) 230 | ## evaluate general expression for extra additive term in meat 231 | extra <- function(p, sig) { 232 | v <- working.covariance(p, invert = TRUE) 233 | b <- bread.geeglm(p, wcovinv = v, approx = FALSE) 234 | estfun.geeglm(p, wcovinv = v, small = FALSE) %*% b %*% t(sig) 235 | } 236 | ## optionally apply any small-sample correction only to original "meat" term 237 | if (small & !correct.all) res <- with(x, y - fitted.values) 238 | ## augment meat for estimated weights 239 | if (weight) { 240 | pd <- gee.scalars(pd) 241 | ## keep aligned with observations in 'x' 242 | obs <- align.obs(x, pd, lag) 243 | sig <- mapply(Ux.p, 244 | D = split.data.frame(model.matrix(x) * dot.mu(x), x$id), 245 | V = wcovinv, 246 | r = split(res, x$id), 247 | k = cluster.size(x), 248 | Dp = split.data.frame(Up.coef(pd, one = FALSE), pd$id), 249 | j = obs, 250 | SIMPLIFY = FALSE) 251 | sig <- Reduce("+", sig) 252 | u <- u - extra(pd, sig) 253 | } 254 | ## augment meat for estimated centering probabilities 255 | if (center) { 256 | if (is.null(label)) stop("Specify non-NULL treatment term label.") 257 | label <- attributes(terms(as.formula(paste("y ~", label))))$term.labels 258 | pn <- gee.scalars(pn) 259 | ## indices of design matrix related to treatment effects 260 | k <- which.terms(x, label) 261 | obs <- align.obs(x, pn, lag) 262 | sig1 <- mapply(Ux.p, 263 | D = split.data.frame(model.matrix(x) * dot.mu(x), x$id), 264 | V = wcovinv, 265 | r = split(res, x$id), 266 | k = cluster.size(x), 267 | Dp = split.data.frame(Up.coef(pn, one = FALSE), pn$id), 268 | j = obs, 269 | SIMPLIFY = FALSE) 270 | sig1 <- Reduce("+", sig1) 271 | ## design matrix component in second term of partial derivative is... 272 | mm2 <- model.matrix(x) 273 | ## ... zero in columns for main effect 274 | mm2[, -k] <- 0 275 | ## ... scaled by negative probability in columns for treatment effect 276 | mm2[, k] <- -mm2[, k] * ifelse(x$weights == 0, 0, 277 | 1 / as.vector(mm2[, k[1]])) 278 | sig2 <- mapply(Ux.p, 279 | D = split.data.frame(mm2 * dot.mu(x), x$id), 280 | V = wcovinv, 281 | r = split(res, x$id), 282 | k = cluster.size(x), 283 | Dp = split.data.frame(Up.coef(pn), pn$id), 284 | p = split(pn$fitted.values, pn$id), 285 | j = obs, 286 | SIMPLIFY = FALSE) 287 | sig2 <- Reduce("+", sig2) 288 | ## residual component in third term reduces to probability factor 289 | resid3 <- as.vector(-mm2[, k, drop = FALSE] %*% coef(x)[k]) 290 | sig3 <- mapply(Ux.p, 291 | D = split.data.frame(model.matrix(x) * dot.mu(x), x$id), 292 | V = wcovinv, 293 | r = split(resid3, x$id), 294 | k = cluster.size(x), 295 | Dp = split.data.frame(Up.coef(pn), pn$id), 296 | p = split(pn$fitted.values, pn$id), 297 | j = obs, 298 | SIMPLIFY = FALSE) 299 | sig3 <- Reduce("+", sig3) 300 | u <- u - extra(pn, sig1 + sig2 + sig3) 301 | } 302 | } 303 | t(u) %*% u 304 | } 305 | 306 | ## return model 'x' design matrix column indices based on the term 'label' 307 | which.terms <- function(x, label, stripnames = FALSE) { 308 | if (is.null(x$terms)) x$terms <- terms(x) 309 | f <- attributes(x$terms)$factors 310 | j <- which(colnames(f) == label) 311 | if (length(j) != 1) stop("Treatment term label not found in 'x'.") 312 | k <- which(f[rownames(f) == label, ] != 0) 313 | w <- k >= attributes(x$terms)$intercept 314 | if (j %in% k[w]) j <- j + 1 315 | k[w] <- k[w] + 1 316 | w <- c(j, k[k != j]) 317 | ## strip label from names 318 | if (stripnames) { 319 | names(w) <- gsub(paste0(label, ":?"), "", 320 | gsub(paste0(":?", label), "", names(w), fixed = TRUE), 321 | fixed = TRUE) 322 | names(w)[1] <- "one" 323 | } 324 | w 325 | } 326 | 327 | ## return indices for observations in model 'p' that are aligned with model 'x' 328 | align.obs <- function(x, p, lag) { 329 | if (!identical(unique(x$id), unique(p$id))) 330 | stop("Treatment probabiliy model(s) should be based on the same sample.") 331 | obs.beg <- as.vector(table(p$id) - table(x$id)) - lag + 1 332 | if (any(obs.beg < 1)) 333 | stop("Treatment probability model(s) based on too few observations.") 334 | obs.end <- as.vector(table(p$id)) - lag 335 | mapply(function(i, j) i:j, obs.beg, obs.end, SIMPLIFY = FALSE) 336 | } 337 | 338 | ## extract geeglm's working covariance matrices 339 | ## nb: like glm, the 'weights' argument specifies the prior weight for the 340 | ## scale parameter of the working variance function 341 | working.covariance <- function(x, invert = FALSE, wcor = NULL) { 342 | if (is.null(wcor)) wcor <- working.correlation(x) 343 | phi <- x$geese$gamma^(x$geese$model$scale.fix - 1) 344 | g <- if (invert) function(V, w, k) diag(w, k) %*% solve(V) 345 | else function(V, w, k) diag(ifelse(w == 0, 0, 1 / w), k) %*% V 346 | mapply(function(a, s, w, k) g(phi * diag(a, k) %*% 347 | wcor[1:k, 1:k, drop = FALSE] %*% 348 | diag(a, k), w, k), 349 | a = split(sqrt(x$family$variance(x$fitted.values)), x$id), 350 | w = split(x$prior.weights, x$id), 351 | k = cluster.size(x), 352 | SIMPLIFY = FALSE) 353 | } 354 | 355 | ## extract geeglm's working correlation matrix 356 | working.correlation <- function(x, ...) { 357 | R <- x$wcor 358 | if (is.null(R)) { 359 | R <- diag(max(cluster.size(x))) 360 | if (length(x$geese$alpha)) R[lower.tri(R) | upper.tri(R)] <- x$geese$alpha 361 | if (x$corstr == "ar1") R <- R^abs(col(R) - row(R)) 362 | } 363 | R 364 | } 365 | 366 | ## calculate the sandwich estimator of the covariance matrix for the regression 367 | ## coefficients 368 | vcov.geeglm <- function(x, ...) { 369 | x <- gee.scalars(x) 370 | v <- x$vcov 371 | if (is.null(v)) { 372 | w <- working.covariance(x, invert = TRUE) 373 | b <- bread.geeglm(x, wcovinv = w) 374 | m <- meat.geeglm(x, wcovinv = w, ...) 375 | v <- b %*% m %*% t(b) 376 | } 377 | v 378 | } 379 | 380 | ## summarize linear combinations of regression coefficients, where: 381 | ## 'combos' is a matrix whose rows give the linear combinations 382 | ## 'null' gives the value of each combintation under the null hypothesis 383 | ## 'omnibus' indicates that the specified combinations should be tested 384 | ## simultaneously instead of individually 385 | estimate <- function(x, combos = NULL, omnibus = FALSE, null = 0, 386 | small = TRUE, conf.int = 0.95, normal = FALSE, ...) { 387 | if (is.null(combos)) { 388 | combos <- diag(length(coef(x))) 389 | rownames(combos) <- names(coef(x)) 390 | omnibus <- FALSE 391 | } 392 | est <- combos %*% coef(x) 393 | if (nrow(est) != length(null)) null <- rep(null[1], nrow(est)) 394 | ## apply Mancl and DeRouen's (2001) small sample correction 395 | if (is.logical(small)) small <- small * 50 396 | n <- cluster.number(x, overall = FALSE) 397 | d1 <- if (omnibus) nrow(combos) 398 | else apply(combos != 0, 1, sum) 399 | d2 <- n - length(coef(x)) 400 | ## apply Hotelling's T-squared test, following Liao et al. (2016) 401 | if (n <= small & !normal) { 402 | type <- "Hotelling" 403 | adj <- d1 * (d1 + d2 - 1) / d2 404 | qfun <- function(p) mapply(qf, p = p, df1 = d1, df2 = d2) / adj 405 | pfun <- function(q) 1 - mapply(pf, q = q * adj, df1 = d1, df2 = d2) 406 | } 407 | else { 408 | type <- "Wald" 409 | qfun <- if (normal) function(p) qnorm((1 + p) / 2) 410 | else function(p) mapply(qf, p = p, df1 = d1, df2 = d2) 411 | pfun <- if (normal) function(q) 1 - mapply(pchisq, q = q, df = d1) 412 | else function(q) 1 - mapply(pf, q = q, df1 = d1, df2 = d2) 413 | } 414 | var.est <- combos %*% vcov(x, small = small, ...) %*% t(combos) 415 | se.est <- sqrt(diag(var.est)) 416 | crit <- sqrt(qfun(conf.int)) 417 | lcl <- est - se.est * crit 418 | ucl <- est + se.est * crit 419 | stat <- if (omnibus) rep(t(est - null) %*% solve(var.est) %*% (est - null), d1) 420 | else (est - null)^2 / diag(var.est) 421 | pvalue <- pfun(stat) 422 | out <- cbind(est, lcl, ucl, se.est, stat, pvalue) 423 | rownames(out) <- rownames(combos) 424 | colnames(out) <- c("Estimate", 425 | paste0(round(conf.int * 100), "% ", c("LCL", "UCL")), 426 | "SE", type, "p-value") 427 | class(out) <- c("estimate", "matrix") 428 | out 429 | } 430 | 431 | print.estimate <- function(object, digits = min(getOption("digits"), 3), 432 | signif.stars = TRUE, eps.pvalue = 1e-4, ...) { 433 | printCoefmat(object, digits = digits, dig.tst = digits, 434 | signif.stars = signif.stars, has.Pvalue = TRUE, 435 | eps.Pvalue = eps.pvalue, ...) 436 | } 437 | -------------------------------------------------------------------------------- /sim-omit.Rout: -------------------------------------------------------------------------------- 1 | 2 | R version 3.3.1 (2016-06-21) -- "Bug in Your Hair" 3 | Copyright (C) 2016 The R Foundation for Statistical Computing 4 | Platform: x86_64-pc-linux-gnu (64-bit) 5 | 6 | R is free software and comes with ABSOLUTELY NO WARRANTY. 7 | You are welcome to redistribute it under certain conditions. 8 | Type 'license()' or 'licence()' for distribution details. 9 | 10 | Natural language support but running in an English locale 11 | 12 | R is a collaborative project with many contributors. 13 | Type 'contributors()' for more information and 14 | 'citation()' on how to cite R or R packages in publications. 15 | 16 | Type 'demo()' for some demos, 'help()' for on-line help, or 17 | 'help.start()' for an HTML browser interface to help. 18 | Type 'q()' to quit R. 19 | 20 | > library("foreach") 21 | > library("doParallel") 22 | Loading required package: iterators 23 | Loading required package: parallel 24 | > library("parallel") 25 | > source("init.R") 26 | 27 | Attaching package: ‘zoo’ 28 | 29 | The following objects are masked from ‘package:base’: 30 | 31 | as.Date, as.Date.numeric 32 | 33 | make: Nothing to be done for `all'. 34 | > source("sim.R") 35 | > 36 | > ## set number of Monte Carlo replicates 37 | > M <- 1000 38 | > 39 | > ## set number of threads to use for parallel processing and the random seed 40 | > ## (nb: these two values ensure that the results are replicable) 41 | > cores <- 4 42 | > seed <- 0 43 | > 44 | > cl <- makeCluster(getOption("cl.cores", cores)) 45 | > clusterEvalQ(cl, source("init.R")) 46 | make: Nothing to be done for `all'. 47 | make: Nothing to be done for `all'. 48 | make: Nothing to be done for `all'. 49 | make: Nothing to be done for `all'. 50 | [[1]] 51 | [[1]]$value 52 | [[1]]$value$value 53 | function (origin = 1, sd = 1, coralpha = sqrt(0.5), corstr = c("ar1", 54 | "exchangeable"), beta0 = c(-0.2, 0, 0, 0.2, 0), beta1 = rep(0, 55 | 4), eta = c(0, 0, 0.8, -0.8, 0), mu = rep(0, 3), theta0 = c(0, 56 | 0.8), theta1 = c(0, 0), coef.avail = c(100, rep(0, 3)), coef.state = rep(0, 57 | 5), tfun = NULL, lag = 3 + any(beta1 != 0)) 58 | { 59 | corstr <- match.arg(corstr) 60 | if (is.null(tfun)) 61 | tfun <- rep(list(function(tcur, tmax) rep(0, length(tcur))), 62 | 4) 63 | list(origin = 1, lag = lag, sd = sd, coralpha = coralpha, 64 | corstr = corstr, beta0 = setNames(beta0, c("one", "tmod", 65 | "base", "state", "lag1a")), beta1 = setNames(beta1, 66 | c("one", "lag1tmod", "base", "lag1state")), eta = setNames(eta, 67 | c("one", "base", "state", "lag1a", "lag1y")), mu = setNames(mu, 68 | c("one", "ty", "base")), theta0 = setNames(theta0, 69 | c("avail", "state")), theta1 = setNames(theta1, c("lag1avail", 70 | "lag1state")), coef.avail = setNames(coef.avail, 71 | c("one", "tavail", "lag1a", "lag1y")), coef.state = setNames(coef.state, 72 | c("one", "tstate", "base", "lag1state", "lag1a")), 73 | tfun = setNames(tfun, c("ty", "tmod", "tavail", "tstate"))) 74 | } 75 | 76 | [[1]]$value$visible 77 | [1] FALSE 78 | 79 | 80 | [[1]]$visible 81 | [1] FALSE 82 | 83 | 84 | [[2]] 85 | [[2]]$value 86 | [[2]]$value$value 87 | function (origin = 1, sd = 1, coralpha = sqrt(0.5), corstr = c("ar1", 88 | "exchangeable"), beta0 = c(-0.2, 0, 0, 0.2, 0), beta1 = rep(0, 89 | 4), eta = c(0, 0, 0.8, -0.8, 0), mu = rep(0, 3), theta0 = c(0, 90 | 0.8), theta1 = c(0, 0), coef.avail = c(100, rep(0, 3)), coef.state = rep(0, 91 | 5), tfun = NULL, lag = 3 + any(beta1 != 0)) 92 | { 93 | corstr <- match.arg(corstr) 94 | if (is.null(tfun)) 95 | tfun <- rep(list(function(tcur, tmax) rep(0, length(tcur))), 96 | 4) 97 | list(origin = 1, lag = lag, sd = sd, coralpha = coralpha, 98 | corstr = corstr, beta0 = setNames(beta0, c("one", "tmod", 99 | "base", "state", "lag1a")), beta1 = setNames(beta1, 100 | c("one", "lag1tmod", "base", "lag1state")), eta = setNames(eta, 101 | c("one", "base", "state", "lag1a", "lag1y")), mu = setNames(mu, 102 | c("one", "ty", "base")), theta0 = setNames(theta0, 103 | c("avail", "state")), theta1 = setNames(theta1, c("lag1avail", 104 | "lag1state")), coef.avail = setNames(coef.avail, 105 | c("one", "tavail", "lag1a", "lag1y")), coef.state = setNames(coef.state, 106 | c("one", "tstate", "base", "lag1state", "lag1a")), 107 | tfun = setNames(tfun, c("ty", "tmod", "tavail", "tstate"))) 108 | } 109 | 110 | [[2]]$value$visible 111 | [1] FALSE 112 | 113 | 114 | [[2]]$visible 115 | [1] FALSE 116 | 117 | 118 | [[3]] 119 | [[3]]$value 120 | [[3]]$value$value 121 | function (origin = 1, sd = 1, coralpha = sqrt(0.5), corstr = c("ar1", 122 | "exchangeable"), beta0 = c(-0.2, 0, 0, 0.2, 0), beta1 = rep(0, 123 | 4), eta = c(0, 0, 0.8, -0.8, 0), mu = rep(0, 3), theta0 = c(0, 124 | 0.8), theta1 = c(0, 0), coef.avail = c(100, rep(0, 3)), coef.state = rep(0, 125 | 5), tfun = NULL, lag = 3 + any(beta1 != 0)) 126 | { 127 | corstr <- match.arg(corstr) 128 | if (is.null(tfun)) 129 | tfun <- rep(list(function(tcur, tmax) rep(0, length(tcur))), 130 | 4) 131 | list(origin = 1, lag = lag, sd = sd, coralpha = coralpha, 132 | corstr = corstr, beta0 = setNames(beta0, c("one", "tmod", 133 | "base", "state", "lag1a")), beta1 = setNames(beta1, 134 | c("one", "lag1tmod", "base", "lag1state")), eta = setNames(eta, 135 | c("one", "base", "state", "lag1a", "lag1y")), mu = setNames(mu, 136 | c("one", "ty", "base")), theta0 = setNames(theta0, 137 | c("avail", "state")), theta1 = setNames(theta1, c("lag1avail", 138 | "lag1state")), coef.avail = setNames(coef.avail, 139 | c("one", "tavail", "lag1a", "lag1y")), coef.state = setNames(coef.state, 140 | c("one", "tstate", "base", "lag1state", "lag1a")), 141 | tfun = setNames(tfun, c("ty", "tmod", "tavail", "tstate"))) 142 | } 143 | 144 | [[3]]$value$visible 145 | [1] FALSE 146 | 147 | 148 | [[3]]$visible 149 | [1] FALSE 150 | 151 | 152 | [[4]] 153 | [[4]]$value 154 | [[4]]$value$value 155 | function (origin = 1, sd = 1, coralpha = sqrt(0.5), corstr = c("ar1", 156 | "exchangeable"), beta0 = c(-0.2, 0, 0, 0.2, 0), beta1 = rep(0, 157 | 4), eta = c(0, 0, 0.8, -0.8, 0), mu = rep(0, 3), theta0 = c(0, 158 | 0.8), theta1 = c(0, 0), coef.avail = c(100, rep(0, 3)), coef.state = rep(0, 159 | 5), tfun = NULL, lag = 3 + any(beta1 != 0)) 160 | { 161 | corstr <- match.arg(corstr) 162 | if (is.null(tfun)) 163 | tfun <- rep(list(function(tcur, tmax) rep(0, length(tcur))), 164 | 4) 165 | list(origin = 1, lag = lag, sd = sd, coralpha = coralpha, 166 | corstr = corstr, beta0 = setNames(beta0, c("one", "tmod", 167 | "base", "state", "lag1a")), beta1 = setNames(beta1, 168 | c("one", "lag1tmod", "base", "lag1state")), eta = setNames(eta, 169 | c("one", "base", "state", "lag1a", "lag1y")), mu = setNames(mu, 170 | c("one", "ty", "base")), theta0 = setNames(theta0, 171 | c("avail", "state")), theta1 = setNames(theta1, c("lag1avail", 172 | "lag1state")), coef.avail = setNames(coef.avail, 173 | c("one", "tavail", "lag1a", "lag1y")), coef.state = setNames(coef.state, 174 | c("one", "tstate", "base", "lag1state", "lag1a")), 175 | tfun = setNames(tfun, c("ty", "tmod", "tavail", "tstate"))) 176 | } 177 | 178 | [[4]]$value$visible 179 | [1] FALSE 180 | 181 | 182 | [[4]]$visible 183 | [1] FALSE 184 | 185 | 186 | > registerDoParallel(cl) 187 | > 188 | > sim.omit <- function() { 189 | + out <- NULL 190 | + ## low, medium and high degrees of moderation by state 191 | + for (b in c(0.2, 0.5, 0.8)) { 192 | + for (n in c(30, 60)) { 193 | + for (tmax in c(30, 50)) { 194 | + clusterSetRNGStream(cl, seed) 195 | + out <- 196 | + rbind(out, 197 | + cbind(level = paste("$\\beta_{11}^* = ", b, "$", sep = ""), 198 | + sim(n, tmax, M, 199 | + ## regress response on state and proximal treatment, 200 | + ## ignoring the underlying interaction between the two 201 | + y.formula = list(w = y ~ state + I(a - pn), 202 | + u.ind = y ~ state + a, 203 | + u.ar1 = y ~ state + a, 204 | + u.exch = y ~ state + a), 205 | + y.names = c(w = "Weighted and centered", 206 | + u.ind = "GEE independence", 207 | + u.ar1 = "GEE AR(1)", 208 | + u.exch = "GEE exchangeable"), 209 | + ## term labels for proximal treatment 210 | + y.label = list(w = "I(a - pn)", 211 | + u.ind = "a", u.ar1 = "a", u.exch = "a"), 212 | + ## specify weights and working correlation structure 213 | + y.args = list(w = list(wn = "pn", wd = "prob"), 214 | + u.ind = list(), 215 | + u.ar1 = list(corstr = "ar1"), 216 | + u.exch = list(corstr = "exch")), 217 | + ## specify weight numerator model 218 | + a.formula = list(pn = a ~ 1), 219 | + a.names = c(pn = "Intercept-only"), 220 | + ## use default generative model, but with the specified 221 | + ## level of moderation by the time-varying state 222 | + beta0 = c(-0.2, 0, 0, b, 0)))) 223 | + } 224 | + } 225 | + } 226 | + out 227 | + } 228 | > 229 | > omit <- sim.omit() 230 | 231 | Generative model attributes 232 | 233 | $origin 234 | [1] 1 235 | 236 | $lag 237 | [1] 3 238 | 239 | $sd 240 | [1] 1 241 | 242 | $coralpha 243 | [1] 0.7071068 244 | 245 | $corstr 246 | [1] "ar1" 247 | 248 | $beta0 249 | one tmod base state lag1a 250 | -0.2 0.0 0.0 0.2 0.0 251 | 252 | $beta1 253 | one lag1tmod base lag1state 254 | 0 0 0 0 255 | 256 | $eta 257 | one base state lag1a lag1y 258 | 0.0 0.0 0.8 -0.8 0.0 259 | 260 | $mu 261 | one ty base 262 | 0 0 0 263 | 264 | $theta0 265 | avail state 266 | 0.0 0.8 267 | 268 | $theta1 269 | lag1avail lag1state 270 | 0 0 271 | 272 | $coef.avail 273 | one tavail lag1a lag1y 274 | 100 0 0 0 275 | 276 | $coef.state 277 | one tstate base lag1state lag1a 278 | 0 0 0 0 0 279 | 280 | $tfun 281 | $tfun$ty 282 | function (tcur, tmax) 283 | rep(0, length(tcur)) 284 | 285 | 286 | $tfun$tmod 287 | function (tcur, tmax) 288 | rep(0, length(tcur)) 289 | 290 | 291 | $tfun$tavail 292 | function (tcur, tmax) 293 | rep(0, length(tcur)) 294 | 295 | 296 | $tfun$tstate 297 | function (tcur, tmax) 298 | rep(0, length(tcur)) 299 | 300 | 301 | 302 | Analysis models 303 | 304 | Weighted and centered: y ~ state + I(a - pn) 305 | 306 | GEE independence: y ~ state + a 307 | 308 | GEE AR(1): y ~ state + a 309 | 310 | GEE exchangeable: y ~ state + a 311 | 312 | Treatment probability models 313 | 314 | Intercept-only: a ~ 1 315 | 316 | 317 | Generative model attributes 318 | 319 | $origin 320 | [1] 1 321 | 322 | $lag 323 | [1] 3 324 | 325 | $sd 326 | [1] 1 327 | 328 | $coralpha 329 | [1] 0.7071068 330 | 331 | $corstr 332 | [1] "ar1" 333 | 334 | $beta0 335 | one tmod base state lag1a 336 | -0.2 0.0 0.0 0.2 0.0 337 | 338 | $beta1 339 | one lag1tmod base lag1state 340 | 0 0 0 0 341 | 342 | $eta 343 | one base state lag1a lag1y 344 | 0.0 0.0 0.8 -0.8 0.0 345 | 346 | $mu 347 | one ty base 348 | 0 0 0 349 | 350 | $theta0 351 | avail state 352 | 0.0 0.8 353 | 354 | $theta1 355 | lag1avail lag1state 356 | 0 0 357 | 358 | $coef.avail 359 | one tavail lag1a lag1y 360 | 100 0 0 0 361 | 362 | $coef.state 363 | one tstate base lag1state lag1a 364 | 0 0 0 0 0 365 | 366 | $tfun 367 | $tfun$ty 368 | function (tcur, tmax) 369 | rep(0, length(tcur)) 370 | 371 | 372 | $tfun$tmod 373 | function (tcur, tmax) 374 | rep(0, length(tcur)) 375 | 376 | 377 | $tfun$tavail 378 | function (tcur, tmax) 379 | rep(0, length(tcur)) 380 | 381 | 382 | $tfun$tstate 383 | function (tcur, tmax) 384 | rep(0, length(tcur)) 385 | 386 | 387 | 388 | Analysis models 389 | 390 | Weighted and centered: y ~ state + I(a - pn) 391 | 392 | GEE independence: y ~ state + a 393 | 394 | GEE AR(1): y ~ state + a 395 | 396 | GEE exchangeable: y ~ state + a 397 | 398 | Treatment probability models 399 | 400 | Intercept-only: a ~ 1 401 | 402 | 403 | Generative model attributes 404 | 405 | $origin 406 | [1] 1 407 | 408 | $lag 409 | [1] 3 410 | 411 | $sd 412 | [1] 1 413 | 414 | $coralpha 415 | [1] 0.7071068 416 | 417 | $corstr 418 | [1] "ar1" 419 | 420 | $beta0 421 | one tmod base state lag1a 422 | -0.2 0.0 0.0 0.2 0.0 423 | 424 | $beta1 425 | one lag1tmod base lag1state 426 | 0 0 0 0 427 | 428 | $eta 429 | one base state lag1a lag1y 430 | 0.0 0.0 0.8 -0.8 0.0 431 | 432 | $mu 433 | one ty base 434 | 0 0 0 435 | 436 | $theta0 437 | avail state 438 | 0.0 0.8 439 | 440 | $theta1 441 | lag1avail lag1state 442 | 0 0 443 | 444 | $coef.avail 445 | one tavail lag1a lag1y 446 | 100 0 0 0 447 | 448 | $coef.state 449 | one tstate base lag1state lag1a 450 | 0 0 0 0 0 451 | 452 | $tfun 453 | $tfun$ty 454 | function (tcur, tmax) 455 | rep(0, length(tcur)) 456 | 457 | 458 | $tfun$tmod 459 | function (tcur, tmax) 460 | rep(0, length(tcur)) 461 | 462 | 463 | $tfun$tavail 464 | function (tcur, tmax) 465 | rep(0, length(tcur)) 466 | 467 | 468 | $tfun$tstate 469 | function (tcur, tmax) 470 | rep(0, length(tcur)) 471 | 472 | 473 | 474 | Analysis models 475 | 476 | Weighted and centered: y ~ state + I(a - pn) 477 | 478 | GEE independence: y ~ state + a 479 | 480 | GEE AR(1): y ~ state + a 481 | 482 | GEE exchangeable: y ~ state + a 483 | 484 | Treatment probability models 485 | 486 | Intercept-only: a ~ 1 487 | 488 | 489 | Generative model attributes 490 | 491 | $origin 492 | [1] 1 493 | 494 | $lag 495 | [1] 3 496 | 497 | $sd 498 | [1] 1 499 | 500 | $coralpha 501 | [1] 0.7071068 502 | 503 | $corstr 504 | [1] "ar1" 505 | 506 | $beta0 507 | one tmod base state lag1a 508 | -0.2 0.0 0.0 0.2 0.0 509 | 510 | $beta1 511 | one lag1tmod base lag1state 512 | 0 0 0 0 513 | 514 | $eta 515 | one base state lag1a lag1y 516 | 0.0 0.0 0.8 -0.8 0.0 517 | 518 | $mu 519 | one ty base 520 | 0 0 0 521 | 522 | $theta0 523 | avail state 524 | 0.0 0.8 525 | 526 | $theta1 527 | lag1avail lag1state 528 | 0 0 529 | 530 | $coef.avail 531 | one tavail lag1a lag1y 532 | 100 0 0 0 533 | 534 | $coef.state 535 | one tstate base lag1state lag1a 536 | 0 0 0 0 0 537 | 538 | $tfun 539 | $tfun$ty 540 | function (tcur, tmax) 541 | rep(0, length(tcur)) 542 | 543 | 544 | $tfun$tmod 545 | function (tcur, tmax) 546 | rep(0, length(tcur)) 547 | 548 | 549 | $tfun$tavail 550 | function (tcur, tmax) 551 | rep(0, length(tcur)) 552 | 553 | 554 | $tfun$tstate 555 | function (tcur, tmax) 556 | rep(0, length(tcur)) 557 | 558 | 559 | 560 | Analysis models 561 | 562 | Weighted and centered: y ~ state + I(a - pn) 563 | 564 | GEE independence: y ~ state + a 565 | 566 | GEE AR(1): y ~ state + a 567 | 568 | GEE exchangeable: y ~ state + a 569 | 570 | Treatment probability models 571 | 572 | Intercept-only: a ~ 1 573 | 574 | 575 | Generative model attributes 576 | 577 | $origin 578 | [1] 1 579 | 580 | $lag 581 | [1] 3 582 | 583 | $sd 584 | [1] 1 585 | 586 | $coralpha 587 | [1] 0.7071068 588 | 589 | $corstr 590 | [1] "ar1" 591 | 592 | $beta0 593 | one tmod base state lag1a 594 | -0.2 0.0 0.0 0.5 0.0 595 | 596 | $beta1 597 | one lag1tmod base lag1state 598 | 0 0 0 0 599 | 600 | $eta 601 | one base state lag1a lag1y 602 | 0.0 0.0 0.8 -0.8 0.0 603 | 604 | $mu 605 | one ty base 606 | 0 0 0 607 | 608 | $theta0 609 | avail state 610 | 0.0 0.8 611 | 612 | $theta1 613 | lag1avail lag1state 614 | 0 0 615 | 616 | $coef.avail 617 | one tavail lag1a lag1y 618 | 100 0 0 0 619 | 620 | $coef.state 621 | one tstate base lag1state lag1a 622 | 0 0 0 0 0 623 | 624 | $tfun 625 | $tfun$ty 626 | function (tcur, tmax) 627 | rep(0, length(tcur)) 628 | 629 | 630 | $tfun$tmod 631 | function (tcur, tmax) 632 | rep(0, length(tcur)) 633 | 634 | 635 | $tfun$tavail 636 | function (tcur, tmax) 637 | rep(0, length(tcur)) 638 | 639 | 640 | $tfun$tstate 641 | function (tcur, tmax) 642 | rep(0, length(tcur)) 643 | 644 | 645 | 646 | Analysis models 647 | 648 | Weighted and centered: y ~ state + I(a - pn) 649 | 650 | GEE independence: y ~ state + a 651 | 652 | GEE AR(1): y ~ state + a 653 | 654 | GEE exchangeable: y ~ state + a 655 | 656 | Treatment probability models 657 | 658 | Intercept-only: a ~ 1 659 | 660 | 661 | Generative model attributes 662 | 663 | $origin 664 | [1] 1 665 | 666 | $lag 667 | [1] 3 668 | 669 | $sd 670 | [1] 1 671 | 672 | $coralpha 673 | [1] 0.7071068 674 | 675 | $corstr 676 | [1] "ar1" 677 | 678 | $beta0 679 | one tmod base state lag1a 680 | -0.2 0.0 0.0 0.5 0.0 681 | 682 | $beta1 683 | one lag1tmod base lag1state 684 | 0 0 0 0 685 | 686 | $eta 687 | one base state lag1a lag1y 688 | 0.0 0.0 0.8 -0.8 0.0 689 | 690 | $mu 691 | one ty base 692 | 0 0 0 693 | 694 | $theta0 695 | avail state 696 | 0.0 0.8 697 | 698 | $theta1 699 | lag1avail lag1state 700 | 0 0 701 | 702 | $coef.avail 703 | one tavail lag1a lag1y 704 | 100 0 0 0 705 | 706 | $coef.state 707 | one tstate base lag1state lag1a 708 | 0 0 0 0 0 709 | 710 | $tfun 711 | $tfun$ty 712 | function (tcur, tmax) 713 | rep(0, length(tcur)) 714 | 715 | 716 | $tfun$tmod 717 | function (tcur, tmax) 718 | rep(0, length(tcur)) 719 | 720 | 721 | $tfun$tavail 722 | function (tcur, tmax) 723 | rep(0, length(tcur)) 724 | 725 | 726 | $tfun$tstate 727 | function (tcur, tmax) 728 | rep(0, length(tcur)) 729 | 730 | 731 | 732 | Analysis models 733 | 734 | Weighted and centered: y ~ state + I(a - pn) 735 | 736 | GEE independence: y ~ state + a 737 | 738 | GEE AR(1): y ~ state + a 739 | 740 | GEE exchangeable: y ~ state + a 741 | 742 | Treatment probability models 743 | 744 | Intercept-only: a ~ 1 745 | 746 | 747 | Generative model attributes 748 | 749 | $origin 750 | [1] 1 751 | 752 | $lag 753 | [1] 3 754 | 755 | $sd 756 | [1] 1 757 | 758 | $coralpha 759 | [1] 0.7071068 760 | 761 | $corstr 762 | [1] "ar1" 763 | 764 | $beta0 765 | one tmod base state lag1a 766 | -0.2 0.0 0.0 0.5 0.0 767 | 768 | $beta1 769 | one lag1tmod base lag1state 770 | 0 0 0 0 771 | 772 | $eta 773 | one base state lag1a lag1y 774 | 0.0 0.0 0.8 -0.8 0.0 775 | 776 | $mu 777 | one ty base 778 | 0 0 0 779 | 780 | $theta0 781 | avail state 782 | 0.0 0.8 783 | 784 | $theta1 785 | lag1avail lag1state 786 | 0 0 787 | 788 | $coef.avail 789 | one tavail lag1a lag1y 790 | 100 0 0 0 791 | 792 | $coef.state 793 | one tstate base lag1state lag1a 794 | 0 0 0 0 0 795 | 796 | $tfun 797 | $tfun$ty 798 | function (tcur, tmax) 799 | rep(0, length(tcur)) 800 | 801 | 802 | $tfun$tmod 803 | function (tcur, tmax) 804 | rep(0, length(tcur)) 805 | 806 | 807 | $tfun$tavail 808 | function (tcur, tmax) 809 | rep(0, length(tcur)) 810 | 811 | 812 | $tfun$tstate 813 | function (tcur, tmax) 814 | rep(0, length(tcur)) 815 | 816 | 817 | 818 | Analysis models 819 | 820 | Weighted and centered: y ~ state + I(a - pn) 821 | 822 | GEE independence: y ~ state + a 823 | 824 | GEE AR(1): y ~ state + a 825 | 826 | GEE exchangeable: y ~ state + a 827 | 828 | Treatment probability models 829 | 830 | Intercept-only: a ~ 1 831 | 832 | 833 | Generative model attributes 834 | 835 | $origin 836 | [1] 1 837 | 838 | $lag 839 | [1] 3 840 | 841 | $sd 842 | [1] 1 843 | 844 | $coralpha 845 | [1] 0.7071068 846 | 847 | $corstr 848 | [1] "ar1" 849 | 850 | $beta0 851 | one tmod base state lag1a 852 | -0.2 0.0 0.0 0.5 0.0 853 | 854 | $beta1 855 | one lag1tmod base lag1state 856 | 0 0 0 0 857 | 858 | $eta 859 | one base state lag1a lag1y 860 | 0.0 0.0 0.8 -0.8 0.0 861 | 862 | $mu 863 | one ty base 864 | 0 0 0 865 | 866 | $theta0 867 | avail state 868 | 0.0 0.8 869 | 870 | $theta1 871 | lag1avail lag1state 872 | 0 0 873 | 874 | $coef.avail 875 | one tavail lag1a lag1y 876 | 100 0 0 0 877 | 878 | $coef.state 879 | one tstate base lag1state lag1a 880 | 0 0 0 0 0 881 | 882 | $tfun 883 | $tfun$ty 884 | function (tcur, tmax) 885 | rep(0, length(tcur)) 886 | 887 | 888 | $tfun$tmod 889 | function (tcur, tmax) 890 | rep(0, length(tcur)) 891 | 892 | 893 | $tfun$tavail 894 | function (tcur, tmax) 895 | rep(0, length(tcur)) 896 | 897 | 898 | $tfun$tstate 899 | function (tcur, tmax) 900 | rep(0, length(tcur)) 901 | 902 | 903 | 904 | Analysis models 905 | 906 | Weighted and centered: y ~ state + I(a - pn) 907 | 908 | GEE independence: y ~ state + a 909 | 910 | GEE AR(1): y ~ state + a 911 | 912 | GEE exchangeable: y ~ state + a 913 | 914 | Treatment probability models 915 | 916 | Intercept-only: a ~ 1 917 | 918 | 919 | Generative model attributes 920 | 921 | $origin 922 | [1] 1 923 | 924 | $lag 925 | [1] 3 926 | 927 | $sd 928 | [1] 1 929 | 930 | $coralpha 931 | [1] 0.7071068 932 | 933 | $corstr 934 | [1] "ar1" 935 | 936 | $beta0 937 | one tmod base state lag1a 938 | -0.2 0.0 0.0 0.8 0.0 939 | 940 | $beta1 941 | one lag1tmod base lag1state 942 | 0 0 0 0 943 | 944 | $eta 945 | one base state lag1a lag1y 946 | 0.0 0.0 0.8 -0.8 0.0 947 | 948 | $mu 949 | one ty base 950 | 0 0 0 951 | 952 | $theta0 953 | avail state 954 | 0.0 0.8 955 | 956 | $theta1 957 | lag1avail lag1state 958 | 0 0 959 | 960 | $coef.avail 961 | one tavail lag1a lag1y 962 | 100 0 0 0 963 | 964 | $coef.state 965 | one tstate base lag1state lag1a 966 | 0 0 0 0 0 967 | 968 | $tfun 969 | $tfun$ty 970 | function (tcur, tmax) 971 | rep(0, length(tcur)) 972 | 973 | 974 | $tfun$tmod 975 | function (tcur, tmax) 976 | rep(0, length(tcur)) 977 | 978 | 979 | $tfun$tavail 980 | function (tcur, tmax) 981 | rep(0, length(tcur)) 982 | 983 | 984 | $tfun$tstate 985 | function (tcur, tmax) 986 | rep(0, length(tcur)) 987 | 988 | 989 | 990 | Analysis models 991 | 992 | Weighted and centered: y ~ state + I(a - pn) 993 | 994 | GEE independence: y ~ state + a 995 | 996 | GEE AR(1): y ~ state + a 997 | 998 | GEE exchangeable: y ~ state + a 999 | 1000 | Treatment probability models 1001 | 1002 | Intercept-only: a ~ 1 1003 | 1004 | 1005 | Generative model attributes 1006 | 1007 | $origin 1008 | [1] 1 1009 | 1010 | $lag 1011 | [1] 3 1012 | 1013 | $sd 1014 | [1] 1 1015 | 1016 | $coralpha 1017 | [1] 0.7071068 1018 | 1019 | $corstr 1020 | [1] "ar1" 1021 | 1022 | $beta0 1023 | one tmod base state lag1a 1024 | -0.2 0.0 0.0 0.8 0.0 1025 | 1026 | $beta1 1027 | one lag1tmod base lag1state 1028 | 0 0 0 0 1029 | 1030 | $eta 1031 | one base state lag1a lag1y 1032 | 0.0 0.0 0.8 -0.8 0.0 1033 | 1034 | $mu 1035 | one ty base 1036 | 0 0 0 1037 | 1038 | $theta0 1039 | avail state 1040 | 0.0 0.8 1041 | 1042 | $theta1 1043 | lag1avail lag1state 1044 | 0 0 1045 | 1046 | $coef.avail 1047 | one tavail lag1a lag1y 1048 | 100 0 0 0 1049 | 1050 | $coef.state 1051 | one tstate base lag1state lag1a 1052 | 0 0 0 0 0 1053 | 1054 | $tfun 1055 | $tfun$ty 1056 | function (tcur, tmax) 1057 | rep(0, length(tcur)) 1058 | 1059 | 1060 | $tfun$tmod 1061 | function (tcur, tmax) 1062 | rep(0, length(tcur)) 1063 | 1064 | 1065 | $tfun$tavail 1066 | function (tcur, tmax) 1067 | rep(0, length(tcur)) 1068 | 1069 | 1070 | $tfun$tstate 1071 | function (tcur, tmax) 1072 | rep(0, length(tcur)) 1073 | 1074 | 1075 | 1076 | Analysis models 1077 | 1078 | Weighted and centered: y ~ state + I(a - pn) 1079 | 1080 | GEE independence: y ~ state + a 1081 | 1082 | GEE AR(1): y ~ state + a 1083 | 1084 | GEE exchangeable: y ~ state + a 1085 | 1086 | Treatment probability models 1087 | 1088 | Intercept-only: a ~ 1 1089 | 1090 | 1091 | Generative model attributes 1092 | 1093 | $origin 1094 | [1] 1 1095 | 1096 | $lag 1097 | [1] 3 1098 | 1099 | $sd 1100 | [1] 1 1101 | 1102 | $coralpha 1103 | [1] 0.7071068 1104 | 1105 | $corstr 1106 | [1] "ar1" 1107 | 1108 | $beta0 1109 | one tmod base state lag1a 1110 | -0.2 0.0 0.0 0.8 0.0 1111 | 1112 | $beta1 1113 | one lag1tmod base lag1state 1114 | 0 0 0 0 1115 | 1116 | $eta 1117 | one base state lag1a lag1y 1118 | 0.0 0.0 0.8 -0.8 0.0 1119 | 1120 | $mu 1121 | one ty base 1122 | 0 0 0 1123 | 1124 | $theta0 1125 | avail state 1126 | 0.0 0.8 1127 | 1128 | $theta1 1129 | lag1avail lag1state 1130 | 0 0 1131 | 1132 | $coef.avail 1133 | one tavail lag1a lag1y 1134 | 100 0 0 0 1135 | 1136 | $coef.state 1137 | one tstate base lag1state lag1a 1138 | 0 0 0 0 0 1139 | 1140 | $tfun 1141 | $tfun$ty 1142 | function (tcur, tmax) 1143 | rep(0, length(tcur)) 1144 | 1145 | 1146 | $tfun$tmod 1147 | function (tcur, tmax) 1148 | rep(0, length(tcur)) 1149 | 1150 | 1151 | $tfun$tavail 1152 | function (tcur, tmax) 1153 | rep(0, length(tcur)) 1154 | 1155 | 1156 | $tfun$tstate 1157 | function (tcur, tmax) 1158 | rep(0, length(tcur)) 1159 | 1160 | 1161 | 1162 | Analysis models 1163 | 1164 | Weighted and centered: y ~ state + I(a - pn) 1165 | 1166 | GEE independence: y ~ state + a 1167 | 1168 | GEE AR(1): y ~ state + a 1169 | 1170 | GEE exchangeable: y ~ state + a 1171 | 1172 | Treatment probability models 1173 | 1174 | Intercept-only: a ~ 1 1175 | 1176 | 1177 | Generative model attributes 1178 | 1179 | $origin 1180 | [1] 1 1181 | 1182 | $lag 1183 | [1] 3 1184 | 1185 | $sd 1186 | [1] 1 1187 | 1188 | $coralpha 1189 | [1] 0.7071068 1190 | 1191 | $corstr 1192 | [1] "ar1" 1193 | 1194 | $beta0 1195 | one tmod base state lag1a 1196 | -0.2 0.0 0.0 0.8 0.0 1197 | 1198 | $beta1 1199 | one lag1tmod base lag1state 1200 | 0 0 0 0 1201 | 1202 | $eta 1203 | one base state lag1a lag1y 1204 | 0.0 0.0 0.8 -0.8 0.0 1205 | 1206 | $mu 1207 | one ty base 1208 | 0 0 0 1209 | 1210 | $theta0 1211 | avail state 1212 | 0.0 0.8 1213 | 1214 | $theta1 1215 | lag1avail lag1state 1216 | 0 0 1217 | 1218 | $coef.avail 1219 | one tavail lag1a lag1y 1220 | 100 0 0 0 1221 | 1222 | $coef.state 1223 | one tstate base lag1state lag1a 1224 | 0 0 0 0 0 1225 | 1226 | $tfun 1227 | $tfun$ty 1228 | function (tcur, tmax) 1229 | rep(0, length(tcur)) 1230 | 1231 | 1232 | $tfun$tmod 1233 | function (tcur, tmax) 1234 | rep(0, length(tcur)) 1235 | 1236 | 1237 | $tfun$tavail 1238 | function (tcur, tmax) 1239 | rep(0, length(tcur)) 1240 | 1241 | 1242 | $tfun$tstate 1243 | function (tcur, tmax) 1244 | rep(0, length(tcur)) 1245 | 1246 | 1247 | 1248 | Analysis models 1249 | 1250 | Weighted and centered: y ~ state + I(a - pn) 1251 | 1252 | GEE independence: y ~ state + a 1253 | 1254 | GEE AR(1): y ~ state + a 1255 | 1256 | GEE exchangeable: y ~ state + a 1257 | 1258 | Treatment probability models 1259 | 1260 | Intercept-only: a ~ 1 1261 | 1262 | > save(omit, file = "sim-omit.RData") 1263 | > 1264 | > stopCluster(cl) 1265 | > 1266 | > proc.time() 1267 | user system elapsed 1268 | 11.376 0.617 8169.800 1269 | --------------------------------------------------------------------------------