Allow multiple 'references' in single call to omxInterval function.
[openmx:openmx.git] / R / MxInterval.R
1 #\r
2 #   Copyright 2007-2010 The OpenMx Project\r
3 #\r
4 #   Licensed under the Apache License, Version 2.0 (the "License");\r
5 #   you may not use this file except in compliance with the License.\r
6 #   You may obtain a copy of the License at\r
7\r
8 #        http://www.apache.org/licenses/LICENSE-2.0\r
9\r
10 #   Unless required by applicable law or agreed to in writing, software\r
11 #   distributed under the License is distributed on an "AS IS" BASIS,\r
12 #   WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.\r
13 #   See the License for the specific language governing permissions and\r
14 #   limitations under the License.\r
15 \r
16 setClass(Class = "MxInterval",\r
17         representation = representation(\r
18                 reference = "character",\r
19                 lowerdelta = "numeric",\r
20                 upperdelta = "numeric"
21         ))\r
22 \r
23 setMethod("initialize", "MxInterval",\r
24         function(.Object, reference, lowerdelta, upperdelta) {\r
25                 .Object@reference <- reference\r
26                 .Object@lowerdelta <- lowerdelta\r
27                 .Object@upperdelta <- upperdelta\r
28                 return(.Object)\r
29         }\r
30 )\r
31 \r
32 createNewInterval <- function(reference, lowerdelta, upperdelta) {\r
33         return(new("MxInterval", reference, lowerdelta, upperdelta))\r
34 }\r
35 \r
36 expandSingleInterval <- function(interval) {\r
37         references <- interval@reference\r
38         if (length(references) == 1) {\r
39                 return(interval)\r
40         } else {\r
41                 return(lapply(references, createNewInterval, \r
42                         interval@lowerdelta, interval@upperdelta))\r
43         }\r
44 }\r
45 \r
46 expandIntervals <- function(intervals) {\r
47         if (length(intervals) == 0) {\r
48                 return(intervals)\r
49         }\r
50         retval <- lapply(intervals, expandSingleInterval)\r
51         retval <- unlist(retval)\r
52         return(retval)\r
53 }\r
54 \r
55 omxInterval <- function(reference, lowerdelta, upperdelta) {\r
56         if (single.na(lowerdelta)) { lowerdelta <- as.numeric(NA) }
57         if (single.na(upperdelta)) { upperdelta <- as.numeric(NA) }
58         if (!is.character(reference) || length(reference) < 1 || any(is.na(reference))) {
59                 stop("'reference' argument must be a character vector")
60         }
61         if (!is.numeric(lowerdelta) || length(lowerdelta) != 1) {
62                 stop("'lowerdelta' argument must be a numeric value")
63         }
64         if (!is.numeric(upperdelta) || length(upperdelta) != 1) {
65                 stop("'upperdelta' argument must be a numeric value")
66         }\r
67         retval <- createNewInterval(reference, lowerdelta, upperdelta)\r
68         return(retval)\r
69 }
70
71 modelAddIntervals <- function(model, intervals) {
72         if (length(intervals) == 0) {\r
73                 return(model)\r
74         }
75         iNames <- names(intervals)
76         for(i in 1:length(intervals)) {
77                 model@intervals[[iNames[[i]]]] <- intervals[[i]]
78         }
79         return(model)
80 }
81
82 modelRemoveIntervals <- function(model, intervals) {
83         if (length(intervals) == 0) {\r
84                 return(model)\r
85         }
86         iNames <- names(intervals)
87         for(i in 1:length(intervals)) {         
88                 model@intervals[[iNames[[i]]]] <- NULL
89         }
90         return(model)
91 }
92
93 generateIntervalList <- function(flatModel, useIntervals, modelname, parameters) {
94         if (length(useIntervals) != 1 || 
95                 typeof(useIntervals) != "logical" || 
96                 is.na(useIntervals)) {
97                 stop(paste("'intervals' argument", 
98                         "must be TRUE or FALSE in",
99                         deparse(width.cutoff = 400L, sys.call(-1))), call. = FALSE)
100         }
101         if (!useIntervals) {
102                 return(list())
103         }
104         return(lapply(flatModel@intervals, generateIntervalListHelper, flatModel, modelname, parameters))
105 }\r
106
107
108 generateIntervalListHelper <- function(interval, flatModel, modelname, parameters) {
109         pnames <- names(parameters)
110         reference <- interval@reference
111         if(reference %in% pnames) {
112                 return(c(parameters[[reference]][[3]], interval@lowerdelta, interval@upperdelta))
113         } else if (hasSquareBrackets(reference)) {
114                 components <- splitSubstitution(reference)
115                 entityName <- components[[1]]
116                 row <- as.numeric(components[[2]])
117                 col <- as.numeric(components[[3]])
118                 entityNumber <- omxLocateIndex(flatModel, entityName, 
119                         paste("confidence interval", interval@reference))
120                 return(c(entityNumber, row - 1, col - 1, interval@lowerdelta, interval@upperdelta))             
121         } else {
122                 stop(paste("Unknown reference to", omxQuotes(reference),
123                         "detected in a confidence interval",
124                         "specification in model", omxQuotes(modelname), "in",
125                         deparse(width.cutoff = 400L, sys.call(-3))), call. = FALSE)
126         }
127 }
128
129 displayInterval <- function(object) {\r
130         cat("MxInterval", '\n')\r
131         cat("@reference: ", object@reference, '\n')
132         cat("@lowerdelta: ", object@lowerdelta, '\n')
133         cat("@upperdelta: ", object@upperdelta, '\n')\r
134 }\r
135 \r
136 setMethod("print", "MxInterval", function(x,...) { displayInterval(x) })\r
137 setMethod("show", "MxInterval", function(object) { displayInterval(object) })