Disable NPSOL gradient verification by default (this is a developer feature)
[openmx:openmx.git] / R / MxOptions.R
1 #
2 #   Copyright 2007-2013 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 (length(value) > 1 && key!="No Sort Data") {
21                 msg <- paste("argument 'value' must be either NULL or of length 1.",
22                         "You gave me an object of length", length(value))
23                 stop(msg)
24         }
25         if (length(reset) != 1 || !is.logical(reset)) {
26                 stop("argument 'reset' must be TRUE or FALSE")
27         }
28         if (key == "Major iterations" && typeof(value) == "closure") {
29                 args <- formals(value)
30                 if (length(args) != 2) {
31                         msg <- paste("The function provided to the option 'Major iterations'",
32                                 "must have exactly 2 arguments but you have provided",
33                                 "a function with", length(args), "arguments.")
34                         stop(msg)
35                 }
36                 if (!single.na(match("...", names(args)))) {
37                         msg <- paste("You have provided a function to the option 'Major iterations'",
38                                 "that uses the '...' argument.")
39                         stop(msg)
40                 }
41         }
42     if (length(model) == 0 && is.null(model)) {
43         return(processDefaultOptionList(key, value, reset))
44     }
45         if (length(model) > 1 || !is(model, "MxModel")) {
46                 stop("argument 'model' must be an MxModel object")
47         }
48         if (reset) {
49                 model@options <- list()
50                 return(model)
51         }
52         optionsNames <- names(getOption('mxOptions'))
53         match <- grep(paste("^", key, "$", sep = ""), optionsNames,
54                 ignore.case=TRUE)
55         if(length(match) == 0) {
56                 stop(paste("argument 'key' is the character string",
57                         omxQuotes(key), "and cannot be found in",
58                         "getOption('mxOptions')"))
59         }
60         if (!identical(optionsNames[[match]], key)) {
61                 stop(paste("argument 'key' is the character string",
62                         omxQuotes(key), "but the option is named",
63                         omxQuotes(optionsNames[[match]]), ": please correct",
64                         "the capitalization and re-run mxOption()."))
65         }
66         model@options[[key]] <- value
67         return(model)
68 }
69
70 processDefaultOptionList <- function(key, value, reset) {
71         defaultOptions <- getOption('mxOptions')
72         optionsNames <- names(defaultOptions)
73         match <- grep(paste("^", key, "$", sep = ""), optionsNames,
74                 ignore.case=TRUE)
75         if(length(match) == 0) {
76                 stop(paste("argument 'key' has a value",
77                         omxQuotes(key), "that cannot be found in",
78                         "getOption('mxOptions')"))
79         }
80         if (!identical(optionsNames[[match]], key)) {
81                 stop(paste("argument 'key' has a value",
82                         omxQuotes(key), "but the option is named",
83                         omxQuotes(optionsNames[[match]]), ": please correct",
84                         "the capitalization and re-run mxOption()."))
85         }
86         defaultOptions[[key]] <- value
87         options('mxOptions' = defaultOptions)
88         return(invisible(defaultOptions))
89 }
90
91 # Names and values must all be strings
92 npsolOptions <- list(
93         "Nolist" = "",
94         "Print level" = "0",
95         "Minor print level" = "0",
96         "Print file" = "0",
97         "Summary file" = "0",
98         "Function precision" = "1e-14",
99         "Optimality tolerance" = "6.3e-12",
100         "Infinite bound size" = "1.0e+15",
101         "Feasibility tolerance" = "1.0e-05",
102         "Optimality tolerance" = as.character(1e-14 ^ 0.8),
103         "Major iterations" = function(nParams, nConstraints) { max(1000, 3 * nParams + 10 * nConstraints) },
104         "Verify level" = "-1",
105         "Line search tolerance" = "0.3",
106         "Derivative level" = "0",
107         "Hessian" = "Yes",
108         "Calculate Hessian" = "Yes",
109         "Standard Errors" = "Yes",
110         "CI Max Iterations" = "5",
111         "Analytic Gradients" = "Yes",
112         "Number of Threads" = 0
113 )
114
115 checkpointOptions <- list(
116         "Checkpoint Directory" = ".", 
117         "Checkpoint Prefix" = "",
118         "Checkpoint Units" = "minutes", 
119         "Checkpoint Count" = c("minutes" = 10, "iterations" = 100),
120         "Socket Server" = "", 
121         "Socket Port" = 8080,
122         "Socket Units" = "minutes", 
123         "Socket Count" = c("minutes" = 0.08, "iterations" = 1)
124 )
125
126 otherOptions <- list(
127     "Always Checkpoint" = "No",
128         "Error Checking" = "Yes",
129         "No Sort Data" = character(),
130         "RAM Inverse Optimization" = "Yes",
131         "RAM Max Depth" = NA,
132         "UsePPML" = "No",
133         "Allow Unlabeled" = FALSE
134 )
135
136 generateOptionsList <- function(model, numParam, constraints, useOptimizer) {
137         input <- model@options
138         if (is.null(input[["Standard Errors"]]) && length(constraints) > 0) {
139                 input[["Standard Errors"]] <- "No"
140         }
141         if (is.null(input[["Calculate Hessian"]]) && length(constraints) > 0) {
142                 input[["Calculate Hessian"]] <- "No"
143         }
144         if( !is.null(input[["UsePPML"]]) 
145                 && (input[["UsePPML"]] == "PartialSolved" || input[["UsePPML"]] == "Split") ) {
146                 input[["Calculate Hessian"]] <- "No"
147                 input[["Hessian"]] <- "No"
148                 input[["Standard Errors"]] <- "No"
149         }
150         options <- combineDefaultOptions(input)
151         mIters <- options[["Major iterations"]]
152         if (typeof(mIters) == "closure") {
153                 mIters <- do.call(mIters, list(numParam, length(constraints)))
154         }
155         options[["Major iterations"]] <- as.character(mIters)
156         if (useOptimizer) {
157                 options[["useOptimizer"]] <- "Yes"
158                 #PPML Analytical solution
159                 if (!is.null(model@options$UsePPML) && model@options$UsePPML == "Solved")
160                         options[["useOptimizer"]] <- "No"
161         } else {
162                 options[["useOptimizer"]] <- "No"
163         }
164         if (model@.forcesequential) {
165                 options[["Number of Threads"]] <- 1L 
166         } else if (is.null(options[["Number of Threads"]]) || 
167                         options[["Number of Threads"]] == 0) {
168                 if (imxSfClient()) {
169                         options[["Number of Threads"]] <- 1L 
170                 } else {
171                         thrlimit <- as.integer(Sys.getenv("OMP_NUM_THREADS"))
172                         if (!is.na(thrlimit)) {
173                                 options[["Number of Threads"]] <- thrlimit
174                         } else {
175                                 detect <- omxDetectCores()
176                                 if(is.na(detect)) detect <- 1L
177                                 options[["Number of Threads"]] <- detect 
178                         }
179                 }
180         }
181         if (identical(options[["Standard Errors"]], "Yes") &&
182                 identical(options[["Calculate Hessian"]], "No")) {
183                 msg <- paste('The "Standard Errors" option is enabled and',
184                 'the "Calculate Hessian" option is disabled. Generating',
185                 'standard errors requires the Hessian calculation. Please',
186                 'disable standard errors or enable the Hessian calculation.')
187                 stop(msg, call. = FALSE)
188         }
189         return(options)
190 }
191
192 # Convert the keys and values into strings
193 combineDefaultOptions <- function(input) {
194         options <- getOption('mxOptions')
195         options <- options[names(options) %in% names(npsolOptions)]
196         temp <- input[names(input) %in% names(npsolOptions)]
197         temp[["Major iterations"]] <- NULL
198         if (length(temp) > 0) {
199                 keys <- sapply(names(temp), as.character)
200                 values <- sapply(temp, as.character)
201                 ynOptions <- options[keys]=='Yes' | options[keys]=='No'
202                 badYN <- values[ynOptions] != 'Yes' & values[ynOptions] != 'No'
203                 if (any(badYN)) {
204                         stop(paste("mxOption '", names(badYN),
205                                    "' must be either 'Yes' or 'No'\n", sep=''))
206                 }
207                 options[keys] <- values
208         }
209         if (!is.null(input[["Major iterations"]])) {
210                 options[["Major iterations"]] <- input[["Major iterations"]]
211         }
212         return(options)
213 }