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.
omxLocateParameters <- function(model, labels = NULL, indep = FALSE,
free = c(TRUE, FALSE, NA)) {
if (identical(free, c(TRUE, FALSE, NA))) {
free <- TRUE
}
retval <- locateParametersInternal(model, labels, indep, free)
if (nrow(retval) > 0) {
retval <- retval[order(retval$label),]
}
rownames(retval) <- NULL
return(retval)
}
locateParametersInternal <- function(model, labels, indep, free) {
if (!is.null(labels) && !single.na(labels) && !is.character(labels)) {
stop("'labels' argument must be NULL or a character vector")
}
retval <- lapply(model@matrices, locateParametersHelper, model@name, labels, free)
retval <- do.call(rbind, retval)
if(indep) {
submodels <- model@submodels
} else {
submodels <- imxDependentModels(model)
}
if (length(submodels) > 0) {
subparams <- lapply(submodels, locateParametersInternal, labels, indep, free)
subparams <- do.call(rbind, subparams)
retval <- rbind(retval, subparams)
}
return(retval)
}
locateParametersHelper <- function(matrix, modelname, target, free) {
retval <- data.frame(label = character(0), model = character(0),
matrix = character(0), row = numeric(0),
col = numeric(0), value = numeric(0),
lbound = numeric(0), ubound = numeric(0),
stringsAsFactors = FALSE)
freeMask <- matrix@free
if (is.na(free)) freeMask[,] <- TRUE
else freeMask <- freeMask == free
count <- sum(freeMask)
if (count == 0) {
return(retval)
} else {
labels <- matrix@labels[freeMask]
rows <- row(freeMask)[freeMask]
cols <- col(freeMask)[freeMask]
values <- matrix@values[freeMask]
lbound <- matrix@lbound[freeMask]
ubound <- matrix@ubound[freeMask]
for(i in 1:count) {
pname <- labels[[i]]
if (is.null(target) || (is.na(pname) && any(is.na(target))) ||
pname %in% target) {
nextentry <- nrow(retval) + 1
retval[nextentry,'label'] <- pname
retval[nextentry,'model'] <- modelname
retval[nextentry,'matrix'] <- matrix@name
retval[nextentry,'row'] <- rows[[i]]
retval[nextentry,'col'] <- cols[[i]]
retval[nextentry,'value'] <- values[[i]]
retval[nextentry,'lbound'] <- lbound[[i]]
retval[nextentry,'ubound'] <- ubound[[i]]
}
}
}
return(retval)
}
omxGetParameters <- function(model, indep = FALSE, free = c(TRUE, FALSE, NA),
fetch = c('values', 'free', 'lbound', 'ubound', 'all'),
labels=c()) {
if (identical(free, c(TRUE, FALSE, NA))) {
free <- TRUE
}
if (identical(fetch, c('values', 'free', 'lbound', 'ubound', 'all'))) {
fetch <- 'values'
}
if (!is.logical(free) || length(free) != 1) {
stop("argument 'free' must be a 'TRUE', 'FALSE', or NA")
}
if (!is.character(fetch) || length(fetch) != 1 ||
!(fetch %in% c('values', 'free', 'lbound', 'ubound', 'all'))) {
stop("argument 'fetch' must be one of c('values', 'free', 'lbound', 'ubound', 'all')")
}
if (fetch == 'all') {
values <- omxGetParameters(model, indep, free, 'values', labels)
lbound <- omxGetParameters(model, indep, free, 'lbound', labels)
ubound <- omxGetParameters(model, indep, free, 'ubound', labels)
if (!is.na(free) && free) {
free <- rep.int(TRUE, length(values))
} else if (!is.na(free) && !free) {
free <- rep.int(FALSE, length(values))
} else {
free <- omxGetParameters(model, indep, free, 'free')
}
return(data.frame(values, free, lbound, ubound))
}
parameters <- lapply(names(model@matrices), getParametersHelper, model, free, fetch, labels)
plen <- lapply(parameters, length)
parameters[plen == 0] <- NULL
names(parameters) <- NULL
parameters <- unlist(parameters)
if(indep) {
submodels <- model@submodels
} else {
submodels <- imxDependentModels(model)
}
if (length(submodels) > 0) {
subparams <- lapply(submodels, omxGetParameters, indep, free, fetch, labels)
plen <- lapply(subparams, length)
subparams[plen == 0] <- NULL
names(subparams) <- NULL
subparams <- unlist(subparams)
parameters <- c(parameters, subparams)
}
if (length(parameters) == 0) return(parameters)
notDup1 <- !duplicated(names(parameters), incomparables = NA)
notDup2 <- !duplicated(names(parameters[!is.na(parameters)]), incomparables = NA)
if (sum(notDup1) == sum(notDup2)) {
# Filter out NAs when some instance of the parameter does have a value.
parameters <- parameters[!is.na(parameters)]
notDup1 <- notDup2
}
parameters <- parameters[notDup1]
return(parameters)
}
setParametersCheckVector <- function(values, test, argname, typename) {
if (is.null(values)) return()
if (!test(values)) {
stop(paste(omxQuotes(argname),
"argument must either be NA or a",
typename, "vector"), call. = FALSE)
}
}
omxSetParameters <- function(model, labels=names(coef(model)), free = NULL, values = NULL,
newlabels = NULL, lbound = NULL, ubound = NULL, indep = FALSE,
strict = TRUE, name = NULL) {
if (missing(labels) || !is.character(labels) || length(labels) == 0) {
stop("'labels' argument must be a character vector")
}
if (any(is.na(labels))) {
stop("'labels' argument must not contain NA values")
}
if (any(duplicated(labels))) {
stop("'labels' argument must not contain duplicate values")
}
if (!is.null(name) && length(name) != 1 && !is.character(name)) {
stop("'name' argument must be a character string")
}
if (missing(free) && missing(values) && missing(newlabels) &&
missing(lbound) && missing(ubound)) {
what <- c('free','values','newlabels','lbound','ubound')
warning(paste("What do you want to change?",
"Pick some of", omxQuotes(what)))
}
if (strict) {
pnames <- names(omxGetParameters(model, indep, NA))
missing <- setdiff(labels, pnames)
if (length(missing) > 0) {
msg <- paste("The following labels are",
"not present in the model",
"(use 'strict' = FALSE to ignore):",
omxQuotes(missing))
stop(msg)
}
}
if (is.vector(lbound) && length(lbound) > 0 && all(sapply(lbound, is.na))) {
lbound <- as.numeric(lbound)
}
if (is.vector(ubound) && length(ubound) > 0 && all(sapply(ubound, is.na))) {
ubound <- as.numeric(ubound)
}
setParametersCheckVector(free, is.logical, 'free', 'logical')
setParametersCheckVector(values, is.numeric, 'values', 'numeric')
setParametersCheckVector(newlabels, is.character, 'newlabels', 'character')
setParametersCheckVector(lbound, is.numeric, 'lbound', 'numeric')
setParametersCheckVector(ubound, is.numeric, 'ubound', 'numeric')
retval <- setParametersHelper(model, labels, free, values,
newlabels, lbound, ubound, indep)
if (!is.null(name)) {
retval <- mxRename(retval, name)
}
retval@.modifiedSinceRun <- TRUE
return(retval)
}
SBMatchHelper <- function(label, modelname) {
if (!hasSquareBrackets(label)) {
return(FALSE)
}
components <- splitSubstitution(label)
fullname <- unlist(strsplit(components[[1]], imxSeparatorChar, fixed = TRUE))
return(fullname[[1]] == modelname)
}
detectSBMatches <- function(model, labels) {
modelname <- model@name
targets <- which(sapply(labels, SBMatchHelper, modelname))
return(targets)
}
setParametersHelper <- function(model, labels, free, values,
newlabels, lbound, ubound, indep) {
squarebrackets <- detectSBMatches(model, labels)
model@matrices <- lapply(model@matrices, setParametersMatrix,
labels, free, values, newlabels, lbound, ubound)
if (length(squarebrackets) > 0) {
model <- setSquareBracketsHelper(model, squarebrackets, labels, free, values, newlabels, lbound, ubound)
}
if(indep) {
if (length(model@submodels) == 0) {
return(model)
}
model@submodels <- lapply(model@submodels, setParametersHelper,
labels, free, values, newlabels, lbound, ubound, indep)
} else {
select <- imxDependentModels(model)
if (length(select) == 0) {
return(model)
}
select <- lapply(select, setParametersHelper,
labels, free, values, newlabels, lbound, ubound, indep)
model@submodels <- c(select, imxIndependentModels(model))
}
return(model)
}
extractFirst <- function(x) {
return(x[[1]])
}
extractSecond <- function(x) {
return(x[[2]])
}
##' omxNameAnonymousParameters
##'
##' Assign new names to the unnamed parameters
##'
##' @param model the MxModel
##' @param indep whether models are independent
##' @return
##' a list with components for the new MxModel with named parameters, and the new names.
omxNameAnonymousParameters <- function(model, indep = FALSE) {
rows <- lapply(model@matrices, getAnonymousRows)
cols <- lapply(model@matrices, getAnonymousCols)
newnames <- mapply(getAnonymousNames, rows)
model@matrices <- mapply(assignAnonymousNames, model@matrices, rows, cols, newnames)
newnames <- unlist(newnames)
if(indep) {
if (length(model@submodels) == 0) {
return(list(model, newnames))
}
pairs <- lapply(model@submodels, omxNameAnonymousParameters, indep)
submodels <- lapply(pairs, extractFirst)
subnames <- unlist(lapply(pairs, extractSecond))
names(submodels) <- names(model@submodels)
model@submodels <- submodels
newnames <- c(newnames, subnames)
} else {
select <- imxDependentModels(model)
if (length(select) == 0) {
return(list(model, newnames))
}
pairs <- lapply(select, omxNameAnonymousParameters, indep)
submodels <- lapply(pairs, extractFirst)
subnames <- unlist(lapply(pairs, extractSecond))
names(submodels) <- names(select)
model@submodels <- c(select, imxIndependentModels(model))
newnames <- c(newnames, subnames)
}
return(list(model, newnames))
}
getAnonymousRows <- function(matrix) {
select <- matrix@free & is.na(matrix@labels)
if (imxSymmetricMatrix(matrix)) {
select <- select & upper.tri(matrix@labels, diag=TRUE)
}
return(row(matrix@free)[select])
}
getAnonymousCols <- function(matrix) {
select <- matrix@free & is.na(matrix@labels)
if (imxSymmetricMatrix(matrix)) {
select <- select & upper.tri(matrix@labels, diag=TRUE)
}
return(col(matrix@free)[select])
}
assignAnonymousNames <- function(matrix, rows, cols, newnames) {
symmetry <- imxSymmetricMatrix(matrix)
if (length(rows) > 0) {
for(i in 1:length(rows)) {
row <- rows[[i]]
col <- cols[[i]]
newname <- newnames[[i]]
matrix@labels[row,col] <- newname
if (symmetry) {
matrix@labels[col,row] <- newname
}
}
}
return(matrix)
}
getAnonymousNames <- function(rows) {
return(replicate(length(rows), imxUntitledName()))
}
omxAssignFirstParameters <- function(model, indep = FALSE) {
params <- omxGetParameters(model, indep, fetch='all')
if (!nrow(params)) return(model)
model <- omxSetParameters(model, rownames(params),
values = params$value, lbound = params$lbound, ubound = params$ubound, indep = indep)
model
}
getParametersHelper <- function(matName, model, selection, fetch, labels) {
amatrix <- model@matrices[[matName]]
modelname <- model@name
if (single.na(selection)) {
select <- amatrix@free | !is.na(amatrix@labels)
} else if (selection) {
select <- amatrix@free
} else {
select <- !amatrix@free & !is.na(amatrix@labels)
}
if (length(labels)) for (lx in 1:length(labels)) {
l1 <- labels[lx]
if (hasSquareBrackets(l1)) {
loc <- splitSubstitution(l1)
fullname <- unlist(strsplit(loc[[1]], imxSeparatorChar, fixed = TRUE))
if (fullname[[1]] == modelname && fullname[[2]] == matName) {
select[as.integer(loc[2]), as.integer(loc[3])] <- TRUE
}
} else {
select <- select | (!is.na(amatrix@labels) & amatrix@labels == l1)
}
}
if (all(!select)) {
return(numeric())
}
if (imxSymmetricMatrix(amatrix)) {
triangle <- upper.tri(select, diag=TRUE)
select <- select & triangle
}
theNames <- amatrix@labels[select]
if (any(is.na(theNames))) {
rows <- row(select)[select]
cols <- col(select)[select]
for(i in 1:length(theNames)) {
if (is.na(theNames[[i]])) {
theNames[[i]] <- paste(modelname, ".", amatrix@name,
"[", rows[i], ",", cols[i], "]", sep ="")
}
}
}
if (fetch == "values") {
theValues <- amatrix@values[select]
} else if (fetch == "lbound") {
theValues <- amatrix@lbound[select]
} else if (fetch == "ubound") {
theValues <- amatrix@ubound[select]
} else if (fetch == "free") {
theValues <- amatrix@free[select]
}
names(theValues) <- theNames
return(theValues[!duplicated(theNames)])
}
#Need to use $ instead of @ accessor for all slots that can be condensed:
setParametersMatrix <- function(amatrix, names, free, values, newlabels, lbound, ubound) {
labels <- amatrix@labels
locations <- which(labels %in% names)
indices <- match(labels[locations], names)
if (!is.null(free)) {
index2 <- ((indices - 1) %% length(free)) + 1
amatrix$free[locations] <- as.logical(free[index2])
}
if (!is.null(values)) {
index2 <- ((indices - 1) %% length(values)) + 1
amatrix@values[locations] <- as.numeric(values[index2])
}
if (!is.null(newlabels)) {
index2 <- ((indices - 1) %% length(newlabels)) + 1
amatrix$labels[locations] <- as.character(newlabels[index2])
}
if (!is.null(lbound)) {
index2 <- ((indices - 1) %% length(lbound)) + 1
amatrix$lbound[locations] <- as.numeric(lbound[index2])
}
if (!is.null(ubound)) {
index2 <- ((indices - 1) %% length(ubound)) + 1
amatrix$ubound[locations] <- as.numeric(ubound[index2])
}
return(amatrix)
}
setSquareBracketsHelper <- function(model, squarebrackets, labels,
free, values, newlabels, lbound, ubound) {
for(i in 1:length(squarebrackets)) {
nextbracket <- squarebrackets[[i]]
nextlabel <- labels[[nextbracket]]
components <- splitSubstitution(nextlabel)
fullname <- unlist(strsplit(components[[1]], imxSeparatorChar, fixed = TRUE))
matrixname <-fullname[[2]]
row <- as.numeric(components[[2]])
col <- as.numeric(components[[3]])
amatrix <- model[[matrixname]]
if (!is.null(amatrix) || !is(amatrix, "MxMatrix")) {
isSymmetric <- imxSymmetricMatrix(amatrix)
if (!is.null(free)) {
index2 <- ((nextbracket - 1) %% length(free)) + 1
amatrix$free[row,col] <- as.logical(free[index2])
if (isSymmetric) {
amatrix$free[col,row] <- as.logical(free[index2])
}
}
if (!is.null(values)) {
index2 <- ((nextbracket - 1) %% length(values)) + 1
amatrix@values[row,col] <- as.numeric(values[index2])
if (isSymmetric) {
amatrix@values[col,row] <- as.numeric(values[index2])
}
}
if (!is.null(newlabels)) {
index2 <- ((nextbracket - 1) %% length(newlabels)) + 1
amatrix$labels[row,col] <- as.character(newlabels[index2])
if (isSymmetric) {
amatrix$labels[col,row] <- as.character(newlabels[index2])
}
}
if (!is.null(lbound)) {
index2 <- ((nextbracket - 1) %% length(lbound)) + 1
amatrix$lbound[row,col] <- as.numeric(lbound[index2])
if (isSymmetric) {
amatrix$lbound[col,row] <- as.numeric(lbound[index2])
}
}
if (!is.null(ubound)) {
index2 <- ((nextbracket - 1) %% length(ubound)) + 1
amatrix$ubound[row,col] <- as.numeric(ubound[index2])
if (isSymmetric) {
amatrix$ubound[col,row] <- as.numeric(ubound[index2])
}
}
model[[matrixname]] <- amatrix
}
}
return(model)
}
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.