#' Compute the nonparametric MLE under double truncation
#'
#' @description
#' Computes the nonparametric maximum likelihood estimator (NPMLE) of the
#' pre-truncation event time and truncation time distributions using an EM
#' algorithm.
#'
#' @param y A `Survdt` object or expression. Observations with missing values
#'   are discarded.
#'   See [Survdt()].
#' @param data An optional data frame used to evaluate `y`.
#' @param se Whether to compute standard errors for each estimate
#'   (default `TRUE`).
#' @param cumhaz Whether to also compute the NPMLE of the event time cumulative
#'   hazard (default `FALSE`).
#' @param ainv Whether to return the NPMLE of the normalized inverse selection
#'   probabilities at the observed event times (default `TRUE`).
#' @param infl Whether to return the influence values for each estimate
#'   (default `FALSE`).
#' @param max_iter The maximum number of iterations for the EM algorithm.
#' @param error Tolerance for determining numerical convergence, defined as the
#'   relative change in the log likelihood being less than `error` or the absolute
#'   change being less than sqrt(`error`) at any iteration.
#' @param init Optional event time cdf point masses to initialize the EM
#'   algorithm.
#' @param convergence_warning Whether to issue a warning when numerical
#'   convergence is not achieved by `max_iter` iterations (default `TRUE`).
#' @param check_identifiability Whether to check and return an error if the
#'   NPMLE is not identifiable (default `TRUE`, see below).
#' @param x Any R object.
#' @param ... Additional arguments passed to or from other methods.
#'
#' @details
#' Given a doubly truncated sample \eqn{(T_1,L_1,R_1)}, \eqn{(T_2,L_2,R_2)},
#' \eqn{\ldots}, \eqn{(T_n,L_n,R_n)}, the NPMLE of the (pre-truncation) event
#' time cdf is a right-continuous step function
#' \deqn{\widehat{F}(t) = \sum_{i=1}^n 1(T_i\leq t) \widehat{f}_i}
#' with point masses at the observed event times.
#' Assuming (quasi-)independent truncation, these point masses maximize the
#' likelihood function
#' \deqn{L(f_1, \ldots, f_n) = \prod_{i=1}^n \frac{f_i}{\sum_j 1(L_i<T_j \leq R_i) f_j}.}
#' Efron and Petrosian (1999) provided a simple EM algorithm to compute the NPMLE.
#'
#' The point masses of the NPMLE can be expressed as
#' \eqn{\widehat{f}_i = 1/[\widehat{a}(T_i)n]},
#' where \eqn{a(t) = P(L<T \leq R|T=t)/P(L<T \leq R)} is the normalized
#' probability of observing time \eqn{t} within a truncation interval.
#' These inverse selection probabilities are used to correct for double truncation
#' bias in [coxph_indtrunc()].
#'
#' Once \eqn{\widehat{F}(t)} is obtained, other quantities such as the survival
#' function, cumulative hazard, and bivariate truncation time cdf point masses
#' are straightforward to compute.
#'
#' @section Identifiability:
#' Xiao and Hudgens (2019) provided a necessary and sufficient condition for the
#' likelihood function \eqn{L(f_1, \ldots, f_n)} to have a unique maximizer.
#' By default, this condition is checked by [npmle()] before estimation.
#'
#' @section Standard errors:
#' By default, [npmle()] computes variance estimates for the NPMLE
#' using the closed-form standard errors derived by Vazquez and Xie (2025).
#' This is generally more computationally efficient than the resampling methods
#' used by other packages.
#' If fit with `infl`=`TRUE`, the `npmle` object may be supplied as an input to
#' other [survdt] functions, which will then not need to re-compute the influence
#' values.
#'
#' @returns
#' [npmle()] returns an object of class `npmle`, i.e. a list with the following
#' components:
#' \item{n}{The complete case sample size.}
#' \item{n_miss}{The number of discarded observations (with missing values).}
#' \item{cdf}{A matrix containing the estimated event time cdf evaluated at
#'   ordered unique event times, with columns `time`, `cdf`, and `se`.}
#' \item{cumhaz}{A matrix containing the estimated event time cumulative hazard
#'   evaluated at ordered unique event times, with columns `time`, `cumhaz`, and
#'   `se`.
#'   Set to `NULL` if `cumhaz`=`FALSE`.}
#' \item{ainv}{A matrix containing the estimated normalized inverse selection
#'   probabilities for each event time (not sorted and including duplicates),
#'   with columns `time`, `ainv`, and `se`.
#'   Set to `NULL` if `ainv`=`FALSE`.}
#' \item{infl_cdf}{A matrix containing the estimated influence function for the
#'   cdf, with `[i,j]`th element corresponding to the `i`th ordered unique event
#'   time and `j`th unsorted individual.
#'   Set to `NULL` if `infl`=`FALSE`.}
#' \item{infl_cumhaz}{A matrix containing the estimated influence function for
#'   the cumulative hazard, with `[i,j]`th element corresponding to the `i`th
#'   ordered unique event time and `j`th unsorted individual.
#'   Set to `NULL` if `cumhaz=FALSE` or `infl`=`FALSE`.}
#' \item{infl_ainv}{A matrix containing the estimated influence function for the
#'   normalized inverse selection probabilities, with `[i,j]`th element
#'   corresponding to the `i`th event time (including ties) and `j`th individual,
#'   both unsorted.
#'   Set to `NULL` if `ainv=FALSE` or `infl`=`FALSE`.}
#' \item{masses}{A data frame containing the point masses for the event time
#'   (`f`) and truncation time (`g`) cdfs and the estimated selection
#'   probabilities for each event time (`pt`) and truncation interval (`plr`),
#'   with one row per observation.
#'   Not sorted.}
#' \item{converged}{Whether the EM algorithm converged before `max_iter` was
#'   reached.}
#' \item{n_iter}{The total number of EM algorithm iterations that ran.}
#' \item{overall_sampling_prob}{A named vector with the estimated overall
#'   probability of non-truncation in `prob` and its standard error in `se`.}
#'
#' [is.npmle()] returns `TRUE` if `x` inherits from the class `npmle` and
#' `FALSE` otherwise. The `print` method for `npmle` objects displays some sample
#' information and the first few steps of the estimated cdf.
#'
#' @export
#'
#' @seealso
#' * [plot.npmle()]: compute/plot estimates and pointwise confidence
#'   intervals for the event time survival function and cumulative hazard,
#'   normalized inverse selection probability weights, and selection probability
#'   as a function of time.
#' * [test_ignorability_indtrunc()]: test for ignorable sampling bias using the
#'   NPMLE.
#' * [test_samplediff_indtrunc()]: test for differences in the event time
#'   distributions across groups using the NPMLE.
#' * [test_quasiindep_ctau()]: test for violations of the quasi-independent
#'   truncation assumption.
#' * `vignette("nonparametric-analysis", package = "survdt")`: an example of
#'   various nonparametric analyses applied to the [aids] data, if vignettes
#'   were built when installing [survdt].
#'
#' @examples
#' npmle(Survdt(incu, ltrunc, rtrunc),
#'       data = aids)
#'
#'
#' @references
#' Efron, B., & Petrosian, V. (1999). Nonparametric methods for doubly truncated
#' data. *Journal of the American Statistical Association*, **94**(447), 824--834.
#'
#' de Uña-Álvarez, J., & Van Keilegom, I. (2021). Efron–Petrosian integrals for
#' doubly truncated data with covariates: An asymptotic analysis. *Bernoulli*,
#' **27**(1), 249--273.
#'
#' Vazquez, O., & Xie, S. X. (2025). Robust inverse probability weighted
#' estimators for doubly truncated Cox regression with closed-form standard
#' errors. *Lifetime Data Analysis*, **31**(2), 364–-393.
#'
#' Xiao, J., & Hudgens, M. G. (2019). On nonparametric maximum likelihood
#' estimation with double truncation. *Biometrika*, **106**(4), 989--996.
npmle <- function(y, data = NULL, se = TRUE, cumhaz = FALSE, ainv = TRUE,
                  infl = FALSE, max_iter = 1000, error = 1e-9, init = NULL,
                  convergence_warning = TRUE, check_identifiability = TRUE){
  # check input
  fn_call <- match.call()
  if (missing(y)) stop('\n  argument "y" is missing, with no default')
  if (!is.null(data)){
    if (is.matrix(data)) data <- as.data.frame(data)
    stopifnot(is.data.frame(data))
    y <- eval(fn_call[["y"]], envir = data, enclos = parent.frame())
  }
  if (is.Survdt2(y)) stop("Input y should be a Survdt object, not Survdt2.",
                          " See ?survdt::survdt2to1")
  stopifnot(is.Survdt(y),
            is.logical(se), is.vector(se), length(se) == 1, all(!is.na(se)),
            is.logical(cumhaz), is.vector(cumhaz), length(cumhaz) == 1,
            all(!is.na(cumhaz)),
            is.logical(ainv), is.vector(ainv),
            length(ainv) == 1, all(!is.na(ainv)),
            is.logical(infl), is.vector(infl),
            length(infl) == 1, all(!is.na(infl)),
            is.numeric(max_iter), is.vector(max_iter), length(max_iter) == 1,
            all(!is.na(max_iter)), max_iter >= 0,
            is.numeric(error), is.vector(error), length(error) == 1,
            all(!is.na(error)), error > 0,
            is.logical(convergence_warning), is.vector(convergence_warning),
            length(convergence_warning) == 1, all(!is.na(convergence_warning)),
            is.logical(check_identifiability), is.vector(check_identifiability),
            length(check_identifiability) == 1,
            all(!is.na(check_identifiability)))
  if (is.null(init)) init <- rep(1 / length(y), length(y))
  stopifnot(is.numeric(init), is.vector(init), length(init) == length(y),
            all(init > 0), all(init < 1))

  # missing values
  n_miss <- sum(is.na(y))
  init <- init[!is.na(y)]
  if (length(init) == 0) stop("No non-missing observations in y")
  if (any(is.na(init))) stop("Missing values in init")
  y <- y[!is.na(y), ]
  init <- init / sum(init)

  n <- length(y)
  sort_indx <- order(y[, "time", drop = TRUE])
  unsort_indx <- order(sort_indx)
  y <- y[sort_indx, ]
  init <- init[sort_indx] / sum(init)
  J <- apply(y[, c("ltrunc", "rtrunc")], MARGIN = 1,
             FUN = function(lr) (lr[1] < y[, "time", drop = TRUE]) &
               (y[, "time", drop = TRUE] <= lr[2]))

  # check connectivity
  if (check_identifiability == TRUE){
    gph <- igraph::graph(unlist(
      sapply(seq_len(n), FUN = function(i) c(rbind(i, which(J[, i]))))
    ))
    if (!igraph::is.connected(gph, "strong")) stop("NPMLE is not identifiable")
  }

  # EM algorithm
  f <- init
  converged <- FALSE
  inv_plr <- 1 / c(t(f) %*% J)
  loglike <- sum(log(f * inv_plr))
  for (i in seq_len(floor(max_iter))){
    f <- 1 / c(J %*% inv_plr)
    f <- f / sum(f)
    inv_plr <- 1 / c(t(f) %*% J)
    loglike_next <- sum(log(f * inv_plr))

    if ((abs(loglike_next - loglike) < sqrt(error)) ||
        (abs((loglike_next - loglike) / loglike) < error)){
      loglike <- loglike_next
      converged <- TRUE
      break
    }
    loglike <- loglike_next
  }
  g <- inv_plr / sum(inv_plr)
  pt <- c(J %*% g)

  if (!converged && convergence_warning)
    warning("EM algorithm reached max_iter before convergence")

  # output
  masses <- data.frame(time = y[, "time", drop = TRUE],
                       ltrunc = y[, "ltrunc", drop = TRUE],
                       rtrunc = y[, "rtrunc", drop = TRUE],
                       f = f, g = g, pt = pt, plr = c(1 / inv_plr))
  overall_sampling_prob <- c(prob = 1 / mean(1 / masses$plr), se = NA)
  jump_indx <- !duplicated(masses$time, fromLast = TRUE)
  npcdf <- cbind(time = masses$time, cdf = pmin(cumsum(masses$f), 1),
                 se = NA)[jump_indx, ]
  npcumhaz <- NULL
  npainv <- NULL
  infl_cdf <- NULL
  infl_cumhaz <- NULL
  infl_ainv <- NULL

  if ((se == TRUE) || (infl == TRUE)){
    stderrs <- npmle_infl(masses = masses, J = J, ainv = ainv, cumhaz = cumhaz,
                          msel_prob = TRUE, already_sorted = TRUE)
    npcdf[, "se"] <- sqrt(stderrs$var_F)
    if (infl == TRUE) infl_cdf <- stderrs$L_F[, unsort_indx]
    overall_sampling_prob["se"] <- sqrt(stderrs$infl_msel_prob$var)

    if (cumhaz == TRUE){
      npcumhaz <- cbind(time = stderrs$cumhaz[, 1], cumhaz = stderrs$cumhaz[, 2],
                        se = sqrt(stderrs$var_cumhaz))
      if (infl == TRUE) infl_cumhaz <- stderrs$L_cumhaz[, unsort_indx]
    }

    if (ainv == TRUE){
      npainv <- cbind(time = masses$time, ainv = 1 / stderrs$a,
                      se = sqrt(stderrs$var_ainv))[unsort_indx, ]
      if (infl == TRUE) {
        infl_ainv <- stderrs$L_ainv[unsort_indx, ]
        infl_ainv <- infl_ainv[, unsort_indx]
      }
    }
  }else{
    if (cumhaz == TRUE){
      lcont_survival <- 1 - c(0, npcdf[-nrow(npcdf), 2])
      dF <- diff(c(0, npcdf[, 2]))
      npcumhaz <- cbind(time = npcdf[, 1], cumhaz = cumsum(dF / lcont_survival),
                        se = NA)
    }
    if (ainv == TRUE){
      npainv <- cbind(time = masses$time, ainv = n * masses$f,
                      se = NA)[unsort_indx, ]
    }
  }

  res <- list(n = n, n_miss = n_miss, cdf = npcdf, cumhaz = npcumhaz,
              ainv = npainv, infl_cdf = infl_cdf, infl_cumhaz = infl_cumhaz,
              infl_ainv = infl_ainv, masses = masses[unsort_indx, ],
              converged = converged, n_iter = i,
              overall_sampling_prob = overall_sampling_prob)
  class(res) <- "npmle"
  res
}

#' @rdname npmle
#' @export
is.npmle <- function(x){
  inherits(x, "npmle")
}


#' Plot estimates from an NPMLE fit
#'
#' @description
#' Given a fitted NPMLE from [npmle()], plot various quantities related to the
#' event time or truncation time distributions along with pointwise confidence
#' intervals.
#' The estimates and standard errors are computed by [plot.npmle()] if they
#' were not included in the `npmle` fit.
#'
#' @param x An `npmle` object. See [npmle()].
#' @param ci Whether to plot pointwise confidence intervals (default `TRUE`).
#' @param level Confidence level for the pointwise confidence intervals (default
#'   0.95).
#' @param ctype Type of confidence interval.
#'   * `"plain"`: linear confidence intervals from a normal approximation.
#'   * `"log"`: back-transformed confidence intervals from the natural log scale.
#'     Guaranteed to be non-negative.
#'   * `"log-log"` (the default): for the survival function and selection
#'     probability, back-transformed confidence intervals from the (natural) log
#'     minus log scale, which are guaranteed to be between zero and one.
#'     For the normalized inverse probability weights and cumulative hazard,
#'     the same confidence intervals as `"log"` are used.
#' @param target Which NPMLE quantity to plot.
#'   * `"survival"` (the default): the event time survival function.
#'   * `"cumhaz"`: the event time cumulative hazard function.
#'   * `"ainv"`: the normalized inverse probability weights at each observed
#'     event time. See [npmle()].
#'   * `"sel_prob"`: the selection (non-truncation) probability as a function of
#'     time.
#' @param ... Additional arguments passed to other methods.
#'
#' @returns
#' After displaying the plot, a list with two elements is returned
#' invisibly.
#' The first element `ests` is a data frame with the columns `time`,
#' `est`, `lower`, and `upper`, containing the point estimates and their computed
#' confidence intervals.
#' The second element `plot` is the plotted object returned by [ggplot2::ggplot()].
#'
#' @export
#'
#' @seealso [npmle()]
#'
#' @examples
#' fit <- npmle(Survdt(incu, ltrunc, rtrunc),
#'              data = aids)
#' plot(fit)
#'
#' plot(fit, target = "cumhaz")
plot.npmle <- function(x, ci = TRUE, level = 0.95,
                       ctype = c("log-log", "log", "plain"),
                       target = c("survival", "cumhaz", "ainv", "sel_prob"),
                       ...){
  ctype <- match.arg(ctype)
  target <- match.arg(target)
  stopifnot(is.npmle(x),
            is.logical(ci), is.vector(ci), all(!is.na(ci)),
            is.numeric(level), is.vector(level), all(!is.na(level)))
  stopifnot(length(ci) == 1, length(level) == 1)
  stopifnot(level > 0, level < 1)
  q <- stats::qnorm(1-(1-level)/2)

  ci_transform <- ifelse(ctype == "plain", "linear", ctype)
  if (target == "cumhaz"){
    ylab <- "Cumulative hazard"
    linedir <- "hv"
    if ((ci == FALSE) && is.null(x[["cumhaz"]])){
      x <- npmle(with(x[["masses"]],
                      Survdt(time = time, ltrunc = ltrunc, rtrunc = rtrunc)),
                 se = ci, cumhaz = TRUE, ainv = FALSE, infl = FALSE,
                 max_iter = 0, init = x[["masses"]]$f,
                 convergence_warning = FALSE, check_identifiability = FALSE)
    }
    if ((ci == TRUE) && (is.null(x[["cumhaz"]]) ||
                         any(is.na(x[["cumhaz"]][, "se"])))){
      stderrs <- npmle_infl(x[["masses"]][order(x[["masses"]]$time), ,
                                          drop = FALSE],
                            cumhaz = TRUE, L_F = x$infl_cdf,
                            already_sorted = TRUE)
      x$cumhaz <- cbind(time = stderrs$cumhaz[, 1], cumhaz = stderrs$cumhaz[, 2],
                        se = sqrt(stderrs$var_cumhaz))
    }

    ests <- data.frame(time = x[["cumhaz"]][, "time", drop = TRUE],
                       est = x[["cumhaz"]][, "cumhaz", drop = TRUE],
                       se = x[["cumhaz"]][, "se", drop = TRUE],
                       lower = rep(NA, nrow(x[["cumhaz"]])),
                       upper = rep(NA, nrow(x[["cumhaz"]])))
    ci_transform <- ifelse(ctype == "log-log", "log", ci_transform)
  }else if (target == "survival"){
    ylab <- "Survival function"
    linedir <- "hv"
    if (ci && any(is.na(x[["cdf"]][, "se", drop = TRUE]))){
      stderrs <- npmle_infl(x[["masses"]][order(x[["masses"]]$time), ,
                                          drop = FALSE],
                            L_F = x[["infl_cdf"]], already_sorted = TRUE)
      x$cdf[, "se"] <- sqrt(stderrs$var_F)
    }

    ests <- data.frame(time = x[["cdf"]][, "time", drop = TRUE],
                       est = 1 - x[["cdf"]][, "cdf", drop = TRUE],
                       se = x[["cdf"]][, "se", drop = TRUE],
                       lower = rep(NA, nrow(x[["cdf"]])),
                       upper = rep(NA, nrow(x[["cdf"]])))
  }else if (target == "ainv"){
    ylab <- "Normalized IPW"
    if ((ci == FALSE) && is.null(x[["ainv"]])){
      x <- npmle(with(x[["masses"]],
                      Survdt(time = time, ltrunc = ltrunc, rtrunc = rtrunc)),
                 se = ci, cumhaz = FALSE, ainv = TRUE, infl = FALSE,
                 max_iter = 0, init = x[["masses"]]$f,
                 convergence_warning = FALSE, check_identifiability = FALSE)
    }
    if ((ci == TRUE) &&
        (is.null(x[["ainv"]]) || any(is.na(x[["ainv"]][, "se"])))){
      sort_indx <- order(x[["masses"]]$time)
      unsort_indx <- order(sort_indx)
      stderrs <- npmle_infl(x[["masses"]][sort_indx, , drop = FALSE], ainv = TRUE,
                            L_F = x[["infl_cdf"]], already_sorted = TRUE)

      x$ainv <- cbind(time = x[["masses"]]$time, ainv = 1 / stderrs$a[unsort_indx],
                      se = sqrt(stderrs$var_ainv[unsort_indx]))
    }

    ests <- data.frame(time = x[["ainv"]][, "time", drop = TRUE],
                       est = x[["ainv"]][, "ainv", drop = TRUE],
                       se = x[["ainv"]][, "se", drop = TRUE],
                       lower = rep(NA, nrow(x[["ainv"]])),
                       upper = rep(NA, nrow(x[["ainv"]])))
    ci_transform <- ifelse(ctype == "log-log", "log", ci_transform)
  }else if (target == "sel_prob"){
    ylab <- "Selection probability"
    linedir <- "vh"
    if (ci == TRUE){
      stderrs <- npmle_infl(x[["masses"]][order(x[["masses"]]$time), ,
                                          drop = FALSE],
                            infl_pt = TRUE, L_F = x[["infl_cdf"]],
                            already_sorted = TRUE)
      ests <- data.frame(time = stderrs$infl_pt$time,
                         est = c(0, stderrs$infl_pt$pt_btwn),
                         se = c(NA, sqrt(stderrs$infl_pt$var_pt_btwn)),
                         lower = rep(NA, length(stderrs$infl_pt$time)),
                         upper = rep(NA, length(stderrs$infl_pt$time)))

    }else{
      lr_times <- unique(sort(c(x[["masses"]]$ltrunc, x[["masses"]]$rtrunc)))
      nlr <- length(lr_times)
      ests <- data.frame(time = lr_times,
                         est = sapply(lr_times, FUN = function(ti) {
                           sum(x[["masses"]]$g[(x[["masses"]]$ltrunc < ti) &
                                                 (ti <= x[["masses"]]$rtrunc)])
                         }),
                         se = rep(NA, nlr),
                         lower = rep(NA, nlr),
                         upper = rep(NA, nlr))
    }
  }


  if (ci == TRUE){
    if (ci_transform == "linear"){
      ests$lower <- ests$est - q * ests$se
      ests$upper <- ests$est + q * ests$se
      if (ests$est[1] <= 0){
        ests$upper[1] <- ests$upper[2]
        ests$lower[1] <- 0
      }
    }else if (ci_transform == "log"){
      ests$lower <- ests$est * exp(-q * ests$se / abs(ests$est))
      ests$upper <- ests$est * exp(q * ests$se / abs(ests$est))
      if (ests$est[nrow(ests)] <= 0){
        ests$upper[nrow(ests)] <- ests$upper[nrow(ests) - 1]
        ests$lower[nrow(ests)] <- 0
      }
      if (ests$est[1] <= 0){
        ests$upper[1] <- ests$upper[2]
        ests$lower[1] <- 0
      }
    }else if (ci_transform == "log-log"){
      ests$upper <- ests$est^exp(-q * ests$se /
                                   abs(ests$est * log(abs(ests$est))))
      ests$lower <- ests$est^exp(q * ests$se /
                                   abs(ests$est * log(abs(ests$est))))
      if (ests$est[nrow(ests)] <= 0){
        ests$upper[nrow(ests)] <- ests$upper[nrow(ests) - 1]
        ests$lower[nrow(ests)] <- 0
      }
      if (ests$est[1] <= 0){
        ests$upper[1] <- ests$upper[2]
        ests$lower[1] <- 0
      }
    }
  }

  pltfn_lower <- function(x) ggplot2::geom_line(x, linetype = "dashed")
  pltfn_upper <- pltfn_lower
  pltfn_est <- ggplot2::geom_point
  if (target != "ainv"){
    if (target %in% c("survival", "cumhaz")){
      ests <- rbind(ests[1, , drop = FALSE], ests)
      ests$est[1] <- ifelse(target == "survival", 1, 0)
      ests$se[1] <- NA
      ests$lower[1] <- ifelse(target == "survival",
                              ests$lower[1],
                              min(0, ests$lower[1]))
      ests$upper[1] <- ifelse(target == "survival",
                              max(1, ests$upper[1]),
                              ests$upper[1])
    }

    pltfn_est <- function(x) ggplot2::geom_step(x, direction = linedir)
    pltfn_lower <- function(x) ggplot2::geom_step(x, linetype = "dashed",
                                                  direction = linedir)
    pltfn_upper <- pltfn_lower
  }

  plt <- ggplot2::ggplot(ests)
  if (ci == TRUE){
    plt <- with(ests,
                plt +
                  pltfn_lower(ggplot2::aes(x = time, y = lower)) +
                  pltfn_upper(ggplot2::aes(x = time, y = upper)))
  }

  plt <- with(ests,
              plt +
                pltfn_est(ggplot2::aes(x = time, y = est)) +
                ggplot2::labs(x = "Time", y = ylab) +
                ggplot2::coord_cartesian(xlim = c(min(x[["masses"]]$time) / 1.01,
                                                  max(x[["masses"]]$time) * 1.01),
                                         ylim = c(0, max(est) * 1.01),
                                         expand = FALSE) +
                ggplot2::theme_classic())

  print(plt)
  invisible(list(ests = ests, plot = plt))
}



#' @rdname npmle
#' @export
print.npmle <- function(x, ...){
  cat(paste0("\nNPMLE fit based on ", x[["n"]], " complete samples (",
             x[["n_miss"]], " dropped due to missingness)\n",
             "with ", nrow(x[["cdf"]]), " unique event times:\n\n"))
  print(x[["cdf"]][1:min(nrow(x[["cdf"]]), 5), , drop = FALSE])
  cat(ifelse(nrow(x[["cdf"]]) <= 5, " \n\n", "...\n\n"))
  invisible(x)
}

#' Test for non-ignorable sampling bias
#'
#' @description
#' Implements two possible nonparametric tests for non-ignorable sampling bias
#' based on the NPMLE:
#' 1. check for non-constant selection probabilities across the event time range;
#' 2. check for a difference between the estimated event time cumulative
#'    distribution functions adjusted and not adjusted for double truncation.
#'
#' Typically used to determine if a doubly truncated sample must be analyzed
#' with methods that account for truncation bias.
#'
#' @param y A `Survdt` object or expression, or an `npmle` object. Observations
#'   with missing values are discarded.
#'   See [Survdt()] and [npmle()].
#' @param data An optional data frame used to evaluate `y`.
#' @param test_type The test statistic to use: `"sel_prob"` (default) or `"cdf"`.
#'   See below.
#' @param level The confidence level for the test (default 0.95).
#' @param B The number of simulations from the estimated null distribution used
#'   to compute the p-value (default 2000).
#' @param restr_times An optional numerical vector of length two giving a time
#'   window to restrict the test statistic.
#'   Values of `NA` are replaced with the minimum and maximum observed event
#'   time respectively, i.e. no restriction.
#'   The default setting is no restriction.
#' @param wt_fn An optional function that takes a numerical vector of times as
#'   input and returns a vector of weights to apply in the test statistic.
#'   If unspecified, all times have equal weight of 1.
#' @param x Any R object.
#' @param ... Additional arguments passed to other methods.
#'
#' @details
#' The sampling bias from double truncation is called ignorable when the
#' selection (non-truncation) probability is constant over all possible event
#' times.
#' Since all event times have an equal probability of being included in the sample,
#' the sampling mechanism does not alter their distribution, so standard analysis
#' methods can be applied to the data.
#'
#' Define the normalized selection probability at any time \eqn{t} by
#' \eqn{a(t) = P(L<T \leq R|T=t)/P(L<T \leq R)}.
#' Its estimate \eqn{\widehat{a}(t)} is a left-continuous step function with
#' jumps at the observed truncation times.
#' By default, [test_ignorability_indtrunc()] tests for non-ignorable sampling
#' bias through the test statistic
#' \deqn{\sup_{\min_i T_i \leq t \leq \max_i T_i} |\widehat{a}(t) - 1|}
#' with the p-value computed by simulating from the estimated asymptotic null
#' distribution.
#' Another option is to compare two estimated event time cdfs: the NPMLE
#' \eqn{\widehat{F}(t)} which adjusts for double truncation and the empirical
#' cdf \eqn{\widehat{F}^*(t)} which does not adjust for double truncation.
#' The test statistic would then be
#' \deqn{\sup_t |\widehat{F}(t) - \widehat{F}^*(t)|.}
#'
#' @section Restricted time window and weighted tests:
#' When the NPMLE has high variance at extreme event times, the test may suffer
#' from reduced power.
#' One possible remedy is to restrict the time range of the test to some interval
#' \eqn{[\tau_1, \tau_2]} contained in \eqn{[\min_i T_i, \max_i T_i]}.
#' Another option is to down-weight event times with large variance through a
#' weight function \eqn{w(t)}.
#' The stabilized test statistic will have the form
#' \deqn{\sup_{\tau_1 \leq t \leq \tau_2} |w(t)(\widehat{h}(t) - h(t))|}
#' where \eqn{\widehat{h}(t)} is the NPMLE without assuming the null hypothesis
#' holds and \eqn{h(t)} is the reference value under the null.
#' See `vignette("nonparametric-analysis", package = "survdt")` for an illustration
#' with the [aids] data assuming vignettes were built when installing [survdt].
#'
#' @section No effective truncation:
#' A doubly truncated sample has no effective truncation when
#' \eqn{\max_i L_i < \min_i T_i} and \eqn{\max_i T_i \leq \min_i R_i}.
#' The estimated selection probability is equal to one across all event times
#' in this case, and its standard errors may not be reliable.
#' Typically one would conclude that the truncation mechanism is ignorable in
#' these types of samples, so standard methods can be applied for data analysis.
#'
#' @returns
#' [test_ignorability_indtrunc()] returns an object of class
#' `ignorability_indtrunc_test`, i.e. a list with the following components:
#' \item{n}{The complete case sample size.}
#' \item{n_unique}{The number of unique event times among complete cases.}
#' \item{n_miss}{The number of discarded observations (with missing values).}
#' \item{teststat}{The value of the observed test statistic.}
#' \item{pval}{The p-value for the test.}
#' \item{critval}{The critical value for the test at the user-specified level.}
#' \item{testresult}{Whether the test resulted in rejecting the null hypothesis
#'   of ignorable sampling bias.}
#' \item{sims}{A vector of the `B` simulations from the estimated null
#'   distribution of the test statistic.}
#' \item{test_type}{The matched `test_type` value.}
#' \item{level}{The user-supplied `level`.}
#' \item{B}{The number of simulations specified by the user.}
#' \item{timerange}{A vector with the minimum and maximum times used in the
#'   test.}
#' \item{wt_name}{A string giving the name of the user-supplied `wt_fn`, if any.}
#' \item{eventrange}{A vector with the unrestricted range of observed event times.}
#' \item{ests}{A data frame of estimates to be used by
#'   [plot.ignorability_indtrunc_test()].}
#'
#' The `print` method for `ignorability_indtrunc_test` objects displays a summary
#' of the test results, while the `plot` method returns a visualization comparing
#' the NPMLE and its reference value under the null hypothesis using a uniform
#' confidence band, generated through [ggplot2::ggplot()].
#'
#' @export
#'
#' @seealso
#' * [npmle()]: the nonparametric maximum likelihood estimator which forms the
#'   basis for these tests.
#' * `vignette("nonparametric-analysis", package = "survdt")`: an illustration
#'   of ignorability tests applied to the [aids] data, if vignettes were built
#'   when installing [survdt].
#'
#' @examples
#' igtest <- test_ignorability_indtrunc(Survdt(incu, ltrunc, rtrunc),
#'                                      data = aids)
#' igtest
#' plot(igtest)
#'
#' @references
#' de Uña‐Álvarez, J. (2023). Testing for an ignorable sampling bias under random
#' double truncation. *Statistics in Medicine*, **42**(20), 3732--3744.
#'
#' Vazquez, O., & Xie, S. X. (2025). Robust inverse probability weighted
#' estimators for doubly truncated Cox regression with closed-form standard
#' errors. *Lifetime Data Analysis*, **31**(2), 364–-393.
test_ignorability_indtrunc <- function(y, data = NULL,
                                       test_type = c("sel_prob", "cdf"),
                                       level = 0.95, B = 2000,
                                       restr_times = NULL, wt_fn = NULL){
  # check input
  fn_call <- match.call()
  if (missing(y)) stop('\n  argument "y" is missing, with no default')
  if (!is.null(data)){
    if (is.matrix(data)) data <- as.data.frame(data)
    stopifnot(is.data.frame(data))
    y <- eval(fn_call[["y"]], envir = data, enclos = parent.frame())
  }
  if (is.Survdt2(y)) stop("Input y should be a Survdt object, not Survdt2.",
                          " See ?survdt::survdt2to1")
  stopifnot(is.npmle(y) || is.Survdt(y))
  test_type <- match.arg(test_type)
  if (is.null(restr_times)) restr_times <- c(NA_real_, NA_real_)
  if (is.null(wt_fn)) {
    wt_name <- "none"
    wt_fn <- function(x) rep(1, length(x))
  }else{
    wt_name <- format(substitute(wt_fn))
  }
  stopifnot(is.character(test_type), is.vector(test_type), all(!is.na(test_type)),
            is.numeric(level), is.vector(level), all(!is.na(level)),
            is.numeric(B), is.vector(B), all(!is.na(B)),
            is.numeric(restr_times), is.vector(restr_times), is.function(wt_fn))
  stopifnot(length(test_type) == 1, length(level) == 1, length(B) == 1,
            length(restr_times) == 2)
  stopifnot(0 < level, level < 1, B > 1)
  B <- floor(B)

  # npmle
  if (is.Survdt(y)){
    y <- npmle(y, se = TRUE, cumhaz = FALSE, ainv = FALSE, infl = TRUE)
    if (!y[["converged"]]) stop("Fitted npmle did not converge")

  }
  sort_indx <- order(y[["masses"]]$time)
  unsort_indx <- order(sort_indx)
  n <- y[["n"]]
  n_unique <- nrow(y[["cdf"]])
  n_miss <- y[["n_miss"]]
  eventrange <- range(y[["masses"]]$time)
  time_lims <- eventrange
  if (!is.na(restr_times[1]) && (restr_times[1] >= time_lims[2]))
    stop("restr_times[1] must be less than the maximum observed event time")
  if (!is.na(restr_times[2]) && (restr_times[2] <= time_lims[1]))
    stop("restr_times[2] must be greater than the minimum observed event time")
  if (all(!is.na(restr_times)) && (restr_times[1] >= restr_times[2]))
    stop("Must have restr_times[1]<restr_times[2]")
  if (all((y[["masses"]]$ltrunc < time_lims[1]) &
          (time_lims[2] <= y[["masses"]]$rtrunc)))
    warning(paste0("All truncation intervals cover the entire event time range,",
                   " indicating no effective truncation. ",
                   "Test results may be unreliable."))
  if (n_unique == 1)
    stop("Ignorability is not testable with one unique event time.")

  test_window <- ifelse(is.na(restr_times), time_lims,
                        c(max(restr_times[1], time_lims[1]),
                          min(restr_times[2], time_lims[2])))
  # test statistic and null distribution
  if (test_type == "cdf"){
    if (is.null(y[["infl_cdf"]]))
      y$infl_cdf <- npmle_infl(y[["masses"]][sort_indx, , drop = FALSE],
                               already_sorted = TRUE)$L_F[, unsort_indx]
    wts <- wt_fn(y[["cdf"]][, "time", drop = TRUE])
    if (!is.numeric(wts) || !is.vector(wts))
      stop("wt_fn must return a numeric vector")
    if (length(wts) != nrow(y[["cdf"]]))
      stop("wt_fn output length does not match input")
    bad_times <- y[["cdf"]][is.na(wts) | is.infinite(wts), "time", drop = TRUE]
    if (length(bad_times) > 5) bad_times <- c(bad_times[1:5], "...")
    if (length(bad_times) > 0)
      stop(paste0("wt_fn produced infinite or missing values at time ",
                  paste0(bad_times, collapse = ", ")))

    sorted_times <- y[["masses"]]$time[sort_indx]
    unique_indx <- !duplicated(sorted_times, fromLast = TRUE)
    e_cdf <- cumsum(rep(1, n))[unique_indx] / n
    endpoints <- findInterval(test_window, sorted_times[unique_indx])
    time_indx <- endpoints[1]:endpoints[2]
    window_times <- (sorted_times[unique_indx])[time_indx]
    test_wts <- wts[time_indx]
    teststat <- max(abs(test_wts * (y[["cdf"]][time_indx, "cdf", drop = TRUE] -
                                      e_cdf[time_indx])))
    L_nulldist <- y[["infl_cdf"]][time_indx, , drop = FALSE] -
      sapply(y[["masses"]]$time, FUN = function(xi) {
        (xi <= window_times) - e_cdf[time_indx]
      })
    ests <- data.frame(time = y[["cdf"]][, "time", drop = TRUE],
                       npmle_cdf = y[["cdf"]][, "cdf", drop = TRUE],
                       empirical_cdf = e_cdf,
                       out_of_window = rep(TRUE, length(e_cdf)),
                       wt = wts)
    ests$out_of_window[time_indx] <- FALSE
  }else if (test_type == "sel_prob"){
    if (is.null(y[["infl_cdf"]])){
      infl_vals <- npmle_infl(y[["masses"]][sort_indx, , drop = FALSE],
                              infl_at = TRUE, already_sorted = TRUE)
    }else{
      infl_vals <- npmle_infl(y[["masses"]][sort_indx, , drop = FALSE],
                              infl_at = TRUE, L_F = y[["infl_cdf"]][, sort_indx],
                              already_sorted = TRUE)
    }
    wts <- wt_fn(infl_vals$infl_at$time)
    if (!is.numeric(wts) || !is.vector(wts))
      stop("wt_fn must return a numeric vector")
    if (length(wts) != length(infl_vals$infl_at$time))
      stop("wt_fn output length does not match input")
    bad_times <- infl_vals$infl_at$time[is.na(wts) | is.infinite(wts)]
    if (length(bad_times) > 5) bad_times <- c(bad_times[1:5], "...")
    if (length(bad_times) > 0)
      stop(paste0("wt_fn produced infinite or missing values at time ",
                  paste0(bad_times, collapse = ", ")))

    endpoints <- pmin(findInterval(test_window, infl_vals$infl_at$time,
                                   left.open = TRUE) + 1,
                      length(infl_vals$infl_at$time))
    lrindx <- seq(endpoints[1], endpoints[2])
    test_wts <- wts[lrindx]
    teststat <- max(abs(test_wts * (infl_vals$infl_at$at_btwn[lrindx - 1] - 1)))
    L_nulldist <- infl_vals$infl_at$L_at_btwn[lrindx - 1, , drop = FALSE]
    ests <- data.frame(time = infl_vals$infl_at$time,
                       at = c(0, infl_vals$infl_at$at_btwn),
                       overall_sampling_prob =
                         rep(y[["overall_sampling_prob"]]["prob"],
                             length(infl_vals$infl_at$time)),
                       out_of_window = rep(TRUE, length(infl_vals$infl_at$time)),
                       wt = wts)
    ests$out_of_window[lrindx] <- FALSE
  }

  sims <- replicate(B, {
    wt <- stats::rnorm(n, 1, 1)
    max(abs(test_wts * c(L_nulldist %*% wt / n)))
  })
  critval <- stats::quantile(sims, level)

  res <- list(n = n, n_unique = n_unique, n_miss = n_miss, teststat = teststat,
              pval = mean(sims >= teststat), critval = critval,
              testresult = teststat > critval, sims = sims,
              test_type = test_type, level = level, B = B,
              timerange = test_window, wt_name = wt_name, eventrange = eventrange,
              ests = ests)
  class(res) <- "ignorability_indtrunc_test"
  res
}

#' @rdname test_ignorability_indtrunc
#' @export
plot.ignorability_indtrunc_test <- function(x, level, ...){
  if (missing(level)) level <- x[["level"]]
  stopifnot(is.numeric(level), is.vector(level), all(!is.na(level)))
  stopifnot(length(level) == 1, all(level > 0), all(level < 1))
  q <- stats::quantile(x[["sims"]], level)

  ests <- NULL
  if (x[["test_type"]] == "cdf"){
    ests <- data.frame(time = x[["ests"]]$time,
                       npmle = x[["ests"]]$npmle_cdf,
                       reference = x[["ests"]]$empirical_cdf,
                       out_of_window = x[["ests"]]$out_of_window,
                       wt = x[["ests"]]$wt)
    ests$lower <- pmax(ests$reference - (q / abs(ests$wt)), 0)
    ests$upper <- pmin(ests$reference + (q / abs(ests$wt)), 1)
  }else if (x[["test_type"]] == "sel_prob"){
    msel_prob <- x[["ests"]]$overall_sampling_prob[1]
    ests <- data.frame(time = x[["ests"]]$time,
                       npmle = msel_prob * x[["ests"]]$at,
                       reference = rep(msel_prob, nrow(x[["ests"]])),
                       out_of_window = x[["ests"]]$out_of_window,
                       wt = x[["ests"]]$wt)
    ests$lower <- pmax(ests$reference * (1 - (q / abs(ests$wt))), 0)
    ests$upper <- pmin(ests$reference * (1 + (q / abs(ests$wt))), 1)
  }
  ests$lower[ests$out_of_window] <- 0
  ests$upper[ests$out_of_window] <- 1
  stairdir <- ifelse(x[["test_type"]] == "cdf", "hv", "vh")

  with(ests,
       ggplot2::ggplot(ests) +
         ggplot2::geom_step(ggplot2::aes(x = time, y = lower),
                            linetype = "dashed", direction = stairdir) +
         ggplot2::geom_step(ggplot2::aes(x = time, y = upper),
                            linetype = "dashed", direction = stairdir) +
         ggplot2::geom_step(ggplot2::
                              aes(x = time, y = reference,
                                  color = "assuming ignorable sampling bias"),
                            direction = stairdir) +
         ggplot2::geom_step(ggplot2::aes(x = time, y = npmle, color = "NPMLE"),
                            direction = stairdir) +
         ggplot2::scale_color_manual(breaks =
                                       c("NPMLE",
                                         "assuming ignorable sampling bias"),
                                     values = c("maroon", "black"),
                                     guide =
                                       ggplot2::guide_legend(override.aes =
                                                               list(lwd = 2))) +
         ggplot2::labs(x = "Time",
                       y = ifelse(x[["test_type"]] == "cdf",
                                  "Cumulative distribution function",
                                  "Selection probability"),
                       color = "") +
         ggplot2::coord_cartesian(ylim = c(0, 1.01), xlim = x[["timerange"]],
                                  expand = FALSE) +
         ggplot2::theme_classic() +
         ggplot2::theme(legend.position = "bottom"))
}

#' @rdname test_ignorability_indtrunc
#' @export
print.ignorability_indtrunc_test <- function(x, ...){
  pval <- format(x[["pval"]], digits = 2, nsmall = 1)
  pval <- ifelse(pval == "0.0",
                 paste0("<", 1 / x[["B"]]),
                 paste0("=", pval))
  cat(paste0("\n",
             "Ignorable sampling bias test under quasi-independent truncation.",
                "\n",
                "\n",
             "  NPMLE fit based on ", x[["n"]], " complete samples (",
                x[["n_miss"]], " dropped due to missingness)",
                "\n",
             "    with ", x[["n_unique"]], " unique event times.",
                "\n",
             "  Min event time: ", x[["eventrange"]][1],
                "\n",
             "  Max event time: ", x[["eventrange"]][2],
                "\n",
                "\n",
             "  Supremum test of type ", '"', x[["test_type"]], '".',
                "\n",
             "  Test statistic: ",
                  format(x[["teststat"]], digits = 2, nsmall = 1),
                  "\n",
             "    Time range:   [", x[["timerange"]][1], ", ",
                  x[["timerange"]][2], "]",
                  "\n",
             "    Time weights: ", x[["wt_name"]],
                  "\n",
             "  Critical value: ",
                  format(x[["critval"]], digits = 2, nsmall = 1),
                " at level ", x[["level"]],
                "\n",
             "  Significant evidence ", ifelse(x[["testresult"]], "", "not "),
                "found against ignorability (p", pval, ").",
                "\n",
             "  Results based on ", x[["B"]], " simulations from the estimated ",
                "null distribution.",
                "\n",
                "\n"))
  invisible(x)
}

#' Test for dependence between truncation times and the event time
#'
#' @description
#' Computes the conditional Kendall's tau rank correlation between the event
#' time and each of the two truncation times, accounting for double truncation.
#' Then tests whether both correlations are equal to zero.
#'
#' Typically used to determine if nonparametric analysis can be done using the
#' NPMLE, which requires quasi-independence (see [npmle()]).
#'
#' @param y A `Survdt` object or expression. Observations with missing values are
#'   discarded. See [Survdt()].
#' @param data An optional data frame used to evaluate `y`.
#' @param singular_thresh The numerical threshold for determining whether the
#'   variance matrix for the correlations is singular (default `1e-9`).
#'   This can occur when the truncation times are a constant distance from each
#'   other.
#' @inheritParams test_ignorability_indtrunc
#'
#' @details
#' The conditional Kendall's tau rank correlation between the left truncation
#' time and event time is estimated by the average of
#' \deqn{\text{sign}\{(T_i - T_j)(L_i - L_j)\}}
#' across all comparable pairs of subjects \eqn{(i,j)}.
#' A pair is called comparable if \eqn{L_j<T_i \leq R_j} and \eqn{L_i<T_j \leq R_i},
#' which ensures that the order of the pair's times is not influenced by truncation
#' under quasi-independence.
#' Similarly, the conditional Kendall's tau rank correlation between the right
#' truncation time and event time is estimated by the average of
#' \deqn{\text{sign}\{(T_i - T_j)(R_i - R_j)\}}
#' across the same comparable pairs of subjects \eqn{(i,j)}.
#'
#' Under quasi-independent truncation, both conditional Kendall's tau rank
#' correlations should converge to zero in large samples.
#'
#' @returns
#' [test_quasiindep_ctau()] returns an object of class `quasiindep_ctau_test`,
#' i.e. a list with the following components:
#' \item{tau}{A numerical vector of length two containing the estimated
#'   conditional Kendall's tau rank correlation (1) between the event time and
#'   left truncation time, and (2) between the event time and right truncation
#'   time.}
#' \item{teststat}{The chi-squared test statistic for testing the null hypothesis
#'   that both correlations are zero.}
#' \item{df}{The degrees of freedom for `teststat`.}
#' \item{pval}{The p-value for testing that both correlations are zero.}
#' \item{var_matrix}{The estimated variance matrix for the two conditional
#'   Kendall's tau correlation estimates.}
#' \item{singular}{Whether `var_matrix` was determined to be singular.}
#' \item{prob_comp}{The fraction of subject pairs that are comparable.}
#'
#' The `print` method for `quasiindep_ctau_test` objects displays a summary of
#' the test results.
#'
#' @export
#'
#' @seealso
#' * [test_quasiindep_covariates()]: a test for dependent truncation when
#'   covariates are involved, e.g. when aiming to analyze data with
#'   [coxph_indtrunc()].
#'
#' @examples
#' test_quasiindep_ctau(Survdt(incu, ltrunc, rtrunc), aids)
#'
#' @references
#' Martin, E. C., & Betensky, R. A. (2005). Testing quasi-independence of failure
#' and truncation times via conditional Kendall's tau. *Journal of the American
#' Statistical Association*, **100**(470), 484--492.
test_quasiindep_ctau <- function(y, data = NULL, singular_thresh = 1e-9){
  # check input
  fn_call <- match.call()
  if (missing(y)) stop('\n  argument "y" is missing, with no default')
  if (!is.null(data)){
    if (is.matrix(data)) data <- as.data.frame(data)
    stopifnot(is.data.frame(data))
    y <- eval(fn_call[["y"]], envir = data, enclos = parent.frame())
  }
  if (is.Survdt2(y)) stop("Input y should be a Survdt object, not Survdt2.",
                          " See ?survdt::survdt2to1")
  stopifnot(is.Survdt(y),
            is.numeric(singular_thresh), is.vector(singular_thresh))
  stopifnot(length(singular_thresh) == 1, !any(is.na(singular_thresh)))
  stopifnot(singular_thresh > 0)

  # missing data
  n_init <- length(y)
  complete_cases <- !is.na(y)
  if (sum(complete_cases) == 0)
    stop("All subjects have missing data")
  y <- y[complete_cases, ]
  n <- length(y)
  n_miss <- n_init - n

  # components for tau and variance matrix
  comparable <- sapply(seq_len(n), FUN = function(i) {
    (y[, "ltrunc", drop = TRUE] < y[i, "time", drop = TRUE]) &
      (y[i, "time", drop = TRUE] <= y[, "rtrunc", drop = TRUE]) &
      (y[i, "ltrunc", drop = TRUE] < y[, "time", drop = TRUE]) &
      (y[, "time", drop = TRUE] <= y[i, "rtrunc", drop = TRUE])
  })
  ests <- rowSums(sapply(seq_len(n), FUN = function(i){
    if (any(comparable[-i, i])){
      comp_indx <- which(comparable[, i])
      comp_indx <- comp_indx[comp_indx != i]

      n_pairs <- 0
      new_pairs <- c(0, 0)
      if (any(comp_indx > i)){
        pair_indx <- comp_indx[comp_indx > i]
        n_pairs <- length(pair_indx)
        new_pairs <- c(sum(sign((y[i, "time", drop = TRUE] -
                                   y[pair_indx, "time", drop = TRUE]) *
                                  (y[i, "ltrunc", drop = TRUE] -
                                     y[pair_indx, "ltrunc", drop = TRUE]))),
                       sum(sign((y[i, "time", drop = TRUE] -
                                   y[pair_indx, "time", drop = TRUE]) *
                                  (y[i, "rtrunc", drop = TRUE] -
                                     y[pair_indx, "rtrunc", drop = TRUE]))))
      }

      new_triples <- c(0, 0, 0)
      if (length(comp_indx) > 1){
        ltsum <- sum(sign((y[i, "time", drop = TRUE] -
                             y[comp_indx, "time", drop = TRUE]) *
                            (y[i, "ltrunc", drop = TRUE] -
                               y[comp_indx, "ltrunc", drop = TRUE])))
        rtsum <- sum(sign((y[i, "time", drop = TRUE] -
                             y[comp_indx, "time", drop = TRUE]) *
                            (y[i, "rtrunc", drop = TRUE] -
                               y[comp_indx, "rtrunc", drop = TRUE])))

        new_triples <- c(ltsum^2, ltsum * rtsum, rtsum^2)
      }
      c(new_pairs, new_triples, n_pairs)
    }else{
      c(0, 0, 0, 0, 0, 0)
    }
  }))

  # results
  tau <- ests[1:2] / ests[6]
  prob_comp <- ests[6] / (n * (n - 1) / 2)
  n3 <- n * (n-1)^2
  var_matrix <- matrix(c((ests[3] / n3) - (prob_comp * tau[1])^2,
                         (ests[4] / n3) - (tau[1] * tau[2] * prob_comp^2),
                         (ests[4] / n3) - (tau[1] * tau[2] * prob_comp^2),
                         (ests[5] / n3) - (prob_comp * tau[2])^2), nrow = 2)
  var_matrix <- var_matrix * 4 / (n * prob_comp^2)
  singular <- (var_matrix[1, 1] * var_matrix[2, 2] - var_matrix[1, 2]^2) <
    singular_thresh
  if (singular){
    teststat <- ifelse(var_matrix[1, 1] > 0, tau[1]^2 / (var_matrix[1, 1]), NA)
    df <- 1
    pval <- stats::pchisq(teststat, df, lower.tail = FALSE)
  }else{
    teststat <- t(tau) %*% solve(var_matrix) %*% tau
    df <- 2
    pval <- stats::pchisq(teststat, df, lower.tail = FALSE)
  }

  res <- list(tau = tau, teststat = teststat,
              df = ifelse(is.na(teststat), NA, df), pval = pval,
              var_matrix = var_matrix, singular = singular,
              prob_comp = prob_comp)
  class(res) <- "quasiindep_ctau_test"
  return(res)
}

#' @rdname test_quasiindep_ctau
#' @export
print.quasiindep_ctau_test <- function(x, ...){
  pval <- format(x[["pval"]], digits = 2, nsmall = 1)
  cat(paste0("\n",
             "Quasi-independent truncation test by conditional rank correlations.",
             "\n",
             "\n",
             "  Conditional Kendall's tau between event time and...",
                  "\n",
             "    left truncation time: ",
                     format(x[["tau"]][1], digits = 2, nsmall = 1),
                  "\n",
             "    right truncation time: ",
                     format(x[["tau"]][2], digits = 2, nsmall = 1),
             "\n",
             "  Test statistic: chisq=",
                   format(x[["teststat"]], digits = 2, nsmall = 1),
                ", df=", x[["df"]],
             "\n",
             "  p-value: ", pval,
             "\n",
             "  Proportion of subject pairs comparable was ",
                format(x[["prob_comp"]], digits = 2, nsmall = 1), ".",
             "\n",
             "\n"))
  invisible(x)
}


#' Test for survival differences across groups
#'
#' @description
#' Tests for any difference in event time distribution by comparing
#' the stratified and unstratified estimates obtained using the NPMLE.
#'
#' @param formula A formula with a `Survdt` response and stratification variables
#'   on the right hand side.
#'   Note that subtraction will not remove stratification variables here.
#'   Subjects with missing values are discarded.
#'   See [Survdt()].
#' @param data An optional data frame used to evaluate `formula`.
#' @param test_type The test statistic to use: `"survival"` (default) or
#'   `"cumhaz"`.
#'   See below.
#' @param max_iter The maximum number of iterations to use within each call to
#' [npmle()]. If missing then the default setting of [npmle()] is used.
#' @param simple_labels Whether to drop the factor names from the stratum labels
#' (Default `FALSE`).
#' @inheritParams test_ignorability_indtrunc
#'
#' @details
#' Let \eqn{\widehat{S}(t|s)} be the NPMLE for the survival function in stratum
#' \eqn{s}.
#' By default, [test_samplediff_indtrunc()] tests for event time distribution
#' differences through the test statistic
#' \deqn{\max_s\sup_{\min_i T_i \leq t \leq \max_i T_i} |\widehat{S}(t|s) - \widehat{S}(t)|}
#' where \eqn{\widehat{S}(t)} is the unstratified NPMLE.
#' Another option is to compare the stratified cumulative hazards
#' \eqn{\widehat{\Lambda}(t|s)} with the unstratified NPMLE \eqn{\widehat{\Lambda}(t)}
#' through the test statistic
#' \deqn{\max_s\sup_{\min_i T_i \leq t \leq \max_i T_i}
#'       |\widehat{\Lambda}(t|s) - \widehat{\Lambda}(t)|.}
#' The p-value in all cases is computed by simulating from the estimated asymptotic
#' null distribution.
#'
#' @inheritSection test_ignorability_indtrunc Restricted time window and weighted tests
#'
#' @returns
#' [test_samplediff_indtrunc()] returns an object of class
#' `samplediff_indtrunc_test`, i.e. a list with the following components:
#' \item{n}{The complete case sample size.}
#' \item{n_unique}{The number of unique event times among complete cases.}
#' \item{n_miss}{The number of discarded observations (with missing values).}
#' \item{teststat}{The value of the observed test statistic.}
#' \item{pval}{The p-value for the test.}
#' \item{critval}{The critical value for the test at the user-specified level.}
#' \item{testresult}{Whether the test results in rejecting the null
#'   hypothesis of no differences across strata.}
#' \item{sims}{A vector of the `B` simulations from the estimated null
#'   distribution of the test statistic.}
#' \item{test_type}{The matched `test_type` value.}
#' \item{level}{The user-supplied `level`.}
#' \item{B}{The number of simulations specified by the user.}
#' \item{timerange}{A vector with the minimum and maximum times used in the test.}
#' \item{wt_name}{A string giving the name of the user-supplied `wt_fn`, if any.}
#' \item{eventrange}{A vector with the unrestricted range of observed event times.}
#' \item{strata_ests}{A data frame of estimates to be used by
#'   [plot.samplediff_indtrunc_test()].}
#' \item{strata_summary}{Some summary statistics for each stratum.}
#'
#' The `print` method for `samplediff_indtrunc_test` objects displays a summary
#' of the test results, while the `plot` method returns a visualization comparing
#' the stratified and unstratified NPMLE using a uniform confidence band,
#' generated through [ggplot2::ggplot()].
#'
#' @export
#'
#' @seealso
#' * [npmle()]: the nonparametric maximum likelihood estimator which forms the
#'   basis for these tests.
#' * `vignette("nonparametric-analysis", package = "survdt")`: an illustration
#'   of group tests applied to the [aids] data, if vignettes were built when
#'   installing [survdt].
#'
#' @examples
#' difftest <- test_samplediff_indtrunc(Survdt(incu, ltrunc, rtrunc) ~ age_gp,
#'                                      data = aids,
#'                                      restr_times = c(NA, 70))
#' difftest
#' plot(difftest)
#'
#' @references
#' Vazquez, O., & Xie, S. X. (2025). Robust inverse probability weighted
#' estimators for doubly truncated Cox regression with closed-form standard
#' errors. *Lifetime Data Analysis*, **31**(2), 364–-393.
test_samplediff_indtrunc <- function(formula, data = NULL,
                                     test_type = c("survival", "cumhaz"),
                                     level = 0.95, B = 2000,
                                     restr_times = NULL, wt_fn = NULL,
                                     max_iter = NULL, simple_labels = FALSE){
  # check input
  if (missing(formula))
    stop('\n  argument "formula" is missing, with no default')
  stopifnot(inherits(formula, "formula"))
  if (length(formula) < 3) stop("The formula is missing a LHS or a RHS")
  if (!is.null(data) && is.matrix(data)) data <- as.data.frame(data)
  stopifnot(is.null(data) || is.data.frame(data))

  mf <- stats::model.frame(stats::update(formula, ~.-1), data = data,
                           na.action = stats::na.pass)
  if (attr(attr(mf, "terms"), "response") == 0)
    stop("formula is missing a response")
  y <- mf[[attr(attr(mf, "terms"), "response")]]
  if (length(mf) < 2) stop("formula is missing stratafiction variables on RHS")
  strata_vars <- mf[-attr(attr(mf, "terms"), "response")]
  complete_cases <- rowSums(is.na(mf)) == 0
  factor_names <- c(apply(strata_vars[1, , drop = FALSE],
                          MARGIN = 1, FUN = names))
  stopifnot(is.logical(simple_labels), is.vector(simple_labels),
            length(simple_labels) == 1, all(!is.na(simple_labels)))
  if (simple_labels == TRUE) factor_names <- rep("", length(factor_names))
  s <- apply(strata_vars, MARGIN = 1, FUN = function(x) {
    paste0(factor_names, x, sep = "", collapse = ", ")
  })

  if (is.Survdt2(y))
    stop(paste0("Response should be a Survdt object with one observation",
                " per subject (not Survdt2). See ?survdt::survdt2to1"))
  test_type <- match.arg(test_type)
  if (is.null(restr_times)) restr_times <- c(NA_real_, NA_real_)
  if (is.null(wt_fn)) {
    wt_name <- "none"
    wt_fn <- function(x) rep(1, length(x))
  }else{
    wt_name <- format(substitute(wt_fn))
  }
  if (is.null(max_iter)) max_iter <- formals(npmle)[["max_iter"]]
  stopifnot(is.Survdt(y),
            is.character(test_type), is.vector(test_type), all(!is.na(test_type)),
            is.numeric(level), is.vector(level), !any(is.na(level)),
            is.numeric(B), is.vector(B), !any(is.na(B)),
            is.numeric(restr_times), is.vector(restr_times), is.function(wt_fn),
            is.numeric(max_iter), is.vector(max_iter), !any(is.na(max_iter)))
  stopifnot(length(y) == length(s), length(test_type) == 1, length(level) == 1,
            all(level > 0), all(level < 1), length(B) == 1, all(B > 1),
            length(restr_times) == 2, length(max_iter) == 1, all(max_iter > 1))
  B <- floor(B)
  max_iter <- floor(max_iter)

  # missing data
  n_init <- length(y)
  if (sum(complete_cases) == 0) stop("No observations without missing data")
  if (length(unique(s)) != length(unique(s[complete_cases])))
    warning("Dropping strata with no complete cases")
  y <- y[complete_cases, ]
  n <- length(y)
  s <- s[complete_cases]
  s <- factor(s, levels = unique(s[order(c(strata_vars[complete_cases, 1,
                                                       drop = TRUE])[1:n])]))
  sort_indx <- order(y[, "time", drop = TRUE])
  y <- y[sort_indx, ]
  s <- s[sort_indx]
  strata_vals <- unique(s)
  n_strata <- length(strata_vals)
  n_miss <- n_init - n
  if (n_strata < 2) stop("Only one stratum in complete cases")

  eventrange <- range(y[, "time", drop = TRUE])
  time_lims <- eventrange
  if (!is.na(restr_times[1]) && (restr_times[1] >= time_lims[2]))
    stop("restr_times[1] must be less than the maximum observed event time")
  if (!is.na(restr_times[2]) && (restr_times[2] <= time_lims[1]))
    stop("restr_times[2] must be greater than the minimum observed event time")
  if (all(!is.na(restr_times)) && (restr_times[1] >= restr_times[2]))
    stop("Must have restr_times[1]<restr_times[2]")
  n_unique_strata <- stats::aggregate(y[, "time", drop = TRUE] ~ s,
                                      FUN = function(x) length(unique(x)))
  small_strata <- n_unique_strata[n_unique_strata[, 2, drop = TRUE] < 2, 1,
                                  drop = TRUE]
  if (length(n_unique_strata) > 5)
    n_unique_strata <- c(as.character(n_unique_strata[1:5]), "...")
  if (length(small_strata) > 0)
    stop(paste0("Less than two unique event times found in stratum: ",
                paste0(small_strata, collapse = "; ")))
  strata_summary <- data.frame(strata = n_unique_strata[, 1, drop = TRUE],
                               strata_size =
                                 sapply(n_unique_strata[, 1, drop = TRUE],
                                        FUN = function(x) sum(s == x)),
                               unique_event_times =
                                 n_unique_strata[, 2, drop = TRUE])

  test_window <- ifelse(is.na(restr_times), time_lims,
                        c(max(restr_times[1], time_lims[1]),
                          min(restr_times[2], time_lims[2])))

  # unstratified npmle
  pooled_npmle <- npmle(y, se = TRUE, cumhaz = test_type == "cumhaz",
                        infl = TRUE, max_iter = max_iter)
  if (pooled_npmle[["converged"]] == FALSE)
    stop("Unstratified npmle() did not converge")
  n_unique <- nrow(pooled_npmle[["cdf"]])
  wts <- wt_fn(pooled_npmle[["cdf"]][, "time", drop = TRUE])
  if (!is.numeric(wts) || !is.vector(wts))
    stop("wt_fn must return a numeric vector")
  bad_times <- pooled_npmle[["cdf"]][is.na(wts) | is.infinite(wts), "time",
                                     drop = TRUE]
  if (length(bad_times) > 5) bad_times <- c(bad_times[1:5], "...")
  if (length(bad_times) > 0)
    stop(paste0("wt_fn produced infinite or missing values at time ",
                paste0(bad_times, collapse = ", ")))

  endpoints_test <- findInterval(test_window,
                                 pooled_npmle[["cdf"]][, "time", drop = TRUE])
  test_indx <- endpoints_test[1]:endpoints_test[2]
  n_time_total <- nrow(pooled_npmle[["cdf"]])
  n_time_test <- length(test_indx)
  if (test_type == "survival"){
    est_unstrat <- 1 - pooled_npmle[["cdf"]][, "cdf", drop = TRUE]
    L_unstrat <- pooled_npmle[["infl_cdf"]][test_indx, , drop = FALSE]
  }else{
    est_unstrat <- pooled_npmle[["cumhaz"]][, "cumhaz", drop = TRUE]
    L_unstrat <- pooled_npmle[["infl_cumhaz"]][test_indx, , drop = FALSE]
  }

  # strata npmle and null distribution
  L_nulldist <- matrix(nrow = n_time_test * n_strata, ncol = n)
  test_wts <- rep(wts[test_indx], n_strata)
  new_out_of_window <- pooled_npmle[["cdf"]][, "cdf", drop = TRUE] <= 0
  strata_ests <- data.frame(strata = rep(strata_vals, each = n_time_total),
                            time = rep(pooled_npmle[["cdf"]][, "time",
                                                             drop = TRUE],
                                       n_strata),
                            unstrat_npmle = rep(est_unstrat, n_strata),
                            npmle = rep(NA, n_time_total * n_strata),
                            out_of_window = rep(!(seq_len(n_time_total) %in%
                                                    test_indx),
                                                n_strata),
                            wt = rep(wts, n_strata))
  for (i in seq_len(n_strata)){
    strata_indx <- s == strata_vals[i]
    strata_npmle <- npmle(y[strata_indx, ], se = TRUE,
                          cumhaz = test_type == "cumhaz", infl = TRUE,
                          max_iter = max_iter)
    if (strata_npmle[["converged"]] == FALSE)
      stop(paste0("Stratified npmle() did not converge in stratum ",
                  strata_vals[i]))

    rows_L <- n_time_test * (i-1) + seq_len(n_time_test)
    rows_ests <- n_time_total * (i-1) + seq_len(n_time_total)
    timeindx_s <- findInterval(strata_ests$time[rows_ests],
                               strata_npmle[["cdf"]][, "time", drop = TRUE]) + 1

    nsratio <- n / sum(strata_indx)
    if (test_type == "survival"){
      est_strat <- 1 -
        c(0, strata_npmle[["cdf"]][, "cdf", drop = TRUE], 1)[timeindx_s]
      first_Lrow <- strata_npmle[["infl_cdf"]][1, , drop = TRUE]
      last_Lrow <- strata_npmle[["infl_cdf"]][nrow(strata_npmle[["infl_cdf"]]), ,
                                              drop = TRUE]
      L_strat <- rbind(nsratio * first_Lrow,
                       nsratio * strata_npmle[["infl_cdf"]],
                       nsratio * last_Lrow)[timeindx_s[test_indx], , drop = FALSE]
    }else{
      est_strat <- c(0,
                     strata_npmle[["cumhaz"]][, "cumhaz", drop = TRUE],
                     strata_npmle[["cumhaz"]][nrow(strata_npmle[["cumhaz"]]),
                                              "cumhaz"])[timeindx_s]
      first_Lrow <- strata_npmle[["infl_cumhaz"]][1, , drop = TRUE]
      last_Lrow <-
        strata_npmle[["infl_cumhaz"]][nrow(strata_npmle[["infl_cumhaz"]]), ,
                                      drop = TRUE]
      L_strat <- rbind(nsratio * first_Lrow,
                       nsratio * strata_npmle[["infl_cumhaz"]],
                       nsratio * last_Lrow)[timeindx_s[test_indx], ,
                                            drop = FALSE]
    }
    strata_ests$npmle[rows_ests] <- est_strat
    L_nulldist[rows_L, ] <- -L_unstrat
    L_nulldist[rows_L, strata_indx] <- L_nulldist[rows_L, strata_indx,
                                                  drop = FALSE] +
      L_strat
  }
  if (any(new_out_of_window)){
    strata_ests$out_of_window <- strata_ests$out_of_window |
      rep(new_out_of_window, n_strata)
    L_nulldist[rep(new_out_of_window[test_indx], n_strata), ] <- 0

    testindx_range <- range(test_indx[!new_out_of_window[test_indx]])
    test_window[1] <- max(test_window[1],
                          pooled_npmle[["cdf"]][testindx_range[1], "time",
                                                drop = TRUE])
    if (testindx_range[2] < n_time_total)
      test_window[2] <- min(test_window[2],
                            pooled_npmle[["cdf"]][testindx_range[2] + 1, "time",
                                                  drop = TRUE])
  }

  # results
  teststat <-
    max(abs(strata_ests$wt[!strata_ests$out_of_window] *
              (strata_ests$npmle[!strata_ests$out_of_window] -
                 strata_ests$unstrat_npmle[!strata_ests$out_of_window])))
  sims <- replicate(B, {
    wt <- stats::rnorm(n, 1, 1)
    max(abs(test_wts * c(L_nulldist %*% wt / n)))
  })
  critval <- stats::quantile(sims, level)

  res <- list(n = n, n_unique = n_unique, n_miss = n_miss, teststat = teststat,
              pval = mean(sims >= teststat), critval = critval,
              testresult = teststat > critval, sims = sims, test_type = test_type,
              level = level, B = B, timerange = test_window, wt_name = wt_name,
              eventrange = eventrange, strata_ests = strata_ests,
              strata_summary = strata_summary)
  class(res) <- "samplediff_indtrunc_test"
  res
}

#' @rdname test_samplediff_indtrunc
#' @export
plot.samplediff_indtrunc_test <- function(x, level, ...){
  if (missing(level)) level <- x[["level"]]
  stopifnot(is.numeric(level), is.vector(level), all(!is.na(level)))
  stopifnot(length(level) == 1, all(level > 0), all(level < 1))
  q <- stats::quantile(x[["sims"]], level)
  ests <- x[["strata_ests"]]

  upper_bounds <- ests$unstrat_npmle[!ests$out_of_window] +
    (q / abs(ests$wt[!ests$out_of_window]))
  upper_cutoff <- ifelse(x[["test_type"]] == "survival", 1,
                         max(max(ests$npmle[!ests$out_of_window]),
                             max(ests$unstrat_npmle[!ests$out_of_window]),
                             max(upper_bounds[!is.infinite(upper_bounds)])) *
                           1.01)
  ests$lower <- ifelse(ests$out_of_window, 0,
                       pmax(0, ests$unstrat_npmle - (q / abs(ests$wt))))
  ests$upper <- ifelse(ests$out_of_window, upper_cutoff,
                       pmin(upper_cutoff, ests$unstrat_npmle + (q / abs(ests$wt))))

  ylab <-  ifelse(x[["test_type"]] == "survival",
                  "Survival function", "Cumulative hazard")
  with(ests,
       ggplot2::ggplot(ests) +
         ggplot2::geom_step(ggplot2::aes(x = time, y = lower),
                            linetype = "dashed", direction = "hv") +
         ggplot2::geom_step(ggplot2::aes(x = time, y = upper),
                            linetype = "dashed", direction = "hv") +
         ggplot2::geom_step(ggplot2::aes(x = time, y = npmle, group = strata,
                                         color = "stratified NPMLE"),
                            direction = "hv") +
         ggplot2::geom_step(ggplot2::aes(x = time, y = unstrat_npmle,
                                         color = "unstratified NPMLE"),
                            direction = "hv") +
         ggplot2::scale_color_manual(breaks = c("stratified NPMLE",
                                                "unstratified NPMLE"),
                                     values = c("maroon", "black"),
                                     guide =
                                       ggplot2::guide_legend(override.aes =
                                                               list(lwd = 2))) +
         ggplot2::labs(x = "Time", y = ylab, color = "") +
         ggplot2::coord_cartesian(ylim = c(0, upper_cutoff * 1.01),
                                  xlim = x[["timerange"]],
                                  expand = FALSE) +
         ggplot2::theme_classic() +
         ggplot2::theme(legend.position = "bottom"))
}

#' @rdname test_samplediff_indtrunc
#' @export
print.samplediff_indtrunc_test <- function(x, ...){
  pval <- format(x[["pval"]], digits = 2, nsmall = 1)
  pval <- ifelse(pval == "0.0",
                 paste0("<", 1 / x[["B"]]),
                 paste0("=", pval))
  cat(paste0("\n",
             "Test for group differences under quasi-independent truncation.",
             "\n",
             "\n",
             "  Unstratified NPMLE fit based on ", x[["n"]], " complete samples (",
             x[["n_miss"]], " dropped due to missingness)",
             "\n",
             "    with ", x[["n_unique"]], " unique event times.",
             "\n",
             "  Min event time: ", x[["eventrange"]][1],
             "\n",
             "  Max event time: ", x[["eventrange"]][2],
             "\n",
             "\n",
             "  Supremum test of type ", '"', x[["test_type"]], '".',
             "\n",
             "  Test statistic: ",
                  format(x[["teststat"]], digits = 2, nsmall = 1),
             "\n",
             "    Time range:   [", x[["timerange"]][1], ", ",
             x[["timerange"]][2], "]",
             "\n",
             "    Time weights: ", x[["wt_name"]],
             "\n",
             "  Critical value: ",
                  format(x[["critval"]], digits = 2, nsmall = 1),
                " at level ", x[["level"]],
             "\n",
             "  Significant evidence ", ifelse(x[["testresult"]], "", "not "),
             "found against equality across strata (p", pval, ").",
             "\n",
             "  Results based on ", x[["B"]], " simulations from the estimated ",
             "null distribution.",
             "\n",
             "\n",
             "Summary of the ", nrow(x[["strata_summary"]]), " groups compared:",
             "\n"))

  sort_indx <- order(x[["strata_summary"]][, "strata_size", drop = TRUE],
                     decreasing = TRUE)
  strata_summary <- x[["strata_summary"]][sort_indx,
                                          c("strata",
                                            "strata_size",
                                            "unique_event_times"),
                                          drop = FALSE]
  colnames(strata_summary) <- c("stratum", "size", "unique event times")
  if (nrow(x[["strata_summary"]]) > 10){
    print(strata_summary[1:10, , drop = FALSE],
          row.names = FALSE)
    cat("  ...")
    cat("\n\n")
  }else{
    print(strata_summary, row.names = FALSE)
    cat("\n")
  }
  invisible(x)
}


#' Test for dependence between truncation times and the event time or covariates
#'
#' @description
#' Implements a two-stage test for dependence between the truncation times and
#' the event time and covariates that first tests within covariate strata and then
#' across strata.
#'
#' Typically used to check the underlying assumptions for inverse probability
#' weighted regression with NPMLE weights, e.g. as used in [coxph_indtrunc()].
#'
#' @inheritParams test_samplediff_indtrunc
#'
#' @details
#' Implements a nonparametric test for dependent truncation to check if the
#' selection probability depends on either the event times or covariates.
#' The test has two stages:
#' 1. Test for dependence between event and truncation times stratified by
#'    covariate groups using conditional Kendall's tau
#'    (see [test_quasiindep_ctau()]).
#'    The aggregate p-value for this stage is computed from a chi-squared
#'    distribution.
#' 2. Test whether the selection probability depends on covariates by comparing
#'    the stratified and unstratified selection probabilities estimated using the
#'    NPMLE.
#'    Let \eqn{\widehat{\pi}(t|s)} be the estimate in stratum \eqn{s}, and
#'    \eqn{\widehat{\pi}(t)} be the unstratified estimate.
#'    Both are left-continuous step functions with jumps at observed truncation
#'    times.
#'    By default, [test_quasiindep_covariates()] uses the test statistic
#'    \deqn{\max_s\sup_{\min_i T_i\leq t \leq \max_i T_i}
#'          |\widehat{\pi}(t|s)-\widehat{\pi}(t)|}
#'    to compare selection probabilities across strata.
#'    The p-value for this stage is computed by simulating from the estimated
#'    asymptotic null distribution.
#'
#' @inheritSection test_ignorability_indtrunc Restricted time window and weighted tests
#'
#' @inheritSection test_ignorability_indtrunc No effective truncation
#'
#' @returns An object of class `quasiindep_strat_test`, i.e. a list with the following
#' components:
#' \item{n}{The complete case sample size.}
#' \item{n_unique}{The number of unique event times among complete cases.}
#' \item{n_miss}{The number of discarded observations (with missing values).}
#' \item{teststat}{The value of the observed test statistic for the across-strata
#'   test (stage 2).}
#' \item{pval}{The p-value for the across-strata test.}
#' \item{critval}{The critical value for the across-strata test at the
#'   user-specified level.}
#' \item{testresult}{Whether the across-strata test results in rejecting the null
#'   hypothesis of quasi-independence.}
#' \item{sims}{A vector of the `B` simulations from the estimated null distribution
#'   of the across-strata test statistic.}
#' \item{level}{The user-supplied `level`.}
#' \item{B}{The number of simulations specified by the user.}
#' \item{timerange}{A vector with the minimum and maximum times used in the
#'   across-strata test.}
#' \item{wt_name}{A string giving the name of the user-suppled `wt_fn`, if any.}
#' \item{eventrange}{A vector with the unrestricted range of observed event times.}
#' \item{strata_ests}{A data frame of estimates to be used by
#'   [plot.quasiindep_strat_test()].}
#' \item{strata_ctau}{A data frame of the within-strata test results (stage 1).
#'   Includes stratum-specific tests by conditional Kendall's tau as well as the
#'   aggregate p-value for testing within-strata quasi-independence in all strata
#'   simultaneously.}
#'
#' The `print` method for `quasiindep_strat_test` objects displays a summary of the
#' test results, while the `plot` method returns a visualization comparing the
#' stratified and unstratified NPMLE from stage 2 using a uniform confidence band,
#' generated through [ggplot2::ggplot()].
#'
#' @export
#'
#' @seealso
#' * [test_quasiindep_ctau()]: the conditional Kendall's tau test for quasi-dependence
#'   without covariates, which is the basis for stage 1.
#' * [npmle()]: the nonparametric maximum likelihood estimator which is the basis
#'   for stage 2.
#' * `vignette("cox-regression-quasiindep", package = "survdt")`: an illustration
#'   of this quasi-independence test applied to the [aids] data, if vignettes were
#'   built when installing [survdt].
#'
#' @examples
#' indtest <- test_quasiindep_covariates(Survdt(incu, ltrunc, rtrunc) ~ age_gp,
#'                                       data = aids)
#' indtest
#' plot(indtest)
#'
#' @references
#' Vazquez, O., & Xie, S. X. (2025). Robust inverse probability weighted estimators
#' for doubly truncated Cox regression with closed-form standard errors.
#' *Lifetime Data Analysis*, **31**(2), 364–-393.
test_quasiindep_covariates <- function(formula, data = NULL, level = 0.95, B = 2000,
                                       restr_times = NULL, wt_fn = NULL,
                                       max_iter = NULL, simple_labels = FALSE){
  # check input
  if (missing(formula)) stop('\n  argument "formula" is missing, with no default')
  stopifnot(inherits(formula, "formula"))
  if (length(formula) < 3) stop("The formula is missing a LHS or a RHS")
  if (!is.null(data) && is.matrix(data)) data <- as.data.frame(data)
  stopifnot(is.null(data) || is.data.frame(data))

  mf <- stats::model.frame(stats::update(formula, ~.-1), data = data,
                           na.action = stats::na.pass)
  if (attr(attr(mf, "terms"), "response") == 0)
    stop("formula is missing a response")
  y <- mf[[attr(attr(mf, "terms"), "response")]]
  if (length(mf) < 2) stop("formula is missing stratafiction variables on RHS")
  strata_vars <- mf[-attr(attr(mf, "terms"), "response")]
  complete_cases <- rowSums(is.na(mf)) == 0
  factor_names <- c(apply(strata_vars[1, , drop = FALSE], MARGIN = 1, FUN = names))
  stopifnot(is.logical(simple_labels), is.vector(simple_labels),
            length(simple_labels) == 1, all(!is.na(simple_labels)))
  if (simple_labels == TRUE) factor_names <- rep("", length(factor_names))
  s <- apply(strata_vars, MARGIN = 1, FUN = function(x) {
    paste0(factor_names, x, sep = "", collapse = ", ")
  })

  if (is.Survdt2(y)) stop("Response should be a Survdt object with one observation",
                          " per subject (not Survdt2). See ?survdt::survdt2to1")
  if (is.null(restr_times)) restr_times <- c(NA_real_, NA_real_)
  if (is.null(wt_fn)) {
    wt_name <- "none"
    wt_fn <- function(x) rep(1, length(x))
  }else{
    wt_name <- format(substitute(wt_fn))
  }
  if (is.null(max_iter)) max_iter <- formals(npmle)[["max_iter"]]
  stopifnot(is.Survdt(y),
            is.numeric(level), is.vector(level), !any(is.na(level)),
            is.numeric(B), is.vector(B), !any(is.na(B)),
            is.numeric(restr_times), is.vector(restr_times), is.function(wt_fn),
            is.numeric(max_iter), is.vector(max_iter), !any(is.na(max_iter)))
  stopifnot(length(y) == length(s), length(level) == 1, all(level > 0),
            all(level < 1), length(B) == 1, all(B > 1), length(restr_times) == 2,
            length(max_iter) == 1, all(max_iter > 1))
  B <- floor(B)
  max_iter <- floor(max_iter)

  # missing data
  n_init <- length(y)
  if (sum(complete_cases) == 0) stop("No observations without missing data")
  if (length(unique(s)) != length(unique(s[complete_cases])))
    warning("Dropping strata with no complete cases")
  y <- y[complete_cases, ]
  n <- length(y)
  s <- s[complete_cases]
  s <- factor(s, levels = unique(s[order(c(strata_vars[complete_cases, 1,
                                                       drop = TRUE])[1:n])]))
  sort_indx <- order(y[, "time", drop = TRUE])
  y <- y[sort_indx, ]
  s <- s[sort_indx]
  strata_vals <- unique(s)
  n_strata <- length(strata_vals)
  n_miss <- n_init - n
  if (n_strata < 2) stop("Only one stratum in complete cases")

  eventrange <- range(y[, "time", drop = TRUE])
  time_lims <- eventrange
  if (!is.na(restr_times[1]) && (restr_times[1] >= time_lims[2]))
    stop("restr_times[1] must be less than the maximum observed event time")
  if (!is.na(restr_times[2]) && (restr_times[2] <= time_lims[1]))
    stop("restr_times[2] must be greater than the minimum observed event time")
  if (all(!is.na(restr_times)) && (restr_times[1] >= restr_times[2]))
    stop("Must have restr_times[1]<restr_times[2]")
  if (all((y[, "ltrunc", drop = TRUE] < time_lims[1]) &
          (time_lims[2] <= y[, "rtrunc", drop = TRUE])))
    warning(paste0("All truncation intervals cover the entire event time range, ",
                   "indicating no effective truncation. ",
                   "Test results may be unreliable."))
  if (length(unique(y[, "time", drop = TRUE])) == 1)
    stop("Ignorability is not testable with one unique event time.")
  test_window <- ifelse(is.na(restr_times), time_lims,
                        c(max(restr_times[1], time_lims[1]),
                          min(restr_times[2], time_lims[2])))

  # unstratified npmle
  pooled_npmle <- npmle(y, se = FALSE, cumhaz = FALSE, ainv = FALSE, infl = FALSE,
                        max_iter = max_iter)
  if (pooled_npmle[["converged"]] == FALSE) stop("Unstratified npmle() did not converge")
  n_unique <- nrow(pooled_npmle[["cdf"]])

  pooled_infl <- npmle_infl(pooled_npmle[["masses"]], infl_pt = TRUE,
                            already_sorted = TRUE)

  endpoints <- findInterval(time_lims, pooled_infl$infl_pt$time, left.open = TRUE)
  if (endpoints[2] >= length(pooled_infl$infl_pt$time))
    stop("Maximum event time lies past maximum right truncation time")
  lrindx <- seq(endpoints[1], endpoints[2])
  endpoints_test <- findInterval(test_window, pooled_infl$infl_pt$time,
                                 left.open = TRUE)
  test_indx <- (endpoints_test[1] <= lrindx) & (lrindx <= endpoints_test[2])
  n_lr_total <- length(lrindx)
  n_lr_test <- sum(test_indx)
  L_pi_unstrat <- pooled_infl$infl_pt$L_pt_btwn[lrindx[test_indx], , drop = FALSE]

  wts <- wt_fn(pooled_infl$infl_pt$time[lrindx + 1])
  if (!is.numeric(wts) || !is.vector(wts))
    stop("wt_fn must return a numeric vector")
  if (length(wts) != length(lrindx))
    stop("wt_fn output length does not match input")
  bad_times <- pooled_infl$infl_pt$time[lrindx[is.na(wts) | is.infinite(wts)] + 1]
  if (length(bad_times) > 5) bad_times <- c(bad_times[1:5], "...")
  if (length(bad_times) > 0)
    stop(paste0("wt_fn produced infinite or missing values at time ",
                paste0(bad_times, collapse = ", ")))

  # strata ctau, npmle, and null distribution
  L_nulldist <- matrix(nrow = n_lr_test * n_strata, ncol = n)
  test_wts <- rep(wts[test_indx], n_strata)
  new_out_of_window <- pooled_infl$infl_pt$pt_btwn[lrindx] <= 0
  strata_ests <- data.frame(strata = rep(strata_vals, each = n_lr_total),
                            time = rep(pooled_infl$infl_pt$time[lrindx], n_strata),
                            unstrat_pt = rep(pooled_infl$infl_pt$pt_btwn[lrindx],
                                             n_strata),
                            pt = rep(NA, n_lr_total * n_strata),
                            out_of_window = rep(!test_indx, n_strata),
                            wt = rep(wts, n_strata))
  strata_ctau <- data.frame(strata = strata_vals, strata_size = rep(NA, n_strata),
                            tau_left = rep(NA, n_strata),
                            tau_right = rep(NA, n_strata),
                            teststat = rep(NA, n_strata), df = rep(NA, n_strata),
                            pval = rep(NA, n_strata), var_left = rep(NA, n_strata),
                            var_right = rep(NA, n_strata), cov = rep(NA, n_strata))
  for (i in seq_len(n_strata)){
    strata_indx <- s == strata_vals[i]
    strata_npmle <- npmle(y[strata_indx, ], se = FALSE, cumhaz = FALSE,
                          ainv = FALSE, infl = FALSE, max_iter = max_iter)
    if (strata_npmle[["converged"]] == FALSE)
      stop(paste0("Stratified npmle() did not converge in stratum ", strata_vals[i]))

    strata_infl <- npmle_infl(strata_npmle[["masses"]], infl_pt = TRUE,
                              already_sorted = TRUE)

    strata_test <- test_quasiindep_ctau(y[strata_indx, ])
    strata_ctau$tau_left[i] <- strata_test[["tau"]][1]
    strata_ctau$tau_right[i] <- strata_test[["tau"]][2]
    strata_ctau$var_left[i] <- strata_test[["var_matrix"]][1, 1]
    strata_ctau$var_right[i] <- strata_test[["var_matrix"]][2, 2]
    strata_ctau$cov[i] <- strata_test[["var_matrix"]][1, 2]
    strata_ctau$teststat[i] <- strata_test[["teststat"]]
    strata_ctau$df[i] <- strata_test[["df"]]
    strata_ctau$pval[i] <- strata_test[["pval"]]
    strata_ctau$strata_size[i] <- sum(strata_indx)

    rows_L <- n_lr_test * (i-1) + seq_len(n_lr_test)
    rows_ests <- n_lr_total * (i-1) + seq_len(n_lr_total)
    lrindx_s <- findInterval(strata_ests$time[rows_ests],
                             strata_infl$infl_pt$time) + 1
    strata_ests$pt[rows_ests] <- c(0, strata_infl$infl_pt$pt_btwn, 0)[lrindx_s]
    nsratio <- n / sum(strata_indx)
    nrow_infl_s <- nrow(strata_infl$infl_pt$L_pt_btwn)
    L_nulldist[rows_L, ] <- -L_pi_unstrat
    L_nulldist[rows_L, strata_indx] <- L_nulldist[rows_L, strata_indx,
                                                  drop = FALSE] +
      rbind(nsratio * strata_infl$infl_pt$L_pt_btwn[1, , drop = FALSE],
            nsratio * strata_infl$infl_pt$L_pt_btwn,
            nsratio *
              strata_infl$infl_pt$L_pt_btwn[nrow_infl_s,
                                            ,
                                            drop = FALSE])[lrindx_s[test_indx],
                                                           ,
                                                           drop = FALSE]
  }
  if (any(new_out_of_window)){
    strata_ests$out_of_window <- strata_ests$out_of_window |
      rep(new_out_of_window, n_strata)
    L_nulldist[rep(new_out_of_window[test_indx], n_strata), ] <- 0
    lrindx_range <- range(lrindx[test_indx & !new_out_of_window])
    test_window[1] <- max(test_window[1],
                          pooled_infl$infl_pt$time[lrindx_range[1]])
    if (lrindx_range[2] < n_lr_total)
      test_window[2] <- min(test_window[2],
                            pooled_infl$infl_pt$time[lrindx_range[2] + 1])
  }

  # results
  teststat <- max(abs(strata_ests$wt[!strata_ests$out_of_window] *
                        (strata_ests$pt[!strata_ests$out_of_window] -
                           strata_ests$unstrat_pt[!strata_ests$out_of_window])))
  sims <- replicate(B, {
    wt <- stats::rnorm(n, 1, 1)
    max(abs(test_wts * c(L_nulldist %*% wt / n)))
  })
  critval <- stats::quantile(sims, level)
  strata_ctau$aggregate_teststat <- sum(strata_ctau$teststat)
  strata_ctau$aggregate_df <- sum(strata_ctau$df)
  strata_ctau$aggregate_pval <- stats::pchisq(strata_ctau$aggregate_teststat[1],
                                              strata_ctau$aggregate_df[1],
                                              lower.tail = FALSE)

  res <- list(n = n, n_unique = n_unique, n_miss = n_miss, teststat = teststat,
              pval = mean(sims >= teststat), critval = critval,
              testresult = teststat > critval, sims = sims, level = level, B = B,
              timerange = test_window, wt_name = wt_name, eventrange = eventrange,
              strata_ests = strata_ests, strata_ctau = strata_ctau)
  class(res) <- "quasiindep_strat_test"
  res
}


#' @rdname test_quasiindep_covariates
#' @export
plot.quasiindep_strat_test <- function(x, level, ...){
  if (missing(level)) level <- x[["level"]]
  stopifnot(is.numeric(level), is.vector(level), all(!is.na(level)))
  stopifnot(length(level) == 1, all(level > 0), all(level < 1))
  q <- stats::quantile(x[["sims"]], level)
  ests <- x[["strata_ests"]]
  ests$lower <- ifelse(ests$out_of_window, 0,
                       pmax(0, ests$unstrat_pt - (q / abs(ests$wt))))
  ests$upper <- ifelse(ests$out_of_window, 1,
                       pmin(1, ests$unstrat_pt + (q / abs(ests$wt))))

  with(ests,
       ggplot2::ggplot(ests) +
         ggplot2::geom_step(ggplot2::aes(x = time, y = lower),
                            linetype = "dashed", direction = "hv") +
         ggplot2::geom_step(ggplot2::aes(x = time, y = upper),
                            linetype = "dashed", direction = "hv") +
         ggplot2::geom_step(ggplot2::aes(x = time, y = pt, group = strata,
                                         color = "stratified NPMLE"),
                            direction = "hv") +
         ggplot2::geom_step(ggplot2::aes(x = time, y = unstrat_pt,
                                         color = "unstratified NPMLE"),
                            direction = "hv") +
         ggplot2::scale_color_manual(breaks = c("stratified NPMLE",
                                                "unstratified NPMLE"),
                                     values = c("maroon", "black"),
                                     guide =
                                       ggplot2::guide_legend(override.aes =
                                                               list(lwd = 2))) +
         ggplot2::labs(x = "Time", y = "Selection probability", color = "") +
         ggplot2::coord_cartesian(ylim = c(0, 1.01), xlim = x[["timerange"]],
                                  expand = FALSE) +
         ggplot2::theme_classic() +
         ggplot2::theme(legend.position = "bottom"))
}

#' @rdname test_quasiindep_covariates
#' @export
print.quasiindep_strat_test <- function(x, ...){
  pval1 <- format(x[["strata_ctau"]]$aggregate_pval[1], digits = 2, nsmall = 1)
  result1 <- x[["strata_ctau"]]$aggregate_pval[1] < (1 - x[["level"]])
  pval2 <- format(x[["pval"]], digits = 2, nsmall = 1)
  pval2 <- ifelse(pval2 == "0.0",
                  paste0("<", 1 / x[["B"]]),
                  paste0("=", pval2))

  cat(paste0("\n",
             "Two-stage quasi-independent truncation test involving covariates.",
             "\n",
             "\n",
             "  Unstratified NPMLE fit based on ", x[["n"]], " complete samples (",
             x[["n_miss"]], " dropped due to missingness)",
             "\n",
             "    with ", x[["n_unique"]], " unique event times.",
             "\n",
             "  Min event time: ", x[["eventrange"]][1],
                "\n",
             "  Max event time: ", x[["eventrange"]][2],
             "\n",
             "\n",
             "  Stage 1 (within strata quasi-independence).",
                "\n",
             "  Test statistic: chisq=",
               format(x[["strata_ctau"]]$aggregate_teststat[1],
                      digits = 2, nsmall = 1),
               ", df=", x[["strata_ctau"]]$aggregate_df[1],
               "\n",
             "  Significant evidence ", ifelse(result1, "", "not "),
               "found against quasi-independence (p=", pval1, ")",
             "\n",
             "\n",
             "  Stage 2 (across strata equality of selection probabilities).",
                "\n",
             "  Test statistic: ",
                   format(x[["teststat"]], digits = 2, nsmall = 1),
                "\n",
             "    Time range:   [", x[["timerange"]][1], ", ",
                    x[["timerange"]][2], "]",
                  "\n",
             "    Time weights: ", x[["wt_name"]],
                "\n",
             "  Critical value: ",
                  format(x[["critval"]], digits = 2, nsmall = 1),
                " at level ", x[["level"]],
                "\n",
             "  Significant evidence ", ifelse(x[["testresult"]], "", "not "),
             "found against equality across strata (p", pval2, ").",
                "\n",
             "  Results based on ", x[["B"]], " simulations from the estimated ",
             "null distribution.",
             "\n",
             "\n",
             "Summary of the ", nrow(x[["strata_ctau"]]), " covariate groups used ",
             "in the test:",
             "\n"))

  sort_indx <- order(x[["strata_ctau"]][, "strata_size", drop = TRUE],
                     decreasing = TRUE)
  strata_summary <- x[["strata_ctau"]][sort_indx,
                                       c("strata",
                                         "strata_size"),
                                       drop = FALSE]
  colnames(strata_summary) <- c("stratum", "size")
  if (nrow(x[["strata_ctau"]]) > 10){
    print(strata_summary[1:10, , drop = FALSE],
          row.names = FALSE)
    cat("  ...")
    cat("\n\n")
  }else{
    print(strata_summary, row.names = FALSE)
    cat("\n")
  }
  invisible(x)
}

#' Internal function to compute the estimated influence function for the NPMLE.
#'
#' @description
#' Computes the estimated influence function for the event time cdf,
#' cumulative hazard, normalized inverse selection probability weights, and
#' selection probability as a function of time.
#' Does not check for valid input arguments.
#'
#' @param masses Part of the output from [npmle()].
#' @param J A matrix with `J[i,j]`=`TRUE` if the `i`th follow up time is in the
#'   `j`th truncation interval. Will be computed from `masses` if not supplied.
#' @param ainv Whether the influence values for the normalized inverse
#'   probability weights should be returned (default `FALSE`).
#' @param cumhaz Whether the influence values for the event time cumulative
#'   hazard should be returned (default `FALSE`).
#' @param msel_prob Whether the influence values for the overall/marginal
#'   selection probability should be returned (default `FALSE`).
#' @param infl_at Whether the influence values for the normalized selection
#'   probabilities (at all times) should be returned (default `FALSE`).
#' @param infl_pt Whether the influence values for the selection
#'   probabilities (at all times) should be returned (default `FALSE`).
#' @param L_F The matrix of influence function values for the NPMLE event time
#'   cdf. The rows should correspond to unique ordered observed event times, while
#'   the columns should match the order of `masses`.
#'   If `NULL`, will be computed.
#' @param already_sorted Whether `masses` (and `J`,`L_F`, if supplied) was
#'   computed from sorted event times (default `FALSE`). If `TRUE` then less
#'   computations are required.
#'
#' @details
#' see Vazquez and Xie (2025).
#'
#'
#' @returns A list containing requested influence values for the NPMLE, to be
#' used for constructing standard errors.
#'
#' @keywords internal
#'
#' @noRd
#'
#' @references
#' Vazquez, O., & Xie, S. X. (2025). Robust inverse probability weighted
#' estimators for doubly truncated Cox regression with closed-form standard
#' errors. *Lifetime Data Analysis*, **31**(2), 364–-393.
npmle_infl <- function(masses, J = NULL, ainv = FALSE, cumhaz = FALSE,
                       msel_prob = FALSE, infl_at = FALSE, infl_pt = FALSE,
                       L_F = NULL, already_sorted = FALSE){
  n <- nrow(masses)
  C_lprod <- function(A) {rbind(A, -colSums(A))}
  C_rprod <- function(A) {sapply(seq_len(n - 1),
                                 FUN = function(i) A[, i] - A[, n])}
  Ct_lprod <- function(A) {sapply(seq_len(ncol(A)),
                                  FUN = function(i) A[-n, i] - A[n, i])}

  if (already_sorted == FALSE){
    sort_indx <- order(masses$time)
    unsort_indx <- order(sort_indx)
    masses <- masses[sort_indx, , drop = FALSE]
    if (!is.null(J)){
      J <- J[sort_indx, , drop = FALSE]
      J <- J[, sort_indx, drop = FALSE]
    }
  }else{
    sort_indx <- seq_len(n)
    unsort_indx <- seq_len(n)
  }

  if (is.null(J)){
    J <- apply(masses[, c("ltrunc", "rtrunc")], MARGIN = 1, FUN = function(lr){
      (lr[1] < masses$time) & (masses$time <= lr[2])
    })
  }

  a <- 1 / (n * masses$f)
  S <- stats::toeplitz(rep(1, n), r = c(1, rep(0, n - 1)))
  S_inv <- stats::toeplitz(c(1, -1, rep(0, n - 2)), r = c(1, rep(0, n - 1)))
  B <- S %*% diag(masses$f)
  B_inv <- diag(1 / masses$f) %*% S_inv
  unique_indx <- !duplicated(masses$time, fromLast = TRUE)
  match_unique_indx <- match(masses$time, masses$time[unique_indx])
  Atilde <- J %*% diag(1 / masses$plr^2) %*% t(J) %*% S_inv / n

  # row sorted event time, col original order
  if (is.null(L_F)){
    H <- sapply(unsort_indx, FUN = function(i) {
      ((masses$time[i] <= masses$time[unique_indx]) / a[i]) -
        (cumsum(J[, i] / a^2)[unique_indx] / (n * masses$plr[i]))
    })
    A <- S %*% diag(1 / a^2) %*% Atilde / n
    IA <- -A
    diag(IA) <- 1 + diag(IA)
    L_F <- (B %*% C_lprod(solve(Ct_lprod(C_rprod(B_inv %*% IA %*% B)),
                                Ct_lprod(B_inv %*% H[match_unique_indx, ])))
    )[unique_indx, ]
  }
  var_F <- rowMeans(L_F^2) / n
  if (already_sorted == FALSE) a <- a[unsort_indx]


  L_ainv <- NULL
  var_ainv <- NULL
  if (ainv == TRUE){
    L_ainv <- sapply(unsort_indx,  FUN = function(i){
      -((J[unsort_indx, i] / masses$plr[i]) - a -
          (Atilde[unsort_indx, , drop = FALSE] %*%
             L_F[match_unique_indx, i])) / a^2
    })
    var_ainv <- rowMeans(L_ainv^2) / n
  }

  cumhazard <- NULL
  L_cumhaz <- NULL
  var_cumhaz <- NULL
  if (cumhaz == TRUE){
    npcdf <- cbind(masses$time, pmin(cumsum(masses$f), 1))[unique_indx, ]
    lcont_survival <- 1 - c(0, npcdf[-nrow(npcdf), 2])
    dF <- diff(c(0, npcdf[, 2]))
    cumhazard <- cbind(npcdf[, 1], cumsum(dF / lcont_survival))
    n_unique_times <- nrow(L_F)
    L_cumhaz <- apply(L_F, MARGIN = 2, FUN = function(lf) {
      cumsum((diff(c(0, lf)) / lcont_survival) +
               (c(0, lf[-n_unique_times]) * dF / lcont_survival^2))
    })
    var_cumhaz <- rowMeans(L_cumhaz^2) / n
  }

  msel <- 1 / mean(1 / masses$plr)
  L_msel <- NULL
  influence_msel_prob <- NULL
  influence_at <- NULL
  influence_pt <- NULL
  if (infl_at || infl_pt){
    lr_times <- unique(sort(c(masses$ltrunc, masses$rtrunc)))
    n_lr <- length(lr_times)
    a_times <- lr_times[-n_lr] + diff(lr_times) / 2

    J_at <- apply(cbind(masses$ltrunc, masses$rtrunc), MARGIN = 1,
                  FUN = function(lr) (lr[1] < a_times) & (a_times <= lr[2]))
    at <- c(J_at %*% (1 / masses$plr) / n)
    L_at <- (J_at[, unsort_indx, drop = FALSE] %*%
               diag(1 / masses$plr[unsort_indx])) -
      matrix(rep(at, n), ncol = n) -
      (J_at %*% diag(1 / masses$plr^2) %*%
         t(J) %*% S_inv %*% L_F[match_unique_indx, ] / n)
    var_at <- rowMeans(L_at^2) / n

    if (infl_at == TRUE){
      influence_at$time <- lr_times
      influence_at$at_btwn <- at
      influence_at$var_at_btwn <- var_at
      influence_at$L_at_btwn <- L_at
    }

    if (infl_pt == TRUE){
      influence_pt$time <- lr_times
      influence_pt$pt_btwn <- at * msel

      L_msel <- (colSums(diag(1 / masses$plr^2) %*%
                           t(J) %*% S_inv %*% L_F[match_unique_indx, ] / n) -
                   (1 / masses$plr[unsort_indx]) +
                   (1 / msel)) *
        msel^2
      influence_pt$L_pt_btwn <- (L_at * msel) + (at %*% t(L_msel))
      influence_pt$var_pt_btwn <- rowMeans(influence_pt$L_pt_btwn^2) / n
    }
  }

  if (msel_prob){
    influence_msel_prob$prob <- msel
    influence_msel_prob$L <- L_msel
    if (is.null(influence_msel_prob$L)){
      influence_msel_prob$L <-
        (colSums(diag(1 / masses$plr^2) %*%
                   t(J) %*% S_inv %*% L_F[match_unique_indx, ] / n) -
           (1 / masses$plr[unsort_indx]) +
           (1 / msel)) *
        msel^2
    }
    influence_msel_prob$var <- mean(influence_msel_prob$L^2) / n
  }

  list(a = a, L_F = L_F, var_F = var_F, L_ainv = L_ainv, var_ainv = var_ainv,
       cumhaz = cumhazard, L_cumhaz = L_cumhaz, var_cumhaz = var_cumhaz,
       infl_at = influence_at, infl_pt = influence_pt,
       infl_msel_prob = influence_msel_prob)
}
