##' Binomial Regression for Censored Competing Risks Data
##'
##' Fits a binomial regression model for a specific time point in the presence of 
##' right-censored data and competing risks. This function implements the 
##' Inverse Probability of Censoring Weighted (IPCW) estimating equation approach.
##'
##' The model estimates the probability:
##' \deqn{P(T \leq t, \epsilon=1 | X ) = \text{expit}( X^T \beta) }
##'
##' Based on binomial regresion IPCW response estimating equation: 
##' \deqn{ X ( \Delta^{ipcw}(t) I(T \leq t, \epsilon=1 ) - expit( X^T beta)) = 0 }
##' where \deqn{\Delta^{ipcw}(t) = I((min(t,T)< C)/G_c(min(t,T)-)} is 
##' IPCW adjustment of the response \deqn{Y(t)= I(T \leq t, \epsilon=1 )}.  
##' Two types of estimators are available:
##' \itemize{
##'   \item \code{type="I"}: Solves the standard IPCW estimating equation.
##'   \item \code{type="II"}: Adds a censoring augmentation term for efficiency gains, 
##'   solving \deqn{X \int E(Y(t)| T>s)/G_c(s) d \hat M_c}.
##' }
##'
##' Alternatively, \code{logitIPCW} performs a standard logistic regression with 
##' IPCW weights applied directly to the likelihood. Thus solving 
##' \deqn{ X  I(min(T_i,t) < G_i)/G_c(min(T_i ,t)) ( I(T \leq t, \epsilon=1 ) - expit( X^T beta)) = 0 } 
##' a standard logistic regression with IPCW weights.
##'
##' The variance estimation is based on squared influence functions, with options 
##' for naive variance (assuming known censoring) and robust variance (accounting 
##' for censoring model estimation).
##'
##' Censoring model may depend on strata (cens.model=~strata(gX)). 
##' @section References:
##' \itemize{
##'   \item Blanche PF, Holt A, Scheike T (2022). "On logistic regression with right censored data, with or without competing risks, and its use for estimating treatment effects." \emph{Lifetime data analysis}, 29, 441–482.
##'   \item Scheike TH, Zhang MJ, Gerds TA (2008). "Predicting cumulative incidence probability by direct binomial regression." \emph{Biometrika}, 95(1), 205–220.
##' }
##'
##' @param formula A formula object specifying the outcome and covariates. 
##'   The outcome must be an \code{Event} object (\code{Event(time, cause)}).
##' @param data A data frame containing the variables in the formula.
##' @param cause Numeric vector or scalar indicating the cause of interest for the competing risks.
##' @param time Numeric scalar indicating the time point of interest for the cumulative incidence.
##' @param beta Optional numeric vector of starting values for the coefficients. Defaults to zeros.
##' @param type Character string. Either \code{"I"} (classic binomial regression) or \code{"II"} (adds augmentation term).
##' @param offset Optional numeric vector of offsets for the linear predictor.
##' @param weights Optional numeric vector of weights for the score equations.
##' @param cens.weights Optional numeric vector of pre-calculated censoring weights. If NULL, they are estimated internally.
##' @param cens.model A formula specifying the censoring model. Defaults to \code{~+1}. Can include strata (e.g., \code{~strata(group)}).
##' @param se Logical. If TRUE, computes standard errors based on IPCW influence functions.
##' @param kaplan.meier Logical. If TRUE, uses Kaplan-Meier estimator for IPCW weights; otherwise uses exponential baseline.
##' @param cens.code Numeric code representing censored observations in the status variable. Defaults to 0.
##' @param no.opt Logical. If TRUE, optimization is skipped and starting values are used.
##' @param method Character string. Optimization method: \code{"nr"} (Newton-Raphson) or \code{"nlm"}.
##' @param augmentation Optional numeric vector for additional augmentation terms.
##' @param outcome Character string. Outcome type: \code{"cif"} (Cumulative Incidence Function), \code{"rmst"} (Restricted Mean Survival Time), or \code{"rmtl"} (Restricted Mean Time Lost).
##' @param model Character string. Link function: \code{"default"} (auto-selects based on outcome), \code{"logit"}, \code{"exp"}, or \code{"lin"} (identity).
##' @param Ydirect Optional numeric vector. If provided, this outcome is used instead of constructing one from \code{outcome}. Useful for custom IPCW adjustments.
##'
##' @section Outcome definition:
##' The observed outcome \eqn{Y_i} constructed from \code{outcome} depends on whether
##' competing risks are present. Competing risks are detected automatically: the data are
##' considered to have competing risks when causes other than those specified in \code{cause}
##' are observed (i.e. \code{any(!(Causes \%in\% cause))}, where \code{Causes} are all
##' non-censoring event codes found in the data).
##'
##' \strong{No competing risks} (all observed events belong to \code{cause}):
##' \itemize{
##'   \item \code{"cif"}: \eqn{Y_i = I(T_i \leq t, \epsilon_i = 1)}. Cumulative incidence.
##'   \item \code{"rmst"}: \eqn{Y_i = \min(T_i, t)}. Restricted mean survival time.
##'   \item \code{"rmtl"}: \eqn{Y_i = t - \min(T_i, t)}. Restricted mean time lost.
##' }
##'
##' \strong{Competing risks} (causes beyond \code{cause} are observed in the data):
##' \itemize{
##'   \item \code{"cif"}: \eqn{Y_i = I(T_i \leq t, \epsilon_i \in \code{cause})}. Cumulative
##'     incidence for the cause(s) of interest.
##'   \item \code{"rmst"} or \code{"rmtl"}: \eqn{Y_i = I(\epsilon_i \in \code{cause})(t - \min(T_i, t))}.
##'     Cause-specific years lost, accumulated only for subjects who experience an event in \code{cause}.
##' }
##'
##' The default link function (\code{model = "default"}) is \code{"logit"} for \code{"cif"} and
##' \code{"exp"} for \code{"rmst"} and \code{"rmtl"}.
##' If \code{Ydirect} is supplied, outcome construction is bypassed entirely.
##' @param ... Additional arguments passed to lower-level optimization functions.
##'
##' @return An object of class \code{"binreg"} containing coefficients, variance-covariance matrix, 
##'   influence functions (\code{iid}), and model details.
##'
##' @author Thomas Scheike
##' @examples
##' data(bmt); bmt$time <- bmt$time+runif(408)*0.001
##' # logistic regresion with IPCW binomial regression 
##' out <- binreg(Event(time,cause)~tcell+platelet,bmt,time=50)
##' summary(out)
##' head(iid(out))
##'
##' predict(out,data.frame(tcell=c(0,1),platelet=c(1,1)),se=TRUE)
##'
##' outs <- binreg(Event(time,cause)~tcell+platelet,bmt,time=50,cens.model=~strata(tcell,platelet))
##' summary(outs)
##'
##' ## glm with IPCW weights 
##' outl <- logitIPCW(Event(time,cause)~tcell+platelet,bmt,time=50)
##' summary(outl)
##'
##' ##########################################
##' ### risk-ratio of different causes #######
##' ##########################################
##' data(bmt)
##' bmt$id <- 1:nrow(bmt)
##' bmt$status <- bmt$cause
##' bmt$strata <- 1
##' bmtdob <- bmt
##' bmtdob$strata <-2
##' bmtdob <- dtransform(bmtdob,status=1,cause==2)
##' bmtdob <- dtransform(bmtdob,status=2,cause==1)
##' ###
##' bmtdob <- rbind(bmt,bmtdob)
##' dtable(bmtdob,cause+status~strata)
##' 
##' cif1 <- cif(Event(time,cause)~+1,bmt,cause=1)
##' cif2 <- cif(Event(time,cause)~+1,bmt,cause=2)
##' plot(cif1)
##' plot(cif2,add=TRUE,col=2)
##' 
##' cifs1 <- binreg(Event(time,cause)~tcell+platelet+age,bmt,cause=1,time=50)
##' cifs2 <- binreg(Event(time,cause)~tcell+platelet+age,bmt,cause=2,time=50)
##' summary(cifs1)
##' summary(cifs2)
##' 
##' cifdob <- binreg(Event(time,status)~-1+factor(strata)+
##' 	 tcell*factor(strata)+platelet*factor(strata)+age*factor(strata)
##' 	 +cluster(id),bmtdob,cause=1,time=50,cens.model=~strata(strata))
##' summary(cifdob)
##' head(iid(cifdob)) 
##' 
##' newdata <- data.frame(tcell=1,platelet=1,age=0,strata=1:2,id=1)
##' riskratio <- function(p) {
##'   cifdob$coef <- p
##'   p <- predict(cifdob,newdata,se=0)
##'   return(p[1]/p[2])
##' }
##' lava::estimate(cifdob,f=riskratio)
##' 
##' predict(cifdob,newdata)
##' (p1 <- predict(cifs1,newdata))
##' (p2 <- predict(cifs2,newdata))
##' p1[1,1]/p2[1,1]
##' 
##' @aliases logitIPCW binregt
##' @export
binreg <- function(formula,data,cause=1,time=NULL,beta=NULL,type=c("II","I"),
	   offset=NULL,weights=NULL,cens.weights=NULL,cens.model=~+1,se=TRUE,
	   kaplan.meier=TRUE,cens.code=0,no.opt=FALSE,method="nr",augmentation=NULL,
	   outcome=c("cif","rmst","rmtl"),model=c("default","logit","exp","lin"),
	   Ydirect=NULL,...)
{# {{{
	monotone <- TRUE
cl <- match.call()# {{{
###    m <- match.call(expand.dots = TRUE)[1:3]
    des <- proc_design(
        formula,
        data = data,
        specials = c("offset", "weights", "cluster"),
        intercept = TRUE
    )
    Y <- des$y
    if (!inherits(Y, c("Event", "Surv"))) {
        stop("Expected a 'Surv' or 'Event'-object")
    }
    if (ncol(Y) == 2) {
        exit <- Y[, 1]
        entry <- rep(0, nrow(Y))
        status <- Y[, 2]
    } else {
        entry <- Y[, 1]
        exit <- Y[, 2]
        status <- Y[, 3]
    }
    X <- des$x
    des.weights <- des$weights
    des.offset  <- des$offset
    id      <- des$cluster
  if (ncol(X)==0) X <- matrix(nrow=0,ncol=0)

  ### possible handling of id to code from 0:(antid-1)
  call.id <- id 
  conid <- construct_id(id,nrow(X),namesX=rownames(X))
  name.id <- conid$name.id; id <- conid$id; nid <- conid$nid
  ## id before time-sorting later 
  orig.id <- id

  ## take offset and weight first from formula, but then from arguments
  if (is.null(des.offset)) {
	  if (is.null(offset)) offset <- rep(0,length(exit)) 
  } else offset <- des.offset
  if (is.null(des.weights)) {
	  if (is.null(weights)) weights <- rep(1,length(exit)) 
  } else weights <- des.weights
# }}}

  if (is.null(time)) stop("Must give time for logistic modelling \n"); 
  statusC <- 1*(status %in% cens.code) 
  statusE <- (status %in% cause) & (exit<= time) 
  if (sum(statusE)==0) warning("No events of type 1 before time \n"); 
  kmt <- kaplan.meier

  ucauses  <-  sort(unique(status))
  ccc <- which(ucauses %in% cens.code)
  if (length(ccc)==0) Causes <- ucauses else Causes <- ucauses[-ccc]
  competing <- any(!(Causes %in% cause))
  data$id__ <- id
  data$exit <- exit
  data$statusC <- statusC 
  cens.strata <- cens.nstrata <- NULL 

 nevent <- sum((status %in% cause)*(exit<=time))
 ## if event before time or alive, then uncensored, equality for both censored and events  
 obs <- (exit<=time & (statusC==0)) | (exit>=time)

  if (is.null(cens.weights))  { ## {{{
      formC <- update.formula(cens.model,Surv(exit,statusC)~ . +cluster(id__))
      resC <- phreg(formC,data)
      if (resC$p>0) kmt <- FALSE
      exittime <- pmin(exit,time)
      cens.weights <- suppressWarnings(predict(resC,data,times=exittime,individual.time=TRUE,se=FALSE,km=kmt,tminus=TRUE)$surv)
      ## strata from original data 
      cens.strata <- resC$strata[order(resC$ord)]
      cens.nstrata <- resC$nstrata
  } else { se <- FALSE; resC <- formC <- NULL} ## }}}
  expit  <- function(z) 1/(1+exp(-z)) ## expit

  p <- ncol(X)
  if (is.null(beta)) beta <- rep(0,p)
  if (is.null(augmentation))  augmentation=rep(0,p)
  X <-  as.matrix(X)
  X2  <- .Call("vecCPMat",X)$XX

 if (!is.null(Ydirect)) Y <-  Ydirect else {
     if (outcome[1]=="cif") Y <- c((status %in% cause)*(exit<=time))
     else { if (!competing) {
	     if (outcome[1]=="rmst")
	     Y <-  c(pmin(exit,time))
             else Y <-  c((time-pmin(exit,time)))
            } else Y <- c((status %in% cause)*(time-pmin(exit,time)))
     }
  }
  Yresp <- c(Y)
  Y <- Yipcw <- c(Y*obs/cens.weights)
  IPCW <- c(obs/cens.weights)

 if (se & monotone) {## {{{ censoring adjustment of variance  and infinitissimal jacknife pseudo augmentation
    ### order of sorted times
    ord <- resC$ord
    X <-  X[ord,,drop=FALSE]
    X2 <-  X2[ord,,drop=FALSE]
    status <- status[ord]
    exit <- exit[ord]
    weights <- weights[ord]
    offset <- offset[ord]
    Y <- Y[ord]

    xx <- resC$cox.prep
    S0i2 <- S0i <- rep(0,length(xx$strata))
    S0i[xx$jumps+1]  <- 1/resC$S0
    S0i2[xx$jumps+1] <- 1/resC$S0^2
    ## compute function h(s) = \sum_i X_i Y_i(t) I(s \leq T_i \leq t) 
    ## to make \int h(s)/Ys  dM_i^C(s) 
###    h  <-  apply(X*Y,2,revcumsumstrata,xx$strata,xx$nstrata)
    h  <-  Mrevcumsumstrata(X*Y,xx$strata,xx$nstrata)
    ### Cens-Martingale as a function of time and for all subjects to handle strata 
    btime <- 1*(exit<time)
    ## to make \int h(s)/Ys  dM_i^C(s)  = \int h(s)/Ys  dN_i^C(s) - dLambda_i^C(s)
###    IhdLam0 <- apply(h*S0i2*btime,2,cumsumstrata,xx$strata,xx$nstrata)
    IhdLam0 <- Mcumsumstrata(h*S0i2*btime,xx$strata,xx$nstrata)
    U <- matrix(0,nrow(xx$X),ncol(X))
    U[xx$jumps+1,] <- (resC$jumptimes<time)*h[xx$jumps+1,]/c(resC$S0)
    MGt <- (U[,drop=FALSE]-IhdLam0)*c(xx$weights)

    ### Censoring Variance Adjustment  \int h^2(s) / y.(s) d Lam_c(s) estimated by \int h^2(s) / y.(s)^2  d N.^C(s) 
    mid <- max(id)
###    MGCiid <- Msumstrata(MGt,2,sumstrata,xx$id,mid+1)
    MGCiid <- Msumstrata(MGt,xx$id,mid+1)

   if (type[1]=="II") { ##  pseudo-value type augmentation
    hYt  <-  revcumsumstrata(Y,xx$strata,xx$nstrata)
    IhdLam0 <- cumsumstrata(hYt*S0i2*btime,xx$strata,xx$nstrata)
    U <- rep(0,length(xx$strata))
    U[xx$jumps+1] <- (resC$jumptimes<time)*hYt[xx$jumps+1]/c(resC$S0)
    MGt <- X*c(U-IhdLam0)*c(xx$weights)
###    MGtiid <- apply(MGt,2,sumstrata,xx$id,mid+1)
    MGtiid <- Msumstrata(MGt,xx$id,mid+1)
    augmentation  <-  colSums(MGtiid) + augmentation
    ###
    EXt  <-  Mrevcumsumstrata(X,xx$strata,xx$nstrata)
    IEXhYtdLam0 <- Mcumsumstrata(EXt*c(hYt)*S0i*S0i2*btime,xx$strata,xx$nstrata)
    U <- matrix(0,nrow(xx$X),ncol(X))
    U[xx$jumps+1,] <- (resC$jumptimes<time)*hYt[xx$jumps+1]*EXt[xx$jumps+1,]/c(resC$S0)^2
    MGt2 <- (U[,drop=FALSE]-IEXhYtdLam0)*c(xx$weights)
    ###
    MGCiid2 <- Msumstrata(MGt2,xx$id,mid+1)
    ### Censoring Variance Adjustment 
    MGCiid <- MGCiid+(MGtiid-MGCiid2)
   }
   ## use data ordered by time (keeping track of id also)
   id <- xx$id
   }  else {
	  MGCiid <- 0
  }## }}}

 ## default links
 if (model[1]=="default") {
	 if (outcome[1]=="cif") model <- "logit"
	 if (outcome[1]=="rmst") model <- "exp"
	 if (outcome[1]=="rmtl") model <- "exp"
	 if (outcome[1]=="years-lost") model <- "exp"
 }

obj <- function(pp,all=FALSE)
{ # {{{
lp <- c(X %*% pp+offset)

    if (model[1]=="exp") {
	 p <- exp(lp) 
         D2logl <- c(weights*p)*X2 
	 if (monotone) {
	    Dlogl <- weights*X*c(Y-p) 
            D2logl <- c(weights*p)*X2 
	 } else { 
	    Dlogl <- weights*X*c((Y-p)*p)
            D2logl <- c(weights*p^2)*X2 
	 }
     } else if (model[1]=="lin") {
	 p <- lp
         D2logl <- c(weights)*X2
         Dlogl <- weights*X*c(Y-p)
    } else if (model[1]=="logit") {
	p <- expit(lp)
        if (monotone) {
           D2logl <- c(weights*p/(1+exp(lp)))*X2
           Dlogl <- weights*X*c(Y-p)
	} else {
           varp <- p/(1+exp(lp))
           Dlogl <- weights*X*c((Y-p)*varp)
           D2logl <- c(weights*varp^2)*X2
	}
} else stop("link functions must be logit,exp,lin\n") 
ploglik <- sum(weights*(Y-p)^2)
## to avoid using ploglik for fitting, with exp,logit only solve estimating equation
if (model[1]!="lin") ploglik <- 0

###D2log <- apply(D2logl,2,sum)
###gradient <- apply(Dlogl,2,sum)+augmentation
D2log <- colSums(D2logl)
gradient <- colSums(Dlogl)+augmentation
np <- length(pp)
hessian <- matrix(.Call("XXMatFULL",matrix(D2log,nrow=1),np,PACKAGE="mets")$XXf,np,np)

  if (all) {
      ploglik <- sum(weights*(Y-p)^2)
      ihess <- pinv(hessian)
      beta.iid <- Dlogl %*% ihess ## %*% t(Dlogl) 
###      beta.iid <-  apply(beta.iid,2,sumstrata,id,max(id)+1)
      beta.iid <-  Msumstrata(beta.iid,id,max(id)+1)
      robvar <- crossprod(beta.iid)
      val <- list(par=pp,ploglik=ploglik,gradient=gradient,hessian=hessian,ihessian=ihess,
	 id=id,Dlogl=Dlogl,iid=beta.iid,robvar=robvar,var=robvar,se.robust=diag(robvar)^.5)
      return(val)
  }  
 structure(-ploglik,gradient=-gradient,hessian=hessian)
}# }}}

## setting default for NR 
dots <- list(...)
if (length(dots)==0) {
   if (model[1]=="exp") control <- list(tol=1e-10,stepsize=0.5)  
   else control <- NULL
} else control <- dots[[1]]

  p <- ncol(X)
  opt <- NULL
  if (p>0) {
  if (no.opt==FALSE) {
      if (tolower(method)=="nr") {
          tim <- system.time(opt <- lava::NR(beta,obj,control=control))
	  opt$timing <- tim
	  opt$estimate <- opt$par
      } else {
	  opt <- nlm(obj,beta,...)
	  opt$method <- "nlm"
      }
      cc <- opt$estimate; 
###	      if (!se) return(cc)
      val <- c(list(coef=cc),obj(opt$estimate,all=TRUE))
      } else {
	      val <- c(list(coef=beta),obj(beta,all=TRUE))
  }
  } else {
      val <- obj(0,all=TRUE)
  }

  if (length(val$coef)==length(colnames(X))) names(val$coef) <- colnames(X)
  val <- c(val,list(time=time,formula=formula,formC=formC,
    cens.weights=cens.weights, cens.strata=cens.strata, cens.nstrata=cens.nstrata, 
    n=length(exit),nevent=nevent,ncluster=nid))

  if ( (!monotone) & se) { ## {{{ censoring adjustment of variance 
    ### order of sorted times
    ord <- resC$ord
    X <-  X[ord,,drop=FALSE]
    status <- status[ord]
    exit <- exit[ord]
    weights <- weights[ord]
    offset <- offset[ord]
    lp <- c(X %*% val$coef+offset)
    Y <- Y[ord]

   if (model[1]=="exp") {
	 p <- exp(lp) 
         Yglm <- weights*X*c(Y*p)
    } else if (model[1]=="lin") {
	 p <- lp
         Yglm <- weights*X*c(Y)
    } else if (model[1]=="logit") {
	 p <- expit(lp) 
         varp <- p/(1+exp(lp))
         Yglm <- weights*X*c(Y*varp)
    }

    xx <- resC$cox.prep
    S0i2 <- S0i <- rep(0,length(xx$strata))
    S0i[xx$jumps+1]  <- 1/resC$S0
    S0i2[xx$jumps+1] <- 1/resC$S0^2
    ## compute function h(s) = \sum_i X_i Y_i(t) I(s \leq T_i \leq t) 
    ## to make \int h(s)/Ys  dM_i^C(s) 
    h  <-  apply(Yglm,2,revcumsumstrata,xx$strata,xx$nstrata)
    ### Cens-Martingale as a function of time and for all subjects to handle strata 
    ## to make \int h(s)/Ys  dM_i^C(s)  = \int h(s)/Ys  dN_i^C(s) - dLambda_i^C(s)
    IhdLam0 <- apply((exit<time)*h*S0i2,2,cumsumstrata,xx$strata,xx$nstrata)
    U <- matrix(0,nrow(xx$X),ncol(X))
    U[xx$jumps+1,] <- (resC$jumptimes<time)*h[xx$jumps+1,] /c(resC$S0)
    MGt <- (U[,drop=FALSE]-IhdLam0)*c(xx$weights)
    MGCiid <- apply(MGt,2,sumstrata,xx$id,max(id)+1)
  }## }}}

  ## do not need this, since have iid
  val$Dlogl  <- NULL

  val$call <- cl
  val$MGciid <- MGCiid 
  val$call.id <- call.id
  val$id <- orig.id
  val$name.id <- name.id
  val$nid <- nid
  val$iid.naive <- val$iid
  val$naive.var <- NULL 
  if (se)  val$iid  <- val$iid+(MGCiid %*% val$ihessian)
  if (!is.null(name.id)) val$iid <- nameme(val$iid,name.id)
  robvar <- crossprod(val$iid)
  val$var <-  val$robvar <- robvar
  val$se.robust <- diag(robvar)^.5
  val$se.coef <- diag(val$var)^.5
  val$cause <- cause
  val$cens.code <- cens.code 
  val$augmentation <- augmentation
  val$model <- model[1]
  val$outcome <- outcome[1]
  val$Yipcw <- Yipcw
  val$Y     <- Yresp
  val$IPCW   <- IPCW
  val$Causes <- Causes
  val$nevent <- nevent
  val$design <- des

  class(val) <- "binreg"
  return(val)
}# }}}

###binreg <- function(formula,data,cause=1,time=NULL,beta=NULL,type=c("II","I"),
###	   offset=NULL,weights=NULL,cens.weights=NULL,cens.model=~+1,se=TRUE,
###	   kaplan.meier=TRUE,cens.code=0,no.opt=FALSE,method="nr",augmentation=NULL,
###	   outcome=c("cif","rmst","rmtl"),model=c("default","logit","exp","lin"),
###	   Ydirect=NULL,...)
###{# {{{
###	monotone <- TRUE
###cl <- match.call()# {{{
######    m <- match.call(expand.dots = TRUE)[1:3]
###    des <- proc_design(
###        formula,
###        data = data,
###        specials = c("offset", "weights", "cluster"),
###        intercept = TRUE
###    )
###    Y <- des$y
###    if (!inherits(Y, c("Event", "Surv"))) {
###        stop("Expected a 'Surv' or 'Event'-object")
###    }
###    if (ncol(Y) == 2) {
###        exit <- Y[, 1]
###        entry <- rep(0, nrow(Y))
###        status <- Y[, 2]
###    } else {
###        entry <- Y[, 1]
###        exit <- Y[, 2]
###        status <- Y[, 3]
###    }
###    X <- des$x
###    des.weights <- des$weights
###    des.offset  <- des$offset
###    id      <- des$cluster
###  if (ncol(X)==0) X <- matrix(nrow=0,ncol=0)
###
###  ### possible handling of id to code from 0:(antid-1)
###  call.id <- id 
###  conid <- construct_id(id,nrow(X),namesX=rownames(X))
###  name.id <- conid$name.id; id <- conid$id; nid <- conid$nid
###  ## id before time-sorting later 
###  orig.id <- id
###
###  ## take offset and weight first from formula, but then from arguments
###  if (is.null(des.offset)) {
###	  if (is.null(offset)) offset <- rep(0,length(exit)) 
###  } else offset <- des.offset
###  if (is.null(des.weights)) {
###	  if (is.null(weights)) weights <- rep(1,length(exit)) 
###  } else weights <- des.weights
#### }}}
###
###  if (is.null(time)) stop("Must give time for logistic modelling \n"); 
###  statusC <- 1*(status %in% cens.code) 
###  statusE <- (status %in% cause) & (exit<= time) 
###  if (sum(statusE)==0) warning("No events of type 1 before time \n"); 
###  kmt <- kaplan.meier
###
###  ucauses  <-  sort(unique(status))
###  ccc <- which(ucauses %in% cens.code)
###  if (length(ccc)==0) Causes <- ucauses else Causes <- ucauses[-ccc]
###  competing <- any(!(Causes %in% cause))
###  data$id__ <- id
###  data$exit <- exit
###  data$statusC <- statusC 
###  cens.strata <- cens.nstrata <- NULL 
###
### nevent <- sum((status %in% cause)*(exit<=time))
### ## if event before time or alive, then uncensored, equality for both censored and events  
### obs <- (exit<=time & (statusC==0)) | (exit>=time)
###
###  if (is.null(cens.weights))  { ## {{{
###      formC <- update.formula(cens.model,Surv(exit,statusC)~ . +cluster(id__))
###      resC <- phreg(formC,data)
###      if (resC$p>0) kmt <- FALSE
###      exittime <- pmin(exit,time)
###      cens.weights <- suppressWarnings(predict(resC,data,times=exittime,individual.time=TRUE,se=FALSE,km=kmt,tminus=TRUE)$surv)
###      ## strata from original data 
###      cens.strata <- resC$strata[order(resC$ord)]
###      cens.nstrata <- resC$nstrata
###  } else { se <- FALSE; resC <- formC <- NULL} ## }}}
###  expit  <- function(z) 1/(1+exp(-z)) ## expit
###
###  p <- ncol(X)
###  if (is.null(beta)) beta <- rep(0,p)
###  if (is.null(augmentation))  augmentation=rep(0,p)
###  X <-  as.matrix(X)
###  X2  <- .Call("vecCPMat",X)$XX
###
### if (!is.null(Ydirect)) Y <-  Ydirect else {
###     if (outcome[1]=="cif") Y <- c((status %in% cause)*(exit<=time))
###     else { if (!competing) {
###	     if (outcome[1]=="rmst")
###	     Y <-  c(pmin(exit,time))
###             else Y <-  c((time-pmin(exit,time)))
###            } else Y <- c((status %in% cause)*(time-pmin(exit,time)))
###     }
###  }
###  Yresp <- c(Y)
###  Y <- Yipcw <- c(Y*obs/cens.weights)
###  IPCW <- c(obs/cens.weights)
###
### if (se & monotone) {## {{{ censoring adjustment of variance  and infinitissimal jacknife pseudo augmentation
###    ### order of sorted times
###    ord <- resC$ord
###    X <-  X[ord,,drop=FALSE]
###    X2 <-  X2[ord,,drop=FALSE]
###    status <- status[ord]
###    exit <- exit[ord]
###    weights <- weights[ord]
###    offset <- offset[ord]
###    Y <- Y[ord]
###
###    xx <- resC$cox.prep
###    S0i2 <- S0i <- rep(0,length(xx$strata))
###    S0i[xx$jumps+1]  <- 1/resC$S0
###    S0i2[xx$jumps+1] <- 1/resC$S0^2
###    ## compute function h(s) = \sum_i X_i Y_i(t) I(s \leq T_i \leq t) 
###    ## to make \int h(s)/Ys  dM_i^C(s) 
###    h  <-  apply(X*Y,2,revcumsumstrata,xx$strata,xx$nstrata)
###    ### Cens-Martingale as a function of time and for all subjects to handle strata 
###    btime <- 1*(exit<time)
###    ## to make \int h(s)/Ys  dM_i^C(s)  = \int h(s)/Ys  dN_i^C(s) - dLambda_i^C(s)
###    IhdLam0 <- apply(h*S0i2*btime,2,cumsumstrata,xx$strata,xx$nstrata)
###    U <- matrix(0,nrow(xx$X),ncol(X))
###    U[xx$jumps+1,] <- (resC$jumptimes<time)*h[xx$jumps+1,]/c(resC$S0)
###    MGt <- (U[,drop=FALSE]-IhdLam0)*c(xx$weights)
###
###    ### Censoring Variance Adjustment  \int h^2(s) / y.(s) d Lam_c(s) estimated by \int h^2(s) / y.(s)^2  d N.^C(s) 
###    mid <- max(id)
###    MGCiid <- apply(MGt,2,sumstrata,xx$id,mid+1)
###
###   if (type[1]=="II") { ##  pseudo-value type augmentation
###    hYt  <-  revcumsumstrata(Y,xx$strata,xx$nstrata)
###    IhdLam0 <- cumsumstrata(hYt*S0i2*btime,xx$strata,xx$nstrata)
###    U <- rep(0,length(xx$strata))
###    U[xx$jumps+1] <- (resC$jumptimes<time)*hYt[xx$jumps+1]/c(resC$S0)
###    MGt <- X*c(U-IhdLam0)*c(xx$weights)
###    MGtiid <- apply(MGt,2,sumstrata,xx$id,mid+1)
###    augmentation  <-  apply(MGtiid,2,sum) + augmentation
###    ###
###    EXt  <-  apply(X,2,revcumsumstrata,xx$strata,xx$nstrata)
###    IEXhYtdLam0 <- apply(EXt*c(hYt)*S0i*S0i2*btime,2,cumsumstrata,xx$strata,xx$nstrata)
###    U <- matrix(0,nrow(xx$X),ncol(X))
###    U[xx$jumps+1,] <- (resC$jumptimes<time)*hYt[xx$jumps+1]*EXt[xx$jumps+1,]/c(resC$S0)^2
###    MGt2 <- (U[,drop=FALSE]-IEXhYtdLam0)*c(xx$weights)
###    ###
###    MGCiid2 <- apply(MGt2,2,sumstrata,xx$id,mid+1)
###    ### Censoring Variance Adjustment 
###    MGCiid <- MGCiid+(MGtiid-MGCiid2)
###   }
###   ## use data ordered by time (keeping track of id also)
###   id <- xx$id
###   }  else {
###	  MGCiid <- 0
###  }## }}}
###
### ## default links
### if (model[1]=="default") {
###	 if (outcome[1]=="cif") model <- "logit"
###	 if (outcome[1]=="rmst") model <- "exp"
###	 if (outcome[1]=="rmtl") model <- "exp"
###	 if (outcome[1]=="years-lost") model <- "exp"
### }
###
###obj <- function(pp,all=FALSE)
###{ # {{{
###lp <- c(X %*% pp+offset)
###
###    if (model[1]=="exp") {
###	 p <- exp(lp) 
###         D2logl <- c(weights*p)*X2 
###	 if (monotone) {
###	    Dlogl <- weights*X*c(Y-p) 
###            D2logl <- c(weights*p)*X2 
###	 } else { 
###	    Dlogl <- weights*X*c((Y-p)*p)
###            D2logl <- c(weights*p^2)*X2 
###	 }
###     } else if (model[1]=="lin") {
###	 p <- lp
###         D2logl <- c(weights)*X2
###         Dlogl <- weights*X*c(Y-p)
###    } else if (model[1]=="logit") {
###	p <- expit(lp)
###        if (monotone) {
###           D2logl <- c(weights*p/(1+exp(lp)))*X2
###           Dlogl <- weights*X*c(Y-p)
###	} else {
###           varp <- p/(1+exp(lp))
###           Dlogl <- weights*X*c((Y-p)*varp)
###           D2logl <- c(weights*varp^2)*X2
###	}
###} else stop("link functions must be logit,exp,lin\n") 
###ploglik <- sum(weights*(Y-p)^2)
##### to avoid using ploglik for fitting, with exp,logit only solve estimating equation
###if (model[1]!="lin") ploglik <- 0
###
###D2log <- apply(D2logl,2,sum)
###gradient <- apply(Dlogl,2,sum)+augmentation
###np <- length(pp)
###hessian <- matrix(.Call("XXMatFULL",matrix(D2log,nrow=1),np,PACKAGE="mets")$XXf,np,np)
###
###  if (all) {
###      ploglik <- sum(weights*(Y-p)^2)
###      ihess <- pinv(hessian)
###      beta.iid <- Dlogl %*% ihess ## %*% t(Dlogl) 
###      beta.iid <-  apply(beta.iid,2,sumstrata,id,max(id)+1)
###      robvar <- crossprod(beta.iid)
###      val <- list(par=pp,ploglik=ploglik,gradient=gradient,hessian=hessian,ihessian=ihess,
###	 id=id,Dlogl=Dlogl,iid=beta.iid,robvar=robvar,var=robvar,se.robust=diag(robvar)^.5)
###      return(val)
###  }  
### structure(-ploglik,gradient=-gradient,hessian=hessian)
###}# }}}
###
##### setting default for NR 
###dots <- list(...)
###if (length(dots)==0) {
###   if (model[1]=="exp") control <- list(tol=1e-10,stepsize=0.5)  
###   else control <- NULL
###} else control <- dots[[1]]
###
###  p <- ncol(X)
###  opt <- NULL
###  if (p>0) {
###  if (no.opt==FALSE) {
###      if (tolower(method)=="nr") {
###          tim <- system.time(opt <- lava::NR(beta,obj,control=control))
###	  opt$timing <- tim
###	  opt$estimate <- opt$par
###      } else {
###	  opt <- nlm(obj,beta,...)
###	  opt$method <- "nlm"
###      }
###      cc <- opt$estimate; 
######	      if (!se) return(cc)
###      val <- c(list(coef=cc),obj(opt$estimate,all=TRUE))
###      } else {
###	      val <- c(list(coef=beta),obj(beta,all=TRUE))
###  }
###  } else {
###      val <- obj(0,all=TRUE)
###  }
###
###  if (length(val$coef)==length(colnames(X))) names(val$coef) <- colnames(X)
###  val <- c(val,list(time=time,formula=formula,formC=formC,
###    cens.weights=cens.weights, cens.strata=cens.strata, cens.nstrata=cens.nstrata, 
###    n=length(exit),nevent=nevent,ncluster=nid))
###
###  if ( (!monotone) & se) { ## {{{ censoring adjustment of variance 
###    ### order of sorted times
###    ord <- resC$ord
###    X <-  X[ord,,drop=FALSE]
###    status <- status[ord]
###    exit <- exit[ord]
###    weights <- weights[ord]
###    offset <- offset[ord]
###    lp <- c(X %*% val$coef+offset)
###    Y <- Y[ord]
###
###   if (model[1]=="exp") {
###	 p <- exp(lp) 
###         Yglm <- weights*X*c(Y*p)
###    } else if (model[1]=="lin") {
###	 p <- lp
###         Yglm <- weights*X*c(Y)
###    } else if (model[1]=="logit") {
###	 p <- expit(lp) 
###         varp <- p/(1+exp(lp))
###         Yglm <- weights*X*c(Y*varp)
###    }
###
###    xx <- resC$cox.prep
###    S0i2 <- S0i <- rep(0,length(xx$strata))
###    S0i[xx$jumps+1]  <- 1/resC$S0
###    S0i2[xx$jumps+1] <- 1/resC$S0^2
###    ## compute function h(s) = \sum_i X_i Y_i(t) I(s \leq T_i \leq t) 
###    ## to make \int h(s)/Ys  dM_i^C(s) 
###    h  <-  apply(Yglm,2,revcumsumstrata,xx$strata,xx$nstrata)
###    ### Cens-Martingale as a function of time and for all subjects to handle strata 
###    ## to make \int h(s)/Ys  dM_i^C(s)  = \int h(s)/Ys  dN_i^C(s) - dLambda_i^C(s)
###    IhdLam0 <- apply((exit<time)*h*S0i2,2,cumsumstrata,xx$strata,xx$nstrata)
###    U <- matrix(0,nrow(xx$X),ncol(X))
###    U[xx$jumps+1,] <- (resC$jumptimes<time)*h[xx$jumps+1,] /c(resC$S0)
###    MGt <- (U[,drop=FALSE]-IhdLam0)*c(xx$weights)
###    MGCiid <- apply(MGt,2,sumstrata,xx$id,max(id)+1)
###  }## }}}
###
###  val$call <- cl
###  val$MGciid <- MGCiid 
###  val$call.id <- call.id
###  val$id <- orig.id
###  val$name.id <- name.id
###  val$nid <- nid
###  val$iid.naive <- val$iid
###  val$naive.var <- NULL 
###  if (se)  val$iid  <- val$iid+(MGCiid %*% val$ihessian)
###  if (!is.null(name.id)) val$iid <- nameme(val$iid,name.id)
###  robvar <- crossprod(val$iid)
###  val$var <-  val$robvar <- robvar
###  val$se.robust <- diag(robvar)^.5
###  val$se.coef <- diag(val$var)^.5
###  val$cause <- cause
###  val$cens.code <- cens.code 
###  val$augmentation <- augmentation
###  val$model <- model[1]
###  val$outcome <- outcome[1]
###  val$Yipcw <- Yipcw
###  val$Y     <- Yresp
###  val$IPCW   <- IPCW
###  val$Causes <- Causes
###  val$nevent <- nevent
###  val$design <- des
###
###  class(val) <- "binreg"
###  return(val)
###}# }}}


#' Influence curve components for binomial regression ATE
#'
#' Extracts and scales influence function (IC) components from a fitted
#' binomial regression ATE object or raw IC matrix. Depending on the object
#' class and requested `type`, returns one or more components combined by
#' column-binding.
#'
#' @param x An object of class \code{ATE}, or an object containing an
#'   \code{iid} component.
#' @param type Character vector specifying which influence curve components
#'   to return. Possible values are:
#'   \describe{
#'     \item{coef}{Influence curve for regression coefficients}
#'     \item{DR}{Doubly robust ATE influence curve}
#'     \item{G}{G-computation ATE influence curve}
#'   }
#'   If \code{x} inherits from \code{ATE} and \code{type} is missing,
#'   the default is \code{c("DR", "G")}.
#' @param ... Currently unused.
#'
#' @return A numeric matrix obtained by column-binding the selected
#' influence curve components. Each column corresponds to one element
#' of \code{type}, with column names preserved.
#'
#' @details
#' For objects of class \code{ATE}, the function extracts and rescales
#' the stored influence curve components:
#'
#' \itemize{
#'   \item \code{x$iid} for coefficient ICs
#'   \item \code{x$riskDR.iid} for doubly robust ATE ICs
#'   \item \code{x$riskG.iid} for G-computation ICs
#' }
#'
#' Each component is multiplied by its sample size (\code{NROW(.)}).
#'
#' For non-\code{ATE} objects, the function returns
#' \code{NROW(x$iid) * x$iid}.
#'
#' @examples
#' \dontrun{
#' data(bmt)
#' dfactor(bmt)  <-  ~.
#'
#' fit  <- binregATE(Event(time,cause)~tcell.f+platelet+age,bmt,time=50,cause=1,
#'	  treat.model=tcell.f~platelet+age)
#
#' # default ATE behavior (DR + G)
#' head(IC(fit))
#'
#' # only DR component
#' head(IC(fit, "DR"))
#'
#' # multiple components
#' head(IC(fit, c("coef", "DR")))
#' }
#'
#' @export
IC.binreg <- function(x, type = c("coef", "DR", "G"), ...) { ## {{{ 

  # Default override for ATE objects
  if (inherits(x, "ATE") && missing(type)) {
    type <- c("DR", "G")
  }

  type <- match.arg(type, several.ok = TRUE)

  if (!inherits(x, "ATE")) {
    return(x$iid * NROW(x$iid))
  }

  comps <- list()

  for (t in type) {

    ic_t <- switch(t,
      "coef" = NROW(x$iid) * x$iid,
      "DR"   = NROW(x$riskDR.iid) * x$riskDR.iid,
      "G"    = NROW(x$riskG.iid) * x$riskG.iid,
      stop("Unknown type: ", t)
    )

    comps[[t]] <- ic_t
  }

  out <- do.call(cbind, comps)

  return(out)
}  ## }}} 

##' @export
print.binreg  <- function(x,...) {# {{{
  print(summary(x),...)
}# }}}

##' @export
summary.binreg <- function(object,...) {# {{{

if (!is.null(object$gradient)) { ## write warning if gradient not small 
gradient <- max(abs(object$gradient))
if (gradient > 0.000001) { cat("gradient:\n"); print(object$gradient) }
}

cc  <- estimate(coef=object$coef,vcov=object$var)$coefmat
V=object$var

res <- list(coef=cc,n=object$n,nevent=object$nevent,strata=NULL,
	    ncluster=object$ncluster,var=V,model=object$model[1])

if (object$model[1]=="exp" | object$model[1]=="logit") {
expC <- exp(lava::estimate(coef=coef(object),vcov=object$var)$coefmat[,c(1,3,4),drop=FALSE])
res <- c(res,list(exp.coef=expC))
}

## to add marginal estimates for binregATE 
if (!is.null(object$riskDR))  {
    marginalDR <- estimate(coef=object$riskDR,vcov=object$var.riskDR)$coefmat
    difmarginalDR <- estimate(coef=object$difriskDR,vcov=as.matrix(object$var.difriskDR))$coefmat
###    rownames(difmarginalDR) <- "differenceDR"
    marginalDR <- rbind(marginalDR,difmarginalDR)

    marginalG <- estimate(coef=object$riskG,vcov=object$var.riskG)$coefmat
    difG <- estimate(coef=object$difriskG,vcov=as.matrix(object$var.difriskG))$coefmat
###    rownames(difG) <- "differenceG"
    marginalG <- rbind(marginalG,difG) 
    res <- c(res,list(ateG=marginalG,ateDR=marginalDR))

    if (!is.null(object$attc)) {
    attc <- estimate(coef=object$attc,vcov=object$var.attc)$coefmat
    res <- c(res,list(attc=attc))
    }
}

class(res) <- "summary.binreg"
return(res)
}# }}}

##' @export
print.summary.binreg <- function(x,max.strata=5,...) { ## {{{

  nn <- cbind(x$n, x$nevent)
  rownames(nn) <- levels(x$strata); colnames(nn) <- c("n","events")
  if (is.null(rownames(nn))) rownames(nn) <- rep("",NROW(nn))
  if (length(x$strata)>max.strata) {
      nn <- rbind(c(colSums(nn),length(x$strata)));
      colnames(nn) <- c("n","events","stratas")
      rownames(nn) <- ""
  } 
  print(nn,quote=FALSE)  
  if (!is.null(x$ncluster)) cat("\n ", x$ncluster, " clusters\n",sep="")
  if (!is.null(x$coef)) {
    cat("coeffients:\n")
    printCoefmat(x$coef,...)
    cat("\n")
    if (x$model[1]=="exp" | x$model[1]=="logit") {
    cat("exp(coeffients):\n")
    printCoefmat(x$exp.coef,...)
    }
  }
  cat("\n")

 ## for binreg ATE
 if (!is.null(x$ateDR)) {
    cat("Average Treatment effects (G-formula) :\n")
    printCoefmat(x$ateG,...)
    cat("\n")

    cat("Average Treatment effects (double robust) :\n")
    printCoefmat(x$ateDR,...)
    cat("\n")

###    if (!is.null(x$attc)) {
###    cat("Average Treatment effects on Treated/Non-Treated (DR) :\n")
###    printCoefmat(x$attc,...)
###    cat("\n")
###    }

  }
  cat("\n")

} ## }}}

###}}} 


##' @export
vcov.binreg <- function(object,...) {# {{{
	return(object$var)
}# }}}

##' @export
coef.binreg <- function(object,...) {# {{{
	return(object$coef)
}# }}}

##' @export
predict.binreg <- function(object,newdata=NULL,se=TRUE,pred.iid=FALSE,level=0.95,design=FALSE,...)
{# {{{
   if (!is.null(newdata)) x <- update_design(object$design,data = newdata,response=FALSE) else x <- object$design
  Z <- x$x

  if (object$model[1]=="logit") {
  lp <- c(Z %*% object$coef)
  p <- expit(lp)
  preds <- p
  alpha <- 1-level

  if (se) {
     if (is.null(object$var)) covv <- vcov(object)  else covv <- object$var
     Dpv <- Z*exp(-lp)*p^2
     se <- apply((Dpv %*% covv)* Dpv,1,sum)^.5
     crit <- qnorm(1-alpha/2)
     cmat <- data.frame(pred=p,se=se,lower=p-1.96*se,upper=p+1.96*se)
     names(cmat)[1:4] <- c("pred","se","lower","upper")
     preds <- cmat
  }
  if (pred.iid) {
      Piid <- object$iid  %*% t(Dpv)
      preds <- list(pred=preds,iid=Piid)
  }

  } else {

  lp <- c(Z %*% object$coef)
  if (object$model[1]=="exp") p <- exp(lp) else p <- lp
  preds <- p

  level <- 0.95
  alpha <- 1-level
  crit <- qnorm(1-alpha/2)

  if (se) {
     if (is.null(object$var)) covv <- vcov(object)  else covv <- object$var
###     if (object$model[1]=="dexp") Dpv <- Z*p^2 else 
     if (object$model[1]=="exp") Dpv <- Z*p else Dpv <- Z 
     se <- apply((Dpv %*% covv)* Dpv,1,sum)^.5
     cmat <- data.frame(pred=p,se=se,lower=p-crit*se,upper=p+crit*se)
     names(cmat)[1:4] <- c("pred","se","lower","upper")
     preds <- cmat
  }
  if (pred.iid) {
      Piid <- object$iid  %*% t(Dpv)
      preds <- list(pred=preds,iid=Piid,id=x$cluster)
  }

  }

  attr(preds,"id") <- x$cluster
  if (design) attr(preds,"x") <- Z

return(preds)
} # }}}

##' @export
binregt <- function(formula,data,cause=1,time=NULL,beta=NULL,
	   offset=NULL,weights=NULL,cens.weights=NULL,cens.model=~+1,se=TRUE,
	   kaplan.meier=TRUE,cens.code=0,no.opt=FALSE,method="nr",augmentation=NULL,...)
{# {{{
  cl <- match.call()# {{{
###    m <- match.call(expand.dots = TRUE)[1:3]
    des <- proc_design(
        formula,
        data = data,
        specials = c("offset", "weights", "cluster"),
        intercept = TRUE
    )
    Y <- des$y
    if (!inherits(Y, c("Event", "Surv"))) {
        stop("Expected a 'Surv' or 'Event'-object")
    }
    if (ncol(Y) == 2) {
        exit <- Y[, 1]
        entry <- rep(0, nrow(Y))
        status <- Y[, 2]
    } else {
        entry <- Y[, 1]
        exit <- Y[, 2]
        status <- Y[, 3]
    }
    X <- des$x
    des.weights <- des$weights
    des.offset  <- des$offset
    id      <- des$cluster

  call.id <- id
  conid <- construct_id(id,nrow(X),namesX=rownames(X))
  name.id <- conid$name.id; id <- conid$id; nid <- conid$nid
  ## id before time-sorting
  orig.id <- id

###  if (is.null(offset)) offset <- rep(0,length(exit)) 
###  if (is.null(weights)) weights <- rep(1,length(exit)) 
  ## take offset and weight first from formula, but then from arguments
  if (is.null(des.offset)) {
	  if (is.null(offset)) offset <- rep(0,length(exit)) 
  } else offset <- des.offset
  if (is.null(des.weights)) {
	  if (is.null(weights)) weights <- rep(1,length(exit)) 
  } else weights <- des.weights

# }}}




  if (is.null(time)) stop("Must give time for logistic modelling \n"); 
  statusC <- (status %in% cens.code) 
  statusE <- (status %in% cause)*outer(exit,time,"<=") 
  if (any(apply(statusE,2,sum))==0) stop("No events of type 1 before time \n"); 
  kmt <- kaplan.meier
  data$id__ <- id
  data$exit <- exit
  data$statusC <- statusC 
  cens.strata <- cens.nstrata <- NULL 

  if (is.null(cens.weights))  {
      formC <- update.formula(cens.model,Surv(exit,statusC)~ . +cluster(id__))
      resC <- phreg(formC,data)
      if (resC$p>0) kmt <- FALSE
      cens.weights <- c()
      for (tt in time)  {
      exittime <- pmin(exit,tt)
      cens.weights1 <- suppressWarnings(predict(resC,data,times=exittime,individual.time=TRUE,se=FALSE,km=kmt,tminus=TRUE)$surv)
      cens.weights <- cbind(cens.weights,cens.weights1)
      }
      ## strata from original data 
      cens.strata <- resC$strata[order(resC$ord)]
      cens.nstrata <- resC$nstrata
  } else formC <- NULL
  expit  <- function(z) 1/(1+exp(-z)) ## expit

  if (length(time)>1) {
      Yt <- outer(exit,time,"<=") 
      nevent <- apply(c(status %in% cause)*Yt,2,sum)
      Y <- c((status %in%cause)/cens.weights)*Yt
  } else {
      Y <- c((status %in%cause)*(exit<=time)/cens.weights)
      nevent <- sum((status %in%cause)*(exit<=time))
  }

  ppt <- length(time)
  p <- pd <- ncol(X)+(length(time)-1)
  if (is.null(beta)) beta <- rep(0,ncol(X)+ppt-1)
  X <-  as.matrix(X)
  X2o  <- .Call("vecMatMat",X[,-1,drop=FALSE],X[,-1,drop=FALSE])$vXZ
###  X2  <- .Call("vecMatMat",X,X)$vXZ

  if (is.null(augmentation))  augmentation=rep(0,p)

obj <- function(pp,all=FALSE)
{ # {{{

lp <- c(X[,-1,drop=FALSE] %*% pp[-seq(1,ppt)])
lp <- outer(lp,pp[1:ppt],"+")
p <- expit(lp)
ploglik <- sum(weights*(Y-p)^2)

Dloglt <- weights*(Y-p)
Dloglo <- weights*X[,-1]*apply((Y-p),1,sum)
Dlogl <- cbind(Dloglt,Dloglo)

wwp <- (weights*p/(1+exp(lp)))
wwpt <- apply(wwp,2,sum)
wwpo <- apply(wwp,1,sum)
D2loglo <- c(wwpo)*X2o
hessian <- matrix(0,pd,pd)
hessian[seq(1,ppt),seq(1,ppt)] <- diag(wwpt,ppt,ppt)
for (i in 1:ppt) hessian[i,(ppt+1):pd] <- apply(wwp[,i]*X[,-1,drop=FALSE],2,sum)
hessian[(ppt+1):pd,1:ppt]  <- t(hessian[1:ppt,(ppt+1):pd])
hessian[(ppt+1):pd,(ppt+1):pd] <- c(apply(D2loglo,2,sum))

gradient <- apply(Dlogl,2,sum)+augmentation

  if (all) {
      ihess <- pinv(hessian)
      beta.iid <- Dlogl %*% ihess ## %*% t(Dlogl) 
      beta.iid <-  apply(beta.iid,2,sumstrata,id,max(id)+1)
      robvar <- crossprod(beta.iid)
      val <- list(par=pp,ploglik=ploglik,gradient=gradient,hessian=hessian,ihessian=ihess,
	 id=id,Dlogl=Dlogl,iid=beta.iid,robvar=robvar,var=robvar,se.robust=diag(robvar)^.5)
      return(val)
  }  
 structure(-ploglik/nid,gradient=-gradient/nid,hessian=hessian/nid)
}# }}}

	  p <- pd 
	  opt <- NULL
	  if (p>0) {
	  if (no.opt==FALSE) {
	      if (tolower(method)=="nr") {
		  tim <- system.time(opt <- lava::NR(beta,obj,...))
		  opt$timing <- tim
		  opt$estimate <- opt$par
	      } else {
		  opt <- nlm(obj,beta,...)
		  opt$method <- "nlm"
	      }
	      cc <- opt$estimate; 
	      if (!se) return(cc)
	      val <- c(list(coef=cc),obj(opt$estimate,all=TRUE))
	      } else val <- c(list(coef=beta),obj(beta,all=TRUE))
	  } else {
	      val <- obj(0,all=TRUE)
	  }

	  if (length(time)==1) {
	  if (length(val$coef)==length(colnames(X))) names(val$coef) <- colnames(X) }
	  else names(val$coef) <- c(paste("Intercept",time,sep=""),colnames(X)[-1])
	  val <- c(val,list(time=time,formula=formula,formC=formC,
	    exit=exit, cens.weights=cens.weights, cens.strata=cens.strata, cens.nstrata=cens.nstrata, 
	    n=length(exit),nevent=nevent,ncluster=nid))
	  

 if (se) {## {{{ censoring adjustment of variance 
    ### order of sorted times
    ord <- resC$ord
    X <-  X[ord,,drop=FALSE]
    status <- status[ord]
    exit <- exit[ord]
    weights <- weights[ord]
    offset <- offset[ord]
    cens.weights <- cens.weights[ord]
    if (length(time)>1) {
         Yt <- outer(exit,time,"<=") 
         Y <- c((status%in% cause)/cens.weights)*Yt
	 Ys <- apply(Y,1,sum)
     } else {
         Ys <- Y <- c((status%in%cause)*(exit<=time)/cens.weights)
     }

    xx <- resC$cox.prep
    S0i2 <- S0i <- rep(0,length(xx$strata))
    S0i[xx$jumps+1]  <- 1/resC$S0
    S0i2[xx$jumps+1] <- 1/resC$S0^2
    ## compute function h(s) = \sum_i X_i Y_i(t) I(s \leq T_i \leq t) 
    ## to make \int h(s)/Ys  dM_i^C(s) 
    h  <-  apply(cbind(Y,X[,-1]*Ys),2,revcumsumstrata,xx$strata,xx$nstrata)
    ### Cens-Martingale as a function of time and for all subjects to handle strata 
    ## to make \int h(s)/Ys  dM_i^C(s)  = \int h(s)/Ys  dN_i^C(s) - dLambda_i^C(s)
###    btime <- 1*outer(exit,time,"<") 
    IhdLam0 <- apply(h*c(S0i2),2,cumsumstrata,xx$strata,xx$nstrata)
    U <- matrix(0,nrow(X),pd)
    jtime <- outer(resC$jumptimes,time,"<")*1
    U[xx$jumps+1,] <- (h[xx$jumps+1,])/c(resC$S0)
    MGt <- (U[,drop=FALSE]-IhdLam0)*c(xx$weights)

    ### Censoring Variance Adjustment  \int h^2(s) / y.(s) d Lam_c(s) estimated by \int h^2(s) / y.(s)^2  d N.^C(s) 
    MGCiid <- apply(MGt,2,sumstrata,xx$id,max(id)+1)
 
   }  else {
	  MGCiid <- 0
  }## }}}

  val$call <- cl
  val$MGciid <- MGCiid
  val$call.id <- call.id
  val$name.id <- name.id
  val$id <- orig.id
  val$nid <- nid
  val$iid.naive <- val$iid 
  if (se) val$iid  <- val$iid+(MGCiid %*% val$ihessian) else val$iid  <- val$iid
  val$naive.var <- val$var
  robvar <- crossprod(val$iid)
  val$var <-  val$robvar <- robvar
  val$se.robust <- diag(robvar)^.5
  val$se.coef <- diag(val$var)^.5
  val$cause <- cause
  val$cens.code <- cens.code 
  val$model <- "logit"
  val$design <- des


  class(val) <- "binreg"
  return(val)
}# }}}

##' @export
logitIPCW <- function(formula,data,cause=1,time=NULL,beta=NULL,
	   offset=NULL,weights=NULL,cens.weights=NULL,cens.model=~+1,se=TRUE,
	   kaplan.meier=TRUE,cens.code=0,no.opt=FALSE,method="nr",augmentation=NULL,
	   outcome=c("cif","rmst","rmtl"),model=c("default","logit","exp","lin"),Ydirect=NULL,...)
{# {{{
  cl <- match.call()# {{{
###  m <- match.call(expand.dots = TRUE)[1:3]
    des <- proc_design(
        formula,
        data = data,
        specials = c("offset", "weights", "cluster"),
        intercept = TRUE
    )
    Y <- des$y
    if (!inherits(Y, c("Event", "Surv"))) {
        stop("Expected a 'Surv' or 'Event'-object")
    }
    if (ncol(Y) == 2) {
        exit <- Y[, 1]
        entry <- rep(0, nrow(Y))
        status <- Y[, 2]
    } else {
        entry <- Y[, 1]
        exit <- Y[, 2]
        status <- Y[, 3]
    }
    X <- des$x
    des.weights <- des$weights
    des.offset  <- des$offset
    id      <- des$cluster

  ### possible handling of id to code from 0:(antid-1)
  call.id <- id 
  conid <- construct_id(id,nrow(X),namesX=rownames(X))
  name.id <- conid$name.id; id <- conid$id; nid <- conid$nid
  orig.id <- id

  ## take offset and weight first from formula, but then from arguments
  if (is.null(des.offset)) {
	  if (is.null(offset)) offset <- rep(0,length(exit)) 
  } else offset <- des.offset
  if (is.null(des.weights)) {
	  if (is.null(weights)) weights <- rep(1,length(exit)) 
  } else weights <- des.weights

# }}}

  if (is.null(time)) stop("Must give time for logistic modelling \n"); 
  statusC <- (status%in% cens.code) 
  statusE <- (status%in%cause) & (exit<= time) 
  if (sum(statusE)==0) stop("No events of type 1 before time \n"); 
  kmt <- kaplan.meier

  statusC <- (status %in%cens.code) 
  data$id__ <- id
  data$exit <- exit
  data$statusC <- statusC 
  ucauses  <-  sort(unique(status))
  ccc <- which(ucauses %in% cens.code)
  if (length(ccc)==0) Causes <- ucauses else Causes <- ucauses[-ccc]
  competing  <-  (length(Causes)>1) 

  cens.strata <- cens.nstrata <- NULL 

  if (is.null(cens.weights))  {
      formC <- update.formula(cens.model,Surv(exit,statusC)~ . +cluster(id__))
      resC <- phreg(formC,data)
      if (resC$p>0) kmt <- FALSE
      exittime <- pmin(exit,time)
      cens.weights <- suppressWarnings(predict(resC,data,times=exittime,individual.time=TRUE,se=FALSE,km=kmt,tminus=TRUE)$surv)
      ## strata from original data 
      cens.strata <- resC$strata[order(resC$ord)]
      cens.nstrata <- resC$nstrata
  } else formC <- NULL
  expit  <- function(z) 1/(1+exp(-z)) ## expit

  if (is.null(beta)) beta <- rep(0,ncol(X))
  p <- ncol(X)

  X <-  as.matrix(X)
  X2  <- .Call("vecCPMat",X)$XX
  obs <- (exit<=time & status!=cens.code) | (exit>=time)
  weights <- obs*weights/c(cens.weights)
  cens.weights <- c(cens.weights)

  if (!is.null(Ydirect)) Y <-  Ydirect else {
     if (outcome[1]=="cif") Y <- c((status %in% cause)*(exit<=time))
     else { if (!competing) {
	     if (outcome[1]=="rmst")
	     Y <-  c(pmin(exit,time)) 
             else Y <-  c((time-pmin(exit,time)))
            } else Y <- c((status %in% cause)*(time-pmin(exit,time)))
     }
  }
  Yipcw <- Y
 
 if (is.null(augmentation))  augmentation=rep(0,p)
 nevent <- sum(Y)

 ## default links
 if (model[1]=="default") {
	 if (outcome[1]=="cif") model <- "logit"
	 if (outcome[1]=="rmst") model <- "exp"
	 if (outcome[1]=="rmtl") model <- "exp"
	 if (outcome[1]=="years-lost") model <- "exp"
 }


obj <- function(pp,all=FALSE)
{ # {{{

lp <- c(X %*% pp+offset)

    if (model[1]=="exp") {
	 p <- exp(lp) 
         D2logl <- c(weights*p)*X2 
     } else if (model[1]=="lin") {
	 p <- lp
         D2logl <- c(weights)*X2
     } else if (model[1]=="logit") {
	p <- expit(lp)
        D2logl <- c(weights*p/(1+exp(lp)))*X2
     } else stop("link functions must be logit,exp,lin\n") 
ploglik <- sum(weights*(Y-p)^2)

if (model[1]=="exp") ploglik <- 0
Dlogl <- weights*X*c(Y-p)
D2log <- apply(D2logl,2,sum)
gradient <- apply(Dlogl,2,sum)+augmentation
np <- length(pp)
hessian <- matrix(.Call("XXMatFULL",matrix(D2log,nrow=1),np,PACKAGE="mets")$XXf,np,np)

  if (all) {
      ihess <- pinv(hessian)
      beta.iid <- Dlogl %*% ihess ## %*% t(Dlogl) 
      beta.iid <-  apply(beta.iid,2,sumstrata,id,max(id)+1)
      robvar <- crossprod(beta.iid)
      val <- list(par=pp,ploglik=ploglik,gradient=gradient,hessian=hessian,ihessian=ihess,
	 id=id,Dlogl=Dlogl,iid=beta.iid,robvar=robvar,var=robvar,se.robust=diag(robvar)^.5)
      return(val)
  }  
 structure(-ploglik,gradient=-gradient,hessian=hessian)
}# }}}

## setting default for NR 
dots <- list(...)
if (length(dots)==0) {
   if (model[1]=="exp") control <- list(tol=1e-10,stepsize=0.5)  
   else control <- NULL
} else control <- dots[[1]]

  p <- ncol(X)
  opt <- NULL
  if (p>0) {
  if (no.opt==FALSE) {
      if (tolower(method)=="nr") {
	  tim <- system.time(opt <- lava::NR(beta,obj,control=control))
	  opt$timing <- tim
	  opt$estimate <- opt$par
      } else {
	  opt <- nlm(obj,beta,...)
	  opt$method <- "nlm"
      }
      cc <- opt$estimate; 
      val <- c(list(coef=cc),obj(opt$estimate,all=TRUE))
      } else val <- c(list(coef=beta),obj(beta,all=TRUE))
  } else {
      val <- obj(0,all=TRUE)
  }

  if (length(val$coef)==length(colnames(X))) names(val$coef) <- colnames(X)
  val <- c(val,list(time=time,formula=formula,formC=formC,
    cens.weights=cens.weights, cens.strata=cens.strata, cens.nstrata=cens.nstrata, 
    n=length(exit),nevent=nevent,ncluster=nid,weights=weights))
  
 if (se) {## {{{ censoring adjustment of variance 
    ### order of sorted times
    ord <- resC$ord
    X <-  X[ord,,drop=FALSE]
    status <- status[ord]
    exit <- exit[ord]
    weights <- weights[ord]
    offset <- offset[ord]
    lp <- c(X %*% val$coef+offset)
    p <- expit(lp)
    Yglm <- weights*c(Y[ord]-p) # *(exit<=time)

    xx <- resC$cox.prep
    S0i2 <- S0i <- rep(0,length(xx$strata))
    S0i[xx$jumps+1]  <- 1/resC$S0
    S0i2[xx$jumps+1] <- 1/resC$S0^2
    ## compute function h(s) = \sum_i X_i Y_i(t) I(s \leq T_i \leq t) 
    ## to make \int h(s)/Ys  dM_i^C(s) 
    h  <-  apply(X*Yglm,2,revcumsumstrata,xx$strata,xx$nstrata)
    ### Cens-Martingale as a function of time and for all subjects to handle strata 
    ## to make \int h(s)/Ys  dM_i^C(s)  = \int h(s)/Ys  dN_i^C(s) - dLambda_i^C(s)
    IhdLam0 <- apply((exit<time)*h*S0i2,2,cumsumstrata,xx$strata,xx$nstrata)
    U <- matrix(0,nrow(xx$X),ncol(X))
    U[xx$jumps+1,] <- (resC$jumptimes<time)*h[xx$jumps+1,] /c(resC$S0)
    MGt <- (U[,drop=FALSE]-IhdLam0)*c(xx$weights)

    ### Censoring Variance Adjustment  \int h^2(s) / y.(s) d Lam_c(s) estimated by \int h^2(s) / y.(s)^2  d N.^C(s) 
    MGCiid <- apply(MGt,2,sumstrata,xx$id,max(id)+1)
  }  else {
	  MGCiid <- 0
  }## }}}

    val$Y <- Yipcw
    val$model <- model[1]
    val$outcome <- outcome[1]
    val$call <- cl
    val$MGciid <- MGCiid
    val$id <- orig.id
    val$call.id <- call.id
    val$name.id <- name.id
    val$nid <- nid
    val$iid.naive <- val$iid 
    if (se)
    val$iid  <- val$iid+(MGCiid %*% val$ihessian)
    if (!is.null(call.id)) val$iid <- nameme(val$iid,name.id)
    val$naive.var <- val$var
    robvar <- crossprod(val$iid)
    val$var <-  val$robvar <- robvar
    val$se.robust <- diag(robvar)^.5
    val$se.coef <- diag(val$var)^.5
    val$cause <- cause
    val$cens.code <- cens.code 
    val$augmentation <- augmentation
    val$design <- des

  class(val) <- "binreg"
  return(val)
}# }}}


##' Average Treatment Effect for Censored Competing Risks Data using Binomial Regression
##'
##' Estimates the average treatment effect (ATE) \eqn{E(Y(1) - Y(0))} for censored 
##' competing risks data using binomial regression with Inverse Probability of 
##' Censoring Weighting (IPCW).
##'
##' Under standard causal assumptions, the ATE can be estimated. These assumptions include:
##' \itemize{
##'   \item \strong{Consistency}: The observed outcome equals the potential outcome under the observed treatment.
##'   \item \strong{Ignorability}: \eqn{(Y(1), Y(0)) \perp A | X} (treatment assignment is independent of potential outcomes given covariates).
##'   \item \strong{Positivity}: All treatment levels have non-zero probability given covariates.
##' }
##'
##' The first covariate in the competing risks regression model must be the treatment variable, 
##' which should be coded as a factor. If the factor has more than two levels, multinomial 
##' logistic regression (\code{mlogit}) is used for propensity score modeling. In the absence 
##' of censoring, this reduces to ordinary logistic regression.
##'
##' The ATE is estimated using standard doubly robust estimating equations that are 
##' IPCW-censoring adjusted. As an alternative to binomial regression, 
##' \code{logitIPCWATE} provides an IPCW-weighted version of standard logistic regression.
##'
##' When \code{typeATE = "II"}, the estimating equation is augmented with:
##' \deqn{ (A/\pi(X)) \int E( O(t) | T \geq t, S(X))/ G_c(t,S(X)) d \hat M_c(s) }
##' when estimating the mean outcome for the treated group.
##'
##' @section References:
##' \itemize{
##'   \item Blanche PF, Holt A, Scheike T (2022). "On logistic regression with right censored data, with or without competing risks, and its use for estimating treatment effects." \emph{Lifetime Data Analysis}, 29, 441–482.
##' }
##'
##' @param formula A formula object specifying the outcome and covariates (see \code{coxph}). 
##'   The first covariate should be the treatment variable coded as a factor.
##' @param data A data frame containing the variables in the formula.
##' @param cause Numeric scalar indicating the cause of interest for competing risks.
##' @param time Numeric scalar indicating the time point of interest.
##' @param beta Optional numeric vector of starting values for the coefficients.
##' @param treat.model A formula specifying the logistic treatment model given covariates 
##'   (e.g., \code{treatment ~ covariate1 + covariate2}).
##' @param cens.model A formula specifying the censoring model. Only stratified Cox models 
##'   without covariates are supported (e.g., \code{~ strata(group)}).
##' @param offset Optional numeric vector of offsets for the partial likelihood.
##' @param weights Optional numeric vector of weights for the score equations.
##' @param cens.weights Optional numeric vector of pre-calculated censoring weights. 
##'   If \code{NULL}, weights are estimated internally.
##' @param se Logical. If \code{TRUE}, computes standard errors with IPCW adjustment. 
##'   If \code{FALSE}, assumes IPCW weights are known.
##' @param type Character string. Either \code{"I"} (classic binomial regression) or 
##'   \code{"II"} (adds augmentation term for efficiency).
##' @param kaplan.meier Logical. If \code{TRUE}, uses Kaplan-Meier for IPCW weights; 
##'   otherwise uses \eqn{\exp(-\text{Baseline})}.
##' @param cens.code Numeric code representing censored observations in the status variable.
##' @param no.opt Logical. If \code{TRUE}, optimization is skipped and starting values are used.
##' @param method Character string. Optimization method: \code{"nr"} (Newton-Raphson) or \code{"nlm"}.
##' @param augmentation Optional numeric vector for augmenting binomial regression.
##' @param outcome Character string. Outcome type: \code{"cif"} (Cumulative Incidence Function, 
##'   \eqn{F(t|X)}), \code{"rmst"} (Restricted Mean Survival Time, \eqn{E(\min(T, t) | X)}), 
##'   or \code{"rmtl"} (Restricted Mean Time Lost, \eqn{E(I(\epsilon=\text{cause})(t - \min(T,t)) | X)}).
##' @param model Character string. Link function for the outcome model: \code{"exp"} or 
##'   \code{"lin"} (identity). For \code{"cif"}, \code{"logit"} is typically used.
##' @param Ydirect Optional numeric vector. Use this outcome Y with IPCW version instead of 
##'   constructing one from \code{outcome}.
##' @param typeATE Character string. Either \code{"II"} (censoring augmentation of the 
##'   estimating equation) or \code{"I"} (standard).
##' @param ... Additional arguments passed to lower-level functions (e.g., \code{binreg} 
##'   that fits the outcome model).
##'
##' @return An object of class \code{c("binreg", "ATE")} containing:
##' \item{coef}{Estimated coefficients from the outcome model.}
##' \item{riskDR}{Double-robust marginal risk estimates for each treatment level.}
##' \item{riskG}{G-formula marginal risk estimates for each treatment level.}
##' \item{difriskDR}{Difference in risks (ATE) using double-robust estimator.}
##' \item{difriskG}{Difference in risks (ATE) using G-formula estimator.}
##' \item{riskDR.iid, riskG.iid}{Influence functions for marginal risk estimates.}
##' \item{var, var.riskDR, var.riskG}{Variance-covariance matrices.}
##' \item{se.coef, se.riskDR, se.riskG}{Standard errors.}
##'
##' @author Thomas Scheike
##'
##' @seealso \code{\link{binreg}}, \code{\link{logitIPCWATE}}, \code{\link{logitATE}}, 
##'   \code{\link{binregG}}
##' @examples
##' data(bmt)
##' dfactor(bmt)  <-  ~.
##'
##' brs <- binregATE(Event(time,cause)~tcell.f+platelet+age,bmt,time=50,cause=1,
##'	  treat.model=tcell.f~platelet+age)
##' summary(brs)
##' head(brs$riskDR.iid)
##' head(brs$riskG.iid)
##'
##' brsi <- binregATE(Event(time,cause)~tcell.f+tcell.f*platelet+tcell.f*age,bmt,time=50,cause=1,
##'	  treat.model=tcell.f~platelet+age)
##' summary(brsi)
##' head(brs$riskDR.iid)
##' head(brs$riskG.iid)
##' @seealso [kumarsim()] [kumarsimRCT()]
##' @aliases logitIPCWATE logitATE normalATE
##' @export
binregATE <- function(formula,data,cause=1,time=NULL,beta=NULL,treat.model=~+1,cens.model=~+1,
   offset=NULL,weights=NULL,cens.weights=NULL,se=TRUE,type=c("II","I"),
   kaplan.meier=TRUE,cens.code=0,no.opt=FALSE,method="nr",augmentation=NULL,
   outcome=c("cif","rmst","rmtl"),model=c("default","logit","exp","lin"),Ydirect=NULL,typeATE="II",...)
{# {{{
  cl <- match.call()# {{{
###  m <- match.call(expand.dots = TRUE)[1:3]
    des <- proc_design(
        formula,
        data = data,
        specials = c("offset", "weights", "cluster"),
        intercept = TRUE
    )
    Y <- des$y
    if (!inherits(Y, c("Event", "Surv"))) {
        stop("Expected a 'Surv' or 'Event'-object")
    }
    if (ncol(Y) == 2) {
        exit <- Y[, 1]
        entry <- rep(0, nrow(Y))
        status <- Y[, 2]
    } else {
        entry <- Y[, 1]
        exit <- Y[, 2]
        status <- Y[, 3]
    }
    X <- des$x
    des.weights <- des$weights
    des.offset  <- des$offset
    id      <- des$cluster

 call.id <- id;
 conid <- construct_id(id,nrow(X),namesX=rownames(X))
 name.id <- conid$name.id; id <- conid$id; nid <- conid$nid
 idclust <- id; nclust <- nid

 ## take each data-record with its own iid or organize after idclust later 
 nid <- length(id); 
 id <- 0:(nid-1); 

  ## take offset and weight first from formula, but then from arguments
  if (is.null(des.offset)) {
	  if (is.null(offset)) offset <- rep(0,length(exit)) 
  } else offset <- des.offset
  if (is.null(des.weights)) {
	  if (is.null(weights)) weights <- rep(1,length(exit)) 
  } else weights <- des.weights

###  if (is.null(offset)) offset <- rep(0,length(exit)) 
###  if (is.null(weights)) weights <- rep(1,length(exit)) 
# }}}

  ## {{{ setting up status, response, censoring model 
  if (is.null(time)) stop("Must give time for logistic modelling \n"); 
  statusC <- (status %in%cens.code) 
  statusE <- (status %in% cause) & (exit<= time) 
  if (sum(statusE)==0) warning("No events of type 1 before time \n"); 
  kmt <- kaplan.meier
  ucauses  <-  sort(unique(status))
  ccc <- which(ucauses %in% cens.code)
  if (length(ccc)==0) Causes <- ucauses else Causes <- ucauses[-ccc]
  competing  <-  (length(Causes)>1) 

  statusC <- (status %in%cens.code) 
  data$id__ <- id 
  data$exit <- exit
  data$statusC <- statusC 
  n <- length(exit)
  cens.strata <- cens.nstrata <- NULL 

  call.cw <- cens.weights
  if (is.null(cens.weights))  {
      formC <- update.formula(cens.model,Surv(exit,statusC)~ . +cluster(id__))
      resC <- phreg(formC,data)
      if (resC$p>0) kmt <- FALSE
      exittime <- pmin(exit,time)
      cens.weights <- suppressWarnings(predict(resC,data,times=exittime,individual.time=TRUE,se=FALSE,km=kmt,tminus=TRUE)$surv)
      ## strata from original data 
      cens.strata <- resC$strata[order(resC$ord)]
      cens.nstrata <- resC$nstrata
  } else formC <- NULL
  expit  <- function(z) 1/(1+exp(-z)) ## expit

  p <- ncol(X)
  if (is.null(beta)) beta <- rep(0,p)
  X <-  as.matrix(X)
  ###  X2  <- .Call("vecMatMat",X,X)$vXZ
  X2  <- .Call("vecCPMat",X)$XX
  ###
  ucauses  <-  sort(unique(status))
  ccc <- which(ucauses %in% cens.code)
  if (length(ccc)>=1) Causes <- ucauses[-ccc] else Causes <- ucauses
  obs <- (exit<=time & (status %in% Causes)) | (exit>=time)

 if (!is.null(Ydirect)) Y <-  Ydirect*obs/cens.weights else {
     if (outcome[1]=="cif") Y <- c((status %in% cause)*(exit<=time)/cens.weights)
     else { if (!competing) {
	     if (outcome[1]=="rmst") Y <-  c(pmin(exit,time)*obs)/cens.weights 
	     else Y <-  c((time-pmin(exit,time))*obs)/cens.weights 
            } else Y <- c((status %in% cause)*(time-pmin(exit,time))*obs)/cens.weights
     }
  }
 nevent <- sum((status %in% cause)*(exit<=time))

 ## }}}

## change id from call to id__ to get ordering as data
formula <- drop.specials(formula,"cluster")
formula <- update(formula, .~.+cluster(id__))

  val <- binreg(formula,data,cause=cause,time=time,beta=beta,type=type,
	cens.model=cens.model,se=se,kaplan.meier=kaplan.meier,
        offset=offset,weights=weights,cens.weights=call.cw,
        cens.code=cens.code,no.opt=no.opt,method=method,augmentation=augmentation,
        outcome=outcome[1],model=model[1],Ydirect=Ydirect,...)

model <- val$model[1]

# {{{ computation of ate, att, atc and their influence functions

### treatment is rhs of treat.model 
if (length(all.vars(treat.model))==0) 
{ respformula  <-  as.formula( paste(all.vars(formula)[3],"~."))
  treat.model  <- update.formula(treat.model,respformula)
###  cat("Using propensity score model :\n "); print(treat.model)
}
treat.name <-  all.vars(treat.model)[1]
treatvar <- data[,treat.name]
if (!is.factor(treatvar)) stop(paste("treatment=",treat.name," must be coded as factor \n",sep="")); 
## treatvar, 1,2,...,nlev or 1,2
nlev <- nlevels(treatvar)
nlevs <- levels(treatvar)
###treatvar <- as.numeric(treatvar)
ntreatvar <- as.numeric(treatvar)
ytreat <- ntreatvar-1

## dropping cluster here 
if (nlev==2) {
   treat.model <- drop.specials(treat.model,"cluster")
   treat <- glm(treat.model,data,family="binomial")
   iidalpha <- iid(treat,id=id)
   lpa <- treat$linear.predictors 
   pal <- expit(lpa)
   pal <-cbind(1-pal,pal)
   ppp <- (pal/pal[,1])
   spp <- 1/pal[,1]
} else {  
   treat.modelid <- update.formula(treat.model,.~.+cluster(id__))
   treat <- mlogit(treat.modelid,data)
   iidalpha <- iid(treat)
   pal <- predict(treat,data,se=0,response=FALSE)
   ppp <- (pal/pal[,1])
   spp <- 1/pal[,1]
}

   ###########################################################
   ### computes derivative of D (1/Pa) propensity score 
   ###########################################################
   Xtreat <- model.matrix(treat.model,data)
   tvg2 <- 1*(ntreatvar>=2)
   pA <- c(mdi(pal, 1:length(treatvar), ntreatvar))
   pppy <- c(mdi(ppp,1:length(treatvar), ntreatvar))
   Dppy <-  (spp*tvg2-pppy) 
   Dp <- c()
   for (i in seq(nlev-1)) Dp <- cbind(Dp,Xtreat*ppp[,i+1]*Dppy/spp^2);  
   DPai <- -1*Dp/pA^2
   p1lp <-   X %*% val$coef+offset
   if (model[1]=="logit") { p1 <- expit(p1lp) } else {
    if (model[1]=="exp") { p1 <- exp(p1lp); } else { p1 <- p1lp;}
   }


k <- 0
DePsia <- DariskG <- DaPsia <- list(); 
pia <- Ya <- riskG <- riska <- c(); 
datA <- dkeep(data,x=all.vars(formula))
xlev <- lapply(datA,levels)
formulanc <- drop.specials(formula,"cluster")
a <- nlevs[1]
for (a in nlevs) {# {{{
	k <- k+1
	datA[,treat.name] <- a
	Xa <- model.matrix(formulanc[-2],datA,xlev=xlev)
        lpa <- Xa %*% val$coef+offset
	if (model[1]=="logit") {
	   ma <- expit(lpa); Dma  <-  Xa*c(ma/(1+exp(lpa)))
	} else {
	    if (model[1]=="exp") { ma <- exp(lpa);  Dma<-c(ma)*Xa; } else { ma <- lpa; Dma <- Xa }
	}
	paka <- pal[,k]
	riska <- cbind(riska,((treatvar==a)/paka)*(Y-ma)+ma)
	riskG <- cbind(riskG,ma)
	Ya <- cbind(Ya,Y*((treatvar==a)/paka))
	pia <- cbind(pia,((treatvar==a)/paka))
        DariskG[[k]] <- apply(Dma,2,sum)
        DePsia[[k]] <-  apply(Dma*(1-(treatvar==a)/paka),2,sum)
        DaPsia[[k]] <-  apply(DPai*(treatvar==a)*c(Y-p1),2,sum)
}# }}}

augmentationATE <- 0
 if (se) {## {{{ censoring adjustment of variance 
    ### order of sorted times
    ord <- resC$ord
    X <-  X[ord,,drop=FALSE]
    Xtreat <- Xtreat[ord,,drop=FALSE]
    ytreat <- ytreat[ord]
    status <- status[ord]
    exit <- exit[ord]
    weights <- weights[ord]
    offset <- offset[ord]
    Ya <- Ya[ord,]
    pal <- pal[ord]
    piaC <- pia[ord,]
    cens.weights <- cens.weights[ord]
    lp <- c(X %*% val$coef+offset)
    obs <- obs[ord]
    p <- expit(lp)

  Y <- Y[ord]
  Yc <- matrix(Y,ncol=1)

 Y <- Y*weights 
 xx <- resC$cox.prep
 S0i2 <- S0i <- rep(0,length(xx$strata))
 S0i[xx$jumps+1]  <- 1/resC$S0
 S0i2[xx$jumps+1] <- 1/resC$S0^2
 ## compute function h(s) = \sum_i X_i Y_i(t) I(s \leq T_i \leq t) 
 ## to make \int h(s)/Ys  dM_i^C(s) 
 has  <-  apply(Ya,2,revcumsumstrata,xx$strata,xx$nstrata)
###    hattc  <-  apply(cbind(ytreat-pal*(1-ytreat)/(1-pal),-(1-ytreat)+(1-pal)*ytreat/pal)*Y,2,revcumsumstrata,xx$strata,xx$nstrata)
    ### Cens-Martingale as a function of time and for all subjects to handle strata 
    ## to make \int h(s)/Ys  dM_i^C(s)  = \int h(s)/Ys  dN_i^C(s) - dLambda_i^C(s)
    btime <- 1*(exit<time)
    IhdLamhas <- apply(has*S0i2*btime,2,cumsumstrata,xx$strata,xx$nstrata)
    Uas <- matrix(0,nrow(xx$X),ncol(has))
    Uas[xx$jumps+1,] <- (resC$jumptimes<time)*has[xx$jumps+1,] /c(resC$S0)
    MGtas <- (Uas[,drop=FALSE]-IhdLamhas)*c(xx$weights)

    if (typeATE=="II") {
            h  <-  apply(Yc,2,revcumsumstrata,xx$strata,xx$nstrata)
	    IhdLam <- apply(h*S0i2*btime,2,cumsumstrata,xx$strata,xx$nstrata)
	    U <- matrix(0,nrow(xx$X),1)
	    U[xx$jumps+1,] <- (resC$jumptimes<time)*h[xx$jumps+1,]/c(resC$S0)
	    MGateII <- piaC*c(U[,drop=FALSE]-IhdLam)*c(xx$weights)
	    augmentationATE <- apply(MGateII,2,sum)

	    hapi  <-  apply(piaC,2,revcumsumstrata,xx$strata,xx$nstrata)
	    IhaidLam <- apply(hapi*c(h)*S0i*S0i2*btime,2,cumsumstrata,xx$strata,xx$nstrata)
	    Uai <- matrix(0,nrow(xx$X),ncol(hapi))
	    Uai[xx$jumps+1,] <- (resC$jumptimes<time)*c(h[xx$jumps+1,])*hapi[xx$jumps+1,]/c(resC$S0)^2
	    MGait <- (Uai[,drop=FALSE]-IhaidLam)*c(xx$weights)
	    MGtII <- MGateII - MGait
    }
    ### Censoring Variance Adjustment \int h^2(s) / y.(s) d Lam_c(s) estimated by \int h^2(s) / y.(s)^2  d N.^C(s) 
    mid <- max(xx$id)+1
    MGCiidas <- apply(MGtas,2,sumstrata,xx$id,mid)
    if (typeATE=="II") {
        MGtII <-  apply(MGtII,2,sumstrata,xx$id,mid)
        MGCiidas  <-  MGCiidas+MGtII
    } else MGtII <- 0
 
  }  else { MGCiid <- MGCiidas <- 0 }
## }}}

################################
### estimates risk, att, atc
################################
###val$riskDR <- apply(riska,2,mean)
val$riskDR <- apply(riska,2,mean)+augmentationATE/nid
val$riskG<-  apply(riskG,2,mean)
names(val$riskDR) <- paste("treat",nlevs,sep="")
names(val$riskG) <- paste("treat",nlevs,sep="")

################################
## iid's of marginal risk estimates 
################################

k <- 1
iidrisk <- c()
riskG.iid <- c()
for (a in nlevs) {
	iidbasea <- c(sumstrata(riska[,k]-val$riskDR[k],id,nid))
	iidcifa <- c(DePsia[[k]] %*% t(val$iid))
	iidpala <- c(DaPsia[[k]] %*% t(iidalpha))
	if (se)  iidGca <- MGCiidas[,k] else iidGca<-0 
        ###
	iidriskDR <- (iidbasea+iidcifa+iidpala+iidGca)/nid
        iidrisk <- cbind(iidrisk,iidriskDR)
	iidriskG <- c(sumstrata(riskG[,k]-val$riskG[k],id,nid))
	iidriskG <- c(iidriskG)/nid+c(DariskG[[k]] %*% t(val$iid))/nid
        riskG.iid <- cbind(riskG.iid,iidriskG)
	k <- k+1
}
# }}}

val$call.id <- call.id
val$name.id  <- name.id
val$id <- idclust
val$nid  <- nclust

# {{{ output variances and se for ate; cluster correction
val$iid <- apply(val$iid,2,sumstrata,idclust,nclust)
robvar <- crossprod(val$iid)
val$var <-  val$robvar <- robvar
val$se.robust <- diag(robvar)^.5
val$se.coef <- diag(val$var)^.5
val$MGciid <- NULL
val$iid.naive <- NULL

## outcome model from binreg
iidrisk <- apply(iidrisk,2,sumstrata,idclust,nclust)
val$var.riskDR <- crossprod(iidrisk); 
val$se.riskDR <- diag(val$var.riskDR)^.5
val$riskDR.iid <- iidrisk

pdiff <- function(x) lava::contr(lapply(seq(x-1), function(z) seq(z,x)))
contrast <- -pdiff(length(nlevs))
nncont <- c()
for (k in seq_along(nlevs[-length(nlevs)])) nncont <-c(nncont, paste("treat:",nlevs[-seq(k)],"-",nlevs[k],sep="")) 
rownames(contrast) <- nncont

mm <- estimate(coef=val$riskDR,vcov=val$var.riskDR,f=contrast)
val$difriskDR <- mm$coef 
names(val$difriskDR) <-  rownames(contrast) 
val$var.difriskDR <- mm$vcov 
val$se.difriskDR <- diag(val$var.difriskDR)^.5

riskG.iid <- apply(riskG.iid,2,sumstrata,idclust,nclust)
###
val$riskG.iid <- riskG.iid
val$var.riskG <- crossprod(val$riskG.iid)
val$se.riskG <- diag(val$var.riskG)^.5
###
mm <- estimate(coef=val$riskG,vcov=val$var.riskG,f=contrast)
val$difriskG <- mm$coef 
names(val$difriskG) <-  rownames(contrast) 
val$var.difriskG <- mm$vcov 
val$se.difriskG <- diag(val$var.difriskG)^.5

###### DR-estimator, G add names to iid 
if (!is.null(call.id)) {
    val$riskDR.iid <- nameme(iidrisk,name.id)
    val$riskG.iid  <- nameme(riskG.iid,name.id)
    val$iid        <- nameme(val$iid,name.id)
}
## }}}

  class(val) <- c("binreg","ATE")
  return(val)
}# }}}

##' @export
estimate.ATE  <- function(x,type=c("all","DR","G"),...)
{
if (type[1]=="all") {
iidGDR <- cbind(x$riskG.iid,x$riskDR.iid)
coefs <- c(x$riskG,x$riskDR)
names(coefs)  <- c(paste("G",names(x$riskG),sep="-"), paste("DR",names(x$riskG),sep="-"))
} else if (type[1]=="DR") {
iidGDR <- x$riskDR.iid
coefs <- x$riskDR
names(coefs)  <- paste("DR",names(x$riskG),sep="-")
} else {
iidGDR <- x$riskG.iid
coefs <- x$riskG
names(coefs)  <- paste("G",names(x$riskG),sep="-")
}
out <-estimate(coef=coefs,IC=iidGDR*nrow(iidGDR),...)
return(out)
}


##' G-Estimator for Binomial Regression Model (Standardized Estimates)
##'
##' Computes the G-estimator (G-formula) for standardized risk estimates based on a 
##' fitted \code{binreg} object. The G-estimator standardizes predictions over the 
##' covariate distribution in the data:
##' \deqn{ \hat F(t, A=a) = n^{-1} \sum_{i=1}^n \hat F(t, A=a, Z_i) }
##'
##' This function assumes that the first covariate in the original model formula 
##' represents the treatment or exposure variable (\eqn{A}). It calculates the 
##' marginal risk for specified values of \eqn{A} by averaging the conditional 
##' predictions over the observed covariate distribution \eqn{Z}.
##'
##' The function returns influence functions for these risk estimates, allowing 
##' for the computation of standard errors and confidence intervals.
##'
##' If the first covariate is a factor, contrasts between all levels are computed 
##' automatically. If it is continuous, specific values must be provided via 
##' \code{Avalues}.
##'
##' @section References:
##' \itemize{
##'   \item Blanche PF, Holt A, Scheike T (2022). "On logistic regression with right censored data, with or without competing risks, and its use for estimating treatment effects." \emph{Lifetime Data Analysis}, 29, 441–482.
##' }
##'
##' @param x An object of class \code{"binreg"} obtained from \code{binreg()} or \code{logitIPCW()}.
##' @param data A data frame containing the covariates to be used for averaging the risk 
##'   estimates. This should ideally be the same data used to fit the model, or a 
##'   representative sample.
##' @param Avalues Numeric or factor vector specifying the values of the first covariate 
##'   (\eqn{A}) for which to compute standardized risks. 
##'   \itemize{
##'     \item If the first covariate is a factor and \code{Avalues} is \code{NULL}, 
##'       all levels of the factor are used.
##'     \item If the first covariate is continuous, \code{Avalues} must be provided.
##'   }
##' @param varname Optional character string specifying the name of the variable to be 
##'   treated as the treatment/exposure variable. If \code{NULL}, the first variable 
##'   in the model formula is used.
##'
##' @return An object of class \code{"survivalG"} containing:
##' \item{risk}{A table of standardized risk estimates for each value of \code{Avalues}.}
##' \item{risk.iid}{Influence functions for the standardized risk estimates.}
##' \item{difference}{Pairwise differences in risks between levels of \code{A}.}
##' \item{ratio}{Risk ratios between levels of \code{A}.}
##' \item{vcov}{Variance-covariance matrix of the risk estimates.}
##' \item{model}{The link function used in the original model.}
##'
##' @author Thomas Scheike
##'
##' @seealso \code{\link{binreg}}, \code{\link{binregATE}}
##' @examples
##' data(bmt); bmt$time <- bmt$time+runif(408)*0.001
##' bmt$event <- (bmt$cause!=0)*1
##' 
##' b1 <- binreg(Event(time,cause)~age+tcell+platelet,bmt,cause=1,time=50)
##' sb1 <- binregG(b1,bmt,Avalues=c(0,1,2))
##' summary(sb1)
##' @export
binregG <- function(x,data,Avalues=NULL,varname=NULL)
{# {{{

### dealing with first variable 
if (is.null(varname))  {
   treat.name <- all.vars(update.formula(x$formula,1~.))[1]
} else treat.name <- varname
treatvar <- data[,treat.name]

if (is.factor(treatvar)) {
   ## treatvar, levels to look at 
   if (is.null(Avalues)) nlevels <- levels(treatvar) else nlevels <- Avalues
} else {
   nlevels <- Avalues
}
if (is.null(nlevels)) stop("must specify values")

desx <- update_design(x$design,data=data)
if (is.null(desx$cluster)) { ## data must be same as data used for x
   id <- x$id
} else {
  id <- desx$cluster-1
}
datA <- data

DariskG <- list()
risks <- c()
k <- 0
for (a in nlevels) {# {{{
k <- k+1
datA[,treat.name] <- a
pa <- predict.binreg(x,datA,se=0,design=TRUE)
Xa <- attr(pa,"x")
lpa <- Xa %*% x$coef
if (x$model[1]=="logit") {
###   pa <- expit(lpa)
   Dma  <-  Xa*c(pa/(1+exp(lpa)))
} else if (x$model[1]=="exp") {
###   pa <- exp(lpa)
   Dma  <-  Xa*c(pa) 
} else {
###   pa <- lpa
   Dma  <-  Xa
}
risks <- cbind(risks,pa)
DariskG[[k]] <- apply(Dma,2,sum)
}# }}}

Grisk <- apply(risks,2,mean)
Gest <- list(Gest=Grisk,iid=t(t(risks)-Grisk))

nid <- max(x$id)+1
n <-  ndata <- length(unique(id))
risk.iid <- apply(Gest$iid,2,sumstrata,x$id,nid)/n 
DGiid <- risk.iid

for (a in seq_along(nlevels)) {
	DGiid[,1] <- c(x$iid  %*% DariskG[[a]])/n
	risk.iid[,a] <- risk.iid[,a]+ c(x$iid  %*% DariskG[[a]])/n
}
vv <- crossprod(risk.iid)

Gout <- estimate(coef=Gest$Gest,vcov=vv,labels=paste("risk",nlevels,sep=""))
ed <-  summary(estimate(coef=Gest$Gest,vcov=vv),f=function(p) p[-1]-p[1])
rd <- summary(estimate(coef=Gest$Gest,vcov=vv),f=function(p) log(p[-1]/p[1]),null=0)
out <- list(risk.iid=risk.iid,risk=Gout,difference=ed,ratio=rd,vcov=vv,model=x$model[1])
class(out) <- "survivalG"
return(out)
} ## }}}

##' @export
logitIPCWATE <- function(formula,data,cause=1,time=NULL,beta=NULL,treat.model=~+1, cens.model=~+1,
	   offset=NULL,weights=NULL,cens.weights=NULL,se=TRUE,
	   kaplan.meier=TRUE,cens.code=0,no.opt=FALSE,method="nr",augmentation=NULL,
           outcome=c("cif","rmst","rmtl"),model=c("default","logit","exp","lin"),Ydirect=NULL,...)
{# {{{
  cl <- match.call()# {{{
    m <- match.call(expand.dots = TRUE)[1:3]
    des <- proc_design(
        formula,
        data = data,
        specials = c("offset", "weights", "cluster"),
        intercept = TRUE
    )
    Y <- des$y
    if (!inherits(Y, c("Event", "Surv"))) {
        stop("Expected a 'Surv' or 'Event'-object")
    }
    if (ncol(Y) == 2) {
        exit <- Y[, 1]
        entry <- rep(0, nrow(Y))
        status <- Y[, 2]
    } else {
        entry <- Y[, 1]
        exit <- Y[, 2]
        status <- Y[, 3]
    }
    X <- des$x
    des.weights <- des$weights
    des.offset  <- des$offset
    id      <- des$cluster


 call.id <- id;
 conid <- construct_id(id,nrow(X),namesX=rownames(X))
 name.id <- conid$name.id; id <- conid$id; nid <- conid$nid
 idclust <- id; nclust <- nid

 ## make all computations for each subject, later sum influence functions and sort after idclust 
 nid <- length(id); id <- 0:(nid-1); 

  ## take offset and weight first from formula, but then from arguments
  if (is.null(des.offset)) {
	  if (is.null(offset)) offset <- rep(0,length(exit)) 
  } else offset <- des.offset
  if (is.null(des.weights)) {
	  if (is.null(weights)) weights <- rep(1,length(exit)) 
  } else weights <- des.weights

###  if (is.null(offset)) offset <- rep(0,length(exit)) 
###  if (is.null(weights)) weights <- rep(1,length(exit)) 
# }}}

  if (is.null(time)) stop("Must give time for logistic modelling \n"); 
  statusC <- (status %in% cens.code) 
  statusE <- (status %in% cause) & (exit<= time) 
  if (sum(statusE)==0) stop("No events of type 1 before time \n"); 
  kmt <- kaplan.meier
  ucauses  <-  sort(unique(status))
  ccc <- which(ucauses %in% cens.code)
  if (length(ccc)==0) Causes <- ucauses else Causes <- ucauses[-ccc]
  competing  <-  (length(Causes)>1) 

  statusC <- (status %in% cens.code) 
  data$id__ <- id
  data$exit <- exit
  data$statusC <- statusC 
  n <- length(exit)

  cens.strata <- cens.nstrata <- NULL 

  if (is.null(cens.weights))  {
      formC <- update.formula(cens.model,Surv(exit,statusC)~ . +cluster(id__))
      resC <- phreg(formC,data)
      if (resC$p>0) kmt <- FALSE
      exittime <- pmin(exit,time)
###      cens.weights <- predict(resC,data,times=exittime,individual.time=TRUE,se=FALSE,km=kmt)$surv
      cens.weights <- suppressWarnings(predict(resC,data,times=exittime,individual.time=TRUE,se=FALSE,km=kmt,tminus=TRUE)$surv)
      ## strata from original data 
      cens.strata <- resC$strata[order(resC$ord)]
      cens.nstrata <- resC$nstrata
  } else formC <- NULL

  if (is.null(beta)) beta <- rep(0,ncol(X))
  p <- ncol(X)

  X <-  as.matrix(X)
  X2  <- .Call("vecMatMat",X,X)$vXZ
  obs <- (exit<=time & status!=cens.code) | (exit>=time)
  weights <- obs*weights/c(cens.weights)
  cens.weights <- c(cens.weights)

  Y <- c((status==cause)*(exit<=time))

  if (!is.null(Ydirect)) Y <-  Ydirect else {
     if (outcome[1]=="cif") Y <- c((status %in% cause)*(exit<=time))
     else { if (!competing) {
	     if (outcome[1]=="rmst") Y <-  c(pmin(exit,time))
	     else Y <-  c((time-pmin(exit,time)))
            } else Y <- c((status %in% cause)*(time-pmin(exit,time)))
     }
  }
 Yout <- Y
 if (is.null(augmentation))  augmentation=rep(0,p)
 nevent <- sum(Y)

 ## default links
if (model[1]=="default") {
	 if (outcome[1]=="cif") model <- "logit"
	 if (outcome[1]=="rmst") model <- "exp"
	 if (outcome[1]=="rmtl") model <- "exp"
 }

obj <- function(pp,all=FALSE)
{ # {{{

lp <- c(X %*% pp+offset)
if (model[1]=="exp") {
    p <- exp(lp) 
    D2logl <- c(weights*p)*X2 
} else if (model[1]=="lin") {
    p <- lp
    D2logl <- c(weights)*X2
} else if (model[1]=="logit") {
   p <- expit(lp)
   D2logl <- c(weights*p/(1+exp(lp)))*X2
} 

ploglik <- sum(weights*(Y-p)^2)
Dlogl <- weights*X*c(Y-p)
D2log <- apply(D2logl,2,sum)
gradient <- apply(Dlogl,2,sum)+augmentation
hessian <- matrix(D2log,length(pp),length(pp))

  if (all) {
      ihess <- pinv(hessian)
      beta.iid <- Dlogl %*% ihess ## %*% t(Dlogl) 
      beta.iid <-  apply(beta.iid,2,sumstrata,id,max(id)+1)
      robvar <- crossprod(beta.iid)
      val <- list(par=pp,ploglik=ploglik,gradient=gradient,hessian=hessian,ihessian=ihess,
	 id=id,Dlogl=Dlogl,
	 iid=beta.iid,robvar=robvar,var=robvar,se.robust=diag(robvar)^.5)
      return(val)
  }  
 structure(-ploglik,gradient=-gradient,hessian=hessian)
}# }}}

  p <- ncol(X)
  opt <- NULL
  if (p>0) {
  if (no.opt==FALSE) {
      if (tolower(method)=="nr") {
	  tim <- system.time(opt <- lava::NR(beta,obj,...))
	  opt$timing <- tim
	  opt$estimate <- opt$par
      } else {
	  opt <- nlm(obj,beta,...)
	  opt$method <- "nlm"
      }
      cc <- opt$estimate; 
      val <- c(list(coef=cc),obj(opt$estimate,all=TRUE))
      } else val <- c(list(coef=beta),obj(beta,all=TRUE))
  } else {
      val <- obj(0,all=TRUE)
  }

  if (length(val$coef)==length(colnames(X))) names(val$coef) <- colnames(X)
  val <- c(val,list(time=time,formula=formula,formC=formC,
    exit=exit, cens.weights=cens.weights, cens.strata=cens.strata, cens.nstrata=cens.nstrata, 
    n=length(exit),nevent=nevent,ncluster=nid,weights=weights))
  
# {{{ computation of ate, att, atc and their influence functions
if (length(all.vars(treat.model))==0) 
{ respformula  <-  as.formula( paste(all.vars(formula)[3],"~."))
  treat.model  <- update.formula(treat.model,respformula)
###  cat("Using propensity score model :\n "); print(treat.model)
}

## dropping cluster here 
treat.model <- drop.specials(treat.model,"cluster")
treat <- glm(treat.model,data,family="binomial")
Xtreat <- model.matrix(treat$formula,data)
ytreat <- treat$y

lpa <- treat$linear.predictors 
pal <- expit(lpa)
iidalpha <- iid(treat,id=id)

### treatment is rhs of treat.model 
treat.name <-  all.vars(treat.model)[1]
dat0 <- data
dat0[,treat.name] <- 0 ## treat.contrast[1]
dat1 <- data
dat1[,treat.name] <- 1 ## treat.contrast[2]

formulanc <- drop.specials(formula,"cluster")

X1 <- model.matrix(formulanc[-2],dat1)
X0 <- model.matrix(formulanc[-2],dat0)

p11lp <- X1 %*% val$coef+offset
p10lp <- X0 %*% val$coef+offset
p1lp <-   X %*% val$coef+offset

if (model[1]=="exp") {
   p1 <- exp(p1lp); p10 <- exp(p10lp); p11 <- exp(p11lp);
} else if (model[1]=="lin") {
   p1 <- p1lp; p10 <- p10lp; p11 <- p11lp; 
} else if (model[1]=="logit") {
    p1 <- expit(p1lp); p10 <- expit(p10lp); p11 <- expit(p11lp);
} else stop("link functions must be logit,exp,lin\n") 

Yorig <- Y
Y <- c(Y*obs/cens.weights)
risk1 <- ytreat*(Y-p11)/pal+p11
risk0 <- (1-ytreat)*(Y-p10)/(1-pal)+p10
riskG1 <- p11
riskG0 <- p10

ntreat <- sum(ytreat)
###att <- ytreat*Y-(pal*(1-ytreat)*Y + (ytreat - pal)* p10)/(1-pal)
###atc <- ((1-pal)*ytreat*Y - ((ytreat - pal)* p11)/pal)-(1-ytreat)*Y

if (model[1]=="logit") {
	Dp1 <- X * c(p1/(1+exp(p1lp)))
	Dp11 <- X1 * c(p11/(1+exp(p11lp)))
	Dp10 <- X0 * c(p10/(1+exp(p10lp)))
} else if (model[1]=="lin") {
      Dp1 <- X; Dp11 <- X1; Dp10 <- X0;
} else {
      Dp1 <- c(p1)*X; Dp11 <- c(p11)*X1; Dp10 <- c(p10)*X0;
}

Dpai <-  - Xtreat * exp(-lpa)
D1mpai <-   Xtreat * exp(lpa)

DaPsi1 <-  apply( Dpai * ytreat * c( Y - p1),2,sum)
DaPsi0 <-  apply( D1mpai * (1-ytreat) * c( Y - p1),2,sum)
DePsi1 <-  apply( Dp11 * ( 1- ytreat/pal),2,sum)
DePsi0 <-  apply( Dp10 * ( 1- (1-ytreat)/(1-pal)),2,sum)

###DePsiatt <- - apply( Dp10* (ytreat-pal)/(1-pal),2,sum)
###DaPsiatt <- apply(c((1-ytreat)*(Y-p10))*D1mpai,2,sum)
###
###DePsiatc <- -apply( Dp11* (ytreat-pal)/pal,2,sum)
###DaPsiatc <- apply(c(ytreat*(Y-p11))*Dpai,2,sum)

DriskG1 <- apply(Dp11,2,sum)
DriskG0 <- apply(Dp10,2,sum)
DdifriskG <- DriskG1-DriskG0

 if (se) {## {{{ censoring adjustment of variance 
    ### order of sorted times
    ord <- resC$ord
    X <-  X[ord,,drop=FALSE]
    Xtreat <- Xtreat[ord,,drop=FALSE]
    ytreat <- ytreat[ord]
    pal <-   pal[ord]
    status <- status[ord]
    exit <- exit[ord]
    weights <- weights[ord]
    offset <- offset[ord]
    cens.weights <- cens.weights[ord]
    lp <- c(X %*% val$coef+offset)
    if (model[1]=="exp") { p <- exp(lp) } else if (model[1]=="lin") { p <- lp } else if (model[1]=="logit") {p <- expit(lp) } 
    Yglm <- weights*(Yout[ord]-p)
    Y <- Yout[ord]

    xx <- resC$cox.prep
    S0i2 <- S0i <- rep(0,length(xx$strata))
    S0i[xx$jumps+1]  <- 1/resC$S0
    S0i2[xx$jumps+1] <- 1/resC$S0^2
    ## compute function h(s) = \sum_i X_i Y_i(t) I(s \leq T_i \leq t) 
    ## to make \int h(s)/Ys  dM_i^C(s) 
    h  <-  apply(X*Yglm,2,revcumsumstrata,xx$strata,xx$nstrata)
    h10  <-  apply(cbind((ytreat/pal)*Y,I(ytreat==0)/(1-pal))*Y,2,revcumsumstrata,xx$strata,xx$nstrata)
###  hattc  <-  apply(cbind(ytreat-pal*(1-ytreat)/(1-pal),-(1-ytreat)+(1-pal)*ytreat/pal)*Y,2,revcumsumstrata,xx$strata,xx$nstrata)
    ### Cens-Martingale as a function of time and for all subjects to handle strata 
    ## to make \int h(s)/Ys  dM_i^C(s)  = \int h(s)/Ys  dN_i^C(s) - dLambda_i^C(s)
    IhdLam0 <- apply((exit<=time)*h*S0i2,2,cumsumstrata,xx$strata,xx$nstrata)
    U <- matrix(0,nrow(xx$X),ncol(X))
    U[xx$jumps+1,] <- (resC$jumptimes<=time)*h[xx$jumps+1,] /c(resC$S0)
    MGt <- (U[,drop=FALSE]-IhdLam0)*c(xx$weights)

    IhdLamh10 <- apply(h10*S0i2,2,cumsumstrata,xx$strata,xx$nstrata)
    U10 <- matrix(0,nrow(xx$X),2)
    U10[xx$jumps+1,] <- h10[xx$jumps+1,] /c(resC$S0)
    MGt10 <- (U10[,drop=FALSE]-IhdLamh10)*c(xx$weights)

###    IhdLamhattc <- apply(hattc*S0i2,2,cumsumstrata,xx$strata,xx$nstrata)
###    Uattc <- matrix(0,nrow(xx$X),2)
###    Uattc[xx$jumps+1,] <- hattc[xx$jumps+1,]/c(resC$S0)
###    MGtattc <- (Uattc[,drop=FALSE]-IhdLamhattc)*c(xx$weights)

    ### Censoring Variance Adjustment  \int h^2(s) / y.(s) d Lam_c(s) estimated by \int h^2(s) / y.(s)^2  d N.^C(s) 
    mid <- max(id)+1
    MGCiid <- apply(MGt,2,sumstrata,xx$id,mid)
    MGCiid10 <- apply(MGt10,2,sumstrata,xx$id,mid)
###    MGCiidattc <- apply(MGtattc,2,sumstrata,xx$id,mid)
  }  else { MGCiidattc <- MGCiid <- 0; MGCiid10 <- 0 }
## }}}

val$MGciid <- MGCiid
val$MGciid10 <- MGCiid10
val$id <- id
val$call.id <- call.id
val$name.id <- name.id
val$nid <- nid
val$iid.naive <- val$iid 
if (se) val$iid  <- val$iid+(MGCiid %*% val$ihessian)
val$naive.var <- val$var
robvar <- crossprod(val$iid)
val$var <-  val$robvar <- robvar
val$se.robust <- diag(robvar)^.5
val$se.coef <- diag(val$var)^.5
val$cause <- cause
val$cens.code <- cens.code 

### estimates risk, att, atc
val$riskDR <- c(mean(risk1),mean(risk0))
val$riskG<- c(mean(riskG1),mean(riskG0))

###val$att <- sum(att)/ntreat
###val$atc <- sum(atc)/(n-ntreat)
###val$attc <- c(val$att,val$atc)
###names(val$attc) <- c("ATT","ATC")

names(val$riskDR) <- paste("treat",1:0,sep="-")
names(val$riskG) <- paste("treat",1:0,sep="-")

## iid's of marginal risk estimates 
iidbase1 <- c(risk1-val$riskDR[1])
iidcif1 <- c(c(DePsi1) %*% t(val$iid))
iidpal1 <- c(c(DaPsi1) %*% t(iidalpha))
if (se)  {
iidGc1 <- MGCiid10[,1]; iidGc0 <- MGCiid10[,2]
###iidGatt <-  MGCiidattc[,1]; iidGatc <-  MGCiidattc[,2]
}  else { iidGc1 <- iidGatt  <- iidGatc  <- iidGc0  <- 0 } 

iidbase0 <- c(risk0-val$riskDR[2])
iidcif0 <- c(c(DePsi0) %*% t(val$iid))
iidpal0 <- c(c(DaPsi0) %*% t(iidalpha))

iidrisk1 <- iidbase1+iidcif1+iidpal1+iidGc1
iidrisk0 <- iidbase0+iidcif0+iidpal0+iidGc0
difriskiid <- (iidrisk1-iidrisk0)/n

iidrisk <- cbind(iidrisk1,iidrisk0)/n

###iidatt <- att-ytreat*val$att
###iidatc <- atc-(1-ytreat)*val$atc
###iidcifatt <- c(c(DePsiatt) %*% t(val$iid))
###iidpalatt <- c(c(DaPsiatt) %*% t(iidalpha))  
###iidcifatc <- c(c(DePsiatc) %*% t(val$iid))
###iidpalatc <- c(c(DaPsiatc) %*% t(iidalpha)) 
###iidatt <- iidatt+iidcifatt+iidpalatt+iidGatt
###iidatc <- iidatc+iidcifatc+iidpalatc+iidGatc

# }}}


val$call.id <- call.id
val$name.id  <- name.id

# {{{ output variances and se for ate; cluster correction
val$id <- idclust
val$nid  <- nclust

## make iid form before combining into clusters 
riskG.iid <- cbind(c(p11-val$riskG[1]) + c(DriskG1 %*% t(val$iid)),
	          c(p10-val$riskG[2]) + c(DriskG0 %*% t(val$iid)))/n

## outcome model from IPCW logistic regression 
val$iid <- apply(val$iid,2,sumstrata,idclust,nclust)
robvar <- crossprod(val$iid)
val$var <-  val$robvar <- robvar
val$se.robust <- diag(robvar)^.5
val$se.coef <- diag(val$var)^.5
val$MGciid <- NULL
val$iid.naive <- NULL

## DR estimates 
iidrisk <- apply(iidrisk,2,sumstrata,idclust,nclust)
val$var.riskDR <- crossprod(iidrisk); 
val$se.riskDR <- diag(val$var.riskDR)^.5
val$riskDR.iid <- iidrisk

###nlevs <- 2
###pdiff <- function(x) lava::contr(lapply(seq(x-1), function(z) seq(z,x)))
###contrast <- -pdiff(length(nlevs))
###nncont <- c()
###for (k in seq_along(nlevs[-length(nlevs)])) nncont <-c(nncont, paste("treat:",nlevs[-seq(k)],"-",nlevs[k],sep="")) 
###rownames(contrast) <- nncont
contrast <- rbind(c(1,-1))

mm <- estimate(coef=val$riskDR,vcov=val$var.riskDR,f=rbind(c(1,-1)))
val$difriskDR <- mm$coef 
names(val$difriskDR) <-  rownames(contrast) 
val$var.difriskDR <- mm$vcov 
val$se.difriskDR <- diag(val$var.difriskDR)^.5

riskG.iid <- apply(riskG.iid,2,sumstrata,idclust,nclust)
###
val$riskG.iid <- riskG.iid
val$var.riskG <- crossprod(riskG.iid)
val$se.riskG <- diag(val$var.riskG)^.5
###
mm <- estimate(coef=val$riskG,vcov=val$var.riskG,f=contrast)
val$difriskG <- mm$coef 
names(val$difriskG) <-  rownames(contrast) 
val$var.difriskG <- mm$vcov 
val$se.difriskG <- diag(val$var.difriskG)^.5

### DR-estimator ; G -estimator sort after namid; also outcome model
if (!is.null(call.id)) {
    val$riskDR.iid <- nameme(iidrisk,name.id)
    val$riskG.iid  <- nameme(riskG.iid,name.id)
    val$iid <-       nameme(val$iid,name.id)
}
## }}}

  val$model <- model[1]
  val$outcome <- outcome[1]
  val$call.id <- call.id
  class(val) <- c("binreg","ATE")
  return(val)
}# }}}

##' @export
logitATE <- function(formula,data,binreg=TRUE,...)
{# {{{
   ## use IPCW machine in no-censoring case
    cl <- match.call()
    m <- match.call(expand.dots = TRUE)[1:3]
    special <- c("strata", "cluster", "offset")
    Terms <- terms(formula, special, data = data)
    m$formula <- Terms
    m[[1]] <- as.name("model.frame")
    m <- eval(m, parent.frame())
    Y <- model.extract(m, "response")
    if (inherits(Y,"Event")) {
    if (binreg) out <- binregATE(formula,data,...) else out <- logitIPCWATE(formula,data,...)
    } else {
      response <- all.vars(formula)[1]
      Ydirect <-  as.numeric(data[,response]) 
      data$time <- 2
      data$event <- 1
      time <- 2
      Survform <-  update.formula(formula,Event(time,event)~.)
      n <- nrow(data)
      if (binreg)
      out <- binregATE(Survform,data,se=0,cens.weights=rep(1,n),time=time,Ydirect=Ydirect,...)
      else
      out <- logitIPCWATE(Survform,data,se=0,cens.weights=rep(1,n),time=time,Ydirect=Ydirect,...)
    }

   return(out)
}# }}}

##' @export
normalATE <- function(formula,data,binreg=TRUE,model="lin",...)
{# {{{
   if (binreg) 
   out <- logitATE(formula,data,binreg=binreg,model=model,outcome="rmst",...)
   else 
   out <- logitATE(formula,data,binreg=binreg,...)
   return(out)
}# }}}


