#
# Copyright 2007-2020 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 = "MxConstraint",
representation = representation(
name = "character",
formula = "MxAlgebraFormula",
alg1 = "MxCharOrNumber",
alg2 = "MxCharOrNumber",
relation = "MxCharOrNumber",
jac = "MxCharOrNumber",
linear = "logical",
strict = "logical",
verbose = "integer"
))
setMethod("initialize", "MxConstraint",
function(.Object, name, formula, jac=character(0), verbose, strict){#, linear=FALSE) {
.Object@name <- name
.Object@formula <- formula
.Object@alg1 <- as.character(NA)
.Object@alg2 <- as.character(NA)
.Object@relation <- as.character(NA)
#if(linear && is.null(jac)){stop("linear constraints must be provided with a Jacobian")}
.Object@jac <- jac
.Object@linear <- FALSE
.Object@verbose <- verbose
.Object@strict <- strict
return(.Object)
}
)
mxConstraintFromString <- function(exprString, name = NA,...) {
eval(substitute(mxConstraint(tExp, name=name, ...),
list(tExp = parse(text=exprString)[[1]])))
}
mxConstraint <- function(expression, name=NA, ..., jac=character(0), verbose=0L, strict=TRUE){#, linear=FALSE) {
prohibitDotdotdot(list(...))
if (single.na(name)) {
name <- imxUntitledName()
}
imxVerifyName(name, 0)
if (typeof(name) != "character") {
stop(paste("Name argument is not a string",
"(the name of the constraint)"))
}
formula <- match.call()$expression
if (length(formula) != 3) {
stop(paste("A constraint must be of the form:",
omxQuotes("exp1 [<, ==, >] exp2")),
call. = FALSE)
}
relation <- as.character(formula[[1]])
if (!(relation %in% imxConstraintRelations)) {
stop(paste("A constraint must be of the form:",
omxQuotes("exp1 [<, ==, >] exp2")),
call. = FALSE)
}
algebraErrorChecking(formula[[2]], "mxConstraint")
algebraErrorChecking(formula[[3]], "mxConstraint")
return(new("MxConstraint", name, formula, jac, as.integer(verbose),
as.logical(strict)))#, linear))
}
convertConstraints <- function(flatModel) {
return(lapply(flatModel@constraints, function(x) {
convertSingleConstraint(x, flatModel)}))
}
convertSingleConstraint <- function(constraint, flatModel) {
index1 <- imxLocateIndex(flatModel, constraint@alg1,
constraint@name)
index2 <- imxLocateIndex(flatModel, constraint@alg2,
constraint@name)
index3 <- match(constraint@relation, imxConstraintRelations)
if(is.na(index3)) {
clist <- paste(imxConstraintRelations,
collapse = ",")
msg <- paste("The relation for constraint",
omxQuotes(constraint@name),
"is not in the following list:",
clist)
stop(msg, call.=FALSE)
}
index4 <- imxLocateIndex(flatModel, constraint@jac, constraint@name)
lin <- FALSE
return(list(index1,index2,index3 - 1,index4,lin,
constraint@verbose, constraint@strict))
}
##' imxConstraintRelations
##'
##' A string vector of valid constraint binary relations.
imxConstraintRelations <- c("<", "==", ">")
setMethod("$", "MxConstraint", imxExtractSlot)
setReplaceMethod("$", "MxConstraint",
function(x, name, value) {
return(imxReplaceSlot(x, name, value, check=TRUE))
}
)
setMethod("names", "MxConstraint", slotNames)
displayConstraint <- function(object) {
cat("MxConstraint", omxQuotes(object@name), '\n')
cat("$formula: ", deparse(object@formula, width.cutoff=500L), '\n')
}
setMethod("print", "MxConstraint", function(x,...) { displayConstraint(x) })
setMethod("show", "MxConstraint", function(object) { displayConstraint(object) })
##' imxHasConstraint
##'
##' This is an internal function exported for those people who know
##' what they are doing. This function checks if a model (or its
##' submodels) has at least one MxConstraint.
##'
##' @param model model
imxHasConstraint <- function(model) {
if(length(model$constraints) > 0 ){
return(TRUE)
}
# Check submodels for constraints
if(length(model$submodels) > 0){
attempt <- sapply(model@submodels, imxHasConstraint)
if(any(attempt)){
return(TRUE)
}
}
return(FALSE)
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.