R/fn.check.R

In AdMit: Adaptive Mixture of Student-t Distributions

## Functions which validate the arguments of the exported functions
## __20260819__

## Function which checks that a value is a single finite whole number
## __input__
## N    : [scalar] value to check
## name : [character] name of the argument, used in the error message
## __output__
## [integer] the value, invisibly
'fn.checkN' <- function(N, name)
  {
    if (!is.numeric(N) | length(N)!=1)
      stop ("'", name, "' must be a single number")
    if (!is.finite(N))
      stop ("'", name, "' must be finite")
    if (N!=round(N))
      stop ("'", name, "' must be a whole number")
    if (N>.Machine$integer.max) ## '.C' would receive NA after coercion
      stop ("'", name, "' must not exceed ", .Machine$integer.max)
    invisible(as.integer(N))
  }

## Function which checks the value returned by 'KERNEL'
## __input__
## lnk  : [vector] value returned by the kernel function
## n    : [integer] number of points at which it was evaluated
## name : [character] name of the argument, used in the error message
## __output__
## [vector] the kernel values, invisibly
'fn.checkkernel' <- function(lnk, n, name="KERNEL")
  {
    if (!is.numeric(lnk))
      stop ("'", name, "' must return a numeric vector")
    if (length(lnk)!=n) ## a non-vectorized kernel would otherwise be recycled
      stop ("'", name, "' must return one value per point: got ", length(lnk),
            " instead of ", n, ". Is '", name, "' vectorized?")
    if (any(is.na(lnk))) ## '-Inf' is a legitimate zero density, 'NA'/'NaN' is not
      stop ("'", name, "' returned NA or NaN values")
    invisible(as.vector(lnk))
  }

## Function which checks the mixture information and substitutes the default
## __input__
## mit  : [list] containing mixture information
## name : [character] name of the argument, used in the messages
## __output__
## [list] the mixture, with 'df' expanded to one value per component
'fn.checkmit' <- function(mit, name="mit")
  {
    if (!is.list(mit))
      stop ("'", name, "' must be a list")

    if (length(mit$p)==0)
      { ## default for the mixture
        warning ("'", name, "' not well defined; set to default")
        return (list(p=1, mu=as.matrix(0), Sigma=as.matrix(1), df=1))
      }

    H <- length(mit$p)
    if (!is.numeric(mit$p) | any(!is.finite(mit$p)) | any(mit$p<0))
      stop ("'", name, "$p' must be finite and non-negative")
    if (sum(mit$p)<=0)
      stop ("'", name, "$p' must have a positive sum")
    if (!is.matrix(mit$mu) | nrow(as.matrix(mit$mu))!=H)
      stop ("'", name, "$mu' must be a matrix with one row per mixture component")
    if (!is.matrix(mit$Sigma) | nrow(as.matrix(mit$Sigma))!=H)
      stop ("'", name, "$Sigma' must be a matrix with one row per mixture component")
    if (!is.numeric(mit$mu) | any(!is.finite(mit$mu)))
      stop ("'", name, "$mu' must be finite and numeric")
    if (!is.numeric(mit$Sigma) | any(!is.finite(mit$Sigma)))
      stop ("'", name, "$Sigma' must be finite and numeric")

    k <- ncol(mit$mu)
    if (ncol(mit$Sigma)!=k*k)
      stop ("'", name, "$Sigma' must have ncol('", name, "$mu')^2 = ", k*k, " columns")
    if (length(mit$df)!=1 & length(mit$df)!=H)
      stop ("'", name, "$df' must be of length 1 or ", H)
    if (!is.numeric(mit$df) | any(!is.finite(mit$df)) | any(mit$df<=0))
      stop ("'", name, "$df' must be finite and positive")

    for (h in 1:H)
      { ## each scale matrix must define a proper Student-t component
        S <- matrix(mit$Sigma[h,], k, k)
        if (!isSymmetric(S))
          stop ("'", name, "$Sigma' is not symmetric for component ", h)
        if (inherits(try(chol(S), silent=TRUE), "try-error"))
          stop ("'", name, "$Sigma' is not positive definite for component ", h)
      }

    ## 'dMit' uses the probabilities as they are while 'rMit' normalises them
    ## through 'sample'; make the two describe the same mixture
    if (abs(sum(mit$p)-1)>sqrt(.Machine$double.eps))
      {
        warning ("'", name, "$p' does not sum to one; normalised")
        mit$p <- mit$p/sum(mit$p)
      }

    ## df can be a double or a vector, replicated in the former case
    if (length(mit$df)==1 & H>1)
      mit$df <- rep(mit$df, H)

    mit
  }