File: MxMatrixFunctions.R

package info (click to toggle)
r-cran-openmx 2.21.1%2Bdfsg-1
  • links: PTS, VCS
  • area: main
  • in suites: bookworm
  • size: 14,412 kB
  • sloc: cpp: 36,577; ansic: 13,811; fortran: 2,001; sh: 1,440; python: 350; perl: 21; makefile: 5
file content (120 lines) | stat: -rw-r--r-- 3,954 bytes parent folder | download | duplicates (3)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
#
#   Copyright 2007-2018 by the individuals mentioned in the source code history
#
#   Licensed under the Apache License, Version 2.0 (the "License");
#   you may not use this file except in compliance with the License.
#   You may obtain a copy of the License at
# 
#        http://www.apache.org/licenses/LICENSE-2.0
# 
#   Unless required by applicable law or agreed to in writing, software
#   distributed under the License is distributed on an "AS IS" BASIS,
#   WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
#   See the License for the specific language governing permissions and
#   limitations under the License.

componentCombination <- function(func, slotname, args) {
	args <- lapply(args, slot, slotname)
	return(do.call(func, args))
}

checkAnonymousFreeParameters <- function(mxmatrix) {
	if(any(is.na(mxmatrix@labels) & mxmatrix@free)) {
		msg <- paste("Anonymous free parameters are",
			"not allowed when 'allowUnlabeled' argument",
			"is FALSE.")
		stop(msg, call. = FALSE)
	}
}

omxCbind <- function(..., allowUnlabeled = 
		getOption("mxOptions")[["Allow Unlabeled"]], 
		dimnames = NA, name = NA) {

	args <- list(...)
	objcheck <- sapply(args, isS4)
	if (any(!objcheck)) {
		stop("All input arguments must be MxMatrix objects.")
	}
	objcheck <- sapply(args, is, "MxMatrix")
	if (any(!objcheck)) {
		stop("All input arguments must be MxMatrix objects.")
	}
	if (length(allowUnlabeled) != 1 || 
		!is.logical(allowUnlabeled) || 
		is.na(allowUnlabeled)) {
		stop("'allowUnlabeled' must be either TRUE or FALSE.")
	}
	if (!allowUnlabeled) {
		lapply(args, checkAnonymousFreeParameters)
	}
	values <- componentCombination(cbind, "values", args)
	free   <- componentCombination(cbind, "free", args)
	labels <- componentCombination(cbind, "labels", args)
	lbound <- componentCombination(cbind, "lbound", args)
	ubound <- componentCombination(cbind, "ubound", args)
	retval <- mxMatrix(type = "Full", free = free, 
		values = values, labels = labels, lbound = lbound,
		ubound = ubound, dimnames = dimnames, name = name)
	return(retval)
}

omxRbind <- function(..., allowUnlabeled = 
		getOption("mxOptions")[["Allow Unlabeled"]], 
		dimnames = NA, name = NA) {

	args <- list(...)
	objcheck <- sapply(args, isS4)
	if (any(!objcheck)) {
		stop("All input arguments must be MxMatrix objects.")
	}
	objcheck <- sapply(args, is, "MxMatrix")
	if (any(!objcheck)) {
		stop("All input arguments must be MxMatrix objects.")
	}
	if (length(allowUnlabeled) != 1 || 
		!is.logical(allowUnlabeled) || 
		is.na(allowUnlabeled)) {
		stop("'allowUnlabeled' must be either TRUE or FALSE.")
	}
	if (!allowUnlabeled) {
		lapply(args, checkAnonymousFreeParameters)
	}
	values <- componentCombination(rbind, "values", args)
	free   <- componentCombination(rbind, "free", args)
	labels <- componentCombination(rbind, "labels", args)
	lbound <- componentCombination(rbind, "lbound", args)
	ubound <- componentCombination(rbind, "ubound", args)
	retval <- mxMatrix(type = "Full", free = free, 
		values = values, labels = labels, lbound = lbound,
		ubound = ubound, dimnames = dimnames, name = name)
	return(retval)
}

omxTranspose <- function(matrix, allowUnlabeled = 
		getOption("mxOptions")[["Allow Unlabeled"]], 
		dimnames = NA, name = NA) {

	if (!isS4(matrix)) {
		stop("input argument must be a MxMatrix object.")
	}
	if (!is(matrix, "MxMatrix")) {
		stop("input argument must be a MxMatrix object.")
	}
	if (length(allowUnlabeled) != 1 || 
		!is.logical(allowUnlabeled) || 
		is.na(allowUnlabeled)) {
		stop("'allowUnlabeled' must be either TRUE or FALSE.")
	}
	if (!allowUnlabeled) {
		checkAnonymousFreeParameters(matrix)
	}
	values <- t(matrix@values)
	free   <- t(matrix@free)
	labels <- t(matrix@labels)
	lbound <- t(matrix@lbound)
	ubound <- t(matrix@ubound)
	retval <- mxMatrix(type = "Full", free = free, 
		values = values, labels = labels, lbound = lbound,
		ubound = ubound, dimnames = dimnames, name = name)
}