R/Auxiliary.R

In eFCM: Exponential Factor Copula Model

#'
#' Auxiliary functions to compute log copula function for partially censored data
#'
#' @noMd
#' @noRd
#'
#' @importFrom fields rdist.earth
#' @srrstats {G1.4}
#'
Mnu <- function(arg, nu) {
  abs(arg)^nu * besselK(arg, nu)
}
#' @noMd
#' @noRd
#' @srrstats {G1.4}
#' @srrstats {G3.0} *Statistical software should never compare floating point numbers for equality. All numeric equality comparisons should either ensure that they are made between integers, or use appropriate tolerances for approximate equality.*
rM.st <- function(locs, rho1, rho2, nu) {
  s <- locs[1, ]
  t <- locs[2, ]

  if (isTRUE(all.equal(s, t, tolerance = .Machine$double.eps^0.5))) {
    return(1)
  }

  tmp <- rep(NA, 3)
  d <- rdist.earth(locs, miles = F)[1, 2]
  if (any(d < 0)) {
    stop("distance argument must be nonnegative")
  }
  d[d == 0] <- 1e-10
  d <- d / (2 * sqrt(nu))
  con <- (2^(nu - 2)) * gamma(nu)
  tmp[1] <- 1 / con
  den <- rho1^2 + rho2^2
  tmp[2] <- (rho1 * rho2) / den
  arg <- (2 * sqrt(2 * nu) * d) / sqrt(den)
  tmp[3] <- Mnu(arg, nu)
  return(prod(tmp))
}
#'
#' @noMd
#' @noRd
#' @srrstats {G1.4}
tidy <- function(neigh) {
  emp <- which(sapply(neigh, function(x) is.null(x)))
  emp1 <- which(sapply(neigh, function(x) length(x) == 1))
  emp <- c(emp, emp1)
  return(emp)
}
#' @noMd
#' @noRd
#' @srrstats {G1.4}
L1 <- function(w, lambda) {
  -sum(log(sapply(w, function(x) dfcm(x, lambda))), na.rm = T)
}