Fix test for optimizer; additionally test for mxCondenseMatrixSlots default
[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) && !is.null(model@options[[key]])) {
22                         return(model@options[[key]])
23                 }
24                 return(processDefaultOptionList(key, value))
25         }
26         if (length(value) > 1 && key!="No Sort Data") {
27                 msg <- paste("argument 'value' must be either NULL or of length 1.",
28                         "You gave me an object of length", length(value))
29                 stop(msg)
30         }
31         if (length(reset) != 1 || !is.logical(reset)) {
32                 stop("argument 'reset' must be TRUE or FALSE")
33         }
34         if (key == "Major iterations" && typeof(value) == "closure") {
35                 args <- formals(value)
36                 if (length(args) != 2) {
37                         msg <- paste("The function provided to the option 'Major iterations'",
38                                 "must have exactly 2 arguments but you have provided",
39                                 "a function with", length(args), "arguments.")
40                         stop(msg)
41                 }
42                 if (!single.na(match("...", names(args)))) {
43                         msg <- paste("You have provided a function to the option 'Major iterations'",
44                                 "that uses the '...' argument.")
45                         stop(msg)
46                 }
47         }
48     if (length(model) == 0 && is.null(model)) {
49         return(processDefaultOptionList(key, value))
50     }
51         if (length(model) > 1 || !is(model, "MxModel")) {
52                 stop("argument 'model' must be an MxModel object")
53         }
54         if (reset) {
55                 model@options <- list()
56                 return(model)
57         }
58         optionsNames <- names(getOption('mxOptions'))
59         match <- grep(paste("^", key, "$", sep = ""), optionsNames,
60                 ignore.case=TRUE)
61         if(length(match) == 0) {
62                 stop(paste("argument 'key' is the character string",
63                         omxQuotes(key), "and cannot be found in",
64                         "getOption('mxOptions')"))
65         }
66         if (!identical(optionsNames[[match]], key)) {
67                 stop(paste("argument 'key' is the character string",
68                         omxQuotes(key), "but the option is named",
69                         omxQuotes(optionsNames[[match]]), ": please correct",
70                         "the capitalization and re-run mxOption()."))
71         }
72         if (key == "Default optimizer") {
73                 stop(paste(key, "is a global option and cannot be set on models.\n",
74                 "To switch optimizers globally, use, e.g.:\n",
75                 "mxOption(NULL, 'Default optimizer', 'CSOLNP')", sep = ""))
76         # to use NLOPT, use: mxOption(NULL, 'Default optimizer', 'NLOPT')
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 imxDetermineDefaultOptimizer <- function() {
105         engine <- Sys.getenv("IMX_OPT_ENGINE")
106         if (!nchar(engine)) {
107                 if (imxHasNPSOL()) {
108                         engine <- "NPSOL"
109                 } else {
110                         engine <- "CSOLNP"
111                 }
112         }
113         engine
114 }
115
116 # Names and values must all be strings
117 npsolOptions <- list(
118         "Nolist" = "",
119         "Print level" = "0",
120         "Minor print level" = "0",
121         "Print file" = "0",
122         "Summary file" = "0",
123         "Function precision" = "1e-14",
124         "Optimality tolerance" = "6.3e-12",
125         "Infinite bound size" = "1.0e+15",
126         "Feasibility tolerance" = "1.0e-05",
127         "Major iterations" = function(nParams, nConstraints) { max(1000, 3 * nParams + 10 * nConstraints) },
128         "Verify level" = "-1",
129         "Line search tolerance" = "0.3",
130         "Derivative level" = "0",
131         "Hessian" = "Yes",
132 # below are not npsol options
133     "Major iteration_CSOLNP" = "400",
134     "Minor iteration_CSOLNP" = "800",
135     "Function precision_CSOLNP" = "1.0e-7",
136         "Calculate Hessian" = "Yes",
137         "Standard Errors" = "Yes",
138         "CI Max Iterations" = "5",
139         "Analytic Gradients" = "Yes",
140         "Number of Threads" = 0
141 )
142
143 checkpointOptions <- list(
144         "Checkpoint Directory" = ".", 
145         "Checkpoint Prefix" = "",
146         "Checkpoint Units" = "minutes", 
147         "Checkpoint Count" = c("minutes" = 10, "iterations" = 100),
148         "Checkpoint Fullpath" = "",
149         "Socket Server" = "", 
150         "Socket Port" = 8080,
151         "Socket Units" = "minutes", 
152         "Socket Count" = c("minutes" = 0.08, "iterations" = 1)
153 )
154
155 otherOptions <- list(
156     "Always Checkpoint" = "No",
157         "Error Checking" = "Yes",
158         "No Sort Data" = character(),
159         "RAM Inverse Optimization" = "Yes",
160         "RAM Max Depth" = NA,
161         "UsePPML" = "No",
162         "Allow Unlabeled" = FALSE,
163     "loglikelihoodScale" = -2.0,
164     "mvnMaxPointsA" = 0,
165     "mvnMaxPointsB" = 0,
166     "mvnMaxPointsC" = 5000,
167     "mvnAbsEps" = 1e-3,
168     "mvnRelEps" = 0,
169     "maxStackDepth" = 25000L   # R_PPSSIZE/2
170 )
171
172 generateOptionsList <- function(model, numParam, constraints, useOptimizer) {
173         input <- list()
174         if (!is.null(model)) {
175                 input <- model@options
176                 if (is.null(input[["Standard Errors"]]) && length(constraints) > 0) {
177                         input[["Standard Errors"]] <- "No"
178                 }
179                 if (is.null(input[["Calculate Hessian"]]) && length(constraints) > 0) {
180                         input[["Calculate Hessian"]] <- "No"
181                 }
182                 if( !is.null(input[["UsePPML"]]) 
183                    && (input[["UsePPML"]] == "PartialSolved" || input[["UsePPML"]] == "Split") ) {
184                         input[["Calculate Hessian"]] <- "No"
185                         input[["Hessian"]] <- "No"
186                         input[["Standard Errors"]] <- "No"
187                 }
188         }
189         options <- combineDefaultOptions(input)
190         if (!is.null(model)) {
191                 mIters <- options[["Major iterations"]]
192                 if (typeof(mIters) == "closure") {
193                         mIters <- do.call(mIters, list(numParam, length(constraints)))
194                 }
195                 options[["Major iterations"]] <- as.character(mIters)
196         }
197         if (useOptimizer) {
198                 options[["useOptimizer"]] <- "Yes"
199                 #PPML Analytical solution
200                 if (!is.null(model@options$UsePPML) && model@options$UsePPML == "Solved")
201                         options[["useOptimizer"]] <- "No"
202         } else {
203                 options[["useOptimizer"]] <- "No"
204         }
205         if (!is.null(model) && model@.forcesequential) {
206                 options[["Number of Threads"]] <- 1L 
207         } else if (is.null(options[["Number of Threads"]]) || 
208                         options[["Number of Threads"]] == 0) {
209                 if (imxSfClient()) {
210                         options[["Number of Threads"]] <- 1L 
211                 } else {
212                         thrlimit <- as.integer(Sys.getenv("OMP_NUM_THREADS"))
213                         if (!is.na(thrlimit)) {
214                                 options[["Number of Threads"]] <- thrlimit
215                         } else {
216                                 detect <- omxDetectCores()
217                                 if(is.na(detect)) detect <- 1L
218                                 options[["Number of Threads"]] <- detect 
219                         }
220                 }
221         }
222         if (identical(options[["Standard Errors"]], "Yes") &&
223                 identical(options[["Calculate Hessian"]], "No")) {
224                 msg <- paste('The "Standard Errors" option is enabled and',
225                 'the "Calculate Hessian" option is disabled. This may',
226                              'result in poor accuracy standard errors.')
227                 warning(msg)
228         }
229         return(options)
230 }
231
232 # Convert the keys and values into strings
233 combineDefaultOptions <- function(input) {
234         options <- getOption('mxOptions')
235         temp <- input[names(input) %in% names(npsolOptions)]
236         temp[["Major iterations"]] <- NULL
237         if (length(temp) > 0) {
238                 keys <- sapply(names(temp), as.character)
239                 values <- sapply(temp, as.character)
240                 ynOptions <- options[keys]=='Yes' | options[keys]=='No'
241                 badYN <- values[ynOptions] != 'Yes' & values[ynOptions] != 'No'
242                 if (any(badYN)) {
243                         stop(paste("mxOption '", names(badYN),
244                                    "' must be either 'Yes' or 'No'\n", sep=''))
245                 }
246                 options[keys] <- values
247         }
248         if (!is.null(input[["Major iterations"]])) {
249                 options[["Major iterations"]] <- input[["Major iterations"]]
250         }
251   #Need to make sure that non-default values for options not already handled in this function don't get
252   #overwritten by the defaults:
253   namesHandled <- c( names(temp), "Major iterations" )
254         if(sum( !(names(input) %in% namesHandled) )>0){
255     options[names(input)[!(names(input) %in% namesHandled)]] <- 
256       input[names(input)[!(names(input) %in% namesHandled)]]
257   }
258         return(options)
259 }