R/misc.R

In sambrilleman/simjm: Simulate Joint Longitudinal and Survival Data

# Copyright (C) 2017,2018 Sam Brilleman

# Error message with call. set to FALSE
stop2 <- function(...) {
  stop(..., call. = FALSE)
}

# Check if x is a numeric scalar
is.scalar <- function(x) {
  length(x) == 1L && is.vector(x) && is.numeric(x)
}

# Check x is a valid correlation matrix
validate_corr_matrix <- function(x) {
  if (is.null(x) || !is.matrix(x))
    stop2("'b_rho' should be a scalar or a correlation matrix.")
  if (!all(diag(x) == 1) ||
      !all(abs(x)  <= 1) ||
      !all(x[lower.tri(x)] == t(x)[lower.tri(x)]))
    stop2("'b_rho' should be a scalar or a correlation matrix.")
  as.matrix(x)
}

#------------------------------
# Below are code chunks taken from the 'rstanarm' R package, obtained
# under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 3 of the License, or
# (at your option) any later version.
#
# Copyright (C) 2017 Trustees of Columbia University

# Draw from inverse Gaussian distribution
.rinvGauss <- function(n, mu, lambda) {
  mu2 <- mu^2
  y <- stats::rnorm(n)^2
  z <- stats::runif(n)
  tmp <- (mu2 * y - mu * sqrt(4 * mu * lambda * y + mu2 * y^2))
  x <- mu + tmp / (2 * lambda)
  ifelse(z <= (mu / (mu + x)), x, mu2 / x)
}

# Maybe broadcast
#
# @param x A vector or scalar.
# @param n Number of replications to possibly make.
# @return If \code{x} has no length the \code{0} replicated \code{n} times is
#   returned. If \code{x} has length 1, the \code{x} replicated \code{n} times
#   is returned. Otherwise \code{x} itself is returned.
maybe_broadcast <- function(x, n) {
  if (!length(x)) {
    rep(0, times = n)
  } else if (length(x) == 1L) {
    rep(x, times = n)
  } else {
    x
  }
}

# Check family argument
#
# @param f The \code{family} argument specified by user (or the default).
# @return If no error is thrown, then either \code{f} itself is returned (if
#   already a family) or the family object created from \code{f} is returned (if
#   \code{f} is a string or function).
validate_family <- function(f) {
  if (is.character(f))
    f <- get(f, mode = "function", envir = parent.frame(2))
  if (is.function(f))
    f <- f()
  if (!is(f, "family"))
    stop("'family' must be a family.", call. = FALSE)

  return(f)
}

# Create a named list using specified names or, if names are omitted, using the
# names of the objects in the list
#
# @param ... Objects to include in the list.
# @return A named list.
nlist <- function(...) {
  m <- match.call()
  out <- list(...)
  no_names <- is.null(names(out))
  has_name <- if (no_names) FALSE else nzchar(names(out))
  if (all(has_name))
    return(out)
  nms <- as.character(m)[-1L]
  if (no_names) {
    names(out) <- nms
  } else {
    names(out)[!has_name] <- nms[!has_name]
  }

  return(out)
}