Some code cleanup for the mxPath() 'connect' argument.
[openmx:openmx.git] / R / MxPath.R
1 #
2 #   Copyright 2007-2010 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         bivariate <- FALSE
64         self      <- FALSE
65         
66         # interpret 'connect' argument
67         if ((connect == "unique.pairs" ) || (connect == "unique.bivariate")){
68                 bivariate <- TRUE
69         }
70         if ((connect == "all.bivariate") || (connect == "unique.bivariate")){
71                 self <- 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 (bivariate){
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 (self){
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)) {
200                 stop(paste("The", omxQuotes(valname), 
201                         "argument to mxPath must be a",
202                         type, "vector."), 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) && !single.na(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                 stop(msg)
219         }
220         garbageArguments <- list(...)
221         extraArgument <- garbageArguments[['all']]
222         if (!is.null(extraArgument)) {
223                 stop("The 'all' argument to mxPath ",
224                         "has been deprecated. It has been replaced ",
225                         "with the safer interface 'connect' in OpenMx 1.2. ",
226                         "See ?mxPath for more information.")
227         }
228         if (length(garbageArguments) > 0) {
229                 msg <- paste("mxPath does not accept values",
230                                 "for the '...' argument.",
231                                 "See ?mxPath for more information.")
232                 stop(msg)
233     }
234         if (identical(connect, c("single", "all.pairs", "unique.pairs", 
235                     "all.bivariate", "unique.bivariate"))) {
236                 connect <- "single"
237         }
238         if (length(connect) != 1 || single.na(connect)) {
239                 msg <- paste("'connect' must be one of",
240                                 "'single', 'all.pairs', 'unique.pairs',",
241                     "'all.bivariate', or 'unique.bivariate'")
242                 stop(msg)
243         }
244         if (identical(connect, "all.pairs") && identical(arrows, 2)) {
245                 msg <- paste("'connect=all.pairs' argument cannot",
246                                         "be used with 'arrows=2.',",
247                                         "Please use 'connect=unique.pairs'.")
248                 stop(msg)
249         }
250         if (identical(connect, "all.bivariate") && identical(arrows, 2)) {
251                 msg <- paste("'connect=all.bivariate' argument cannot",
252                                         "be used with 'arrows=2'.",
253                                         "Please use 'connect=unique.bivariate'.")
254                 stop(msg)
255         }
256         if (!identical(connect, "single") && length(arrows) != 1) {
257                 msg <- paste("multiple values for the 'arrows' argument are",
258                                 "not allowed when the 'connect' argument",
259                                 "is not equal to 'single'")
260                 stop(msg)
261         }
262         if (all.na(to)) { to <- as.character(to) }
263         if (all.na(from)) { from <- as.character(from) }
264         if (all.na(values)) { values <- as.numeric(values) }
265         if (all.na(labels)) { labels <- as.character(labels) }
266         if (all.na(lbound)) { lbound <- as.numeric(lbound) }
267         if (all.na(ubound)) { ubound <- as.numeric(ubound) }
268         if (all.na(connect)) { connect <- as.character(connect) }       
269         pathCheckVector(from, 'from', is.character, 'character')
270         pathCheckVector(to, 'to', is.character, 'character')
271         pathCheckVector(arrows, 'arrows', is.numeric, 'numeric')
272         pathCheckVector(free, 'free', is.logical, 'logical')
273         pathCheckVector(labels, 'labels', is.character, 'character')
274         pathCheckVector(values, 'values', is.numeric, 'numeric')
275         pathCheckVector(lbound, 'lbound', is.numeric, 'numeric')
276         pathCheckVector(ubound, 'ubound', is.numeric, 'numeric')
277         generatePath(from, to, connect, arrows,
278                 values, free, labels, 
279                 lbound, ubound)
280 }
281
282 displayPath <- function(object) {
283         cat("mxPath", '\n')
284         cat("@from: ", omxQuotes(object@from), '\n')
285         cat("@to: ", omxQuotes(object@to), '\n')
286         cat("@arrows: ", object@arrows, '\n')
287         cat("@values: ", object@values, '\n')
288         cat("@free: ", object@free, '\n')
289         cat("@labels: ", object@labels, '\n')
290         cat("@lbound: ", object@lbound, '\n')
291         cat("@ubound: ", object@ubound, '\n')
292 }
293
294 setMethod("print", "MxPath", function(x,...) { displayPath(x) })
295 setMethod("show", "MxPath", function(object) { displayPath(object) })