The changes in MxRAMModel.R and MxPath.R reflect the new connect slot which replaces...
[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         # intepret 'connect' argument
67         if ((connect[1]=="unique.pairs" )|(connect[1]=="unique.bivariate")){bivariate <- TRUE}
68         if ((connect[1]=="all.bivariate")|(connect[1]=="unique.bivariate")){self <- TRUE}
69         
70         # if a variable is a connect = "single" then it does not need to be expanded
71         if ((connect[1] !="single")){ 
72         
73                 from <- rep(from, each=length(to))
74                 to   <- rep(to, length(from)/length(to))
75
76                 exclude <- rep(FALSE, length(from))
77
78                 # if 'excluderedundant', then exclude b,a if a,b is present
79                 if (bivariate){
80                         sortedPairs <- t(apply(matrix(c(from, to), ncol = 2), 1, sort))
81                         exclude <- exclude | duplicated(sortedPairs)
82                 }
83
84                 # if 'excludeself', then exclude x,x paths
85                 if (self){
86                         exclude <- exclude | (from==to)
87                 }
88                 
89                 from <- from[!exclude]
90                 to   <- to[!exclude]
91                 
92         }       
93         
94         # check for a missing to or from
95         pathCheckToAndFrom(from, to)
96         
97         # check for length mismatches
98         pathCheckLengths(from, to, arrows, values, free, labels, lbound, ubound, loop)
99         
100         # create a new MxPath in the MxModel
101         return(new("MxPath", unalteredFrom, unalteredTo, arrows, values, free, labels, lbound, ubound, connect))
102 }
103
104 pathCheckToAndFrom <- function(from, to){
105         # check for a missing to or from
106         if (any(is.na(from)) || any(is.na(to))) {
107                 stop("The \'from\' field or the \'to\' field contains an NA", call. = FALSE)
108         }
109 }
110
111 pathCheckLengths <- function(from, to, arrows, values, 
112         free, labels, lbound, ubound, loop) {
113     numPaths <- max(length(from), length(to))
114     pathCheckSingleLength(numPaths, length(arrows), "arrows", from, to, loop)
115     pathCheckSingleLength(numPaths, length(values), "values", from, to, loop)
116     pathCheckSingleLength(numPaths, length(free), "free/fixed designations", from, to, loop)
117     pathCheckSingleLength(numPaths, length(labels), "labels", from, to, loop)
118     pathCheckSingleLength(numPaths, length(lbound), "lbounds", from, to, loop)
119     pathCheckSingleLength(numPaths, length(ubound), "ubounds", from, to, loop)
120 }
121
122 pathCheckSingleLength <- function(numPaths, len, lenName, from, to, loop) {
123     if (numPaths < len) {
124         if (loop) { to <- NA }
125         stop(paste("mxPath() call will generate", 
126             numPaths, "paths but you have specified",
127             len, lenName, "with 'from' argument assigned to", omxQuotes(from),
128             "and 'to' argument assigned to", omxQuotes(to)), call. = FALSE)
129     }
130 }
131
132
133 generateSinglePath <- function(from, to, 
134                 arrows, values, free,
135                 labels, lbound, ubound) {
136         result <- list()
137         result[['from']] <- from
138         result[['to']] <- to
139         result[['arrows']] <- arrows[[1]]
140         result[['values']] <- values[[1]]       
141         result[['free']] <- free[[1]]
142         result[['labels']] <- labels[[1]]       
143         result[['lbound']] <- lbound[[1]]
144         result[['ubound']] <- ubound[[1]]
145         return(result)
146 }
147
148 imxIsPath <- function(value) {
149         return(is.list(value) && 
150                 !is.null(value[['from']]) &&
151                 !is.null(value[['to']]))
152 }
153
154 matrixToPaths <- function(mxMatrix, arrows = c(1,2)) {
155         values <- mxMatrix@values
156         free <- mxMatrix@free
157         labels <- mxMatrix@labels
158         if (arrows == 2) {
159                 values[upper.tri(values)] <- 0
160                 free[upper.tri(free)] <- FALSE
161                 labels[upper.tri(labels)] <- as.character(NA)
162         }
163         select <- (values != 0) | (free) | (!is.na(labels))
164         if (length(select) > 0) {
165             rowFactors <- row(values, as.factor=TRUE)
166             colFactors <- col(values, as.factor=TRUE)   
167                 fromNames <- as.character(colFactors[select])
168                 toNames <- as.character(rowFactors[select])
169                 if (length(fromNames) > 0 && length(toNames) > 0) {
170                         return(mxPath(from = fromNames, to = toNames, arrows = arrows))
171                 }
172         }
173         return(list())
174 }
175
176 meansToPaths <- function(mxMatrix) {
177         if (is.null(mxMatrix)) return(list())
178         values <- mxMatrix@values
179         free <- mxMatrix@free
180         labels <- mxMatrix@labels
181         select <- (values != 0) | (free) | (!is.na(labels))
182         if (length(select) > 0) {
183             colFactors <- col(values, as.factor=TRUE)
184                 toNames <- as.character(colFactors[select])
185                 if (length(toNames) > 0) {
186                         return(mxPath(from = 'one', to = toNames, arrows = 1))
187                 }
188         }
189         return(list())
190 }
191
192 pathCheckVector <- function(value, valname, check, type) {
193         if (!is.vector(value) || !check(value)) {
194                 stop(paste("The", omxQuotes(valname), 
195                         "argument to mxPath must be a",
196                         type, "vector."), call. = FALSE)
197         }
198 }
199
200 mxPath <- function(from, to = NA, 
201         connect = c("single", "all.pairs", "unique.pairs", 
202                     "all.bivariate", "unique.bivariate"), arrows = 1, 
203         free = TRUE, values = NA, labels = NA, lbound = NA, ubound = NA, ...) {
204         if (missing(from)) {
205                 stop("The 'from' argument to mxPath must have a value.")
206         }
207         if ((connect == TRUE) || (connect == FALSE)) {
208                 msg <- paste("The 'all' argument to mxPath ",
209                         "has been deprecated. It has been replaced ",
210                         "with the safer interface 'connect' in OpenMx 1.2. ",
211                         "See ?mxPath for more information.")
212                 stop(msg)
213         }
214         garbageArguments <- list(...)
215         if (length(garbageArguments) > 0) {
216                                 extraArgument <- garbageArguments[[1]]
217                                 if (extraArgument==TRUE || extraArgument==FALSE){
218                                 stop("The 'all' argument to mxPath ",
219                                         "has been deprecated. It has been replaced ",
220                                         "with the safer interface 'connect' in OpenMx 1.2. ",
221                                         "See ?mxPath for more information.")
222                                 }
223                                 else{
224                         stop("mxPath does not accept values for the '...' argument. See ?mxPath for more information.")
225                                 }       
226     }
227         if (is.vector(connect) && length(connect) > 0 && 
228             connect[1]=="all.pairs" && arrows==2) {
229                 msg <- paste("'connect=all.pairs' argument cannot be used with 'arrows=2' Please use 'connect=unique.pairs'.")
230                 stop(msg)
231         }
232         if (is.vector(connect) && length(connect) > 0 && 
233             connect[1]=="all.bivariate" && arrows==2) {
234                 msg <- paste("'connect=all.bivariate' argument cannot be used with 'arrows=2'. Please use 'connect=unique.bivariate'.")
235                 stop(msg)
236         }
237         if (is.vector(connect) && length(connect) == 5 && 
238             connect[1] == "single" && connect[2] == "all.pairs" &&
239             connect[3] == "unique.pairs" && connect[4] == "all.bivariate" &&
240             connect[5] == "unique.bivariate") {
241                  # if the value of 'connect' is the vector of 5 values,
242                  # then make it equal to "single"
243                 connect = "single"
244         }
245         if (all.na(to)) { to <- as.character(to) }
246         if (all.na(from)) { from <- as.character(from) }
247         if (all.na(values)) { values <- as.numeric(values) }
248         if (all.na(labels)) { labels <- as.character(labels) }
249         if (all.na(lbound)) { lbound <- as.numeric(lbound) }
250         if (all.na(ubound)) { ubound <- as.numeric(ubound) }
251         if (all.na(connect)) { connect <- as.character(connect) }       
252         pathCheckVector(from, 'from', is.character, 'character')
253         pathCheckVector(to, 'to', is.character, 'character')
254         pathCheckVector(arrows, 'arrows', is.numeric, 'numeric')
255         pathCheckVector(free, 'free', is.logical, 'logical')
256         pathCheckVector(labels, 'labels', is.character, 'character')
257         pathCheckVector(values, 'values', is.numeric, 'numeric')
258         pathCheckVector(lbound, 'lbound', is.numeric, 'numeric')
259         pathCheckVector(ubound, 'ubound', is.numeric, 'numeric')
260         generatePath(from, to, connect, arrows,
261                 values, free, labels, 
262                 lbound, ubound)
263 }
264
265 displayPath <- function(object) {
266         cat("mxPath", '\n')
267         cat("@from: ", omxQuotes(object@from), '\n')
268         cat("@to: ", omxQuotes(object@to), '\n')
269         cat("@arrows: ", object@arrows, '\n')
270         cat("@values: ", object@values, '\n')
271         cat("@free: ", object@free, '\n')
272         cat("@labels: ", object@labels, '\n')
273         cat("@lbound: ", object@lbound, '\n')
274         cat("@ubound: ", object@ubound, '\n')
275 }
276
277 setMethod("print", "MxPath", function(x,...) { displayPath(x) })
278 setMethod("show", "MxPath", function(object) { displayPath(object) })