Nothing
#' @include semspec.R
{}
SEMREPR_CLASS <- "semrepr"
is_semrepr <- function(object) {
any(class(object) %in% SEMREPR_CLASS)
}
#' @export
semrepr <- function(object) {
stopifnot(is_semspec(object))
ret <- expand_semspec(object$model)
ret <- flatten_semspec(ret)
if ( !is.null(object$dataset) ) {
group <- unique(ret$group)
group <- group[!is.na(group)]
levels <- lapply(object$dataset[group], levels)
ret <- expand_semrepr_data(ret, levels)
}
if ( !is.null(object$constraints) ) {
ret <- expand_semrepr_constraints(ret, object$constraints)
}
structure(ret, class = c(SEMREPR_CLASS, class(ret)))
}
### Expand semspec model: ############################################
expand_semspec <- function(object) {
expand <- function(x) {
attrs <- attributes(x)
group <- find_group(x)
if ( !is.null(group) ) {
x <- remove_group(x)
}
x <- expand_formula(x)
if ( !is.null(group) ) {
f <- sprintf("%s | %s", deparse(x), deparse(group))
x <- as.formula(f, env = environment(x))
}
attributes(x) <- attrs
x
}
object$regression <- lapply(object$regression, expand)
object$latent <- lapply(object$latent, expand)
object
}
find_group <- function(term) {
## A bar is always on the right hand side.
if ( (length(term[[3]]) >= 3) && term[[3]][[1]] == as.name("|") )
term[[3]][[3]]
else
NULL
}
remove_group <- function(term) {
## We assume that there is a group on the right hand side, when
## calling this function.
f <- paste(deparse(term[[2]]), deparse(term[[1]]),
deparse(term[[3]][[2]]), collapse = "")
as.formula(f, env = environment(term))
}
expand_formula <- function(term) {
## We want to expand both sides of a formula.
if ( length(term) == 2 ) {
rhs <- expand_term(term[[2]])
f <- sprintf("~ %s", deparse(rhs))
}
if ( length(term) == 3 ) {
rhs <- expand_term(term[[3]])
lhs <- expand_term(term[[2]])
f <- sprintf("%s ~ %s", deparse(lhs), deparse(rhs))
}
as.formula(f, env = environment(term))
}
expand_term <- function(term) {
stopifnot(is.language(term))
term <- formula(paste("~", deparse(term)))
t <- terms(term)
t <- attr(t, "term.labels")
t <- paste(t, collapse = " + ")
as.formula(sprintf("~ %s", t))[[2]]
}
### Flatten semspec model: ###########################################
flatten_semspec <- function(object) {
group <- object$group
object$group <- NULL
ret <- list()
for ( n in names(object) ) {
ret[[n]] <- lapply(object[[n]], flatten_formula, n)
ret[[n]] <- do.call(rbind, ret[[n]])
}
ret <- do.call(rbind, ret)
rownames(ret) <- NULL
if ( !is.null(group) ) {
ret$group[is.na(ret$group)] <- as.character(group)
}
ret
}
flatten_formula <- function(term, type) {
param <- attr(term, "param")
group <- find_group(term)
if ( !is.null(group) ) {
term <- remove_group(term)
group <- as.character(group)
} else {
group <- NA_character_
}
lhs <- as.character(flatten_term(term[[2]]))
rhs <- as.character(flatten_term(term[[3]]))
ret <- expand.grid(type = type, lhs = lhs,
rhs = rhs, lhsparam = NA_character_,
rhsparam = NA_character_, group = group,
stringsAsFactors = FALSE)
attr(ret, "out.attrs") <- NULL
lhsparam <- ret$lhs
rhsparam <- ret$rhs
if ( !is.null(param) ) {
ml <- match(lhsparam, names(param), nomatch = 0)
mr <- match(rhsparam, names(param), nomatch = 0)
lhsparam[lhsparam %in% names(param)] <- param[ml]
rhsparam[rhsparam %in% names(param)] <- param[mr]
}
ret$lhsparam <- lhsparam
ret$rhsparam <- rhsparam
ret
}
flatten_term <- function(term) {
if ( length(term) > 1 )
return(c(flatten_term(term[[2]]), term[[3]]))
term
}
### Expand semrepr based on data and constraints: ####################
expand_semrepr_data <- function(object, groups) {
## NOTE: this is a hack, but does exactly what I want!
ret <- object[1, ]
ret$level <- NA_character_
ret$param <- NA_character_
n <- nrow(object)
for ( i in seq(length = n) ) {
x <- object[i, ]
rownames(x) <- NULL
level <- NA_character_
if ( !is.na(x$group) ) {
level <- groups[[x$group]]
}
d <- data.frame(x, level = level)
d$param <- sprintf("%s_%s%s", d$lhsparam, d$rhsparam,
ifelse(is.na(d$level), "", sprintf(":%s", d$level)))
ret <- rbind(ret, d)
}
ret <- ret[-1, ]
rownames(ret) <- NULL
## ... and all parameters are at this point free:
ret$free <- TRUE
ret
}
expand_semrepr_constraints <- function(object, constraints) {
## We only allow constraints with one term on the left-hand side.
if ( !is.null(object$param) ) {
unfree <- constrained_parameters(constraints)
object$free[object$param %in% unfree] <- FALSE
}
object
}
constrained_parameters <- function(x) {
as.character(sapply(x, "[[", 2))
}
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.