Nothing
#
# 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.
deparseVector <- function(vec) {
if (is.character(vec)) {
inner <- paste(sapply(vec, omxQuotes), collapse = ", ")
} else {
inner <- paste(vec, collapse = ", ")
}
return(paste("c(", inner, ")", sep = ""))
}
deparseDimnames <- function(dimnames) {
if (is.null(dimnames[[1]])) {
rownames <- "NULL"
} else {
rownames <- deparseVector(dimnames[[1]])
}
if (is.null(dimnames[[2]])) {
colnames <- "NULL"
} else {
colnames <- deparseVector(dimnames[[2]])
}
return(paste("list(", rownames,
", ", colnames, ")", sep = ""))
}
##' Deparse for MxObjects
##'
##' @param object object
##' @param indent indent
##' @aliases
##' imxDeparse,IdenMatrix-method
##' imxDeparse,MxAlgebra-method
##' imxDeparse,MxConstraint-method
##' imxDeparse,MxData-method
##' imxDeparse,MxMatrix-method
##' imxDeparse,UnitMatrix-method
##' imxDeparse,ZeroMatrix-method
##' imxDeparse,matrix-method
setGeneric("imxDeparse", function(object, indent = ' ') {
return(standardGeneric("imxDeparse"))
})
setMethod("imxDeparse", "MxAlgebra",
function(object, indent = ' ') {
return(paste("mxAlgebra", "(",
deparse(object@formula), ", name = ",
omxQuotes(object@name), ")", sep = ""))
}
)
setMethod("imxDeparse", "MxConstraint",
function(object, indent = ' ') {
return(paste("mxConstraint", "(",
omxQuotes(object@alg1), ", ",
omxQuotes(object@relation), ", ",
omxQuotes(object@alg2), ", ",
"name=", omxQuotes(object@name),
")", sep = ""))
}
)
setMethod("imxDeparse", "MxData",
function(object, indent = ' ') {
if (is.na(object@means)) {
means <- "NA"
} else {
means <- "..."
}
if (is.na(object@numObs)) {
numObs <- as.character(object@numObs)
} else {
numObs <- "NA"
}
return(paste("mxData", "(",
"observed = ...", ", ",
"type = ", omxQuotes(object@type), ", ",
"means = ", means, ", ",
"numObs = ", numObs, ")", sep = ""))
}
)
setMethod("imxDeparse", "matrix",
function(object, indent = ' ') {
if (nrow(object) == 0 || ncol(object) == 0) {
return(paste("matrix(nrow = ",
nrow(object), ", ncol = ",
ncol(object), ")", sep = ""))
}
first <- object[1,1]
if (all(apply(object, c(1,2), identical, first))) {
return(paste("matrix(", first,
", nrow = ", nrow(object),
", ncol = ", ncol(object), ")", sep = ""))
}
return(paste("matrix(", deparseVector(c(t(object))),
", nrow = ", nrow(object),
", ncol = ", ncol(object),
", byrow = TRUE)", sep = ""))
}
)
setMethod("imxDeparse", "ZeroMatrix",
function(object, indent = ' ') {
return(paste("mxMatrix(type = 'Zero', nrow = ",
nrow(object), ", ncol = ",
ncol(object), ", name = ",
omxQuotes(object@name), ")", sep = ""))
}
)
setMethod("imxDeparse", "UnitMatrix",
function(object, indent = ' ') {
return(paste("mxMatrix(type = 'Unit', nrow = ",
nrow(object), ", ncol = ",
ncol(object), ", name = ",
omxQuotes(object@name), ")", sep = ""))
}
)
setMethod("imxDeparse", "IdenMatrix",
function(object, indent = ' ') {
return(paste("mxMatrix(type = 'Iden', nrow = ",
nrow(object), ", ncol = ",
ncol(object), ", name = ",
omxQuotes(object@name), ")", sep = ""))
}
)
matrixNAdefault <- function(object, location, retval) {
if (all(is.na(object))) {
} else if (all(apply(object, c(1,2), identical, object[1,1]))) {
if (is.character(object)) {
retval <- paste(retval, ", ", location, " = ",
omxQuotes(object[1,1]), sep = "")
} else {
retval <- paste(retval, ", ", location, " = ",
object[1,1], sep = "")
}
} else {
retval <- paste(retval, ", ", location, " = ",
deparseVector(c(t(object@labels))), sep = "")
}
return(retval)
}
setMethod("imxDeparse", "MxMatrix",
function(object, indent = ' ') {
type <- sub("Matrix", "", class(object)[[1]], fixed = TRUE)
retval <- paste("mxMatrix(", omxQuotes(type), sep = "")
retval <- paste(retval, ", ", nrow(object),
", ", ncol(object), sep = "")
if (all(object@free)) {
retval <- paste(retval, ", free = TRUE", sep = "")
} else if (any(object@free)) {
retval <- paste(retval, ", free = ",
deparseVector(c(t(object@free))), sep = "")
}
if (all(object@values == 0)) {
} else if (all(object@values == object@values[1,1])) {
retval <- paste(retval, ", values = ",
object@values[1,1], sep = "")
} else {
retval <- paste(retval, ", values = ",
deparseVector(c(t(object@values))), sep = "")
}
retval <- matrixNAdefault(object@labels, "labels", retval)
retval <- matrixNAdefault(object@lbound, "lbound", retval)
retval <- matrixNAdefault(object@ubound, "ubound", retval)
retval <- paste(retval, ", byrow = TRUE", sep = "")
if (!is.null(dimnames(object))) {
retval <- paste(retval, ", dimnames = ", deparseDimnames(dimnames(object)), sep = "")
}
retval <- paste(retval, ", name = ", omxQuotes(object@name), sep = "")
retval <- paste(retval, ')', sep = "")
return(retval)
}
)
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.