R/addhook.R

In lava: Latent Variable Models

##' Set global options for \code{lava}
##'
##' Extract and set global parameters of \code{lava}. In particular optimization
##' parameters for the \code{estimate} function.
##'
##' \itemize{
##'   \item \code{param}: 'relative' (factor loading and variance of one
##' endogenous variables in each measurement model are fixed to one), 'absolute'
##' (mean and variance of latent variables are set to 0 and 1, respectively),
##' 'hybrid' (intercept of latent variables is fixed to 0, and factor loading of
##' at least one endogenous variable in each measurement model is fixed to 1),
##' 'none' (no constraints are added)
##'   \item \code{layout}: One of 'dot','fdp','circo','twopi','neato','osage'
##'   \item \code{messages}: Set to 0 to disable various output messages
##'   \item ...  }
##'
##' see \code{control} parameter of the \code{estimate} function.
##'
##' @param \dots Arguments
##' @return \code{list} of parameters
##' @author Klaus K. Holst
##' @keywords models
##' @examples
##'
##' \dontrun{
##' lava.options(iter.max=100,messages=0)
##' }
##'
##' @export
lava.options <- function(...) {
    dots <- list(...)
    newopt <- curopt <- get("options",envir=lava.env)
    if (length(dots)==0)
        return(curopt[order(names(curopt))])
    if (length(dots)==1 && is.list(dots[[1]]) && is.null(names(dots))) {
        dots <- dots[[1]]
    }
    idx <- which(names(dots)!="")
    newopt[names(dots)[idx]] <- dots[idx]
    assign("options",newopt,envir=lava.env)
    invisible(curopt)
}

##' @export
gethook <- function(hook="estimate.hooks",...) {
    get(hook,envir=lava.env)
}

char2num <- function(x,...) {
    idx <- grep("^[-]*[0-9\\.]+",x,perl=TRUE,invert=TRUE)
    if (length(idx)>0) x[idx] <- NA
    as.numeric(x)
}

##' @export
addhook <- function(x,hook="estimate.hooks",...) {
    newhooks <- unique(c(gethook(hook),x))
    assign(hook,newhooks,envir=lava.env)
    invisible(newhooks)
}

packagecheck <- function(pkg) {
  nzchar(system.file(package=pkg))
}

versioncheck <- function(pkg="lava",geq,sep=".",...) {
  if (!is.character(pkg)) return(FALSE)
  if (packagecheck(pkg)) {
    xyz <- char2num(strsplit(as.character(utils::packageVersion(pkg)),
                             split=sep,fixed=TRUE)[[1]])
  } else {
    return(FALSE)
  }
  if (missing(geq)) return(xyz)
  for (i in seq(min(length(xyz),length(geq)))) {
    if (xyz[i]>geq[i]) return(TRUE)
    if (xyz[i]<geq[i]) return(FALSE)
  }
  if (length(xyz)>=length(geq)) return(TRUE)
  return(FALSE)
}

lava.env <- new.env()
assign("init.hooks",c(),envir=lava.env)
assign("remove.hooks",c(),envir=lava.env)
assign("estimate.hooks",c(),envir=lava.env)
assign("color.hooks",c(),envir=lava.env)
assign("sim.hooks",c(),envir=lava.env)
assign("post.hooks",c(),envir=lava.env)
assign("print.hooks",c(),envir=lava.env)
assign("plot.post.hooks",c(),envir=lava.env)
assign("plot.hooks",c(),envir=lava.env)
assign("options", list(
                      trace=0,
                      tol=1e-6,
                      gamma=1,
                      backtrack="wolfe",
                      ngamma=0,
                      iter.max=300,
                      eval.max=250,
                      constrain=FALSE,
                      allow.negative.variance=FALSE,
                      progressbarstyle=3,
                      itol=1e-16,
                      cluster.index=packagecheck("mets"),
                      Dmethod="simple",
                      messages=ifelse(interactive(), 1, 0),
                      parallel=TRUE,
                      param="relative",
                      sparse=FALSE,
                      test=TRUE,
                      coef.names=FALSE,
                      constrain=TRUE,
                      graph.proc="beautify",
                      regex=FALSE,
                      min.weight=1e-3,
                      exogenous=TRUE,
                      plot.engine="Rgraphviz",
                      node.color=c(exogenous="lightblue",endogenous="orange",
                                   latent="yellowgreen",transform="lightgray"),
                      edgecolor=FALSE,
                      layout="dot",
                      ## symbols=c("<-","<->"),
                      symbols=c("~","~~"),
                      devel=FALSE,
                      debug=FALSE), envir=lava.env)