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
121
122
123
|
#
# Copyright 2007-2019 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.
# deprecated
# nocov start
##' omxRAMtoML
##'
##' Convert a RAM model to an ML model
##'
##' @param model the MxModel
##' @details
##' This is a legacy function that was once used to convert RAM models to ML models
##' in the old (1.0 release of OpenMx) objective function style.
##' @return
##' an ML model with an ML objective
omxRAMtoML <- function(model) {
namespace <- imxGenerateNamespace(model)
job <- shareData(model)
return(RAMtoMLHelper(model, job, namespace))
}
RAMtoMLHelper <- function(model, job, namespace) {
model <- convertRAMtoMLModel(model, job, namespace)
if (length(model@submodels) > 0) {
model@submodels <- lapply(model@submodels, RAMtoMLHelper, job, namespace)
}
return(model)
}
createNewName <- function(model, namespace, suggestedName) {
if (availableName(model, namespace, suggestedName)) {
return(suggestedName)
} else {
return(paste(suggestedName, imxUntitledName(), sep = '_'))
}
}
convertRAMtoMLModel <- function(model, job, namespace) {
objective <- model$objective
if (is.null(objective)) {
return(model)
}
if (!is(objective, "MxRAMObjective")) {
return(model)
}
modelname <- model@name
aName <- imxConvertIdentifier(objective@A, modelname, namespace)
sName <- imxConvertIdentifier(objective@S, modelname, namespace)
fName <- imxConvertIdentifier(objective@F, modelname, namespace)
mName <- imxConvertIdentifier(objective@M, modelname, namespace)
iName <- createNewName(model, namespace, 'I')
model <- mxModel(model, mxMatrix(type="Iden",
nrow = nrow(job[[aName]]), name = iName))
zName <- createNewName(model, namespace, 'Z')
zFormula <- substitute(solve(I - A),
list(I = as.symbol(iName), A = as.symbol(aName)))
algebra <- eval(substitute(mxAlgebra(x, y), list(x = zFormula, y = zName)))
model <- mxModel(model, algebra)
covName <- createNewName(model, namespace, 'covariance')
covFormula <- substitute(F %*% Z %*% S %*% t(Z) %*% t(F),
list(F = as.symbol(fName), Z = as.symbol(zName),
S = as.symbol(sName)))
algebra <- eval(substitute(mxAlgebra(x, y),
list(x = covFormula, y = covName)))
model <- mxModel(model, algebra)
if(!single.na(mName)) {
meansFormula <- substitute(t(F %*% Z %*% t(M)),
list(F = as.symbol(fName), Z = as.symbol(zName),
M = as.symbol(mName)))
meansName <- createNewName(model, namespace, 'means')
algebra <- eval(substitute(mxAlgebra(x, y),
list(x = meansFormula, y = meansName)))
model <- mxModel(model, algebra)
}
translatedNames <- modelManifestNames(job[[fName]]@values, modelname)
dataset <- job[[modelname]]@data
if (dataset@type == 'raw') {
objectiveType <- as.symbol('mxFIMLObjective')
if (is.na(mName)) {
objective <- eval(substitute(obj(covariance = x,
thresholds = z, vector = w, dimnames = u),
list(x = covName, z = objective@thresholds,
w = objective@vector, u = translatedNames, obj = objectiveType)))
} else {
objective <- eval(substitute(obj(covariance = x,
means = y, thresholds = z, vector = w, dimnames = u),
list(x = covName, y = meansName, z = objective@thresholds,
w = objective@vector, u = translatedNames, obj = objectiveType)))
}
} else {
objectiveType <- as.symbol('mxMLObjective')
if (is.na(mName)) {
objective <- eval(substitute(obj(covariance = x,
thresholds = z, dimnames = u),
list(x = covName, z = objective@thresholds,
u = translatedNames, obj = objectiveType)))
} else {
objective <- eval(substitute(obj(covariance = x,
means = y, thresholds = z, dimnames = u),
list(x = covName, y = meansName, z = objective@thresholds,
u = translatedNames, obj = objectiveType)))
}
}
model@objective <- objective
class(model) <- 'MxModel'
return(model)
}
# nocov end
|
