# Helper to compute 3rd order partial derivatives of log-likelihood
.compute_L3 <- function(loglik_fn, par, eps = 1e-4) {
  p <- length(par)
  L3 <- array(0, dim = c(p, p, p))
  for (k in seq_len(p)) {
    p1 <- par; p1[k] <- p1[k] + eps
    p2 <- par; p2[k] <- p2[k] - eps
    H1 <- .num_hessian(loglik_fn, p1, eps = eps)
    H2 <- .num_hessian(loglik_fn, p2, eps = eps)
    L3[, , k] <- (H1 - H2) / (2 * eps)
  }
  return(L3)
}

#' Bayesian Estimation via Lindley's Approximation under Adaptive Type-I PHCS
#'
#' Computes Bayes estimates of parameters using Lindley's expansion for Adaptive Type-I PHCS.
#'
#' @param data Numeric vector of observed failure times.
#' @param n Integer, total initial sample size placed on test.
#' @param m Integer, pre-fixed target number of failures.
#' @param T_thresh Numeric, pre-fixed time threshold T > 0.
#' @param R Numeric vector of length m, progressive censoring scheme.
#' @param pdf Function, user-supplied probability density function pdf(x, par).
#' @param cdf Function (optional), user-supplied cumulative distribution function cdf(x, par).
#' @param surf Function (optional), user-supplied survival function surf(x, par).
#' @param prior Function (optional), user-supplied prior density function log_prior(par). Default is flat prior.
#' @param start Numeric vector, initial parameter guess for finding MLE.
#' @param lower Numeric vector (optional), lower bounds for parameters.
#' @param upper Numeric vector (optional), upper bounds for parameters.
#'
#' @return A list containing Lindley Bayes estimates, MLEs, and log-likelihood details.
#' @export
#' @examples
#' set.seed(123)
#' my_cdf <- function(x, par) pexp(x, rate = par[1])
#' my_pdf <- function(x, par) dexp(x, rate = par[1])
#' my_surf <- function(x, par) 1 - pexp(x, rate = par[1])
#' flat_prior <- function(par) ifelse(par[1] > 0, 0, -Inf)
#' R_plan <- c(rep(1, 8), rep(0, 4))
#' dat <- r_adapt1_phcs(
#'   n = 20, m = 12, T_thresh = 2.5,
#'   R = R_plan, pdf = my_pdf,
#'   cdf = my_cdf, par = 0.5
#' )$data
#' lindley_res <- lindley_adapt1_phcs(
#'   data = dat, n = 20, m = 12,
#'   T_thresh = 2.5, R = R_plan,
#'   pdf = my_pdf, cdf = my_cdf,
#'   surf = my_surf, prior = flat_prior,
#'   start = c(rate = 0.8)
#' )
#' print(lindley_res$estimates)
lindley_adapt1_phcs <- function(data, n, m, T_thresh, R, pdf, cdf = NULL, surf = NULL, prior = NULL, start, lower = NULL, upper = NULL) {
  fit_mle <- mle_adapt1_phcs(data = data, n = n, m = m, T_thresh = T_thresh, R = R, pdf = pdf, cdf = cdf, surf = surf, start = start, method = "BFGS", lower = lower, upper = upper)
  
  if (is.null(prior)) prior <- function(par) 0
  
  mle_par <- fit_mle$par
  p_len <- length(mle_par)
  sigma_mat <- fit_mle$vcov
  
  d <- length(data)
  data_sorted <- sort(data)
  loglik_fn <- function(par) {
    if (!is.null(lower) && any(par <= lower)) return(-1e12)
    if (!is.null(upper) && any(par >= upper)) return(-1e12)
    dens <- pdf(data_sorted, par)
    if (any(dens <= 0) || any(is.na(dens))) return(-1e12)
    if (d >= m) {
      s_vals <- fit_mle$surf(data_sorted[1:(m - 1)], par)
      s_T <- fit_mle$surf(T_thresh, par)
      if (any(s_vals <= 0) || s_T <= 0 || is.na(s_T)) return(-1e12)
      rem_cens <- n - d - sum(R[1:(m - 1)])
      return(sum(log(dens)) + sum(R[1:(m - 1)] * log(s_vals)) + rem_cens * log(s_T))
    } else {
      s_vals <- fit_mle$surf(data_sorted, par)
      s_T <- fit_mle$surf(T_thresh, par)
      if (any(s_vals <= 0) || s_T <= 0 || is.na(s_T)) return(-1e12)
      rem_cens <- n - d - sum(R[1:d])
      return(sum(log(dens)) + sum(R[1:d] * log(s_vals)) + rem_cens * log(s_T))
    }
  }
  
  rho_grad <- .num_grad(prior, mle_par)
  L3 <- .compute_L3(loglik_fn, mle_par)
  
  bay_est <- numeric(p_len)
  if (!is.null(names(mle_par))) names(bay_est) <- names(mle_par)
  
  for (l in seq_len(p_len)) {
    t1 <- sum(rho_grad * sigma_mat[l, ])
    t2 <- 0
    for (i in seq_len(p_len)) {
      for (j in seq_len(p_len)) {
        for (k in seq_len(p_len)) {
          t2 <- t2 + L3[i, j, k] * sigma_mat[i, j] * sigma_mat[k, l]
        }
      }
    }
    bay_est[l] <- mle_par[l] + t1 + 0.5 * t2
  }
  
  res_mat <- cbind(MLE = mle_par, `Lindley Bayes` = bay_est)
  
  return(list(
    estimates = res_mat,
    mle_fit = fit_mle,
    scheme = "Adaptive Type-I PHCS"
  ))
}

#' Bayesian Estimation via Lindley's Approximation under Adaptive Type-II PHCS
#'
#' Computes Bayes estimates of parameters using Lindley's expansion for Adaptive Type-II PHCS.
#'
#' @param data Numeric vector of m observed failure times.
#' @param n Integer, total initial sample size placed on test.
#' @param m Integer, pre-fixed target number of failures.
#' @param T_thresh Numeric, pre-fixed time threshold T > 0.
#' @param R Numeric vector of length m, progressive censoring scheme.
#' @param pdf Function, user-supplied probability density function pdf(x, par).
#' @param cdf Function (optional), user-supplied cumulative distribution function cdf(x, par).
#' @param surf Function (optional), user-supplied survival function surf(x, par).
#' @param prior Function (optional), user-supplied prior density function log_prior(par). Default is flat prior.
#' @param start Numeric vector, initial parameter guess for finding MLE.
#' @param lower Numeric vector (optional), lower bounds for parameters.
#' @param upper Numeric vector (optional), upper bounds for parameters.
#'
#' @return A list containing Lindley Bayes estimates, MLEs, and log-likelihood details.
#' @export
#' @examples
#' set.seed(123)
#' my_cdf <- function(x, par) pexp(x, rate = par[1])
#' my_pdf <- function(x, par) dexp(x, rate = par[1])
#' my_surf <- function(x, par) 1 - pexp(x, rate = par[1])
#' flat_prior <- function(par) ifelse(par[1] > 0, 0, -Inf)
#' R_plan <- c(rep(1, 8), rep(0, 4))
#' dat <- r_adapt2_phcs(
#'   n = 20, m = 12, T_thresh = 2.5,
#'   R = R_plan, pdf = my_pdf,
#'   cdf = my_cdf, par = 0.5
#' )$data
#' lindley_res <- lindley_adapt2_phcs(
#'   data = dat, n = 20, m = 12,
#'   T_thresh = 2.5, R = R_plan,
#'   pdf = my_pdf, cdf = my_cdf,
#'   surf = my_surf, prior = flat_prior,
#'   start = c(rate = 0.8)
#' )
#' print(lindley_res$estimates)
lindley_adapt2_phcs <- function(data, n, m, T_thresh, R, pdf, cdf = NULL, surf = NULL, prior = NULL, start, lower = NULL, upper = NULL) {
  fit_mle <- mle_adapt2_phcs(data = data, n = n, m = m, T_thresh = T_thresh, R = R, pdf = pdf, cdf = cdf, surf = surf, start = start, method = "BFGS", lower = lower, upper = upper)
  
  if (is.null(prior)) prior <- function(par) 0
  
  mle_par <- fit_mle$par
  p_len <- length(mle_par)
  sigma_mat <- fit_mle$vcov
  
  data_sorted <- sort(data)
  m_obs <- length(data_sorted)
  J <- sum(data_sorted <= T_thresh)
  if (J >= m_obs - 1) {
    R_eff <- R
  } else {
    R_eff <- c(if(J > 0) R[1:J] else numeric(0), rep(0, m_obs - J - 1), n - m_obs - sum(if(J > 0) R[1:J] else 0))
  }
  
  loglik_fn <- function(par) {
    if (!is.null(lower) && any(par <= lower)) return(-1e12)
    if (!is.null(upper) && any(par >= upper)) return(-1e12)
    dens <- pdf(data_sorted, par)
    s_vals <- fit_mle$surf(data_sorted, par)
    if (any(dens <= 0) || any(s_vals <= 0) || any(is.na(dens))) return(-1e12)
    return(sum(log(dens)) + sum(R_eff * log(s_vals)))
  }
  
  rho_grad <- .num_grad(prior, mle_par)
  L3 <- .compute_L3(loglik_fn, mle_par)
  
  bay_est <- numeric(p_len)
  if (!is.null(names(mle_par))) names(bay_est) <- names(mle_par)
  
  for (l in seq_len(p_len)) {
    t1 <- sum(rho_grad * sigma_mat[l, ])
    t2 <- 0
    for (i in seq_len(p_len)) {
      for (j in seq_len(p_len)) {
        for (k in seq_len(p_len)) {
          t2 <- t2 + L3[i, j, k] * sigma_mat[i, j] * sigma_mat[k, l]
        }
      }
    }
    bay_est[l] <- mle_par[l] + t1 + 0.5 * t2
  }
  
  res_mat <- cbind(MLE = mle_par, `Lindley Bayes` = bay_est)
  
  return(list(
    estimates = res_mat,
    mle_fit = fit_mle,
    scheme = "Adaptive Type-II PHCS"
  ))
}
