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