Began implementation of a namespace for models.
[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
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                 result = "matrix"))
25                 
26 setMethod("initialize", "MxAlgebra",
27         function(.Object, formula, name) {
28                 .Object@formula <- sys.call(which=-3)[[3]]
29                 .Object@name <- name
30                 .Object@dirty <- FALSE
31                 return(.Object)
32         }
33 )
34
35 mxAlgebra <- function(expression, name = NA) {
36         if (is.na(name)) {
37                 name <- omxUntitledName()
38         }
39         omxVerifyName(name)
40         retval <- new("MxAlgebra", NA, name)
41         retval@formula <- match.call()$expression
42         return(retval)  
43 }
44
45 defStringsAsFactors <- getOption('stringsAsFactors')
46 options(stringsAsFactors = FALSE)
47 data(omxSymbolTable)
48 options(stringsAsFactors = defStringsAsFactors)
49
50
51 omxFormulaList <- function(x) {
52         retval <- as.list(x)
53         retval <- lapply(retval, function(x) {
54                 if(is.call(x)) {omxFormulaList(x)} else {x}
55         })
56         return(retval)
57 }
58
59 omxNumericCheck <- function(formula, name) {
60         formula <- unlist(omxFormulaList(formula))
61         test <- sapply(formula, is.numeric)
62         if(any(test)) {
63                 msg <- paste("There is a numeric operand in",
64                         "the algebra named", omxQuotes(name))
65                 stop(msg, call. = FALSE)
66         }
67 }
68
69 omxSymbolCheck <- function(formula, name) {
70         formula <- unlist(omxFormulaList(formula))
71         test <- sapply(formula, function(x) {!is.numeric(x)})
72         if(length(formula[test]) == 1) {
73                 msg <- paste("The reference", omxQuotes(formula[test]),
74                         "is unknown in the algebra named", omxQuotes(name))
75                 stop(msg, call. = FALSE)
76         } else if (length(formula[test]) > 1) {
77                 msg <- paste("The references", omxQuotes(formula[test]),
78                         "are unknown in the algebra named", omxQuotes(name))
79                 stop(msg, call. = FALSE)                
80         }
81 }
82
83 generateAlgebraHelper <- function(algebra, matrixNames, algebraNames) {
84         retval <- algebra@formula
85         omxNumericCheck(retval, algebra@name)
86         matrixNumbers <- as.list(as.double(-1 : (-length(matrixNames))))
87         algebraNumbers <- as.list(as.double(0 : (length(algebraNames) - 1)))
88         names(matrixNumbers) <- matrixNames
89         names(algebraNumbers) <- algebraNames
90         retval <- eval(substitute(substitute(e, matrixNumbers), list(e = retval)))
91         retval <- eval(substitute(substitute(e, algebraNumbers), list(e = retval)))
92         retval <- substituteOperators(as.list(retval))
93         omxSymbolCheck(retval, algebra@name)
94         return(retval)
95 }
96
97 substituteOperators <- function(algebra) {
98         if ((length(algebra) == 1) && (is.list(algebra))) {
99                 algebra <- list(0, algebra[[1]])
100         } else if ((length(algebra) > 1) && (!is.numeric(algebra[[1]]))) {
101                 names <- omxSymbolTable["R.name"] == as.character(algebra[[1]])
102         variableSymbols <- omxSymbolTable["Number.of.arguments"] == -1
103                 result <- omxSymbolTable[names & variableSymbols, "Num"]
104                 if (length(result) > 1) {
105                                 stop(paste("Ambiguous function with name", algebra[[1]],
106                                         "and", (length(algebra) - 1), "arguments"))
107                 } else if(length(result) == 1) {
108                         head <- as.double(result[[1]])
109                         tail <- lapply(algebra[-1], substituteOperators)
110                         result <- append(tail, head, after=0)
111                         return(result)
112                 } else {
113                         length <- omxSymbolTable["Number.of.arguments"] == (length(algebra) - 1)
114                         result <- omxSymbolTable[names & length, "Num"]
115                         if (length(result) == 0) {
116                                 stop(paste("Could not find function with name", algebra[[1]],
117                                         "and", (length(algebra) - 1), "arguments"))
118                         } else if (length(result) > 1) {
119                                 stop(paste("Ambiguous function with name", algebra[[1]],
120                                         "and", (length(algebra) - 1), "arguments"))
121                         } else {
122                                 head <- as.double(result[[1]])
123                             tail <- lapply(algebra[-1], substituteOperators)
124                                 result <- append(tail, head, after=0)
125                                 return(result)
126                         }
127         }
128         }
129         return(algebra)
130 }