# 07/16/2024
# binsreg package, supporting functions
# p: degree of polynomial
# s: number of cts (deriv) constraints
# J: # of bins
# knot: complete knot sequence

genKnot.es <- function(x.min, x.max, J) {
  knot <- seq(x.min, x.max, length.out = J+1)
  return(knot)
}

# Quantile knot list (including xmin and xmax as boundaries)
genKnot.qs <- function(x, J) {
  knot <- quantile(x, seq(0, 1, 1/J), names = F, type=2)
  return(knot)
}

binsreg.bin.counts <- function(x, knot, nbins) {
  if (nbins == length(knot)) {
    bin <- match(x, knot)
  } else {
    bin <- findInterval(x, knot, rightmost.closed = T, left.open = T)
  }
  return(tabulate(bin, nbins=nbins))
}

# grid generation
binsreg.grid <- function(knot, ngrid, addmore=F) {
  eval <- cumsum(c(knot[1], rep(diff(knot)/(ngrid+1), each=ngrid+1)))
  eval <- eval[-c(1, length(eval))]
  bin <- isknot <- mid <- NA
  if (addmore) {
     bin <- rep(1:(length(knot)-1), each=ngrid+1)
     bin <- bin[-length(bin)]
     isknot <- rep(c(rep(0, ngrid), 1), length(knot)-1)
     isknot <- isknot[-length(isknot)]
     id.mid <- rep(0, ngrid+1); id.mid[ceiling(ngrid/2)] <- 1
     mid <- rep(id.mid, length(knot)-1)
     mid <- mid[-length(mid)]
  }
  return(list(eval=eval, bin=bin, isknot=isknot, mid=mid))
}

# Generate Design
binsreg.spdes <- function(eval, p, s, knot, deriv) {
  if (s == 0) {
     # mimic STATA irecode
     pos <- findInterval(eval, knot, rightmost.closed = T, left.open = T)
     n <- length(eval)
     jmax <- p + 1L
     P <- matrix(0, n, (length(knot)-1L) * jmax)
     h <- diff(knot)
     eval.cen <- (eval-knot[-length(knot)][pos]) / h[pos]
     col.base <- (pos - 1L) * jmax
     for (j in (deriv+1L):jmax) {
       P[cbind(seq_len(n), col.base+j)] <- eval.cen^(j-1L-deriv) *
         factorial(j-1L) / factorial(j-1L-deriv) / h[pos]^deriv
     }
  } else {
    if (length(knot) >= 3) {
       ext.knot <- c(rep(knot[1], p+1), rep(knot[2:(length(knot)-1)], each = p-s+1), rep(knot[length(knot)], p+1))
    } else {
       ext.knot <- c(rep(knot[1], p+1), rep(knot[length(knot)], p+1))
    }
    P <- splineDesign(knots = ext.knot, eval, ord = p+1, derivs = deriv)
  }
  return(P)
}

# check drop, display warning
check.drop <- function(beta, k) {
  if (any(is.na(beta[1:k]))) {
    warning("some X-based variables dropped")
  }
}

binsreg.rq.formula <- function(y, P, design.name) {
  fit.formula <- reformulate(design.name, response="y", intercept=FALSE)
  fit.env <- new.env(parent=parent.frame())
  fit.env$y <- y
  assign(design.name, P, envir=fit.env)
  environment(fit.formula) <- fit.env
  return(fit.formula)
}

binsreg.rq.complete <- function(model) {
  if (is.null(model$binsreg.design.name)) return(model)
  if (is.null(model$formula)) {
    model$formula <- binsreg.rq.formula(model$y, model$x, model$binsreg.design.name)
  }
  if (is.null(model$terms)) model$terms <- terms(model$formula)
  if (is.null(model$call)) model$call <- call("rq", formula=model$formula, tau=model$tau)
  if (is.null(model$xlevels)) model$xlevels <- list()
  if (is.null(model$contrasts)) model$contrasts <- NULL
  if (is.null(model$rho)) {
    resid <- as.vector(model$residuals)
    rho.weights <- if (is.null(model$weights)) 1 else model$weights
    model$rho <- sum(rho.weights * resid * (model$tau - (resid < 0)))
  }
  if (is.null(model$model)) {
    model.frame <- data.frame(y=model$y, check.names=FALSE)
    model.frame[[model$binsreg.design.name]] <- I(model$x)
    if (!is.null(model$weights)) model.frame[["(weights)"]] <- model$weights
    attr(model.frame, "terms") <- model$terms
    model$model <- model.frame
  }
  return(model)
}

# wrapper of vcov and vcovCL
binsreg.vcov <- function(model, type, cluster, is.qreg=FALSE, ...) {
  if (is.qreg) {
    model <- binsreg.rq.complete(model)
    V <- summary.rq(model, se=type, covariance = TRUE, cluster=cluster, ...)$cov
  } else {
    if (type=="const") {
      V <- vcov(model)
    } else {
      V <- vcovCL(model, type=type, cluster=cluster)
    }
  }
  return(V)
}

# faster internal lm/glm fitters for already-built numeric design matrices
binsreg.fit.lm <- function(y, P, weights=NULL) {
  if (is.null(weights)) {
    model <- lm.fit(x=P, y=y)
  } else {
    model <- lm.wfit(x=P, y=y, w=weights)
  }
  model$terms <- terms(y ~ -1 + P)
  model$call <- match.call()
  model$x <- P
  model$y <- y
  if (!is.null(weights)) model$weights <- weights
  class(model) <- "lm"
  return(model)
}

binsreg.fit.glm <- function(y, P, family, weights=NULL, ...) {
  dots <- list(...)
  dot.names <- names(dots)
  allowed <- setdiff(names(formals(glm.fit)), c("x", "y", "weights", "family"))
  if (length(dots) && (is.null(dot.names) || any(dot.names == "") || any(!dot.names %in% allowed))) {
    return(glm(y ~ P - 1, family=family, weights=weights, ...))
  }
  model <- do.call(glm.fit, c(list(x=P, y=y, weights=weights, family=family), dots))
  model$terms <- terms(y ~ -1 + P)
  model$call <- match.call()
  model$x <- P
  model$y <- y
  model$prior.weights <- if (is.null(weights)) rep.int(1, length(y)) else weights
  model$contrasts <- NULL
  model$xlevels <- list()
  model$formula <- y ~ -1 + P
  class(model) <- c("glm", "lm")
  return(model)
}

binsreg.fit.rq <- function(y, P, tau, weights=NULL, qregopt=NULL, design.name="P") {
  if (is.null(qregopt)) qregopt <- list()

  opt.names <- names(qregopt)
  reserved <- c("formula", "data", "subset", "na.action", "model", "contrasts",
                "x", "y", "tau", "weights")
  if (length(tau)!=1L || (length(qregopt) &&
      (is.null(opt.names) || any(opt.names=="") || any(opt.names %in% reserved)))) {
    fit.formula <- binsreg.rq.formula(y, P, design.name)
    return(do.call(rq, c(list(formula=fit.formula, tau=tau, weights=weights), qregopt)))
  }

  if (is.null(weights)) {
    model <- if (length(qregopt)==0L) {
      rq.fit(P, y, tau=tau)
    } else {
      do.call(rq.fit, c(list(x=P, y=y, tau=tau), qregopt))
    }
  } else {
    model <- if (length(qregopt)==0L) {
      rq.wfit(P, y, tau=tau, weights=weights)
    } else {
      do.call(rq.wfit, c(list(x=P, y=y, tau=tau, weights=weights), qregopt))
    }
  }

  coef.names <- colnames(P)
  if (is.null(coef.names)) {
    coef.names <- if (ncol(P)==1L) design.name else paste0(design.name, seq_len(ncol(P)))
  } else {
    coef.names <- paste0(design.name, coef.names)
  }
  if (length(model$coefficients)==length(coef.names)) names(model$coefficients) <- coef.names

  model$x <- P
  model$y <- y
  if (!is.null(weights)) model$weights <- weights
  model$binsreg.design.name <- design.name
  model$tau <- tau
  model$method <- if (is.null(qregopt$method)) "br" else qregopt$method

  class(model) <- "rq"
  return(model)
}

binsreg.cbind <- function(x, w) {
  if (is.null(w) || length(w)==0) x else cbind(x, w)
}

binsregselect.cache.env <- new.env(parent=emptyenv())
binsregselect.cache.env$entries <- list()

binsregselect.eval <- function(args) {
  arg.names <- names(args)
  if (is.null(arg.names)) arg.names <- rep("", length(args))
  unnamed <- !nzchar(arg.names)
  if (any(unnamed)) {
    arg.names[unnamed] <- names(formals(binsregselect))[seq_along(args)][unnamed]
  }
  names(args) <- arg.names

  eval.env <- list2env(args, parent=parent.frame())
  call.args <- lapply(arg.names, as.name)
  names(call.args) <- arg.names
  eval(as.call(c(list(quote(binsregselect)), call.args)), envir=eval.env)
}

binsregselect.cached <- function(...) {
  args <- list(...)
  # randcut consumes RNG, so cache only deterministic internal selections.
  if (!is.null(args$randcut)) {
    return(binsregselect.eval(args))
  }

  key <- tryCatch(serialize(args, NULL, version=2), error=function(e) NULL)
  if (is.null(key)) {
    return(binsregselect.eval(args))
  }

  entries <- binsregselect.cache.env$entries
  for (entry in entries) {
    if (identical(entry$key, key)) {
      for (msg in entry$warnings) warning(msg, call.=FALSE)
      return(entry$value)
    }
  }

  warnings <- character()
  out <- withCallingHandlers(binsregselect.eval(args),
                             warning=function(w) warnings <<- c(warnings, conditionMessage(w)))
  entries <- c(list(list(key=key, value=out, warnings=warnings)), entries)
  if (length(entries) > 8) entries <- entries[seq_len(8)]
  binsregselect.cache.env$entries <- entries
  return(out)
}

# internal pred function (model is long regression, NA handled inside)
binsreg.pred <- function(X, model, type="xb", vce, cluster=NULL, deriv=0, wvec=NULL, is.qreg=FALSE, avar=FALSE, vcv=NULL,...) {
   k <- ncol(X)
   fit <- NA
   if (type == "xb" | type == "all") {
      coef <- model$coeff
      coef[is.na(coef)] <- 0
      if (!is.null(wvec) & deriv==0) {
        fit <- as.vector(X %*% coef[1:k]) + sum(wvec*coef[-(1:k)])
      } else {
        fit <- as.vector(X %*% coef[1:k])
      }
   }
   se <- NA
   if (type == "se" | type == "all") {
      if (is.null(vcv)) {
        if (is.qreg) {
          vcv <- binsreg.vcov(model, type=vce, cluster=cluster, is.qreg=TRUE, ...)
        } else {
          vcv <- binsreg.vcov(model, type=vce, cluster=cluster)
        }
      }
      if (avar) {
        pos <- !is.na(model$coeff[1:k])
        k.new <- sum(pos)
        vcv <- vcv[1:k.new, 1:k.new, drop=F]
        X.pos <- X[, pos, drop=F]
        se <- sqrt(rowSums((X.pos %*% vcv) * X.pos))
      } else {
        if (!is.null(wvec) && deriv != 0) {
          pos <- !is.na(model$coeff[1:k])
          k.new <- sum(pos)
          vcv <- vcv[1:k.new, 1:k.new, drop=F]
        } else {
          if (!is.null(wvec)) {
            X <- cbind(X, matrix(wvec, nrow=nrow(X), ncol=length(wvec), byrow=TRUE))
          }
          pos <- !is.na(model$coeff)
        }
        X.pos <- X[, pos, drop=F]
        se <- sqrt(rowSums((X.pos %*% vcv) * X.pos))
      }
   }
   return(list(fit=fit, se=se))
}

# square root matrix
lssqrtm <- function(A) {
  decomp <- svd(A)
  decomp$d[decomp$d < 0] <- 0
  rootA  <- decomp$u %*% diag(sqrt(decomp$d)) %*% t(decomp$u)
  return(rootA)
}

# pval, cval simulation (tstat should be 2-col matrix)
binsreg.pval <- function(num, denom, rep, tstat=NULL, side=NULL, alpha, lp=Inf) {
  tvec <- if (!is.null(side)) numeric(rep) else NULL
  pval <- NA
  if (!is.null(tstat)) pval <- numeric(nrow(tstat))
  cval <- NA
  k <- ncol(num)

  chunk.size <- min(rep, max(1L, floor(5e6 / max(1L, nrow(num)))))
  start <- 1L
  while (start <= rep) {
    chunk <- min(chunk.size, rep - start + 1L)
    eps <- matrix(rnorm(k * chunk, 0, 1), nrow = k)
    tx <- (num %*% eps) / denom

    max.tx <- matrixStats::colMaxs(tx)
    min.tx <- matrixStats::colMins(tx)
    abs.tx <- if (is.infinite(lp)) {
      matrixStats::colMaxs(abs(tx))
    } else {
      colMeans(abs(tx)^lp)^(1/lp)
    }

    if (!is.null(side)) {
      idx <- start:(start + chunk - 1L)
      if (side == "two") {
        tvec[idx] <- abs.tx
      } else if (side == "left") {
        tvec[idx] <- max.tx
      } else if (side == "right") {
        tvec[idx] <- min.tx
      }
    }

    if (!is.null(tstat)) {
      for (j in seq_len(nrow(tstat))) {
        # 1: left; 2: right; 3: two-sided
        if (tstat[j,2] == 1) {
          pval[j] <- pval[j] + sum(max.tx >= tstat[j,1])
        } else if (tstat[j,2] == 2) {
          pval[j] <- pval[j] + sum(min.tx <= tstat[j,1])
        } else if (tstat[j,2] == 3) {
          pval[j] <- pval[j] + sum(abs.tx >= tstat[j,1])
        }
      }
    }
    start <- start + chunk
  }

  if (!is.null(tstat)) {
    pval <- pval / rep
  }

  if (!is.null(side)) {
    cval <- quantile(tvec, alpha/100, na.rm=T, names = F, type=2)
  }

  return(list(pval=pval, cval=cval))
}

# pval used only by binspwc
binspwc.pval <- function(nummat1, nummat2, denom1, denom2, rep, tstat=NULL, testtype=NULL, lp=Inf, alpha=95) {
  pval <- 0
  tvec <- numeric(rep)
  k1 <- ncol(nummat1); k2 <- ncol(nummat2)
  denom <- sqrt(denom1^2+denom2^2)

  chunk.size <- min(rep, max(1L, floor(5e6 / max(1L, nrow(nummat1)))))
  start <- 1L
  while (start <= rep) {
    chunk <- min(chunk.size, rep - start + 1L)
    eps <- matrix(rnorm((k1 + k2) * chunk, 0, 1), nrow = k1 + k2)
    eps1 <- eps[seq_len(k1), , drop=F]
    eps2 <- eps[k1 + seq_len(k2), , drop=F]
    tx <- (nummat1 %*% eps1 - nummat2 %*% eps2) / denom

    max.tx <- matrixStats::colMaxs(tx)
    min.tx <- matrixStats::colMins(tx)
    abs.tx <- if (is.infinite(lp)) {
      matrixStats::colMaxs(abs(tx))
    } else {
      colMeans(abs(tx)^lp)^(1/lp)
    }

    if (testtype == "left") {
      pval <- pval + sum(max.tx >= tstat)
    } else if (testtype == "right") {
      pval <- pval + sum(min.tx <= tstat)
    } else {
      pval <- pval + sum(abs.tx >= tstat)
    }

    idx <- start:(start + chunk - 1L)
    tvec[idx] <- matrixStats::colMaxs(abs(tx))
    start <- start + chunk
  }
  pval <- pval / rep
  cval.cb <- quantile(tvec, alpha/100, na.rm=T, names = F, type=2)
  return(list(pval=pval, cval.cb=cval.cb))
}

# IMSE V constant
imse.vcons <- function(p, deriv) {
  n <- p + 1
  V <- as.matrix(1/sapply(1:n, function(x) x:(x+n-1)))
  Vderiv <- matrix(0, n, n)
  for (r in (deriv+1):n) {
    for (c in (deriv+1):n) {
      Vderiv[r,c] <- 1/(r+c-1-2*deriv)*
            (factorial(r-1)/factorial(r-1-deriv))*
            (factorial(c-1)/factorial(c-1-deriv))
    }
  }
  vcons <- sum(diag(solve(V, Vderiv)))
  return(vcons)
}

# IMSE B constant
imse.bcons <- function(p, s=0, deriv) {
  ord <- p + 1
  if (s == 0) {
     bcons <- 1 / (2*(ord-deriv) + 1) / factorial(ord-deriv)^2 / choose(2*(ord-deriv), ord-deriv)^2
  } else {
    if (p==0) {
      bernum <- 1/6
    } else if (p==1) {
      bernum <- 1/30
    } else if (p==2) {
      bernum <- 1/42
    } else  if (p==3) {
      bernum <- 1/30
    } else if (p==4) {
      bernum <- 5/66
    } else if (p==5) {
      bernum <- 691/2730
    } else if (p==6) {
      bernum <- 7/6
    } else {
      print("p>6 not allowed.")
      stop()
    }
     bcons <- 1 / factorial(2*(ord-deriv)) * bernum
  }
  return(bcons)
}

bernpoly <- function(x, p) {
  n <- length(x)
  if (p==0) {
    bernx <- rep(1, n)
  } else if (p==1) {
    bernx <- x - 0.5
  } else if (p==2) {
    bernx <- x^2-x+1/6
  } else if (p==3) {
    bernx <- x^3 - 1.5*x^2 + 0.5*x
  } else if (p==4) {
    bernx <- x^4 - 2*x^3 + x^2 - 1/30
  } else if (p==5) {
    bernx <- x^5 - 2.5*x^4 + 5/3*x^3 - 1/6*x
  } else if (p==6) {
    bernx <- x^6 - 3*x^5 + 2.5*x^4 - 0.5*x^2 + 1/42
  } else {
    print("p>6 not allowed.")
    stop()
  }
  return(bernx)
}

# ROT selector
binsregselect.rot <- function(y, x, w, p, s, deriv, es=F, eN, norotnorm=F, qrot=2, den.alpha=0.975, weights=NULL) {
  x <- (x - min(x)) / (max(x) - min(x))
  ord <- p+1
  N <- length(x)

  x.p <- matrix(NA, N, p+qrot+1)
  for (j in 1:(p+qrot+1))  x.p[,j] <- x^(j-1)
  P <- binsreg.cbind(x.p, w)
  est <- binsreg.fit.lm(y, P, weights=weights)
  beta <- est$coefficients; est <- est$fitted.values

  # variance constant
  s2 <- binsreg.fit.lm(y^2, P, weights=weights)$fitted.values - est^2
  if (norotnorm) {
    fz <- 1
  } else {
    x.summ <- binsreg.summ(x, w=weights, std=T)
    fz <- dnorm(x, x.summ$mu, x.summ$sig)
    # trim density from below
    cutval <- dnorm(qnorm(den.alpha)*x.summ$sig, 0, x.summ$sig)
    fz[fz<cutval] <- cutval
  }
  if (es) {
    s2 <- s2 / fz
  } else {
    s2 <- s2 * (fz^(2*deriv))
  }

  s2 <- binsreg.summ(s2, w=weights, std=F)$mu
  vcons <- imse.vcons(p, deriv)
  imse.v <- vcons * s2

  # bias constant
  bcons <- imse.bcons(p, s=0, deriv)
  mu.m.hat <- 0
  for (j in (p+1):(p+qrot)) {
    mu.m.hat <- mu.m.hat + x^(j-p-1)*beta[j+1]*factorial(j)/factorial(j-p-1)
  }
  mu.m.hat <- mu.m.hat^2
  if (!es) {
    mu.m.hat <- mu.m.hat / (fz^(2*ord-2*deriv))
  }
  imse.b <- bcons * binsreg.summ(mu.m.hat, w=weights, std=F)$mu

  J.rot <- ceiling((imse.b*2*(ord-deriv)/(imse.v*(1+2*deriv)))^(1/(2*ord+1)) * eN^(1/(2*ord+1)))
  return(list(J.rot=J.rot, imse.b=imse.b, imse.v=imse.v))
}

# locate h
binsreg.locate <- function(x, knot, type="all") {
  h <- tl <- NA
  loc.ind <- findInterval(x, knot, rightmost.closed = T)
  if (type=="all"|type=="h") {
    size    <- diff(knot)
    h       <- size[loc.ind]
  }
  if (type=="all"|type=="tl") {
    pos     <- knot[-length(knot)]
    tl      <- pos[loc.ind]
  }
  return(list(h=h, tl=tl))
}

# IMSE V cons
genV <- function(y, x, w, p, s, deriv, knot, vce, cluster=NULL, weights=NULL,
                 B0=NULL, basis.deriv=NULL) {
  if (is.null(B0)) B0 <- binsreg.spdes(eval=x, p=p, s=s, knot=knot, deriv=0)
  B <- B0
  k  <- ncol(B)
  if (!is.null(basis.deriv)) {
     basis <- basis.deriv
  } else if (deriv>0) {
     basis <- binsreg.spdes(eval=x, p=p, s=s, knot=knot, deriv=deriv)
  } else {
     basis <- B
  }
  P     <- binsreg.cbind(B, w)
  model  <- binsreg.fit.lm(y, P, weights=weights)
  pos <- !is.na(model$coeff[1:k])
  k.new <- sum(pos)
  vcv <- binsreg.vcov(model, type=vce, cluster=cluster)[1:k.new, 1:k.new]
  m.s2   <- binsreg.summ(rowSums((basis[,pos, drop=F] %*% vcv) * basis[,pos, drop=F]), w=weights, std=F)$mu
  return(m.s2)
}

# bias term
bias <- function(x, p, s, deriv, knot) {
  locate <- binsreg.locate(x, knot)
  h  <- locate$h
  tl <- locate$tl
  bern <- bernpoly((x-tl)/h, p+1-deriv) / factorial(p+1-deriv) * (h^(p+1-deriv))
  return(bern)
}

genB <- function(y, x, w, p, s, deriv, knot, weights=NULL,
                 B0=NULL, basis.deriv=NULL) {
  B  <- binsreg.spdes(eval=x, p=p+1, s=s+1, knot=knot, deriv=0)   # use smoothest spline
  k    <- ncol(B)
  P    <- binsreg.cbind(B, w)
  beta <- binsreg.fit.lm(y, P, weights=weights)$coefficients[1:k]
  pos  <- !is.na(beta)
  basis <- binsreg.spdes(eval=x, p=p+1, s=s+1, knot=knot, deriv=p+1)
  basis.pos <- basis[, pos, drop=F]
  mu.m.fit  <- basis.pos %*% beta[pos]

  bias.0 <- mu.m.fit * bias(x, p, s, 0, knot)    # proj component, v=0!!!
  if (is.null(B0)) B0 <- binsreg.spdes(eval=x, p=p, s=s, knot=knot, deriv=0)
  B <- B0
  beta <- binsreg.fit.lm(bias.0, B, weights=weights)$coefficients
  pos <- !is.na(beta)
  if (deriv > 0) {
     if (is.null(basis.deriv)) {
       basis <- binsreg.spdes(eval=x, p=p, s=s, knot=knot, deriv=deriv)
     } else {
       basis <- basis.deriv
     }
     bias.v <- mu.m.fit * bias(x, p, s, deriv, knot)    # need to recalculate for v>0!!!
  } else {
     basis <- B
     bias.v <- bias.0
  }
  basis.pos <- basis[, pos, drop=F]
  bias.l2 <- bias.v - basis.pos %*% beta[pos]
  bias.cons <- binsreg.summ(bias.l2^2, w=weights, std=F)$mu
  return(bias.cons)
}

# DPI selector
binsregselect.dpi <- function(y, x, w, p, s, deriv, es=F, vce, cluster=NULL, nbinsrot, weights=NULL) {
  J.rot <- nbinsrot
  x <- (x - min(x))/ (max(x) - min(x))
  ord <- p + 1

  if (es) {
    knot <- genKnot.es(0, 1, J.rot)
  } else {
    knot <- genKnot.qs(x, J.rot)
  }

  B0 <- binsreg.spdes(eval=x, p=p, s=s, knot=knot, deriv=0)
  basis.deriv <- if (deriv>0) {
    binsreg.spdes(eval=x, p=p, s=s, knot=knot, deriv=deriv)
  } else {
    B0
  }

  # bias constant
  imse.b <- genB(y, x, w, p, s, deriv, knot, weights=weights,
                 B0=B0, basis.deriv=basis.deriv) * J.rot^(2*(ord-deriv))

  # variance constant
  genV_val <- genV(y, x, w, p, s, deriv, knot, vce, cluster,
                   weights=weights, B0=B0, basis.deriv=basis.deriv)
  imse.v <- genV_val / (J.rot^(1+2*deriv))
  J.dpi <- ceiling((imse.b*2*(ord-deriv)/((1+2*deriv)*imse.v))^(1/(2*ord+1)))
  return(list(J.dpi=J.dpi, imse.v=imse.v, imse.b=imse.b))
}

# Check local mass points
binsreg.checklocalmass <- function(x, J, es, knot=NULL) {
  if (is.null(knot)) {
    if (es) {
      knot <- genKnot.es(min(x), max(x), J)
    } else {
      knot <- genKnot.qs(x, J)
    }
  }
  pos <- findInterval(x, knot, rightmost.closed = T, left.open = T)
  uniqnum <- sapply(1:J, function(z) length(unique(x[pos==z])))
  return(min(uniqnum))
}

# slightly modified mean fun
binsreg.summ <- function(x, w=NULL, std=F) {
  mu <- sig <- NA
  if (is.null(w)) {
    mu <- mean(x)
    if (std) sig <- sd(x)
  } else {
    mu <- weighted.mean(x, w=w)
    if (std) sig <- sqrt(sum(w*(x-mu)^2)/(sum(w)-1))
  }
  return(list(mu=mu, sig=sig))
}

# extract formula information
binsreg.model.mat <- function(formula=NULL, data=NULL) {
  des <- model.matrix(formula, data=data)
  col.term <- attr(des, "assign")                    # each column comes from which var
  factor.strlist <- names(attr(des, "contrasts"))    # names of factor vars.

  formula.info <- terms.formula(formula)
  term.mat <- attr(formula.info, "factors")          # which term uses which var.
  row.name <- rownames(term.mat)
  factor.index <- row.name %in% factor.strlist       # pos of factor vars in the string list
  usefactor.pos <- which(colSums(term.mat[factor.index,,drop=F])>0)   # index for terms that use factor vars

  factor.colnum <- col.term %in% usefactor.pos      # pos of columns in the design that use factor vars

  if (attr(formula.info, "intercept")==1) {
    des <- des[,-1,drop=F]
    factor.colnum <- factor.colnum[-1]
  }
  return(list(design=des, factor.colnum=factor.colnum))
}

# check if an object is a formula
is.formula <- function(x) {
  ind <- try(is.call(x) && x[[1]] == quote(`~`), silent = T)
  if (inherits(ind, "try-error")) {
    ind <- F
  }
  return(ind)
}
