# Statistical metric functions

#' Quantile summary statistics
#'
#' @title Quantile Summary
#' @description Computes summary statistics and quantiles for a numeric vector.
#'
#' @param x Numeric vector.
#' @param statfuns Function returning named summary statistics.
#' @param probs Named numeric vector of quantile probabilities.
#' @param names Logical; include names in quantile output.
#'
#' @return Named numeric vector of statistics and quantiles.
#' @export
quant_fun <- function(x,
                      statfuns = function(y) c(MEAN = mean(y, na.rm = TRUE),
                                               SE   = sd(y,   na.rm = TRUE)),
                      probs    = c("min" = 0, "2.5%" = 0.025, "25%" = 0.25,
                                   median = 0.5, "75%" = 0.75, "97.5%" = 0.975,
                                   "max"  = 1),
                      names    = TRUE) {
  c(statfuns(x), quantile(x, probs = probs, na.rm = TRUE, names = names))
}

#' Quantile summaries over matrix margins
#'
#' @title Quantile Summaries (Matrix)
#' @description Applies \code{\link{quant_fun}} over rows or columns of a
#'   matrix or data frame.
#'
#' @param x Matrix or data frame.
#' @param MARGIN Integer; \code{1} for rows, \code{2} for columns.
#' @param statfuns Function returning named summary statistics.
#' @param probs Named numeric vector of quantile probabilities.
#'
#' @return Data frame of statistics.
#' @export
quant_funs <- function(x,
                       MARGIN   = 1,
                       statfuns = function(y) c(MEAN = mean(y, na.rm = TRUE),
                                                SE   = sd(y,   na.rm = TRUE)),
                       probs    = c("min" = 0, "2.5%" = 0.025, "25%" = 0.25,
                                    median = 0.5, "75%" = 0.75, "97.5%" = 0.975,
                                    "max"  = 1)) {
  if (is.null(names(probs)))
    if (length(probs) > 0)
      if (all(probs <= 1) && all(probs >= 0))
        names(probs) <- paste0(round(probs * 100, 3), "%")
  as.data.frame(structure(
    .Data      = apply(X = x, MARGIN = MARGIN, quant_fun,
                       statfuns = statfuns, probs = probs, names = FALSE),
    .Dimnames  = list(
      c(names(as.list(as.list(statfuns)[[2]]))[-1], names(probs)),
      rownames(x)
    )
  ))
}

#' Transposed quantile summaries over matrix margins
#'
#' @title Transposed Quantile Summaries (Matrix)
#' @description Like \code{\link{quant_funs}} but returns transposed result.
#'
#' @param x Matrix or data frame.
#' @param MARGIN Integer; \code{1} for rows, \code{2} for columns.
#' @param statfuns Function returning named summary statistics.
#' @param probs Named numeric vector of quantile probabilities.
#'
#' @return Transposed data frame of statistics.
#' @export
quant_funst <- function(x,
                        MARGIN   = 1,
                        statfuns = function(y) c(MEAN = mean(y, na.rm = TRUE),
                                                 SE   = sd(y,   na.rm = TRUE)),
                        probs    = c("min" = 0, "2.5%" = 0.025, "25%" = 0.25,
                                     median = 0.5, "75%" = 0.75, "97.5%" = 0.975,
                                     "max"  = 1)) {
  as.data.frame(structure(
    .Data     = t(apply(X = x, MARGIN = MARGIN, quant_fun,
                        statfuns = statfuns, probs = probs, names = FALSE)),
    .Dimnames = list(
      rownames(x),
      c(names(as.list(as.list(statfuns)[[2]]))[-1], names(probs))
    )
  ))
}

#' Test for whole number
#'
#' @title Test for Whole Number
#' @description Tests whether numeric values are whole numbers within a
#'   numeric tolerance.
#'
#' @param x Numeric vector.
#' @param tol Numeric tolerance. Default \code{.Machine$double.eps^0.5}.
#'
#' @return Logical vector.
#' @export
is.wholenumber <- function(x, tol = .Machine$double.eps^0.5) abs(x - round(x)) < tol

#' Quantile summaries by group
#'
#' @title Quantile Summaries by Group
#' @description Computes quantile summaries within each level of a categorical
#'   variable.
#'
#' @param x Numeric vector.
#' @param catvar Factor or character vector of group labels.
#' @param pooled Logical; include a pooled row. Default \code{TRUE}.
#' @param n Logical; include count and missing count columns. Default \code{TRUE}.
#'
#' @return Data frame with one row per group.
#' @export
quant_fun_groups <- function(x, catvar, pooled = TRUE, n = TRUE) {
  if (inherits(catvar, "factor")) catvar <- levels(catvar)[as.integer(catvar)]
  tmp <- as.data.frame(t(mapply(function(gr) {
    y <- x[catvar %in% gr]
    if (gr == "Pooled") y <- x
    retv <- quant_fun(y)
    if (n) retv <- c(n = length(y), "n missing" = sum(is.na(y)), retv)
    return(retv)
  }, gr = c(unique(catvar), if (pooled) "Pooled" else NULL))))
  cbind(name = rownames(tmp), tmp)
}

#' @rdname quant_fun_groups
#' @param x A list of numeric vectors.
#' @export
quant_funs_groups <- function(x, catvar, pooled = TRUE, n = TRUE) {
  tmp <- lapply(x, FUN = quant_fun_groups, catvar = catvar, pooled = pooled, n = n)
  tmp <- Map(function(lv, ln) {
    lv <- rbind(NA, NA, lv)
    lv[2, 1] <- ln
    rownames(lv)[2] <- ln
    lv
  }, lv = tmp, ln = names(tmp))
  do.call(rbind, tmp)
}

#' Standardise distribution name
#'
#' @title Standardise Distribution Name
#' @description Maps common distribution name variants to their canonical R
#'   short form (e.g., \code{"normal"} -> \code{"norm"}).
#'
#' @param dist Character distribution name.
#'
#' @return Canonical short-form character name.
#' @export
fixdist <- function(dist) {
  structure(
    .Data  = c("norm", "norm", "lnorm", "lnorm", "lnorm", "exp", "exp",
               "beta", "gamma", "weibull", "weibull", tolower(dist)),
    .Names = c("normal", "norm", "lnorm", "lnormal", "lognormal", "exp",
               "exponential", "beta", "gamma", "weib", "weibull", tolower(dist))
  )[[tolower(dist)]]
}

#' Get a distribution function by type
#'
#' @title Get Distribution Function
#' @description Returns the named R distribution function (density, CDF,
#'   quantile, or random) for a given distribution, with an extra \code{...}
#'   argument appended to its formals.
#'
#' @param dist Character distribution name (passed to \code{\link{fixdist}}).
#' @param type Character; one of \code{"p"}, \code{"d"}, \code{"q"}, \code{"r"}.
#'
#' @return A function.
#' @export
getf <- function(dist, type) {
  thisf <- get(paste0(type, fixdist(dist)))
  formals(thisf) <- c(formals(thisf), alist("..." = ))
  return(thisf)
}

#' @rdname getf
#' @export
getp <- function(dist) getf(dist, "p")

#' @rdname getf
#' @export
getq <- function(dist) getf(dist, "q")

#' @rdname getf
#' @export
getd <- function(dist) getf(dist, "d")

#' @rdname getf
#' @export
getr <- function(dist) getf(dist, "r")

#' Mean of a distribution
#'
#' @param qfun Quantile function.
#' @param pars Named list of distribution parameters.
#' @return Numeric mean.
#' @export
getMean <- function(qfun, pars) do.call(integrate, c(list(qfun, 0, 1), pars))$value

#' Variance of a distribution
#'
#' @param qfun Quantile function or character distribution name.
#' @param pars Named list of distribution parameters.
#' @return Numeric variance.
#' @export
getVar <- function(qfun, pars) {
  if (is.character(qfun)) qfun <- getq(qfun)
  tmpmean <- getMean(qfun, pars)
  do.call(integrate,
          list(function(p) (do.call(qfun, c(list(p), pars)) - tmpmean)^2, 0, 1))$value
}

#' Standard deviation of a distribution
#'
#' @param qfun Quantile function or character distribution name.
#' @param pars Named list of distribution parameters.
#' @return Numeric standard deviation.
#' @export
getSD <- function(qfun, pars) sqrt(getVar(qfun, pars))

#' Density for an order statistic
#'
#' @title Order Statistic Density
#' @description Computes the density of the \eqn{r}-th order statistic in a
#'   random sample of \eqn{n} from a given distribution.
#'
#' @param x Numeric vector of values.
#' @param r Integer rank.
#' @param n Sample size.
#' @param par Named vector of distribution parameters.
#' @param dist Character distribution name.
#' @param log Logical; return log-density. Default \code{FALSE}.
#'
#' @return Numeric density (or log-density).
#' @export
ordD <- function(x, r, n, par = c(mean = 0, sd = 1), dist = "norm", log = FALSE) {
  if (any(r > n)) stop("r cannot be larger than n.")
  nchoices <- lfactorial(n) - (lfactorial(r - 1) + lfactorial(n - r))
  fx   <- do.call(getd(dist), c(list(x = x, log = TRUE), as.list(par)))
  Fxl  <- do.call(getp(dist), c(list(q = x, log = TRUE), as.list(par)))
  Fxlm <- do.call(getp(dist), c(list(q = x, log = TRUE, lower.tail = FALSE), as.list(par)))
  fx  [fx   == -Inf] <- log(.Machine$double.xmin)
  Fxl [Fxl  == -Inf] <- log(.Machine$double.xmin)
  Fxlm[Fxlm == -Inf] <- log(.Machine$double.xmin)
  if (log) {
    return(nchoices + fx + Fxlm * (n - r) + Fxl * (r - 1))
  } else {
    return(exp(nchoices + fx + Fxlm * (n - r) + Fxl * (r - 1)))
  }
}

#' Expected value of an order statistic
#'
#' @title Order Statistic Expected Value
#' @description Computes the expected value of the \eqn{r}-th order statistic
#'   in a random sample of \eqn{n} from a given distribution.
#'
#' @param r Integer rank (or vector of ranks).
#' @param n Sample size.
#' @param par Named vector of distribution parameters.
#' @param dist Character distribution name.
#' @param log Currently unused.
#'
#' @return Numeric expected value.
#' @export
ordE <- function(r, n, par = c(mean = 0, sd = 1), dist = "norm", log = FALSE) {
  if (any(r > n)) stop("r cannot be larger than n.")
  if (any(r < 1)) stop("r cannot be smaller than 1.")
  if (length(r) > 1) return(sapply(r, ordE, n = n, par = par, dist = dist, log = log))
  if (n < 1000) {
    bounds <- do.call(getq(dist), c(list(p = c(0.000001, 0.999999)), as.list(par)))
    integrate(f = function(x, ...) x * ordD(x, ...), lower = bounds[1], upper = bounds[2],
              r = r, n = n, par = par, dist = dist, log = log, subdivisions = 1000L)[[1]]
  } else {
    bounds <- do.call(getq(dist), c(list(p = c(0.000001, (1:9) / 10, 0.999999)), as.list(par)))
    sum(sapply(1:10, function(thisv) {
      integrate(f = function(x, ...) x * ordD(x, ...), lower = bounds[thisv],
                upper = bounds[thisv + 1], r = r, n = n, par = par,
                dist = dist, log = log, subdivisions = 1000L)[[1]]
    }))
  }
}

#' Expected probability of order statistics
#'
#' @title Order Statistic Expected Probabilities
#' @param probs Numeric vector of rank proportions.
#' @param n Sample size.
#' @param par Named vector of distribution parameters.
#' @param dist Character distribution name.
#' @return Numeric vector of probabilities.
#' @export
ordEp <- function(probs, n, par = c(mean = 0, sd = 1), dist = "normal") {
  r    <- n * probs
  names(r) <- probs
  pfun <- switch(dist,
    norm       = pnorm,
    normal     = pnorm,
    lnorm      = plnorm,
    lognormal  = plnorm,
    beta       = pbeta,
    gamma      = pgamma,
    exp        = pexp,
    exponential = pexp,
    weibull    = pweibull
  )
  newprobs <- sapply(r, function(x) {
    do.call(pfun, c(as.list(par), list(q = ordE(r = x, n = n, par = par, dist = dist))))
  })
  newprobs[(probs - newprobs) > 0.2] <- probs[(probs - newprobs) > 0.2]
  newprobs
}

# ---------------------------------------------------------------------------
# Fisher's ICC
# ---------------------------------------------------------------------------

#' Fisher's intraclass correlation coefficient
#'
#' @title Fisher's ICC
#' @description Computes Fisher's intraclass correlation coefficient between
#'   two numeric vectors or matrices.
#'
#' @param y Numeric vector, matrix, or data frame.
#' @param x Numeric vector, matrix, or data frame.
#' @param ... Currently unused.
#'
#' @return Numeric ICC value.
#' @export
fisher_icc <- function(y, x, ...) UseMethod("fisher_icc")

#' @rdname fisher_icc
#' @export
fisher_icc.data.frame <- function(y, x, ...) {
  apply(y, MARGIN = 2, FUN = fisher_icc, x, ...)
}

#' @rdname fisher_icc
#' @export
fisher_icc.matrix <- function(y, x, ...) fisher_icc(as.data.frame(y), x, ...)

#' @rdname fisher_icc
#' @export
fisher_icc.numeric <- function(y, x, ...) {
  if (!is.matrix(x) && is.numeric(x)) return(fisher_icc.two_numeric(y, x, ...))
  if (inherits(x, c("data.frame", "matrix")))
    return(apply(as.data.frame(x), MARGIN = 2, FUN = function(iter) fisher_icc(y, iter, ...)))
}

#' @exportS3Method
fisher_icc.two_numeric <- function(y, x, ...) {
  if (!is.numeric(y)) stop("y must be a numeric vector")
  if (!is.numeric(x)) stop("x must be a numeric vector")
  if (length(y) != length(x)) stop("y and x must have the same length")
  if (length(y) < 2) stop("y must be at least of length 2")
  if (all(y == x)) return(1)
  data    <- cbind(x, y)
  data    <- cbind(data, rowMeans(data))
  data    <- data[!is.na(data[, 3]), ]
  if (length(dim(data)) == 0) return(NA)
  x_avg   <- sum(data[, 1:2]) / (2 * nrow(data))
  data    <- cbind(data, (data[, 1:2] - x_avg)^2)
  s_sq    <- sum(data[, 4:5]) / (2 * (nrow(data) - 1))
  return(sum((data[, 1] - x_avg) * (data[, 2] - x_avg)) / ((nrow(data) - 1) * s_sq))
}

# ---------------------------------------------------------------------------
# Lin's concordance correlation coefficient
# ---------------------------------------------------------------------------

#' Lin's concordance correlation coefficient (simplified)
#'
#' @title Lin's CCC (simplified)
#' @param y Numeric vector, matrix, or data frame.
#' @param x Numeric vector, matrix, or data frame.
#' @param ... Passed to \code{\link{LCCC}}.
#' @return Numeric CCC value.
#' @export
just_CCC <- function(y, x, ...) UseMethod("just_CCC")

#' @rdname just_CCC
#' @export
just_CCC.data.frame <- function(y, x, ...) {
  apply(y, MARGIN = 2, FUN = just_CCC, x, ...)
}

#' @rdname just_CCC
#' @export
just_CCC.matrix <- function(y, x, ...) just_CCC(as.data.frame(y), x, ...)

#' @rdname just_CCC
#' @export
just_CCC.numeric <- function(y, x, ...) {
  if (!is.matrix(x) && is.numeric(x)) return(just_CCC.two_numeric(y, x, ...))
  if (inherits(x, c("data.frame", "matrix")))
    return(apply(as.data.frame(x), MARGIN = 2, FUN = function(iter) just_CCC(y, iter, ...)))
}

#' @exportS3Method
just_CCC.two_numeric <- function(y, x, ...) {
  if (!is.numeric(y)) stop("y must be a numeric vector")
  if (!is.numeric(x)) stop("x must be a numeric vector")
  if (length(y) != length(x)) stop("y and x must have the same length")
  if (length(y) < 2) return(NA)
  if (all(y == x)) return(1)
  LCCC(x, y, justp = TRUE, ...)
}

#' Lin's concordance correlation coefficient
#'
#' @title Lin's Concordance Correlation Coefficient
#' @description Calculates Lin's concordance correlation coefficient (CCC) for
#'   a pair of variables, measuring agreement along the 45-degree line.
#'
#' @param x Numeric vector; first variable.
#' @param y Numeric vector; second variable.
#' @param ci Character; method for confidence interval. Default
#'   \code{"z-transform"}.
#' @param conf.level Numeric; confidence level. Default \code{0.95}.
#' @param na.rm Logical; remove \code{NA} values. Default \code{FALSE}.
#' @param justp Logical; if \code{TRUE} return only the point estimate.
#'   Default \code{FALSE}.
#' @param ... Currently unused.
#'
#' @return A list with components \code{rho.c}, \code{s.shift},
#'   \code{l.shift}, \code{C.b}, and \code{blalt}.
#' @export
LCCC <- function(x, y, ci = "z-transform", conf.level = 0.95, na.rm = FALSE,
                 justp = FALSE, ...) {
  dat <- data.frame(x, y)
  dat <- if (na.rm) na.omit(dat) else dat
  N.  <- 1 - ((1 - conf.level) / 2)
  zv  <- qnorm(N.)
  k   <- length(dat$y)
  xb  <- mean(dat$x)
  yb  <- mean(dat$y)
  sx2 <- var(dat$x) * (k - 1) / k
  sy2 <- var(dat$y) * (k - 1) / k
  sd1 <- sd(dat$y)
  sd2 <- sd(dat$x)
  r   <- cor(dat$x, dat$y)
  sxy <- r * sqrt(sx2 * sy2)
  p   <- 2 * sxy / (sx2 + sy2 + (yb - xb)^2)
  if (justp) return(p)
  v   <- sd1 / sd2
  u   <- (yb - xb) / ((sx2 * sy2)^0.25)
  C.b <- p / r
  sep <- sqrt(((1 - r^2) * p^2 * (1 - p^2) / r^2 +
                 2 * p^3 * (1 - p) * u^2 / r -
                 0.5 * p^4 * u^4 / r^2) / (k - 2))
  ll  <- p - zv * sep
  ul  <- p + zv * sep
  t   <- log((1 + p) / (1 - p)) / 2
  set <- sep / (1 - p^2)
  llt <- t - zv * set
  ult <- t + zv * set
  llt <- (exp(2 * llt) - 1) / (exp(2 * llt) + 1)
  ult <- (exp(2 * ult) - 1) / (exp(2 * ult) + 1)
  rho.c <- data.frame(est    = p,
                      lwr.ci = ifelse(ci == "asymptotic", ll, llt),
                      upr.ci = ifelse(ci == "asymptotic", ul, ult))
  list(rho.c  = rho.c,
       s.shift = v,
       l.shift = u,
       C.b     = C.b,
       blalt   = data.frame(mean = rowMeans(dat), delta = dat$x - dat$y))
}

# ---------------------------------------------------------------------------
# Error metrics (S3 generics)
# ---------------------------------------------------------------------------

#' Average Relative Error
#'
#' @title Average Relative Error
#' @param est Numeric; estimates.
#' @param obs Numeric; observations.
#' @param absolute Logical; return absolute version. Default \code{FALSE}.
#' @param ... Currently unused.
#' @return Numeric ARE value.
#' @export
ARE <- function(est, obs, absolute = FALSE, ...) UseMethod("ARE")

#' @rdname ARE
#' @export
ARE.data.frame <- function(est, obs, absolute = FALSE, ...) {
  apply(est, MARGIN = 2, FUN = ARE, obs, absolute, ...)
}

#' @rdname ARE
#' @export
ARE.matrix <- function(est, obs, absolute = FALSE, ...) ARE(as.data.frame(est), obs, absolute, ...)

#' @rdname ARE
#' @export
ARE.numeric <- function(est, obs, absolute = FALSE, ...) {
  if (!is.matrix(obs) && is.numeric(obs)) return(ARE.two_numeric(est, obs, absolute, ...))
  if (inherits(obs, c("data.frame", "matrix")))
    return(apply(as.data.frame(obs), MARGIN = 2,
                 FUN = function(iter) ARE(est, iter, absolute, ...)))
}

#' @exportS3Method
ARE.two_numeric <- function(est, obs, absolute = FALSE, ...) {
  if (!is.numeric(est)) stop("est must be a numeric vector")
  if (!is.numeric(obs)) stop("obs must be a numeric vector")
  if (absolute) return(mean(abs(est - obs) / obs))
  return(mean((est - obs) / obs))
}

#' @rdname ARE
#' @param dfys Numeric matrix or data frame of estimates.
#' @param dfobs Numeric matrix or data frame of observations.
#' @export
ARE_conform <- function(dfys, dfobs, absolute = FALSE) {
  if (is.list(dfys)) return(sapply(dfys, function(dfest) ARE_conform(dfest, dfobs, absolute)))
  if (is.matrix(dfobs)) {
    if (is.null(colnames(dfobs)) && !is.null(rownames(dfobs))) {
      dfys  <- t(dfys)
      dfobs <- t(dfobs)
    }
  }
  dfest <- as.data.frame(dfys)
  dfobs <- as.data.frame(dfobs)
  nx    <- colnames(dfobs)
  colnames(dfest) <- nx
  names(nx) <- nx
  sapply(nx, function(thisn) ARE(dfest[, thisn], dfobs[, thisn], absolute))
}

#' Relative Mean Squared Error
#'
#' @title Relative Mean Squared Error
#' @param est Numeric; estimates.
#' @param obs Numeric; observations.
#' @param trueobs Numeric; true values.
#' @param ... Currently unused.
#' @return Numeric ReMSE value.
#' @export
ReMSE <- function(est, obs, trueobs, ...) UseMethod("ReMSE")

#' @rdname ReMSE
#' @export
ReMSE.data.frame <- function(est, obs, trueobs, ...) {
  apply(est, MARGIN = 2, FUN = ReMSE, obs, trueobs, ...)
}

#' @rdname ReMSE
#' @export
ReMSE.matrix <- function(est, obs, trueobs, ...) ReMSE(as.data.frame(est), obs, trueobs, ...)

#' @rdname ReMSE
#' @export
ReMSE.numeric <- function(est, obs, trueobs, ...) {
  if (!is.matrix(obs) && is.numeric(obs)) return(ReMSE.two_numeric(est, obs, trueobs, ...))
  if (inherits(obs, c("data.frame", "matrix")))
    return(apply(as.data.frame(obs), MARGIN = 2,
                 FUN = function(iter) ReMSE(est, iter, trueobs, ...)))
}

#' @exportS3Method
ReMSE.two_numeric <- function(est, obs, trueobs, ...) {
  if (!is.numeric(est))     stop("est must be a numeric vector")
  if (!is.numeric(obs))     stop("obs must be a numeric vector")
  if (!is.numeric(trueobs)) stop("trueobs must be a numeric vector")
  return(mean((est - trueobs)^2) / mean((obs - trueobs)^2))
}

#' @rdname ReMSE
#' @param dfys Numeric matrix or data frame of estimates.
#' @param dfobs Numeric matrix or data frame of observations.
#' @export
ReMSE_conform <- function(dfys, dfobs, trueobs) {
  if (is.list(dfys)) return(sapply(dfys, function(dfest) ReMSE_conform(dfest, dfobs, trueobs)))
  if (is.matrix(dfobs)) {
    if (is.null(colnames(dfobs)) && !is.null(rownames(dfobs))) {
      dfys  <- t(dfys)
      dfobs <- t(dfobs)
    }
  }
  dfest <- as.data.frame(dfys)
  dfobs <- as.data.frame(dfobs)
  nx    <- colnames(dfobs)
  colnames(dfest) <- nx
  names(nx) <- nx
  if (length(trueobs) == 1) trueobs <- rep(trueobs, length(nx))
  names(trueobs) <- nx
  trueobs <- as.list(trueobs)
  sapply(nx, function(thisn) ReMSE(dfest[, thisn], dfobs[, thisn], trueobs[[thisn]]))
}

#' Root Mean Square Error
#'
#' @title Root Mean Square Error
#' @param est Numeric; estimates.
#' @param obs Numeric; observations.
#' @param percentage Logical; return as percentage of mean. Default \code{FALSE}.
#' @param ... Passed to \code{mean} and \code{sqrt}.
#' @return Numeric RMSE value.
#' @export
RMSE <- function(est, obs, percentage = FALSE, ...) UseMethod("RMSE")

#' @rdname RMSE
#' @export
RMSE.data.frame <- function(est, obs, percentage = FALSE, ...) {
  apply(est, MARGIN = 2, FUN = RMSE, obs, percentage, ...)
}

#' @rdname RMSE
#' @export
RMSE.matrix <- function(est, obs, percentage = FALSE, ...) {
  RMSE(as.data.frame(est), obs, percentage, ...)
}

#' @rdname RMSE
#' @export
RMSE.numeric <- function(est, obs, percentage = FALSE, ...) {
  if (!is.matrix(obs) && is.numeric(obs)) return(RMSE.two_numeric(est, obs, percentage, ...))
  if (inherits(obs, c("data.frame", "matrix")))
    return(apply(as.data.frame(obs), MARGIN = 2,
                 FUN = function(iter) RMSE(est, iter, percentage, ...)))
}

#' @exportS3Method
RMSE.two_numeric <- function(est, obs, percentage = FALSE, ...) {
  if (!is.numeric(est)) stop("est must be a numeric vector")
  if (!is.numeric(obs)) stop("obs must be a numeric vector")
  if (percentage) {
    return(sqrt(mean((obs - est)^2), ...) / mean(obs, ...) * 100)
  } else {
    return(sqrt(mean((obs - est)^2, ...)))
  }
}

#' Percentage RMSE
#' @param est Numeric; estimates.
#' @param obs Numeric; observations.
#' @param ... Passed to \code{\link{RMSE}}.
#' @rdname RMSE
#' @export
pRMSE <- function(est, obs, ...) RMSE(est, obs, percentage = TRUE, ...)

#' @rdname RMSE
#' @export
rRMSE <- function(est, obs, ...) RMSE(est, obs, percentage = TRUE, ...)

#' Mean Absolute Error
#'
#' @title Mean Absolute Error
#' @param est Numeric; estimates.
#' @param obs Numeric; observations.
#' @param ... Passed to \code{mean}.
#' @return Numeric MAE value.
#' @export
MAE <- function(est, obs, ...) UseMethod("MAE")

#' @rdname MAE
#' @export
MAE.data.frame <- function(est, obs, ...) {
  apply(est, MARGIN = 2, FUN = MAE, obs, ...)
}

#' @rdname MAE
#' @export
MAE.matrix <- function(est, obs, ...) MAE(as.data.frame(est), obs, ...)

#' @rdname MAE
#' @export
MAE.numeric <- function(est, obs, ...) {
  if (!is.matrix(obs) && is.numeric(obs)) return(MAE.two_numeric(est, obs, ...))
  if (inherits(obs, c("data.frame", "matrix")))
    return(apply(as.data.frame(obs), MARGIN = 2,
                 FUN = function(iter) MAE(est, iter, ...)))
}

#' @exportS3Method
MAE.two_numeric <- function(est, obs, ...) {
  if (!is.numeric(est)) stop("est must be a numeric vector")
  if (!is.numeric(obs)) stop("obs must be a numeric vector")
  return(mean(abs(obs - est), ...))
}

#' Mean Absolute Relative Error / Mean Absolute Percentage Error
#'
#' @title Mean Absolute Relative Error (MARE / MAPE)
#' @param est Numeric; estimates.
#' @param obs Numeric; observations.
#' @param ... Currently unused.
#' @return Numeric MARE value.
#' @export
MAPE <- function(est, obs, ...) UseMethod("MARE")

#' @rdname MAPE
#' @export
MARE <- function(est, obs, ...) UseMethod("MARE")

#' @rdname MAPE
#' @export
MARE.data.frame <- function(est, obs, ...) {
  apply(est, MARGIN = 2, FUN = MARE, obs, ...)
}

#' @rdname MAPE
#' @export
MARE.matrix <- function(est, obs, ...) MARE(as.data.frame(est), obs, ...)

#' @rdname MAPE
#' @export
MARE.numeric <- function(est, obs, ...) {
  if (!is.matrix(obs) && is.numeric(obs)) return(MARE.two_numeric(est, obs, ...))
  if (inherits(obs, c("data.frame", "matrix")))
    return(apply(as.data.frame(obs), MARGIN = 2,
                 FUN = function(iter) MARE(est, iter, ...)))
}

#' @exportS3Method
MARE.two_numeric <- function(est, obs, ...) {
  if (!is.numeric(est)) stop("est must be a numeric vector")
  if (!is.numeric(obs)) stop("obs must be a numeric vector")
  return(mean(abs((obs - est) / obs), ...))
}

#' Uncertainty at 95 Percent
#'
#' @title Uncertainty at 95 Percent
#' @param est Numeric; estimates.
#' @param obs Numeric; observations.
#' @param ... Passed to \code{var} and \code{sqrt}.
#' @return Numeric U95 value.
#' @export
U95 <- function(est, obs, ...) UseMethod("U95")

#' @rdname U95
#' @export
U95.data.frame <- function(est, obs, ...) {
  apply(est, MARGIN = 2, FUN = U95, obs, ...)
}

#' @rdname U95
#' @export
U95.matrix <- function(est, obs, ...) U95(as.data.frame(est), obs, ...)

#' @rdname U95
#' @export
U95.numeric <- function(est, obs, ...) {
  if (!is.matrix(obs) && is.numeric(obs)) return(U95.two_numeric(est, obs, ...))
  if (inherits(obs, c("data.frame", "matrix")))
    return(apply(as.data.frame(obs), MARGIN = 2,
                 FUN = function(iter) U95(est, iter, ...)))
}

#' @exportS3Method
U95.two_numeric <- function(est, obs, ...) {
  if (!is.numeric(est)) stop("est must be a numeric vector")
  if (!is.numeric(obs)) stop("obs must be a numeric vector")
  return(1.96 * sqrt(var(obs - est, ...) + RMSE(est, obs, ...)^2, ...))
}

#' Root Mean Square Relative Error
#'
#' @title Root Mean Square Relative Error
#' @param est Numeric; estimates.
#' @param obs Numeric; observations.
#' @param ... Currently unused.
#' @return Numeric RMSRE value.
#' @export
RMSRE <- function(est, obs, ...) UseMethod("RMSRE")

#' @rdname RMSRE
#' @export
RMSRE.data.frame <- function(est, obs, ...) {
  apply(est, MARGIN = 2, FUN = RMSRE, obs, ...)
}

#' @rdname RMSRE
#' @export
RMSRE.matrix <- function(est, obs, ...) RMSRE(as.data.frame(est), obs, ...)

#' @rdname RMSRE
#' @export
RMSRE.numeric <- function(est, obs, ...) {
  if (!is.matrix(obs) && is.numeric(obs)) return(RMSRE.two_numeric(est, obs, ...))
  if (inherits(obs, c("data.frame", "matrix")))
    return(apply(as.data.frame(obs), MARGIN = 2,
                 FUN = function(iter) RMSRE(est, iter, ...)))
}

#' @exportS3Method
RMSRE.two_numeric <- function(est, obs, ...) {
  if (!is.numeric(est)) stop("est must be a numeric vector")
  if (!is.numeric(obs)) stop("obs must be a numeric vector")
  return(sqrt(mean(((obs - est) / obs)^2, ...), ...))
}

#' Mean Bias Error
#'
#' @title Mean Bias Error
#' @param est Numeric; estimates.
#' @param obs Numeric; observations.
#' @param ... Passed to \code{mean}.
#' @return Numeric MBE value.
#' @export
MBE <- function(est, obs, ...) UseMethod("MBE")

#' @rdname MBE
#' @export
MBE.data.frame <- function(est, obs, ...) {
  apply(est, MARGIN = 2, FUN = MBE, obs, ...)
}

#' @rdname MBE
#' @export
MBE.matrix <- function(est, obs, ...) MBE(as.data.frame(est), obs, ...)

#' @rdname MBE
#' @export
MBE.numeric <- function(est, obs, ...) {
  if (!is.matrix(obs) && is.numeric(obs)) return(MBE.two_numeric(est, obs, ...))
  if (inherits(obs, c("data.frame", "matrix")))
    return(apply(as.data.frame(obs), MARGIN = 2,
                 FUN = function(iter) MBE(est, iter, ...)))
}

#' @exportS3Method
MBE.two_numeric <- function(est, obs, ...) {
  if (!is.numeric(est)) stop("est must be a numeric vector")
  if (!is.numeric(obs)) stop("obs must be a numeric vector")
  return(mean(obs - est, ...))
}

#' Maximum Absolute Relative Error
#'
#' @title Maximum Absolute Relative Error
#' @param est Numeric; estimates.
#' @param obs Numeric; observations.
#' @param ... Currently unused.
#' @return Numeric erMAX value.
#' @export
erMAX <- function(est, obs, ...) UseMethod("erMAX")

#' @rdname erMAX
#' @export
erMAX.data.frame <- function(est, obs, ...) {
  apply(est, MARGIN = 2, FUN = erMAX, obs, ...)
}

#' @rdname erMAX
#' @export
erMAX.matrix <- function(est, obs, ...) erMAX(as.data.frame(est), obs, ...)

#' @rdname erMAX
#' @export
erMAX.numeric <- function(est, obs, ...) {
  if (!is.matrix(obs) && is.numeric(obs)) return(erMAX.two_numeric(est, obs, ...))
  if (inherits(obs, c("data.frame", "matrix")))
    return(apply(as.data.frame(obs), MARGIN = 2,
                 FUN = function(iter) erMAX(est, iter, ...)))
}

#' @exportS3Method
erMAX.two_numeric <- function(est, obs, ...) {
  if (!is.numeric(est)) stop("est must be a numeric vector")
  if (!is.numeric(obs)) stop("obs must be a numeric vector")
  return(max(abs((obs - est) / obs, ...), ...))
}

#' t-statistic for model comparison
#'
#' @title t-Statistic
#' @param est Numeric; estimates.
#' @param obs Numeric; observations.
#' @param ... Currently unused.
#' @return Numeric t-statistic.
#' @export
tstat <- function(est, obs, ...) UseMethod("tstat")

#' @rdname tstat
#' @export
tstat.data.frame <- function(est, obs, ...) {
  apply(est, MARGIN = 2, FUN = tstat, obs, ...)
}

#' @rdname tstat
#' @export
tstat.matrix <- function(est, obs, ...) tstat(as.data.frame(est), obs, ...)

#' @rdname tstat
#' @export
tstat.numeric <- function(est, obs, ...) {
  if (!is.matrix(obs) && is.numeric(obs)) return(tstat.two_numeric(est, obs, ...))
  if (inherits(obs, c("data.frame", "matrix")))
    return(apply(as.data.frame(obs), MARGIN = 2,
                 FUN = function(iter) tstat(est, iter, ...)))
}

#' @exportS3Method
tstat.two_numeric <- function(est, obs, ...) {
  if (!is.numeric(est)) stop("est must be a numeric vector")
  if (!is.numeric(obs)) stop("obs must be a numeric vector")
  thisMBEs <- MBE(est, obs, ...)^2
  return(sqrt(((sum(!is.na(obs)) - 1) * thisMBEs) / (RMSE(est, obs, ...)^2 - thisMBEs)))
}

#' Comparison table of error metrics
#'
#' @title Comparison Table
#' @description Computes multiple error metrics and returns them as a matrix.
#'
#' @param est Numeric vector or matrix of estimates.
#' @param obs Numeric vector of observations.
#' @param ... Passed to metric functions.
#'
#' @return A numeric matrix with one row per metric.
#' @export
comp_table <- function(est, obs, ...) {
  rbind("Pearson's R" = cor(est, obs, ...)[, ],
        ICC    = fisher_icc(est, obs, ...),
        CCC    = just_CCC(est, obs, ...),
        MAE    = MAE(est, obs, ...),
        RMSE   = RMSE(est, obs, ...),
        MARE   = MARE(est, obs, ...),
        U95    = U95(est, obs, ...),
        RMSRE  = RMSRE(est, obs, ...),
        rRMSE  = rRMSE(est, obs, ...),
        erMAX  = erMAX(est, obs, ...),
        MBE    = MBE(est, obs, ...),
        tstat  = tstat(est, obs, ...))
}

#' Two-sample t-test from summary statistics
#'
#' @title Two-Sample t-Test from Summary Statistics
#' @param m1 Numeric; mean of sample 1.
#' @param m2 Numeric; mean of sample 2.
#' @param s1 Numeric; SD of sample 1.
#' @param s2 Numeric; SD of sample 2.
#' @param n1 Numeric; size of sample 1.
#' @param n2 Numeric; size of sample 2.
#' @param m0 Numeric; null difference. Default \code{0}.
#' @param equal.variance Logical; assume equal variances. Default \code{FALSE}.
#' @return Named numeric vector with test statistics and confidence interval.
#' @export
t_test2 <- function(m1, m2, s1, s2, n1, n2, m0 = 0, equal.variance = FALSE) {
  if (!equal.variance) {
    se <- sqrt((s1^2 / n1) + (s2^2 / n2))
    df <- ((s1^2 / n1 + s2^2 / n2)^2) / ((s1^2 / n1)^2 / (n1 - 1) + (s2^2 / n2)^2 / (n2 - 1))
  } else {
    se <- sqrt((1 / n1 + 1 / n2) * ((n1 - 1) * s1^2 + (n2 - 1) * s2^2) / (n1 + n2 - 2))
    df <- n1 + n2 - 2
  }
  t   <- (m1 - m2 - m0) / se
  md  <- m1 - m2
  dat <- c(md, se, t, 2 * pt(-abs(t), df), md + se * qnorm(c(0.025, 0.975)))
  names(dat) <- c("Difference of means", "Std Error", "t", "p-value", "95% LB", "95% UB")
  return(dat)
}

#' Combined mean of two groups
#' @param m1 Mean of group 1 (scalar or vector).
#' @param m2 Mean of group 2 (scalar or vector).
#' @param n1 Size of group 1.
#' @param n2 Size of group 2.
#' @param na.rm Logical.
#' @return Combined mean.
#' @export
combmean <- function(m1, m2, n1 = NULL, n2 = NULL, na.rm = FALSE) {
  if (any(is.na(m1))) { n1 <- n1[!is.na(m1)]; m1 <- m1[!is.na(m1)] }
  if (any(is.na(m2))) { n2 <- n2[!is.na(m2)]; m2 <- m2[!is.na(m2)] }
  if (length(m1) > 1 || length(m2) > 1)
    return(combmean(mean(m1, na.rm = na.rm), mean(m2, na.rm = na.rm),
                    length(m1), length(m2)))
  sum(n1 * m1, n2 * m2, na.rm = na.rm) / sum(n1, n2, na.rm = na.rm)
}

#' Combined standard deviation of two groups
#' @param m1 Mean of group 1.
#' @param m2 Mean of group 2.
#' @param s1 SD of group 1.
#' @param s2 SD of group 2.
#' @param n1 Size of group 1.
#' @param n2 Size of group 2.
#' @param na.rm Logical.
#' @return Combined SD.
#' @export
combsd <- function(m1, m2, s1, s2, n1, n2, na.rm = FALSE) {
  df1 <- data.frame(m = m1, s = s1, n = n1)
  df2 <- data.frame(m = m2, s = s2, n = n2)
  if (na.rm) { df1 <- df1[complete.cases(df1), ]; df2 <- df2[complete.cases(df2), ] }
  df <- rbind(df1, df2)
  if (NROW(df) == 1) {
    df$s
  } else {
    m12 <- combmean(m1, m2, n1, n2, na.rm = na.rm)
    d1  <- sum(m1, -m12, na.rm = na.rm)
    d2  <- sum(m2, -m12, na.rm = na.rm)
    sqrt((n1 * (s1^2 + d1^2) + n2 * (s2^2 + d2^2)) / (n1 + n2))
  }
}

#' Combined mean of multiple groups
#' @param ms Numeric vector of group means.
#' @param ns Numeric vector of group sizes.
#' @param na.rm Logical.
#' @return Combined mean.
#' @export
combmeans <- function(ms, ns, na.rm = FALSE) {
  cm <- 0
  cn <- 0
  for (i in seq_along(ms)) {
    cm <- combmean(cm, ms[i], cn, ns[i], na.rm = na.rm)
    cn <- cn + ns[i]
  }
  return(cm)
}

#' Combined SD of multiple groups
#' @param ms Numeric vector of group means.
#' @param ss Numeric vector of group SDs.
#' @param ns Numeric vector of group sizes.
#' @param na.rm Logical.
#' @return Combined SD.
#' @export
combsds <- function(ms, ss, ns, na.rm = FALSE) {
  cm <- 0
  cs <- 0
  cn <- 0
  for (i in seq_along(ms)) {
    cs <- combsd(cm, ms[i], cs, ss[i], cn, ns[i], na.rm = na.rm)
    cm <- combmean(cm, ms[i], cn, ns[i])
    cn <- cn + ns[i]
  }
  return(cs)
}

#' Combined mean, SD and n for multiple groups
#' @param ms Numeric vector of group means.
#' @param ss Numeric vector of group SDs.
#' @param ns Numeric vector of group sizes.
#' @param na.rm Logical.
#' @return Matrix with columns n, mean, sd.
#' @export
combmssds <- function(ms, ss, ns, na.rm = FALSE) {
  cm <- 0
  cs <- 0
  cn <- 0
  for (i in seq_along(ms)) {
    if (na.rm) {
      if (!any(is.na(c(ms[i], ss[i], ns[i])))) {
        cs <- combsd(cm, ms[i], cs, ss[i], cn, ns[i], na.rm = na.rm)
        cm <- combmean(cm, ms[i], cn, ns[i], na.rm = na.rm)
        cn <- sum(cn, ns[i], na.rm = na.rm)
      }
    } else {
      cs <- combsd(cm, ms[i], cs, ss[i], cn, ns[i], na.rm = na.rm)
      cm <- combmean(cm, ms[i], cn, ns[i], na.rm = na.rm)
      cn <- sum(cn, ns[i], na.rm = na.rm)
    }
  }
  return(cbind(n = cn, mean = cm, sd = cs))
}
