Changed printing of 0x0 matrices to produce informative message.
[openmx:openmx.git] / R / MxAlgebra.R
1 #
2 #   Copyright 2007-2009 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 setClassUnion("MxListOrNull", c("list", "NULL"))
17 setClassUnion("MxAlgebraFormula", c("call", "name", "logical"))
18
19 setClass(Class = "MxAlgebra",
20         representation = representation(
21                 formula = "MxAlgebraFormula",
22                 name = "character",
23                 dirty = "logical",
24                 .dimnames = "MxListOrNull",
25                 result = "matrix"))
26                 
27 setMethod("initialize", "MxAlgebra",
28         function(.Object, formula, name) {
29                 .Object@formula <- sys.call(which=-3)[[3]]
30                 .Object@name <- name
31                 .Object@dirty <- FALSE
32                 .Object@.dimnames <- NULL
33                 return(.Object)
34         }
35 )
36
37 setMethod("dimnames", "MxAlgebra",
38         function(x) { x@.dimnames }
39 )
40
41 setReplaceMethod("dimnames", "MxAlgebra",
42         function(x, value) {
43                 if (is.null(value)) {
44                 } else if (!is.list(value)) {
45                         stop("dimnames of MxAlgebra object must be either NULL or list of length 2")
46                 } else if (length(value) != 2) {
47                         stop("dimnames of MxAlgebra object must be either NULL or list of length 2")
48                 }
49                 x@.dimnames <- value
50                 return(x)
51         }
52 )
53
54 mxAlgebra <- function(expression, name = NA, dimnames = NA) {
55         if (is.na(name)) {
56                 name <- omxUntitledName()
57         }
58         omxVerifyName(name)
59         retval <- new("MxAlgebra", NA, name)
60         retval@formula <- match.call()$expression
61         if(!(length(dimnames) == 1 && is.na(dimnames))) {
62                 dimnames(retval) <- dimnames
63         }
64         return(retval)  
65 }
66
67 defStringsAsFactors <- getOption('stringsAsFactors')
68 options(stringsAsFactors = FALSE)
69 data(omxSymbolTable)
70 options(stringsAsFactors = defStringsAsFactors)
71
72
73 formulaList <- function(x) {
74         retval <- as.list(x)
75         retval <- lapply(retval, function(x) {
76                 if(is.call(x)) {formulaList(x)} else {x}
77         })
78         return(retval)
79 }
80
81 algebraNumericCheck <- function(formula, name) {
82         formula <- unlist(formulaList(formula))
83         test <- sapply(formula, is.numeric)
84         if(any(test)) {
85                 msg <- paste("There is a numeric operand in",
86                         "the algebra named", omxQuotes(name))
87                 stop(msg, call. = FALSE)
88         }
89 }
90
91 algebraSymbolCheck <- function(formula, name) {
92         formula <- unlist(formulaList(formula))
93         test <- sapply(formula, function(x) {!is.numeric(x)})
94         if(length(formula[test]) == 1) {
95                 msg <- paste("The reference", omxQuotes(formula[test]),
96                         "is unknown in the algebra named", omxQuotes(name))
97                 stop(msg, call. = FALSE)
98         } else if (length(formula[test]) > 1) {
99                 msg <- paste("The references", omxQuotes(formula[test]),
100                         "are unknown in the algebra named", omxQuotes(name))
101                 stop(msg, call. = FALSE)                
102         }
103 }
104
105 generateAlgebraHelper <- function(algebra, matrixNames, algebraNames) {
106         retval <- algebra@formula
107         algebraNumericCheck(retval, algebra@name)
108         matrixNumbers <- as.list(as.double(-1 : (-length(matrixNames))))
109         algebraNumbers <- as.list(as.double(0 : (length(algebraNames) - 1)))
110         names(matrixNumbers) <- matrixNames
111         names(algebraNumbers) <- algebraNames
112         retval <- eval(substitute(substitute(e, matrixNumbers), list(e = retval)))
113         retval <- eval(substitute(substitute(e, algebraNumbers), list(e = retval)))
114         retval <- substituteOperators(as.list(retval))
115         algebraSymbolCheck(retval, algebra@name)
116         return(retval)
117 }
118
119 substituteOperators <- function(algebra) {
120         if ((length(algebra) == 1) && (is.list(algebra))) {
121                 algebra <- list(0, algebra[[1]])
122         } else if ((length(algebra) > 1) && (!is.numeric(algebra[[1]]))) {
123                 if (as.character(algebra[[1]]) == '(') {
124                         return(substituteOperators(as.list(algebra[[2]])))
125                 }
126                 names <- omxSymbolTable["R.name"] == as.character(algebra[[1]])
127         variableSymbols <- omxSymbolTable["Number.of.arguments"] == -1
128                 result <- omxSymbolTable[names & variableSymbols, "Num"]
129                 if (length(result) > 1) {
130                                 stop(paste("Ambiguous function with name", algebra[[1]],
131                                         "and", (length(algebra) - 1), "arguments"))
132                 } else if(length(result) == 1) {
133                         head <- as.double(result[[1]])
134                         tail <- lapply(algebra[-1], substituteOperators)
135                         result <- append(tail, head, after=0)
136                         return(result)
137                 } else {
138                         length <- omxSymbolTable["Number.of.arguments"] == (length(algebra) - 1)
139                         result <- omxSymbolTable[names & length, "Num"]
140                         if (length(result) == 0) {
141                                 stop(paste("Could not find function with name", algebra[[1]],
142                                         "and", (length(algebra) - 1), "arguments"))
143                         } else if (length(result) > 1) {
144                                 stop(paste("Ambiguous function with name", algebra[[1]],
145                                         "and", (length(algebra) - 1), "arguments"))
146                         } else {
147                                 head <- as.double(result[[1]])
148                             tail <- lapply(algebra[-1], substituteOperators)
149                                 result <- append(tail, head, after=0)
150                                 return(result)
151                         }
152         }
153         }
154         return(algebra)
155 }
156
157 displayAlgebra <- function(mxAlgebra) {
158         cat("mxAlgebra", omxQuotes(mxAlgebra@name), '\n')
159         cat("@formula: ", deparse(mxAlgebra@formula, width.cutoff=500L), '\n')
160         if (length(mxAlgebra@result) == 0) {
161                 cat("@result: (not yet computed) ")
162         } else {
163                 cat("@result:\n")
164         }
165         print(mxAlgebra@result)
166         if (is.null(dimnames(mxAlgebra))) {
167                         cat("dimnames: NULL\n")
168         } else {
169                 cat("dimnames:\n")
170                 print(dimnames(mxAlgebra))
171         }
172 }
173
174 setMethod("print", "MxAlgebra", function(x,...) { displayAlgebra(x) })
175 setMethod("show", "MxAlgebra", function(object) { displayAlgebra(object) })