Author: Klaus Holst & Thomas Scheike
Date: 2021-09-05

# Binomial Regression

#### Klaus Holst & Thomas Scheike

#### 2021-09-05

# Binomial Regression for censored data

The binreg function does direct binomial regression for one time-point, \(t\), fitting the model \[\begin{align*} P(T \leq t, \epsilon=1 | X ) & = \mbox{expit}( X^T \beta) \end{align*}\] the estimation is based on IPCW weighted EE \[\begin{align*} U(\beta) = & X ( \Delta(t) I(T \leq t, \epsilon=1 )/G_c(T_i- \wedge t) - \mbox{expit}( X^T \beta)) = 0 \end{align*}\] for IPCW adjusted responses and with \(\Delta\) indicator of death and \(G_c\) censoring survival distribution. With \(\Delta(t) = I( C_i > T_i \wedge t)\).

The function logitIPCW instead considers \[\begin{align*} U(\beta) = & X \Delta(t) /G_c(T_i- \wedge t) ( I(T \leq t, \epsilon=1 ) - \mbox{expit}( X^T \beta)) = 0. \end{align*}\] The two score equations are quite similar, and exactly the same when the censoring model is fully-nonparametric.

Additional functions logitATE, and binregATE computes the average treatment effect, the average effect on treated (ATT), and the average effect on non-treated (ATC). We demonstrate this in another vignette.

The function logitATE also works when there is no censoring and we thus have simple binary outcome.

Variance is based on sandwich formula with IPCW adjustment, and naive.var is variance under known censoring model. The influence functions are stored in the output.

     library(mets)
     options(warn=-1)
     set.seed(1000) # to control output in simulatins for p-values below.

     data(bmt)
     bmt$time <- bmt$time+runif(nrow(bmt))*0.01
     # logistic regresion with IPCW binomial regression
     out <- binreg(Event(time,cause)~tcell+platelet,bmt,time=50)
     summary(out)
    #>
    #>    n events
    #>  408    160
    #>
    #>  408 clusters
    #> coeffients:
    #>              Estimate   Std.Err      2.5%     97.5% P-value
    #> (Intercept) -0.178126  0.127204 -0.427442  0.071189  0.1614
    #> tcell       -0.426691  0.348043 -1.108843  0.255460  0.2202
    #> platelet    -0.441989  0.242406 -0.917095  0.033117  0.0683
    #>
    #> exp(coeffients):
    #>             Estimate    2.5%  97.5%
    #> (Intercept)  0.83684 0.65218 1.0738
    #> tcell        0.65266 0.32994 1.2911
    #> platelet     0.64276 0.39968 1.0337

We can also compute predictions using the estimates

     predict(out,data.frame(tcell=c(0,1),platelet=c(1,1)),se=TRUE)
    #>        pred         se     lower     upper
    #> 1 0.3497553 0.04858060 0.2545373 0.4449732
    #> 2 0.2598388 0.07039666 0.1218613 0.3978162

Further the censoring model can depend on strata

     outs <- binreg(Event(time,cause)~tcell+platelet,bmt,time=50,cens.model=~strata(tcell,platelet))
     summary(outs)
    #>
    #>    n events
    #>  408    160
    #>
    #>  408 clusters
    #> coeffients:
    #>              Estimate   Std.Err      2.5%     97.5% P-value
    #> (Intercept) -0.180697  0.127414 -0.430424  0.069030  0.1561
    #> tcell       -0.365928  0.350632 -1.053154  0.321299  0.2967
    #> platelet    -0.433494  0.240270 -0.904415  0.037428  0.0712
    #>
    #> exp(coeffients):
    #>             Estimate    2.5%  97.5%
    #> (Intercept)  0.83469 0.65023 1.0715
    #> tcell        0.69355 0.34884 1.3789
    #> platelet     0.64824 0.40478 1.0381

# Absolute risk differences and ratio

Now for illustrations I wish to consider the absolute risk difference depending on tcell

     outs <- binreg(Event(time,cause)~tcell,bmt,time=50,cens.model=~strata(tcell))
     summary(outs)
    #>
    #>    n events
    #>  408    160
    #>
    #>  408 clusters
    #> coeffients:
    #>             Estimate  Std.Err     2.5%    97.5% P-value
    #> (Intercept) -0.30054  0.11153 -0.51914 -0.08194  0.0070
    #> tcell       -0.51741  0.33981 -1.18342  0.14860  0.1278
    #>
    #> exp(coeffients):
    #>             Estimate    2.5%  97.5%
    #> (Intercept)  0.74042 0.59503 0.9213
    #> tcell        0.59606 0.30623 1.1602

the risk difference is

    ps <-  predict(outs,data.frame(tcell=c(0,1)),se=TRUE)
    ps
    #>        pred         se     lower     upper
    #> 1 0.4254253 0.02726306 0.3719897 0.4788609
    #> 2 0.3061988 0.06819019 0.1725461 0.4398516
    sum( c(1,-1) * ps[,1])
    #> [1] 0.1192264

Getting the standard errors are easy enough since the two-groups are independent. In the case where we in addition had adjusted for other covariates, however, we would need the to apply the delta-theorem thus using the relevant covariances along the lines of

    dd <- data.frame(tcell=c(0,1))
    p <- predict(outs,dd)

    riskdifratio <- function(p,contrast=c(1,-1)) {
       outs$coef <- p
       p <- predict(outs,dd)[,1]
       pd <- sum(contrast*p)
       r1 <- p[1]/p[2]
       r2 <- p[2]/p[1]
       return(c(pd,r1,r2))
    }

    estimate(outs,f=riskdifratio,dd,null=c(0,1,1))
    #>      Estimate Std.Err     2.5%  97.5% P-value
    #> [p1]   0.1192 0.07344 -0.02471 0.2632 0.10448
    #> [p2]   1.3894 0.32197  0.75833 2.0204 0.22652
    #> [p3]   0.7197 0.16679  0.39284 1.0467 0.09291
    #>
    #>  Null Hypothesis:
    #>   [p1] = 0
    #>   [p2] = 1
    #>   [p3] = 1
    #>
    #> chisq = 12.0249, df = 3, p-value = 0.007298

same as

    run <- 0
    if (run==1) {
    library(prodlim)
    pl <- prodlim(Hist(time,cause)~tcell,bmt)
    spl <- summary(pl,times=50,asMatrix=TRUE)
    spl
    }

# Augmenting the Binomial Regression

Rather than using a larger censoring model we can also compute an augmentation term and then fit the binomial regression model based on this augmentation term. Here we compute the augmentation based on stratified non-parametric estimates of \(F_1(t,S(X))\), where \(S(X)\) gives strata based on \(X\) as a working model.

Computes the augmentation term for each individual as well as the sum \[\begin{align*} A & = \int_0^t H(u,X) \frac{1}{S^*(u,s)} \frac{1}{G_c(u)} dM_c(u) \end{align*}\] with \[\begin{align*} H(u,X) & = F_1^*(t,S(X)) - F_1^*(u,S(X)) \end{align*}\] using a KM for \(G_c(t)\) and a working model for cumulative baseline related to \(F_1^*(t,s)\) and \(s\) is strata, \(S^*(t,s) = 1 - F_1^*(t,s) - F_2^*(t,s)\).

Standard errors computed under assumption of correct but estimated \(G_c(s)\) model.

     data(bmt)
     dcut(bmt,breaks=2) <- ~age
     out1<-BinAugmentCifstrata(Event(time,cause)~platelet+agecat.2+
                  strata(platelet,agecat.2),data=bmt,cause=1,time=40)
     summary(out1)
    #>
    #>    n events
    #>  408    157
    #>
    #>  408 clusters
    #> coeffients:
    #>                      Estimate  Std.Err     2.5%    97.5% P-value
    #> (Intercept)          -0.50044  0.17069 -0.83498 -0.16590  0.0034
    #> platelet             -0.63447  0.23596 -1.09695 -0.17200  0.0072
    #> agecat.2(0.203,1.94]  0.53823  0.21192  0.12287  0.95358  0.0111
    #>
    #> exp(coeffients):
    #>                      Estimate    2.5%  97.5%
    #> (Intercept)           0.60626 0.43388 0.8471
    #> platelet              0.53021 0.33389 0.8420
    #> agecat.2(0.203,1.94]  1.71297 1.13074 2.5950

     out2<-BinAugmentCifstrata(Event(time,cause)~platelet+agecat.2+
         strata(platelet,agecat.2)+strataC(platelet),data=bmt,cause=1,time=40)
     summary(out2)
    #>
    #>    n events
    #>  408    157
    #>
    #>  408 clusters
    #> coeffients:
    #>                      Estimate  Std.Err     2.5%    97.5% P-value
    #> (Intercept)          -0.50015  0.17118 -0.83566 -0.16463  0.0035
    #> platelet             -0.63540  0.23741 -1.10071 -0.17010  0.0074
    #> agecat.2(0.203,1.94]  0.53768  0.21227  0.12163  0.95372  0.0113
    #>
    #> exp(coeffients):
    #>                      Estimate    2.5%  97.5%
    #> (Intercept)           0.60644 0.43359 0.8482
    #> platelet              0.52972 0.33264 0.8436
    #> agecat.2(0.203,1.94]  1.71203 1.12934 2.5953

# SessionInfo

    sessionInfo()
    #> R version 4.1.1 (2021-08-10)
    #> Platform: x86_64-apple-darwin20.4.0 (64-bit)
    #> Running under: macOS Big Sur 11.5.2
    #>
    #> Matrix products: default
    #> BLAS:   /usr/local/Cellar/openblas/0.3.17/lib/libopenblasp-r0.3.17.dylib
    #> LAPACK: /usr/local/Cellar/r/4.1.1/lib/R/lib/libRlapack.dylib
    #>
    #> locale:
    #> [1] en_US.UTF-8/en_US.UTF-8/en_US.UTF-8/C/en_US.UTF-8/en_US.UTF-8
    #>
    #> attached base packages:
    #> [1] stats     graphics  grDevices utils     datasets  methods   base
    #>
    #> other attached packages:
    #> [1] mets_1.2.9      lava_1.6.11     timereg_2.0.0   survival_3.2-13
    #>
    #> loaded via a namespace (and not attached):
    #>  [1] Rcpp_1.0.7          bslib_0.2.5.1       compiler_4.1.1
    #>  [4] jquerylib_0.1.4     tools_4.1.1         digest_0.6.27
    #>  [7] jsonlite_1.7.2      evaluate_0.14       lattice_0.20-44
    #> [10] ucminf_1.1-4        rlang_0.4.11        Matrix_1.3-4
    #> [13] yaml_2.2.1          parallel_4.1.1      mvtnorm_1.1-2
    #> [16] xfun_0.25           fastmap_1.1.0       stringr_1.4.0
    #> [19] knitr_1.33          sass_0.4.0          globals_0.14.0
    #> [22] grid_4.1.1          listenv_0.8.0       R6_2.5.1
    #> [25] future.apply_1.8.1  parallelly_1.27.0   rmarkdown_2.10
    #> [28] magrittr_2.0.1      codetools_0.2-18    htmltools_0.5.2
    #> [31] splines_4.1.1       future_1.22.1       numDeriv_2016.8-1.1
    #> [34] stringi_1.7.4