R/Utilities.R

In haziqj/diagacc: Modelling Diagnostic Accuracy using Latent Class Models

read_diagacc_opt <- function(env) {
  sens <- getOption("diagacc.sens")
  spec <- getOption("diagacc.spec")
  item.names <- getOption("diagacc.item.names")
  p <- getOption("diagacc.pwg")

  list2env(list(sens = sens, spec = spec, item.names = item.names, p = p),
           env)
}

is.try_error <- function(x) inherits(x, "try-error")

is.diagaccSim1 <- function(x) inherits(x, "diagaccSim1")

is.diagaccSim2 <- function(x) inherits(x, "diagaccSim2")

is.diagaccLC <- function(x) !is.null(x$diagaccmod) & (x$diagaccmod == "LC")

is.diagaccLCRE <- function(x) !is.null(x$diagaccmod) & (x$diagaccmod == "LCRE")

is.diagaccFM <- function(x) !is.null(x$diagaccmod) & (x$diagaccmod == "FM")

extract_B <- function(x) {
  if (is.diagaccSim1(x)) return(x$sim.settings$B)
  if (is.diagaccSim2(x)) return(x$study.settings$B)
}

extract_n <- function(x) {
  if (is.diagaccSim1(x)) return(x$sim.settings$n)
  if (is.diagaccSim2(x)) return(x$study.settings$n)
}

extract_tau <- function(x) {
  if (is.diagaccSim1(x)) return(x$sim.settings$tau)
  if (is.diagaccSim2(x)) return(x$study.settings$tau)
}

extract_miss.prop <- function(x) {
  if (is.diagaccSim1(x)) return(x$sim.settings$miss.prop)
  if (is.diagaccSim2(x)) return(x$study.settings$miss.prop)
}

extract_data.gen <- function(x) {
  if (is.diagaccSim1(x)) return(x$sim.settings$data.gen)
  if (is.diagaccSim2(x)) return(x$study.settings$data.gen)
}

extract_sim.msg <- function(x) {
  if (is.diagaccSim1(x)) return(x$sim.settings$sim.msg)
  if (is.diagaccSim2(x)) return(x$study.settings$sim.msg)
}

extract_lc.method <- function(x) {
  if (is.diagaccSim1(x)) return(x$sim.settings$lc.method)
  if (is.diagaccSim2(x)) return(x$study.settings$lc.method)
}

extract_lcre.method <- function(x) {
  if (is.diagaccSim1(x)) return(x$sim.settings$lcre.method)
  if (is.diagaccSim2(x)) return(x$study.settings$lcre.method)
}

true_vals <- function(x) {
  p <- getOption("diagacc.p")
  sens <- getOption("diagacc.sens")[1:p]
  spec <- getOption("diagacc.spec")[1:p]
  tau <- extract_tau(x)
  c(tau, sens, spec)
}

true_vals_with_gs <- function(x) {
  sens <- getOption("diagacc.sens")
  spec <- getOption("diagacc.spec")
  tau <- extract_tau(x)
  c(tau, sens, spec)
}

which_class_diseased <- function(x) {
  # Helper function for the randomLCA method to determine which class is
  # diseased. Compares the probabilities P[X = 1 | row1] vs P[X = 1 | row2] and
  # determines that if the probabilities are larger in row1 then row2 is the
  # diseased class, and vice versa. The logic is that the larger probabilities
  # should imply the sensitivities of the tests, which should be high.
  #
  # Args: x is a (2 by no. of items) matrix. Each row is the probabilities P[X =
  # 1 | delta]. This is obtained from the fit of randomLCA.
  #
  # Returns: Numeric. The row number for the diseased class (1 or 2).
  tmp <- apply(x, 2, function(y) which(y == max(y)))
  as.numeric(names(sort(table(tmp)))[1])
}