Updated copyright to 2013 for R/ demo/ models/passing and src/ folders, and also...
[openmx:openmx.git] / R / MxMatrixFunctions.R
1 #
2 #   Copyright 2007-2013 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 componentCombination <- function(func, slotname, args) {
17         args <- lapply(args, slot, slotname)
18         return(do.call(func, args))
19 }
20
21 checkAnonymousFreeParameters <- function(mxmatrix) {
22         if(any(is.na(mxmatrix@labels) & mxmatrix@free)) {
23                 msg <- paste("Anonymous free parameters are",
24                         "not allowed when 'allowUnlabeled' argument",
25                         "is FALSE.")
26                 stop(msg, call. = FALSE)
27         }
28 }
29
30 omxCbind <- function(..., allowUnlabeled = 
31                 getOption("mxOptions")[["Allow Unlabeled"]], 
32                 dimnames = NA, name = NA) {
33
34         args <- list(...)
35         objcheck <- sapply(args, isS4)
36         if (any(!objcheck)) {
37                 stop("All input arguments must be MxMatrix objects.")
38         }
39         objcheck <- sapply(args, is, "MxMatrix")
40         if (any(!objcheck)) {
41                 stop("All input arguments must be MxMatrix objects.")
42         }
43         if (length(allowUnlabeled) != 1 || 
44                 !is.logical(allowUnlabeled) || 
45                 is.na(allowUnlabeled)) {
46                 stop("'allowUnlabeled' must be either TRUE or FALSE.")
47         }
48         if (!allowUnlabeled) {
49                 lapply(args, checkAnonymousFreeParameters)
50         }
51         values <- componentCombination(cbind, "values", args)
52         free   <- componentCombination(cbind, "free", args)
53         labels <- componentCombination(cbind, "labels", args)
54         lbound <- componentCombination(cbind, "lbound", args)
55         ubound <- componentCombination(cbind, "ubound", args)
56         retval <- mxMatrix(type = "Full", free = free, 
57                 values = values, labels = labels, lbound = lbound,
58                 ubound = ubound, dimnames = dimnames, name = name)
59         return(retval)
60 }
61
62 omxRbind <- function(..., allowUnlabeled = 
63                 getOption("mxOptions")[["Allow Unlabeled"]], 
64                 dimnames = NA, name = NA) {
65
66         args <- list(...)
67         objcheck <- sapply(args, isS4)
68         if (any(!objcheck)) {
69                 stop("All input arguments must be MxMatrix objects.")
70         }
71         objcheck <- sapply(args, is, "MxMatrix")
72         if (any(!objcheck)) {
73                 stop("All input arguments must be MxMatrix objects.")
74         }
75         if (length(allowUnlabeled) != 1 || 
76                 !is.logical(allowUnlabeled) || 
77                 is.na(allowUnlabeled)) {
78                 stop("'allowUnlabeled' must be either TRUE or FALSE.")
79         }
80         if (!allowUnlabeled) {
81                 lapply(args, checkAnonymousFreeParameters)
82         }
83         values <- componentCombination(rbind, "values", args)
84         free   <- componentCombination(rbind, "free", args)
85         labels <- componentCombination(rbind, "labels", args)
86         lbound <- componentCombination(rbind, "lbound", args)
87         ubound <- componentCombination(rbind, "ubound", args)
88         retval <- mxMatrix(type = "Full", free = free, 
89                 values = values, labels = labels, lbound = lbound,
90                 ubound = ubound, dimnames = dimnames, name = name)
91         return(retval)
92 }
93
94 omxTranspose <- function(matrix, allowUnlabeled = 
95                 getOption("mxOptions")[["Allow Unlabeled"]], 
96                 dimnames = NA, name = NA) {
97
98         if (!isS4(matrix)) {
99                 stop("input argument must be a MxMatrix object.")
100         }
101         if (!is(matrix, "MxMatrix")) {
102                 stop("input argument must be a MxMatrix object.")
103         }
104         if (length(allowUnlabeled) != 1 || 
105                 !is.logical(allowUnlabeled) || 
106                 is.na(allowUnlabeled)) {
107                 stop("'allowUnlabeled' must be either TRUE or FALSE.")
108         }
109         if (!allowUnlabeled) {
110                 checkAnonymousFreeParameters(matrix)
111         }
112         values <- t(matrix@values)
113         free   <- t(matrix@free)
114         labels <- t(matrix@labels)
115         lbound <- t(matrix@lbound)
116         ubound <- t(matrix@ubound)
117         retval <- mxMatrix(type = "Full", free = free, 
118                 values = values, labels = labels, lbound = lbound,
119                 ubound = ubound, dimnames = dimnames, name = name)
120 }