Nothing
#
# Copyright 2007-2021 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.
setClass(Class = "MxPath",
representation = representation(
from = "character",
to = "character",
arrows = "numeric",
values = "numeric",
free = "logical",
labels = "character",
lbound = "numeric",
ubound = "numeric",
connect = "character",
joinKey = "character",
step="MxOptionalInteger"
))
setMethod("initialize", "MxPath",
function(.Object, from, to, arrows, values,
free, labels, lbound, ubound, connect, joinKey, step) {
.Object@from <- from
.Object@to <- to
.Object@arrows <- arrows
.Object@values <- values
.Object@free <- free
.Object@labels <- labels
.Object@lbound <- lbound
.Object@ubound <- ubound
.Object@connect <- connect
.Object@joinKey <- joinKey
.Object@step <- step
return(.Object)
}
)
setMethod("$", "MxPath", imxExtractSlot)
setReplaceMethod("$", "MxPath",
function(x, name, value) {
stop("Changing path values directly is not recommended. Please use the mxPath() function to set path values.")
}
)
setMethod("names", "MxPath", slotNames)
expandPathConnect <- function(from, to, connect) {
# now expand the paths to check for errors
excludeBivariate <- FALSE
excludeSelf <- FALSE
# interpret 'connect' argument
if ((connect == "unique.pairs" ) || (connect == "unique.bivariate")){
excludeBivariate <- TRUE
}
if ((connect == "all.bivariate") || (connect == "unique.bivariate")){
excludeSelf <- TRUE
}
# if a variable is a connect = "single" then it does not need to be expanded
if ((connect != "single")){
from <- rep(from, each=length(to))
to <- rep(to, length(from)/length(to))
exclude <- rep(FALSE, length(from))
# if 'excluderedundant', then exclude b,a if a,b is present
if (excludeBivariate){
sortedPairs <- t(apply(matrix(c(from, to), ncol = 2), 1, sort))
exclude <- exclude | duplicated(sortedPairs)
}
# if 'excludeself', then exclude x,x paths
if (excludeSelf){
exclude <- exclude | (from==to)
}
from <- from[!exclude]
to <- to[!exclude]
}
return(list(from=from,to=to))
}
# returns a list of paths
generatePath <- function(from, to,
connect, arrows, values, free,
labels, lbound, ubound, joinKey, step) {
# save exactly what the user typed to pass to mxModel for creation
unalteredTo <- to
unalteredFrom <- from
# check if user employed the loop shortcut by only specifying from
if (single.na(to)) {
loop <- TRUE
to <- from
} else {
loop <- FALSE
}
expanded <- expandPathConnect(from, to, connect)
from <- expanded$from
to <- expanded$to
if (max(length(from), length(to)) == 0 && length(values) <= 1 &&
length(free) <= 1 && length(labels) <= 1 && length(lbound) <= 1 &&
length(ubound) <= 1 && length(joinKey) <= 1) return(NULL)
# check for a missing to or from
pathCheckToAndFrom(from, to)
if(any(labels %in% "one")){
warning("It is unwise to use the word 'one' as a label.\n",
"That has a special meaning, as it used in 'from = \"one\", ' in means paths.\n",
"See help(mxPath) to learn about mxPaths and labels")
}
# check the labels for illegal references
lapply(labels, imxVerifyReference, -1)
# check for length mismatches
pathCheckLengths(from, to, arrows, values, free, labels, lbound, ubound, loop)
numBounds <- max(length(lbound), length(ubound))
for (bx in 1:numBounds) {
l1 <- lbound[ 1 + (bx-1) %% length(lbound) ]
u1 <- ubound[ 1 + (bx-1) %% length(ubound) ]
if (!is.na(l1) && !is.na(u1) && l1 >= u1) {
stop(paste("Lower bound", l1, "is greater than or equal to upper bound", u1))
}
}
# create a new MxPath in the MxModel
return(new("MxPath", unalteredFrom, unalteredTo, arrows, values, free, labels, lbound, ubound, connect, joinKey, step))
}
pathCheckToAndFrom <- function(from, to){
# check for a missing to or from
if (any(is.na(from)) || any(is.na(to))) {
stop("The \'from\' field or the \'to\' field contains an NA", call. = FALSE)
}
}
pathCheckLengths <- function(from, to, arrows, values,
free, labels, lbound, ubound, loop) {
numPaths <- max(length(from), length(to))
pathCheckSingleLength(numPaths, length(arrows), "arrows", from, to, loop)
pathCheckSingleLength(numPaths, length(values), "values", from, to, loop)
pathCheckSingleLength(numPaths, length(free), "free/fixed designations", from, to, loop)
pathCheckSingleLength(numPaths, length(labels), "labels", from, to, loop)
pathCheckSingleLength(numPaths, length(lbound), "lbounds", from, to, loop)
pathCheckSingleLength(numPaths, length(ubound), "ubounds", from, to, loop)
}
pathCheckSingleLength <- function(numPaths, len, lenName, from, to, loop) {
if (numPaths < len) {
if (loop) { to <- NA }
stop(paste("mxPath() call will generate",
numPaths, "paths but you have specified",
len, lenName, "with 'from' argument assigned to", omxQuotes(from),
"and 'to' argument assigned to", omxQuotes(to)), call. = FALSE)
}
}
##' imxIsPath
##'
##' This is an internal function exported for those people who know
##' what they are doing.
##'
##' @param value value
imxIsPath <- function(value) {
return(is.list(value) &&
!is.null(value[['from']]) &&
!is.null(value[['to']]))
}
matrixToPaths <- function(mxMatrix, arrows = c(1,2)) {
values <- mxMatrix@values
free <- mxMatrix@free
labels <- mxMatrix@labels
if (arrows == 2) {
values[upper.tri(values)] <- 0
free[upper.tri(free)] <- FALSE
labels[upper.tri(labels)] <- as.character(NA)
}
select <- (values != 0) | (free) | (!is.na(labels))
if (length(select) > 0) {
rowFactors <- row(values, as.factor=TRUE)
colFactors <- col(values, as.factor=TRUE)
fromNames <- as.character(colFactors[select])
toNames <- as.character(rowFactors[select])
if (length(fromNames) > 0 && length(toNames) > 0) {
return(mxPath(from = fromNames, to = toNames, arrows = arrows))
}
}
return(list())
}
meansToPaths <- function(mxMatrix) {
if (is.null(mxMatrix)) return(list())
values <- mxMatrix@values
free <- mxMatrix@free
labels <- mxMatrix@labels
select <- (values != 0) | (free) | (!is.na(labels))
if (length(select) > 0) {
colFactors <- col(values, as.factor=TRUE)
toNames <- as.character(colFactors[select])
if (length(toNames) > 0) {
return(mxPath(from = 'one', to = toNames, arrows = 1))
}
}
return(list())
}
pathCheckVector <- function(value, valname, check, type) {
if (!is.vector(value) || !check(value) || length(value) == 0) {
stop(paste("The", omxQuotes(valname),
"argument to mxPath must be a",
type, "vector of length > 0 in",
deparse(width.cutoff = 400L, imxLocateFunction("mxPath")),
omxQuotes(valname), "argument had class", class(value), "and length", length(value)
), call. = FALSE)
}
}
mxPath <- function(from, to = NA,
connect = c("single", "all.pairs", "unique.pairs",
"all.bivariate", "unique.bivariate"), arrows = 1,
free = TRUE, values = NA, labels = NA, lbound = NA, ubound = NA, ...,
joinKey=as.character(NA), step=c()) {
if (missing(from)) {
stop("The 'from' argument to mxPath must have a value.")
}
if (is.logical(connect)) {
msg <- paste("The 'all' argument to mxPath ",
"has been deprecated. It has been replaced ",
"with the safer interface 'connect' in OpenMx 1.2. ",
"See ?mxPath for more information.")
# throw an error if 'all' has illegal value
if ((length(connect) != 1) || single.na(connect)) {
stop(msg)
} else {
warning(msg)
}
}
garbageArguments <- list(...)
allArgument <- garbageArguments[['all']]
if (!is.null(allArgument)) {
msg <- paste("The 'all' argument to mxPath ",
"has been deprecated. It has been replaced ",
"with the safer interface 'connect' in OpenMx 1.2. ",
"See ?mxPath for more information.")
# throw an error if 'all' has illegal value
if (!(is.logical(allArgument) &&
(length(allArgument) == 1) &&
!single.na(allArgument))) {
stop(msg)
# throw an error if 'all' and 'connect' are both specified
} else if (!identical(connect,
c("single", "all.pairs", "unique.pairs",
"all.bivariate", "unique.bivariate"))) {
stop(msg)
} else {
warning(msg)
connect <- allArgument
}
} else if (length(garbageArguments) > 0) {
msg <- paste("mxPath does not accept",
omxQuotes(names(garbageArguments)),
"as argument(s) and",
"does not accept values",
"for the '...' argument.",
"See ?mxPath for more information.")
stop(msg)
}
if (identical(connect, c("single", "all.pairs", "unique.pairs",
"all.bivariate", "unique.bivariate"))) {
connect <- "single"
}
# eliminate this test when "all" argument is eliminated
if (is.logical(connect)) {
if (connect) {
connect <- "all.pairs"
} else {
connect <- "single"
}
} else {
if (!(length(connect) == 1 && !single.na(connect) &&
is.character(connect) && (connect %in%
c("single", "all.pairs", "unique.pairs",
"all.bivariate", "unique.bivariate")))) {
msg <- paste("'connect' must be one of",
"'single', 'all.pairs', 'unique.pairs',",
"'all.bivariate', or 'unique.bivariate'")
stop(msg)
}
if (identical(connect, "all.pairs") && identical(arrows, 2)) {
msg <- paste("'connect=all.pairs' argument cannot",
"be used with 'arrows=2.',",
"Please use 'connect=unique.pairs'.")
stop(msg)
}
if (identical(connect, "all.bivariate") && identical(arrows, 2)) {
msg <- paste("'connect=all.bivariate' argument cannot",
"be used with 'arrows=2'.",
"Please use 'connect=unique.bivariate'.")
stop(msg)
}
if (!identical(connect, "single") && length(arrows) != 1) {
msg <- paste("multiple values for the 'arrows' argument are",
"not allowed when the 'connect' argument",
"is not equal to 'single'")
stop(msg)
}
}
if (length(joinKey) > 1) {
msg <- paste("cannot only joinKey a single foreign key, not",
length(joinKey))
stop(msg)
}
if (!is.na(joinKey)) {
if (any(arrows != 1)) {
msg <- paste("between level join mappings can only use single",
"headed arrows")
stop(msg)
}
}
if (length(step)) {
step <- as.integer(step)
if (identical(arrows, 0) || (length(arrows) == length(step) &&
all(arrows[!is.na(step)] == 0))) {
# OK
} else {
stop(paste("step can only be provided for arrows=0 paths"))
}
}
if (length(step)==0 && any(arrows==0)) {
step <- rep(NA_integer_, length(arrows))
step[arrows==0] <- 1L # default step
}
if (isAllNa(to)) { to <- as.character(to) }
if (isAllNa(from)) { from <- as.character(from) }
if (isAllNa(values)) { values <- as.numeric(values) }
if (isAllNa(labels)) { labels <- as.character(labels) }
if (isAllNa(lbound)) { lbound <- as.numeric(lbound) }
if (isAllNa(ubound)) { ubound <- as.numeric(ubound) }
if (isAllNa(connect)) { connect <- as.character(connect) }
pathCheckVector(from, 'from', is.character, 'character')
pathCheckVector(to, 'to', is.character, 'character')
pathCheckVector(arrows, 'arrows', is.numeric, 'numeric')
pathCheckVector(free, 'free', is.logical, 'logical')
pathCheckVector(labels, 'labels', is.character, 'character')
if(!nchar0(labels)){
stop("Found illegal label '', i.e. the empty label. Give us a real label, love.")
}
pathCheckVector(values, 'values', is.numeric, 'numeric')
pathCheckVector(lbound, 'lbound', is.numeric, 'numeric')
pathCheckVector(ubound, 'ubound', is.numeric, 'numeric')
if (any(arrows==0)) pathCheckVector(step, 'step', is.numeric, 'numeric')
generatePath(from, to, connect, arrows,
values, free, labels,
lbound, ubound, joinKey, step)
}
nchar0 <- function(x){
all(nchar(x) > 0 | is.na(x))
}
prepPath <- function(path) {
path@values[ is.na(path@values) ] <- 0
if (single.na(path@to)) {
# convert model.var -> var
path@to <- sapply(path@from, function(x) {
pieces <- strsplit(x, imxSeparatorChar, fixed = TRUE)[[1]]
ifelse(length(pieces) == 2, pieces[2], pieces[1])
}, USE.NAMES = FALSE)
}
expanded <- expandPathConnect(path@from, path@to, path@connect)
path@from <- expanded$from
path@to <- expanded$to
path
}
displayPath <- function(object) {
cat(paste0("mxPath", '\n'))
path <- prepPath(object)
allfrom <- path@from
allto <- path@to
allarrows <- path@arrows
allfree <- path@free
allvalues <- path@values
alllabels <- path@labels
alllbound <- path@lbound
allubound <- path@ubound
allstep <- path@step
maxlength <- max(length(allfrom), length(allto))
for(i in 0:(maxlength - 1)) {
from <- allfrom[[i %% length(allfrom) + 1]]
to <- allto[[i %% length(allto) + 1]]
arrows <- allarrows[[i %% length(allarrows) + 1]]
nextvalue <- allvalues[[i %% length(allvalues) + 1]]
nextfree <- allfree[[i %% length(allfree) + 1]]
nextlabel <- alllabels[[i %% length(alllabels) + 1]]
nextubound <- allubound[[i %% length(allubound) + 1]]
nextlbound <- alllbound[[i %% length(alllbound) + 1]]
nextjoinkey <- path@joinKey[[i %% length(path@joinKey) + 1]]
nextstep <- ifelse(length(allstep)==0, NA, allstep[[i %% length(allstep) + 1]])
cat(from)
cat(paste0(' ', ifelse(arrows==1, "->", "<->"), ' '))
cat(to)
cat(paste0(" [value=",nextvalue))
cat(paste0(", free=",nextfree))
if (!is.na(nextlabel)) {
cat(paste0(", label='", nextlabel,"'"))
}
if (!is.na(nextlbound)) {
cat(paste0(", lbound=", nextlbound))
}
if (!is.na(nextubound)) {
cat(paste0(", ubound=", nextubound))
}
if (!is.na(nextjoinkey)) {
cat(paste0(", joinKey=", nextjoinkey))
}
if (!is.na(nextstep)) {
cat(paste0(", step=", nextstep))
}
cat("]")
cat('\n')
}
}
setMethod("print", "MxPath", function(x,...) { displayPath(x) })
setMethod("show", "MxPath", function(object) { displayPath(object) })
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.