Nothing
#
# Copyright 2007-2021 by the individuals mentioned in the source code history
#
# Licensed under the Apache License, Version 2.0 (the "License");
# you may not use this file except in compliance with the License.
# You may obtain a copy of the License at
#
# http://www.apache.org/licenses/LICENSE-2.0
#
# Unless required by applicable law or agreed to in writing, software
# distributed under the License is distributed on an "AS IS" BASIS,
# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
# See the License for the specific language governing permissions and
# limitations under the License.
mxOption <- function(model=NULL, key=NULL, value, reset = FALSE) {
if (!reset && (length(key) != 1 || !is.character(key))) {
stop("argument 'key' must be a character string")
}
if (!missing(model) && !is.null(model) && !is(model, "MxModel")) {
stop(paste("The first argument to mxOption must",
"be an MxModel, not", omxQuotes(class(model))))
}
if (is.null(model) && reset) {
return(invisible(mxSetDefaultOptions()))
}
optionsNames <- names(getOption('mxOptions'))
match <- grep(paste("^", key, "$", sep = ""), optionsNames,
ignore.case=TRUE)
if(length(match) == 0) {
stop(paste("argument 'key' is the character string",
omxQuotes(key), "and cannot be found in",
"getOption('mxOptions')"))
}
key <- optionsNames[[match]] # repair capitalization
if (missing(value)) {
if (length(model) && !is.null(model@options[[key]])) {
return(model@options[[key]])
}
return(processDefaultOptionList(key, value))
}
if (length(value) > 1 && key!="No Sort Data" && key != "Status OK") {
msg <- paste("argument 'value' must be either NULL or of length 1.",
"You gave me an object of length", length(value))
stop(msg)
}
if (length(reset) != 1 || !is.logical(reset)) {
stop("argument 'reset' must be TRUE or FALSE")
}
if (key == "Major iterations" && typeof(value) == "closure") {
args <- formals(value)
if (length(args) != 2) {
msg <- paste("The function provided to the option 'Major iterations'",
"must have exactly 2 arguments but you have provided",
"a function with", length(args), "arguments.")
stop(msg)
}
if (!single.na(match("...", names(args)))) {
msg <- paste("You have provided a function to the option 'Major iterations'",
"that uses the '...' argument.")
stop(msg)
}
}
if (is.null(model)) {
return(processDefaultOptionList(key, value))
}
if (length(model) > 1 || !is(model, "MxModel")) {
stop("argument 'model' must be an MxModel object")
}
if (reset) {
model@options <- list()
return(model)
}
if (key == "Default optimizer" || key == "Gradient algorithm" ||
key == "Gradient iterations" || key == "Gradient step size") {
stop(paste(omxQuotes(key), " is a global option and cannot be set on models.\n",
"To change ", omxQuotes(key) ," globally, use, e.g.:\n",
"mxOption(NULL, '", key, "', '", value,"')", sep = ""))
# to use NLOPT, use: mxOption(NULL, 'Default optimizer', 'NLOPT')
}
if (key == "Status OK") value <- as.statusCode(value)
model@options[[key]] <- value
return(model)
}
processDefaultOptionList <- function(key, value) {
defaultOptions <- getOption('mxOptions')
optionsNames <- names(defaultOptions)
match <- grep(paste("^", key, "$", sep = ""), optionsNames,
ignore.case=TRUE)
if(length(match) == 0) {
stop(paste("argument 'key' has a value",
omxQuotes(key), "that cannot be found in",
"getOption('mxOptions')"))
}
key <- optionsNames[[match]] # repair capitalization
if (missing(value)) return(defaultOptions[[key]])
defaultOptions[[key]] <- value
options('mxOptions' = defaultOptions)
return(invisible(defaultOptions))
}
##' imxDetermineDefaultOptimizer
##'
##' This is an internal function exported for those people who know
##' what they are doing.
##'
##' @details Returns a character, the default optimizer
imxDetermineDefaultOptimizer <- function() {
engine <- Sys.getenv("IMX_OPT_ENGINE")
if (!nchar(engine)) {
if (imxHasNPSOL()) {
engine <- "SLSQP"
} else {
engine <- "SLSQP"
}
}
engine
}
# Names and values must all be strings
npsolOptions <- list(
"Nolist" = "",
"Print level" = "0",
"Minor print level" = "0",
"Print file" = "0",
"Summary file" = "0",
"Function precision" = "Auto",#"1e-14"
"Optimality tolerance" = "6.3e-12",
"Infinite bound size" = "1.0e+15",
"Feasibility tolerance" = "5e-2",
"Major iterations" = function(nParams, nConstraints) { max(1000, 3 * nParams + 10 * nConstraints) },
"Verify level" = "-1",
"Line search tolerance" = "0.3",
"Derivative level" = "0",
"Step limit" = "2.0",
"Hessian" = "Yes",
# below are not npsol options
"Calculate Hessian" = "Yes",
"Standard Errors" = "Yes",
"Analytic Gradients" = "Yes"
)
checkpointOptions <- list(
"Checkpoint Directory" = ".",
"Checkpoint Prefix" = "",
"Checkpoint Units" = "iterations",
"Checkpoint Count" = 1,
"Checkpoint Fullpath" = "",
"Socket Server" = "",
"Socket Port" = 8080,
"Socket Units" = "minutes",
"Socket Count" = c("minutes" = 0.08, "iterations" = 1)
)
otherOptions <- list(
"Always Checkpoint" = "No",
"Error Checking" = "Yes",
"No Sort Data" = character(),
"RAM Inverse Optimization" = "Yes",
"RAM Max Depth" = NA,
"UsePPML" = "No",
"Allow Unlabeled" = FALSE,
"loglikelihoodScale" = -2.0,
"maxOrdinalPerBlock" = 20,
"mvnMaxPointsA" = 0,
"mvnMaxPointsB" = 0,
"mvnMaxPointsC" = 0,
"mvnMaxPointsD" = 3.606464,
"mvnMaxPointsE" = -0.126859,
"mvnAbsEps" = 0,
"mvnRelEps" = .005,
"maxStackDepth" = 25000L, # R_PPSSIZE/2
"Gradient algorithm" = NULL,
"Gradient iterations" = "Auto",#1L,
"Gradient step size" = "Auto",#1.0e-7,
"Parallel diagnostics" = "No",
"Debug protect stack" = "No",
"Nudge zero starts" = "Yes",
"Status OK"= as.statusCode(c("OK", "OK/green")),
"Max minutes"=0
)
limitMajorIterations <- function(options, numParam, numConstraints) {
mIters <- options[["Major iterations"]]
if (typeof(mIters) == "closure") {
mIters <- do.call(mIters, list(numParam, numConstraints))
}
options[["Major iterations"]] <- as.character(mIters)
options
}
imxGetNumThreads <- function() {
if (imxSfClient()) {
return(1L)
} else {
thrlimit <- as.integer(Sys.getenv("OMP_NUM_THREADS"))
if (!is.na(thrlimit)) {
return(thrlimit)
} else {
# CRAN allows use of up to 2 CPUs when OMP_NUM_THREADS is not
# set, but for some reason some examples finish too fast as if
# we're using more than 2 CPUs:
#
# "Examples with CPU time > 2.5 times elapsed time"
#
# To work around this issue, never use more than 1 CPU when
# OMP_NUM_THREADS is not set.
return(1L)
}
}
}
generateOptionsList <- function(model, useOptimizer) {
input <- list()
if (!is.null(model)) {
input <- model@options
if( !is.null(input[["UsePPML"]])
&& (input[["UsePPML"]] == "PartialSolved" || input[["UsePPML"]] == "Split") ) {
input[["Calculate Hessian"]] <- "No"
input[["Hessian"]] <- "No"
input[["Standard Errors"]] <- "No"
}
}
options <- combineDefaultOptions(input)
if (useOptimizer) {
options[["useOptimizer"]] <- "Yes"
#PPML Analytical solution
if (!is.null(model@options$UsePPML) && model@options$UsePPML == "Solved")
options[["useOptimizer"]] <- "No"
} else {
options[["useOptimizer"]] <- "No"
}
if (identical(options[["Standard Errors"]], "Yes") &&
identical(options[["Calculate Hessian"]], "No")) {
msg <- paste('The "Standard Errors" option is enabled and',
'the "Calculate Hessian" option is disabled. This may',
'result in poor accuracy standard errors.')
warning(msg)
}
return(options)
}
# Convert the keys and values into strings
combineDefaultOptions <- function(input) {
options <- getOption('mxOptions')
temp <- input[names(input) %in% names(npsolOptions)]
temp[["Major iterations"]] <- NULL
if (length(temp) > 0) {
keys <- sapply(names(temp), as.character)
values <- sapply(temp, as.character)
ynOptions <- options[keys]=='Yes' | options[keys]=='No'
badYN <- values[ynOptions] != 'Yes' & values[ynOptions] != 'No'
if (any(badYN)) {
stop(paste("mxOption '", names(badYN),
"' must be either 'Yes' or 'No'\n", sep=''))
}
options[keys] <- values
}
if (!is.null(input[["Major iterations"]])) {
options[["Major iterations"]] <- input[["Major iterations"]]
}
#Need to make sure that non-default values for options not already handled in this function don't get
#overwritten by the defaults:
namesHandled <- c( names(temp), "Major iterations" )
if(sum( !(names(input) %in% namesHandled) )>0){
options[names(input)[!(names(input) %in% namesHandled)]] <-
input[names(input)[!(names(input) %in% namesHandled)]]
}
return(options)
}
##' imxAutoOptionValue
##'
##' Convert "Auto" placeholders in global mxOptions to actual default values.
##'
##' This is an internal function exported for documentation purposes.
##' Its primary purpose is to convert the on-load value of "Auto"to
##' valid values for \link{mxOption}s \sQuote{Gradient step size},
##' \sQuote{Gradient iterations}, and
##' \sQuote{Function precision}--respectively, 1.0e-7, 1L, and 1e-14.
##'
##' @param optionName Character string naming the \link{mxOption} for which a numeric or integer value is wanted.
##' @param optionList List of options; defaults to list of global \link{mxOption}s.
##' imxAutoOptionValue
imxAutoOptionValue <- function(optionName, optionList=options()$mxOption){
#First, check to see if the option already has a valid value (possibly in string form), and if so, return that:
numcast <- try(suppressWarnings(as.numeric(optionList[[optionName]])),silent=TRUE)
if(!length(numcast)){
#NULL numcast is most likely to result from either (1) misspelled optionName,
#or (2) user providing non-default value for optionList that lacks an element named optionName.
#Throwing an error seems the best behavior in this case.
stop(paste("extracting element '",optionName,"' from argument 'optionList' resulted in NULL"),sep="")
}
#numcast will be try-error for e.g. NPSOL option "Major iterations" (on-load default is a function);
if("try-error" %in% class(numcast)){return(optionList[[optionName]])}
if(length(numcast) && !is.na(numcast)){
if(optionName=="Gradient iterations"){numcast <- as.integer(numcast)}
return(numcast)
}
#Otherwise, if the current value is a string and can be matched to "Auto",
#convert to default numerical value for the three motivating cases:
else{
if(length(grep(pattern="Auto",x=optionList[[optionName]],ignore.case=T))){
if(optionName=="Gradient step size"){return(1.0e-7)}
if(optionName=="Gradient iterations"){return(1L)}
if(optionName=="Function precision"){return(1e-14)}
}
else{stop(paste("found unrecognized character string '",optionList[[optionName]],"' as value for mxOption '",optionName,"' in argument 'optionList'",sep=""))}
}
}
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.