R/DefinitionVars.R

Defines functions populateDefVarMatrix populateDefInitialValues definitionStartingValue

#
#   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.

definitionStartingValue <- function(defName, matrixName, flatModel, defvar.row = 1) {
	components <- unlist(strsplit(defName, imxSeparatorChar, fixed = TRUE))
	dataName <- paste(components[[1]], components[[2]], sep = '.')
	dataSet <- flatModel@datasets[[dataName]]
	if(is.null(dataSet)) {
		stop(paste("Could not find the dataset", 
			"associated with model", omxQuotes(flatModel@name),
			"used by the definition variable", 
			omxQuotes(simplifyName(defName, flatModel@name))),
			call. = FALSE)
	}
	if (!(components[[3]] %in% colnames(dataSet@observed))) {
		stop(paste("Could not find the column name", omxQuotes(components[[3]]),
			"in the dataset", omxQuotes(simplifyName(dataName, flatModel@name)), 
			"used by the definition variable", 
			omxQuotes(simplifyName(defName, flatModel@name))),
			call. = FALSE)
	}
	if (defvar.row < 1 || defvar.row > nrow(dataSet@observed)) {
		stop(paste("Row number", omxQuotes(defvar.row),
			"is out of bounds for definition variable",
			omxQuotes(simplifyName(defName, flatModel@name)), 
			"used in the context of",
			omxQuotes(simplifyName(matrixName, flatModel@name)),
			"\nOne possibility is you didn't add this variable to the data for this group?"
		), call. = FALSE)
	}
	return(dataSet@observed[defvar.row, components[[3]], drop=TRUE])
}

populateDefInitialValues <- function(flatModel) {
	matrices <- flatModel@matrices
	flatModel@matrices <- lapply(flatModel@matrices, populateDefVarMatrix, flatModel)
	return(flatModel)
}

populateDefVarMatrix <- function(matrix, model, defvar.row = 1) {
	labels <- matrix@labels
	notNA <- !is.na(labels)
	if (!any(notNA)) { return(matrix) }
	rows <- row(labels)[notNA]
	cols <- col(labels)[notNA]
	subs <- labels[notNA]
	select <- sapply(subs, imxIsDefinitionVariable)
	if (!any(select)) { return(matrix) }
	rows <- rows[select]
	cols <- cols[select]
	subs <- subs[select]
	value <- matrix@values
	for(i in 1:length(subs)) {
		startValue <- definitionStartingValue(subs[[i]], matrix@name, model, defvar.row)
		value[rows[[i]],cols[[i]]] <- startValue
	}
	matrix@values <- value
	return(matrix)
}

Try the OpenMx package in your browser

Any scripts or data that you put into this service are public.

OpenMx documentation built on Nov. 8, 2023, 1:08 a.m.