modified error msg in mxRun and mxOption to tell user how to change default optimizer...
[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, value))
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         if (key == "Default optimizer") {
74                 stop(paste(key, "is a global option and cannot be set on models.\n",
75                 "To switch optimizers globally, use, e.g.:\n",
76                 "mxOption(NULL, 'Default optimizer', 'CSOLNP')", sep = ""))
77         }
78         model@options[[key]] <- value
79         return(model)
80 }
81
82 processDefaultOptionList <- function(key, value) {
83         defaultOptions <- getOption('mxOptions')
84         optionsNames <- names(defaultOptions)
85         match <- grep(paste("^", key, "$", sep = ""), optionsNames,
86                 ignore.case=TRUE)
87         if(length(match) == 0) {
88                 stop(paste("argument 'key' has a value",
89                         omxQuotes(key), "that cannot be found in",
90                         "getOption('mxOptions')"))
91         }
92         if (!identical(optionsNames[[match]], key)) {
93                 stop(paste("argument 'key' has a value",
94                         omxQuotes(key), "but the option is named",
95                         omxQuotes(optionsNames[[match]]), ": please correct",
96                         "the capitalization and re-run mxOption()."))
97         }
98         if (missing(value)) return(defaultOptions[[key]])
99         defaultOptions[[key]] <- value
100         options('mxOptions' = defaultOptions)
101         return(invisible(defaultOptions))
102 }
103
104 determineDefaultOptimizer <- function() {
105         engine <- Sys.getenv("IMX_OPT_ENGINE")
106         if (!nchar(engine)) {
107                 engine <- "CSOLNP"
108         }
109         engine
110 }
111
112 # Names and values must all be strings
113 npsolOptions <- list(
114         "Nolist" = "",
115         "Print level" = "0",
116         "Minor print level" = "0",
117         "Print file" = "0",
118         "Summary file" = "0",
119         "Function precision" = "1e-14",
120         "Optimality tolerance" = "6.3e-12",
121         "Infinite bound size" = "1.0e+15",
122         "Feasibility tolerance" = "1.0e-05",
123         "Optimality tolerance" = as.character(1e-14 ^ 0.8),
124         "Major iterations" = function(nParams, nConstraints) { max(1000, 3 * nParams + 10 * nConstraints) },
125         "Verify level" = "-1",
126         "Line search tolerance" = "0.3",
127         "Derivative level" = "0",
128         "Hessian" = "Yes",
129 # below are not npsol options
130         "Calculate Hessian" = "Yes",
131         "Standard Errors" = "Yes",
132         "CI Max Iterations" = "5",
133         "Analytic Gradients" = "Yes",
134         "Number of Threads" = 0
135 )
136
137 checkpointOptions <- list(
138         "Checkpoint Directory" = ".", 
139         "Checkpoint Prefix" = "",
140         "Checkpoint Units" = "minutes", 
141         "Checkpoint Count" = c("minutes" = 10, "iterations" = 100),
142         "Socket Server" = "", 
143         "Socket Port" = 8080,
144         "Socket Units" = "minutes", 
145         "Socket Count" = c("minutes" = 0.08, "iterations" = 1)
146 )
147
148 otherOptions <- list(
149     "Always Checkpoint" = "No",
150         "Error Checking" = "Yes",
151         "No Sort Data" = character(),
152         "RAM Inverse Optimization" = "Yes",
153         "RAM Max Depth" = NA,
154         "UsePPML" = "No",
155         "Allow Unlabeled" = FALSE,
156     "loglikelihoodScale" = -2.0,
157     "mvnMaxPointsA" = 0,
158     "mvnMaxPointsB" = 0,
159     "mvnMaxPointsC" = 5000,
160     "mvnAbsEps" = 1e-3,
161     "mvnRelEps" = 0,
162     "maxStackDepth" = 25000L   # R_PPSSIZE/2
163 )
164
165 generateOptionsList <- function(model, numParam, constraints, useOptimizer) {
166         input <- list()
167         if (!is.null(model)) {
168                 input <- model@options
169                 if (is.null(input[["Standard Errors"]]) && length(constraints) > 0) {
170                         input[["Standard Errors"]] <- "No"
171                 }
172                 if (is.null(input[["Calculate Hessian"]]) && length(constraints) > 0) {
173                         input[["Calculate Hessian"]] <- "No"
174                 }
175                 if( !is.null(input[["UsePPML"]]) 
176                    && (input[["UsePPML"]] == "PartialSolved" || input[["UsePPML"]] == "Split") ) {
177                         input[["Calculate Hessian"]] <- "No"
178                         input[["Hessian"]] <- "No"
179                         input[["Standard Errors"]] <- "No"
180                 }
181         }
182         options <- combineDefaultOptions(input)
183         if (!is.null(model)) {
184                 mIters <- options[["Major iterations"]]
185                 if (typeof(mIters) == "closure") {
186                         mIters <- do.call(mIters, list(numParam, length(constraints)))
187                 }
188                 options[["Major iterations"]] <- as.character(mIters)
189         }
190         if (useOptimizer) {
191                 options[["useOptimizer"]] <- "Yes"
192                 #PPML Analytical solution
193                 if (!is.null(model@options$UsePPML) && model@options$UsePPML == "Solved")
194                         options[["useOptimizer"]] <- "No"
195         } else {
196                 options[["useOptimizer"]] <- "No"
197         }
198         if (!is.null(model) && model@.forcesequential) {
199                 options[["Number of Threads"]] <- 1L 
200         } else if (is.null(options[["Number of Threads"]]) || 
201                         options[["Number of Threads"]] == 0) {
202                 if (imxSfClient()) {
203                         options[["Number of Threads"]] <- 1L 
204                 } else {
205                         thrlimit <- as.integer(Sys.getenv("OMP_NUM_THREADS"))
206                         if (!is.na(thrlimit)) {
207                                 options[["Number of Threads"]] <- thrlimit
208                         } else {
209                                 detect <- omxDetectCores()
210                                 if(is.na(detect)) detect <- 1L
211                                 options[["Number of Threads"]] <- detect 
212                         }
213                 }
214         }
215         if (identical(options[["Standard Errors"]], "Yes") &&
216                 identical(options[["Calculate Hessian"]], "No")) {
217                 msg <- paste('The "Standard Errors" option is enabled and',
218                 'the "Calculate Hessian" option is disabled. This may',
219                              'result in poor accuracy standard errors.')
220                 warning(msg)
221         }
222         return(options)
223 }
224
225 # Convert the keys and values into strings
226 combineDefaultOptions <- function(input) {
227         options <- getOption('mxOptions')
228         temp <- input[names(input) %in% names(npsolOptions)]
229         temp[["Major iterations"]] <- NULL
230         if (length(temp) > 0) {
231                 keys <- sapply(names(temp), as.character)
232                 values <- sapply(temp, as.character)
233                 ynOptions <- options[keys]=='Yes' | options[keys]=='No'
234                 badYN <- values[ynOptions] != 'Yes' & values[ynOptions] != 'No'
235                 if (any(badYN)) {
236                         stop(paste("mxOption '", names(badYN),
237                                    "' must be either 'Yes' or 'No'\n", sep=''))
238                 }
239                 options[keys] <- values
240         }
241         if (!is.null(input[["Major iterations"]])) {
242                 options[["Major iterations"]] <- input[["Major iterations"]]
243         }
244   #Need to make sure that non-default values for options not already handled in this function don't get
245   #overwritten by the defaults:
246   namesHandled <- c( names(temp), "Major iterations" )
247         if(sum( !(names(input) %in% namesHandled) )>0){
248     options[names(input)[!(names(input) %in% namesHandled)]] <- 
249       input[names(input)[!(names(input) %in% namesHandled)]]
250   }
251         return(options)
252 }