Error checking for 0-length arguments to mxPath()
[openmx:openmx.git] / R / MxPath.R
1 #
2 #   Copyright 2007-2012 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 setClass(Class = "MxPath",
17         representation = representation(
18                 from = "character",
19                 to = "character",
20                 arrows = "numeric",
21                 values = "numeric",
22                 free = "logical",
23                 labels = "character",
24                 lbound = "numeric",
25                 ubound = "numeric",
26                 connect = "character"
27 ))
28
29 setMethod("initialize", "MxPath",
30         function(.Object, from, to, arrows, values,
31                 free, labels, lbound, ubound, connect) {
32                 .Object@from <- from
33                 .Object@to <- to
34                 .Object@arrows <- arrows
35                 .Object@values <- values
36                 .Object@free <- free
37                 .Object@labels <- labels
38                 .Object@lbound <- lbound
39                 .Object@ubound <- ubound
40                 .Object@connect <- connect
41                 return(.Object)
42         }
43 )
44
45 # returns a list of paths
46 generatePath <- function(from, to, 
47                 connect, arrows, values, free,
48                 labels, lbound, ubound) {
49                 
50         # save exactly what the user typed to pass to mxModel for creation
51         unalteredTo <- to
52         unalteredFrom <- from
53                 
54         # check if user employed the loop shortcut by only specifying from      
55         if (single.na(to)) {
56                 loop <- TRUE
57                 to <- from
58         } else {
59                 loop <- FALSE
60         }
61         
62         # now expand the paths to check for errors
63         excludeBivariate <- FALSE
64         excludeSelf      <- FALSE
65         
66         # interpret 'connect' argument
67         if ((connect == "unique.pairs" ) || (connect == "unique.bivariate")){
68                 excludeBivariate <- TRUE
69         }
70         if ((connect == "all.bivariate") || (connect == "unique.bivariate")){
71                 excludeSelf <- TRUE
72         }
73         
74         # if a variable is a connect = "single" then it does not need to be expanded
75         if ((connect != "single")){ 
76         
77                 from <- rep(from, each=length(to))
78                 to   <- rep(to, length(from)/length(to))
79
80                 exclude <- rep(FALSE, length(from))
81
82                 # if 'excluderedundant', then exclude b,a if a,b is present
83                 if (excludeBivariate){
84                         sortedPairs <- t(apply(matrix(c(from, to), ncol = 2), 1, sort))
85                         exclude <- exclude | duplicated(sortedPairs)
86                 }
87
88                 # if 'excludeself', then exclude x,x paths
89                 if (excludeSelf){
90                         exclude <- exclude | (from==to)
91                 }
92                 
93                 from <- from[!exclude]
94                 to   <- to[!exclude]            
95         }       
96         
97         # check for a missing to or from
98         pathCheckToAndFrom(from, to)
99
100         # check the labels for illegal references
101         lapply(labels, imxVerifyReference, -1)
102         
103         # check for length mismatches
104         pathCheckLengths(from, to, arrows, values, free, labels, lbound, ubound, loop)
105         
106         # create a new MxPath in the MxModel
107         return(new("MxPath", unalteredFrom, unalteredTo, arrows, values, free, labels, lbound, ubound, connect))
108 }
109
110 pathCheckToAndFrom <- function(from, to){
111         # check for a missing to or from
112         if (any(is.na(from)) || any(is.na(to))) {
113                 stop("The \'from\' field or the \'to\' field contains an NA", call. = FALSE)
114         }
115 }
116
117 pathCheckLengths <- function(from, to, arrows, values, 
118         free, labels, lbound, ubound, loop) {
119     numPaths <- max(length(from), length(to))
120     pathCheckSingleLength(numPaths, length(arrows), "arrows", from, to, loop)
121     pathCheckSingleLength(numPaths, length(values), "values", from, to, loop)
122     pathCheckSingleLength(numPaths, length(free), "free/fixed designations", from, to, loop)
123     pathCheckSingleLength(numPaths, length(labels), "labels", from, to, loop)
124     pathCheckSingleLength(numPaths, length(lbound), "lbounds", from, to, loop)
125     pathCheckSingleLength(numPaths, length(ubound), "ubounds", from, to, loop)
126 }
127
128 pathCheckSingleLength <- function(numPaths, len, lenName, from, to, loop) {
129     if (numPaths < len) {
130         if (loop) { to <- NA }
131         stop(paste("mxPath() call will generate", 
132             numPaths, "paths but you have specified",
133             len, lenName, "with 'from' argument assigned to", omxQuotes(from),
134             "and 'to' argument assigned to", omxQuotes(to)), call. = FALSE)
135     }
136 }
137
138
139 generateSinglePath <- function(from, to, 
140                 arrows, values, free,
141                 labels, lbound, ubound) {
142         result <- list()
143         result[['from']] <- from
144         result[['to']] <- to
145         result[['arrows']] <- arrows[[1]]
146         result[['values']] <- values[[1]]       
147         result[['free']] <- free[[1]]
148         result[['labels']] <- labels[[1]]       
149         result[['lbound']] <- lbound[[1]]
150         result[['ubound']] <- ubound[[1]]
151         return(result)
152 }
153
154 imxIsPath <- function(value) {
155         return(is.list(value) && 
156                 !is.null(value[['from']]) &&
157                 !is.null(value[['to']]))
158 }
159
160 matrixToPaths <- function(mxMatrix, arrows = c(1,2)) {
161         values <- mxMatrix@values
162         free <- mxMatrix@free
163         labels <- mxMatrix@labels
164         if (arrows == 2) {
165                 values[upper.tri(values)] <- 0
166                 free[upper.tri(free)] <- FALSE
167                 labels[upper.tri(labels)] <- as.character(NA)
168         }
169         select <- (values != 0) | (free) | (!is.na(labels))
170         if (length(select) > 0) {
171             rowFactors <- row(values, as.factor=TRUE)
172             colFactors <- col(values, as.factor=TRUE)   
173                 fromNames <- as.character(colFactors[select])
174                 toNames <- as.character(rowFactors[select])
175                 if (length(fromNames) > 0 && length(toNames) > 0) {
176                         return(mxPath(from = fromNames, to = toNames, arrows = arrows))
177                 }
178         }
179         return(list())
180 }
181
182 meansToPaths <- function(mxMatrix) {
183         if (is.null(mxMatrix)) return(list())
184         values <- mxMatrix@values
185         free <- mxMatrix@free
186         labels <- mxMatrix@labels
187         select <- (values != 0) | (free) | (!is.na(labels))
188         if (length(select) > 0) {
189             colFactors <- col(values, as.factor=TRUE)
190                 toNames <- as.character(colFactors[select])
191                 if (length(toNames) > 0) {
192                         return(mxPath(from = 'one', to = toNames, arrows = 1))
193                 }
194         }
195         return(list())
196 }
197
198 pathCheckVector <- function(value, valname, check, type) {
199         if (!is.vector(value) || !check(value) || length(value) == 0) {
200                 stop(paste("The", omxQuotes(valname), 
201                         "argument to mxPath must be a",
202                         type, "vector of length > 0."), call. = FALSE)
203         }
204 }
205
206 mxPath <- function(from, to = NA, 
207         connect = c("single", "all.pairs", "unique.pairs", 
208                     "all.bivariate", "unique.bivariate"), arrows = 1, 
209         free = TRUE, values = NA, labels = NA, lbound = NA, ubound = NA, ...) {
210         if (missing(from)) {
211                 stop("The 'from' argument to mxPath must have a value.")
212         }
213         if (is.logical(connect)) {
214                 msg <- paste("The 'all' argument to mxPath ",
215                         "has been deprecated. It has been replaced ",
216                         "with the safer interface 'connect' in OpenMx 1.2. ",
217                         "See ?mxPath for more information.")
218                 # throw an error if 'all' has illegal value
219                 if ((length(connect) != 1) || single.na(connect)) {
220                         stop(msg)
221                 } else {
222                         warning(msg)
223                 }
224         }
225         garbageArguments <- list(...)
226         allArgument <- garbageArguments[['all']]
227         if (!is.null(allArgument)) {
228                 msg <- paste("The 'all' argument to mxPath ",
229                         "has been deprecated. It has been replaced ",
230                         "with the safer interface 'connect' in OpenMx 1.2. ",
231                         "See ?mxPath for more information.")
232                 # throw an error if 'all' has illegal value
233                 if (!(is.logical(allArgument) && 
234                         (length(allArgument) == 1) && 
235                         !single.na(allArgument))) {
236                         stop(msg)
237                 # throw an error if 'all' and 'connect' are both specified
238                 } else if (!identical(connect, 
239                         c("single", "all.pairs", "unique.pairs", 
240                         "all.bivariate", "unique.bivariate"))) {
241                         stop(msg)
242                 } else {
243                         warning(msg)
244                         connect <- allArgument
245                 }
246         } else if (length(garbageArguments) > 0) {
247                 msg <- paste("mxPath does not accept values",
248                                 "for the '...' argument.",
249                                 "See ?mxPath for more information.")
250                 stop(msg)
251     }
252         if (identical(connect, c("single", "all.pairs", "unique.pairs", 
253                     "all.bivariate", "unique.bivariate"))) {
254                 connect <- "single"
255         }
256         # eliminate this test when "all" argument is eliminated
257         if (is.logical(connect)) {
258                 if (connect) {
259                         connect <- "all.pairs"
260                 } else {
261                         connect <- "single"
262                 }
263         } else {
264                 if (!(length(connect) == 1 && !single.na(connect) && 
265                          is.character(connect) && (connect %in% 
266                                 c("single", "all.pairs", "unique.pairs", 
267                     "all.bivariate", "unique.bivariate")))) {
268                         msg <- paste("'connect' must be one of",
269                                         "'single', 'all.pairs', 'unique.pairs',",
270                             "'all.bivariate', or 'unique.bivariate'")
271                         stop(msg)
272                 }
273                 if (identical(connect, "all.pairs") && identical(arrows, 2)) {
274                         msg <- paste("'connect=all.pairs' argument cannot",
275                                                 "be used with 'arrows=2.',",
276                                                 "Please use 'connect=unique.pairs'.")
277                         stop(msg)
278                 }
279                 if (identical(connect, "all.bivariate") && identical(arrows, 2)) {
280                         msg <- paste("'connect=all.bivariate' argument cannot",
281                                                 "be used with 'arrows=2'.",
282                                                 "Please use 'connect=unique.bivariate'.")
283                         stop(msg)
284                 }
285                 if (!identical(connect, "single") && length(arrows) != 1) {
286                         msg <- paste("multiple values for the 'arrows' argument are",
287                                         "not allowed when the 'connect' argument",
288                                         "is not equal to 'single'")
289                         stop(msg)
290                 }
291         }
292         if (all.na(to)) { to <- as.character(to) }
293         if (all.na(from)) { from <- as.character(from) }
294         if (all.na(values)) { values <- as.numeric(values) }
295         if (all.na(labels)) { labels <- as.character(labels) }
296         if (all.na(lbound)) { lbound <- as.numeric(lbound) }
297         if (all.na(ubound)) { ubound <- as.numeric(ubound) }
298         if (all.na(connect)) { connect <- as.character(connect) }       
299         pathCheckVector(from, 'from', is.character, 'character')
300         pathCheckVector(to, 'to', is.character, 'character')
301         pathCheckVector(arrows, 'arrows', is.numeric, 'numeric')
302         pathCheckVector(free, 'free', is.logical, 'logical')
303         pathCheckVector(labels, 'labels', is.character, 'character')
304         pathCheckVector(values, 'values', is.numeric, 'numeric')
305         pathCheckVector(lbound, 'lbound', is.numeric, 'numeric')
306         pathCheckVector(ubound, 'ubound', is.numeric, 'numeric')
307         generatePath(from, to, connect, arrows,
308                 values, free, labels, 
309                 lbound, ubound)
310 }
311
312 displayPath <- function(object) {
313         cat("mxPath", '\n')
314         cat("@from: ", omxQuotes(object@from), '\n')
315         cat("@to: ", omxQuotes(object@to), '\n')
316         cat("@arrows: ", object@arrows, '\n')
317         cat("@values: ", object@values, '\n')
318         cat("@free: ", object@free, '\n')
319         cat("@labels: ", object@labels, '\n')
320         cat("@lbound: ", object@lbound, '\n')
321         cat("@ubound: ", object@ubound, '\n')
322     cat("@connect: ", object@connect, '\n')
323 }
324
325 setMethod("print", "MxPath", function(x,...) { displayPath(x) })
326 setMethod("show", "MxPath", function(object) { displayPath(object) })