## Set of various R functions

#@name processControl
#@title Control parameters processsing
processControl <- function(control) {
  if (!is.list(control)) {
    control <- list()
  }
  nam <- names(control)
  if (!("type" %in% nam) || is.null(control$type)) {
    control$type <- 1
  }
  if (!("ttype" %in% nam) || is.null(control$ttype)) {
    control$ttype <- 2
  }
  if (!("hac" %in% nam) || is.null(control$hac)) {
    control$hac <- FALSE
  }
  if (!("nBoot" %in% nam) || is.null(control$nBoot)) {
    control$nBoot <- 499
  }
  if (!("bBoot" %in% nam) || is.null(control$bBoot)) {
    control$bBoot <- 1
  }
  if (!("pBoot" %in% nam) || is.null(control$pBoot)) {
    control$pBoot <- 1
  }
  if (!("nCore" %in% nam) || is.null(control$nCore)) {
    control$nCore <- 1
  }
  if (!("minObs" %in% nam) || is.null(control$minObs)) {
    control$minObs <- 10
  }
  if (!("minObsPi" %in% nam) || is.null(control$minObsPi)) {
    control$minObsPi <- 1
  }
  if (!("lambda" %in% nam) || is.null(control$lambda)) {
    control$lambda <- NULL
  }
  if (!("screen_beta" %in% nam) || is.null(control$screen_beta)) {
    control$screen_beta <- FALSE
  }
  if (!("fastAdjust" %in% nam) || is.null(control$fastAdjust)) {
    control$fastAdjust <- FALSE
  }
  if (!("gammaPos" %in% nam) || is.null(control$gammaPos)) {
    control$gammaPos <- 0.4
  }
  if (!("gammaNeg" %in% nam) || is.null(control$gammaNeg)) {
    control$gammaNeg <- 0.6
  }

  # basic validation of the (possibly user-supplied) values
  for (nm in c("hac", "screen_beta", "fastAdjust")) {
    v <- control[[nm]]
    if (length(v) != 1L || !is.logical(v) || is.na(v))
      stop("'control$", nm, "' must be a single TRUE/FALSE")
  }
  for (nm in c("type", "ttype", "pBoot", "nBoot", "bBoot", "nCore",
               "minObs", "minObsPi", "gammaPos", "gammaNeg")) {
    v <- control[[nm]]
    if (length(v) != 1L || !is.numeric(v) || !is.finite(v))
      stop("'control$", nm, "' must be a single finite number")
  }
  # the count-like controls must be whole numbers (they feed sample.int(),
  # makeCluster(), and array indexing)
  for (nm in c("nBoot", "bBoot", "nCore", "minObs", "minObsPi")) {
    v <- control[[nm]]
    if (v != round(v))
      stop("'control$", nm, "' must be a whole number")
    control[[nm]] <- as.integer(round(v))
  }
  if (!(control$type %in% c(1, 2))) stop("'control$type' must be 1 or 2")
  if (!(control$ttype %in% c(1, 2))) stop("'control$ttype' must be 1 or 2")
  if (!(control$pBoot %in% c(1, 2))) stop("'control$pBoot' must be 1 or 2")
  if (!is.logical(control$hac)) stop("'control$hac' must be logical")
  if (control$nBoot < 1) stop("'control$nBoot' must be >= 1")
  if (control$bBoot < 0) stop("'control$bBoot' must be >= 0")
  if (control$nCore < 1) stop("'control$nCore' must be >= 1")
  if (control$minObs < 1) stop("'control$minObs' must be >= 1")
  if (control$minObsPi < 0) stop("'control$minObsPi' must be >= 0")
  if (!is.null(control$lambda) && (any(control$lambda < 0) || any(control$lambda >= 1)))
    stop("'control$lambda' must lie in [0, 1)")
  if (control$gammaPos <= 0 || control$gammaPos >= 1) stop("'control$gammaPos' must lie in (0, 1)")
  if (control$gammaNeg <= 0 || control$gammaNeg >= 1) stop("'control$gammaNeg' must lie in (0, 1)")

  return(control)
}

#@name .coefNames
#@title Row labels for the screen_beta coefficients (alpha + factor betas)
.coefNames <- function(factors) {
  nm <- colnames(factors)
  if (is.null(nm)) {
    nm <- paste0("beta", seq_len(ncol(as.matrix(factors))))
  }
  c("alpha", nm)
}

#@name alphaFactor
#@title Compute alpha factor
alphaFactor <- function(X, factors = NULL) {
  fit <- stats::lm(X ~ 1 + factors)
  alpha <- as.vector(fit$coef[1, ])
  return(alpha)
}

#' @name sharpe
#' @title Compute Sharpe ratio
#' @description Function which computes the Sharpe ratio.
#' @details The Sharpe ratio (Sharpe 1994) is one industry standard for measuring the
#' absolute risk adjusted performance of hedge funds.
#' @param X Vector (of length \eqn{T}) or matrix (of size \eqn{T \times
#' N}{TxN}) of returns for \eqn{N} funds. \code{NA} values are allowed.
#' @param na.rm A logical value indicating whether \code{NA} values should be
#' stripped before the computation. Default \code{na.rm = TRUE}
#' @return A scalar or a vector (of size \eqn{N}) with the Sharpe ratios.
#' @author David Ardia and Kris Boudt.
#' @seealso \code{\link{sharpeTesting}}, \code{\link{sharpeScreening}} and
#' \code{\link{msharpe}}.
#' @references
#' Ardia, D., Boudt, K. (2015).
#' Testing equality of modified Sharpe ratios.
#' \emph{Finance Research Letters} \bold{13}, pp.97--104.
#' \doi{10.1016/j.frl.2015.02.008}
#'
#' Ardia, D., Boudt, K. (2016).
#' The Peer Ratios Performance of Hedge Funds.
#' \emph{Working paper}.
#' \doi{10.2139/ssrn.2000901}
#'
#' Sharpe, W.F. (1994).
#' The Sharpe ratio.
#' \emph{Journal of Portfolio Management} \bold{21}(1), pp.49--58.
#' \doi{10.3905/jpm.1994.409501}
#' @keywords htest
#' @examples
#' ## Load the data
#' data('hfdata')
#'
#' ## Compute the Sharpe ratio
#' out = sharpe(hfdata)
#' print(out)
#'
#' out = sharpe(hfdata, na.rm = FALSE)
#' print(out)
#' @export
sharpe <- function(X, na.rm = TRUE) {
  X <- as.matrix(X)
  N <- ncol(X)
  tmp <- .sharpe(X, na.rm)
  out <- tmp$mu.hat/tmp$sig.hat
  return(out)
}

#@name .sharpe
#@title Compute Sharpe ratio
.sharpe <- function(X, na.rm) {
  nObs <- colSums(is.finite(X))
  mu.hat <- colMeans(X, na.rm = na.rm)
  X_ <- sweep(x = X, MARGIN = 2, STATS = mu.hat, FUN = "-")
  sig.hat <- sqrt(colSums(X_^2, na.rm = na.rm)/(nObs - 1))
  out <- list(mu.hat = mu.hat, sig.hat = sig.hat)
  return(out)
}

#' @name msharpe
#' @title Compute modified Sharpe ratio
#' @description Function which computes the modified Sharpe ratio
#' @details The modified Sharpe ratio (Favre and Galeano 2002) is one industry
#' standard for measuring the absolute risk adjusted performance of hedge
#' funds.
#' @param X Vector (of length \eqn{T}) or matrix (of size \eqn{T \times
#' N}{TxN}) of returns.  \code{NA} values are allowed.
#' @param level Modified Value-at-Risk level. Default: \code{level = 0.90}.
#' @param na.rm A logical value indicating whether \code{NA} values should be
#' stripped before the computation. Default \code{na.rm = TRUE}.
#' @param na.neg A logical value indicating whether \code{NA} values should be
#' returned if a negative modified Value-at-Risk is obtained.  Default
#' \code{na.neg = TRUE}.
#' @return Scalar or a vector (of size \eqn{N}) with the modified Sharpe
#' ratios.
#' @author David Ardia and Kris Boudt.
#' @seealso \code{\link{msharpeTesting}}, \code{\link{msharpeScreening}} and
#' \code{\link{sharpe}}.
#' @references
#' Ardia, D., Boudt, K. (2015).
#' Testing equality of modified Sharpe ratios.
#' \emph{Finance Research Letters} \bold{13}, 97--104.
#'
#' Ardia, D., Boudt, K. (2018).
#' The peer performance ratios of hedge Funds.
#' \emph{Journal of Banking and Finance} \bold{87}, 351--368.
#'
#' Favre, L., Galeano, J.A. (2002).
#' Mean-modified Value-at-Risk Optimization with Hedge Funds.
#' \emph{Journal of Alternative Investments} \bold{5}(2), 21--25.
#'
#' Gregoriou, G. N., Gueyie, J.-P. (2003).
#' Risk-adjusted performance of funds of hedge funds using a modified Sharpe ratio.
#' \emph{Journal of Wealth Management} \bold{6}(3), 77--83.
#' @keywords htest
#' @examples
#' ## Load the data (randomized data of monthly hedge fund returns)
#' data('hfdata')
#'
#' out = msharpe(hfdata)
#' print(out)
#'
#' out = msharpe(hfdata, na.rm = FALSE)
#' print(out)
#' @export
#' @importFrom stats qnorm
msharpe <- function(X, level = 0.9, na.rm = TRUE, na.neg = TRUE) {
  X <- as.matrix(X)
  N <- ncol(X)
  tmp <- .msharpe(X, level, na.rm, na.neg)
  out <- tmp$m1/tmp$mVaR
  return(out)
}

.msharpe <- function(X, level, na.rm, na.neg) {
  m1 <- colMeans(X, na.rm = na.rm)
  X_ <- sweep(x = X, MARGIN = 2, STATS = m1, FUN = "-")
  m2 <- colMeans(X_^2, na.rm = na.rm)
  m3 <- colMeans(X_^3, na.rm = na.rm)
  m4 <- colMeans(X_^4, na.rm = na.rm)
  za <- stats::qnorm(1 - level)
  skew <- m3/m2^(3/2)
  kurt <- (m4/m2^2) - 3
  mVaR <- -m1 + sqrt(m2) * (-za - (1/6) * (za^2 - 1) * skew - (1/24) *
                              (za^3 - 3 * za) * kurt + (1/36) * (2 * za^3 - 5 * za) * skew^2)
  if (na.neg) {
    mVaR[mVaR < 0] <- NA
  }
  out <- list(m1 = m1, mVaR = mVaR)
  return(out)
}

# #' @name .infoFund
# #' @import compiler
.infoFund <- function(X, factors = NULL, level = NULL, na.rm = TRUE, na.neg = TRUE, screen_beta=FALSE) {
  X <- as.matrix(X)
  N <- ncol(X)
  nObs <- colSums(is.finite(X))
  muX <- colMeans(X, na.rm = na.rm)
  rX <- sweep(x = X, MARGIN = 2, STATS = muX, FUN = "-")
  sigX <- sqrt(colSums(rX^2, na.rm = na.rm)/(nObs - 1))
  sharpe_ <- muX/sigX

  # if (is.null(factors)) {
  #   fit <- stats::lm(X ~ 1)
  # } else {
  #   fit <- stats::lm(X ~ 1 + factors)
  # }
  # alpha_ <- as.vector(fit$coef[1, ]) #output is a vector.

  # FIX
  # preallocate space.
  if(screen_beta){
    alpha_ <- matrix(NA, nrow=ncol(factors)+1, ncol=ncol(X))
  }else{
    alpha_ <- rep(NA, ncol(X))
  }

  if (is.null(factors)) {
    for (col in 1:ncol(X)) {
      fit <- stats::lm(X[,col] ~ 1)
      alpha_[col] <- fit$coef[1]
    }
  } else {
    for (col in 1:ncol(X)) {
      fit <- stats::lm(X[,col] ~ 1 + factors)
      if(screen_beta){
        alpha_[, col] <- fit$coef
      }else{
        alpha_[col] <- fit$coef[1]
      }

    }
  }

  msharpe_ <- NULL
  if (!is.null(level)) {
    msharpe_ <- msharpe(X, level = level, na.rm = na.rm, na.neg = na.neg)
  }

  out <- list(nObs = nObs, mu = muX, sig = sigX, sharpe = sharpe_, alpha = alpha_,
              msharpe = msharpe_)
  return(out)
}
infoFund <- compiler::cmpfun(.infoFund)

# #' @name .bootIndicesByLen
# Pre-generate bootstrap indices for every distinct pairwise sample length, in
# the master process. The screening functions pass the resulting named list to
# the PSOCK workers, which select the matrix matching their pair's
# complete-case length. This keeps all randomness in the master (so seeded
# results do not depend on 'nCore') and guarantees a valid circular-block
# structure at every length: previously a single full-length index matrix was
# remapped by modulo inside the workers, which biased the iid resampling and
# broke the block contiguity on unbalanced panels. Lengths shorter than the
# block length are skipped (the corresponding pairs are left untested). On a
# balanced panel there is a single length and the draws are identical to the
# previous behavior.
.bootIndicesByLen <- function(lens, nBoot, bBoot) {
  lens <- sort(unique(as.integer(lens)), decreasing = TRUE)
  lens <- lens[lens >= 1L]
  keep <- lens >= max(1L, bBoot)
  if (!any(keep)) {
    stop("the bootstrap block length 'bBoot' cannot exceed the number of concordant observations of every pair")
  }
  if (!all(keep)) {
    warning("some pairs have fewer concordant observations than the block length 'bBoot' and are left untested")
  }
  lens <- lens[keep]
  out <- lapply(lens, function(L) bootIndices(L, nBoot, bBoot))
  names(out) <- as.character(lens)
  return(out)
}
bootIndicesByLen <- compiler::cmpfun(.bootIndicesByLen)

# #' @name .bootIndices
# #' @import compiler
.bootIndices <- function(T, nBoot, bBoot) {
  if (bBoot > T) {
    stop("the bootstrap block length 'bBoot' cannot exceed the number of observations")
  }
  idsBoot <- matrix(data = NA, nrow = T, ncol = nBoot)
  if (bBoot == 1) {
    idsBoot <- matrix(sample.int(T, size = T * nBoot, replace = TRUE),
                      nrow = T, ncol = nBoot)
  } else {
    for (i in 1:nBoot) {
      l <- floor(T/bBoot)
      ids <- c(1:T, 1:bBoot)
      seqb <- vector("integer", T)
      start.points <- sample.int(T, size = l, replace = TRUE)
      for (j in (1:l)) {
        start <- start.points[j]
        seqb[((j - 1) * bBoot + 1):(j * bBoot)] <- ids[start:(start +
                                                                bBoot - 1)]
      }
      idsBoot[, i] <- seqb
    }
  }
  return(idsBoot)
}
bootIndices <- compiler::cmpfun(.bootIndices)
