mxOption without a value to show the current setting
[openmx:openmx.git] / R / MxOptions.R
1 #
2 #   Copyright 2007-2014 The OpenMx Project
3 #
4 #   Licensed under the Apache License, Version 2.0 (the "License");
5 #   you may not use this file except in compliance with the License.
6 #   You may obtain a copy of the License at
7
8 #        http://www.apache.org/licenses/LICENSE-2.0
9
10 #   Unless required by applicable law or agreed to in writing, software
11 #   distributed under the License is distributed on an "AS IS" BASIS,
12 #   WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
13 #   See the License for the specific language governing permissions and
14 #   limitations under the License.
15
16 mxOption <- function(model, key, value, reset = FALSE) {
17         if (length(key) != 1 || !is.character(key)) {
18                 stop("argument 'key' must be a character string")
19         }
20         if (missing(value)) {
21                 if (length(model) == 0 && is.null(model)) {
22                         return(processDefaultOptionList(key, value))
23                 } else {
24                         return(model@options[[key]])
25                 }
26         }
27         if (length(value) > 1 && key!="No Sort Data") {
28                 msg <- paste("argument 'value' must be either NULL or of length 1.",
29                         "You gave me an object of length", length(value))
30                 stop(msg)
31         }
32         if (length(reset) != 1 || !is.logical(reset)) {
33                 stop("argument 'reset' must be TRUE or FALSE")
34         }
35         if (key == "Major iterations" && typeof(value) == "closure") {
36                 args <- formals(value)
37                 if (length(args) != 2) {
38                         msg <- paste("The function provided to the option 'Major iterations'",
39                                 "must have exactly 2 arguments but you have provided",
40                                 "a function with", length(args), "arguments.")
41                         stop(msg)
42                 }
43                 if (!single.na(match("...", names(args)))) {
44                         msg <- paste("You have provided a function to the option 'Major iterations'",
45                                 "that uses the '...' argument.")
46                         stop(msg)
47                 }
48         }
49     if (length(model) == 0 && is.null(model)) {
50         return(processDefaultOptionList(key))
51     }
52         if (length(model) > 1 || !is(model, "MxModel")) {
53                 stop("argument 'model' must be an MxModel object")
54         }
55         if (reset) {
56                 model@options <- list()
57                 return(model)
58         }
59         optionsNames <- names(getOption('mxOptions'))
60         match <- grep(paste("^", key, "$", sep = ""), optionsNames,
61                 ignore.case=TRUE)
62         if(length(match) == 0) {
63                 stop(paste("argument 'key' is the character string",
64                         omxQuotes(key), "and cannot be found in",
65                         "getOption('mxOptions')"))
66         }
67         if (!identical(optionsNames[[match]], key)) {
68                 stop(paste("argument 'key' is the character string",
69                         omxQuotes(key), "but the option is named",
70                         omxQuotes(optionsNames[[match]]), ": please correct",
71                         "the capitalization and re-run mxOption()."))
72         }
73         model@options[[key]] <- value
74         return(model)
75 }
76
77 processDefaultOptionList <- function(key, value) {
78         defaultOptions <- getOption('mxOptions')
79         optionsNames <- names(defaultOptions)
80         match <- grep(paste("^", key, "$", sep = ""), optionsNames,
81                 ignore.case=TRUE)
82         if(length(match) == 0) {
83                 stop(paste("argument 'key' has a value",
84                         omxQuotes(key), "that cannot be found in",
85                         "getOption('mxOptions')"))
86         }
87         if (!identical(optionsNames[[match]], key)) {
88                 stop(paste("argument 'key' has a value",
89                         omxQuotes(key), "but the option is named",
90                         omxQuotes(optionsNames[[match]]), ": please correct",
91                         "the capitalization and re-run mxOption()."))
92         }
93         if (missing(value)) return(defaultOptions[[key]])
94         defaultOptions[[key]] <- value
95         options('mxOptions' = defaultOptions)
96         return(invisible(defaultOptions))
97 }
98
99 determineDefaultOptimizer <- function() {
100         engine <- Sys.getenv("IMX_OPT_ENGINE")
101         if (!nchar(engine)) {
102                 engine <- "CSOLNP"
103         }
104         engine
105 }
106
107 # Names and values must all be strings
108 npsolOptions <- list(
109         "Nolist" = "",
110         "Print level" = "0",
111         "Minor print level" = "0",
112         "Print file" = "0",
113         "Summary file" = "0",
114         "Function precision" = "1e-14",
115         "Optimality tolerance" = "6.3e-12",
116         "Infinite bound size" = "1.0e+15",
117         "Feasibility tolerance" = "1.0e-05",
118         "Optimality tolerance" = as.character(1e-14 ^ 0.8),
119         "Major iterations" = function(nParams, nConstraints) { max(1000, 3 * nParams + 10 * nConstraints) },
120         "Verify level" = "-1",
121         "Line search tolerance" = "0.3",
122         "Derivative level" = "0",
123         "Hessian" = "Yes",
124 # below are not npsol options
125         "Calculate Hessian" = "Yes",
126         "Standard Errors" = "Yes",
127         "CI Max Iterations" = "5",
128         "Analytic Gradients" = "Yes",
129         "Number of Threads" = 0
130 )
131
132 checkpointOptions <- list(
133         "Checkpoint Directory" = ".", 
134         "Checkpoint Prefix" = "",
135         "Checkpoint Units" = "minutes", 
136         "Checkpoint Count" = c("minutes" = 10, "iterations" = 100),
137         "Socket Server" = "", 
138         "Socket Port" = 8080,
139         "Socket Units" = "minutes", 
140         "Socket Count" = c("minutes" = 0.08, "iterations" = 1)
141 )
142
143 otherOptions <- list(
144     "Always Checkpoint" = "No",
145         "Error Checking" = "Yes",
146         "No Sort Data" = character(),
147         "RAM Inverse Optimization" = "Yes",
148         "RAM Max Depth" = NA,
149         "UsePPML" = "No",
150         "Allow Unlabeled" = FALSE,
151     "loglikelihoodScale" = -2.0,
152     "mvnMaxPointsA" = 0,
153     "mvnMaxPointsB" = 0,
154     "mvnMaxPointsC" = 5000,
155     "mvnAbsEps" = 1e-3,
156     "mvnRelEps" = 0,
157     "maxStackDepth" = 25000L   # R_PPSSIZE/2
158 )
159
160 generateOptionsList <- function(model, numParam, constraints, useOptimizer) {
161         input <- list()
162         if (!is.null(model)) {
163                 input <- model@options
164                 if (is.null(input[["Standard Errors"]]) && length(constraints) > 0) {
165                         input[["Standard Errors"]] <- "No"
166                 }
167                 if (is.null(input[["Calculate Hessian"]]) && length(constraints) > 0) {
168                         input[["Calculate Hessian"]] <- "No"
169                 }
170                 if( !is.null(input[["UsePPML"]]) 
171                    && (input[["UsePPML"]] == "PartialSolved" || input[["UsePPML"]] == "Split") ) {
172                         input[["Calculate Hessian"]] <- "No"
173                         input[["Hessian"]] <- "No"
174                         input[["Standard Errors"]] <- "No"
175                 }
176         }
177         options <- combineDefaultOptions(input)
178         if (!is.null(model)) {
179                 mIters <- options[["Major iterations"]]
180                 if (typeof(mIters) == "closure") {
181                         mIters <- do.call(mIters, list(numParam, length(constraints)))
182                 }
183                 options[["Major iterations"]] <- as.character(mIters)
184         }
185         if (useOptimizer) {
186                 options[["useOptimizer"]] <- "Yes"
187                 #PPML Analytical solution
188                 if (!is.null(model@options$UsePPML) && model@options$UsePPML == "Solved")
189                         options[["useOptimizer"]] <- "No"
190         } else {
191                 options[["useOptimizer"]] <- "No"
192         }
193         if (!is.null(model) && model@.forcesequential) {
194                 options[["Number of Threads"]] <- 1L 
195         } else if (is.null(options[["Number of Threads"]]) || 
196                         options[["Number of Threads"]] == 0) {
197                 if (imxSfClient()) {
198                         options[["Number of Threads"]] <- 1L 
199                 } else {
200                         thrlimit <- as.integer(Sys.getenv("OMP_NUM_THREADS"))
201                         if (!is.na(thrlimit)) {
202                                 options[["Number of Threads"]] <- thrlimit
203                         } else {
204                                 detect <- omxDetectCores()
205                                 if(is.na(detect)) detect <- 1L
206                                 options[["Number of Threads"]] <- detect 
207                         }
208                 }
209         }
210         if (identical(options[["Standard Errors"]], "Yes") &&
211                 identical(options[["Calculate Hessian"]], "No")) {
212                 msg <- paste('The "Standard Errors" option is enabled and',
213                 'the "Calculate Hessian" option is disabled. This may',
214                              'result in poor accuracy standard errors.')
215                 warning(msg)
216         }
217         return(options)
218 }
219
220 # Convert the keys and values into strings
221 combineDefaultOptions <- function(input) {
222         options <- getOption('mxOptions')
223         temp <- input[names(input) %in% names(npsolOptions)]
224         temp[["Major iterations"]] <- NULL
225         if (length(temp) > 0) {
226                 keys <- sapply(names(temp), as.character)
227                 values <- sapply(temp, as.character)
228                 ynOptions <- options[keys]=='Yes' | options[keys]=='No'
229                 badYN <- values[ynOptions] != 'Yes' & values[ynOptions] != 'No'
230                 if (any(badYN)) {
231                         stop(paste("mxOption '", names(badYN),
232                                    "' must be either 'Yes' or 'No'\n", sep=''))
233                 }
234                 options[keys] <- values
235         }
236         if (!is.null(input[["Major iterations"]])) {
237                 options[["Major iterations"]] <- input[["Major iterations"]]
238         }
239         return(options)
240 }