nameme <- function(iid,name.id,sort=TRUE) { ## {{{
if (is.matrix(iid))
	if (nrow(iid)==length(name.id)) {
		rownames(iid) <- name.id
###		if (sort)  {
###		oid <- order(name.id);
###		iid <- iid[oid,,drop=FALSE];
###		}
}
return(iid)
} ## }}}

construct_id <- function(id,nid,namesX=NULL,as.data=FALSE) { ## {{{
  call.id <- id

  if (!is.null(id)) {
	  ids <- unique(id)
	  nid <- length(ids)
      if (is.numeric(id)) id <-  fast.approx(ids,id)-1 else  {
      id <- as.integer(factor(id,labels=seq(nid)))-1
     }
     name.id <- sort(ids)
   } else {
	   id <- 1:nid-1;
	   ids <- id+1
	   order.ids <- ids
	   name.id <- NULL
	   ## Use rownames of design matrix as labels when id was not provided
           name.id <- if (!is.null(namesX)) namesX else NULL 
   }
   ## orginal id coding into integers
   ## id from 0,1,...,nid-1

    if (as.data) {
        id  <- (0:(nid - 1))[order(ids)][id +1]
        name.id <- ids
    }

  return(list(call.id=call.id,id=id,nid=nid,unique.id=ids,name.id=name.id))
} ## }}}

###{{{ phreg01
phreg01 <- function(X,entry,exit,status,id=NULL,strata=NULL, offset=NULL,weights=NULL,strata.name=NULL,cumhaz=TRUE,
    beta,stderr=TRUE,method="NR", no.opt=FALSE,Z=NULL,propodds=NULL,AddGam=NULL,
    marks=NULL,no.var=0,augmentation=0,...) {
  p <- ncol(X)
  if (missing(beta)) beta <- rep(0,p)
  if (p==0) X <- cbind(rep(0,length(exit)))

  if (is.null(strata)) {
	  strata <- rep(0,length(exit)); nstrata <- 1; strata.level <- NULL;
  } else {
	  strata.level <- levels(strata)
	  ustrata <- sort(unique(strata))
	  nstrata <- length(ustrata)
	  strata.values <- ustrata
      if (is.numeric(strata)) strata <-  fast.approx(ustrata,strata)-1 else  {
      strata <- as.integer(factor(strata,labels=seq(nstrata)))-1
    }
  }
  strata.call <- strata
  Zcall <- matrix(1,1,1) ## to not use for ZX products when Z is not given
  if (!is.null(Z)) Zcall <- Z

  ## possible casewights to use for bootstrapping and other things
  if (is.null(marks)) marks <- rep(1,length(exit))
  trunc <- (any(entry>0))
###  if (!trunc) entry <- rep(0,length(exit))

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

  dd <- .Call("FastCoxPrepStrata", entry,exit,status,X,id,trunc,strata,weights,offset,Zcall,marks,PACKAGE="mets")

  dd$nstrata <- nstrata
   obj <- function(pp,U=FALSE,all=FALSE) {# {{{
      if (length(dd$jumps) >0) {
	      if (is.null(propodds) & is.null(AddGam)) {
		val <- with(dd, .Call("FastCoxPLstrata",pp,X,XX,sign,jumps, strata,nstrata,weights,offset,ZX,caseweights,PACKAGE="mets"))
	      } else if (is.null(AddGam))
		val <- with(dd, .Call("FastCoxPLstrataPO",pp,X,XX,sign,jumps, strata,nstrata,weights,offset,ZX,propodds,PACKAGE="mets"))
	      else val <- with(dd, .Call("FastCoxPLstrataAddGam",pp,X,XX,sign,jumps, strata,nstrata,weights,offset,ZX,
					 AddGam$theta,AddGam$dimthetades,AddGam$thetades,AddGam$ags,AddGam$varlink,AddGam$dimjumprv,AddGam$jumprv,
					 AddGam$JumpsCauses,PACKAGE="mets"))
	      val$gradient <- val$gradient+augmentation
      } else {
	      val <- list(jumps=NULL,ploglik=NULL,U=NULL,gradient=NULL,hessian=NULL,hessiantime=NULL,S2S0=NULL,E=NULL,S0=NULL)
      }

	  if (all) {
	      val$time <- dd$time
	      ### plus 1 for R index
	      val$ord <- dd$ord+1
	      val$jumps <- dd$jumps+1
	      val$jumptimes <- val$time[val$jumps]
	      val$weightsJ <- dd$weights[val$jumps]
	      val$marks <- dd$marks[val$jumps]
	      val$nevent <- length(val$S0)
	      val$nstrata <- dd$nstrata
	      val$strata <- dd$strata
	      val$strata.jumps <- val$strata[val$jumps]
	      return(val)
	  }
          n <- length(dd$time)
	 with(val,structure(-ploglik/n,gradient=-gradient/n,hessian=-hessian/n))
	}# }}}

  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;  names(cc) <- colnames(X)
      if (!stderr) 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)
  }

  se.cumhaz <- lcumhaz <- lse.cumhaz <- NULL
  II <- NULL
  if (no.opt==FALSE & p!=0) {
         II <- - tryCatch(pinv(val$hessian),error=function(e) matrix(0,nrow(val$hessian),ncol(val$hessian)) )
  } else II <- matrix(0,p,p)

  ## Brewslow estimator, to handle also possible weights, caseweights that are 0
  ww <- val$caseweightsJ * val$weightsJ
  val$S0[abs(ww)<.00000001] <- 0

  ### computes Breslow estimator
  if (cumhaz==TRUE & (length(val$jumps)>0)) { # {{{
	 strata <- val$strata[val$jumps]
	 nstrata <- val$nstrata
	 jumptimes <- val$jumptimes

	 ## Brewslow estimator, to handle also possible weights/case-weights, and caseweights that are 0
	 S0i2 <- S0i <- rep(0,length(val$S0))
         wwJ <- val$caseweightsJ*val$weightsJ
	 S0i[val$S0>0] <- 1/val$S0[val$S0>0]
	 S0i2[val$S0>0] <- 1/(val$S0[val$S0>0]^2*wwJ[val$S0>0])
	 cumhaz <- cbind(jumptimes,cumsumstrata(S0i,strata,nstrata))
	 if ((no.opt==FALSE & p!=0)) {
	     DLambeta.t <- apply(val$E*S0i,2,cumsumstrata,strata,nstrata)
	     varbetat <-   rowSums((DLambeta.t %*% II)*DLambeta.t)
	 ### covv <-  apply(covv*DLambeta.t,1,sum) Covariance is "0" by construction
	 } else varbetat <- 0
	 var.cumhaz <- cumsumstrata(S0i2,strata,nstrata)+varbetat
	 se.cumhaz <- cbind(jumptimes,(var.cumhaz)^.5)

	 colnames(cumhaz)    <- c("time","cumhaz")
	 colnames(se.cumhaz) <- c("time","se.cumhaz")
 } # }}}
 else {cumhaz <- se.cumhaz <- lcumhaz <- lse.cumhaz <- NULL}

  res <- c(val,
           list(cox.prep=dd,
                strata.call=strata.call, strata.level=strata.level,
                entry=entry, exit=exit, status=status, X=X,
                p=p, offsets=offset, weights=weights,
                id=id,call.id=call.id,nid=nid,name.id=name.id,
                opt=opt, no.opt=no.opt, cumhaz=cumhaz, se.cumhaz=se.cumhaz,
                lcumhaz=lcumhaz, lse.cumhaz=lse.cumhaz, ihessian=II,
                II=II,strata.name=strata.name,propodds=propodds))
  class(res) <- "phreg"

  ## also computing robust variance
  if (p>0 & no.var==0) {
  beta.iid <- iid(res)
  phvar <- crossprod(beta.iid)
###  estimate.beta <- estimate(coef=val$coef,IC=nrow(beta.iid)*beta.iid,id=name.id)
###  res$estimate.beta <- estimate.beta
  colnames(phvar) <- rownames(phvar) <- names(res$coef)
  res$var <- phvar
  res$beta.iid <- beta.iid
  } else res$var <- NULL

  return(res)
}

###}}} phreg0

###{{{ phreg

##' Fast Cox Proportional Hazards Regression
##'
##' Fits a Cox proportional hazards model using a fast C++ backend.
##' Robust variance (sandwich estimator) is the default variance estimate in the summary.
##'
##' The influence functions (IID decomposition) follow the numerical order of the given cluster variable.
##' Ordering the results by `$id` will align the IID terms with the original dataset order.
##'
##' @param formula Formula with a 'Surv' or 'Event' outcome (similar to \code{coxph}).
##' @param data Data frame containing the variables.
##' @param offset Offsets for the Cox model linear predictor.
##' @param weights Weights for the Cox score equations.
##' @param ... Additional arguments passed to lower-level functions (e.g., optimization controls).
##'
##' @return An object of class \code{"phreg"} containing:
##' \item{coef}{Vector of estimated coefficients.}
##' \item{var}{Robust variance-covariance matrix.}
##' \item{beta.iid}{Influence functions for the regression coefficients.}
##' \item{cumhaz}{Matrix of cumulative hazard estimates (time, cumhaz).}
##' \item{se.cumhaz}{Matrix of standard errors for the cumulative hazard.}
##' \item{cox.prep}{List containing preprocessed data for the Cox model.}
##' \item{opt}{Optimization results (if optimization was performed).}
##' \item{call}{The matched call.}
##'
##' @author Klaus K. Holst, Thomas Scheike
##' @seealso \code{\link{plot.phreg}}, \code{\link{predict.phreg}}, \code{\link{robust_phreg}}
##' @aliases phreg robust_phreg
##' @examples
##' data(TRACE)
##' dcut(TRACE) <- ~.
##' # Fit model with clustering
##' out1 <- phreg(Surv(time, status == 9) ~ wmi + age + strata(vf, chf) + cluster(id), data = TRACE)
##' summary(out1)
##'
##' # Plotting baselines
##' par(mfrow = c(1, 2))
##' plot(out1)
##'
##' # Computing robust variance for baseline
##' rob1 <- robust_phreg(out1)
##' plot(rob1, se = TRUE, robust = TRUE)
##'
##' # IID decomposition for regression parameters
##' head(iid(out1))
##'
##' # IID decomposition for baseline at a specific time-point
##' Aiiid <- iid(out1, time = 30)
##' head(Aiiid)
##'
##' # Combined IID decomposition (beta and baseline)
##' dd <- iidBaseline(out1, time = 30)
##' head(dd$beta.iid)
##' head(dd$base.iid)
##'
##' # Stratified model
##' outs <- phreg(Surv(time, status == 9) ~ strata(vf, wmicat.4) + cluster(id), data = TRACE)
##' summary(outs)
##' par(mfrow = c(1, 2))
##' plot(outs)
##' @export
phreg <- function(formula,data,offset=NULL,weights=NULL,...) {# {{{
  cl <- match.call() ## {{{
    m <- match.call(expand.dots = TRUE)[1:3]
    des <- proc_design(
        formula,
        data = data,
        specials = c("offset", "weights", "cluster","strata","marks"),
        intercept = FALSE
    )
    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
    strata <- des$strata
    marks <- des$marks
    if (!is.null(strata))  {
      strata.name <- attr(des$specials.var$strata, "name.mf")
    } else strata.name <- NULL
    pos.strata <- NULL
    des.weights <- des$weights
    des.offset  <- des$offset
    id      <- des$cluster
    ## no use of
    pos.cluster <- NULL

 ## 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
 ## }}}

 res <- c(
     phreg01(X, entry, exit, status,
         id = id, strata = strata, offset = offset,
         weights = weights, strata.name = strata.name, marks = marks, ...
     ),
     list(
         call = cl, formula = formula, strata.pos = pos.strata,
         cluster.pos = pos.cluster, n = length(exit)
     )
 )
  res$model.frame <- proc_design(des$terms, data)$data #, specials="cluster")$data
  des$data <- data[0,]
  res$design <- des
  class(res) <- "phreg"

  res
}# }}}

readPhreg <- function (object, newdata, nr=TRUE,data=TRUE, ...)
{# {{{
   respindata <- length((grep(all.vars(object$formula)[1],names(newdata))))
   if (respindata>0) des <- update_design(object$design,data = newdata,response=TRUE)
   else des <- update_design(object$design,data = newdata)

   clusters <- des$cluster
   X <- des$x
   if (data) {
       xxr <- drop.specials(object$formula,"cluster")
       vars <- all.vars( update.formula(xxr,1~.))
       data <- newdata[,vars,drop=FALSE]
   } else data <- NULL

   if (!is.null(des$strata)) strataNew <- as.numeric(des$strata)-1 else strataNew <- rep(0,nrow(X))

    if (!is.null(des$y)) {
	    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]
	    }
    } else {status <- exit <- entry <- NULL; }

return(list(data=data,X=X,strata=strataNew,entry=entry,exit=exit,status=status,clusters=clusters))
}# }}}


### }}} phreg

### {{{ iid & Robust variances

transformation_phreg <- function(type, lp = TRUE) {
  # p[1]: linear predictor
  # p[2..]: baseline cumulative hazard in different strata
  if (type == "risk") {
    f <- ifelse(lp,
      function(p) {
        res <- numeric(length(p) - 1)
        for (i in seq(2, length(p))) {
          res[i - 1] <- 1 - exp(-p[i])**exp(p[1])
        }
        if (length(res) == 1L) {
          names(res) <- type
        } else {
          names(res) <- names(p)[-1]
        }
        return(res)
      },
      function(p) {
        res <- 1 - exp(-p)
        if (length(res) == 1L) {
          names(res) <- type
        } else {
          names(res) <- names(p)
        }
        return(res)
      }
    )
    return(f)
  }
  if (type == "surv") {
    f <- ifelse(lp,
      function(p) {
        res <- numeric(length(p) - 1)
        for (i in seq(2, length(p))) {
          res[i - 1] <- exp(-p[i])**exp(p[1])
        }
        if (length(res) == 1L) {
          names(res) <- type
        } else {
          names(res) <- names(p)[-1]
        }
        return(res)
      },
      function(p) {
        res <- exp(-p)
        if (length(res) == 1L) {
          names(res) <- type
        } else {
          names(res) <- names(p)
        }
        return(res)
      }
    )
    return(f)
  }
  ## type == "chaz"
  f <- ifelse(lp,
    function(p) {
      res <- numeric(length(p) - 1)
      for (i in seq(2, length(p))) {
        res[i - 1] <- p[i]*exp(p[1])
      }
      if (length(res) == 1L) {
        names(res) <- type
      } else {
        names(res) <- names(p)[-1]
      }
      return(res)
    },
    function(p) {
      if (length(p) == 1L) {
        names(p) <- type
      }
      return(p)
    }
  )
  return(f)
}

##' @export
estimate.phreg <- function(x, ..., time = NULL,
			   newdata = NULL, X = NULL,all=FALSE,
                           type = c("chaz", "surv", "risk"),
                           baseline.args = list()) { ## {{{ 
  if (NCOL(model.matrix(x))==0L & is.null(time)) stop("Non-parametric model; need `time` argument")
  if (!is.null(newdata) || !is.null(X)) {
    if (is.null(X)) {
      X <- model.matrix(x, data = newdata)
    }
    if (NROW(X) > 1) {
      X <- X[1, ]
      warning("Only using first row of the data")
    }
    if (all(X == 0L)) X <- NULL
  }
  if (!is.null(X)) {
    lp <- estimate(x, rbind(X), labels = "lp")
    if (is.null(time)) {
      return(estimate(lp, ...))
    }
    base <- estimate(x,
      time = time,
      type = "chaz",
      baseline.args = baseline.args
    )
    res <- transform(merge(lp, base,
                           paired = TRUE
                           ),
                     transformation_phreg(tolower(type[1]))
                     )
    return(estimate(res, ...))
  }
  ic <- do.call(IC, c(list(x, time = time,all=all), baseline.args))
  cc <- attr(ic, "coef")
  if (is.null(cc)) cc <- coef(x)
  lab <- names(cc)
###  if (!is.null(time) && length(cc) > 1 || is.null(lab)) lab <- x$strata.level
###  b <- lava::estimate(coef = cc, IC = ic, labels = lab)
  b <- lava::estimate(coef = cc, IC = ic)
  if (!is.null(time)) {
    b <- transform(b, transformation_phreg(tolower(type[1]), FALSE))
  }
  return(estimate(b, ...))
} ## }}} 

##' Influence Functions for phreg objects
##'
##' Computes the influence functions (IID decomposition) for the regression coefficients
##' and/or the baseline cumulative hazard at a specific time point.
##'
##' @param x Object of class \code{"phreg"}.
##' @param type Type of influence function: \code{"robust"} (default) or \code{"martingale"}.
##' @param all Logical; if \code{TRUE}, returns both beta and baseline influence functions.
##' @param time Time point for baseline influence function (required if baseline is requested).
##' @param baseline Arguments for baseline estimation.
##' @param ... Additional arguments.
##'
##' @return A matrix of influence functions. If \code{all=TRUE}, columns correspond to
##' regression coefficients and baseline cumulative hazard. Attributes include \code{coef}
##' and \code{time}.
##'
##' @author Thomas Scheike
##' @seealso \code{\link{phreg}}, \code{\link{iidBaseline}}
##' @export
IC.phreg  <- function(x,type="robust",all=FALSE,time=NULL,baseline=NULL,...) {# {{{
  if (x$p==0 & is.null(time)) stop("Non-parametric model; need `time` argument")
  if (!is.null(time)) {
    iid <- iidBaseline(x, time = time, ...)
    if (all)  {
            res <- with(iid, cbind(beta.iid,base.iid) * NROW(base.iid))
	    coefs <- c(iid$coef,iid$cumhaz.time) 
	    colnames(res) <- names(coefs)
            attr(res, "coef") <- coefs
    } else { 
            res <- with(iid, base.iid * NROW(base.iid))
	    attr(res, "coef") <- c(iid$cumhaz.time)
    }
    attr(res, "strata.level") <- iid$strata.level
    attr(res, "time") <- time
    return(res)
  }
    classes1 <- "mlogit"
    if ((length(class(x)) == 1) || inherits(x, classes1)) {
        invhess <- -pinv(x$hessian)
        orig.order <- FALSE
        if (is.null(x$propodds)) {
            if (type == "robust") {
                xx <- x$cox.prep
                ii <- invhess
                S0i <- rep(0, length(xx$strata))
                S0i[xx$jumps + 1] <- 1/x$S0
                Z <- xx$X
                U <- E <- matrix(0, nrow(xx$X), x$p)
                E[xx$jumps + 1, ] <- x$E
                U[xx$jumps + 1, ] <- x$U
                cumhaz <- cbind(xx$time, cumsumstrata(S0i, xx$strata,
                  xx$nstrata))
                EdLam0 <- apply(E * S0i, 2, cumsumstrata, xx$strata,
                  xx$nstrata)
                rr <- c(xx$sign * exp(Z %*% coef(x) + xx$offset))
                MGt <- U[, drop = FALSE] - (Z * cumhaz[, 2] -
                  EdLam0) * rr * c(xx$weights)
                if (orig.order) {
                  oo <- (1:nrow(xx$X))[xx$ord + 1]
                  oo <- order(oo)
                  MGt <- MGt[oo, , drop = FALSE]
                  id <- xx$id[oo]
                }
                else id <- xx$id
            }
            else {
                MGt <- x$U
                MG.base <- 1/x$S0
            }
        } else {
            xx <- x$cox.prep
            ii <- invhess
            S0i <- rep(0, length(xx$strata))
            S0i[xx$jumps + 1] <- 1/x$S0
            Z <- xx$X
            U <- E <- matrix(0, nrow(xx$X), x$p)
            E[xx$jumps + 1, ] <- x$E
            U[xx$jumps + 1, ] <- x$U
            cumhazA <- cumsumstratasum(S0i, xx$strata, xx$nstrata,
                type = "all")
            cumhaz <- c(cumhazA$sum)
            cumhazm <- cumhazA$lagsum
            EdLam0 <- apply(E * S0i, 2, cumsumstrata, xx$strata,
                xx$nstrata)
            rr <- c(xx$sign * exp(Z %*% coef(x) + xx$offset))
            rro <- c(exp(Z %*% coef(x) + xx$offset))
            S0star <- revcumsumstrata(rr/(1 + rro * cumhazm),
                xx$strata, xx$nstrata)
            S0 <- revcumsumstrata(rr, xx$strata, xx$nstrata)
            S1 <- apply(Z * rr, 2, revcumsumstrata, xx$strata,
                xx$nstrata)
            Et <- S1/c(S0)
            lt <- apply((Z - Et) * c(rr * rro/(1 + rro * cumhazm)),
                2, revcumsumstrata, xx$strata, xx$nstrata)
            Estar <- S0star/S0
            EstardLam <- cumsumstrata(Estar * S0i, xx$strata,
                xx$nstrata)
            k <- exp(-EstardLam)
            basecor <- apply(lt * c(k * S0i), 2, revcumsumstrata,
                xx$strata, xx$nstrata)
            basecor <- basecor/c(k * S0)
            www <- x$propoddsW * x$weightsJ
            U[xx$jumps + 1, ] <- U[xx$jumps + 1, ] - c(www) *
                basecor[xx$jumps + 1, ]
            MGt <- U
            if (type == "robust") {
                baseDLam0 <- apply(basecor * S0i, 2, cumsumstrata,
                  xx$strata, xx$nstrata)
                MGt <- U[, drop = FALSE] - (Z * cumhaz - EdLam0 -
                  baseDLam0) * rr * c(xx$weights)
            }
            else MGt <- MGt[xx$jumps + 1, ]
            MG.base <- 1/x$S0
            id <- xx$id
        }
        ncluster <- NULL
        if (type == "robust" & (!is.null(x$id) | any(x$entry >
            0))) {
            if (type == "martingale")
                id <- x$id[x$jumps]
            UU <- apply(MGt, 2, sumstrata, id, max(id) + 1)
            ncluster <- nrow(UU)
        }
        else {
            UU <- MGt
        }
        res <- structure(UU %*% invhess, invhess = invhess, ncluster = ncluster)
        if (is.null(colnames(res))) colnames(res) <- names(coef(x))
	if (!is.null(x$name.id)) res <- nameme(res, x$name.id)
        res <- res * NROW(res)
        return(res)
    }
    else if (inherits(x, c("cifreg", "recreg", "IPTW"))) {
        if (inherits(x, c("IPTW")))
            res <- x$IID
        else res <- x$iid
        if (is.null(colnames(res)))
            colnames(res) <- names(coef(x))
        res <- res * NROW(res)
        return(res)
    }
} ## }}}

##' Influence Functions or IID Decomposition of Baseline
##'
##' Computes the influence functions for the baseline cumulative hazard (and optionally
##' regression coefficients) for \code{phreg}, \code{recreg}, or \code{cifregFG} objects.
##'
##' The decomposition is based on the formula:
##' \deqn{ \sum_i \int_0^t \frac{f(s)}{S_0(s)} dM_{ki}(s) - P(t) \beta_k }
##' where \eqn{k} denotes the stratum and \eqn{i} the cluster.
##'
##' @param object Object of class \code{"phreg"}, \code{"recreg"}, or \code{"cifregFG"}.
##' @param time Time point for baseline IID (required).
##' @param ft Function to compute IID of baseline integrated against \eqn{f(t)}.
##' @param fixbeta Logical; if \code{TRUE}, fixes the coefficients (useful for specific tests).
##' @param beta.iid Optional matrix of beta influence functions to use.
##' @param tminus Logical; if \code{TRUE}, computes predictions at \eqn{t-} (strictly before \eqn{t}), useful for IPCW techniques.
##' @param ... Additional arguments passed to lower-level functions.
##'
##' @return An object of class \code{"iidBaseline"} containing:
##' \item{time}{Time point.}
##' \item{base.iid}{Influence functions for the baseline.}
##' \item{beta.iid}{Influence functions for the regression coefficients.}
##' \item{cumhaz.time}{Cumulative hazard at the specified time.}
##' \item{strata}{Strata indices.}
##'
##' @author Thomas Scheike
##' @seealso \code{\link{phreg}}, \code{\link{recreg}}, \code{\link{cifreg}}
##' @export
iidBaseline <- function(object, time = NULL, ft = NULL, fixbeta = NULL, beta.iid = NULL, tminus = FALSE, ...) UseMethod("iidBaseline")

##' @export
iidBaseline.phreg <- function(object,time=NULL,ft=NULL,fixbeta=NULL,beta.iid=NULL,tminus=FALSE,...)
{# {{{
###  sum_i int_0^t f(s)/S_0(s) dM_{ki}(s) - P(t) \beta_k
###  with possible strata and cluster "k", and i in clusters
  x <- object
  if (!inherits(x,"phreg")) stop("Must be phreg object\n");
  if (is.null(time)) stop("Must give time for iid of baseline")

  if (!is.null(x$propodds))  stop("Only for Cox model")
  ### sets fixbeta based on  wheter xr has been optimized in beta (so cox case)
  if (is.null(fixbeta)) {
    fixbeta <- if ((x$no.opt) | is.null(x$coef)) 1 else 0
 }


  xx <- x$cox.prep
  btimexx <- c(1*(xx$time < time))

  S0i2 <- S0i <- rep(0,length(xx$strata))
  S0i[xx$jumps+1] <- 1/x$S0
  ww <- xx$caseweights*xx$weights
  S0i2[xx$jumps+1] <- 1/(x$S0^2*ww[xx$jumps+1])
  Z <- xx$X
  U <- E <- matrix(0,nrow(xx$X),x$p)
  E[xx$jumps+1,] <- x$E
  U[xx$jumps+1,] <- x$U
  ### only up to time t for A
  if (is.null(ft))  ft <- rep(1,length(xx$time))
  if (is.matrix(ft)) ft <- c(ft)
  cumhaz <- c(cumsumstrata(ft*S0i,xx$strata,xx$nstrata))
  cumS0i2 <- c(cumsumstrata(ft*S0i2*btimexx,xx$strata,xx$nstrata))
  if (fixbeta==0) {
	  EdLam0 <- apply(ft*E*S0i,2,cumsumstrata,xx$strata,xx$nstrata)
	  Ht <- apply(ft*E*S0i*btimexx,2,cumsumstrata,xx$strata,xx$nstrata)
  } else Ht <- NULL
  if (fixbeta==0) rr <- c(xx$sign*exp(Z %*% coef(x) + xx$offset)) else rr <- c(xx$sign*exp(xx$offset))
  id <-   xx$id
  mid <- max(id)+1
  MGAiid <- ft*S0i*btimexx-cumS0i2*rr*c(xx$weights)

  MGtiid <- NULL
  if (fixbeta==0) {# {{{
     if (!is.null(beta.iid)) MGtiid <- beta.iid else {
     invhess <- -pinv(x$hessian)
     MGt <- ft*U[,drop=FALSE]-(Z*cumhaz-EdLam0)*rr*c(xx$weights)
     MGt <- MGt %*% invhess
     MGtiid <- apply(MGt,2,sumstrata,id,mid)
    }
     ## Ht efter strata
     Htlast <- tailstrata(xx$strata,xx$nstrata)
     HtS <- Ht[Htlast,,drop=FALSE]
     if (!is.null(x$call.id)) MGtiid <- nameme(MGtiid,x$name.id)
  }# }}}

 ### \hat beta - \beta = \sum_i \beta_i  (iid)
 ### iid after baseline:
 ### \hat A_s-A_s=\sum_{i clusters} \sum_{j: i(j)=i, s(j)=s} \int_0^t 1/S_0 dM^s_{i,j} - P^s(t) \sum_i \beta_i
 ### = \sum_{i clusters} ( \sum_{j \in i(j)=i, s(j)=s} \int_0^t 1/S_0 dM^s_j - P^s(t) \beta_i )

 ## sum after id's within strata and order
 MGAiids <- c()
 cumhaz.time <- c()
 sus <- sort(unique(xx$strata))
 for (i in sus)  {
	 wi <- which(xx$strata==i)
         MGAiidl <- sumstrata(MGAiid[xx$strata==i],xx$id[xx$strata==i],mid)
	 cumhazs <- rbind(0,x$cumhaz[x$strata[x$jumps]==i,])
	 cumhaz.time <- c(cumhaz.time,cpred(cumhazs,time,tminus=tminus)[,2])

        if (fixbeta==0) {
           UU <-  apply(HtS[i+1,]*t(MGtiid),2,sum)
           MGAiidl <- MGAiidl - UU
         }
         MGAiids <- cbind(MGAiids,MGAiidl)
 }
 names(cumhaz.time) <- paste("strata",sus,sep="")
 MGAiid <- MGAiids
 if (is.matrix(MGAiid)) {
    colnames(MGAiid) <- paste("strata",sus,sep="")
   if (!is.null(x$name.id)) MGAiid <- nameme(MGAiid,x$name.id)
    ###    if (length(x$name.id)==nrow(MGAiid)) rownames(MGAiid) <- x$name.id
 }

 cumhaz <- x$cumhaz
 out <- list(time=time,base.iid=MGAiid,strata=xx$strata,nstrata=xx$nstrata,coef=x$coef,
	     cumhaz=cumhaz,cumhaz.time=cumhaz.time,
	     id=id,beta.iid=MGtiid,formula=x$formula,
	     design=object$design)
 class(out) <- c("iidBaseline","phreg")
 return(out)
} # }}}

##' @export
summary.iidBaseline  <- function(object,...) { ## {{{
cat("iid decomposition of object phreg/cifregFG/recreg \n")
} # }}}

##' @export
print.iidBaseline <- function(x,...) { ## {{{
	x$base.iid
} # }}}


##' @export
residuals.phreg  <- function(object,cumsum=FALSE,...) {# {{{
  orig.order <- FALSE
  x <- object

if (is.null(x$propodds)) { # {{{ cox model
	  xx <- x$cox.prep
	  dN <- S0i <- rep(0,length(xx$strata))
	  S0i[xx$jumps+1] <- 1/x$S0
	  dN[xx$jumps+1] <- 1
	  cumhaz <- cumsumstrata(S0i,xx$strata,xx$nstrata)
	  Z <- xx$X
	  if (is.null(coef(x)))
		  rr <- c(xx$sign*exp(xx$offset))
          else
	  rr <- c(xx$sign*exp(Z %*% coef(x) + xx$offset))
	  ### dMartingale  as a function of time and for all subjects to handle strata
	  Lamt <- (cumhaz)*rr*c(xx$weights)
	  dMGt <- dN-Lamt
	  if (orig.order) {
	     oo <- (1:nrow(xx$X))[xx$ord+1]
	     oo <- order(oo)
	     ### back to order of iid variable
	     dMGt <- dMGt[oo,,drop=FALSE]   ## sum after id later so not needed
	     id <- xx$id[oo]
	  } else id <-  xx$id
} else { ## }}}
	# {{{  prop-odds model logitSurv
	  xx <- x$cox.prep
	  dN <- S0i <- rep(0,length(xx$strata))
	  S0i[xx$jumps+1] <- 1/x$S0
	  dN[xx$jumps+1] <- 1
	  U <- E <- matrix(0,nrow(xx$X),x$p)
	  E[xx$jumps+1,] <- x$E
	  U[xx$jumps+1,] <- x$U
	  S0i <- rep(0,length(xx$strata))
	  S0i[xx$jumps+1] <- 1/x$S0
	  cumhazA <- cumsumstratasum(S0i,xx$strata,xx$nstrata,type="all")
	  cumhaz <- c(cumhazA$sum)
	  cumhazm <- cumhazA$lagsum
          ###
	  EdLam0 <- apply(E*S0i,2,cumsumstrata,xx$strata,xx$nstrata)
	  Z <- xx$X
	  rr <- c(xx$sign*exp(Z %*% coef(x) + xx$offset))
	  rro <- c(exp(Z %*% coef(x) + xx$offset))
          S0star <- revcumsumstrata(rr/(1+rro*cumhazm),xx$strata,xx$nstrata)
          S0 <- revcumsumstrata(rr,xx$strata,xx$nstrata)
          S1 <- apply(Z*rr,2,revcumsumstrata,xx$strata,xx$nstrata)
	  Et <- S1/c(S0)
          lt <- apply((Z-Et)*c(rr*rro/(1+rro*cumhazm)),2,revcumsumstrata,xx$strata,xx$nstrata)
	  Estar <- S0star/S0
	  EstardLam <- cumsumstrata(Estar*S0i,xx$strata,xx$nstrata)
	  k <- exp(-EstardLam)
	  basecor <- apply(lt*c(k*S0i),2,revcumsumstrata,xx$strata,xx$nstrata)
	  basecor <- basecor/c(k*S0)
	  www <- x$propoddsW*x$weightsJ
	  U[xx$jumps+1,] <- U[xx$jumps+1,] - c(www)* basecor[xx$jumps+1,]
	  baseDLam0 <- apply(basecor*S0i,2,cumsumstrata,xx$strata,xx$nstrata)

	  ### Martingale  as a function of time and for all subjects to handle strata
	  MGt <- U[,drop=FALSE]-(Z*cumhaz-EdLam0-baseDLam0)*rr*c(xx$weights)

	  if (orig.order) {
	     oo <- (1:nrow(xx$X))[xx$ord+1]
	     oo <- order(oo)
	     ### back to order of data-set
	     MGt <- MGt[oo,,drop=FALSE]
	     id <- xx$id[oo]
	  } else id <-  xx$id
  }# }}}

  ncluster <- NULL
  if (!cumsum) {
	  mid <- max(id)+1
    Mt <- sumstrata(dMGt,id,mid)
    cumhaz <- sumstrata(Lamt,id,mid)
    out <- list(residuals=c(Mt),cumhaz=c(cumhaz))
  } else {
     mid <- max(id)+1
     out <- data.frame(dMGt=c(dMGt),Lamt=Lamt,status=dN,
		time=c(xx$time),id=c(xx$id)+1,sign=xx$sign)
     dsort(out) <- ~time+status+id-sign
     Mt <- cumsumstrata(out$dMGt,out$id-1,mid)
     cumhaz <- cumsumstrata(out$Lamt,out$id-1,mid)
    out <- cbind(out,Mt,cumhaz)
    out <- subset(out,sign==1)
    ddrop(out)  <- ~sign+dMGt+Lamt
  }

  return(out)
} # }}}

##' Robust Baseline Hazard Standard Errors
##'
##' Computes robust (sandwich) standard errors for the cumulative baseline
##' hazard from a \code{phreg} object.
##'
##' @param x a \code{phreg} object.
##' @param type type of standard error (default \code{"robust"}).
##' @param fixbeta if non-NULL, fixes beta at given value.
##' @param ... additional arguments passed to \code{squareintHdM}.
##' @return A list with \code{cumhaz}, \code{se.cumhaz}, and \code{strata}.
##' @rdname phreg-helpers
##' @export
robust.basehaz.phreg  <- function(x,type="robust",fixbeta=NULL,...) {# {{{

  IsdM <- squareintHdM(x,ft=NULL,fixbeta=fixbeta,...)
  varA <-   IsdM$varInt[x$jumps]
  strata <- x$strata[x$jumps]
  cumhaz <- x$cumhaz
  se.cumhaz <- cbind(cumhaz[,1],varA^.5)
  colnames(se.cumhaz) <- c("time","se.cumhaz")

  return(list(cumhaz=cumhaz,se.cumhaz=se.cumhaz,strata=strata))
} # }}}

##' @export robust_phreg
robust_phreg  <- function(x,fixbeta=NULL,...) {

  if (is.null(fixbeta))
  if ((x$no.opt) | is.null(x$coef)) fixbeta<- 1 else fixbeta <- 0

 if (fixbeta==0)  {
    beta.iid <- iid(x)
    robvar <- crossprod(beta.iid)
 } else robvar <- beta.iid <- NULL
 baseline <- robust.basehaz.phreg(x,fixbeta=fixbeta,...);
 ## add arguments so that we can call basehazplot.phreg
 res <- c(x,list(beta.iid=beta.iid,robvar=robvar,robse.cumhaz=baseline$se.cumhaz))
 class(res) <- "phreg"
 return(res)
}

###}}}

###{{{ phreg: coef vcov print summary print.summary  plot lines

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

##' @export
vcov.phreg  <- function(object,...) {     ## {{{
 if (is.null(coef(object))) return(NULL)
 if ((length(class(object))==1) & inherits(object,"phreg")) {
  res <- object$var
  if (!is.null(res)) colnames(res) <- rownames(res) <- names(coef(object))
} else {
  res <- object$var
  if (!is.null(res)) colnames(res) <- rownames(res) <- names(coef(object))
}
  res
} ## }}}

##' @export
summary.phreg <- function(object,type=c("robust","martingale"),augment.type=c("var.augment.times","var.augmenti"),...) { ## {{{
  expC <- cc <- ncluster <- V <- NULL

   if (length(object$p)>0 & object$p>0 & (!object$no.opt)) {
    I <- -pinv(object$hessian)
    if ( (length(class(object))==2) && ( inherits(object,c("cifreg","recreg")))) {
	    V <- object$var
	    ncluster <- object$ncluster ## nrow(object$Uiid)
            if (!is.null(object$augmentation)) { V <- object[[augment.type[1]]]; }
    } else  {  ## phreg
	    V <- vcov(object,type=type[1])
            ncluster <- object$n
    }
    cc <- cbind(coef(object),diag(V)^0.5,diag(I)^0.5)
    cc  <- cbind(cc,2*(pnorm(abs(cc[,1]/cc[,2]),lower.tail=FALSE)))
    colnames(cc) <- c("Estimate","S.E.","dU^-1/2","P-value")
    if (length(class(object))==1) if (!is.null(ncluster <- attributes(V)$ncluster))
    rownames(cc) <- names(coef(object))
    expC <- exp(lava::estimate(coef=coef(object),vcov=V)$coefmat[,c(1,3,4),drop=FALSE])
  }
  Strata <- levels(object$strata)
  n <- object$n
  res <- list(coef=cc,n=n,nevent=object$nevent,strata=Strata,ncluster=ncluster,var=V,exp.coef=expC)
  class(res) <- "summary.phreg"
  res
} ## }}}

##' Summarize Baseline Hazard from phreg
##'
##' Summarizes cumulative baseline hazard estimates from a phreg object,
##' optionally with robust standard errors.
##'
##' @param object a \code{phreg} object.
##' @param robust logical; if TRUE, uses robust standard errors.
##' @param ... additional arguments.
##' @return An object of class \code{"summary.recurrent"}.
##' @rdname phreg-helpers
##' @export
summarybase.phreg <- function(object,robust=FALSE,...) { ## {{{
  out <- summaryRecurrentobject(object,robust=robust,...)
  class(out) <- "summary.recurrent"
  return(out)
}# }}}


##' @export
print.phreg  <- function(x,...) { ## {{{
  cat("Call:\n")
  dput(x$call)
  cat("\n")

  Strata <- levels(x$strata)
  nn <- cbind(x$n, x$nevent)
  rownames(nn) <- Strata; colnames(nn) <- c("n","events")
  if (is.null(rownames(nn))) rownames(nn) <- rep("",NROW(nn))
  print(nn, quote=FALSE)

  if (!is.null(x$coef) && length(x$coef) > 0) {
    cat("\ncoefficients:\n")
    ## V <- x$var
    ## if (!is.null(V)) {
    ##   cc <- cbind(coef(x), diag(V)^0.5)
    ##   cc <- cbind(cc, 2*(pnorm(abs(cc[,1]/cc[,2]), lower.tail=FALSE)))
    ##   colnames(cc) <- c("Estimate", "S.E.", "P-value")
    ##   rownames(cc) <- names(coef(x))
    ##   printCoefmat(cc, P.values=TRUE, has.Pvalue=TRUE, ...)
    ## } else {
    print(coef(x))
    ## }
  }
  cat("\n")
  invisible(x)
}  ## }}}

##' Plotting the baselines of stratified Cox
##'
##' Plotting the baselines of stratified Cox
##' @param x phreg object
##' @param ... Additional arguments to baseplot funtion
##' @author Klaus K. Holst, Thomas Scheike
##' @aliases baseplot bplot  basecumhaz plotConfRegion  plotConfRegionSE plotstrata kmplot plotConfregion
##' @examples
##' data(TRACE)
##' dcut(TRACE) <- ~.
##' out1 <- phreg(Surv(time,status==9)~vf+chf+strata(wmicat.4),data=TRACE)
##'
##' par(mfrow=c(2,2))
##' plot(out1)
##' plot(out1,stratas=c(0,3))
##' plot(out1,stratas=c(0,3),col=2:3,lty=1:2,se=TRUE)
##' plot(out1,stratas=c(0),col=2,lty=2,se=TRUE,polygon=FALSE)
##' plot(out1,stratas=c(0),col=matrix(c(2,1,3),1,3),lty=matrix(c(1,2,3),1,3),se=TRUE,polygon=FALSE)
##' @aliases plotConfRegion  plotConfRegionSE plotstrata kmplot plotConfregion
##' @export
plot.phreg  <- function(x,...)  baseplot(x,...)

##' @export
lines.phreg <- function(x,...,add=TRUE) plot(x,...,add=add)

##' @export
bplot <- function(x,...,add=TRUE) plot(x,...,add=add)

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

  if (length(class(x))==2 & inherits(x,"cifreg")) cat("Competing risks regression \n");
  if (!is.null(x$propodds)) {
       cat("Proportional odds model, log-OR regression \n");
  } else cat("\n")

  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("coefficients:\n")
    printCoefmat(x$coef,...)
    cat("\n")
    cat("exp(coefficients):\n")
    printCoefmat(x$exp.coef,...)
  }
  cat("\n")

} ## }}}

###}}}

##' Confidence Intervals with Transformations
##'
##' Computes confidence intervals using log or plain transformations,
##' with optional restrictions to positive values or probability scale.
##'
##' @param x point estimate(s).
##' @param std.err standard error(s).
##' @param conf.type type of transformation: \code{"log"} or \code{"plain"}.
##' @param restrict restriction: \code{"positive"}, \code{"prob"}, or \code{"none"}.
##' @param conf.int confidence level (default 0.95).
##' @return A list with \code{upper}, \code{lower}, \code{conf.type}, and \code{conf.int}.
##' @rdname phreg-helpers
##' @aliases conftype summarybase.phreg robust.basehaz.phreg
##' @export
conftype <- function(x,std.err,conf.type=c("log","plain"),restrict=c("positive","prob","none"),conf.int=0.95)
{ ## {{{
zval <- qnorm(1 - (1 - conf.int)/2, 0, 1)
 if (conf.type[1] == "plain") {# {{{
    temp1 <- x + zval * std.err
    temp2 <- x - zval * std.err
    if (restrict[1]=="prob") cix <- list(upper = pmin(temp1, 1), lower = pmax(temp2, 0), conf.type = "plain", conf.int = conf.int)
    if (restrict[1]=="positive") cix <- list(upper = pmax(temp1, 0), lower = pmax(temp2, 0), conf.type = "plain", conf.int = conf.int)
    if (restrict[1]=="none") cix <- list(upper = temp1, lower = temp2, conf.type = "plain", conf.int = conf.int)
 }
 if (conf.type[1] == "log") {
    xx <- ifelse(x <= 0, NA, x)
    temp1 <- ifelse(x <= 0, NA, exp(log(xx) + zval * std.err/xx))
    temp2 <- ifelse(x <= 0, NA, exp(log(xx) - zval * std.err/xx))
    if (restrict[1]=="prob") cix <- list(upper = pmin(temp1, 1), lower = temp2, conf.type = "log", conf.int = conf.int)
    else cix <- list(upper = temp1, lower = temp2, conf.type = "log", conf.int = conf.int)
 }
### if (conf.type[1] == "log-log") {
###    who <- (x == 0 | x == 1)
###    xx <- ifelse(who, NA, x)
###    temp1 <- exp(-exp(log(-log(xx)) + zval * std.err/log(xx)))
###    temp2 <- exp(-exp(log(-log(xx)) - zval * std.err/log(xx)))
###    if (restrict[1]=="prob") {
###	    temp3 <- ifelse(x == 0, NA, 1)
###	    temp1 <- ifelse(who, temp3, temp1)
###	    temp2 <- ifelse(who, temp3, temp2)
###    } else {
###    cix <- list(upper = temp1, lower = temp2, conf.type = "log-log", conf.int = conf.int)
###    }
### }# }}}
 return(cix)
}# }}}

basecumhaz <- function(x,type=c("list"),only=0,joint=0,cumhaz="cumhaz",se.cumhaz="se.cumhaz",robust=FALSE,columns=NULL,...) {# {{{
   ## all strata
   stratobs <- x$strata[x$jumps]
   ustratobs <- sort(unique(stratobs))
   stratas <- 0:(x$nstrata-1)
   ## default 
   if (is.null(columns)) columns <- 1:2

   se.cum <- cum <- c()
   se.cum <- cum <- x[[cumhaz]]
   if (robust==TRUE) {
	   ## take robse if there otherwise stay with se.cumhaz
	   secum <- x$robse.cumhaz
	   if (is.null(secum)) secum <- x[[se.cumhaz]]
   } else secum  <- x[[se.cumhaz]]
   if (is.null(secum)) nose <- TRUE else nose <- FALSE

   out <- rep(list(NULL),x$nstrata)
   if (length(ustratobs)>0)
   for (i in ustratobs) {
	   if (!is.null(x[[cumhaz]])) {
	   cumhazard <- x[[cumhaz]][stratobs==i,columns,drop=FALSE]
           nr <- nrow(cumhazard)
	   if (nr>=1) {
		   if (!nose) se.cum <- secum[stratobs==i,columns,drop=FALSE] else se.cum <- NULL
		   if (only==0) {
			  if (joint==0) out[[i+1]] <- list(cumhaz=cumhazard,se.cumhaz=se.cum,strata=i) else
		                        out[[i+1]] <- list(cumhaz=cbind(cumhazard,se.cum[,2],i))
	           } else out[[i+1]] <- cumhazard
         }
	 }
   }

   class(out) <- "basecumhaz"
   attr(out,"stratobs") <- ustratobs
   return(out)
}# }}}

baseplot  <- function(x,se=FALSE,time=NULL,add=FALSE,ylim=NULL,xlim=NULL,
     lty=NULL,col=NULL,lwd=NULL,legend=TRUE,legend.args=list(),
     ylab="Cumulative hazard",xlab="time",
     polygon=TRUE,level=0.95,stratas=NULL,robust=FALSE,cumhaz="cumhaz",
     se.cumhaz="se.cumhaz",
     conf.type=c("log","plain"),restrict = c("positive","prob", "none"),...) {# {{{

###   if (!inherits(x,"phreg")) stop("must be phreg/recreg/ \n")

   base <- basecumhaz(x,joint=1,robust=robust,cumhaz=cumhaz,se.cumhaz=se.cumhaz)
   nstrata <- x$nstrata
   stratobs <- attr(base,"stratobs")
   ###
   if (is.null(stratas)) stratas <- stratobs else {
         wm <-   match(stratas,stratobs)
         wm <- wm[!is.na(wm)]
         if (length(wm)==0) stratas <- rep(0,0) else stratas <- stratobs[wm]
   }

   ## all confidence intervals for relevant strata  to make ylim
   if (length(stratobs)>0) {
   xx <- conftype(x$cumhaz[,2],x$se.cumhaz[,2],conf.type=conf.type[1],restrict=restrict[1],conf.int=level)

   if (is.null(xlim)) {
	   xlim <-  range(x$cumhaz[,1],na.rm=TRUE)
   }
   if (se) {
       if (is.null(x$se.cumhaz) & is.null(x$robse.cumhaz)) stop("phreg must be with cumhazard=TRUE\n");
       rrse <- range(c(xx$lower,xx$upper),na.rm=TRUE)
       if (is.null(ylim))
       {
        if (Inf %in% abs(rrse)) ylim <- range(x$cumhaz[,2],na.rm=TRUE) else ylim <- rrse
       }
   } else {
       if (is.null(ylim)) ylim <- range(x$cumhaz[,2],na.rm=TRUE)
   }

   ## all strata
   ## {{{
   ltys <- lty; cols <- col; lwds <- lwd

   if (length(stratas)>0 & x$nstrata>1) { ## with strata
   lstrata <- x$strata.level[(stratas+1)]
   stratn <-  substring(x$strata.name,8,nchar(x$strata.name)-1)
   stratnames <- paste(stratn,lstrata,sep=":")

      if (!is.matrix(lty)) {
         if (is.null(lty)) lty <- ltys <- 1:length(stratas)
         if (length(lty)!=length(stratas)) ltys <- rep(lty[1],length(stratas)) else ltys <- lty
      } else ltys <- lty
      if (!is.matrix(col)) {
         if (is.null(col)) col <- cols <- 1:length(stratas)
	 if (length(col)!=length(stratas)) cols <- rep(col[1],length(stratas)) else cols <- col
      } else cols <- col
      if (!is.matrix(lwd)) {
         if (is.null(lwd)) lwd <- lwds <- rep(1,length(stratas))
	 if (length(lwd)!=length(stratas)) lwds <- rep(lwd[1],length(stratas)) else lwds <- lwd
      } else lwds <- lwd
   } else {
     stratnames <- "Baseline"
     if (is.matrix(col))  cols <- col
     if (is.null(col)) cols <- 1  else cols <- col[1]
     if (is.matrix(lty))  ltys <- lty
     if (is.null(lty)) ltys <- 1  else ltys <- lty[1]
     if (is.matrix(lwd))  lwds <- lwd
     if (is.null(lwd)) lwds <- 1  else lwds <- lwd[1]
   }

  if (!is.matrix(ltys))  ltys <- cbind(ltys,ltys,ltys)
  if (!is.matrix(cols))  cols <- cbind(cols,cols,cols)
  if (!is.matrix(lwds))  lwds <- cbind(lwds,lwds,lwds)
  ## }}}

  first <- 1
  j <- 1
  for (i in stratas)  {
	if (!is.null(base[[i+1]])) {
	cumhazard <- base[[i+1]]$cumhaz
	if (nrow(cumhazard)>1) {
        if (add | first==0) lines(cumhazard,type="s",lty=ltys[j,1],col=cols[j,1],lwd=lwds[j,1])
        else {
	  first <- 0
          plot(cumhazard,type="s",lty=ltys[j,1],col=cols[j,1],lwd=lwds[j,1],ylim=ylim,ylab=ylab,xlab=xlab,xlim=xlim,...)
        }
        if (se==TRUE) {
            xx <- conftype(cumhazard[,2],cumhazard[,3],conf.type=conf.type[1],restrict=restrict[1],conf.int=level)
            nl <- cbind(cumhazard[,1],xx$lower); ul <- cbind(cumhazard[,1],xx$upper)
	      if (!polygon) {
		  lines(nl,type="s",lty=ltys[j,2],col=cols[j,2],lwd=lwds[j,2],...)
		  lines(ul,type="s",lty=ltys[j,3],col=cols[j,3],lwd=lwds[j,3],...)
	      } else plotConfRegion(nl[,1],cbind(nl[,2],ul[,2]),col=cols[j,1])
        }
     }
     }
    j <- j+1
  }

     if (legend & (!add))  {
       if (is.null(legend.args$x)) {
         legend.args$x <- ifelse (inherits(x,"km"), "topright", "topleft")
       }
       if (is.null(legend.args$col)) legend.args$col <- cols[,1]
       if (is.null(legend.args$lty)) legend.args$lty <- ltys[,1]
       if (is.null(legend.args$legend)) legend.args$legend <- stratnames
       do.call(graphics::legend, legend.args)
     }
   } else {
	   if (!add) plot(0,0,ylim=ylim,ylab=ylab,xlab=xlab,xlim=xlim,...)
   }
}# }}}

###{{{ phreg: basehazplot.phreg predictphreg 

basehazplot.phreg  <- function(x,se=FALSE,time=NULL,add=FALSE,ylim=NULL,xlim=NULL,lty=NULL,col=NULL,
			       lwd=NULL,legend=TRUE,legend.args=list(),
                   ylab=NULL,xlab=NULL,polygon=TRUE,level=0.95,
			       stratas=NULL,robust=FALSE,conf.type=c("plain","log"),...) {# {{{
   if (inherits(x,"phreg") & is.null(ylab)) ylab <- "Cumulative hazard"
   if (is.null(xlab)) xlab <- "time"
   level <- -qnorm((1-level)/2)
   rr <- range(x$cumhaz[,-1])
   strat <- x$strata[x$jumps]
   ylimo <- ylim
   if (is.null(ylim)) ylim <- rr
   if (is.null(xlim)) xlim <- range(x$cumhaz[,1])
   if (se==TRUE) {
	   if (is.null(x$se.cumhaz) & is.null(x$robse.cumhaz)) stop("phreg must be with cumhazard=TRUE\n");
       if (conf.type[1]=="plain")
       rrse <- range(c(x$cumhaz[,-1]+level*x$se.cumhaz[,-1]))
       else { ## type="log"
	       relse <- exp(level*x$se.cumhaz[,-1]/x$cumhaz[,-1])
	       rrse <- range(x$cumhaz[,-1]/relse,x$cumhaz[,-1]*relse)
       }
       if (inherits(x,"km")) rrse <- c(min(x$lower,na.rm=TRUE),1)
       if (is.null(ylimo)) ylim <- rrse
   }

   ## all strata
   if (is.null(stratas)) stratas <- 0:(x$nstrata-1)
   ltys <- lty
   cols <- col
   lwds <- lwd

   if (length(stratas)>0 & x$nstrata>1) { ## with strata
   lstrata <- x$strata.level[(stratas+1)]
   stratn <-  substring(x$strata.name,8,nchar(x$strata.name)-1)
   stratnames <- paste(stratn,lstrata,sep=":")

      if (!is.matrix(lty)) {
         if (is.null(lty)) lty <- ltys <- 1:length(stratas)
         if (length(lty)!=length(stratas)) ltys <- rep(lty[1],length(stratas)) else ltys <- lty
      } else ltys <- lty
      if (!is.matrix(col)) {
         if (is.null(col)) col <- cols <- 1:length(stratas)
	 if (length(col)!=length(stratas)) cols <- rep(col[1],length(stratas)) else cols <- col
      } else cols <- col
      if (!is.matrix(lwd)) {
         if (is.null(lwd)) lwd <- lwds <- rep(1,length(stratas))
	 if (length(lwd)!=length(stratas)) lwds <- rep(lwd[1],length(stratas)) else lwds <- lwd
      } else lwds <- lwd
   } else {
     stratnames <- "Baseline"
     if (is.matrix(col))  cols <- col
     if (is.null(col)) cols <- 1  else cols <- col[1]
     if (is.matrix(lty))  ltys <- lty
     if (is.null(lty)) ltys <- 1  else ltys <- lty[1]
     if (is.matrix(lwd))  lwds <- lwd
     if (is.null(lwd)) lwds <- 1  else lwds <- lwd[1]
   }

  if (!is.matrix(ltys))  ltys <- cbind(ltys,ltys,ltys)
  if (!is.matrix(cols))  cols <- cbind(cols,cols,cols)
  if (!is.matrix(lwds))  lwds <- cbind(lwds,lwds,lwds)


  first <- 0
  for (i in seq(stratas)) {
      j <- stratas[i]
        cumhazard <- x$cumhaz[strat==j,,drop=FALSE]
        if (!is.null(cumhazard)) {
	if (nrow(cumhazard)>1) {
        if (add | first==1)
        lines(cumhazard,type="s",lty=ltys[i,1],col=cols[i,1],lwd=lwds[i,1])
       else {
	  first <- 1
          plot(cumhazard,type="s",lty=ltys[i,1],col=cols[i,1],lwd=lwds[i,1],ylim=ylim,ylab=ylab,xlab=xlab,xlim=xlim,...)
       }
       if (se==TRUE) {
	    if (robust==TRUE) secumhazard  <- x$robse.cumhaz[strat==j,,drop=FALSE]
	    else secumhazard <- x$se.cumhaz[strat==j,,drop=FALSE]
	    xx <- cumhazard[,2]
	    std.err <- secumhazard[,2]
	 if (conf.type[1] == "log") {
	    temp1 <-  exp(log(xx) + level * std.err/xx)
	    temp2 <-  exp(log(xx) - level * std.err/xx)
	    ul = cbind(cumhazard[,1],temp1);
	    nl <- cbind(cumhazard[,1],temp2);
	 }
	 if (conf.type[1] == "plain") {
		 ul <-cbind(cumhazard[,1],cumhazard[,2]+level*secumhazard[,2])
		 nl <-cbind(cumhazard[,1],cumhazard[,2]-level*secumhazard[,2])
	 }
	 if (inherits(x,"km")) { ul[,2] <- x$upper[x$strata==j];
	                          nl[,2] <- x$lower[x$strata==j];
	                          wna <- which(is.na(ul[,2]))
	                          ul[wna,2] <- 0
	                          nl[wna,2] <- 0

	 }
	      if (!polygon) {
		  lines(nl,type="s",lty=ltys[i,2],col=cols[i,2],lwd=lwds[i,2],...)
		  lines(ul,type="s",lty=ltys[i,3],col=cols[i,3],lwd=lwds[i,3],...)
	      } else plotConfRegion(nl[,1],cbind(nl[,2],ul[,2]),col=cols[j+1])
        }
     }
     }
    }

     if (legend & (!add))  {
       if (is.null(legend.args$x)) {
         legend.args$x <- ifelse (inherits(x,"km"), "topright", "topleft")
       }
       if (is.null(legend.args$col)) legend.args$col <- cols[,1]
       if (is.null(legend.args$lty)) legend.args$lty <- ltys[,1]
       if (is.null(legend.args$legend)) legend.args$legend <- stratnames
       do.call(graphics::legend, legend.args)
     }

}# }}}

###}}} plot

plotpredictphreg <- function(x,se=FALSE,add=FALSE,ylim=NULL,xlim=NULL,lty=NULL,col=NULL,
       type=c("surv","cumhaz","cif"),ylab=NULL,xlab=NULL,
       polygon=TRUE,whichx=NULL,robust=FALSE,...) {# {{{
   if (type[1]=="surv" & is.null(ylab)) ylab <- "Surival probability"
   if (type[1]=="cumhaz" & is.null(ylab)) ylab <- "Cumulative hazard"
   if (type[1]=="cif" & is.null(ylab)) ylab <- "Cumulative probability"

   if (is.null(xlim)) xlim <- range(x$times)
   if (is.null(xlab)) xlab <- "time"
   if (is.null(x$se.cumhaz) & se==TRUE)  {
	  warning("predict.phreg must be with se=TRUE\n");
          se <- FALSE
   }
   ylimo <- ylim
   nlower <- paste(type[1],".lower",sep="")
   nupper <- paste(type[1],".upper",sep="")
   xx <- x[[type[1]]]

   if (se==TRUE) {
      upper <- x[[nupper]]
      lower <- x[[nlower]]
      if (is.null(x$se.cumhaz)) stop("predict.phreg/cifreg/recreg must be with se=TRUE\n");
      rrse <- range(c(0,x[[nlower]],x[[nupper]]),na.rm=TRUE)
      if (is.null(ylimo)) ylim <- rrse
   } else {
      rrse <- range(c(xx),na.rm=TRUE)
      if (is.null(ylimo)) ylim <- rrse
   }

   ## all covriates
   nx <- nrow(x$surv)
   if (is.null(whichx)) whichx <- 1:nx
   stratas <- whichx
   ltys <- lty
   cols <- col

   if (length(whichx)>0 ) { ## with X

      if (!is.matrix(lty)) {
         if (is.null(lty)) ltys <- 1:length(whichx) else
		 if (length(lty)!=length(whichx)) ltys <- rep(lty[1],length(whichx)) else ltys <- lty
      } else ltys <- lty

      if (!is.matrix(col)) {
         if (is.null(col)) cols <- 1:length(stratas) else
		 if (length(col)!=length(stratas)) cols <- rep(col[1],length(stratas))
      } else cols <- col
   } else {
     if (is.matrix(col))  cols <- col
     if (is.null(col)) cols <- 1  else cols <- col[1]
     if (is.matrix(lty))  ltys <- lty
     if (is.null(lty)) ltys <- 1  else ltys <- lty[1]
   }

  if (!is.matrix(ltys))  ltys <- cbind(ltys,ltys,ltys)
  if (!is.matrix(cols))  cols <- cbind(cols,cols,cols)

  i <- 1
  j <- whichx[i]

   if (!add)
  plot(x$times,xx[j,],type="s",lty=ltys[i,1],col=cols[i,1],ylim=ylim,ylab=ylab,xlim=xlim,xlab=xlab,...)
  else lines(x$times,xx[j,],type="s", lty=ltys[i,1],col=cols[i,1],...)
  if (length(whichx)>1)
  for (i in seq(2,length(whichx))) lines(x$times,xx[whichx[i],],type="s",lty=ltys[i,1],col=cols[i,1],...)

    if (se==TRUE) {
    for (i in seq(1,length(whichx))) {
      j <- whichx[i]
      ul <- upper[j,]; nl <- lower[j,];
      if (!polygon) {
      lines(x$times,nl,type="s",lty=ltys[i,2],col=cols[i,2])
      lines(x$times,ul,type="s",lty=ltys[i,3],col=cols[i,3])
      } else plotConfRegion(x$times,cbind(nl,ul),col=cols[i,1])
    }
  }

  where <- "topleft";
  if (type[1]=="surv") where <-  "topright"

}# }}}

###{{{ predict.phreg print.predict plot.predict.phreg

##' Predictions from Proportional Hazards Model
##'
##' Computes predictions for survival probability, cumulative hazard, or risk at specified
##' time points for new data or existing data. Includes standard errors and confidence intervals.
##'
##' @param object Object of class \code{"phreg"}.
##' @param newdata Data frame for prediction. If \code{NULL}, predictions are made for the original data.
##' @param times Time points for prediction. Defaults to all unique event times in the model.
##' @param individual.time Logical; if \code{TRUE}, uses one time per subject (requires \code{newdata} and \code{times} to be same length).
##' @param tminus Logical; if \code{TRUE}, predicts at \eqn{t-} (strictly before \eqn{t}).
##' @param se Logical; if \code{TRUE}, computes standard errors and confidence intervals.
##' @param robust Logical; if \code{TRUE}, uses robust standard errors (default for most functions).
##' @param conf.type Transformation for survival estimates: \code{"log"} (default) or \code{"plain"}.
##' @param conf.int Confidence level (default 0.95).
##' @param km Logical; if \code{TRUE}, uses Kaplan-Meier product-limit for baseline; otherwise uses exponential of cumulative baseline.
##' @param ... Additional arguments for plotting functions.
##'
##' @return An object of class \code{"predictphreg"} containing:
##' \item{surr}{Matrix of survival probabilities.}
##' \item{cumhaz}{Matrix of cumulative hazards.}
##' \item{cif}{Matrix of cumulative incidence functions (if applicable).}
##' \item{times}{Vector of time points.}
##' \item{surv.upper, surv.lower}{Confidence bounds for survival.}
##' \item{RR}{Relative risks.}
##'
##' @author Thomas Scheike
##' @export
predict.phreg <- function(object,newdata,times=NULL,individual.time=FALSE,tminus=FALSE,se=TRUE,robust=FALSE,conf.type="log",conf.int=0.95,km=FALSE,...)
{# {{{ default is all time-points from the object
### take baseline and strata from object# {{{
ocumhaz <- object$cumhaz
jumptimes <- ocumhaz[,1]
chaz <- ocumhaz[,2]
if (is.null(object$nstrata)) {  ## try to make more robust
nstrata <- 1;
strata <- rep(1,length(jumptimes))
} else {
nstrata <- object$nstrata
strata <- object$strata[object$jumps]
}
if (length(jumptimes)==0) se <- FALSE
if (se) {
if (!robust) {
   se.chaz <- object$se.cumhaz[,2]
   varbeta <- object$ihessian
   if (!object$no.opt) Pt <- apply(object$E/c(object$S0),2,cumsumstrata,strata,nstrata)
   else Pt <- 0
} else { ## only relevant for phreg objects
  if ((object$no.opt) | is.null(object$coef)) fixbeta<- 1 else fixbeta <- 0
  IsdM <- squareintHdM(object,ft=NULL,fixbeta=fixbeta,...)
  ###
  se.chaz <-   IsdM$varInt[object$jumps]^.5
  covv <- IsdM$covv[object$jumps,,drop=FALSE]
  varbeta <- IsdM$vbeta
  Pt <- IsdM$Ht[object$jumps,,drop=FALSE]
}
} # }}}

### setting up newdata with factors and strata
if (!is.null(newdata)) 
x <- update_design(object$design,data = newdata,response=FALSE)
else x <- object$design
X <- x$x
if (!is.null(x$strata)) strataNew <- as.numeric(x$strata)-1 else strataNew <- rep(0,nrow(X))

if (is.null(times)) times <- sort(unique(c(object$exit)))
if (individual.time & is.null(times)) times <- c(object$exit)
if (individual.time & length(times)==1) times <- rep(times,length(object$exit))

    se.cumhaz <- NULL
    if (!individual.time) {
       pcumhaz <- surv <- matrix(0,nrow(X),length(times))
       if (se) se.cumhaz <- matrix(0,nrow(X),length(times))
    } else {
        pcumhaz <- surv <- matrix(0,nrow(X),1)
        if (se) se.cumhaz <- matrix(0,nrow(X),1)
    }
    hazt <- length(times)

    for (j in unique(strataNew)) {
        where <- predictCumhaz(c(0,jumptimes[strata==j]),times,type="left",tminus=tminus)
	plhazt <- hazt <- c(0,chaz[strata==j])
	if (km) { plhazt <- suppressWarnings(c(1,exp(cumsum(log(1-diff(hazt))))));  plhazt[is.na(hazt)] <- 0 }
	if (se) se.hazt <- c(0,se.chaz[strata==j])
	Xs <- X[strataNew==j,,drop=FALSE]
        if (object$p==0) RR <- rep(1,nrow(Xs)) else RR <- c(exp( Xs %*% coef(object)))
	if (se)  { # {{{ based on Hazard's
		if (object$p>0) {
			Ps <- Pt[strata==j,,drop=FALSE]
			Ps <- rbind(0,Ps)[where,,drop=FALSE]
			Xbeta <- Xs %*% varbeta
			seXbeta <- rowSums(Xbeta*Xs)^.5
			cov2 <- cov1 <- Xbeta %*% t(Ps*hazt[where])
		        if (robust)	{
			   covvs <- covv[strata==j,,drop=FALSE]
			   covvs <- rbind(0,covvs)[where,,drop=FALSE]
                           covv1 <- Xs %*% t((covvs*hazt[where]))
			   cov1 <- cov1-covv1
			}
		} else cov1 <- 0
	}# }}}
   haztw <- hazt[where]
   if (se) se.haztw <- se.hazt[where]
	if (is.null(object$propodds)) {
           plhaztw <- plhazt[where]
 	   if (!individual.time) pcumhaz[strataNew==j,]  <- RR%o%haztw else pcumhaz[strataNew==j,] <- RR*haztw[strataNew==j]
           if (!km) {
	     if (!individual.time) surv[strataNew==j,]  <- exp(- RR%o%haztw)
	     else surv[strataNew==j,]  <- exp(-RR*haztw[strataNew==j])
	   } else {
             if (!individual.time) surv[strataNew==j,]  <- exp( RR %o% log(plhaztw))
	     else surv[strataNew==j,]  <- plhaztw[strataNew==j]^RR
	   }
	} else {
	  if (!individual.time) surv[strataNew==j,]  <- 1/(1+RR%o%haztw)
          else surv[strataNew==j,]  <- 1/(1+RR*haztw[strataNew==j])
	}
	if (se) {# {{{
	    if (object$p>0)  {
	       if (!individual.time) se.cumhaz[strataNew==j,]  <-
		     ((RR %o% se.haztw)^2+(c(RR*seXbeta) %o% haztw)^2-2*RR^2*cov1)^.5
	        else se.cumhaz[strataNew==j,]  <- RR* (se.haztw^2+(c(seXbeta)*haztw)^2-2*diag(cov1))^.5
	    } else {
	       if (!individual.time) se.cumhaz[strataNew==j,]  <- RR %o% (se.haztw)
	        else se.cumhaz[strataNew==j,]  <- RR* se.haztw[strataNew==j]
	    }
	}# }}}
    }

  if (se)  {
     cibase <- conftype(pcumhaz,se.cumhaz,conf.type=conf.type[1],restrict="positive",conf.int=conf.int)
     cisurv <- conftype(surv,surv*se.cumhaz,conf.type=conf.type[1],restrict="prob",conf.int=conf.int)
  } else {
     cibase <- list(upper=NULL,lower=NULL,conf.type=conf.type[1],restrict="positive",conf.int=conf.int)
     cisurv <- list(upper=NULL,lower=NULL,conf.type=conf.type[1],restrict="positive",conf.int=conf.int)
  }

 if (object$p>0) RR <-  exp(X %*% coef(object)) else RR <- rep(1,nrow(X))

### non-cox setting
if (!is.null(object$propodds)) pcumhaz <- -log(surv)

 out <- list(surv=surv,times=times,
    surv.upper=cisurv$upper,surv.lower=cisurv$lower,cumhaz=pcumhaz,se.cumhaz=se.cumhaz,
    se.surv=surv*se.cumhaz,se.cif=surv*se.cumhaz,
    cif=1-surv,cif.lower=1-cisurv$upper,cif.upper=1-cisurv$lower,
    cumhaz.upper=cibase$upper,cumhaz.lower=cibase$lower,strata=strataNew,X=X,RR=RR,id=x$cluster)

class(out) <- c("predictphreg",class(object)[1])
return(out)
}# }}}

##' @export
model.frame.phreg <- function(formula, data = NULL, ...) {
    if (is.null(data)) {
        return(formula$model.frame)
    }
    model.frame(formula$design$formula, data = data, ...)
}

##' @export
model.matrix.phreg <- function(object, data=NULL, ...) {
  if (is.null(data)) return(object$design$x)
  update_design(object$design, data=data, ...)$x
}

##' @export
summary.predictphreg <- function(object, type = c("surv", "cumhaz", "cif")[1],
                                 times = NULL, np = 10, extend = FALSE,
                                 digits = 4, ...) { ## {{{ 
  # ---- resolve time indices ----------------------------------------
  call.times <- times
  if (is.null(times)) {
    indexcol <- seq(ncol(object$surv))
    times    <- object$times
  } else {
    if (!is.numeric(times))
      stop("'times' must be numeric or NULL\n")
    if (extend) {
      indexcol <- predictCumhaz(c(0, object$times), times, return.index = TRUE)
    } else {
      indexcol <- predictCumhaz(object$times, times, return.index = TRUE)
      times[indexcol == 0] <- NA
      if (any(indexcol == 0))
        warning("Some requested times are before the first event time, returning NA\n")
    }
  }

  # ---- resolve subject (row) indices --------------------------------
  n_subj <- nrow(object[[type[1]]])
  if (is.null(np)) {
    ids <- seq(n_subj)
  } else {
    if (!is.numeric(np))
      stop("'np' must be row ids, a count, or NULL\n")
    if (length(np) > 1)       ids <- np           # explicit ids
    else if (np >= n_subj)    ids <- seq(n_subj)  # np >= data size
    else                      ids <- seq(np)       # first np rows
  }

  # ---- extract the requested quantity --------------------------------
  qty <- type[1]
  if (is.null(object[[qty]]))
    stop(sprintf("Type '%s' not found in predict object\n", qty))

  mat      <- object[[qty]]
  lower    <- object[[paste0(qty, ".lower")]]
  upper    <- object[[paste0(qty, ".upper")]]
  se.out   <- object[[paste0("se.", qty)]]

  # ---- extend with time-0 boundary if requested ---------------------
  if (extend) {
    boundary <- if (qty == "surv") 1 else 0
    mat    <- cbind(boundary, mat)
    se.out <- if (!is.null(se.out)) cbind(0, se.out) else NULL
    lower  <- if (!is.null(lower))  cbind(boundary, lower)  else NULL
    upper  <- if (!is.null(upper))  cbind(boundary, upper)  else NULL
  }

  # ---- slice and return ---------------------------------------------
  has_ci <- length(lower) > 1
  if (has_ci) {
    out <- list(
      pred    = mat[ids, indexcol, drop = FALSE],
      se.pred = se.out[ids, indexcol, drop = FALSE],
      lower   = lower[ids, indexcol, drop = FALSE],
      upper   = upper[ids, indexcol, drop = FALSE],
      times   = times,
      rows    = ids
    )
  } else {
    out <- list(
      pred  = mat[ids, indexcol, drop = FALSE],
      times = times,
      rows  = ids
    )
  }

  out$call.times <- call.times
  out$type       <- qty
  class(out)     <- "summary.predictphreg"
  out
} ## }}} 

##' @export
print.summary.predictphreg <- function(x, digits = 4, ...) { ## {{{
  has_ci <- !is.null(x$lower)
  cat(sprintf("Predictions of type '%s'\n", x$type))
  cat(sprintf("  Showing subjects: %s\n",
              paste(x$rows, collapse = ", ")))
  cat(sprintf("  Showing times:    %s\n\n",
              paste(round(x$times, digits), collapse = ", ")))

  for (i in seq_along(x$rows)) {
    cat(sprintf("-- Subject %d --\n", x$rows[i]))
    entry <- data.frame(time = round(x$times, digits),
                        pred = round(x$pred[i, ], digits))
    names(entry)[2] <- x$type
    if (has_ci) {
      entry$se    <- round(x$se.pred[i, ], digits)
      entry$lower <- round(x$lower[i, ],   digits)
      entry$upper <- round(x$upper[i, ],   digits)
    }
    print(entry, row.names = FALSE)
    cat("\n")
  }
  invisible(x)
} ## }}} 

##' @export
print.predictphreg <- function(x, type = c("surv", "cumhaz", "cif")[1],
                               times = NULL, np = 10, digits = 4, ...) { ## {{{ 
  # Run summary to get the sliced data
  s <- summary(x, type = type[1], times = times, np = np, ...)

  n_subj  <- nrow(x[[type[1]]])
  n_times <- ncol(x[[type[1]]])
  has_ci  <- !is.null(s$lower)

  cat(sprintf("Predictions of type '%s'\n", type[1]))
  cat(sprintf("  Subjects: %d total, showing %d\n", n_subj,  length(s$rows)))
  cat(sprintf("  Times:    %d total, showing %d\n", n_times, length(s$times)))
  if (has_ci) cat("  Confidence intervals available\n")
  cat("\n")

  # Build a long-format data frame: one row per (subject, time)
  rows <- s$rows
  tms  <- round(s$times, digits)
  pred <- s$pred

  df_list <- vector("list", length(rows))
  for (i in seq_along(rows)) {
    entry <- data.frame(
      subject = rows[i],
      time    = tms,
      pred    = round(pred[i, ], digits)
    )
    names(entry)[3] <- type[1]
    if (has_ci) {
      entry$lower <- round(s$lower[i, ], digits)
      entry$upper <- round(s$upper[i, ], digits)
      entry$se    <- round(s$se.pred[i, ], digits)
    }
    df_list[[i]] <- entry
  }
  out_df <- do.call(rbind, df_list)
  rownames(out_df) <- NULL

  print(out_df, row.names = FALSE)
  invisible(x)
} ## }}} 


##' @export
plot.predictphreg  <- function(x,se=FALSE,add=FALSE,ylim=NULL,xlim=NULL,lty=NULL,col=NULL,type=c("surv","cumhaz","cif"),ylab=NULL,xlab=NULL,
    polygon=TRUE,level=0.95,whichx=NULL,robust=FALSE,...) {# {{{
   if (type[1]=="cumhaz" & is.null(ylab)) ylab <- "Cumulative hazard"
   if (type[1]=="cif" & is.null(ylab)) ylab <- "Cumulative probability"
   if (type[1]=="surv" & is.null(ylab)) ylab <- "Surival probability"

   if (is.null(xlab)) xlab <- "time"
   if (type[1]=="cif") rr <- c(0,1)
   if (type[1]=="surv") rr <- c(0,1)
   if (type[1]=="cumhaz") rr <- range(c(0,x$cumhaz))
   ylimo <- ylim
   if (is.null(ylim)) ylim <- rr
   if (is.null(xlim)) xlim <- range(x$times)
   if (is.null(x$se.cumhaz) & se==TRUE)  {
	  warning("predict.phreg must be with se=TRUE\n");
          se <- FALSE
   }
   if (se==TRUE) {
      if (is.null(x$se.cumhaz)) stop("predict.phreg must be with se=TRUE\n");
   if (type[1]=="surv") rrse <- range(c(x$surv.upper,x$surv.lower,na.rm=TRUE))
   if (type[1]=="surv") rrse <- range(c(x$surv.upper,x$surv.lower,na.rm=TRUE))
   if (type[1]=="cumhaz") {
	   cumhaz.upper <- x$cumhaz+level*x$se.cumhaz
	   cumhaz.lower <- x$cumhaz-level*x$se.cumhaz
       rrse <- range(c(cumhaz.upper,cumhaz.lower),na.rm=TRUE)
   }
   if (type[1]=="surv") rrse <- c(0,1)
   if (type[1]=="cif") rrse <- c(0,1)
   if (type[1]=="cumhaz") rrse <- c(max(0,rrse[1]),rrse[2])
   if (is.null(ylimo)) ylim <- rrse
   }

   ## all covriates
   nx <- nrow(x$surv)
   if (is.null(whichx)) whichx <- 1:nx
   stratas <- whichx

   ltys <- lty
   cols <- col

   if (length(whichx)>0 ) { ## with X

      if (!is.matrix(lty)) {
         if (is.null(lty)) ltys <- 1:length(whichx) else
		 if (length(lty)!=length(whichx)) ltys <- rep(lty[1],length(whichx)) else ltys <- lty
      } else ltys <- lty

      if (!is.matrix(col)) {
         if (is.null(col)) cols <- 1:length(stratas) else
		 if (length(col)!=length(stratas)) cols <- rep(col[1],length(stratas))
      } else cols <- col
   } else {
     if (is.matrix(col))  cols <- col
     if (is.null(col)) cols <- 1  else cols <- col[1]
     if (is.matrix(lty))  ltys <- lty
     if (is.null(lty)) ltys <- 1  else ltys <- lty[1]
   }

  if (!is.matrix(ltys))  ltys <- cbind(ltys,ltys,ltys)
  if (!is.matrix(cols))  cols <- cbind(cols,cols,cols)

  i <- 1
  j <- whichx[i]

  recreg <- cifreg <- FALSE
  if ((length(class(x))==2) && (substr(class(x)[2],1,3)=="cif")) cifreg <- TRUE
###  if ((length(class(x))==2) && (substr(class(x)[2],1,3)=="rec")) recreg <- TRUE
  if (type[1]=="surv") {
	  xx <- x$surv
	  if (cifreg)  xx <- x$cif
	  if (recreg)  xx <- x$mean
  } else if (type[1]=="cif") {
	  xx <- 1-x$surv
  } else xx <- x$cumhaz
  if (se) {
     if (type[1]=="surv") {
	     upper <- x$surv.upper; lower <- x$surv.lower
	     if (cifreg) { upper <- x$cif.upper; lower <- x$cif.lower}
	     if (recreg) { upper <- x$mean.upper; lower <- x$mean.lower}
     } else if (type[1]=="cif") {
	     upper <- 1-x$surv.lower; lower <- 1-x$surv.upper
     } else { upper <- cumhaz.upper; lower <- cumhaz.lower}
  }

  if (!add)
  plot(x$times,xx[j,],type="s",lty=ltys[i,1],col=cols[i,1],ylim=ylim,ylab=ylab,xlim=xlim,xlab=xlab,...)
  else lines(x$times,xx[j,],type="s", lty=ltys[i,1],col=cols[i,1],...)
  if (length(whichx)>1)
  for (i in seq(2,length(whichx))) lines(x$times,xx[whichx[i],],type="s",lty=ltys[i,1],col=cols[i,1],...)

    if (se==TRUE) {
    for (i in seq(1,length(whichx))) {
      j <- whichx[i]
      ul <- upper[j,]; nl <- lower[j,];
      if (!polygon) {
      lines(x$times,nl,type="s",lty=ltys[i,2],col=cols[i,2])
      lines(x$times,ul,type="s",lty=ltys[i,3],col=cols[i,3])
      } else plotConfRegion(x$times,cbind(nl,ul),col=cols[i,1])
    }
  }

  where <- "topleft";
  if (type[1]=="surv") where <-  "topright"

}# }}}

###}}} predict

# {{{ Restricted mean for stratified Kaplan-Meier with martingale standard errors

##' Restricted Mean for Stratified Kaplan-Meier or Cox Model
##'
##' Computes the Restricted Mean Survival Time (RMST) for stratified Kaplan-Meier or
##' stratified Cox models with martingale standard errors.
##'
##' The standard error is computed using linear interpolation between standard errors at jump-times.
##' This allows plotting the restricted mean as a function of time.
##'
##' Years lost can be computed based on this and decomposed into years lost for different causes
##' using the \code{cif_yearslost} function.
##'
##' @param x Object of class \code{"phreg"}.
##' @param times Possible times for which to report restricted mean. If \code{NULL}, reports for all event times.
##' @param covs Possible covariates for Cox model adjustment.
##' @param ... Additional arguments passed to lower-level functions.
##'
##' @return An object of class \code{"resmean_phreg"} containing:
##' \item{rmst}{Matrix of restricted mean survival times.}
##' \item{se.rmst}{Standard errors for RMST.}
##' \item{intkmtimes}{Restricted mean at specified times.}
##' \item{years.lost}{Years lost (if applicable).}
##'
##' @author Thomas Scheike
##' @examples
##' data(bmt)
##' bmt$time <- bmt$time + runif(408) * 0.001
##' out1 <- phreg(Surv(time, cause != 0) ~ strata(tcell, platelet), data = bmt)
##'
##' rm1 <- resmean_phreg(out1, times = 10 * (1:6))
##' summary(rm1)
##' e1 <- estimate(rm1)
##' par(mfrow = c(1, 2))
##' plot(rm1, se = 1)
##' plot(rm1, years.lost = TRUE, se = 1)
##'
##' ## Comparing populations
##' rm1 <- resmean_phreg(out1, times = 40)
##' e1 <- estimate(rm1)
##' estimate(e1, rbind(c(1, -1, 0, 0)))
##' @aliases rmst_phreg resmean_phreg
##' @export
resmean_phreg <- function(x,times=NULL,covs=NULL,...)
{# {{{
  ii <- invhess <- x$II

 if (!is.null(times)) {
	   tt <- expand.grid(times,0:(x$nstrata-1))
           mm <- cbind(x$jumptimes,x$strata.jumps,1)
           mm <- rbind(mm,cbind(tt[,1],tt[,2],0))
           ord <- order(mm[,1])
           mm <- mm[ord,]
	   phd <- which(mm[,3]==1)
	   newtimes <- which(mm[,3]==0)
	   S0i <- S0i2 <- rep(0,nrow(mm))
	   S0i[phd] <- c(1/x$S0)
	   S0ii2 <- c(1/(x$S0*(x$S0-1)))
	   S0ii2[x$S0==1] <- 0
	   S0i2[phd] <- S0ii2
           strata.jumps <- mm[,2]
	   nstrata <- x$nstrata;
	   jumptimes <- mm[,1]
	   E <- matrix(0,nrow(mm),x$p)
	   E[phd,] <- x$E
    }   else {
	   strata.jumps <- x$strata.jumps;
	   nstrata <- x$nstrata;
	   jumptimes <- x$jumptimes;
	   S0i <- c(1/x$S0)
	   S0i2 <- c(1/(x$S0*(x$S0-1)))
	   S0i2[x$S0==1] <- 0
	   E <- x$E
 }

  cumhaz <- cumsumstrata(S0i,strata.jumps,nstrata)
  var.cumhazMG <- cumsumstrata(S0i2,strata.jumps,nstrata)

  ## baseline survival
  km <- exp(cumsumstratasum(log(1-S0i),strata.jumps,nstrata,type="lagsum"))

  ## If covariates compute rr = exp( X beta)  and adjust km
  if (!is.null(covs)) { rr <- exp(sum(covs * coef(x))) } else rr <- 1
  km <- km^rr

  ## start integral in 0
  dtime <- c(diffstrata(jumptimes,strata.jumps,nstrata))
  intkm <-  cumsumstrata( c(km)*dtime,strata.jumps,nstrata)

  ### variance of baseline term
  var.intkmcumhaz <- cumsumstrata(intkm*S0i2,strata.jumps,nstrata)
  var.intkm2cumhaz <- cumsumstrata(intkm^2*S0i2,strata.jumps,nstrata)
  var.resmean <- intkm^2*var.cumhazMG+var.intkm2cumhaz-2*intkm*var.intkmcumhaz

   if (!is.null(x$coef)) {
      intp <- apply(E*S0i,2,cumsumstratasum,strata.jumps,nstrata,type="lagsum")
      intpS <-  apply(intp*c(km)*dtime,2,cumsumstrata,strata.jumps,nstrata)
      Dbeta <- -intpS
      if (!is.null(covs)) {
	      intLam <- cumsumstratasum(S0i,strata.jumps,nstrata,type="lagsum")
	      intLamS <-  cumsumstrata( c(intLam)*km*dtime,strata.jumps,nstrata)
	      Dbeta <- Dbeta + matrix(covs,nrow=nrow(intLam),ncol=length(covs),byrow=TRUE)*c(intLamS)
      }
      varbetat <-   rowSums((Dbeta %*% x$II)*Dbeta)
      var.resmean <- rr^2*(var.resmean+varbetat)
  } else {
      varbetat <- 0
  }

  time<- jumptimes
  meanm <- cbind(time,intkm)
  se.resmean <- var.resmean^.5
  se.resmean[var.resmean<0] <- 0
  se.mm <- cbind(time,se.resmean)

  ### make output at specified times
  if (!is.null(times)) {
    intkmtimes <- meanm[newtimes,,drop=FALSE]
    se.intkmtimes <- se.resmean[newtimes]
    skmtimes <- mm[newtimes,2]
    years.lost <- intkmtimes[,1]-intkmtimes[,2]
    intkmtimes <- cbind(skmtimes,intkmtimes,se.intkmtimes,years.lost)
    colnames(intkmtimes) <- c("strata","times","rmean","se.rmean","years.lost")
    rownames(intkmtimes) <- rep(x$strata.level,length(times));
    intkmtimes=data.frame(intkmtimes)
###    logintkmtimes=cbind(intkmtimes[,1:2],log(intkmtimes[,3]),se.intkmtimes/intkmtimes[,3])
###    colnames(logintkmtimes) <- c("strata","times","log-rmean","log-se.rmean")
     coef <- intkmtimes[,3];
     var  <- diag(intkmtimes[,4]^2)
  } else {
	  coef <- var <- intkmtimes <- se.intkmtimes <- NULL
  }

  rmst <- cbind(meanm[,1],vecAllStrata(meanm[,2],strata.jumps,nstrata))
  se.rmst <- cbind(se.mm[,1],vecAllStrata(se.mm[,2],strata.jumps,nstrata))

 out <- list(cumhaz=meanm,se.cumhaz=se.mm,covs=covs,
       time=time,strata=strata.jumps,nstrata=nstrata,
       jumps=1:length(km),strata.name=x$strata.name,
       strata.level=x$strata.level,
       intkmtimes=intkmtimes, rmst=rmst,se.rmst=se.rmst, coef=coef,var=var)
class(out) <- c("resmean_phreg")
return(out)
}# }}}

##' @export
vcov.resmean_phreg <- function(object,cause=1,...)
{# {{{
  if (is.null(object$intkmtimes)) stop("Only for the times given in the call 'times' \n");
  if (is.na(match("rmean",names(object$intkmtimes)))) name <- paste("se.intF_",cause,sep="") else name <- "se.rmean"
  if (!(name %in% colnames(object$intkmtimes))) stop( paste("Cause not consistent with names, looks for ",name,"\n"))

  rest <- object$intkmtimes[,name]
  inttimes <- object$intkmtimes[,2]
  times <- unique(object$intkmtimes[,2])

  if (length(times)==1)   {
   res <- rest 
   out <- diag(res^2, nrow=length(res))
   if (length(res) == length(object$strata.level)) rownames(out) <- colnames(out) <- object$strata.level
  } else {
	  out <- list()
	  k <- 1
          for (tt in times)  {
		  res <- rest[tt==inttimes]
                  if (length(res) == length(object$strata.level)) names(res) <- object$strata.level
                 res <- diag(res^2, nrow=length(res))
                 if (nrow(res) == length(object$strata.level)) rownames(res) <- colnames(res) <- object$strata.level
		  out[[k]] <- res
		  k <- k+1
           }
  }

  return(out)
}# }}}

##' @export
coef.resmean_phreg <- function(object,cause=1,...) 
{# {{{
  if (is.null(object$intkmtimes)) stop("Only for the times given in the call 'times' \n");
  if (is.na(match("rmean",names(object$intkmtimes)))) name <- paste("intF_",cause,sep="") else name <- "rmean"
  if (!(name %in% colnames(object$intkmtimes))) stop( paste("Cause not consistent with names, looks for ",name,"\n"))
  rest <- object$intkmtimes[,name]
  inttimes <- object$intkmtimes[,2]
  times <- unique(object$intkmtimes[,2])

  if (length(times)==1)   {
   res <- rest 
   if (length(res) == length(object$strata.level)) names(res) <- object$strata.level
   out <- res
  } else {
	  out <- list()
	  k <- 1
          for (tt in times)  {
		  res <- rest[tt==inttimes]
                  if (length(res) == length(object$strata.level)) names(res) <- object$strata.level
		  out[[k]] <- res
		  k <- k+1
           }
  }

  return(out)
}# }}}

##' @export
estimate.resmean_phreg <- function(x,cause=1,...)
{# {{{
  if (is.null(x$intkmtimes)) stop("Only for the times given in the call 'times' \n");

  if (is.na(match("rmean",names(x$intkmtimes)))) name <- paste("se.intF_",cause,sep="") else name <- "se.rmean"

  coeft <- coef(x,cause=cause,...)
  vcovt <- vcov(x,cause=cause,...)
  times <- unique(x$intkmtimes[,2])
  if (length(times)==1)  
   out <- estimate(coef=coeft,vcov=vcovt,...)
  else {
	  out <- list()
          for (k in seq_along(times)) {
	  out[[k]] <- estimate(coef=coeft[[k]],vcov=vcovt[[k]],...)
	  }
  }

  return(out)
}# }}}



##' @export
rmst_phreg <- function(x,times=NULL,covs=NULL,...)
{# {{{
out <- resmean_phreg(x,times=times,covs=covs,...)
return(out)
}# }}}

##' Restricted Mean Time Lost for Competing Risks
##'
##' Computes the Restricted Mean Time Lost (RMTL) for competing risks based on the
##' integrated Aalen-Johansen estimator.
##'
##' A set of time points can be given to be returned in the summary, but the function
##' computes years-lost for all event times and can be plotted/viewed.
##' The RMTL for a specific time-point can also be computed using the \code{rmstIPCW} function.
##'
##' @param formula Formula for \code{phreg} object with \code{strata} to indicate strata, or \code{+1} if no strata.
##' @param data Data frame for calculations.
##' @param times Possible times for which to report restricted mean. Summary displays estimates for these times.
##' @param cens.code Censoring code (needed to separate event codes from censorings).
##' @param ... Additional arguments passed to \code{phreg}.
##'
##' @return An object of class \code{"resmean_phreg"} containing:
##' \item{cumhaz}{Matrix of cumulative hazards (years lost).}
##' \item{se.cumhaz}{Standard errors.}
##' \item{intF1times}{Years lost at specified times.}
##' \item{causes}{Vector of cause codes.}
##'
##' @author Thomas Scheike
##' @examples
##' data(bmt)
##' bmt$time <- bmt$time + runif(408) * 0.001
##'
##' ## Years lost decomposed into causes
##' drm1 <- cif_yearslost(Event(time, cause) ~ strata(tcell, platelet), data = bmt, times = c(40, 50))
##' par(mfrow = c(1, 2))
##' plot(drm1, cause = 1, se = 1)
##' plot(drm1, cause = 2, se = 1)
##' summary(drm1)
##' estimate(drm1, cause = 1)
##' estimate(drm1, cause = 2)
##'
##' ## Comparing populations
##' drm1 <- cif_yearslost(Event(time, cause) ~ strata(tcell, platelet), data = bmt, times = 40)
##' summary(drm1, contrast = list(1:4))
##' e1 <- estimate(drm1)
##' estimate(e1, rbind(c(1, -1, 0, 0)))
##' @export
cif_yearslost <- function(formula,data=data,cens.code=0,times=NULL,...)
{# {{{
  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 (!is.Surv(Y)) stop("Expected a 'Surv'-object")
  if (!inherits(Y,c("Event","Surv"))) stop("Expected a 'Surv' or 'Event'-object")
  if (ncol(Y)==2) {
    exit <- Y[,1]
    entry <- NULL ## rep(0,nrow(Y))
    status <- Y[,2]
  } else {
    entry <- Y[,1]
    exit <- Y[,2]
    status <- Y[,3]
  }

  x <- phreg(formula,data=data,no.opt=TRUE,no.var=1,Z=as.matrix(status,ncol=1),...)
  causes <- sort(unique(x$cox.prep$Z[,1]))
  ccc <- which(causes %in% cens.code)
  if (length(ccc)>=1) causes <- causes[-ccc]

 if (!is.null(times)) {# {{{
	   tt <- expand.grid(times,0:(x$nstrata-1))
###           cause.jumps <- x$U+x$E
           cause.jumps <- x$cox.prep$Z[x$cox.prep$jumps+1,1]
           mm <- cbind(x$jumptimes,x$strata.jumps,1,cause.jumps)
           mm <- rbind(mm,cbind(tt[,1],tt[,2],0,cens.code))
           ord <- order(mm[,1])
           mm <- mm[ord,]
	   phd <- which(mm[,3]==1)
	   newtimes <- which(mm[,3]==0)
	   S0i <- S0i2 <- rep(0,nrow(mm))
	   S0i[phd] <- c(1/x$S0)
	   S0ii2 <- c(1/(x$S0*(x$S0-1)))
	   S0ii2[x$S0==1] <- 0
	   S0i2[phd] <- S0ii2
           strata.jumps <- mm[,2]
	   nstrata <- x$nstrata;
	   jumptimes <- mm[,1]
	   cause.jumps <- mm[,4]
    }   else {
	   strata.jumps <- x$strata.jumps;
	   nstrata <- x$nstrata;
	   jumptimes <- x$jumptimes;
           cause.jumps <- x$cox.prep$Z[x$cox.prep$jumps+1]
	   S0i <- c(1/x$S0)
	   S0i2 <- c(1/(x$S0*(x$S0-1)))
	   S0i2[x$S0==1] <- 0
 }# }}}

 ### formula from Pepe-Mori: SIM 93, 737-
 pepemori <- 0
 ### formula from PKA SIM 2013, not corect, missing some terms
 pka <- 0

  years.lostF1 <- se.years.lostF1m  <- se.years.lostF1 <- se.years.lostF1pm <- c()
  for (i in seq_along(causes)) {
	  jumpsi <- (cause.jumps==causes[i])*1
	  jumpsni <- (cause.jumps %in% causes[-i])*1
	  cumhaz <- cumsumstrata(S0i*jumpsi,strata.jumps,nstrata)
	  var.cumhazMG <- cumsumstrata(S0i2*jumpsi,strata.jumps,nstrata)
	  var.cumhazniMG <- cumsumstrata(S0i2*jumpsni,strata.jumps,nstrata)

	  ## baseline survival
	  km <- exp(cumsumstratasum(log(1-S0i),strata.jumps,nstrata,type="lagsum"))
	  F1 <- cumsumstratasum(jumpsi*km*S0i,strata.jumps,nstrata,type="lagsum")
	  ### 1 - F2  = S + F1
	  F1n1 <- km+F1

	  ## start integral in 0
	  dtime <- c(diffstrata(jumptimes,strata.jumps,nstrata))
	  intkm <-  cumsumstrata( c(km)*dtime,strata.jumps,nstrata)
	  intF1 <- cumsumstrata( c(F1)*dtime,strata.jumps,nstrata)

	  years.lostF1 <- cbind(years.lostF1,intF1)

	  if (pka==1) {
	  ### variance of baseline term  \int_0^t 1/Y^2 \int_s^t S(u) du  dN^i{{{
	  var.intkmcumhaz <- cumsumstrata(jumpsi*intkm*S0i2,strata.jumps,nstrata)
	  var.intkm2cumhaz <- cumsumstrata(jumpsi*intkm^2*S0i2,strata.jumps,nstrata)
	  var.resmean1 <- intkm^2*var.cumhazMG+var.intkm2cumhaz-2*intkm*var.intkmcumhaz

	  ### variance of baseline term  \int_0^t 1/Y^2 \int_s^t F_i(u) du  dN^-i
	  var.intF1cumhaz <- cumsumstrata(jumpsni*intF1*S0i2,strata.jumps,nstrata)
	  var.intF12cumhaz <- cumsumstrata(jumpsni*intF1^2*S0i2,strata.jumps,nstrata)
	  var.resmean2 <- intF1^2*var.cumhazniMG+var.intF12cumhaz-2*intF1*var.intF1cumhaz

	  var.intF1 <- (var.resmean1+var.resmean2)

          ## possibly negative due to rounding errors
	  var.intF1[var.intF1<0] <- 0
	  se.intF1 <- var.intF1^.5
	  se.years.lostF1 <- cbind(se.years.lostF1,se.intF1) # }}}
	  }

          ### variance of baseline term  \int_0^t 1/Y^2 ( IF(t)-IF(s) - (t-s) (1-Fn1(s))) dN_1^i{{{
	  vars.1 <- cumsumstrata(jumpsi*intF1^2*S0i2,strata.jumps,nstrata)
	  vars.2 <- cumsumstrata(jumpsi*intF1*S0i2,strata.jumps,nstrata)
	  vars.11 <- intF1^2*var.cumhazMG+vars.1-2*intF1*vars.2

	  vars.3 <- cumsumstrata(jumpsi*F1n1^2*S0i2,strata.jumps,nstrata)
	  vars.4 <- cumsumstrata(jumpsi*F1n1^2*jumptimes^2*S0i2,strata.jumps,nstrata)
	  vars.5 <- cumsumstrata(jumpsi*F1n1^2*jumptimes*S0i2,strata.jumps,nstrata)
	  vars.21 <- jumptimes^2*vars.3+vars.4-2*jumptimes*vars.5

          vars.6 <- cumsumstrata(jumpsi*F1n1*S0i2,strata.jumps,nstrata)
	  vars.7 <- cumsumstrata(jumpsi*F1n1*intF1*S0i2,strata.jumps,nstrata)
	  vars.8 <- cumsumstrata(jumpsi*F1n1*jumptimes*S0i2,strata.jumps,nstrata)
	  vars.9 <- cumsumstrata(jumpsi*F1n1*intF1*jumptimes*S0i2,strata.jumps,nstrata)
	  vars.31 <- jumptimes*intF1*vars.6+vars.9-intF1*vars.8-jumptimes*vars.7
 	  varsj1 <- vars.11+vars.21-2*vars.31

          ### variance of baseline term  \int_0^t 1/Y^2 ( IF(t)-IF(s) - (t-s) F1(s)) dN_n1^i
	  vars.1 <- cumsumstrata(jumpsni*intF1^2*S0i2,strata.jumps,nstrata)
	  vars.2 <- cumsumstrata(jumpsni*intF1*S0i2,strata.jumps,nstrata)
	  vars.11 <- intF1^2*var.cumhazniMG+vars.1-2*intF1*vars.2

	  vars.3 <- cumsumstrata(jumpsni*F1^2*S0i2,strata.jumps,nstrata)
	  vars.4 <- cumsumstrata(jumpsni*F1^2*jumptimes^2*S0i2,strata.jumps,nstrata)
	  vars.5 <- cumsumstrata(jumpsni*F1^2*jumptimes*S0i2,strata.jumps,nstrata)
	  vars.21 <- jumptimes^2*vars.3+vars.4-2*jumptimes*vars.5

          vars.6 <- cumsumstrata(jumpsni*F1*S0i2,strata.jumps,nstrata)
	  vars.7 <- cumsumstrata(jumpsni*F1*intF1*S0i2,strata.jumps,nstrata)
	  vars.8 <- cumsumstrata(jumpsni*F1*jumptimes*S0i2,strata.jumps,nstrata)
	  vars.9 <- cumsumstrata(jumpsni*F1*intF1*jumptimes*S0i2,strata.jumps,nstrata)
	  vars.31 <- jumptimes*intF1*vars.6+vars.9-intF1*vars.8-jumptimes*vars.7
	  varsnj1 <- vars.11+vars.21-2*vars.31

	  varss <-  varsj1+varsnj1
          varss[varss<0] <- 0
	  se.intF1m <- varss^.5
	  se.years.lostF1m <- cbind(se.years.lostF1m,se.intF1m)
# }}}

	  if (pepemori==1) {
          ### variance Pepe-Mori {{{
          ### variance of dN_1 term  \int_0^t 1/Y^2   dN_n1^i
	  vars.1 <- cumsumstrata(jumpsi*intF1^2*S0i2,strata.jumps,nstrata)
	  vars.2 <- cumsumstrata(jumpsi*intF1*S0i2,strata.jumps,nstrata)
	  vars.11 <- intF1^2*var.cumhazMG+vars.1-2*intF1*vars.2

	  vars.4 <- cumsumstrata(jumpsi*jumptimes^2*S0i2,strata.jumps,nstrata)
	  vars.5 <- cumsumstrata(jumpsi*jumptimes*S0i2,strata.jumps,nstrata)
	  vars.21 <- F1n1^2*(jumptimes^2*var.cumhazMG+vars.4-2*jumptimes*vars.5)

          vars.6 <- cumsumstrata(jumpsi*S0i2,strata.jumps,nstrata)
	  vars.7 <- cumsumstrata(jumpsi*intF1*S0i2,strata.jumps,nstrata)
	  vars.8 <- cumsumstrata(jumpsi*jumptimes*S0i2,strata.jumps,nstrata)
	  vars.9 <- cumsumstrata(jumpsi*intF1*jumptimes*S0i2,strata.jumps,nstrata)
	  vars.31 <- F1n1*(jumptimes*intF1*vars.6+vars.9-intF1*vars.8-jumptimes*vars.7)
 	  varsj1 <- vars.11+vars.21-2*vars.31

          ### variance of baseline term  \int_0^t 1/Y^2 ( IF(t)-IF(s)) dN_n1^i
	  vars.1 <- cumsumstrata(jumpsni*intF1^2*S0i2,strata.jumps,nstrata)
	  vars.2 <- cumsumstrata(jumpsni*intF1*S0i2,strata.jumps,nstrata)
	  vars.11 <- intF1^2*var.cumhazniMG+vars.1-2*intF1*vars.2

	  varspm <- vars.11+varsj1

          varspm[varspm<0] <- 0
	  se.intF1pm <- varspm^.5
	  se.years.lostF1pm <- cbind(se.years.lostF1pm,se.intF1pm)
# }}}
	  }
 }
 years.lostF1 <- cbind(jumptimes,years.lostF1)
 colnames(years.lostF1) <- c("time",paste("intF_",causes,sep=""))

  ### make output at specified times
  if (!is.null(times)) {
    intF1times <- years.lostF1[newtimes,]
    years.lost <- apply(intF1times[,-1,drop=FALSE],1,sum)
    if (pka==1) se.intF1times <- se.years.lostF1[newtimes,-1]
    se.intF1mtimes <- se.years.lostF1m[newtimes,]
    stratatimes <- strata.jumps[newtimes]
    intF1mtimes <- cbind(stratatimes,intF1times,se.intF1mtimes,years.lost)
    colnames(intF1mtimes) <- c("strata","times",paste0("intF_",causes),paste0("se.intF_",causes),"total-years-lost")
    rownames(intF1mtimes) <- rep(x$strata.level,length(times));
    intF1mtimes=data.frame(intF1mtimes)
    if (pka==1) {
	    intF1pkatimes <- cbind(stratatimes,intF1times,se.intF1times)
            colnames(intF1pkatimes) <- c("strata","times",paste0("intF_",causes),paste0("se.intF_",causes))
            intF1pkatimes=data.frame(intF1times)
    } else intF1pkatimes <- NULL
    if (pepemori==1) {
          se.intF1pmtimes <- se.years.lostF1pm[newtimes,]
          intF1pmtimes <- cbind(stratatimes,intF1times,se.intF1pmtimes)
          colnames(intF1pmtimes) <- c("strata","times",paste0("intF_",causes),paste0("se.intF_",causes))
         intF1pmtimes=data.frame(intF1pmtimes)
    } else intF1pmtimes <- NULL
  } else coef <- var <- intF1pmtimes <-intF1mtimes <- intF1pkatimes <- NULL

 se.years.lostF1 <- cbind(jumptimes,se.years.lostF1m)
 colnames(se.years.lostF1) <- c("time",paste("intF_",causes,sep=""))

## name things to make use of other programs
 out <- list(cumhaz=years.lostF1,se.cumhaz=se.years.lostF1,
       time=jumptimes, strata=strata.jumps,nstrata=nstrata,
       jumps=1:length(km),strata.name=x$strata.name,
       strata.level=x$strata.level,
       intkmtimes=intF1mtimes, intF1times=intF1mtimes,
       intF1pmtimes=intF1pmtimes, intF1pkatimes=intF1pkatimes,causes=causes
       )
class(out) <- c("resmean_phreg")
return(out)
}# }}}

##' @export
summary.resmean_phreg <- function(object,level=0.95,contrast=NULL,...)
{# {{{

if (is.null(object$intkmtimes)) {
	p <- ncol(object$cumhaz)
	outl <- basecumhaz(object,columns=1:p) 
	outl$strata.name  <- object$strata.name
	outl$strata.level <- object$strata.level
	outl$causes       <- object$causes
} else  {

out <- object$intkmtimes
if (ncol(out)==5) {
   mu <- out[,3]; se <- out[,4];
   xx <- conftype(mu,se,conf.int=level,...)
   lower <- xx$lower
   upper <- xx$upper
   years.lost <- out[,5]
   out <- cbind(out[,-5],lower,upper,years.lost)
   if (!is.null(contrast)) {
	   test <- estimate(object,f=contrast)
	   out <- list(estimates=out,test=test)
   }
   outl <- out
} else {
	p <- ncol(out)
        nn <- names(out)[1:2]
        nl <- names(out)[p]
        outl <- list()
        oute <- list()
	k <- 1
	for (i in object$causes) {
                   name <- paste("intF_",i,sep="")
                   sename <- paste("se.intF_",i,sep="")
		   mu <- out[,name];
		   se <- out[,sename];
                   xx <- conftype(mu,se,conf.int=level,...)
		   loweri <- paste0("lower_",name)
		   upperi <- paste0("upper_",name)
		   out[,loweri] <- xx$lower
		   out[,upperi] <- xx$upper
		   xo <- out[,c(nn,name,sename)]
		   xo[,loweri] <- xx$lower
		   xo[,upperi] <- xx$upper
		   oute[[name]] <- xo
		   if (!is.null(contrast)) {
             test <- estimate(coef=mu,vcov=diag(se^2),f=contrast)
		   testname <- paste0("test",name)
		   outl[[testname]] <- test
		   }
	}
###        outl$estimate <- out
	outl$estimate <- oute
	outl$total.years.lost <- out[,nl]
}
}

return(outl)
}# }}}


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

##' @export
plot.resmean_phreg <- function(x, se=FALSE,time=NULL,add=FALSE,ylim=NULL,xlim=NULL,
                               lty=NULL,col=NULL,lwd=NULL,legend=TRUE,legend.args=list(),
                               ylab=NULL,xlab=NULL,
                               polygon=TRUE,level=0.95,stratas=NULL,robust=FALSE,years.lost=FALSE,cause=1,
                               conf.type=c("log","plain"),...) {# {{{

	if (inherits(x,"phreg") & is.null(ylab)) ylab <- "Cumulative hazard"
	if (inherits(x,"km") & is.null(ylab)) ylab <- "Survival probability"
	if (inherits(x,"cif") & is.null(ylab)) ylab <- "Probability"
	if (inherits(x,"resmean_phreg") & is.null(ylab)) ylab <- "Restricted residual mean life"
	if (inherits(x,"resmean_phreg") & !is.null(x$intF1times)) ylab <- "Years lost up to t: t - E(min(T,t))"
	if (years.lost) ylab <- "Years lost up to t: t - E(min(T,t))"
	if (is.null(xlab)) xlab <- "time"
	ci.level <- level
   level <- -qnorm((1-level)/2)
   if (years.lost) rr <- range(x$cumhaz[,1]-x$cumhaz[,cause+1])  else rr <- range(x$cumhaz[,cause+1])
   strat <- x$strata[x$jumps]
   ylimo <- ylim
   if (is.null(ylim)) ylim <- rr
   if (is.null(xlim)) xlim <- range(x$cumhaz[,1])
   if (se==TRUE) {
      if (is.null(x$se.cumhaz) & is.null(x$robse.cumhaz) )
		   stop("phreg must be with cumhazard=TRUE\n");
   if (years.lost) rrse <- range(c(x$cumhaz[,1]-x$cumhaz[,cause+1]+level*x$se.cumhaz[,cause+1])) else
       rrse <- range(c(x$cumhaz[,cause+1]+level*x$se.cumhaz[,cause+1]))
       if (is.null(ylimo)) ylim <- rrse
   }

   ## all strata
   if (is.null(stratas)) stratas <- 0:(x$nstrata-1)
   ltys <- lty
   cols <- col
   lwds <- lwd

   if (length(stratas)>0 & x$nstrata>1) { ## with strata
   lstrata <- x$strata.level[(stratas+1)]
   ## stratn <-  substring(x$strata.name,8,nchar(x$strata.name)-1)
   ## stratnames <- paste(stratn,lstrata,sep=":")
   stratnames <- lstrata

      if (!is.matrix(lty)) {
         if (is.null(lty)) ltys <- 1:length(stratas) else if (length(lty)!=length(stratas)) ltys <- rep(lty[1],length(stratas))
      } else ltys <- lty
      if (!is.matrix(col)) {
         if (is.null(col)) cols <- 1:length(stratas) else
		 if (length(col)!=length(stratas)) cols <- rep(col[1],length(stratas))
      } else cols <- col
      if (!is.matrix(lwd)) {
         if (is.null(lwd)) lwds <- rep(1,length(stratas)) else
		 if (length(lwd)!=length(stratas)) lwds <- rep(lwd[1],length(stratas))
      } else lwds <- lwd
   } else {
     stratnames <- "Baseline"
     if (is.matrix(col))  cols <- col
     if (is.null(col)) cols <- 1  else cols <- col[1]
     if (is.matrix(lty))  ltys <- lty
     if (is.null(lty)) ltys <- 1  else ltys <- lty[1]
     if (is.matrix(lwd))  lwds <- lwd
     if (is.null(lwd)) lwds <- 1  else lwds <- lwd[1]
   }

  if (!is.matrix(ltys))  ltys <- cbind(ltys,ltys,ltys)
  if (!is.matrix(cols))  cols <- cbind(cols,cols,cols)
  if (!is.matrix(lwds))  lwds <- cbind(lwds,lwds,lwds)

  if (years.lost) x$cumhaz[,cause+1] <- x$cumhaz[,1]-x$cumhaz[,cause+1]
  first <- 0
  for (i in seq(stratas)) {
      j <- stratas[i]
        cumhazard <- x$cumhaz[strat==j,c(1,cause+1),drop=FALSE]
        if (!is.null(cumhazard)) {
	if (nrow(cumhazard)>1) {
        if (add | first==1)
        lines(cumhazard,type="l",lty=ltys[i,1],col=cols[i,1],lwd=lwds[i,1])
       else {
	  first <- 1
          plot(cumhazard,type="l",lty=ltys[i,1],col=cols[i,1],lwd=lwds[i,1],ylim=ylim,ylab=ylab,xlab=xlab,xlim=xlim,...)
       }
       if (se==TRUE) {
	    if (robust==TRUE) secumhazard  <- x$robse.cumhaz[strat==j,c(1,cause+1),drop=FALSE]
	    else secumhazard <- x$se.cumhaz[strat==j,c(1,cause+1),drop=FALSE]
            xx <- conftype(cumhazard[,2],secumhazard[,2],conf.type=conf.type[1],restrict="positive",conf.int=ci.level)
	    ul <-cbind(cumhazard[,1],xx$upper)
	    nl <-cbind(cumhazard[,1],xx$lower)
	    ul[is.na(ul)] <- 0
	    nl[is.na(nl)] <- 0
		 if (inherits(x,"km")) { ul[,2] <- x$upper[x$strata==j];
		                          nl[,2] <- x$lower[x$strata==j];
		                          wna <- which(is.na(ul[,2]))
		                          ul[wna,2] <- 0
		                          nl[wna,2] <- 0

		 }
	      if (!polygon) {
		  lines(nl,type="l",lty=ltys[i,2],col=cols[i,2],lwd=lwds[i,2])
		  lines(ul,type="l",lty=ltys[i,3],col=cols[i,3],lwd=lwds[i,3])
	      } else {
                 ## type="l" confidence regions
		 ll <- length(nl[,1])
		 timess <- nl[,1]
		 tt <- c(timess,rev(timess))
		 yy <- c(nl[,2],rev(ul[,2]))
		 col.alpha<-0.1
		 col.ci<-cols[i,]
		 col.trans <- sapply(col.ci, FUN=function(x)
		   do.call(grDevices::rgb,as.list(c(grDevices::col2rgb(x)/255,col.alpha))))
		 polygon(tt,yy,lty=0,col=col.trans)
	      }
        }
     }
     }
    }
     if (legend & (!add))  {
       if (is.null(legend.args$x)) {
         legend.args$x <- ifelse (inherits(x,"km"), "topright", "topleft")
       }
       if (is.null(legend.args$col)) legend.args$col <- cols[,1]
       if (is.null(legend.args$lty)) legend.args$lty <- ltys[,1]
       if (is.null(legend.args$legend)) legend.args$legend <- stratnames
       do.call(graphics::legend, legend.args)
     }

}# }}}


# }}}

##' IPTW Cox Regression (Inverse Probability of Treatment Weighted)
##'
##' Fits a Cox model with treatment weights \deqn{w(A) = \sum_a I(A=a)/\pi(a|X)}, where
##' \deqn{\pi(a|X) = P(A=a|X)}.
##'
##' Standard errors are computed via influence functions that are returned as the IID argument.
##' Propensity scores are fitted using either logistic regression (\code{glm}) or the multinomial
##' model (\code{mlogit}) when there are more than two treatment categories.
##'
##' The treatment variable must be a factor and is identified on the RHS of the \code{treat.model}.
##' Recurrent events can be considered with a start-stop structure, requiring \code{cluster(id)}.
##' Robust standard errors are computed in all cases.
##'
##' Time-dependent propensity score weights can be computed when \code{treat.var} is used. This weight
##' be 1 at the time of first (A_0) and 2nd treatment (A_1), then uses weights \deqn{w_0(A_0) * w_1(A_1)^{t>T_r}} where \deqn{T_r} is
##' time of 2nd randomization. The weights are constructed using a \code{glm} or \code{mlogit} model based on the data where 
##' \code{treat.var=1}. The propensity score can be constructed for any number of treatments in a similar manner. 
##'
##' @param formula Formula for \code{phreg}.
##' @param data Data frame for risk averaging.
##' @param treat.model Propensity score model (binary or multinomial).
##' @param treat.var A 1/0 variable indicating when treatment is given (for time-dependent weights).
##' @param weights Optional weights to multiply with the IPTW weights.
##' @param estpr (=1, default) to estimate propensity scores and include their uncertainty in the influence function.
##' @param pi0 Fixed simple weights (if \code{estpr=0}).
##' @param se.cluster To compute GEE-type standard errors when additional cluster structure is present.
##' @param ... Arguments for \code{phreg} call.
##'
##' @return An object of class \code{"phreg"} with additional IPTW components:
##' \item{IID}{Influence functions including propensity score uncertainty.}
##' \item{iptw}{IPTW weights used.}
##' \item{naive.var}{Naive variance ignoring propensity score uncertainty.}
##'
##' @author Thomas Scheike
##' @examples
##' data <- mets:::simLT(0.7, 100, beta = 0.3, betac = 0, ce = 1, betao = 0.3)
##' dfactor(data) <- Z.f ~ Z
##' out <- phreg_IPTW(Surv(time, status) ~ Z.f, data = data, treat.model = Z.f ~ X)
##' summary(out)
##' @export
phreg_IPTW <- function (formula, data,treat.model = NULL, treat.var = NULL,weights = NULL, estpr = 1, pi0 = 0.5,se.cluster=NULL,...)
{# {{{
    cl <- match.call()
    m <- match.call(expand.dots = TRUE)[1:3]
    des <- proc_design(
        formula,
        data = data,
        specials = c("offset", "weights", "cluster","strata"),
        intercept = FALSE
    )
    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
    strata <- des$strata
    if (!is.null(strata)) strata.name <- names(des$xlevels)
    else strata.name <- NULL
    pos.strata <- NULL
    des.weights <- des$weights
    des.offset  <- des$offset
    id      <- des$cluster
    ## no use of
    pos.cluster <- NULL

 call.id <- id;
 conid <- construct_id(id,length(exit))
 name.id <- conid$name.id; id <- conid$id; nid <- conid$nid

 ## take offset and weight first from formula, but then from arguments
 offset <- NULL
  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(se.cluster)) {
        sds <- sort(unique(se.cluster))
        sid <- length(sds)
        if (is.numeric(se.cluster))
            se.cluster <- fast.approx(sds, se.cluster) - 1
        else se.cluster <- as.integer(factor(se.cluster, labels = seq(sid))) - 1
    }

    id <- id + 1
    nid <- length(unique(id))
    data$id__ <- id
    data$cid__ <- cumsumstrata(rep(1, length(id)), id - 1, nid)
    treats <- function(treatvar) {
        treatvar <- droplevels(treatvar)
        nlev <- nlevels(treatvar)
        nlevs <- levels(treatvar)
        ntreatvar <- as.numeric(treatvar)
        return(list(nlev = nlev, nlevs = nlevs, ntreatvar = ntreatvar))
    }
    fittreat <- function(treat.model, data, id, ntreatvar, nlev) {
        if (nlev == 2) {
            treat.model <- drop.specials(treat.model, "cluster")
            treat <- glm(treat.model, data, family = "binomial")
            iidalpha <- lava::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 <- lava::iid(treat)
            pal <- predict(treat, data, se = 0, response = FALSE)
            ppp <- (pal/pal[, 1])
            spp <- 1/pal[, 1]
        }
        Xtreat <- model.matrix(treat.model, data)
        tvg2 <- 1 * (ntreatvar >= 2)
        pA <- c(mdi(pal, 1:length(ntreatvar), ntreatvar))
        pppy <- c(mdi(ppp, 1:length(ntreatvar), 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
        out <- list(iidalpha = iidalpha, pA = pA, Dp = Dp, pal = pal,
            ppp = ppp, spp = spp, id = id, DPai = DPai)
        return(out)
    }
    expit <- function(x) 1/(1 + exp(-x))
    if (!is.null(treat.var)) {
        weightWT <- data[, treat.var]
        whereW <- which(weightWT == 1)
        CountW <- cumsumstrata(weightWT, id - 1, nid)
        dataW <- data[whereW, ]
        idW <- id[whereW]
    } else {
        whereW <- 1:nrow(data)
        dataW <- data
        idW <- id
        CountW <- cumsumstrata(rep(1,nrow(data)), id-1,nid)
    }
    treat.name <- all.vars(treat.model)[1]
    treatvar <- dataW[, treat.name]
    if (!is.factor(treatvar))
        stop(paste("treatment=", treat.name, " must be coded as factor \n",
            sep = ""))
    treats <- treats(treatvar)
    wlPA <- ww <- rep(1, nrow(data))
    idWW <- mystrata2index(cbind(id, CountW))
    if (estpr[1] == 1) {
        fitt <- fittreat(treat.model, dataW, idW, treats$ntreatvar, treats$nlev)
        iidalpha0 <- fitt$iidalpha
        wPA <- c(fitt$pA)
        DPai <- fitt$DPai
    } else {
        if (length(pi0)==length(treats$ntreatvar)) wPA <- pi0
	else wPA <- ifelse(treats$ntreatvar==2,pi0[1],1-pi0[1])
        ## pi0 <- rep(pi0, treats$nlev)
        DPai <- matrix(0, nrow(data), 1)
    }
    ww <- rep(1, nrow(data))
    ww[whereW] <- wPA
    wlPA <- exp(cumsumstrata(log(ww), idWW - 1, attr(idWW, "nlevel")))
    wwt <- c(exp(cumsumstrata(log(ww), id - 1, nid)))
    ## P(t) = P_0 * P_1^(I(t>T1)), time-dependent weights
    ## DP = P(t) \sum_j P_j I(t> TJ) (-DP_j/P_j^2)
    if (estpr[1] == 1) {
        DPait <- matrix(0, nrow(data), ncol(DPai))
        DPait[whereW, ] <- DPai
        DPait <- apply(DPait * c(wlPA), 2, cumsumstrata, id - 1, nid)/wwt
    } else DPait <- NULL
    if (is.null(weights)) ww <- 1/wwt else ww <- weights/wwt
    phw <- phreg(formula, data, weights = ww, Z = DPait, ...)

###    check.derivative <- 0
###	if (check.derivative == 1) { ## {{{
###	### for checking derivative
###	fpar <- glm(treat.model,dataw,family=binomial)
###	mm <- model.matrix(treat.model,dataw)
###	cpar <- coef(fpar)
###
###	ff <- function(par,base=0) {
###	pa <-        expit(mm %*% par)
###	www <- ifelse(dataw[,treat.name] == "1", pa, 1 - pa)
###	ww <- rep(1, nrow(data))
###	ww[wherew] <- www
###	wlpa <- exp(cumsumstrata(log(ww), idww - 1, attr(idww, "nlevel")))
###	wwwt <- exp(cumsumstrata(log(ww), id - 1, nid))
###
###	pp <- phreg(formula,data,weights=1/wwwt,no.opt=true,beta=coef(phw))
###	if (base==1) po <- c(pp$cumhaz[,2]) else po <- pp$gradient
###	return(po)
###	}
###
###	print(ff(cpar))
###	gf <- jacobian(ff,cpar)
###	print(t(gf))
###        ###
###        print(ff(cpar,base=1))
###	gf <- jacobian(ff,cpar,base=1)
###	print(gf)
###	print("___________________________________");
###	} ## }}}

if (estpr[1] == 1) {
	xx <- phw$cox.prep
	nid <- max(xx$id)
	S0i <- rep(0, length(xx$strata))
	wPAJ <- xx$weights[xx$jumps+1]*xx$caseweights[xx$jumps+1]
	Xt <- xx$X
	S0 <- phw$S0 * wPAJ
	S0i[xx$jumps + 1] <- 1/S0
	U <- E <- matrix(0, nrow(xx$X), phw$p)
	U[xx$jumps + 1, ] <- phw$U/wPAJ
	E[xx$jumps + 1, ] <- phw$E


        if (phw$p>0) {
	rr <- c(xx$sign * exp(Xt %*% coef(phw) + xx$offset) * xx$weights)
	rrnw <- c(xx$sign * exp(Xt %*% coef(phw) + xx$offset))
        } else {
	rr <- c(xx$sign * exp(xx$offset) * xx$weights)
	rrnw <- c(xx$sign * exp(xx$offset))
        }
	DWX = .Call("vecMatMat", xx$Z, Xt)$vXZ
	S1 = apply(Xt * rr, 2, revcumsumstrata, xx$strata, xx$nstrata)
	###S00 = revcumsumstrata( rr, xx$strata, xx$nstrata)
	DS1 = apply(DWX * rrnw, 2, revcumsumstrata, xx$strata, xx$nstrata)
	DS0 = apply(xx$Z * rrnw, 2, revcumsumstrata, xx$strata, xx$nstrata)
	if (phw$p>0) {
		DS0S1 = .Call("vecMatMat", DS0[xx$jumps + 1, , drop = FALSE],S1[xx$jumps + 1, , drop = FALSE])$vXZ
		DUa2 <- apply(wPAJ * DS1[xx$jumps + 1, , drop = FALSE]/c(S0),2, sum) - apply(wPAJ * DS0S1/c(S0^2), 2, sum)
		DUa2 <- matrix(DUa2, ncol(fitt$DPai), phw$p)
		DUa1 <- t(xx$Z[xx$jumps + 1, ]) %*% (phw$U/wPAJ)
		DUa <- DUa1 - DUa2
		iidpal <- iidalpha0 %*% DUa
		iidbeta <- lava::iid(phw) + iidpal %*% phw$ihess
		phw$DUa <- DUa
		phw$IID <- iidbeta
		phw$naive.var <- phw$var
		phw$var <- crossprod(iidbeta)
	} else iidbeta <- NULL

        ###
	DAw <- apply(xx$caseweights[xx$jumps+1]*xx$Z[xx$jumps + 1, ,drop=FALSE]/c(S0),2,cumsumstrata,phw$strata.jumps,xx$nstrata)
	DA2 <- apply(wPAJ*DS0[xx$jumps + 1, , drop = FALSE]/c(S0)^2,2,cumsumstrata,phw$strata.jumps,xx$nstrata)
	DAt <- 1*(DAw-DA2)
	phw <- robust_phreg(phw,beta.iid=iidbeta)
	varA <- phw$robse.cumhaz[,2]^2
	phw$naive.se.cumhaz <- phw$robse.cumhaz
	vtheta <- crossprod(iidalpha0)
        varthetat <-   rowSums((DAt %*% vtheta)*DAt)
        ###
        ww <- xx$caseweights*xx$weights
	S0i2 <- rep(0,length(xx$strata))
        S0i2[xx$jumps+1] <- 1/(phw$S0^2*ww[xx$jumps+1])
        cumS0i2 <- c(cumsumstrata(S0i2,xx$strata,xx$nstrata))
        xxx <- (S0i-rr*cumS0i2)
	id <- xx$id
	mid <- max(xx$id)+1
        thetat <- iidalpha0[id+1,,drop=FALSE]
        covk1 <- apply(S0i*thetat,2,cumsumidstratasum,id,mid,xx$strata,xx$nstrata,type="sum")
        covk2 <- apply(rr*thetat,2,revcumsumidstratasum,id,mid,xx$strata,xx$nstrata,type="lagsum")
        ###
        covk1 <- apply(S0i*thetat,2,cumsumstrata,xx$strata,xx$nstrata)
        covk2 <- apply(rr*thetat,2,revcumsumstrata,xx$strata,xx$nstrata)
        ###
        covk2 <- covk2*cumS0i2
        covv <- (covk1-covk2)[xx$jumps+1,,drop=FALSE]
        covvt <- 2*apply(covv*DAt,1,sum)
        varA <- varA+varthetat+2*apply(covv*DAt,1,sum)

	Ht <- NULL
	if (phw$p>0) {
		covbetatheta <- t(iidalpha0) %*%  iidbeta
		Ht <- apply(E*S0i,2,cumsumstrata,xx$strata,xx$nstrata)
		Ht <- Ht[xx$jumps+1,,drop=FALSE]
		covvBT <- 2* rowSums((Ht %*% t(covbetatheta))*DAt)
		varA <- varA + covvBT
	}
	phw$robse.cumhaz[,2] <- varA^.5
	phw$se.cumhaz[,2] <- varA^.5
	phw$var.cumhaz <- cbind(phw$se.cumhaz[,1],varA)
	resAiid <- list(DAt=DAt,Ht=Ht,iidalpha0=iidalpha0,iidbeta=phw$IID)
	phw$resAiid <- resAiid
	phw$iptw <- ww
} else {
   phw$iptw <- ww
   phw <- robust_phreg(phw)
   phw$naive.se.cumhaz <- phw$se.cumhaz
   phw$se.cumhaz <- phw$robse.cumhaz
   phw$naive.var <- phw$var
}


if (is.matrix(phw$IID))
	if (nrow(phw$IID)==length(name.id)) rownames(phw$IID) <- name.id

if (!is.null(se.cluster)) {
	phw$IID.simple <- phw$IID
	phw$var.simple <- phw$var
	phw$IID <- apply(phw$IID,2,sumstrata,se.cluster,sid)
	phw$var <- crossprod(phw$IID)
	phw$se.cluster <- se.cluster
}
class(phw) <- c("phreg","IPTW")

return(phw)
}# }}}


##' G-Estimator for Cox and Fine-Gray Models
##'
##' Computes the G-estimator (G-formula) for standardized survival or cumulative incidence estimates:
##' \deqn{ \hat S(t, A=a) = n^{-1} \sum_i \hat S(t, A=a, Z_i) }
##'
##' Based on a \code{phreg} or \code{cifreg} object. Provides influence functions for these risk estimates,
##' allowing for standard error computation.
##'
##' 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}.
##'
##' @param x Object of class \code{"phreg"} or \code{"cifreg"}.
##' @param data Data frame for risk averaging. Must be part of the data used for fitting unless \code{same.data=FALSE}.
##' @param time Time point for estimation.
##' @param Avalues Values to compare for the first covariate \eqn{A}.
##' @param varname Name of the variable to be treated as the treatment/exposure variable (default is the first variable).
##' @param same.data Logical; assumes the same data is used for fitting and averaging.
##' @param First Logical; if \code{TRUE}, uses only the first record for G-averaging (useful for start-stop structures).
##'
##' @return An object of class \code{"survivalG"} containing:
##' \item{risk}{Standardized risk estimates.}
##' \item{risk.iid}{Influence functions for the risk estimates.}
##' \item{difference}{Pairwise differences in risks.}
##' \item{ratio}{Risk ratios.}
##' \item{survival.ratio}{Survival ratios (for \code{phreg}).}
##' \item{survival.difference}{Survival differences (for \code{phreg}).}
##'
##' @author Thomas Scheike
##' @aliases survivalGtime
##' @examples
##' data(bmt)
##' bmt$time <- bmt$time + runif(408) * 0.001
##' bmt$event <- (bmt$cause != 0) * 1
##' bmt$id <- 1:408
##' dfactor(bmt) <- tcell.f ~ tcell
##'
##' # Fine-Gray model
##' fg1 <- cifreg(Event(time, cause) ~ tcell.f + platelet + age, bmt,
##'               cause = 1, cox.prep = TRUE, propodds = NULL)
##' summary(survivalG(fg1, bmt, 50))
##'
##' \donttest{ ## Reduce Ex.Timings
##' # Cox model
##' ss <- phreg(Surv(time, event) ~ tcell.f + platelet + age, bmt)
##' summary(survivalG(ss, bmt, 50))
##'
##' # Stratified Cox model
##' ss <- phreg(Surv(time, event) ~ strata(tcell.f) + platelet + age, bmt)
##' summary(survivalG(ss, bmt, 50))
##'
##' # Time-varying G-estimates
##' sst <- survivalGtime(ss, bmt, n = 50)
##' plot(sst)
##'
##' # Among treated (specify id to link influence functions)
##' ss <- phreg(Surv(time, event) ~ tcell.f + platelet + age + cluster(id), bmt)
##' summary(survivalG(ss, subset(bmt, tcell == 1), 50))
##' }
##' @aliases survivalGtime
##' @export
survivalG <- function(x,data,time=NULL,Avalues=NULL,varname=NULL,same.data=TRUE,First=FALSE)
{# {{{
if (is.null(time)) stop("Give time for estimation of survival/cumulative incidence\n")
if (inherits(x,c("cifreg","phreg","recreg")))
Aiid <- iidBaseline(x,time=time) else stop("Must be cifregFG/phreg/recreg object \n");

### 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]

Alevels <- NULL
if (is.factor(treatvar)) {
   ## treatvar, levels to look at
   if (is.null(Avalues)) Alevels <- levels(treatvar) else Alevels <- Avalues
} else {
   Alevels <- Avalues
}
if (is.null(Alevels)) stop("must either have a factor as first variable or give Avalues for risk average")

## for recreg take first record only of each subject
cid <- countID(data.frame(id=x$id))
if (inherits(x,"recreg") | First) {
    FirstId <- which(cid$Countid==1)
    data <- data[FirstId,]
}

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


k <- 1; risks <- c(); DariskG <- list()
for (a in Alevels) { ## {{{
   datA[,treat.name] <- a
   pp <- predict(x,datA,time,se=0)
   Xbase <- 1*outer(pp$strata,0:(x$nstrata-1),"==")

 if (inherits(x,"cifreg")) {
    ps0 <- c(pp$cif);
    Dma  <- cbind(c(pp$RR)*c(1-ps0)*Xbase,c((1-ps0)*pp$cumhaz)*pp$X);
 } else if (inherits(x,"recreg")) {
    ps0 <- pp$cumhaz;
    Dma <-  cbind(c(pp$RR)*Xbase,c(pp$cumhaz)*pp$X)
 } else if (inherits(x,"phreg"))  {
    ps0 <- c(pp$surv);
    Dma  <- -cbind(c(pp$RR)*ps0*Xbase,c(ps0*pp$cumhaz)*pp$X);
 }
 risks <- cbind(risks,ps0)
 DariskG[[k]] <- apply(Dma,2,sum)
 k <- k+1
} ## }}}

predictAiid <- NULL
###
Grisk <- apply(risks,2,mean)
risk.iid  <- t(t(risks)-Grisk)
### order after all id in data
nid <- max(x$id)+1
ndata <- length(unique(id))

## after id.data, if sub-data then still ok sorted after id.data=0:nid
risk.iid <- apply(risk.iid,2,sumstrata,id,nid)/ndata

## sorted after x$id, so is risk.iid
coxiid <- cbind(Aiid$base.iid,Aiid$beta.iid)

if (same.data) {
   for (a in seq_along(Alevels)) risk.iid[,a] <- risk.iid[,a]+ coxiid %*% DariskG[[a]]/ndata
   vv <- crossprod(risk.iid)
} else {
   predictAiid <- matrix(0,ndata,ncol(risks))
   for (a in seq_along(Alevels))  {
###	risk.iid[,a] <- risk.iid[,a]
	predictAiid[,a] <- coxiid %*% DariskG[[a]]/ndata
   }
   risk.iid <- rbind(risk.iid,predictAiid)
   vv <- crossprod(risk.iid)
}

if (inherits(x,"cifreg") | inherits(x,"recreg")) {
out <- estimate(coef=Grisk,vcov=vv,labels=paste("risk",Alevels,sep=""))
ed <- estimate(coef=Grisk,vcov=vv,f=function(p) (p[-1])-(p[1]))
rd <- estimate(coef=Grisk,vcov=vv,f=function(p) log(p[-1]/p[1]),null=0)
out <- list(risk.iid=risk.iid,risk=out,difference=ed,ratio=rd,vcov=vv)
} else if (inherits(x,"phreg"))  {
out <- estimate(coef=1-Grisk,vcov=vv,labels=paste("risk",Alevels,sep=""))
sout <- estimate(coef=Grisk,vcov=vv,labels=paste("risk",Alevels,sep=""))
ed <- estimate(coef=Grisk,vcov=vv,f=function(p) (1-p[-1])-(1-p[1]))
rd <- estimate(coef=Grisk,vcov=vv,f=function(p) log((1-p[-1])/(1-p[1])),null=0)
srd <- estimate(coef=Grisk,vcov=vv,f=function(p) log(p[-1]/p[1]),null=0)
ssd <- estimate(coef=Grisk,vcov=vv,f=function(p) p[-1]-p[1])
out <- list(risk.iid=risk.iid,survivalG=sout,risk=out,difference=ed,ratio=rd,
	    survival.ratio=srd, survival.difference=ssd,vcov=vv)
}

class(out) <- "survivalG"
attr(out,"levels") <- Alevels
return(out)
} ## }}}

##' @export
estimate.survivalG  <- function(x,...)
{
out <-estimate(coef=x$risk$coefmat[,1],IC=x$risk.iid*nrow(x$risk.iid),...)
return(out)
}

###{{{ summary  survivalG

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

##' @export
summary.survivalG <- function(object,...) {
  res <- list(risk=object$risk,difference=object$difference,ratio=object$ratio,
	      survival.ratio=object$survival.ratio,survival.difference=object$survival.difference)
  class(res) <- "summary.survivalG"
  res
}

##' @export
print.summary.survivalG  <- function(x,...) {
    cat("G-estimator :\n")
    print(x[["risk"]],...)
    cat("\n")

    cat("Average Treatment effect: difference (G-estimator) :\n")
    print(x$difference,...)
    cat("\n")

    cat("Average Treatment effect: ratio (G-estimator) :\n")
    cat("log-ratio: \n")
    print(x$ratio$coefmat,...)
    cat("ratio: \n")
    ratio <- exp(x$ratio$coefmat[,c(1,3:4)])
    print(ratio,...)
    cat("\n")

    if (!is.null(x$survival.difference)) {
    cat("Average Treatment effect:  survival-difference (G-estimator) :\n")
    print(x$survival.difference$coefmat,...)
    cat("\n")
    }

    if (!is.null(x$survival.ratio)) {
    cat("Average Treatment effect: 1-G (survival)-ratio (G-estimator) :\n")
    cat("log-ratio: \n")
    print(x$survival.ratio$coefmat,...)
    cat("ratio: \n")
    ratio <- exp(x$survival.ratio$coefmat[,c(1,3:4)])
    print(ratio,...)
    cat("\n")
    }

}

###}}} summary

##' @export
survivalGtime <- function(x,data,time=NULL,n=100,...)
{# {{{

if (is.null(time)) {
       rr <- range(x$cumhaz[,1])
       if (!is.null(n)) time <- seq(rr[1],rr[2],length=n) else time <- x$cumhaz[,1]
}

survivalGt <- risk <- difference <- ratio <- survival.ratio <- c()

for (tt in time) {
  Gt <- survivalG(x,data,time=tt,...)
  strata <- strata(rownames(Gt$risk$coefmat))
  survivalGt <- rbind(survivalGt,cbind(tt,Gt$survivalG$coefmat))
  risk <- rbind(risk,cbind(tt,Gt$risk$coefmat))
  difference <- rbind(difference,cbind(tt,Gt$difference$coefmat))
  ratio <- rbind(ratio,cbind(tt,exp(Gt$ratio$coefmat)))
  if (!is.null(Gt$survival.ratio$coefmat))
  survival.ratio <- rbind(survival.ratio,cbind(tt,exp(Gt$survival.ratio$coefmat)))
}
  colnames(survivalGt)[1] <- "time"
  colnames(risk)[1] <- "time"
  colnames(difference)[1] <- "time"
  colnames(ratio)[1] <- "time"
  if (!is.null(survival.ratio))
  colnames(survival.ratio)[1] <- "time"
  strata <- strata(rownames(risk))
out <- list(time=time,survivalG=survivalGt,risk=risk,difference=difference,
	    ratio=ratio,survival.ratio=survival.ratio,strata=strata)

class(out) <- "survivalGtime"
return(out)
} ## }}}

##' @export
plot.survivalGtime <- function(x,type=c("survival","risk","survival.ratio","difference","ratio"),ylim=NULL,legend=NULL,...) {# {{{

  ## to deal with fine-gray based things, that do not contain survival estimates
  if ((ncol(x$survivalG)==1) & type[1]=="survival") type <- "risk"
  us <- unique(x$strata)
  cols <- 1:length(us)
  ltys <- cols
  ss0 <- x$strata==us[1]

  if (type[1]=="survival") {
  if (is.null(ylim))  ylim  <- range(x$survivalG[,c(4,5)])
  plot(x$time,x$survivalG[ss0,2],type="s",xlab="time",ylab="Survival",col=cols[1],lty=ltys[1],ylim=ylim,...)
  plotConfRegion(x$time,x$survivalG[ss0,c(4,5)],col=cols[1])

  k <- 2
for (ss in us[-1]) {
   ss0 <- x$strata==ss
   lines(x$time,x$survivalG[ss0,2],type="s",ylim=c(0,1),col=cols[k],lty=ltys[k])
   plotConfRegion(x$time,x$survivalG[ss0,c(4,5)],col=cols[k])
   k <- k+1
}
  }

  if (type[1]=="risk") {
   if (is.null(ylim))  ylim  <- range(x$risk[,c(4,5)])
   plot(x$time,x$risk[ss0,2],type="s",xlab="time",ylab="risk",col=cols[1],lty=ltys[1],ylim=ylim,...)
   plotConfRegion(x$time,x$risk[ss0,c(4,5)],col=cols[1])
   k <- 2
   for (ss in us[-1]) {
   ss0 <- x$strata==ss
   lines(x$time,x$risk[ss0,2],type="s",ylim=c(0,1),col=cols[k],lty=ltys[k])
   plotConfRegion(x$time,x$risk[ss0,c(4,5)],col=cols[k])
   k <- k+1
   }
  }

  if (type[1]=="difference")  {
	  if (is.null(ylim))  ylim  <- range(x$risk[,c(4,5)])
  plot(x$time,x$difference[,2],type="s",xlab="time",ylab="difference in risk",ylim=range(x$difference[,2]),col=cols[1],lty=ltys[1],...)
  plotConfRegion(x$time,x$difference[,c(4,5)],col=cols[1])
  }
  if (type[1]=="ratio")  {
  if (is.null(ylim))  ylim  <- range(x$ratio[,c(4,5)])
  plot(x$time,x$ratio[,2],type="s",ylim=ylim,xlab="time",ylab="ratio",col=cols[1],lty=ltys[1],...)
  plotConfRegion(x$time,x$ratio[,c(4,5)],col=cols[1])
}
 if (type[1]=="survival.ratio")  {
   if (is.null(ylim))  ylim  <- range(x$survival.ratio[,c(4,5)])
  plot(x$time,x$survival.ratio[,2],type="s",xlab="time",ylab="risk",col=cols[1],lty=ltys[1],ylim=ylim,...)
  plotConfRegion(x$time,x$survival.ratio[,c(4,5)],col=cols[1])
}

 if (is.null(legend)) legend("topleft",levels(x$strata),col=cols,lty=ltys)

}
# }}}

##' Fast Additive Hazards Model with Robust Standard Errors
##'
##' Fits a fast Lin-Ying additive hazards model with a possibly stratified baseline.
##' Robust variance is the default variance estimate in the summary.
##'
##' Influence functions (IID) follow the numerical order of the given cluster variable.
##' Ordering by \code{$id} aligns the IID terms with the dataset order.
##'
##' @param formula Formula with a 'Surv' outcome (similar to \code{coxph}).
##' @param data Data frame.
##' @param no.baseline Logical; if \code{TRUE}, fits the model without baseline hazard estimation.
##' @param ... Additional arguments passed to \code{phreg}.
##'
##' @return An object of class \code{"aalenMets"} (extends \code{"phreg"}) containing:
##' \item{coef}{Estimated coefficients.}
##' \item{var}{Robust variance-covariance matrix.}
##' \item{iid}{Influence functions.}
##' \item{intZHZ}{Integrated ZHZ matrix.}
##' \item{gamma}{Coefficient estimates.}
##'
##' @author Thomas Scheike
##' @examples
##' data(bmt)
##' bmt$time <- bmt$time + runif(408) * 0.001
##' out <- aalenMets(Surv(time, cause == 1) ~ tcell + platelet + age, data = bmt)
##' summary(out)
##'
##' ## Comparison with timereg::aalen
##' ## out2 <- timereg::aalen(
##' ##   Surv(time, cause == 1) ~ const(tcell) + const(platelet) + const(age),
##' ##   data = bmt
##' ## )
##' ## summary(out2)
##' @export
aalenMets <- function(formula,data=data,no.baseline=FALSE,...)
{# {{{
formula.call <- formula
x <- phreg(formula,data=data,no.opt=TRUE,...)
xx <- x$cox.prep

### computation of intZHZ matrix, and gamma and baseline ##################
# {{{
eXb <- c(xx$sign) * c(xx$weights)
S0 = c(revcumsumstrata(eXb,xx$strata,xx$nstrata))
S0[S0==0] <- 1
E=apply(eXb*xx$X,2,revcumsumstrata,xx$strata,xx$nstrata)/S0;
if (no.baseline) E <- 0*E
###if (!no.int) E <- cbind(1,E)
###if (no.int) X <-  xx$X else X <- cbind(1,xx$X)
###if (no.int) XX <-  xx$XX else { XX <- .Call("vecCPMat",X)$XX }
X <- xx$X; XX <- xx$XX
###
S2=apply(eXb*XX,2,revcumsumstrata,xx$strata,xx$nstrata)
E2  <- .Call("vecCPMat",E)$XX
###
dts <- c(diffstrata(xx$time,xx$strata,xx$nstrata))
dt <- diff(c(0,xx$time))
###
intZbar <- apply(E*dts,2,cumsumstrata,xx$strata,xx$nstrata)
intZHZt <- apply((S2-S0*E2)*dts,2,cumsum)
p <- ncol(E)
intZHZ <-  matrix(.Call("XXMatFULL",tail(intZHZt,1),p,PACKAGE="mets")$XXf,p,p)

IintZHZ  <-  pinv(intZHZ)
intZHdN <- matrix(x$gradient,ncol(E),1)
XJ <- X[xx$jumps+1,]
if (no.baseline) intZHdN <- matrix(apply(XJ,2,sum),ncol(E),1)
gamma <- IintZHZ %*% intZHdN
###if (!no.int) nn <- c("int",colnames(x$X)) else
nn <- colnames(x$X)
rownames(gamma)  <-  nn
x$cumhaz[,2] <- x$cumhaz[,2]- intZbar[xx$jumps+1,] %*% gamma
# }}}

### iid gamma #########################################
# {{{
id <- xx$id
if (no.baseline==FALSE) {
  mm <-  X * c(X %*% gamma) * c(xx$time)+ apply( E* c(E %*% gamma)*dts,2,cumsumstrata,xx$strata,xx$nstrata) -  X* c(intZbar %*% gamma) - c(X %*% gamma)* intZbar
  mm <- c(xx$weights*xx$sign) * mm
  mm <- apply(mm,2,sumstrata,id,max(id)+1)
  ###
  MGt <- t(x$hessian %*% t(lava::iid(x))) + mm
  XJ2l  <- .Call("vecCPMat",x$U)$XX
  XJ2l <- matrix(apply(XJ2l,2,sum),nrow=1)
  varmg <-  matrix(.Call("XXMatFULL",XJ2l,p,PACKAGE="mets")$XXf,p,p)
  varmg <- IintZHZ %*% varmg %*% IintZHZ
} else {
  mm <-  X * c(X %*% gamma) * c(xx$time)
  mm <- c(xx$weights*xx$sign) * mm
  mm <- apply(mm,2,sumstrata,id,max(id)+1)
  XJ2l  <- .Call("vecCPMat",XJ)$XX
  XJ2l <- matrix(apply(XJ2l,2,sum),nrow=1)
  varmg <-  matrix(.Call("XXMatFULL",XJ2l,p,PACKAGE="mets")$XXf,p,p)
  varmg <- IintZHZ %*% varmg %*% IintZHZ
  XdN  <- apply(XJ,2,sumstrata,id[xx$jumps+1],max(id)+1)
  MGt <-  XdN-mm
}
iid <-  MGt %*% IintZHZ
# }}}

### output  #########################################
# {{{
coef <- c(gamma)
names(coef) <- nn
x$coef <- coef
x$var <- crossprod(iid)
x$varmg <- varmg
x$iid <- iid
x$intZHdN <- intZHdN
x$intZHZ  <-  intZHZ
x$formula <- formula.call
x$ihessian <- IintZHZ
## score of gamma
x$gradient <- c(intZHdN-intZHZ %*% gamma)

x$no.opt <- FALSE
class(x) <- c(class(x),"aalenMets")
# }}}

return(x)
}# }}}

##' Kaplan-Meier with Robust Standard Errors
##'
##' Computes Kaplan-Meier estimates with robust standard errors.
##' Robust variance is the default and is obtained from the \code{predict} call.
##'
##' @param formula Formula with 'Surv' or 'Event' outcome.
##' @param data Data frame.
##' @param km Logical; if \code{TRUE}, returns Kaplan-Meier estimates; otherwise returns Nelson-Aalen based estimates.
##' @param ... Additional arguments passed to \code{phreg}.
##'
##' @return An object of class \code{"km"} (extends \code{"predictphreg"}) containing:
##' \item{surr}{Survival probabilities.}
##' \item{se.surv}{Standard errors.}
##' \item{lower, upper}{Confidence intervals.}
##'
##' @author Thomas Scheike
##' @examples
##' data(sTRACE)
##' sTRACE$cluster <- sample(1:100, 500, replace = TRUE)
##' out1 <- km(Surv(time, status == 9) ~ strata(vf, chf), data = sTRACE)
##' out2 <- km(Surv(time, status == 9) ~ strata(vf, chf) + cluster(cluster), data = sTRACE)
##'
##' summary(out1, times = 1:3)
##' summary(out2, times = 1:3)
##'
##' par(mfrow = c(1, 2))
##' plot(out1, se = TRUE)
##' plot(out2, se = TRUE)
##' @export
km <- function(formula,data=data,km=TRUE,...)
{# {{{
res <- phreg(formula,data=data,...)

rhs <- update(formula,-1~.)
varss <- all.vars(formula)
## find all strata
first <- c(headstrata(res$strata.call,res$nstrata))

ddf <- data[first,varss]
pres <- predict(res,ddf,robust=TRUE,km=km,...)
pres$formula <- formula
pres$call <- match.call()

attr(pres,"data") <- ddf
class(pres) <- c("km","predictphreg")
return(pres)
}# }}}

##' @export
summary.km <- function(object,times=NULL,type=c("cif","cumhaz","surv")[3],...) { ## {{{
   out <- summary.predictphreg(object,times=times,type=type[1],...)
   return(out)
} ## }}}

##' @export
plot.km <- function(x,...) { ## {{{
   plot.predictphreg(x,...)
}# }}}

##' Cumulative Incidence with Robust Standard Errors
##'
##' Computes cumulative incidence functions with robust standard errors.
##'
##' @param formula Formula with 'Event' outcome and \code{strata} (only!).
##' @param data Data frame.
##' @param cause Cause of interest (default is \code{NULL}, which looks at all causes).
##' @param cens.code Censoring code (default is \code{"0"}).
##' @param death.code Alternative to \code{cens.code}; specifies codes of death.
##' @param ... Additional arguments passed to lower-level functions.
##'
##' @return An object of class \code{"cif"} (extends \code{"phreg"}) containing:
##' \item{cumhaz}{Cumulative incidence estimates.}
##' \item{se.cumhaz}{Standard errors.}
##' \item{cause}{Cause of interest.}
##'
##' @author Thomas Scheike
##' @examples
##' data(bmt)
##' bmt$cluster <- sample(1:100, 408, replace = TRUE)
##' out1 <- cif(Event(time, cause) ~ +1, data = bmt, cause = 1)
##' out2 <- cif(Event(time, cause) ~ +1 + cluster(cluster), data = bmt, cause = 1)
##'
##' par(mfrow = c(1, 2))
##' plot(out1, se = TRUE)
##' plot(out2, se = TRUE)
##' @export
cif <- function(formula,data=data,cause=1,cens.code=0,death.code=NULL,...)
{# {{{
  cl <- match.call()
    des <- proc_design(
        formula,
        data = data,
        specials = c("offset", "weights", "cluster","strata"),
        intercept = FALSE
    )
    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
    strata <- des$strata
    if (!is.null(strata)) strata.name <- names(des$xlevels)
    else strata.name <- NULL
    pos.strata <- NULL
    des.weights <- des$weights
    des.offset  <- des$offset
    id      <- des$cluster
    ## no use of
    pos.cluster <- NULL
  if (ncol(X)==0) X <- matrix(nrow=0,ncol=0)

  id.orig <- id;
  if (!is.null(id)) {
	  ids <- sort(unique(id))
	  nid <- length(ids)
      if (is.numeric(id)) id <-  fast.approx(ids,id)-1 else  {
      id <- as.integer(factor(id,labels=seq(nid)))-1
     }
   } else id <- as.integer(seq_along(exit))-1;

  statusE <- 1*(status %in% cause)
  if (is.null(death.code)) statusD <- 1*(!(status %in% cens.code)) else statusD <- 1*(status %in% death.code)
  data$statusE__ <- statusE
  data$statusD__ <- statusD
  data$strata__ <- strata

  ### setting up formulae for the two phreg (cause of interest and death)
  if (is.null(id.orig)) {
     formid <- update.formula(formula,~.+cluster(id))
     data$id <- id
  } else formid <- formula
  tt <- terms(formid)
  tt <- delete.response(tt)
  formid <- formula(tt)

  data$exit__ <- exit
  if (ncol(Y)==3) {
     data$entry__ <- entry
     formE <- as.formula(paste("Surv(entry__,exit__,statusE__)~+1"))
     formD <- as.formula(paste("Surv(entry__,exit__,statusD__)~+1"))
  } else {
     formE <- as.formula(paste("Surv(exit__,statusE__)~+1"))
     formD <- as.formula(paste("Surv(exit__,statusD__)~+1"))
  }
 formE <- update.formula(formE,formid)
 formD <- update.formula(formD,formid)

  if (sum(statusE)==0) warning("No events of type 1\n");
  coxE <- phreg(formE,data=data,...)
  coxS <- phreg(formD,data=data,...)

  ### cif
  if (sum(statusE)>0) cifo <- recurrentMarginalPhreg(coxE,coxS) else cifo <- coxE
  ## to work with predict function
  ##  cifo$no.opt <- TRUE

  ### to use basehazplot.phreg
  class(cifo) <- c("cif","phreg")
  attr(cifo,"cause") <- cause
  attr(cifo,"cens.code") <- cens.code
  attr(cifo,"death.code") <- death.code
  return(cifo)
}# }}}

##' @export
plot.cif <- function(x,se=FALSE,ylab=NULL,ylim=c(0,1),conf.type=c("log","plain"),...) { ## {{{
   if (inherits(x,"cif") & is.null(ylab)) ylab <- "Probability"
   baseplot(x,se=se,ylab=ylab,ylim=ylim,restrict="prob",conf.type=conf.type[1],...)
} ## }}}

##' @export
summary.cif <- function(object,se=FALSE,ylab=NULL,times=NULL,conf.type=c("log","plain"),...) { ## {{{
   if (inherits(object,"cif") & is.null(ylab)) ylab <- "Probability"
   out <- summaryRecurrentobject(object,name="probability",times=times,conf.type=conf.type[1],restrict="prob",...)
   return(out)
} ## }}}

##' Proportional Odds Survival Model
##'
##' Fits a semiparametric proportional odds model where:
##' \deqn{ \mbox{logit}(S(t|x)) = \log(\Lambda(t)) + x \beta }
##' Thus, covariate effects represent the odds ratio (OR) of survival.
##'
##' This is equivalent to using a hazards model:
##' \deqn{ Z \lambda(t) \exp(x \beta) }
##' where \eqn{Z} is gamma distributed with mean and variance 1.
##'
##' @param formula Formula with 'Surv' outcome (similar to \code{coxph}).
##' @param data Data frame.
##' @param offset Offsets for \eqn{\exp(x \beta)} terms.
##' @param weights Weights for score equations.
##' @param ... Additional arguments passed to lower-level functions.
##'
##' @return An object of class \code{"phreg"} with \code{propodds=1}.
##'
##' @author Thomas Scheike
##' @references
##' Eriksson, Frank, Li, Jianing, Scheike, Thomas, and Zhang, Mei-Jie (2015).
##' "The proportional odds cumulative incidence model for competing risks."
##' \emph{Biometrics}, 71(3), 687--695.
##'
##' @examples
##' data(TRACE)
##' dcut(TRACE) <- ~.
##' out1 <- logitSurv(Surv(time, status == 9) ~ vf + chf + strata(wmicat.4), data = TRACE)
##' summary(out1)
##' gof(out1)
##' plot(out1)
##' @export
logitSurv <- function(formula,data,offset=NULL,weights=NULL,...)
{# {{{
   out <- phreg(formula,data,offset=offset,weights=weights,propodds=1,...)
   out$se.cumhaz <- NULL
   return(out)
}# }}}

## {{{ Utility functions, cumsumstrata ....

tailstrata <- function(strata,nstrata)
{# {{{
if (any(strata<0) | any(strata>nstrata-1)) stop("strata index not ok\n");
res <- .Call("tailstrataR",length(strata),strata,nstrata,PACKAGE="mets")
if (any(res$found<0.5))  { warning("Not all strata found");  cat((1:nstrata)[res$found>0.5]); }
return(res$where)
}# }}}

headstrata <- function(strata,nstrata)
{# {{{
if (any(strata<0) | any(strata>nstrata-1)) stop("strata index not ok\n");
res <- .Call("headstrataR",length(strata),strata,nstrata,PACKAGE="mets")
if (any(res$found<0.5))  { warning("Not all strata found");  cat((1:nstrata)[res$found>0.5]); }
return(res$where)
}# }}}

##' Stratified Cumulative and Summary Operations
##'
##' Low-level helper functions for computing sums, cumulative sums, and
##' reverse cumulative sums within strata groups, as well as matrix
##' double-indexing.
##'
##' @name strata-numeric
##' @param x numeric vector (or matrix for \code{matdoubleindex}).
##' @param strata integer vector of strata indices (0-based).
##' @param nstrata number of distinct strata.
##' @param rows row indices for \code{matdoubleindex}.
##' @param cols column indices for \code{matdoubleindex}.
##' @param xvec optional values to assign at indexed positions.
##' @param ... additional arguments (for \code{mdi}).
##' @return Numeric vector of the same length as \code{x} (or modified matrix).
##' @author Klaus K. Holst, Thomas Scheike
##' @aliases sumstrata cumsumstrata revcumsumstrata revcumsum matdoubleindex mdi
NULL

##' @rdname strata-numeric
##' @export
sumstrata <- function(x,strata,nstrata)
{# {{{
if (any(strata<0) | any(strata>nstrata-1)) stop("strata index not ok\n");
if (length(x)!=length(strata)) stop("length of x and strata must be same\n");
res <- .Call("sumstrataR",x,strata,nstrata,PACKAGE="mets")$res
return(res)
}# }}}

##' @rdname strata-numeric
##' @export
cumsumstrata <- function(x,strata,nstrata)
{# {{{
if (any(strata<0) | any(strata>nstrata-1)) stop("strata index not ok\n");
if (length(x)!=length(strata)) stop("length of x and strata must be same\n");
res <- .Call("cumsumstrataR",x,strata,nstrata,PACKAGE="mets")$res
return(res)
}# }}}

##' @export
diffstrata <- function(x,strata,nstrata)
{# {{{
if (any(strata<0) | any(strata>nstrata-1)) stop("strata index not ok\n");
if (length(x)!=length(strata)) stop("length of x and strata must be same\n");
res <- .Call("diffstrataR",x,strata,nstrata,PACKAGE="mets")$res
return(res)
}# }}}

##' @rdname strata-numeric
##' @export
revcumsumstrata <- function(x,strata,nstrata)
{# {{{
if (any(strata<0) | any(strata>nstrata-1)) stop("strata index not ok\n");
if (length(x)!=length(strata)) stop("length of x and strata must be same\n");
res <- .Call("revcumsumstrataR",x,strata,nstrata,PACKAGE="mets")$res
return(res)
}# }}}

revcumsum2strata <- function(x,strata,nstrata,strata2,nstrata2,lag=FALSE)
{# {{{
if (any(strata<0) | any(strata>nstrata-1)) stop("strata index not ok\n");
if (any(strata2<0) | any(strata2>nstrata2-1)) stop("strata2 index not ok\n");
if (length(x)!=length(strata))  stop("length of x and strata must be same\n");
if (length(x)!=length(strata2)) stop("length of x and strata2 must be same\n");
res <- .Call("revcumsum2strataR",as.double(x),strata,nstrata,strata2,nstrata2,PACKAGE="mets")
return(res)
}# }}}

revcumsum2stratafdN <- function(x,y,strata,nstrata,strata2,nstrata2,startx)
{# {{{
if (any(strata<0) | any(strata>nstrata-1))    stop("strata index not ok\n");
if (any(strata2<0) | any(strata2>nstrata2-1)) stop("strata2 index not ok\n");
if (length(x)!=length(strata))  stop("length of x and strata must be same\n");
if (length(x)!=length(strata2)) stop("length of x and strata2 must be same\n");
if (length(x)!=length(y)) stop("length of x and y must be same\n");
res <- .Call("revcumsum2stratafdNR",as.double(x),as.double(y),strata,nstrata,strata2,nstrata2,as.double(startx),PACKAGE="mets")
return(res)
}# }}}


cumsum2strata <- function(x,y,strata,nstrata,strata2,nstrata2,startx)
{# {{{
if (any(strata<0) | any(strata>nstrata-1))    stop("strata index not ok\n");
if (any(strata2<0) | any(strata2>nstrata2-1)) stop("strata2 index not ok\n");
if (length(x)!=length(strata))  stop("length of x and strata must be same\n");
if (length(x)!=length(strata2)) stop("length of x and strata2 must be same\n");
res <- .Call("cumsum2strataR",as.double(x),as.double(y),strata,nstrata,strata2,nstrata2,as.double(startx),PACKAGE="mets")
return(res)
}# }}}


##' @export
vecAllStrata <- function(x,strata,nstrata)
{# {{{
if (any(strata<0) | any(strata>nstrata-1)) stop("strata index not ok\n");
if (length(x)!=length(strata))  stop("length of x and strata must be same\n");
res <- .Call("vecAllStrataR",x,strata,nstrata,PACKAGE="mets")$res
return(res)
}# }}}

##' @rdname strata-numeric
##' @export
revcumsum <- function(x)
{# {{{
res <- .Call("revcumsumR",x,PACKAGE="mets")$res
return(res)
}# }}}

revcumsumstratasum <- function(x,strata,nstrata,type="all")
{# {{{
if (any(strata<0) | any(strata>nstrata-1)) stop("strata index not ok\n");
if (length(x)!=length(strata)) stop("length of x and strata must be same\n");
if (type=="sum")    res <- .Call("revcumsumstratasumR",x,strata,nstrata)$sum
if (type=="lagsum") res <- .Call("revcumsumstratasumR",x,strata,nstrata)$lagsum
if (type=="all")    res <- .Call("revcumsumstratasumR",x,strata,nstrata)
return(res)
}# }}}

cumsumstratasum <- function(x,strata,nstrata,type="all")
{# {{{
if (any(strata<0) | any(strata>nstrata-1)) stop("strata index not ok\n");
if (length(x)!=length(strata)) stop("length of x and strata must be same\n"); 
if (type=="sum")    res <- .Call("_mets_cumsumstratasumR",x,strata,nstrata,0)$sum
if (type=="lagsum") res <- .Call("_mets_cumsumstratasumR",x,strata,nstrata,0)$lagsum
if (type=="all")    res <- .Call("_mets_cumsumstratasumR",x,strata,nstrata,1)
return(res)
}# }}}

##' @rdname strata-numeric
##' @export
matdoubleindex <- function(x,rows,cols,xvec=NULL)
{# {{{
if (!is.matrix(x)) stop("x must be matrix")
ncols <- ncol(x); nrows <- nrow(x)
## to avoid warnings when going to C, get rid of Inf
cols[cols==Inf] <- ncol(x)+1;
rows[rows==Inf] <- nrow(x)+1;
if (length(rows)==1) rows <- rep(rows,length(cols))
if (length(cols)==1) cols <- rep(cols,length(rows))
if (length(cols)!=length(rows)) stop("rows and cols different lengths\n");
if (is.null(xvec)) { assign <- 0; xvec <- 1} else {
	assign <- 1;
        if (length(cols)!=length(xvec)) stop("rows and cols and xvec differ \n");
}
res <- .Call("Matdoubleindex",x,rows-1,cols-1,length(cols),assign,xvec)$mat
return(res)
}# }}}

##' @rdname strata-numeric
##' @export
mdi <- function(x,...) matdoubleindex(x,...)

covfr  <- function(x,y,strata,nstrata)
{# {{{
if (any(strata<0) | any(strata>nstrata-1)) stop("strata index not ok\n");
res <- .Call("covrfR",x,y,strata,nstrata)
return(res)
}# }}}

revcumsumidstratasum <- function(x,id,nid,strata,nstrata,type="all")
{# {{{
if (any(id<0) | any(id>nid-1)) stop("id index not ok\n");
if (any(strata<0) | any(strata>nstrata-1)) stop("strata index not ok\n");
if (type=="sum")    res <- .Call("revcumsumidstratasumR",x,id,nid,strata,nstrata)$sum
if (type=="lagsum")    res <- .Call("revcumsumidstratasumR",x,id,nid,strata,nstrata)$lagsum
if (type=="lagsumsquare") res <- .Call("revcumsumidstratasumR",x,id,nid,strata,nstrata)$lagsumsquare
if (type=="all")    res <- .Call("revcumsumidstratasumR",x,id,nid,strata,nstrata)
return(res)
}# }}}

revcumsumidstratasumCov <- function(x,y,id,nid,strata,nstrata,type="all")
{# {{{
if (any(id<0) | any(id>nid-1)) stop("id index not ok\n");
if (any(strata<0) | any(strata>nstrata-1)) stop("strata index not ok\n");
if (type=="sum")    res <- .Call("revcumsumidstratasumCovR",x,y,id,nid,strata,nstrata)$sum
if (type=="lagsum")    res <- .Call("revcumsumidstratasumCovR",x,y,id,nid,strata,nstrata)$lagsum
if (type=="lagsumsquare") res <- .Call("revcumsumidstratasumCovR",x,y,id,nid,strata,nstrata)$lagsumsquare
if (type=="all")    res <- .Call("revcumsumidstratasumCovR",x,y,id,nid,strata,nstrata)
return(res)
}# }}}

cumsumidstratasumCov <- function(x,y,id,nid,strata,nstrata,type="all")
{# {{{
if (any(id<0) | any(id>nid-1)) stop("id index not ok\n");
if (any(strata<0) | any(strata>nstrata-1)) stop("strata index not ok\n");
if (type=="sum")   res <- .Call("cumsumidstratasumCovR",x,y,id,nid,strata,nstrata)$sum
else res <- .Call("cumsumidstratasumCovR",x,y,id,nid,strata,nstrata)
return(res)
}# }}}

cumsumidstratasum <- function(x,id,nid,strata,nstrata,type="all")
{# {{{
if (any(id<0) | any(id>nid-1)) stop("id index not ok\n");
if (any(strata<0) | any(strata>nstrata-1)) stop("strata index not ok\n");
if (type=="sum")   res <- .Call("cumsumidstratasumR",x,id,nid,strata,nstrata)$sum
else res <- .Call("cumsumidstratasumR",x,id,nid,strata,nstrata)
return(res)
}# }}}

covfridstrata  <- function(x,y,id,nid,strata,nstrata)
{# {{{
if (any(id<0) | any(id>nid-1)) stop("id index not ok\n");
if (any(strata<0) | any(strata>nstrata-1)) stop("strata index not ok\n");
res <- .Call("covrfstrataR",x,y,id,nid,strata,nstrata)
return(res)
}# }}}

covfridstrataCov  <- function(x,y,x1,y1,id,nid,strata,nstrata)
{# {{{
if (any(id<0) | any(id>nid-1)) stop("id index not ok\n");
if (any(strata<0) | any(strata>nstrata-1)) stop("strata index not ok\n");
res <- .Call("covrfstrataCovR",x,y,x1,y1,id,nid,strata,nstrata)
return(res)
}# }}}


## }}}


Mcumsumstrata <- function(A, strata, nstrata) {
    if (!is.matrix(A))
        stop("A must be a matrix")
    if (nrow(A) != length(strata))
        stop("nrow(A) must equal length(strata)")
    if (min(strata) < 0 || max(strata) >= nstrata)
        stop("strata values must be in 0:(nstrata-1)")
    .Call("McumsumstrataR", A, strata, as.integer(nstrata), FALSE)$res
}

Mrevcumsumstrata <- function(A, strata, nstrata) {
    if (!is.matrix(A))
        stop("A must be a matrix")
    if (nrow(A) != length(strata))
        stop("nrow(A) must equal length(strata)")
    if (min(strata) < 0 || max(strata) >= nstrata)
        stop("strata values must be in 0:(nstrata-1)")
    .Call("McumsumstrataR", A, strata, as.integer(nstrata), TRUE)$res
}


Msumstrata <- function(A, strata, nstrata) {
    if (!is.matrix(A))
        stop("A must be a matrix")
    if (nrow(A) != length(strata))
        stop("nrow(A) must equal length(strata)")
    if (min(strata) < 0 || max(strata) >= nstrata)
        stop("strata values must be in 0:(nstrata-1)")
    .Call("MsumstrataR", A, strata, as.integer(nstrata))$res
}


