
.subRubinRule <- function(thetai,ui){
  m <- length(thetai)
  stopifnot(length(ui) == m)
  ui <- ui^2
  theta <- mean(thetai)
  u <- mean(ui)
  B <- var(thetai)
  T <- u + (1+1/m)*B
  SE <- sqrt(T)
  nu <- (m-1)*(1+u/(1+1/m)/B)^2
  ME <- abs(qt(0.975,df=nu))
  ll <- theta - ME * SE
  ul <- theta + ME * SE
  c(theta,SE,ll,ul)
}

.generate_matrix_unique <- function(k,kmax=10,nlevels=2) {
  xset <- c(0:(nlevels-1))
  m <- round(log(kmax)/log(nlevels))
  if (k <= m) {
    mat <- expand.grid(rep(list(xset), k))
    mat <- as.matrix(mat)
  } else {
    seen <- list()
    mat <- matrix(NA, nrow = 0, ncol = k)
    
    while (nrow(mat) < kmax) {
      candidate <- sample(xset, k, replace = TRUE)
      key <- paste(candidate, collapse = "")
      
      if (!key %in% seen) {
        seen[[length(seen) + 1]] <- key
        mat <- rbind(mat, candidate)
      }
    }
  }
  
  colnames(mat) <- paste0("V", seq_len(k))
  return(mat)
}


#' Unblinding bias correction
#'
#' @param W Numeric surrogate outcome.
#' @param T Binary treatment indicator.
#' @param G Binary response indicator.
#' @param method fitting/test method.
#' @param impute missing data or DNK response imputation.
#' 
#' @return An object of class `rctme_fit`.
#' @export
#'
#' @examples
#' \dontrun{
#' if (requireNamespace("rstan", quietly = TRUE)) {
#' sigma = 1.2
#' sig.theta = 1.0
#' beta0 = 0
#' beta1 = 1
#' beta2 = 2
#' ntreat = nsham = 100
#' Tind  = c(rep(1, ntreat), rep(0,nsham))  #treatment group indicator
#' u1v   = rep(u1,ntreat)
#' u2v   = rep(u2,nsham)
#' uv    = c(u1v,u2v)
#' tauv  = uv - rep(u2, ntreat+nsham)
#' r = rnorm(ntreat + nsham, mean = 0, sd = sigma)
#' x = uv + r #actual endpoint outcome
#' q = 1/(1 + exp(-(beta0 + beta1*Tind + beta2*(tauv+r))))
#' bernGen = function(qq){rbinom(1,1,qq)}
#' I = sapply(q,bernGen)
#' rsham = rnorm(ntreat + nsham, mean = 0, sd = sig.theta)
#' w = x + (theta + rsham)*I
#' lm0 = lm(w~Tind)
#' tau1 = lm0$coef[2]; tau1
#' u12 = tapply(w,Tind,FUN=mean,na.rm=TRUE)
#' lm1 = lm(w~Tind+I)
#' tau2 = lm1$coef[2]; tau2
#' mydata <- data.frame(y=w,group=Tind,guess=I)
#' out1 <- blinding.test(W = mydata$y, T = mydata$group, G = mydata$guess,
#'                       method='BI',impute=TRUE)
#' out1 # Blinding Index test
#' 
#' out2 <- blinding.test(W = mydata$y, T = mydata$group, G = mydata$guess,
#'                       method='classic',impute=TRUE)
#' out2 # classic estimate (t-test like)
#' 
#' out3 <- blinding.test(W = mydata$y, T = mydata$group, G = mydata$guess,
#'                       method='adjusted',impute=TRUE)
#' out3 # ANOVA or linear regression using G as a covariate
#' 
#' out4 <- blinding.test(W = mydata$y, T = mydata$group, G = mydata$guess,
#'                       method='EM',impute=TRUE)
#' out4 # MLE using EM-algorithm
#' 
#' out5 <- blinding.test(W = mydata$y, T = mydata$group, G = mydata$guess,
#'                       method='Bayes',impute=TRUE)
#' out5 # MLE using Bayes MCMC
#' }
#' }
#' 

blinding.test <- function(W,T,G,method='adjust',impute=TRUE){
  .validate_inputs(W,T,G)
  method <- match.arg(
    tolower(method), c("mle","cpe","adjusted","classic",
                      "bayes", "stan","em","bi","bridge","waic"))

  if(method=="classic"){
    out <- blindingCLASSIC(y=W,group=T)
  }else if(method == 'bi'){
    out <- blindingBI(group = T, guess = G,impute=impute)
  }else if(method == 'adjusted'){
    out <- blindingADJ(y=W,group=T,guess=G,impute=impute)
  }else if(method == 'cpe'){
    out <- blindingCPE(y=W,group=T,guess=G,impute=impute)
  }else if(method == 'bridge'){
    out <- TestStan(W=W,T=T,G=G,method='bridge')
  }else if(method == 'waic'){
    out <- TestStan(W=W,T=T,G=G,method='waic')
  }else if(method == 'mle' || method == 'em'){
    out <- blindingEM(y=W,group=T,guess=G,impute=impute)
  }else{
    out <- blindingSTAN(y=W,group=T,guess=G,impute=impute)
  }
  out
}




blindingSTAN <- function(y,group,guess,impute=TRUE){
  out <- NULL
  sele <- is.na(guess)
  g2 <- guess[!sele]
  if (all(g2 %in% c(0, 1, 2))) {
    nlvl <- length(unique(g2))
  }else{
    stop("G must have values 0/1/2.", call. = FALSE)
  }
  if(any(sele)){
    if(impute){
      guess[sele] <- 2
    }else{
      y <- y[!sele]
      group <- group[!sele]
      guess <- guess[!sele]
    }
  }
  ## impute if guess=0/1/2, 
  ## compute directly if guess=0/1
  sele <- guess == 2
  k <- sum(sele)
  
  if(k == 0){
    out <- .compSTAN(y=y,group=group,guess=guess)
  }else{
    kmat <- .generate_matrix_unique(k,kmax=10,nlevels=2)
    out2 <- apply(kmat,1,.imputeSTAN,y=y,group=group,guess=guess)
    res1 <- .subRubinRule(thetai=out2[1,], ui=out2[2,])
    res2 <- .subRubinRule(thetai=out2[3,], ui=out2[4,])
    res3 <- .subRubinRule(thetai=out2[5,], ui=out2[6,])
    res4 <- .subRubinRule(thetai=out2[7,], ui=out2[8,])
    
    tmp <- rbind(res1,res2,res3,res4)
    out1 <- as.data.frame(tmp)
    rownames(out1) <- c("tau","mu0","delta1","alphaX")
    names(out1) <- c("Estimate", "Std. Error", "95% LCL (2-Sided)",
                     "95% UCL (2-Sided)")
    out$estimate <- out1
  }
  out
}

.imputeSTAN <- function(x,y,group,guess){
  sele <- guess == 2
  guess[sele] <- x
  out <- .compSTAN(y=y,group=group,guess=guess)
  stat <- c(out$tau, out$se, 
            out$summ[1,1], out$summ[1,2],
            out$summ[12,1], out$summ[12,2],
            out$summ[11,1], out$summ[11,2]
  )
  return(stat)
}

.compSTAN <- function(y,group,guess){
    fit_rctme_stan_delta0_fixed(W=y,T=group,G=guess)  
}


blindingEM <- function(y,group,guess,impute=TRUE){
  out <- NULL
  sele <- is.na(guess)
  g2 <- guess[!sele]
  if (all(g2 %in% c(0, 1, 2))) {
    nlvl <- length(unique(g2))
  }else{
    stop("G must have values 0/1/2.", call. = FALSE)
  }
  if(any(sele)){
    if(impute){
      guess[sele] <- 2
    }else{
      y <- y[!sele]
      group <- group[!sele]
      guess <- guess[!sele]
    }
  }
  ## impute if guess=0/1/2, 
  ## compute directly if guess=0/1
  sele <- guess == 2
  k <- sum(sele)

  if(k == 0){
    out <- .compEM(y=y,group=group,guess=guess)
  }else{
    kmat <- .generate_matrix_unique(k,kmax=10,nlevels=2)
    out2 <- apply(kmat,1,.imputeSTAN,y=y,group=group,guess=guess)
    res1 <- .subRubinRule(thetai=out2[1,], ui=out2[2,])
    res2 <- .subRubinRule(thetai=out2[3,], ui=out2[4,])
    res3 <- .subRubinRule(thetai=out2[5,], ui=out2[6,])
    res4 <- .subRubinRule(thetai=out2[7,], ui=out2[8,])
    
    tmp <- rbind(res1,res2,res3,res4)
    out1 <- as.data.frame(tmp)
    rownames(out1) <- c("tau","mu0","delta1","alphaX")
    names(out1) <- c("Estimate", "Std. Error", "95% LCL (2-Sided)",
                     "95% UCL (2-Sided)")
    out$estimate <- out1
  }
  out
}

.imputeEM <- function(x,y,group,guess){
  sele <- guess == 2
  guess[sele] <- x
  out <- .compEM(y=y,group=group,guess=guess)
  stat <- c(out$tau, out$se, 
            out$summ[1,1], out$summ[1,2],
            out$summ[12,1], out$summ[12,2],
            out$summ[11,1], out$summ[11,2]
  )
  return(stat)
}

.compEM <- function(y,group,guess){
    fit_rctme_em_delta0_fixed(W=y,T=group,G=guess)  
}

blindingCLASSIC <- function(y,group){
  out <- NULL
  Group <- as.factor(group)
  lm0 <- lm(y ~ Group)
  res <- summary(lm0)$coef
  out$estimate <- res
  out$tau <- res[2,1]
  out
}

blindingBI <- function(group, guess, impute=TRUE){
  out <- NULL
  sele <- is.na(guess)
  g2 <- guess[!sele]
  if (all(g2 %in% c(0, 1, 2))) {
    nlvl <- length(unique(g2))
  }else{
    stop("G must have values 0/1/2.", call. = FALSE)
  }
  if(any(sele)){
    if(impute){
      arm <- group
      arm[arm==0] = "B:Control"
      arm[arm==1] = "A:Treatment"
      blind <- guess
      g2 <- guess
      g2[sele] <- 4
      sele <- g2 == 0
      if(any(sele)) blind[sele] <- "2:Control"
      sele <- g2 == 1
      if(any(sele)) blind[sele] <- "1:Treatment"
      sele <- g2 == 2
      if(any(sele)) blind[sele] <- "3:DNK"
      sele <- g2 == 4
      if(any(sele)) blind[sele] <- "4:NA"
      out$tbl <- table(blind, arm)

      k <- sum(sele)
      kmat <- .generate_matrix_unique(k,kmax=100,nlevels=nlvl)
      out2 <- apply(kmat,1,.imputeBI,group=group,guess=guess)
      res1 <- .subRubinRule(thetai=out2[1,], ui=out2[2,])
      ## JBL range [0,+1]
      res1[3] <- max(res1[3],0)
      res1[4] <- min(res1[4],1)
      
      res2c <- .subRubinRule(thetai=out2[3,], ui=out2[4,])
      res2t <- .subRubinRule(thetai=out2[5,], ui=out2[6,])
      ## BBL range [-1,+1]
      res2c[3] <- max(res2c[3],-1)
      res2c[4] <- min(res2c[4],1)
      res2t[3] <- max(res2t[3],-1)
      res2t[4] <- min(res2t[4],1)
      
      tmp <- rbind(NULL,res1)
      res0 <- as.data.frame(tmp)
      rownames(res0) <- "Overall"
      names(res0) <- c("Estimate", "Std. Error", "95% LCL (2-Sided)",
                       "95% UCL (2-Sided)")
      JBI <- res0
      
      tmp <- rbind(res2t, res2c)
      res0 <- as.data.frame(tmp)
      rownames(res0) <- c("Treatment", "Control")
      names(res0) <- c("Estimate", "Std. Error", "95% LCL (2-Sided)",
                       "95% UCL (2-Sided)")
      BBI <- res0
      tmp <- list(JamesBI = JBI, BangBI = BBI)
      out$BI <- tmp
      
    }else{
      group <- group[!sele]
      guess <- guess[!sele]
      out <- .compBI(group,guess)
    }
  }else{
    out <- .compBI(group,guess)
  }
  out
}

.imputeBI <- function(x,group,guess){
  sele <- is.na(guess)
  guess[sele] <- x
  BIres <- .compBI(group=group,guess=guess)
  res <- c(BIres$BI$JamesBI[1,1],BIres$BI$JamesBI[1,2],
           BIres$BI$BangBI[2,1],BIres$BI$BangBI[2,2],
           BIres$BI$BangBI[1,1],BIres$BI$BangBI[1,2])
  return(res)
}

.compBI <- function(group,guess){
  if (all(guess %in% c(0, 1))) {
    arm <- group
    arm[arm==0] = "B:Placebo"
    arm[arm==1] = "A:Treatment"
    blind = guess
    blind[blind!=1] <- "2:Placebo"
    blind[blind==1] <- "1:Treatment"
    xtbl <- table(blind, arm)
    xtbl2 <- rbind(xtbl, "3:DNK"=c(0,0))
    res <- BI::BI(xtbl2)
  }else{
    arm <- group
    arm[arm==0] = "B:Placebo"
    arm[arm==1] = "A:Treatment"
    blind = rep("3:DNK",length(guess))
    blind[guess==0] <- "2:Placebo"
    blind[guess==1] <- "1:Treatment"
    xtbl <- table(blind, arm)
    res <- BI::BI(xtbl)
  }
  list(tbl=xtbl,BI=res)
}

blindingADJ <- function(y,group,guess,impute=TRUE){
  out <- NULL
  sele <- is.na(guess)
  g2 <- guess[!sele]
  if (all(g2 %in% c(0, 1, 2))) {
    nlvl <- length(unique(g2))
  }else{
    stop("G must have values 0/1/2.", call. = FALSE)
  }
  if(any(sele)){
    if(impute){
      k <- sum(sele)
      kmat <- .generate_matrix_unique(k,kmax=100,nlevels=nlvl)
      out2 <- apply(kmat,1,.imputeADJ,y=y,group=group,guess=guess)
      res1 <- .subRubinRule(thetai=out2[1,], ui=out2[2,])
      res2 <- .subRubinRule(thetai=out2[3,], ui=out2[4,])

      tmp <- rbind(res1,res2)
      out <- as.data.frame(tmp)
      rownames(out) <- c("mu0","tau")
      names(out) <- c("Estimate", "Std. Error", "95% LCL (2-Sided)",
                       "95% UCL (2-Sided)")
    }else{
      y <- y[!sele]
      group <- group[!sele]
      guess <- guess[!sele]
      out <- .compADJ(y,group,guess)
    }
  }else{
    out <- .compADJ(y,group,guess)
  }
  out
}

.compADJ <- function(y,group,guess){
  out <- NULL
  Group <- as.factor(group)
  Guess <- as.factor(guess)
  lm0 <- lm(y ~ Group + Guess)
  res <- summary(lm0)$coef
  out$estimate <- res
  out$tau <- res[2,1]
  out
}

.imputeADJ <- function(x,y,group,guess){
  sele <- is.na(guess)
  guess[sele] <- x
  res <- .compADJ(y=y,group=group,guess=guess)$estimate
  stat <- c(res[1,1],res[1,2],res[2,1],res[2,2])
  return(stat)
}



blindingCPE <- function(y,group,guess,impute=TRUE){
  out <- NULL
  sele <- is.na(guess)
  g2 <- guess[!sele]
  if (all(g2 %in% c(0, 1, 2))) {
    nlvl <- length(unique(g2))
  }else{
    stop("G must have values 0/1/2.", call. = FALSE)
  }
  if(any(sele)){
    if(impute){
      guess[sele] <- 2
    }else{
      y <- y[!sele]
      group <- group[!sele]
      guess <- guess[!sele]
    }
  }
  ## impute if guess=0/1/2, 
  ## compute directly if guess=0/1
  sele <- guess == 2
  k <- sum(sele)
  mu.y <- mean(y,na.rm=TRUE)
  sd.y <- sd(y,na.rm=TRUE)
  y0 <- (y - mu.y)/sd.y
  
  if(k == 0){
    res <- .compCPE(y=y0,group=group,guess=guess)

    out <- structure(list(
        fit = res,
        mu <- mu.y,
        sd <- sd.y,
        summary = res$estimate * sd.y,
        tau = res$estimate[2,1] * sd.y,
        theta = res$theta * sd.y
    ), class = "rctcpe_fit")

  }else{
    kmat <- .generate_matrix_unique(k,kmax=100,nlevels=2)
    out2 <- apply(kmat,1,.imputeCPE,y=y0,group=group,guess=guess)
    res1 <- .subRubinRule(thetai=out2[1,], ui=out2[2,])
    res2 <- .subRubinRule(thetai=out2[3,], ui=out2[4,])

    tmp <- rbind(res1,res2)
    out1 <- as.data.frame(tmp)
    rownames(out1) <- c("mu0","tau")
    names(out1) <- c("Estimate", "Std. Error", "95% LCL (2-Sided)",
                    "95% UCL (2-Sided)")

    out <- structure(list(
        fit = NULL,
        mu <- mu.y,
        sd <- sd.y,
        summary = out1 * sd.y,
        tau = out1[2,1] * sd.y
    ), class = "rctcpe_fit")
  }
  out
}

.imputeCPE <- function(x,y,group,guess){
  sele <- guess == 2
  guess[sele] <- x
  res <- .compCPE(y=y,group=group,guess=guess)$estimate
  stat <- c(res[1,1],res[1,2],res[2,1],res[2,2])
  return(stat)
}

.compCPE <- function(y,group,guess){
  db <- data.frame(y=y,group=group,guess=guess)
  lmout1 <- lm(y ~ group, data = db)
  res1 <- lmout1$coef[[2]]
  lmout2 <- lm(y ~ group + guess, data = db)
  res2 <- lmout2$coef[[2]]
  res3 <- lmout2$coef[[3]]
  res0 <- tapply(db$y, db$group, mean, na.rm=TRUE)
  usham <- max(abs(res1),abs(res2),abs(res3),abs(res0))
  
  out <- NULL
  d <- seq(from=0.0,to=3.0,length=200) * usham # 5/10 seemed too large
  b1 <- sapply(d, FUN=.cpe3dev, db=db)
  ## refine the grid --------------------
  out1  <- .cleangrid(d, b1);
  xmin <- out1$xmin; xmax <- out1$xmax
  d <- seq(from=xmin, to=xmax,length=199)
  b1 <- sapply(d, FUN=.cpe3dev, db=db)
  ## remove NAs from the searching grid
  sele <- is.na(b1)
  if(any(sele)){
    d <- d[!sele]; b1 <- b1[!sele]
  }
  out$x <- d; out$y <- b1
  ## define the range for cpe searching -------------
  out2 <- .definegrid(d, b1)
  out$xcut1 <- out2$xcut1
  out$xcut2 <- out2$xcut2
  out$p1.skew <- out2$p1.skew
  out$p2.skew <- out2$p2.skew
  out$xlrt <- out2$xlrt
  out$ylrt <- out2$ylrt
  out$lrtmin <- out2$lrtmin
  out$lrtmax <- out2$lrtmax
  out$xmax <- out2$xmax
  out$xddd <- out2$xddd
  out$yddd <- out2$yddd
  
  out3 <- .findcp_fast(x=out2$x, y=out2$y)
  out$theta <- out3$cpe
  out$xrss <- out3$x; out$yrss <- out3$y
  
  y2 <- db$y - out3$cpe * db$guess
  group <- db$group
  lm0 <- lm(y2 ~ group)
  out$estimate <- summary(lm0)$coef
  out
}

.definegrid <- function(x,y){
  n <- length(x)
  imax <- which.max(y)
  ymax <- y[imax]
  xmax <- x[imax]
  
  n1 <- imax - 1
  n2 <- n - imax
  p.left <- n1/n
  p.skew <- (ymax - y[1])/(ymax - y[n])
  
  dy <- diff(y)
  dx <- x[-1]
  idxmin <- which.min(dy)[1]
  dxmin <- dx[idxmin]
  n2lim <- sum(x < dxmin)
  idxmax <- which.max(dy)[1]
  dxmax <- dx[idxmax]
  n1lim <- sum(x <= dxmax)
  d <- (dx[1] + dxmax) * 0.5
  ## p.skew <- n1lim/n2lim * (n-n2lim)/n2lim * d
  p1.skew <- (dxmax - x[1])/(x[n] - x[1])
  p2.skew <- x[1]/x[n]
  yddd <- diff(dy); xddd = dx[-1]
  m1 <- 1; m2 <- n
  
  if(imax == 1){
    m1 <- 1
    m2 <- min(n, n2lim, 30)
  }else if(imax == n){
    m2 <- n
    m1 <- n - 30
  }else{
    n2u <- min(n2, n2lim - n1, n1)
    d1 <- n1lim - 1 
    d2 <- n2lim - n1lim
    d <- min(d1, d2)
    ##ctrl1 <- p1.skew
    ##ctrl1[p1.skew < 0.1] <- 0.1
    ##ctrl1[p1.skew > 0.35] <- 0.35
    ##dlt1 <- ctrl1
    ##ctrl2 <- p2.skew
    ##ctrl2[p2.skew < 0.02] <- 0.02
    #ctrl2[p2.skew > 0.45] <- 0.45
    ##dlt2 <- ctrl2
    if(p2.skew <= 0){
      m1 <- max(n1lim - (0.55 - 0.5*p1.skew) * d1, 1)
      m2 <- min(n1lim + (0.35 + 0.7*p1.skew) * d2, n2lim)
    }else{
      m1 <- max(n1lim - (0.85 + 0.70*p2.skew - 0.45*p1.skew) * d1, 1)
      m2 <- min(n1lim + (0.35 + 0.05*p2.skew - 0.35*p1.skew) * d2, n2lim)
    }
  }
  m1 <- max(1, round(m1)); m2 <- min(n,max(m1+20, round(m2)))
  
  list(x = x[m1:m2], y = y[m1:m2], 
       xlrt=dx, ylrt=dy, 
       xddd=xddd, yddd=yddd,
       lrtmin=dxmin, lrtmax=dxmax,
       p1.skew = p1.skew, 
       p2.skew = p2.skew, 
       xcut1 = x[m1], xcut2 = x[m2],# actual grid upper boundary
       xmax=xmax) # x of max(y)
}

.cpe3dev <- function(d,db){
  db$y <- db$y - d * db$guess
  sele <- db$guess == 1
  db$guess[sele] <- 1 
  db$guess[!sele] <- 0 
  g1 <- suppressWarnings(glm(guess ~ y, family = binomial(), data=db))
  if(any(max(abs(coef(g1)))>100))
    out = NA
  else
    out = g1$deviance[[1]]
  out
}

.cleangrid <- function(x,y){
  n <- length(x)
  stopifnot(length(y) == n)
  imax <- which.max(y)
  if(imax == 1){
    xmin <- x[1]
    rdy <- 0
    sele.na <- is.na(y)
    if(any(sele.na)){
      ina2 <- which(sele.na)[1]
      xmax <- x[ina2-1]
    }else{
      xmax <- x[n]
    }
  }else if(imax == n){
    xmax <- x[n]
    sele.na <- is.na(y)
    if(any(sele.na)){
      ina1 <- rev(which(sele.na))[1]
      xmin <- x[ina1+1]
    }else{
      xmin <- x[1]
    }
  }else{
    n1 <- imax - 1
    x1 <- x[1:n1]
    y1 <- y[1:n1]
    n2 <- n - imax
    x2 <- x[(imax + 1):n]
    y2 <- y[(imax + 1):n]
    ## left part --------------------------
    sele.na <- is.na(y1)
    if(any(sele.na)){
      ina1 <- rev(which(sele.na))[1]
      xmin <- x1[ina1 + 1]
    }else{
      xmin <- x1[1]
    }
    ## right part -------------------------
    sele.na <- is.na(y2)
    if(any(sele.na)){
      ina2 <- which(sele.na)[1]
      xmax <- x2[ina2 - 1]
    }else{
      xmax <- rev(x2)[1]
    }
  }
  list(xmin=xmin,xmax=xmax)
}


.findcp_fast <- function(x, y) {
  n <- length(y)
  stopifnot(length(x) == n)
  
  # starting point cannot be < 4
  k <- max(round(n * 0.1), 4L)
  if (n < 2*k + 2) stop("n is too small for this k.")
  
  x1 <- x
  x2 <- x1 * x1
  x3 <- x2 * x1
  x4 <- x2 * x2
  
  cy   <- c(0, cumsum(y))
  cx1  <- c(0, cumsum(x1))
  cx2  <- c(0, cumsum(x2))
  cx3  <- c(0, cumsum(x3))
  cx4  <- c(0, cumsum(x4))
  
  cxy1 <- c(0, cumsum(x1 * y))
  cxy2 <- c(0, cumsum(x2 * y))
  cyy  <- c(0, cumsum(y * y))
  
  seg_rss <- function(a, b) {
    s <- function(cs) cs[b + 1L] - cs[a]
    nseg <- b - a + 1L
    
    Sy   <- s(cy)
    Sx1  <- s(cx1)
    Sx2  <- s(cx2)
    Sx3  <- s(cx3)
    Sx4  <- s(cx4)
    Sxy1 <- s(cxy1)
    Sxy2 <- s(cxy2)
    Syy  <- s(cyy)
    
    XtX <- matrix(
      c(nseg, Sx1, Sx2,
        Sx1,  Sx2, Sx3,
        Sx2,  Sx3, Sx4),
      nrow = 3, byrow = TRUE
    )
    
    Xty <- c(Sy, Sxy1, Sxy2)
    
    R <- tryCatch(chol(XtX), error = function(e) NULL)
    if (is.null(R)) {
      b <- solve(XtX, Xty)
    } else {
      b <- backsolve(R, forwardsolve(t(R), Xty))
    }
    
    rss <- as.numeric(Syy - crossprod(b, Xty))
    if(is.na(rss)) rss <- 0
    if (rss < 0 && rss > -1e-10) rss <- 0
    rss
  }
  
  i_seq <- k:(n - k - 1L)
  m <- length(i_seq)
  rss_total <- numeric(m)
  
  for (j in seq_len(m)) {
    i <- i_seq[j]
    rss_total[j] <- seg_rss(1L, i) + seg_rss(i + 1L, n)
  }
  
  i_best <- i_seq[which.min(rss_total)]
  list(cpe=x[i_best], y=rss_total, x=x[i_seq])
}
