R/betaNB-s-cor-nb.R

In betaNB: Bootstrap for Regression Effect Sizes

#' Estimate Semipartial Correlation Coefficients
#' and Generate the Corresponding Sampling Distribution
#' Using Nonparametric Bootstrapping
#'
#' @author Ivan Jacob Agaloos Pesigan
#'
#' @details The vector of semipartial correlation coefficients
#'   (\eqn{r_{s}})
#'   is estimated from bootstrap samples.
#'   Confidence intervals are generated by obtaining
#'   percentiles corresponding to \eqn{100(1 - \alpha)\%}
#'   from the generated sampling
#'   distribution of \eqn{r_{s}},
#'   where \eqn{\alpha} is the significance level.
#'
#' @return Returns an object
#'   of class `betanb` which is a list with the following elements:
#'   \describe{
#'     \item{call}{Function call.}
#'     \item{args}{Function arguments.}
#'     \item{thetahatstar}{Sampling distribution of
#'       \eqn{r_{s}}.}
#'     \item{vcov}{Sampling variance-covariance matrix of
#'       \eqn{r_{s}}.}
#'     \item{est}{Vector of estimated
#'       \eqn{r_{s}}.}
#'     \item{fun}{Function used ("SCorNB").}
#'   }
#'
#' @inheritParams BetaNB
#'
#' @examples
#' # Data ---------------------------------------------------------------------
#' data("nas1982", package = "betaNB")
#'
#' # Fit Model in lm ----------------------------------------------------------
#' object <- lm(QUALITY ~ NARTIC + PCTGRT + PCTSUPP, data = nas1982)
#'
#' # NB -----------------------------------------------------------------------
#' nb <- NB(
#'   object,
#'   R = 100, # use a large value e.g., 5000L for actual research
#'   seed = 0508
#' )
#'
#' # SCorNB -------------------------------------------------------------------
#' out <- SCorNB(nb, alpha = 0.05)
#'
#' ## Methods -----------------------------------------------------------------
#' print(out)
#' summary(out)
#' coef(out)
#' vcov(out)
#' confint(out, level = 0.95)
#'
#' @family Beta Nonparametric Bootstrap Functions
#' @keywords betaNB scor
#' @export
SCorNB <- function(object,
                   alpha = c(0.05, 0.01, 0.001)) {
  stopifnot(
    inherits(
      x = object,
      what = "nb"
    )
  )
  if (object$lm_process$p < 2) {
    stop("Two or more regressors is required.")
  }
  fun <- "SCorNB"
  est <- .SPCor(
    betastar = object$lm_process$betastar,
    sigmacapx = object$lm_process$sigmacapx
  )
  names(est) <- object$lm_process$xnames
  foo <- function(x) {
    return(
      .SPCor(
        betastar = .BetaStarofSigma(
          sigmacap = x,
          q = 1 / sqrt(diag(x)),
          k = object$lm_process$k
        ),
        sigmacapx = x[
          2:object$lm_process$k,
          2:object$lm_process$k,
          drop = FALSE
        ]
      )
    )
  }
  thetahatstar <- lapply(
    X = object$thetahatstar,
    FUN = foo
  )
  vcov <- stats::var(
    do.call(
      what = "rbind",
      args = thetahatstar
    )
  )
  colnames(vcov) <- rownames(vcov) <- names(est)
  out <- list(
    call = match.call(),
    args = list(
      object = object,
      alpha = alpha
    ),
    thetahatstar = thetahatstar,
    jackknife = lapply(
      X = object$jackknife,
      FUN = foo
    ),
    vcov = vcov,
    est = est,
    fun = fun
  )
  class(out) <- c(
    "betanb",
    class(out)
  )
  return(
    out
  )
}