Nothing
inst/modelBuilder/server.R
In ifaTools: Toolkit for Item Factor Analysis with 'OpenMx'
library(shiny)
library(OpenMx)
library(rpf)
library(digest)
# drm == dichotomous help TODO
# do something for minItemsPerScore
#options(shiny.trace=TRUE)
#options(shiny.reactlog=TRUE)
verbose <- FALSE
# Use stupid nouns here to encourage folks to change them
# to more sensible ability labels.
sillyFactorName <- c('teacup','puppy','oink','sun','moon')
AppStateTables <- c("recodeTable", "permuteTable", "itemModel", "bayesianPrior")
AppStateSliderInput <- c("numFactors")
AppStateTextInput <- paste0("nameOfFactor", 1:5)
itemToSpec <- function(item) {
# cat("itemToSpec", item$model, item$outcomes, item$factors, fill=T)
if (is.null(item$model)) browser()
outcomes <- item$outcomes
factors <- item$factors
# Tc doesn't really matter here
switch(item$model,
'drm' = rpf.drm(factors = factors),
'grm' = rpf.grm(outcomes, factors = factors),
'nrm' = rpf.nrm(outcomes, factors = factors, T.a=item$Ta,
T.c=ifelse(item$Tc == 'partial credit', 'id', item$Tc)))
}
mergeDataAndModel <- function(col, outcomes, factors, item) {
if (length(outcomes) != 1) browser()
if (outcomes < 2) return(item) # will complain later
if (is.null(item) ||
(outcomes > 2 && item$model == 'drm') ||
(outcomes == 2 && item$model == 'nrm')) {
# if (verbose) cat("set default model", fill=T)
spec <- rpf.grm(outcomes, factors = factors)
np <- rpf.numParam(spec)
return(list(name=col, model='grm', outcomes=outcomes, factors=factors,
starting=rpf.rparam(spec), labels=rep(NA, np), free=rep(TRUE, np)))
}
if (item$model == 'nrm') {
if (is.null(item$Ta)) item$Ta <- "trend"
if (is.null(item$Tc)) item$Tc <- "trend"
} else {
item$Ta <- NULL
item$Tc <- NULL
}
item$name <- col
item$outcomes <- outcomes
item$factors <- factors
spec <- itemToSpec(item)
np <- rpf.numParam(spec)
if (length(item$starting) != np) {
newSV <- rpf.rparam(spec)
preserveMap <- match(names(newSV), item$starting)
newInd <- which(!is.na(preserveMap))
preserveMap <- preserveMap[!is.na(preserveMap)]
oldItem <- item
item$starting <- newSV
item$free <- rep(TRUE, np)
item$labels <- rep(NA, np)
item$starting[newInd] <- oldItem$starting[preserveMap]
item$free[newInd] <- oldItem$free[preserveMap]
item$labels[newInd] <- oldItem$labels[preserveMap]
}
item
}
changeItemModel <- function(itemModel, input, outcomes, fi, newModel) {
oldModel <- isolate(itemModel[[fi]]$model)
if (is.null(oldModel)) return()
if (newModel != oldModel) {
if (verbose) cat("change",fi,"from", oldModel,"to", newModel,fill=T)
item <- isolate(itemModel[[fi]])
item$model <- newModel
numFactors <- isolate(input$numFactors)
itemModel[[fi]] <- mergeDataAndModel(fi, outcomes, numFactors, item)
}
}
getFactorNames <- function(input) {
numFactors <- isolate(input$numFactors)
if (numFactors == 0) return(c())
sapply(1:numFactors, function (x) input[[ paste0("nameOfFactor", x) ]])
}
getFocusedItems <- function(input, rawData, permuteTable) {
dcols <- includedColumnNames(input, rawData, permuteTable)
range <- sort(match(c(input$focusedItemStart, input$focusedItemEnd), dcols))
if (length(range) != 2) return(c())
dcols[seq(range[1], range[2])]
}
buildParameterTable <- function(input, rawData, permuteTable, itemModel, attr) {
dcols <- getFocusedItems(input, rawData, permuteTable)
if (length(dcols) == 0) return(NULL)
massign <- lapply(dcols, function (col) {
im <- itemModel[[col]]
v <- im[[attr]]
names(v) <- names(im$starting)
v
})
names(massign) <- dcols
tbl <- mxSimplify2Array(massign)
fnames <- getFactorNames(input)
if (length(fnames)) {
rownames(tbl)[1:length(fnames)] <- fnames
}
tbl
}
getFocusedItem <- function(input, rawData, permuteTable, itemModel) {
inames <- getFocusedItems(input, rawData, permuteTable)
if (length(inames) == 0) return()
im <- itemModel[[ inames[1] ]]
im
}
getFocusedParameterNames <- function(input, im) {
pname <- names(im$starting)
fnames <- getFactorNames(input)
if (length(fnames)) {
pname[1:length(fnames)] <- fnames
}
pname
}
computeFreeSelected <- function(im, fx) {
sel <- "Free"
isFree <- im$free[fx]
if (!isFree) {
if (is.finite(im$starting[fx])) {
sel <- im$starting[fx]
} else {
sel <- "inf"
}
}
sel
}
maybeUpdateFree <- function(input, itemModel, im, pname) {
fx <- match(pname, names(im$starting))
if (is.na(fx)) return()
spec <- itemToSpec(im)
sel <- computeFreeSelected(im, fx)
if (sel == input$focusedParameterFree) return()
if (input$focusedParameterFree == "Free") {
if (verbose) cat("free", pname, "of", im$name, fill=TRUE)
im$free[fx] <- TRUE
im$starting[fx] <- rpf.rparam(spec)[fx]
} else {
if (verbose) cat("fixed", pname, "of", im$name, "to",
input$focusedParameterFree, fill=TRUE)
im$free[fx] <- FALSE
pi <- rpf.paramInfo(spec, fx)
if (pi$type == 'bound' && input$focusedParameterFree == 'inf') {
if (names(im$starting[fx]) == 'g') {
im$starting[fx] <- qlogis(0)
} else {
im$starting[fx] <- qlogis(1)
}
} else {
im$starting[fx] <- as.numeric(input$focusedParameterFree)
}
}
itemModel[[ im$name ]] <- im
}
maybeUpdateLabel <- function(input, itemModel, im, pname) {
proposal <- isolate(input$focusedParameterLabel)
newLabel <- ifelse(nchar(proposal), mxMakeNames(proposal), proposal)
fx <- match(pname, names(im$starting))
if (is.na(fx)) return()
sel <- im$labels[fx]
if (is.na(sel)) sel <- "none"
if (sel == newLabel) return()
if (newLabel == "none" || !nzchar(newLabel)) {
im$labels[fx] <- NA
} else {
im$labels[fx] <- newLabel
}
itemModel[[ im$name ]] <- im
}
toScript <- function(input, rawData, recodeTable, permuteTable, itemModel, bayesianPrior) {
if (is.null(rawData$name)) {
loadData <- paste(c("# load some demonstration data",
as.character(rawData$loadDemo)), collapse="\n")
} else {
loadData <- c("# Adjust the path in the next statement to load your data\n",
paste0("data <- read.csv(na.strings=c(), file='",rawData$name,"'"))
if (!input$dataHeader) loadData <- c(loadData, ",header=FALSE")
if (input$dataSep != ",") {
loadData <- c(loadData, paste0(",sep='", input$dataSep, "'"))
}
if (input$dataQuote != '"') {
loadData <- c(loadData, paste0(',quote="', input$dataQuote, '"'))
}
loadData <- c(loadData, ",stringsAsFactors=FALSE,check.names=FALSE)\n",
"colnames(data) <- mxMakeNames(colnames(data), unique=TRUE)")
}
if (input$freqColumnName != '-') {
fc <- input$freqColumnName
loadData <- c(loadData, paste0("\ndata[['", fc, "']] <- as.numeric(data[['", fc, "']])"))
}
loadData <- c(loadData,
sapply(setdiff(permuteTable$exclude, input$freqColumnName),
function(col) paste0("\ndata[['", col, "']] <- NULL # excluded")))
data <- rawData$val
dcols <- includedColumnNames(input, rawData, permuteTable)
mkSpec <- list("spec <- list()")
mker <- sapply(dcols, function(col) {
im <- itemModel[[col]]
str <- c("list(rpf.", im$model, "(factors=numFactors")
if (im$model != "drm") {
str <- c(str, ",outcomes=", im$outcomes)
}
if (im$model == "nrm") {
tc <- im$Tc
if (tc == 'partial credit') {
tc <- paste0("lower.tri(diag(", im$outcomes-1, "),TRUE) * -1")
} else {
tc <- paste0("'",tc,"'")
}
str <- c(str, ",T.a='", im$Ta, "', T.c=", tc)
}
paste0(c(str, "))"), collapse="")
})
code <- rle(mker)
val <- code$values
starts <- cumsum(c(1, code$lengths))[c(rep(TRUE,length(val)),FALSE)]
lens <- code$lengths
if (length(starts) == 1) {
mkSpec <- c(mkSpec, paste0("spec[1:", length(mker),"] <- ",mker[1]))
} else {
mkSpec <- c(mkSpec, mapply(function(start, len, v1) {
paste0("spec[",start,":",(start+len),"] <- ",v1)
}, starts, lens - 1L, val, SIMPLIFY=FALSE))
}
mkSpec <- c(mkSpec,
paste0("names(spec) <- ", paste(deparse(dcols), collapse="\n ")))
mkSpec <- paste(mkSpec, collapse="\n")
fnames <- getFactorNames(input)
starting <- mxSimplify2Array(lapply(dcols, function(col) { itemModel[[col]]$starting }))
free <- mxSimplify2Array(lapply(dcols, function(col) { itemModel[[col]]$free }))
free[is.na(free)] <- TRUE # can ignore these
labels <- mxSimplify2Array(lapply(dcols, function(col) { itemModel[[col]]$labels }))
labels[!free] <- NA
rnames <- paste0('p', 1:nrow(starting))
if (length(fnames)) {
rnames[1:length(fnames)] <- fnames
}
itemInit <- list()
for (rx in 1:nrow(free)) {
rname <- paste0("'", rnames[rx], "'")
fcode <- rle(!free[rx,])
mask <- fcode$values
starts <- cumsum(c(1, fcode$lengths))[c(mask,FALSE)]
lens <- fcode$lengths[mask]
if (length(starts) == 0) {
next
}
if (length(starts) == 1 && lens == ncol(free)) {
itemInit <- c(itemInit, paste0("imat$free[",rname,",] <- FALSE"))
} else {
itemInit <- c(itemInit, mapply(function(start, len) {
paste0("imat$free[",rname,",",start,":",(start+len),"] <- FALSE")
}, starts, lens - 1L, SIMPLIFY=FALSE))
}
srow <- starting[rx,]
srow[free[rx,]] <- NA
code <- rle(srow)
mask <- !is.na(code$value)
itemInit <- c(itemInit, mapply(function(start, len) {
paste0("imat$values[",rname,",",start,":",(start+len),"] <- ", srow[start])
}, cumsum(c(1, code$lengths))[c(mask,FALSE)], code$lengths[mask] - 1L, SIMPLIFY=FALSE))
}
for (rx in 1:nrow(free)) {
rname <- paste0("'", rnames[rx], "'")
code <- rle(labels[rx,])
mask <- !is.na(code$values)
val <- code$values[mask]
starts <- cumsum(c(1, code$lengths))[c(mask,FALSE)]
lens <- code$lengths[mask]
if (length(starts) == 0) next
if (length(starts) == 1 && lens == ncol(free)) {
itemInit <- c(itemInit, paste0("imat$labels[",rname,",] <- '",val[1],"'"))
} else {
itemInit <- c(itemInit, mapply(function(start, len, v1) {
paste0("imat$labels[",rname,",",start,":",(start+len),"] <- '",v1,"'")
}, starts, lens - 1L, val, SIMPLIFY=FALSE))
}
}
ltbl <- table(labels)
if (any(ltbl > 1)) {
itemInit <- c(itemInit,
"hasLabel <- !is.na(imat$labels)",
paste0("for (lab1 in unique(imat$labels[hasLabel])) {
imat$values[hasLabel & imat$labels==lab1] <-
sample(imat$values[hasLabel & imat$labels==lab1], 1)
}"))
}
itemInit <- paste(itemInit, collapse="\n")
topModel <- "itemModel"
fitIFAgroup <- "m1Fit"
ul <- unique(labels)
ul <- ul[!is.na(ul)]
bpList <- match(ul, names(bayesianPrior$map))
bpList <- sort(bpList[!is.na(bpList)])
priorInit <- c()
if (length(bpList)) {
topModel <- "container"
fitIFAgroup <- "m1Fit$itemModel"
bmode <- bayesianPrior$map[bpList]
bmodeNames <- names(bmode)
names(bmode) <- NULL
priorInit <- c(priorInit,
"",
paste0("priorLabels <- ", paste0(deparse(bmodeNames), collapse="")),
"priorMode <- rep(NA, length(priorLabels))")
code <- rle(as.character(bmode))
val <- code$values
starts <- cumsum(c(1, code$lengths))[c(rep(TRUE, length(val)),FALSE)]
lens <- code$lengths
if (length(starts) == 1) {
priorInit <- c(priorInit, paste0("priorMode[1:",length(bmode),"] <- ",bmode[1]))
} else {
priorInit <- c(priorInit, mapply(function(start, len, v1) {
paste0("priorMode[",start,":",(start+len),"] <- ",v1)
}, starts, lens - 1L, val, SIMPLIFY=FALSE))
}
if (input$boundPriorForm == "Beta") {
priorInit <- c(priorInit,
"priorModel <- univariatePrior('beta', priorLabels, priorMode)")
} else if (input$boundPriorForm == "Logit-normal") {
priorInit <- c(priorInit,
"priorModel <- univariatePrior('logit-norm', priorLabels, priorMode)")
} else { browser() }
}
if (length(priorInit)) {
priorInit <- c(priorInit,
"container <- mxModel(model='container', itemModel, priorModel,
mxFitFunctionMultigroup(groups=c('itemModel.fitfunction', 'univariatePrior.fitfunction')))")
priorInit <- paste(priorInit, collapse="\n")
}
writeFactorNames <- ''
if (length(fnames)) {
writeFactorNames <- "rownames(startingValues)[1:numFactors] <- factors"
}
freqCol <- input$freqColumnName
maybeCompress <- list()
freqDataArgs <- ''
# This is temporarily broken because of changes in OpenMx TODO
# if (freqCol == '-') {
# maybeCompress <- "data <- compressDataFrame(data)"
# freqCol <- "freq"
# }
if (freqCol != '-') {
freqDataArgs <- paste0(", frequency='", freqCol,"'")
}
numExtraCol <- 1
getRefModels <- ""
if (input$fitReferenceModels) {
getRefModels <- ", refModels=mxRefModels(itemModel, run = TRUE)"
}
emArgs <- paste0("'itemModel.expectation', 'scores',
mxComputeNewtonRaphson(), verbose=", ifelse(input$showFitProgress, "2L", "0L"))
if (input$infoMethod == "*none*") {
computePlan <- paste0("computePlan <- mxComputeEM(", emArgs, ")")
} else if (input$infoMethod == "Meat") {
computePlan <- paste0("emStep <- mxComputeEM(", emArgs,")\n",
"computePlan <- mxComputeSequence(list(EM=emStep,
IM=mxComputeOnce('fitfunction', 'information', 'meat'),
HQ=mxComputeHessianQuality(),
SE=mxComputeStandardError()))")
} else if (input$infoMethod == "Oakes") {
emArgs <- paste0(emArgs, ",\n information='oakes1999', infoArgs=list(fitfunction='fitfunction')")
computePlan <- paste0("emStep <- mxComputeEM(", emArgs,")\n",
"computePlan <- mxComputeSequence(list(EM=emStep,
HQ=mxComputeHessianQuality(),
SE=mxComputeStandardError()))")
} else if (input$infoMethod == "Agile SEM") {
emArgs <- paste0(emArgs, ",\n information='mr1991',
infoArgs=list(fitfunction='fitfunction', semMethod='agile')")
computePlan <- paste0("emStep <- mxComputeEM(", emArgs,")\n",
"computePlan <- mxComputeSequence(list(SE=emStep,
HQ=mxComputeHessianQuality(),
SE=mxComputeStandardError()))")
} else {
browser()
}
doPlots <- c()
if (length(fnames)) {
doPlots <- c("",
"```{r,fig.height=2}
map1 <- itemResponseMap(m1Grp, factor=1)
ggplot(map1, aes(x=score, y=item, label=outcome)) +
geom_text(size=4, position=position_jitter(h=.25))
```",
"",
"```{r,fig.height=3}
pl <- lapply(names(sfit), function(item) { SitemPlot(sfit, item) })
for (px in 1:length(pl)) {
print(pl[[px]])
}
basis <- rep(0, length(factors))
basis[1] <- 1
plotInformation(m1Grp, width=5, basis=basis)
```")
}
paste(
"---",
paste0('title: "',rawData$stem, '"'),
paste0('date: "', format(Sys.time(), "%d-%b-%Y"), '"'),
paste0("output: html_document"),
"---\n",
"```{r}",
"options(width=120, scipen=2, digits=2)",
"suppressPackageStartupMessages(library(OpenMx))",
"suppressPackageStartupMessages(library(rpf))",
"suppressPackageStartupMessages(library(ifaTools))",
"library(xtable)",
"options(xtable.type='html')",
"",
paste0(loadData, collapse=""),
"",
paste0("factors <- ", paste0(deparse(fnames)), collapse=""),
"numFactors <- length(factors)",
mkSpec,
"",
"missingColumns <- which(is.na(match(names(spec), colnames(data))))",
"if (length(missingColumns)) {",
" stop(paste('Columns missing in the data:', omxQuotes(names(spec)[missingColumns])))",
"}",
"",
genRecodeOutcomesCode(input, rawData, recodeTable, permuteTable),
"",
"#set.seed(1) # uncomment to get the same starting values every time",
"startingValues <- mxSimplify2Array(lapply(spec, rpf.rparam))",
"rownames(startingValues) <- paste0('p', 1:nrow(startingValues))",
writeFactorNames,
"",
"imat <- mxMatrix(name='item', values=startingValues, free=!is.na(startingValues))",
itemInit,
"# Remove non-factor columns (if any)",
"data <- data[,sapply(data, is.factor)]",
"# Remove all-missing rows",
"data <- data[rowSums(!is.na(data[,names(spec)])) != 0,]",
maybeCompress,
paste0("itemModel <- mxModel(model='itemModel', imat,
mxData(observed=data, type='raw'", freqDataArgs, "),
mxExpectationBA81(ItemSpec=spec),
mxFitFunctionML())"),
priorInit,
"",
computePlan,
paste0(topModel, " <- mxModel(", topModel, ", computePlan)"),
"",
paste0("m1Fit <- mxRun(", topModel, ")"),
"",
paste0("m1Grp <- as.IFAgroup(", fitIFAgroup ,", minItemsPerScore=1L)"),
"```",
"",
"An item factor model was fit with `r length(factors)`
factors (`r ifelse(length(factors), factors, '-')`), -2LL=$`r m1Fit$output$fit`$.",
"The condition number of the information matrix was `r round(m1Fit$output$conditionNumber)`.",
"",
"```{r,fig.height=2}
got <- sumScoreEAPTest(m1Grp)
df <- data.frame(score=as.numeric(names(got[['observed']])),
expected=got[['expected']], observed=got[['observed']])
df <- melt(df, id='score', variable.name='source', value.name='n')
ggplot(df, aes(x=score, y=n, color=source)) + geom_line()
```",
"",
"```{r,results='asis'}
ct <- ChenThissen1997(m1Grp)
print(xtable(ct$pval, paste('Log p-value of local dependence between item pairs.')))
```",
"",
"```{r,results='asis'}
sfit <- SitemFit(m1Grp)
tbl <- t(sapply(sfit, function(r) c(n=r$n, df=r$df, stat=r$statistic, pval=r$pval)))
print(xtable(tbl, paste0('Sum-score item-wise fit')))
```",
paste(doPlots, collapse="\n"),
"",
paste0("```{r}
summary(m1Fit", getRefModels, ")
```"),
"",
"```{r,results='asis'}
citation('OpenMx')
```",
sep="\n")
}
execRecodeRule <- function(rc, outcomes) {
if (rc$type == "item") {
ix <- match(rc$name, names(outcomes))
if (is.na(ix)) return(outcomes)
p1 <- setdiff(outcomes[[ix]], rc$from)
if (rc$to != '') p1 <- union(p1, rc$to)
outcomes[[ix]] <- sort(p1)
} else if (rc$type == "outcomeSet") {
oSetNames <- sapply(outcomes, function(oc) digest(oc, ascii=TRUE))
for (ix in which(rc$nameHash == oSetNames)) {
p1 <- setdiff(outcomes[[ix]], rc$from)
if (rc$to != '') p1 <- union(p1, rc$to)
outcomes[[ix]] <- sort(p1)
}
}
outcomes
}
recodeOutcomes <- function(input, rawData, recodeTable, permuteTable) {
dat <- rawData$val
if (is.null(dat)) return(NULL)
ch <- includedColumnNames(input, rawData, permuteTable)
outcomes <- lapply(dat[,ch], function(col) {
sort(unique(col))
})
if (!is.null(recodeTable$val) && nrow(recodeTable$val)) for (rcX in 1:nrow(recodeTable$val)) {
rc <- recodeTable$val[rcX,]
outcomes <- execRecodeRule(rc, outcomes)
}
outcomes
}
flushFactorTransform <- function(fa1, col) {
args <- list(col," <- mxFactor(", col, ", ",
"levels=", paste(deparse(fa1$levels), collapse=""))
if (any(fa1$levels != fa1$labels)) {
args <- c(args, ", labels=", paste(deparse(fa1$labels), collapse=""))
}
if (length(fa1$exclude)) {
args <- c(args, ", exclude=", paste(deparse(fa1$exclude), collapse=""))
}
if (any(duplicated(fa1$labels))) {
args <- c(args, ", collapse=TRUE")
}
args <- c(args, ")")
do.call(paste0, args)
}
trackRecodeRule <- function(fa1, ix, rc, col) {
xf1 <- c()
from <- as.character(rc$from)
to <- as.character(rc$to)
if (from != '' && to != '') {
fx <- match(from, fa1$levels)
if (is.na(fx)) {
xf1 <- c(xf1, flushFactorTransform(fa1, paste0("data[[",col,"]]")))
newLevels <- sort(fa1$labels)
fa1 <- list(levels=newLevels, labels=newLevels, exclude=c())
}
fx <- match(from, fa1$levels)
fa1$labels[fx] <- to
} else if (from == '' && to != '') {
fa1$levels <- append(fa1$levels, to)
fa1$labels <- append(fa1$labels, to)
} else if (from != '' && to == '') {
fx <- match(from, fa1$levels)
if (is.na(fx)) {
xf1 <- c(xf1, flushFactorTransform(fa1, paste0("data[[",col,"]]")))
fa1 <- list(levels=fa1$labels, labels=fa1$labels, exclude=c())
}
fa1$exclude <- append(fa1$exclude, from)
fx <- match(from, fa1$levels)
fa1$levels <- fa1$levels[-fx]
fa1$labels <- fa1$labels[-fx]
}
list(fa1=fa1, xf1=xf1)
}
genRecodeOutcomesCode <- function(input, rawData, recodeTable, permuteTable) {
dat <- rawData$val
if (is.null(dat)) return(NULL)
ch <- includedColumnNames(input, rawData, permuteTable)
outcomes <- lapply(dat[,ch], function(col) {
sort(unique(col))
})
farg <- lapply(outcomes, function(lev) list(levels=lev, labels=lev, exclude=c()))
xform <- c()
if (!is.null(recodeTable$val) && nrow(recodeTable$val)) for (rcX in 1:nrow(recodeTable$val)) {
rc <- recodeTable$val[rcX,]
xf1 <- c()
if (rc$type == "item") {
ix <- match(rc$name, names(outcomes))
if (!is.na(ix)) {
trr <- trackRecodeRule(farg[[ix]], rc$name, rc, paste0("'",rc$name,"'"))
farg[[ix]] <- trr$fa1
xf1 <- c(xf1, trr$xf1)
}
} else if (rc$type == "outcomeSet") {
oSetNames <- sapply(outcomes, function(oc) digest(oc, ascii=TRUE))
xf2 <- c()
loop <- names(which(rc$nameHash == oSetNames))
for (ix in loop) {
trr <- trackRecodeRule(farg[[ix]], ix, rc, "col")
farg[[ix]] <- trr$fa1
xf2 <- trr$xf1 # only need 1 copy
}
if (length(xf2)) {
# tricky and hard to test TODO
xf1 <- c(xf1, paste0("for (col in ",paste(" ", deparse(loop), collapse="\n"),") {\n",
xf2, "}\n"))
}
}
xform <- c(xform, xf1)
outcomes <- execRecodeRule(rc, outcomes)
}
farg <- lapply(farg, function(fa) {
perm <- order(fa$labels)
fa$levels <- fa$levels[perm]
fa$labels <- fa$labels[perm]
fa
})
oSetNames <- sapply(outcomes, function(oc) digest(oc, ascii=TRUE))
for (pe in names(permuteTable$val)) {
if (all(pe != oSetNames)) next
perm <- permuteTable$val[[pe]]
for (name in names(oSetNames[pe == oSetNames])) {
fa <- farg[[name]]
fa$levels <- fa$levels[perm]
fa$labels <- fa$labels[perm]
farg[[name]] <- fa
}
}
for (pe in intersect(names(permuteTable$val), names(outcomes))) {
perm <- permuteTable$val[[pe]]
fa <- farg[[pe]]
fa$levels <- fa$levels[perm]
fa$labels <- fa$labels[perm]
farg[[pe]] <- fa
}
fSetNames <- sapply(farg, function(oc) digest(oc, ascii=TRUE))
fSetTbl <- table(fSetNames)
if (length(fSetTbl) == 1) {
pick <- names(farg)[1]
xform <- c(xform, flushFactorTransform(farg[[pick]], "data[names(spec)]"))
} else {
for (fs in names(fSetTbl)) {
loop <- names(fSetNames[fs == fSetNames])
l1 <- loop[1]
xform <- c(xform, paste0("for (col in ",paste(" ", deparse(loop), collapse="\n"),") {\n ",
flushFactorTransform(farg[[l1]], "data[[col]]"),
"\n}"))
}
}
toRev <- intersect(ch, permuteTable$reversed)
if (length(toRev)) {
xform <- c(xform, paste0("# reverse levels of reversed items\n",
"for (col in ",paste(" ", deparse(toRev), collapse="\n"),") {\n ",
"data[[col]] <- mxFactor(data[[col]], rev(levels(data[[col]])))",
"\n}"))
}
paste(xform, collapse="\n")
}
getFocusedOutcomeDetailUnordered <- function(input, rawData, recodeTable, permuteTable) {
outcomes <- recodeOutcomes(input, rawData, recodeTable, permuteTable) # could accept this as an argument TODO
if (input$focusedOutcomeItem != '-') {
fi <- input$focusedOutcomeItem
iout <- outcomes[[fi]]
perm <- permuteTable$val[[ digest(iout, ascii=TRUE) ]]
if (!is.null(perm) && length(perm) == length(iout)) {
iout <- iout[perm]
}
return(iout)
}
if (input$focusedOutcomeSet != '-') {
fi <- input$focusedOutcomeSet
return(outcomes[[fi]])
}
return(NULL)
}
getFocusedOutcomeDetail <- function(input, rawData, recodeTable, permuteTable) {
outcomes <- getFocusedOutcomeDetailUnordered(input, rawData, recodeTable, permuteTable)
if (input$focusedOutcomeItem != '-') {
fi <- input$focusedOutcomeItem
} else if (input$focusedOutcomeSet != '-') {
fi <- digest(outcomes, ascii=TRUE)
} else {
return(outcomes)
}
perm <- permuteTable$val[[fi]]
if (!is.null(perm) && length(perm) == length(outcomes)) {
outcomes <- outcomes[perm]
}
outcomes
}
dataColumnNamesUnsorted <- function(input, rawData) {
dcol <- colnames(rawData$val)
if (input$freqColumnName != '-') {
dcol <- setdiff(dcol, input$freqColumnName)
}
dcol
}
dataColumnNames <- function(input, rawData, permuteTable) {
dcol <- dataColumnNamesUnsorted(input, rawData)
perm <- permuteTable$items
if (!is.null(perm) && length(perm) == length(dcol)) dcol <- dcol[perm]
dcol
}
includedColumnNames <- function(input, rawData, permuteTable) {
setdiff(dataColumnNames(input, rawData, permuteTable), permuteTable$exclude)
}
setupItemModels <- function(input, rawData, itemModel, outcomes) {
numFactors <- isolate(input$numFactors)
dcol <- isolate(dataColumnNamesUnsorted(input, rawData))
for (col in dcol) {
itemModel[[col]] <- mergeDataAndModel(col, length(outcomes[[col]]), numFactors,
isolate(itemModel[[col]]))
}
}
setupFreqColumnName <- function(session, rawData, freqCol) {
dcols <- isolate(colnames(rawData$val))
if (!missing(freqCol) && is.na(match(freqCol, dcols))) browser()
if (missing(freqCol)) freqCol <- "-"
updateSelectInput(session, "freqColumnName", selected=freqCol,
choices=c("-", dcols))
}
updatePriorMode <- function(input, bayesianPrior, itemModel, im, pname, set) {
fx <- match(pname, names(im$starting))
if (is.na(fx)) return()
oldLabel <- im$labels[fx]
map <- isolate(bayesianPrior$map)
if (set) {
if (!(im$model == 'drm' && (pname == 'g' || pname == 'u')))
return("Can only set prior on dichotomous (drm) bound parameters.")
prior <- isolate(input$focusedParameterPrior)
if (is.na(oldLabel) || !nzchar(oldLabel)) {
oldLabel <- paste0(im$name,"_",pname)
im$labels[fx] <- oldLabel
itemModel[[im$name]] <- im
}
if (pname == 'g') {
mode <- paste0("logit(1/",prior,")")
} else if (pname == 'u') {
mode <- paste0("logit(",(as.integer(prior)-1),"/",prior,")")
}
if (verbose) cat("set bayesian prior", im$name, pname, "to", mode,"using label", oldLabel, fill=TRUE)
map[[oldLabel]] <- mode
bayesianPrior$map <- map
} else {
if (!is.na(oldLabel) && !is.null(map[[oldLabel]])) {
if (verbose) cat("clear bayesian prior", im$name, pname, "on label", oldLabel, fill=TRUE)
map[[oldLabel]] <- NULL
bayesianPrior$map <- map
}
}
return('')
}
# -----------------------------------------------------------------------------------------
shinyServer(function(input, output, session) {
feedback <- reactiveValues(newOutcomeAction="", resetRecodeAction="",
focusedOutcomeMapAction="", codingFile="",
focusedParameterPrior="", parseFile="")
rawData <- reactiveValues(val=NULL, name=NULL)
recodeTable <- reactiveValues(val=NULL)
permuteTable <- reactiveValues(val=NULL, items=NULL, reversed=NULL, exclude=NULL)
itemModel <- reactiveValues() # colname to list(model, Ta, Tc, startingValues, free, labels)
bayesianPrior <- reactiveValues(map=list()) # label -> value map
observe({
if (input$exampleDataKCT == 0) return()
loader <- parse(text=c(
'utils::data("kct", package="rpf")',
'data <- kct.people[20:37]',
'colnames(data) <- mxMakeNames(kct.items[["NAME"]], unique=TRUE)',
'data <- as.data.frame(lapply(data, as.character), stringsAsFactors=FALSE)',
'rownames(data) <- kct.people[[19]]'))
eval(loader)
rawData$datapath <- NULL
rawData$name <- NULL
rawData$loadDemo <- loader
rawData$stem <- "kct"
rawData$val <- data
recodeTable$val <-
structure(list(type = structure(c(1L, 1L, 1L, 1L), .Label = "outcomeSet", class = "factor"),
name = structure(c(1L, 2L, 1L, 1L), .Label = c("X1x1x4", "X18x4x1x3x4x2x1x4"), class = "factor"),
nameHash = structure(c(1L, 2L, 3L, 7L), .Label = c("f99c1d57d88bd654baacdcc798a016b6", "8ee3f19dd735a96f0ff59fb514b8efb8", "b695085c9330f407121bb28e859ad508",
"21c943db9d7a66561c37be2e751f7c85", "19eca0e5d319402184b1a1b20eaaa987",
"2572e3e6d229a7405d0ed1839c58f54c", "b867678184d2befa2e1b57c4529dbdc3" ), class = "factor"),
action = structure(c(1L, 1L, 2L, 2L), .Label = c("add", "recode"), class = "factor"),
from = structure(c(1L, 1L, 2L, 3L), .Label = c("", "0", "1"), class = "factor"),
to = structure(c(1L, 2L, 4L, 3L), .Label = c("0", "1", "correct", "incorrect"), class = "factor")),
.Names = c("type", "name", "nameHash", "action", "from", "to"), row.names = c(NA, 4L), class = "data.frame")
permuteTable$val <-
structure(list("9b162432e63482dee83b819368c73fb4" = c(2L, 1L)),
.Names = "9b162432e63482dee83b819368c73fb4")
permuteTable$exclude <- c("X1x1x4", "X2x2x3", "X3x1x2x4", "X18x4x1x3x4x2x1x4")
isolate({
outcomes <- isolate(recodeOutcomes(input, rawData, recodeTable, permuteTable))
setupItemModels(input, rawData, itemModel, outcomes)
for (name in names(outcomes)) {
itemModel[[name]]$labels[1] <- 'slope'
}
})
setupFreqColumnName(session, rawData)
})
observe({
if (input$exampleDataLSAT6 == 0) return()
loader <- parse(text=c(
'utils::data("LSAT6", package="rpf")',
'data <- LSAT6'
))
eval(loader)
rawData$datapath <- NULL
rawData$name <- NULL
rawData$loadDemo <- loader
rawData$stem <- "LSAT6"
rawData$val <- data
recodeTable$val <-
structure(list(type = structure(c(1L, 1L), .Label = "outcomeSet", class = "factor"),
name = structure(c(1L, 1L), .Label = "Item_1", class = "factor"),
nameHash = structure(1:2, .Label = c("b66901a10dfd2349673b611ab231b535", "b867678184d2befa2e1b57c4529dbdc3"), class = "factor"),
action = structure(c(1L, 1L), .Label = "recode", class = "factor"),
from = structure(1:2, .Label = c("0", "1"), class = "factor"),
to = structure(1:2, .Label = c("incorrect", "correct"), class = "factor")),
.Names = c("type", "name", "nameHash", "action", "from", "to"), row.names = 1:2, class = "data.frame")
permuteTable$val <-
structure(list("9b162432e63482dee83b819368c73fb4" = c(2L, 1L)), .Names = "9b162432e63482dee83b819368c73fb4")
setupFreqColumnName(session, rawData, "Freq")
})
observe({
if (input$exampleDataScience == 0) return()
loader <- parse(text=c(
'utils::data("science", package="rpf")',
'data <- sfpf[20:44]',
'colnames(data) <- mxMakeNames(colnames(data), unique=TRUE)',
'data <- as.data.frame(lapply(data, as.character), stringsAsFactors=FALSE)',
'rownames(data) <- sfpf[[19]]'
))
eval(loader)
rawData$loadDemo <- loader
rawData$datapath <- NULL
rawData$name <- NULL
rawData$stem <- "science"
rawData$val <- data
recodeTable$val <-
structure(list(type = structure(1L, .Label = "outcomeSet", class = "factor"),
name = structure(1L, .Label = "GOTOMUSEUM", class = "factor"),
nameHash = structure(1L, .Label = "7fcb27479582cc445bad8fa1ce4c4c2a", class = "factor"),
action = structure(1L, .Label = "add", class = "factor"),
from = structure(1L, .Label = "", class = "factor"), to = structure(1L, .Label = "dislike", class = "factor")),
.Names = c("type", "name", "nameHash", "action", "from", "to"), row.names = 1L, class = "data.frame")
permuteTable$val <-
structure(list("37cba13974a597e56737c53035b1a6f0" = c(1L, 3L, 2L)),
.Names = "37cba13974a597e56737c53035b1a6f0")
permuteTable$exclude <- 'GOTOMUSEUM'
setupFreqColumnName(session, rawData)
})
observe({
inFile <- input$file1
if (is.null(inFile)) return(NULL)
rawData$datapath <- inFile$datapath
rawData$name <- inFile$name
})
output$parseFileFeedback <- renderText(feedback[["parseFile"]])
observe({
if (is.null(rawData$datapath) || !file.exists(rawData$datapath)) return()
if (0) {
cat("read.csv with options", input$dataRowNames,
input$dataSep, input$dataQuote, fill=T)
}
args <- list(rawData$datapath, header=input$dataHeader,
sep=input$dataSep, quote=input$dataQuote,
stringsAsFactors=FALSE, check.names=FALSE, na.strings=c())
if (input$dataRowNames) {
args$row.names=1L
}
dat <- try(do.call(read.csv, args), silent = TRUE)
if (inherits(dat, "try-error")) {
feedback[["parseFile"]] <- paste("Something went wrong trying to load your file:\n", dat)
return()
}
hint <- "Try different quote and separator options."
if (nrow(dat) == 0) {
feedback[["parseFile"]] <- paste("Dataset appears to have 0 rows.", hint)
return()
}
if (ncol(dat) == 0) {
feedback[["parseFile"]] <- paste("Dataset appears to have 0 columns.", hint)
return()
}
colnames(dat) <- mxMakeNames(colnames(dat), unique=TRUE)
rawData$stem <- sub('\\..{3}$', '', rawData$name, perl=TRUE)
rawData$val <- dat
setupFreqColumnName(session, rawData)
feedback[["parseFile"]] <- ""
})
output$unparsedDataContents <- renderText({
if (is.null(rawData$datapath)) return()
paste(readLines(rawData$datapath, n=6L, warn=FALSE), collapse="\n")
})
output$dataContents <- renderTable({
dat <- rawData$val
# updateTabsetPanel(session, "dataPreviewTabset", "front") dunno why doesn't work TODO
head(dat)
})
output$nameOfDataFile <- renderText({ rawData$name })
observe({
ch <- dataColumnNamesUnsorted(input, rawData)
if (length(ch) == 0) return()
updateSelectInput(session, "focusedItemStart", choices=ch, selected=ch[[1]])
updateSelectInput(session, "focusedItemEnd", choices=ch, selected=ch[[ length(ch) ]])
})
observe({
perm <- permuteTable$items
ch <- isolate(dataColumnNamesUnsorted(input, rawData))
if (!is.null(perm) && length(perm) == length(ch)) ch <- ch[perm]
updateSelectInput(session, "focusedItemStart", choices=ch,
selected=isolate(input$focusedItemStart))
updateSelectInput(session, "focusedItemEnd", choices=ch,
selected=isolate(input$focusedItemEnd))
})
observe({
hits <- input$selectAllItemsAction
if (hits == 0) return()
ch <- isolate(includedColumnNames(input, rawData, permuteTable))
if (length(ch) == 0) return()
updateSelectInput(session, "focusedItemStart", selected=ch[[1]])
updateSelectInput(session, "focusedItemEnd", selected=ch[[ length(ch) ]])
})
output$numberOfDataRows <- renderText({
nrow(rawData$val)
})
output$dataSummary <- renderTable({
dat <- rawData$val
if (is.null(dat)) return(NULL)
ch <- dataColumnNames(input, rawData, permuteTable)
tbl <- sapply(rawData$val[,ch,drop=FALSE], function(col) c(Outcomes=length(unique(col)),
Missing=sum(is.na(col))))
tbl <- t(tbl)
rownames(tbl) <- ch
tbl
})
# ------------------------------------------------------------------ Outcomes
observe({
prevFocus <- isolate(input$focusedOutcomeSet)
outcomes <- recodeOutcomes(input, rawData, recodeTable, permuteTable)
oSetHash <- sapply(outcomes, function(oc) digest(oc, ascii=TRUE))
ch <- names(oSetHash[!duplicated(oSetHash)])
if (length(ch) == 0) return()
updateSelectInput(session, "focusedOutcomeSet",
choices=c('-', ch),
selected=ifelse(!is.na(match(prevFocus, ch)), prevFocus, ch[1]))
})
observe({
ch <- dataColumnNames(input, rawData, permuteTable)
updateSelectInput(session, "focusedOutcomeItem", choices=c("-",ch))
})
observe({
if (input$focusedOutcomeItem == '-') return()
updateSelectInput(session, "focusedOutcomeSet", selected="-")
})
observe({
if (input$focusedOutcomeSet == '-') return()
updateSelectInput(session, "focusedOutcomeItem", selected="-")
})
output$recodeTable <- renderTable({
tbl <- recodeTable$val
if (is.null(tbl) || nrow(tbl) == 0) return()
tbl[,c("type","name","action","from","to")]
})
observe({
outcomes <- getFocusedOutcomeDetail(input, rawData, recodeTable, permuteTable)
if (length(outcomes) == 0) outcomes <- "No item selected"
updateSelectInput(session, "focusedOutcomeMapFrom", choices=outcomes)
updateSelectInput(session, "focusedOutcomeMapTo", choices=c("<NA>", outcomes, "<Rename>"))
})
output$addNewOutcomeActionFeedback <- renderText(feedback[["newOutcomeAction"]])
observe({
if (input$addNewOutcomeAction == 0) return()
newOutcome <- isolate(input$newOutcomeName)
if (nchar(newOutcome) == 0) {
feedback[["newOutcomeAction"]] <- "Enter the name for a new outcome."
return()
}
itemOutcomes <- isolate(getFocusedOutcomeDetailUnordered(input, rawData, recodeTable, permuteTable))
if (any(newOutcome == itemOutcomes)) {
feedback[["newOutcomeAction"]] <-
paste(omxQuotes(newOutcome), "is already an outcome.")
return()
}
focusedOutcomeItem <- isolate(input$focusedOutcomeItem)
focusedOutcomeSet <- isolate(input$focusedOutcomeSet)
origRecodeTable <- isolate(recodeTable$val)
cat("add outcome", newOutcome, "to item",focusedOutcomeItem,
"or set",focusedOutcomeSet, fill=T)
if (focusedOutcomeItem != '-') {
recodeTable$val <-
rbind(origRecodeTable,
data.frame(type="item",
name=focusedOutcomeItem,
nameHash='',
action="add",
from="",
to=newOutcome))
} else if (focusedOutcomeSet != '-') {
outcomes <- isolate(recodeOutcomes(input, rawData, recodeTable, permuteTable))
oSetHash <- sapply(outcomes, function(col) digest(col, ascii=TRUE))
nameHash <- oSetHash[focusedOutcomeSet == names(oSetHash)][[1]]
recodeTable$val <-
rbind(origRecodeTable,
data.frame(type="outcomeSet",
name=focusedOutcomeSet,
nameHash=nameHash,
action="add",
from="",
to=newOutcome))
} else {
feedback[["newOutcomeAction"]] <- "Select an outcome set or item first."
return()
}
feedback[["newOutcomeAction"]] <- ""
})
observe({
if (is.null(recodeTable$val) || nrow(recodeTable$val) == 0) {
updateNumericInput(session, "focusedRecodeRule", min=1, max=1)
} else {
updateNumericInput(session, "focusedRecodeRule", min=1, max=nrow(recodeTable$val))
}
})
output$resetRecodeActionFeedback <- renderText(feedback[["resetRecodeAction"]])
observe({
if (input$resetRecodeAction == 0) return()
origRecodeTable <- isolate(recodeTable$val)
if (is.null(origRecodeTable) || nrow(origRecodeTable) == 0) {
feedback[["resetRecodeAction"]] <- "The recode table is empty."
return()
}
tbl <- origRecodeTable[-isolate(input$focusedRecodeRule),]
rownames(tbl) <- NULL
recodeTable$val <- tbl
feedback[["resetRecodeAction"]] <- ""
})
observe({
if (input$focusedOutcomeMapAction == 0) return()
from <- isolate(input$focusedOutcomeMapFrom)
to <- isolate(input$focusedOutcomeMapTo)
if (to == "<Rename>") {
to <- isolate(input$focusedOutcomeRenameTo)
}
if (from == to) {
feedback[["focusedOutcomeMapAction"]] <-
paste0("Outcome ",omxQuotes(from)," is already mapped to ",omxQuotes(to),".")
return()
}
if (to == "<NA>") to <- ''
focusedOutcomeItem <- isolate(input$focusedOutcomeItem)
focusedOutcomeSet <- isolate(input$focusedOutcomeSet)
origRecodeTable <- isolate(recodeTable$val)
if (focusedOutcomeItem != '-') {
recodeTable$val <-
rbind(origRecodeTable,
data.frame(type="item",
name=focusedOutcomeItem,
nameHash='',
action="recode",
from=from, to=to))
} else if (focusedOutcomeSet != '-') {
outcomes <- isolate(recodeOutcomes(input, rawData, recodeTable, permuteTable))
oSetHash <- sapply(outcomes, function(col) digest(col, ascii=TRUE))
nameHash <- oSetHash[focusedOutcomeSet == names(oSetHash)][[1]]
recodeTable$val <-
rbind(origRecodeTable,
data.frame(type="outcomeSet",
name=focusedOutcomeSet,
nameHash=nameHash,
action="recode",
from=from, to=to))
} else {
feedback[["focusedOutcomeMapAction"]] <- "Select an outcome set or item first."
return()
}
feedback[["focusedOutcomeMapAction"]] <- ""
})
output$focusedOutcomeMapActionFeedback <- renderText(feedback[["focusedOutcomeMapAction"]])
output$focusedOutcomeTable <- renderTable(
data.frame(outcome=getFocusedOutcomeDetail(input, rawData, recodeTable, permuteTable)))
output$reorderOutcomesSorterUI <- renderUI({
outcomes <- getFocusedOutcomeDetail(input, rawData, recodeTable, permuteTable)
if (length(outcomes) == 0) {
return(returnOrder("reorderOutcomesSorter", "Select an item"))
}
returnOrder("reorderOutcomesSorter", outcomes)
})
observe({
newOrder <- input$reorderOutcomesSorter
outcomes <- isolate(getFocusedOutcomeDetailUnordered(input, rawData, recodeTable, permuteTable))
perm <- match(newOrder, outcomes)
focusedOutcomeItem <- isolate(input$focusedOutcomeItem)
focusedOutcomeSet <- isolate(input$focusedOutcomeSet)
if (focusedOutcomeItem != '-') {
fi <- focusedOutcomeItem
} else if (focusedOutcomeSet != '-') {
fi <- digest(outcomes, ascii=TRUE)
} else {
return()
}
oldPerm <- isolate(permuteTable$val[[fi]])
if (!is.null(oldPerm) && length(perm) == length(oldPerm) &&
all(perm == oldPerm)) return()
if (all(perm == 1:length(perm)) && !is.null(oldPerm)) {
permuteTable$val[[fi]] <- NULL
} else if (any(perm != 1:length(perm))) {
permuteTable$val[[fi]] <- perm
}
})
output$permuteTable <- renderTable({
pt <- permuteTable$val
if (length(pt) == 0) return()
t(mxSimplify2Array(pt))
})
output$reversePicker <- renderUI({
cols <- dataColumnNames(input, rawData, permuteTable)
revNames <- isolate(permuteTable$reversed)
rmask <- !is.na(match(cols, revNames))
chooserInput("reverseChooser", "Unreversed", "Reversed",
cols[!rmask], cols[rmask], size = 16, multiple = TRUE)
})
observe({
got <- input$reverseChooser
if (is.null(got)) return()
oldRev <- isolate(permuteTable$reversed)
newRev <- setdiff(union(oldRev, got$right), got$left)
if (length(oldRev) == length(newRev) && all(oldRev == newRev)) return()
if (verbose) cat("reverse chooser", paste(newRev, collapse=","), fill=TRUE)
permuteTable$reversed <- newRev
})
codingToScript <- function() {
out <- list("savedCodingVersion = 1")
for (tbl in AppStateTables) {
dat <- paste(deparse(reactiveValuesToList(get(tbl))), collapse="\n")
out <- c(out, paste(tbl, "<-", dat))
}
inputState <- reactiveValuesToList(input)[c(AppStateSliderInput, AppStateTextInput)]
out <- c(out, paste("input <-", paste(deparse(inputState), collapse="\n")))
paste(out, collapse="\n")
}
output$downloadCoding <- downloadHandler(
filename = function() {
paste(rawData$stem, '-config.R', sep='')
},
content = function(file) {
write(isolate(codingToScript()), file=file)
}
)
output$codingFileFeedback <- renderText(feedback[["codingFile"]])
output$debugSettingsOutput <- renderText({
hit <- input$refreshSettingsAction
isolate(codingToScript())
})
observe({
inFile <- input$codingFile
if (is.null(inFile)) return()
bubble <- new.env()
got <- try(source(inFile$datapath, local=bubble, echo=FALSE), silent=TRUE)
if (inherits(got, "try-error")) {
feedback[["codingFile"]] <- paste("Parse error", got, sep="\n")
return()
}
if (!exists(envir=bubble, inherits=FALSE, "savedCodingVersion") ||
get(envir=bubble, inherits=FALSE, "savedCodingVersion") != 1) {
feedback[["codingFile"]] <- "This does not seem to be a saved coding file."
return()
}
found <- list()
e1 <- as.environment(-1L)
for (tbl in AppStateTables) {
if (!exists(envir=bubble, inherits=FALSE, tbl)) next
rt <- mget(tbl, bubble, ifnotfound=list(NULL))[[tbl]]
dest <- get(tbl)
for (k in names(rt)) {
dest[[k]] <- rt[[k]]
}
found <- c(found, paste0(tbl,': ', paste0(names(rt), collapse=" ")))
}
inputState <- mget("input", bubble, ifnotfound=list(NULL))[["input"]]
if (!is.null(inputState)) {
for (elem in AppStateSliderInput) {
updateSliderInput(session, elem, value=inputState[[elem]])
}
for (elem in AppStateTextInput) {
updateTextInput(session, elem, value=inputState[[elem]])
}
found <- c(found, paste0("input",': ',paste0(c(AppStateSliderInput, AppStateTextInput), collapse=" ")))
}
feedback[["codingFile"]] <- paste0("Found the following saved settings:\n\n",
paste(found, collapse="\n"))
})
# ------------------------------------------------------------------ Item Model & Parameters
observe({
outcomes <- recodeOutcomes(input, rawData, recodeTable, permuteTable)
if (is.null(outcomes)) return()
numFactors <- input$numFactors
if (numFactors) for (fx in 1:numFactors) {
name <- paste0("nameOfFactor", fx)
fn <- isolate(input[[name]])
if (is.null(fn) || fn == "") {
updateTextInput(session, name, value=sillyFactorName[fx])
}
}
setupItemModels(input, rawData, itemModel, outcomes)
})
output$reorderItemsSorterUI <- renderUI({
items <- dataColumnNamesUnsorted(input, rawData)
if (length(items) == 0) {
return(returnOrder("reorderItemsSorter", "No data loaded"))
}
perm <- isolate(permuteTable$items)
if (!is.null(perm) && length(items) == length(perm)) items <- items[perm]
returnOrder("reorderItemsSorter", items)
})
observe({
newOrder <- input$reorderItemsSorter
items <- isolate(dataColumnNamesUnsorted(input, rawData))
perm <- match(newOrder, items)
oldPerm <- isolate(permuteTable$items)
if (!is.null(oldPerm) && length(perm) == length(oldPerm) &&
all(perm == oldPerm)) return()
if (all(perm == 1:length(perm)) && !is.null(oldPerm)) {
permuteTable$items <- NULL
} else if (any(perm != 1:length(perm))) {
permuteTable$items <- perm
}
})
observe({
newModel <- input$focusedItemModel
fi <- isolate(getFocusedItems(input, rawData, permuteTable))
if (is.null(newModel) || is.null(fi) || newModel == 'as is' || fi == "No data loaded") return()
if (verbose) cat("change", fi, "item model to", newModel, fill=T)
outcomes <- isolate(recodeOutcomes(input, rawData, recodeTable, permuteTable))
for (col in fi) {
changeItemModel(itemModel, input, length(outcomes[[col]]), col, newModel)
}
})
output$focusedItemModelTcFeedback <- renderText(feedback[['focusedItemModelTc']])
observe({
newTc <- input$focusedItemModelTc
fi <- getFocusedItems(input, rawData, permuteTable)
if (is.null(newTc) || is.null(fi) || newTc == 'as is' || fi == "No data loaded") return()
if (verbose) cat("change", fi, "item model Tc to", newTc, fill=T)
found <- FALSE
numFactors <- isolate(input$numFactors)
for (col in fi) {
im <- isolate(itemModel[[col]])
if (is.null(im$model) || im$model != "nrm") next
found <- TRUE
if (newTc != im$Tc) {
if (verbose) cat("change",col,"from", im$Tc,"to", newTc,fill=T)
im$Tc <- newTc
itemModel[[col]] <- im
}
}
if (!found) {
feedback[['focusedItemModelTc']] <- "Intercept basis options are only available for the nominal model."
} else {
feedback[['focusedItemModelTc']] <- ''
}
})
observe({
fi <- getFocusedItems(input, rawData, permuteTable)
if (length(fi) == 0) return()
Tsel <- 'as is'
Tchoices <- c('as is', 'trend', 'id', 'partial credit')
if (length(fi) > 1) {
sel <- 'as is'
choices <- c('as is', 'drm', 'grm', 'nrm')
} else {
fi <- fi[[1]]
outcomeMap <- recodeOutcomes(input, rawData, recodeTable, permuteTable)
outcomes <- length(outcomeMap[[fi]])
choices <- c('grm')
if (outcomes == 2) choices <- c('drm', choices)
if (outcomes > 2) choices <- c(choices, 'nrm')
im <- isolate(itemModel[[fi]])
sel <- im$model
if (length(sel) && sel == 'nrm') {
Tsel <- im$Tc
} else {
Tchoices <- 'as is'
}
}
updateSelectInput(session, "focusedItemModel", choices=choices, selected=sel)
updateSelectInput(session, "focusedItemModelTc", choices=Tchoices, selected=Tsel)
})
output$itemStartingValuesTable <- renderTable({
if (length(names(itemModel)) == 0) return(NULL)
sv <- buildParameterTable(input, rawData, permuteTable, itemModel, "starting")
# adjust for equality constraints
labels <- buildParameterTable(input, rawData, permuteTable, itemModel, "labels")
ltbl <- table(labels)
if (any(ltbl > 1)) {
hasLabel <- !is.na(labels)
for (lab in names(ltbl[ltbl > 1])) {
sv[hasLabel & labels== lab] <-
sample(sv[hasLabel & labels==lab], 1)
}
}
sv
})
output$itemFreeTable <- renderTable({
if (length(names(itemModel)) == 0) return(NULL)
buildParameterTable(input, rawData, permuteTable, itemModel, "free")
})
output$itemLabelTable <- renderTable({
if (length(names(itemModel)) == 0) return(NULL)
buildParameterTable(input, rawData, permuteTable, itemModel, "labels")
})
output$itemPriorTable <- renderTable({
if (length(names(itemModel)) == 0) return(NULL)
tbl <- buildParameterTable(input, rawData, permuteTable, itemModel, "labels")
map <- bayesianPrior$map
mapped <- match(tbl[,], names(map))
mapped[!is.na(mapped)] <- unlist(map[ mapped[!is.na(mapped)] ])
tbl[,] <- mapped
for (rx in rownames(tbl)) {
if (rx == 'g' || rx == 'u') {
# OK
} else {
tbl[rx,] <- sapply(tbl[rx,], function(pr) ifelse(is.na(pr), NA, "??"))
}
}
tbl
})
observe({
im <- getFocusedItem(input, rawData, permuteTable, itemModel)
if (is.null(im)) return()
pname <- getFocusedParameterNames(input, im)
prevSelect <- match(isolate(input$focusedItemParameter), pname)
if (is.na(prevSelect)) prevSelect <- 1
updateSelectInput(session, "focusedItemParameter",
choices=pname, selected=pname[prevSelect])
})
observe({
im <- getFocusedItem(input, rawData, permuteTable, itemModel)
if (is.null(im)) return()
fx <- match(input$focusedItemParameter,
isolate(getFocusedParameterNames(input, im)))
if (is.na(fx)) return()
spec <- itemToSpec(im)
if (fx > rpf.numParam(spec)) return()
choices <- c("Free", 0, 1)
pi <- rpf.paramInfo(spec, fx)
if (pi$type == "bound") choices <- c(choices, "inf")
sel <- computeFreeSelected(im, fx)
allFocused <- length(getFocusedItems(input, rawData, permuteTable)) > 1
if (allFocused) {
choices <- c("as is", choices)
sel <- "as is"
}
updateSelectInput(session, "focusedParameterFree", choices=choices,
selected=sel)
label <- im$labels[fx]
if (is.na(label)) label <- "none"
if (allFocused) {
label <- "as is"
}
updateTextInput(session, "focusedParameterLabel", value=label)
})
observe({
if (input$focusedParameterFree == "as is" ||
input$focusedParameterFree == "No parameter selected") return()
im <- isolate(getFocusedItem(input, rawData, permuteTable, itemModel))
if (is.null(im)) return()
origFx <- isolate(match(input$focusedItemParameter,
getFocusedParameterNames(input, im)))
if (is.na(origFx)) return()
pname <- names(im$starting)[origFx]
dcols <- isolate(getFocusedItems(input, rawData, permuteTable))
for (col in dcols) {
maybeUpdateFree(input, itemModel, isolate(itemModel[[col]]), pname)
}
})
observe({
hit <- input$changeLabelAction
if (hit == 0 || isolate(input$focusedParameterLabel) == "as is") return()
im <- isolate(getFocusedItem(input, rawData, permuteTable, itemModel))
if (is.null(im)) return()
origFx <- isolate(match(input$focusedItemParameter,
getFocusedParameterNames(input, im)))
if (is.na(origFx)) return()
pname <- names(im$starting)[origFx]
dcols <- isolate(getFocusedItems(input, rawData, permuteTable))
for (col in dcols) {
maybeUpdateLabel(input, itemModel, isolate(itemModel[[col]]), pname)
}
})
output$focusedParameterPriorFeedback <- renderText(feedback[["focusedParameterPrior"]])
observe({
hit <- input$focusedParameterPriorSetAction
if (hit == 0) return()
im <- isolate(getFocusedItem(input, rawData, permuteTable, itemModel))
if (is.null(im)) return()
origFx <- isolate(match(input$focusedItemParameter,
getFocusedParameterNames(input, im)))
if (is.na(origFx)) return()
pname <- names(im$starting)[origFx]
dcols <- isolate(getFocusedItems(input, rawData, permuteTable))
for (col in dcols) {
feedback[["focusedParameterPrior"]] <-
updatePriorMode(input, bayesianPrior, itemModel, isolate(itemModel[[col]]), pname, set=TRUE)
}
})
observe({
hit <- input$focusedParameterPriorClearAction
if (hit == 0) return()
im <- isolate(getFocusedItem(input, rawData, permuteTable, itemModel))
if (is.null(im)) return()
origFx <- isolate(match(input$focusedItemParameter,
getFocusedParameterNames(input, im)))
if (is.na(origFx)) return()
pname <- names(im$starting)[origFx]
dcols <- isolate(getFocusedItems(input, rawData, permuteTable))
for (col in dcols) {
updatePriorMode(input, bayesianPrior, itemModel, itemModel[[col]], pname, set=FALSE)
}
feedback[["focusedParameterPrior"]] <- ''
})
output$excludePicker <- renderUI({
cols <- dataColumnNames(input, rawData, permuteTable)
exNames <- isolate(permuteTable$exclude)
emask <- !is.na(match(cols, exNames))
chooserInput("excludeChooser", "Included", "Excluded",
cols[!emask], cols[emask], size = 16, multiple = TRUE)
})
observe({
got <- input$excludeChooser
if (is.null(got)) return()
oldRev <- isolate(permuteTable$exclude)
newRev <- setdiff(union(oldRev, got$right), got$left)
if (length(oldRev) == length(newRev) && all(oldRev == newRev)) return()
if (verbose) cat("exclude chooser", paste(newRev, collapse=","), fill=TRUE)
permuteTable$exclude <- newRev
})
output$itemModelAssignment <- renderTable({
if (length(names(itemModel)) == 0) return(NULL)
outcomes <- recodeOutcomes(input, rawData, recodeTable, permuteTable)
massign <- mapply(function (col, cname) {
im <- itemModel[[cname]]
c(Outcomes=length(col),
Model=im$model, T.a=im$Ta, T.c=im$Tc,
Reversed=cname %in% permuteTable$reversed,
Excluded=cname %in% permuteTable$exclude)
}, outcomes, names(outcomes), SIMPLIFY=FALSE)
tbl <- t(mxSimplify2Array(massign))
for (bcol in c('Reversed','Excluded')) {
tbl[tbl[,bcol] == "FALSE", bcol] <- NA
}
tbl
})
# ------------------------------------------------------------------ Preview & Download
output$debugScriptOutput <- renderText({
input$debugScriptAction
validate(need(nrow(rawData$val), "No data is loaded"))
str <- try(isolate(toScript(input, rawData, recodeTable, permuteTable, itemModel, bayesianPrior)), silent=TRUE)
validate(need(!inherits(str, "try-error"),
paste("An error occurred. Please report this to the development team.",
str, sep="\n")))
str
})
output$downloadScript <- downloadHandler(
filename = function() {
validate(need(!is.null(rawData$stem), "No data is loaded")) # TODO, fix
paste(rawData$stem, '.Rmd', sep='')
},
content = function(file) {
write(isolate(toScript(input, rawData, recodeTable, permuteTable, itemModel, bayesianPrior)), file=file)
}
)
})
Try the ifaTools package in your browser
Any scripts or data that you put into this service are public.
ifaTools documentation built on Jan. 20, 2022, 1:08 a.m.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
library(shiny)
library(OpenMx)
library(rpf)
library(digest)
# drm == dichotomous help TODO
# do something for minItemsPerScore
#options(shiny.trace=TRUE)
#options(shiny.reactlog=TRUE)
verbose <- FALSE
# Use stupid nouns here to encourage folks to change them
# to more sensible ability labels.
sillyFactorName <- c('teacup','puppy','oink','sun','moon')
AppStateTables <- c("recodeTable", "permuteTable", "itemModel", "bayesianPrior")
AppStateSliderInput <- c("numFactors")
AppStateTextInput <- paste0("nameOfFactor", 1:5)
itemToSpec <- function(item) {
# cat("itemToSpec", item$model, item$outcomes, item$factors, fill=T)
if (is.null(item$model)) browser()
outcomes <- item$outcomes
factors <- item$factors
# Tc doesn't really matter here
switch(item$model,
'drm' = rpf.drm(factors = factors),
'grm' = rpf.grm(outcomes, factors = factors),
'nrm' = rpf.nrm(outcomes, factors = factors, T.a=item$Ta,
T.c=ifelse(item$Tc == 'partial credit', 'id', item$Tc)))
}
mergeDataAndModel <- function(col, outcomes, factors, item) {
if (length(outcomes) != 1) browser()
if (outcomes < 2) return(item) # will complain later
if (is.null(item) ||
(outcomes > 2 && item$model == 'drm') ||
(outcomes == 2 && item$model == 'nrm')) {
# if (verbose) cat("set default model", fill=T)
spec <- rpf.grm(outcomes, factors = factors)
np <- rpf.numParam(spec)
return(list(name=col, model='grm', outcomes=outcomes, factors=factors,
starting=rpf.rparam(spec), labels=rep(NA, np), free=rep(TRUE, np)))
}
if (item$model == 'nrm') {
if (is.null(item$Ta)) item$Ta <- "trend"
if (is.null(item$Tc)) item$Tc <- "trend"
} else {
item$Ta <- NULL
item$Tc <- NULL
}
item$name <- col
item$outcomes <- outcomes
item$factors <- factors
spec <- itemToSpec(item)
np <- rpf.numParam(spec)
if (length(item$starting) != np) {
newSV <- rpf.rparam(spec)
preserveMap <- match(names(newSV), item$starting)
newInd <- which(!is.na(preserveMap))
preserveMap <- preserveMap[!is.na(preserveMap)]
oldItem <- item
item$starting <- newSV
item$free <- rep(TRUE, np)
item$labels <- rep(NA, np)
item$starting[newInd] <- oldItem$starting[preserveMap]
item$free[newInd] <- oldItem$free[preserveMap]
item$labels[newInd] <- oldItem$labels[preserveMap]
}
item
}
changeItemModel <- function(itemModel, input, outcomes, fi, newModel) {
oldModel <- isolate(itemModel[[fi]]$model)
if (is.null(oldModel)) return()
if (newModel != oldModel) {
if (verbose) cat("change",fi,"from", oldModel,"to", newModel,fill=T)
item <- isolate(itemModel[[fi]])
item$model <- newModel
numFactors <- isolate(input$numFactors)
itemModel[[fi]] <- mergeDataAndModel(fi, outcomes, numFactors, item)
}
}
getFactorNames <- function(input) {
numFactors <- isolate(input$numFactors)
if (numFactors == 0) return(c())
sapply(1:numFactors, function (x) input[[ paste0("nameOfFactor", x) ]])
}
getFocusedItems <- function(input, rawData, permuteTable) {
dcols <- includedColumnNames(input, rawData, permuteTable)
range <- sort(match(c(input$focusedItemStart, input$focusedItemEnd), dcols))
if (length(range) != 2) return(c())
dcols[seq(range[1], range[2])]
}
buildParameterTable <- function(input, rawData, permuteTable, itemModel, attr) {
dcols <- getFocusedItems(input, rawData, permuteTable)
if (length(dcols) == 0) return(NULL)
massign <- lapply(dcols, function (col) {
im <- itemModel[[col]]
v <- im[[attr]]
names(v) <- names(im$starting)
v
})
names(massign) <- dcols
tbl <- mxSimplify2Array(massign)
fnames <- getFactorNames(input)
if (length(fnames)) {
rownames(tbl)[1:length(fnames)] <- fnames
}
tbl
}
getFocusedItem <- function(input, rawData, permuteTable, itemModel) {
inames <- getFocusedItems(input, rawData, permuteTable)
if (length(inames) == 0) return()
im <- itemModel[[ inames[1] ]]
im
}
getFocusedParameterNames <- function(input, im) {
pname <- names(im$starting)
fnames <- getFactorNames(input)
if (length(fnames)) {
pname[1:length(fnames)] <- fnames
}
pname
}
computeFreeSelected <- function(im, fx) {
sel <- "Free"
isFree <- im$free[fx]
if (!isFree) {
if (is.finite(im$starting[fx])) {
sel <- im$starting[fx]
} else {
sel <- "inf"
}
}
sel
}
maybeUpdateFree <- function(input, itemModel, im, pname) {
fx <- match(pname, names(im$starting))
if (is.na(fx)) return()
spec <- itemToSpec(im)
sel <- computeFreeSelected(im, fx)
if (sel == input$focusedParameterFree) return()
if (input$focusedParameterFree == "Free") {
if (verbose) cat("free", pname, "of", im$name, fill=TRUE)
im$free[fx] <- TRUE
im$starting[fx] <- rpf.rparam(spec)[fx]
} else {
if (verbose) cat("fixed", pname, "of", im$name, "to",
input$focusedParameterFree, fill=TRUE)
im$free[fx] <- FALSE
pi <- rpf.paramInfo(spec, fx)
if (pi$type == 'bound' && input$focusedParameterFree == 'inf') {
if (names(im$starting[fx]) == 'g') {
im$starting[fx] <- qlogis(0)
} else {
im$starting[fx] <- qlogis(1)
}
} else {
im$starting[fx] <- as.numeric(input$focusedParameterFree)
}
}
itemModel[[ im$name ]] <- im
}
maybeUpdateLabel <- function(input, itemModel, im, pname) {
proposal <- isolate(input$focusedParameterLabel)
newLabel <- ifelse(nchar(proposal), mxMakeNames(proposal), proposal)
fx <- match(pname, names(im$starting))
if (is.na(fx)) return()
sel <- im$labels[fx]
if (is.na(sel)) sel <- "none"
if (sel == newLabel) return()
if (newLabel == "none" || !nzchar(newLabel)) {
im$labels[fx] <- NA
} else {
im$labels[fx] <- newLabel
}
itemModel[[ im$name ]] <- im
}
toScript <- function(input, rawData, recodeTable, permuteTable, itemModel, bayesianPrior) {
if (is.null(rawData$name)) {
loadData <- paste(c("# load some demonstration data",
as.character(rawData$loadDemo)), collapse="\n")
} else {
loadData <- c("# Adjust the path in the next statement to load your data\n",
paste0("data <- read.csv(na.strings=c(), file='",rawData$name,"'"))
if (!input$dataHeader) loadData <- c(loadData, ",header=FALSE")
if (input$dataSep != ",") {
loadData <- c(loadData, paste0(",sep='", input$dataSep, "'"))
}
if (input$dataQuote != '"') {
loadData <- c(loadData, paste0(',quote="', input$dataQuote, '"'))
}
loadData <- c(loadData, ",stringsAsFactors=FALSE,check.names=FALSE)\n",
"colnames(data) <- mxMakeNames(colnames(data), unique=TRUE)")
}
if (input$freqColumnName != '-') {
fc <- input$freqColumnName
loadData <- c(loadData, paste0("\ndata[['", fc, "']] <- as.numeric(data[['", fc, "']])"))
}
loadData <- c(loadData,
sapply(setdiff(permuteTable$exclude, input$freqColumnName),
function(col) paste0("\ndata[['", col, "']] <- NULL # excluded")))
data <- rawData$val
dcols <- includedColumnNames(input, rawData, permuteTable)
mkSpec <- list("spec <- list()")
mker <- sapply(dcols, function(col) {
im <- itemModel[[col]]
str <- c("list(rpf.", im$model, "(factors=numFactors")
if (im$model != "drm") {
str <- c(str, ",outcomes=", im$outcomes)
}
if (im$model == "nrm") {
tc <- im$Tc
if (tc == 'partial credit') {
tc <- paste0("lower.tri(diag(", im$outcomes-1, "),TRUE) * -1")
} else {
tc <- paste0("'",tc,"'")
}
str <- c(str, ",T.a='", im$Ta, "', T.c=", tc)
}
paste0(c(str, "))"), collapse="")
})
code <- rle(mker)
val <- code$values
starts <- cumsum(c(1, code$lengths))[c(rep(TRUE,length(val)),FALSE)]
lens <- code$lengths
if (length(starts) == 1) {
mkSpec <- c(mkSpec, paste0("spec[1:", length(mker),"] <- ",mker[1]))
} else {
mkSpec <- c(mkSpec, mapply(function(start, len, v1) {
paste0("spec[",start,":",(start+len),"] <- ",v1)
}, starts, lens - 1L, val, SIMPLIFY=FALSE))
}
mkSpec <- c(mkSpec,
paste0("names(spec) <- ", paste(deparse(dcols), collapse="\n ")))
mkSpec <- paste(mkSpec, collapse="\n")
fnames <- getFactorNames(input)
starting <- mxSimplify2Array(lapply(dcols, function(col) { itemModel[[col]]$starting }))
free <- mxSimplify2Array(lapply(dcols, function(col) { itemModel[[col]]$free }))
free[is.na(free)] <- TRUE # can ignore these
labels <- mxSimplify2Array(lapply(dcols, function(col) { itemModel[[col]]$labels }))
labels[!free] <- NA
rnames <- paste0('p', 1:nrow(starting))
if (length(fnames)) {
rnames[1:length(fnames)] <- fnames
}
itemInit <- list()
for (rx in 1:nrow(free)) {
rname <- paste0("'", rnames[rx], "'")
fcode <- rle(!free[rx,])
mask <- fcode$values
starts <- cumsum(c(1, fcode$lengths))[c(mask,FALSE)]
lens <- fcode$lengths[mask]
if (length(starts) == 0) {
next
}
if (length(starts) == 1 && lens == ncol(free)) {
itemInit <- c(itemInit, paste0("imat$free[",rname,",] <- FALSE"))
} else {
itemInit <- c(itemInit, mapply(function(start, len) {
paste0("imat$free[",rname,",",start,":",(start+len),"] <- FALSE")
}, starts, lens - 1L, SIMPLIFY=FALSE))
}
srow <- starting[rx,]
srow[free[rx,]] <- NA
code <- rle(srow)
mask <- !is.na(code$value)
itemInit <- c(itemInit, mapply(function(start, len) {
paste0("imat$values[",rname,",",start,":",(start+len),"] <- ", srow[start])
}, cumsum(c(1, code$lengths))[c(mask,FALSE)], code$lengths[mask] - 1L, SIMPLIFY=FALSE))
}
for (rx in 1:nrow(free)) {
rname <- paste0("'", rnames[rx], "'")
code <- rle(labels[rx,])
mask <- !is.na(code$values)
val <- code$values[mask]
starts <- cumsum(c(1, code$lengths))[c(mask,FALSE)]
lens <- code$lengths[mask]
if (length(starts) == 0) next
if (length(starts) == 1 && lens == ncol(free)) {
itemInit <- c(itemInit, paste0("imat$labels[",rname,",] <- '",val[1],"'"))
} else {
itemInit <- c(itemInit, mapply(function(start, len, v1) {
paste0("imat$labels[",rname,",",start,":",(start+len),"] <- '",v1,"'")
}, starts, lens - 1L, val, SIMPLIFY=FALSE))
}
}
ltbl <- table(labels)
if (any(ltbl > 1)) {
itemInit <- c(itemInit,
"hasLabel <- !is.na(imat$labels)",
paste0("for (lab1 in unique(imat$labels[hasLabel])) {
imat$values[hasLabel & imat$labels==lab1] <-
sample(imat$values[hasLabel & imat$labels==lab1], 1)
}"))
}
itemInit <- paste(itemInit, collapse="\n")
topModel <- "itemModel"
fitIFAgroup <- "m1Fit"
ul <- unique(labels)
ul <- ul[!is.na(ul)]
bpList <- match(ul, names(bayesianPrior$map))
bpList <- sort(bpList[!is.na(bpList)])
priorInit <- c()
if (length(bpList)) {
topModel <- "container"
fitIFAgroup <- "m1Fit$itemModel"
bmode <- bayesianPrior$map[bpList]
bmodeNames <- names(bmode)
names(bmode) <- NULL
priorInit <- c(priorInit,
"",
paste0("priorLabels <- ", paste0(deparse(bmodeNames), collapse="")),
"priorMode <- rep(NA, length(priorLabels))")
code <- rle(as.character(bmode))
val <- code$values
starts <- cumsum(c(1, code$lengths))[c(rep(TRUE, length(val)),FALSE)]
lens <- code$lengths
if (length(starts) == 1) {
priorInit <- c(priorInit, paste0("priorMode[1:",length(bmode),"] <- ",bmode[1]))
} else {
priorInit <- c(priorInit, mapply(function(start, len, v1) {
paste0("priorMode[",start,":",(start+len),"] <- ",v1)
}, starts, lens - 1L, val, SIMPLIFY=FALSE))
}
if (input$boundPriorForm == "Beta") {
priorInit <- c(priorInit,
"priorModel <- univariatePrior('beta', priorLabels, priorMode)")
} else if (input$boundPriorForm == "Logit-normal") {
priorInit <- c(priorInit,
"priorModel <- univariatePrior('logit-norm', priorLabels, priorMode)")
} else { browser() }
}
if (length(priorInit)) {
priorInit <- c(priorInit,
"container <- mxModel(model='container', itemModel, priorModel,
mxFitFunctionMultigroup(groups=c('itemModel.fitfunction', 'univariatePrior.fitfunction')))")
priorInit <- paste(priorInit, collapse="\n")
}
writeFactorNames <- ''
if (length(fnames)) {
writeFactorNames <- "rownames(startingValues)[1:numFactors] <- factors"
}
freqCol <- input$freqColumnName
maybeCompress <- list()
freqDataArgs <- ''
# This is temporarily broken because of changes in OpenMx TODO
# if (freqCol == '-') {
# maybeCompress <- "data <- compressDataFrame(data)"
# freqCol <- "freq"
# }
if (freqCol != '-') {
freqDataArgs <- paste0(", frequency='", freqCol,"'")
}
numExtraCol <- 1
getRefModels <- ""
if (input$fitReferenceModels) {
getRefModels <- ", refModels=mxRefModels(itemModel, run = TRUE)"
}
emArgs <- paste0("'itemModel.expectation', 'scores',
mxComputeNewtonRaphson(), verbose=", ifelse(input$showFitProgress, "2L", "0L"))
if (input$infoMethod == "*none*") {
computePlan <- paste0("computePlan <- mxComputeEM(", emArgs, ")")
} else if (input$infoMethod == "Meat") {
computePlan <- paste0("emStep <- mxComputeEM(", emArgs,")\n",
"computePlan <- mxComputeSequence(list(EM=emStep,
IM=mxComputeOnce('fitfunction', 'information', 'meat'),
HQ=mxComputeHessianQuality(),
SE=mxComputeStandardError()))")
} else if (input$infoMethod == "Oakes") {
emArgs <- paste0(emArgs, ",\n information='oakes1999', infoArgs=list(fitfunction='fitfunction')")
computePlan <- paste0("emStep <- mxComputeEM(", emArgs,")\n",
"computePlan <- mxComputeSequence(list(EM=emStep,
HQ=mxComputeHessianQuality(),
SE=mxComputeStandardError()))")
} else if (input$infoMethod == "Agile SEM") {
emArgs <- paste0(emArgs, ",\n information='mr1991',
infoArgs=list(fitfunction='fitfunction', semMethod='agile')")
computePlan <- paste0("emStep <- mxComputeEM(", emArgs,")\n",
"computePlan <- mxComputeSequence(list(SE=emStep,
HQ=mxComputeHessianQuality(),
SE=mxComputeStandardError()))")
} else {
browser()
}
doPlots <- c()
if (length(fnames)) {
doPlots <- c("",
"```{r,fig.height=2}
map1 <- itemResponseMap(m1Grp, factor=1)
ggplot(map1, aes(x=score, y=item, label=outcome)) +
geom_text(size=4, position=position_jitter(h=.25))
```",
"",
"```{r,fig.height=3}
pl <- lapply(names(sfit), function(item) { SitemPlot(sfit, item) })
for (px in 1:length(pl)) {
print(pl[[px]])
}
basis <- rep(0, length(factors))
basis[1] <- 1
plotInformation(m1Grp, width=5, basis=basis)
```")
}
paste(
"---",
paste0('title: "',rawData$stem, '"'),
paste0('date: "', format(Sys.time(), "%d-%b-%Y"), '"'),
paste0("output: html_document"),
"---\n",
"```{r}",
"options(width=120, scipen=2, digits=2)",
"suppressPackageStartupMessages(library(OpenMx))",
"suppressPackageStartupMessages(library(rpf))",
"suppressPackageStartupMessages(library(ifaTools))",
"library(xtable)",
"options(xtable.type='html')",
"",
paste0(loadData, collapse=""),
"",
paste0("factors <- ", paste0(deparse(fnames)), collapse=""),
"numFactors <- length(factors)",
mkSpec,
"",
"missingColumns <- which(is.na(match(names(spec), colnames(data))))",
"if (length(missingColumns)) {",
" stop(paste('Columns missing in the data:', omxQuotes(names(spec)[missingColumns])))",
"}",
"",
genRecodeOutcomesCode(input, rawData, recodeTable, permuteTable),
"",
"#set.seed(1) # uncomment to get the same starting values every time",
"startingValues <- mxSimplify2Array(lapply(spec, rpf.rparam))",
"rownames(startingValues) <- paste0('p', 1:nrow(startingValues))",
writeFactorNames,
"",
"imat <- mxMatrix(name='item', values=startingValues, free=!is.na(startingValues))",
itemInit,
"# Remove non-factor columns (if any)",
"data <- data[,sapply(data, is.factor)]",
"# Remove all-missing rows",
"data <- data[rowSums(!is.na(data[,names(spec)])) != 0,]",
maybeCompress,
paste0("itemModel <- mxModel(model='itemModel', imat,
mxData(observed=data, type='raw'", freqDataArgs, "),
mxExpectationBA81(ItemSpec=spec),
mxFitFunctionML())"),
priorInit,
"",
computePlan,
paste0(topModel, " <- mxModel(", topModel, ", computePlan)"),
"",
paste0("m1Fit <- mxRun(", topModel, ")"),
"",
paste0("m1Grp <- as.IFAgroup(", fitIFAgroup ,", minItemsPerScore=1L)"),
"```",
"",
"An item factor model was fit with `r length(factors)`
factors (`r ifelse(length(factors), factors, '-')`), -2LL=$`r m1Fit$output$fit`$.",
"The condition number of the information matrix was `r round(m1Fit$output$conditionNumber)`.",
"",
"```{r,fig.height=2}
got <- sumScoreEAPTest(m1Grp)
df <- data.frame(score=as.numeric(names(got[['observed']])),
expected=got[['expected']], observed=got[['observed']])
df <- melt(df, id='score', variable.name='source', value.name='n')
ggplot(df, aes(x=score, y=n, color=source)) + geom_line()
```",
"",
"```{r,results='asis'}
ct <- ChenThissen1997(m1Grp)
print(xtable(ct$pval, paste('Log p-value of local dependence between item pairs.')))
```",
"",
"```{r,results='asis'}
sfit <- SitemFit(m1Grp)
tbl <- t(sapply(sfit, function(r) c(n=r$n, df=r$df, stat=r$statistic, pval=r$pval)))
print(xtable(tbl, paste0('Sum-score item-wise fit')))
```",
paste(doPlots, collapse="\n"),
"",
paste0("```{r}
summary(m1Fit", getRefModels, ")
```"),
"",
"```{r,results='asis'}
citation('OpenMx')
```",
sep="\n")
}
execRecodeRule <- function(rc, outcomes) {
if (rc$type == "item") {
ix <- match(rc$name, names(outcomes))
if (is.na(ix)) return(outcomes)
p1 <- setdiff(outcomes[[ix]], rc$from)
if (rc$to != '') p1 <- union(p1, rc$to)
outcomes[[ix]] <- sort(p1)
} else if (rc$type == "outcomeSet") {
oSetNames <- sapply(outcomes, function(oc) digest(oc, ascii=TRUE))
for (ix in which(rc$nameHash == oSetNames)) {
p1 <- setdiff(outcomes[[ix]], rc$from)
if (rc$to != '') p1 <- union(p1, rc$to)
outcomes[[ix]] <- sort(p1)
}
}
outcomes
}
recodeOutcomes <- function(input, rawData, recodeTable, permuteTable) {
dat <- rawData$val
if (is.null(dat)) return(NULL)
ch <- includedColumnNames(input, rawData, permuteTable)
outcomes <- lapply(dat[,ch], function(col) {
sort(unique(col))
})
if (!is.null(recodeTable$val) && nrow(recodeTable$val)) for (rcX in 1:nrow(recodeTable$val)) {
rc <- recodeTable$val[rcX,]
outcomes <- execRecodeRule(rc, outcomes)
}
outcomes
}
flushFactorTransform <- function(fa1, col) {
args <- list(col," <- mxFactor(", col, ", ",
"levels=", paste(deparse(fa1$levels), collapse=""))
if (any(fa1$levels != fa1$labels)) {
args <- c(args, ", labels=", paste(deparse(fa1$labels), collapse=""))
}
if (length(fa1$exclude)) {
args <- c(args, ", exclude=", paste(deparse(fa1$exclude), collapse=""))
}
if (any(duplicated(fa1$labels))) {
args <- c(args, ", collapse=TRUE")
}
args <- c(args, ")")
do.call(paste0, args)
}
trackRecodeRule <- function(fa1, ix, rc, col) {
xf1 <- c()
from <- as.character(rc$from)
to <- as.character(rc$to)
if (from != '' && to != '') {
fx <- match(from, fa1$levels)
if (is.na(fx)) {
xf1 <- c(xf1, flushFactorTransform(fa1, paste0("data[[",col,"]]")))
newLevels <- sort(fa1$labels)
fa1 <- list(levels=newLevels, labels=newLevels, exclude=c())
}
fx <- match(from, fa1$levels)
fa1$labels[fx] <- to
} else if (from == '' && to != '') {
fa1$levels <- append(fa1$levels, to)
fa1$labels <- append(fa1$labels, to)
} else if (from != '' && to == '') {
fx <- match(from, fa1$levels)
if (is.na(fx)) {
xf1 <- c(xf1, flushFactorTransform(fa1, paste0("data[[",col,"]]")))
fa1 <- list(levels=fa1$labels, labels=fa1$labels, exclude=c())
}
fa1$exclude <- append(fa1$exclude, from)
fx <- match(from, fa1$levels)
fa1$levels <- fa1$levels[-fx]
fa1$labels <- fa1$labels[-fx]
}
list(fa1=fa1, xf1=xf1)
}
genRecodeOutcomesCode <- function(input, rawData, recodeTable, permuteTable) {
dat <- rawData$val
if (is.null(dat)) return(NULL)
ch <- includedColumnNames(input, rawData, permuteTable)
outcomes <- lapply(dat[,ch], function(col) {
sort(unique(col))
})
farg <- lapply(outcomes, function(lev) list(levels=lev, labels=lev, exclude=c()))
xform <- c()
if (!is.null(recodeTable$val) && nrow(recodeTable$val)) for (rcX in 1:nrow(recodeTable$val)) {
rc <- recodeTable$val[rcX,]
xf1 <- c()
if (rc$type == "item") {
ix <- match(rc$name, names(outcomes))
if (!is.na(ix)) {
trr <- trackRecodeRule(farg[[ix]], rc$name, rc, paste0("'",rc$name,"'"))
farg[[ix]] <- trr$fa1
xf1 <- c(xf1, trr$xf1)
}
} else if (rc$type == "outcomeSet") {
oSetNames <- sapply(outcomes, function(oc) digest(oc, ascii=TRUE))
xf2 <- c()
loop <- names(which(rc$nameHash == oSetNames))
for (ix in loop) {
trr <- trackRecodeRule(farg[[ix]], ix, rc, "col")
farg[[ix]] <- trr$fa1
xf2 <- trr$xf1 # only need 1 copy
}
if (length(xf2)) {
# tricky and hard to test TODO
xf1 <- c(xf1, paste0("for (col in ",paste(" ", deparse(loop), collapse="\n"),") {\n",
xf2, "}\n"))
}
}
xform <- c(xform, xf1)
outcomes <- execRecodeRule(rc, outcomes)
}
farg <- lapply(farg, function(fa) {
perm <- order(fa$labels)
fa$levels <- fa$levels[perm]
fa$labels <- fa$labels[perm]
fa
})
oSetNames <- sapply(outcomes, function(oc) digest(oc, ascii=TRUE))
for (pe in names(permuteTable$val)) {
if (all(pe != oSetNames)) next
perm <- permuteTable$val[[pe]]
for (name in names(oSetNames[pe == oSetNames])) {
fa <- farg[[name]]
fa$levels <- fa$levels[perm]
fa$labels <- fa$labels[perm]
farg[[name]] <- fa
}
}
for (pe in intersect(names(permuteTable$val), names(outcomes))) {
perm <- permuteTable$val[[pe]]
fa <- farg[[pe]]
fa$levels <- fa$levels[perm]
fa$labels <- fa$labels[perm]
farg[[pe]] <- fa
}
fSetNames <- sapply(farg, function(oc) digest(oc, ascii=TRUE))
fSetTbl <- table(fSetNames)
if (length(fSetTbl) == 1) {
pick <- names(farg)[1]
xform <- c(xform, flushFactorTransform(farg[[pick]], "data[names(spec)]"))
} else {
for (fs in names(fSetTbl)) {
loop <- names(fSetNames[fs == fSetNames])
l1 <- loop[1]
xform <- c(xform, paste0("for (col in ",paste(" ", deparse(loop), collapse="\n"),") {\n ",
flushFactorTransform(farg[[l1]], "data[[col]]"),
"\n}"))
}
}
toRev <- intersect(ch, permuteTable$reversed)
if (length(toRev)) {
xform <- c(xform, paste0("# reverse levels of reversed items\n",
"for (col in ",paste(" ", deparse(toRev), collapse="\n"),") {\n ",
"data[[col]] <- mxFactor(data[[col]], rev(levels(data[[col]])))",
"\n}"))
}
paste(xform, collapse="\n")
}
getFocusedOutcomeDetailUnordered <- function(input, rawData, recodeTable, permuteTable) {
outcomes <- recodeOutcomes(input, rawData, recodeTable, permuteTable) # could accept this as an argument TODO
if (input$focusedOutcomeItem != '-') {
fi <- input$focusedOutcomeItem
iout <- outcomes[[fi]]
perm <- permuteTable$val[[ digest(iout, ascii=TRUE) ]]
if (!is.null(perm) && length(perm) == length(iout)) {
iout <- iout[perm]
}
return(iout)
}
if (input$focusedOutcomeSet != '-') {
fi <- input$focusedOutcomeSet
return(outcomes[[fi]])
}
return(NULL)
}
getFocusedOutcomeDetail <- function(input, rawData, recodeTable, permuteTable) {
outcomes <- getFocusedOutcomeDetailUnordered(input, rawData, recodeTable, permuteTable)
if (input$focusedOutcomeItem != '-') {
fi <- input$focusedOutcomeItem
} else if (input$focusedOutcomeSet != '-') {
fi <- digest(outcomes, ascii=TRUE)
} else {
return(outcomes)
}
perm <- permuteTable$val[[fi]]
if (!is.null(perm) && length(perm) == length(outcomes)) {
outcomes <- outcomes[perm]
}
outcomes
}
dataColumnNamesUnsorted <- function(input, rawData) {
dcol <- colnames(rawData$val)
if (input$freqColumnName != '-') {
dcol <- setdiff(dcol, input$freqColumnName)
}
dcol
}
dataColumnNames <- function(input, rawData, permuteTable) {
dcol <- dataColumnNamesUnsorted(input, rawData)
perm <- permuteTable$items
if (!is.null(perm) && length(perm) == length(dcol)) dcol <- dcol[perm]
dcol
}
includedColumnNames <- function(input, rawData, permuteTable) {
setdiff(dataColumnNames(input, rawData, permuteTable), permuteTable$exclude)
}
setupItemModels <- function(input, rawData, itemModel, outcomes) {
numFactors <- isolate(input$numFactors)
dcol <- isolate(dataColumnNamesUnsorted(input, rawData))
for (col in dcol) {
itemModel[[col]] <- mergeDataAndModel(col, length(outcomes[[col]]), numFactors,
isolate(itemModel[[col]]))
}
}
setupFreqColumnName <- function(session, rawData, freqCol) {
dcols <- isolate(colnames(rawData$val))
if (!missing(freqCol) && is.na(match(freqCol, dcols))) browser()
if (missing(freqCol)) freqCol <- "-"
updateSelectInput(session, "freqColumnName", selected=freqCol,
choices=c("-", dcols))
}
updatePriorMode <- function(input, bayesianPrior, itemModel, im, pname, set) {
fx <- match(pname, names(im$starting))
if (is.na(fx)) return()
oldLabel <- im$labels[fx]
map <- isolate(bayesianPrior$map)
if (set) {
if (!(im$model == 'drm' && (pname == 'g' || pname == 'u')))
return("Can only set prior on dichotomous (drm) bound parameters.")
prior <- isolate(input$focusedParameterPrior)
if (is.na(oldLabel) || !nzchar(oldLabel)) {
oldLabel <- paste0(im$name,"_",pname)
im$labels[fx] <- oldLabel
itemModel[[im$name]] <- im
}
if (pname == 'g') {
mode <- paste0("logit(1/",prior,")")
} else if (pname == 'u') {
mode <- paste0("logit(",(as.integer(prior)-1),"/",prior,")")
}
if (verbose) cat("set bayesian prior", im$name, pname, "to", mode,"using label", oldLabel, fill=TRUE)
map[[oldLabel]] <- mode
bayesianPrior$map <- map
} else {
if (!is.na(oldLabel) && !is.null(map[[oldLabel]])) {
if (verbose) cat("clear bayesian prior", im$name, pname, "on label", oldLabel, fill=TRUE)
map[[oldLabel]] <- NULL
bayesianPrior$map <- map
}
}
return('')
}
# -----------------------------------------------------------------------------------------
shinyServer(function(input, output, session) {
feedback <- reactiveValues(newOutcomeAction="", resetRecodeAction="",
focusedOutcomeMapAction="", codingFile="",
focusedParameterPrior="", parseFile="")
rawData <- reactiveValues(val=NULL, name=NULL)
recodeTable <- reactiveValues(val=NULL)
permuteTable <- reactiveValues(val=NULL, items=NULL, reversed=NULL, exclude=NULL)
itemModel <- reactiveValues() # colname to list(model, Ta, Tc, startingValues, free, labels)
bayesianPrior <- reactiveValues(map=list()) # label -> value map
observe({
if (input$exampleDataKCT == 0) return()
loader <- parse(text=c(
'utils::data("kct", package="rpf")',
'data <- kct.people[20:37]',
'colnames(data) <- mxMakeNames(kct.items[["NAME"]], unique=TRUE)',
'data <- as.data.frame(lapply(data, as.character), stringsAsFactors=FALSE)',
'rownames(data) <- kct.people[[19]]'))
eval(loader)
rawData$datapath <- NULL
rawData$name <- NULL
rawData$loadDemo <- loader
rawData$stem <- "kct"
rawData$val <- data
recodeTable$val <-
structure(list(type = structure(c(1L, 1L, 1L, 1L), .Label = "outcomeSet", class = "factor"),
name = structure(c(1L, 2L, 1L, 1L), .Label = c("X1x1x4", "X18x4x1x3x4x2x1x4"), class = "factor"),
nameHash = structure(c(1L, 2L, 3L, 7L), .Label = c("f99c1d57d88bd654baacdcc798a016b6", "8ee3f19dd735a96f0ff59fb514b8efb8", "b695085c9330f407121bb28e859ad508",
"21c943db9d7a66561c37be2e751f7c85", "19eca0e5d319402184b1a1b20eaaa987",
"2572e3e6d229a7405d0ed1839c58f54c", "b867678184d2befa2e1b57c4529dbdc3" ), class = "factor"),
action = structure(c(1L, 1L, 2L, 2L), .Label = c("add", "recode"), class = "factor"),
from = structure(c(1L, 1L, 2L, 3L), .Label = c("", "0", "1"), class = "factor"),
to = structure(c(1L, 2L, 4L, 3L), .Label = c("0", "1", "correct", "incorrect"), class = "factor")),
.Names = c("type", "name", "nameHash", "action", "from", "to"), row.names = c(NA, 4L), class = "data.frame")
permuteTable$val <-
structure(list("9b162432e63482dee83b819368c73fb4" = c(2L, 1L)),
.Names = "9b162432e63482dee83b819368c73fb4")
permuteTable$exclude <- c("X1x1x4", "X2x2x3", "X3x1x2x4", "X18x4x1x3x4x2x1x4")
isolate({
outcomes <- isolate(recodeOutcomes(input, rawData, recodeTable, permuteTable))
setupItemModels(input, rawData, itemModel, outcomes)
for (name in names(outcomes)) {
itemModel[[name]]$labels[1] <- 'slope'
}
})
setupFreqColumnName(session, rawData)
})
observe({
if (input$exampleDataLSAT6 == 0) return()
loader <- parse(text=c(
'utils::data("LSAT6", package="rpf")',
'data <- LSAT6'
))
eval(loader)
rawData$datapath <- NULL
rawData$name <- NULL
rawData$loadDemo <- loader
rawData$stem <- "LSAT6"
rawData$val <- data
recodeTable$val <-
structure(list(type = structure(c(1L, 1L), .Label = "outcomeSet", class = "factor"),
name = structure(c(1L, 1L), .Label = "Item_1", class = "factor"),
nameHash = structure(1:2, .Label = c("b66901a10dfd2349673b611ab231b535", "b867678184d2befa2e1b57c4529dbdc3"), class = "factor"),
action = structure(c(1L, 1L), .Label = "recode", class = "factor"),
from = structure(1:2, .Label = c("0", "1"), class = "factor"),
to = structure(1:2, .Label = c("incorrect", "correct"), class = "factor")),
.Names = c("type", "name", "nameHash", "action", "from", "to"), row.names = 1:2, class = "data.frame")
permuteTable$val <-
structure(list("9b162432e63482dee83b819368c73fb4" = c(2L, 1L)), .Names = "9b162432e63482dee83b819368c73fb4")
setupFreqColumnName(session, rawData, "Freq")
})
observe({
if (input$exampleDataScience == 0) return()
loader <- parse(text=c(
'utils::data("science", package="rpf")',
'data <- sfpf[20:44]',
'colnames(data) <- mxMakeNames(colnames(data), unique=TRUE)',
'data <- as.data.frame(lapply(data, as.character), stringsAsFactors=FALSE)',
'rownames(data) <- sfpf[[19]]'
))
eval(loader)
rawData$loadDemo <- loader
rawData$datapath <- NULL
rawData$name <- NULL
rawData$stem <- "science"
rawData$val <- data
recodeTable$val <-
structure(list(type = structure(1L, .Label = "outcomeSet", class = "factor"),
name = structure(1L, .Label = "GOTOMUSEUM", class = "factor"),
nameHash = structure(1L, .Label = "7fcb27479582cc445bad8fa1ce4c4c2a", class = "factor"),
action = structure(1L, .Label = "add", class = "factor"),
from = structure(1L, .Label = "", class = "factor"), to = structure(1L, .Label = "dislike", class = "factor")),
.Names = c("type", "name", "nameHash", "action", "from", "to"), row.names = 1L, class = "data.frame")
permuteTable$val <-
structure(list("37cba13974a597e56737c53035b1a6f0" = c(1L, 3L, 2L)),
.Names = "37cba13974a597e56737c53035b1a6f0")
permuteTable$exclude <- 'GOTOMUSEUM'
setupFreqColumnName(session, rawData)
})
observe({
inFile <- input$file1
if (is.null(inFile)) return(NULL)
rawData$datapath <- inFile$datapath
rawData$name <- inFile$name
})
output$parseFileFeedback <- renderText(feedback[["parseFile"]])
observe({
if (is.null(rawData$datapath) || !file.exists(rawData$datapath)) return()
if (0) {
cat("read.csv with options", input$dataRowNames,
input$dataSep, input$dataQuote, fill=T)
}
args <- list(rawData$datapath, header=input$dataHeader,
sep=input$dataSep, quote=input$dataQuote,
stringsAsFactors=FALSE, check.names=FALSE, na.strings=c())
if (input$dataRowNames) {
args$row.names=1L
}
dat <- try(do.call(read.csv, args), silent = TRUE)
if (inherits(dat, "try-error")) {
feedback[["parseFile"]] <- paste("Something went wrong trying to load your file:\n", dat)
return()
}
hint <- "Try different quote and separator options."
if (nrow(dat) == 0) {
feedback[["parseFile"]] <- paste("Dataset appears to have 0 rows.", hint)
return()
}
if (ncol(dat) == 0) {
feedback[["parseFile"]] <- paste("Dataset appears to have 0 columns.", hint)
return()
}
colnames(dat) <- mxMakeNames(colnames(dat), unique=TRUE)
rawData$stem <- sub('\\..{3}$', '', rawData$name, perl=TRUE)
rawData$val <- dat
setupFreqColumnName(session, rawData)
feedback[["parseFile"]] <- ""
})
output$unparsedDataContents <- renderText({
if (is.null(rawData$datapath)) return()
paste(readLines(rawData$datapath, n=6L, warn=FALSE), collapse="\n")
})
output$dataContents <- renderTable({
dat <- rawData$val
# updateTabsetPanel(session, "dataPreviewTabset", "front") dunno why doesn't work TODO
head(dat)
})
output$nameOfDataFile <- renderText({ rawData$name })
observe({
ch <- dataColumnNamesUnsorted(input, rawData)
if (length(ch) == 0) return()
updateSelectInput(session, "focusedItemStart", choices=ch, selected=ch[[1]])
updateSelectInput(session, "focusedItemEnd", choices=ch, selected=ch[[ length(ch) ]])
})
observe({
perm <- permuteTable$items
ch <- isolate(dataColumnNamesUnsorted(input, rawData))
if (!is.null(perm) && length(perm) == length(ch)) ch <- ch[perm]
updateSelectInput(session, "focusedItemStart", choices=ch,
selected=isolate(input$focusedItemStart))
updateSelectInput(session, "focusedItemEnd", choices=ch,
selected=isolate(input$focusedItemEnd))
})
observe({
hits <- input$selectAllItemsAction
if (hits == 0) return()
ch <- isolate(includedColumnNames(input, rawData, permuteTable))
if (length(ch) == 0) return()
updateSelectInput(session, "focusedItemStart", selected=ch[[1]])
updateSelectInput(session, "focusedItemEnd", selected=ch[[ length(ch) ]])
})
output$numberOfDataRows <- renderText({
nrow(rawData$val)
})
output$dataSummary <- renderTable({
dat <- rawData$val
if (is.null(dat)) return(NULL)
ch <- dataColumnNames(input, rawData, permuteTable)
tbl <- sapply(rawData$val[,ch,drop=FALSE], function(col) c(Outcomes=length(unique(col)),
Missing=sum(is.na(col))))
tbl <- t(tbl)
rownames(tbl) <- ch
tbl
})
# ------------------------------------------------------------------ Outcomes
observe({
prevFocus <- isolate(input$focusedOutcomeSet)
outcomes <- recodeOutcomes(input, rawData, recodeTable, permuteTable)
oSetHash <- sapply(outcomes, function(oc) digest(oc, ascii=TRUE))
ch <- names(oSetHash[!duplicated(oSetHash)])
if (length(ch) == 0) return()
updateSelectInput(session, "focusedOutcomeSet",
choices=c('-', ch),
selected=ifelse(!is.na(match(prevFocus, ch)), prevFocus, ch[1]))
})
observe({
ch <- dataColumnNames(input, rawData, permuteTable)
updateSelectInput(session, "focusedOutcomeItem", choices=c("-",ch))
})
observe({
if (input$focusedOutcomeItem == '-') return()
updateSelectInput(session, "focusedOutcomeSet", selected="-")
})
observe({
if (input$focusedOutcomeSet == '-') return()
updateSelectInput(session, "focusedOutcomeItem", selected="-")
})
output$recodeTable <- renderTable({
tbl <- recodeTable$val
if (is.null(tbl) || nrow(tbl) == 0) return()
tbl[,c("type","name","action","from","to")]
})
observe({
outcomes <- getFocusedOutcomeDetail(input, rawData, recodeTable, permuteTable)
if (length(outcomes) == 0) outcomes <- "No item selected"
updateSelectInput(session, "focusedOutcomeMapFrom", choices=outcomes)
updateSelectInput(session, "focusedOutcomeMapTo", choices=c("<NA>", outcomes, "<Rename>"))
})
output$addNewOutcomeActionFeedback <- renderText(feedback[["newOutcomeAction"]])
observe({
if (input$addNewOutcomeAction == 0) return()
newOutcome <- isolate(input$newOutcomeName)
if (nchar(newOutcome) == 0) {
feedback[["newOutcomeAction"]] <- "Enter the name for a new outcome."
return()
}
itemOutcomes <- isolate(getFocusedOutcomeDetailUnordered(input, rawData, recodeTable, permuteTable))
if (any(newOutcome == itemOutcomes)) {
feedback[["newOutcomeAction"]] <-
paste(omxQuotes(newOutcome), "is already an outcome.")
return()
}
focusedOutcomeItem <- isolate(input$focusedOutcomeItem)
focusedOutcomeSet <- isolate(input$focusedOutcomeSet)
origRecodeTable <- isolate(recodeTable$val)
cat("add outcome", newOutcome, "to item",focusedOutcomeItem,
"or set",focusedOutcomeSet, fill=T)
if (focusedOutcomeItem != '-') {
recodeTable$val <-
rbind(origRecodeTable,
data.frame(type="item",
name=focusedOutcomeItem,
nameHash='',
action="add",
from="",
to=newOutcome))
} else if (focusedOutcomeSet != '-') {
outcomes <- isolate(recodeOutcomes(input, rawData, recodeTable, permuteTable))
oSetHash <- sapply(outcomes, function(col) digest(col, ascii=TRUE))
nameHash <- oSetHash[focusedOutcomeSet == names(oSetHash)][[1]]
recodeTable$val <-
rbind(origRecodeTable,
data.frame(type="outcomeSet",
name=focusedOutcomeSet,
nameHash=nameHash,
action="add",
from="",
to=newOutcome))
} else {
feedback[["newOutcomeAction"]] <- "Select an outcome set or item first."
return()
}
feedback[["newOutcomeAction"]] <- ""
})
observe({
if (is.null(recodeTable$val) || nrow(recodeTable$val) == 0) {
updateNumericInput(session, "focusedRecodeRule", min=1, max=1)
} else {
updateNumericInput(session, "focusedRecodeRule", min=1, max=nrow(recodeTable$val))
}
})
output$resetRecodeActionFeedback <- renderText(feedback[["resetRecodeAction"]])
observe({
if (input$resetRecodeAction == 0) return()
origRecodeTable <- isolate(recodeTable$val)
if (is.null(origRecodeTable) || nrow(origRecodeTable) == 0) {
feedback[["resetRecodeAction"]] <- "The recode table is empty."
return()
}
tbl <- origRecodeTable[-isolate(input$focusedRecodeRule),]
rownames(tbl) <- NULL
recodeTable$val <- tbl
feedback[["resetRecodeAction"]] <- ""
})
observe({
if (input$focusedOutcomeMapAction == 0) return()
from <- isolate(input$focusedOutcomeMapFrom)
to <- isolate(input$focusedOutcomeMapTo)
if (to == "<Rename>") {
to <- isolate(input$focusedOutcomeRenameTo)
}
if (from == to) {
feedback[["focusedOutcomeMapAction"]] <-
paste0("Outcome ",omxQuotes(from)," is already mapped to ",omxQuotes(to),".")
return()
}
if (to == "<NA>") to <- ''
focusedOutcomeItem <- isolate(input$focusedOutcomeItem)
focusedOutcomeSet <- isolate(input$focusedOutcomeSet)
origRecodeTable <- isolate(recodeTable$val)
if (focusedOutcomeItem != '-') {
recodeTable$val <-
rbind(origRecodeTable,
data.frame(type="item",
name=focusedOutcomeItem,
nameHash='',
action="recode",
from=from, to=to))
} else if (focusedOutcomeSet != '-') {
outcomes <- isolate(recodeOutcomes(input, rawData, recodeTable, permuteTable))
oSetHash <- sapply(outcomes, function(col) digest(col, ascii=TRUE))
nameHash <- oSetHash[focusedOutcomeSet == names(oSetHash)][[1]]
recodeTable$val <-
rbind(origRecodeTable,
data.frame(type="outcomeSet",
name=focusedOutcomeSet,
nameHash=nameHash,
action="recode",
from=from, to=to))
} else {
feedback[["focusedOutcomeMapAction"]] <- "Select an outcome set or item first."
return()
}
feedback[["focusedOutcomeMapAction"]] <- ""
})
output$focusedOutcomeMapActionFeedback <- renderText(feedback[["focusedOutcomeMapAction"]])
output$focusedOutcomeTable <- renderTable(
data.frame(outcome=getFocusedOutcomeDetail(input, rawData, recodeTable, permuteTable)))
output$reorderOutcomesSorterUI <- renderUI({
outcomes <- getFocusedOutcomeDetail(input, rawData, recodeTable, permuteTable)
if (length(outcomes) == 0) {
return(returnOrder("reorderOutcomesSorter", "Select an item"))
}
returnOrder("reorderOutcomesSorter", outcomes)
})
observe({
newOrder <- input$reorderOutcomesSorter
outcomes <- isolate(getFocusedOutcomeDetailUnordered(input, rawData, recodeTable, permuteTable))
perm <- match(newOrder, outcomes)
focusedOutcomeItem <- isolate(input$focusedOutcomeItem)
focusedOutcomeSet <- isolate(input$focusedOutcomeSet)
if (focusedOutcomeItem != '-') {
fi <- focusedOutcomeItem
} else if (focusedOutcomeSet != '-') {
fi <- digest(outcomes, ascii=TRUE)
} else {
return()
}
oldPerm <- isolate(permuteTable$val[[fi]])
if (!is.null(oldPerm) && length(perm) == length(oldPerm) &&
all(perm == oldPerm)) return()
if (all(perm == 1:length(perm)) && !is.null(oldPerm)) {
permuteTable$val[[fi]] <- NULL
} else if (any(perm != 1:length(perm))) {
permuteTable$val[[fi]] <- perm
}
})
output$permuteTable <- renderTable({
pt <- permuteTable$val
if (length(pt) == 0) return()
t(mxSimplify2Array(pt))
})
output$reversePicker <- renderUI({
cols <- dataColumnNames(input, rawData, permuteTable)
revNames <- isolate(permuteTable$reversed)
rmask <- !is.na(match(cols, revNames))
chooserInput("reverseChooser", "Unreversed", "Reversed",
cols[!rmask], cols[rmask], size = 16, multiple = TRUE)
})
observe({
got <- input$reverseChooser
if (is.null(got)) return()
oldRev <- isolate(permuteTable$reversed)
newRev <- setdiff(union(oldRev, got$right), got$left)
if (length(oldRev) == length(newRev) && all(oldRev == newRev)) return()
if (verbose) cat("reverse chooser", paste(newRev, collapse=","), fill=TRUE)
permuteTable$reversed <- newRev
})
codingToScript <- function() {
out <- list("savedCodingVersion = 1")
for (tbl in AppStateTables) {
dat <- paste(deparse(reactiveValuesToList(get(tbl))), collapse="\n")
out <- c(out, paste(tbl, "<-", dat))
}
inputState <- reactiveValuesToList(input)[c(AppStateSliderInput, AppStateTextInput)]
out <- c(out, paste("input <-", paste(deparse(inputState), collapse="\n")))
paste(out, collapse="\n")
}
output$downloadCoding <- downloadHandler(
filename = function() {
paste(rawData$stem, '-config.R', sep='')
},
content = function(file) {
write(isolate(codingToScript()), file=file)
}
)
output$codingFileFeedback <- renderText(feedback[["codingFile"]])
output$debugSettingsOutput <- renderText({
hit <- input$refreshSettingsAction
isolate(codingToScript())
})
observe({
inFile <- input$codingFile
if (is.null(inFile)) return()
bubble <- new.env()
got <- try(source(inFile$datapath, local=bubble, echo=FALSE), silent=TRUE)
if (inherits(got, "try-error")) {
feedback[["codingFile"]] <- paste("Parse error", got, sep="\n")
return()
}
if (!exists(envir=bubble, inherits=FALSE, "savedCodingVersion") ||
get(envir=bubble, inherits=FALSE, "savedCodingVersion") != 1) {
feedback[["codingFile"]] <- "This does not seem to be a saved coding file."
return()
}
found <- list()
e1 <- as.environment(-1L)
for (tbl in AppStateTables) {
if (!exists(envir=bubble, inherits=FALSE, tbl)) next
rt <- mget(tbl, bubble, ifnotfound=list(NULL))[[tbl]]
dest <- get(tbl)
for (k in names(rt)) {
dest[[k]] <- rt[[k]]
}
found <- c(found, paste0(tbl,': ', paste0(names(rt), collapse=" ")))
}
inputState <- mget("input", bubble, ifnotfound=list(NULL))[["input"]]
if (!is.null(inputState)) {
for (elem in AppStateSliderInput) {
updateSliderInput(session, elem, value=inputState[[elem]])
}
for (elem in AppStateTextInput) {
updateTextInput(session, elem, value=inputState[[elem]])
}
found <- c(found, paste0("input",': ',paste0(c(AppStateSliderInput, AppStateTextInput), collapse=" ")))
}
feedback[["codingFile"]] <- paste0("Found the following saved settings:\n\n",
paste(found, collapse="\n"))
})
# ------------------------------------------------------------------ Item Model & Parameters
observe({
outcomes <- recodeOutcomes(input, rawData, recodeTable, permuteTable)
if (is.null(outcomes)) return()
numFactors <- input$numFactors
if (numFactors) for (fx in 1:numFactors) {
name <- paste0("nameOfFactor", fx)
fn <- isolate(input[[name]])
if (is.null(fn) || fn == "") {
updateTextInput(session, name, value=sillyFactorName[fx])
}
}
setupItemModels(input, rawData, itemModel, outcomes)
})
output$reorderItemsSorterUI <- renderUI({
items <- dataColumnNamesUnsorted(input, rawData)
if (length(items) == 0) {
return(returnOrder("reorderItemsSorter", "No data loaded"))
}
perm <- isolate(permuteTable$items)
if (!is.null(perm) && length(items) == length(perm)) items <- items[perm]
returnOrder("reorderItemsSorter", items)
})
observe({
newOrder <- input$reorderItemsSorter
items <- isolate(dataColumnNamesUnsorted(input, rawData))
perm <- match(newOrder, items)
oldPerm <- isolate(permuteTable$items)
if (!is.null(oldPerm) && length(perm) == length(oldPerm) &&
all(perm == oldPerm)) return()
if (all(perm == 1:length(perm)) && !is.null(oldPerm)) {
permuteTable$items <- NULL
} else if (any(perm != 1:length(perm))) {
permuteTable$items <- perm
}
})
observe({
newModel <- input$focusedItemModel
fi <- isolate(getFocusedItems(input, rawData, permuteTable))
if (is.null(newModel) || is.null(fi) || newModel == 'as is' || fi == "No data loaded") return()
if (verbose) cat("change", fi, "item model to", newModel, fill=T)
outcomes <- isolate(recodeOutcomes(input, rawData, recodeTable, permuteTable))
for (col in fi) {
changeItemModel(itemModel, input, length(outcomes[[col]]), col, newModel)
}
})
output$focusedItemModelTcFeedback <- renderText(feedback[['focusedItemModelTc']])
observe({
newTc <- input$focusedItemModelTc
fi <- getFocusedItems(input, rawData, permuteTable)
if (is.null(newTc) || is.null(fi) || newTc == 'as is' || fi == "No data loaded") return()
if (verbose) cat("change", fi, "item model Tc to", newTc, fill=T)
found <- FALSE
numFactors <- isolate(input$numFactors)
for (col in fi) {
im <- isolate(itemModel[[col]])
if (is.null(im$model) || im$model != "nrm") next
found <- TRUE
if (newTc != im$Tc) {
if (verbose) cat("change",col,"from", im$Tc,"to", newTc,fill=T)
im$Tc <- newTc
itemModel[[col]] <- im
}
}
if (!found) {
feedback[['focusedItemModelTc']] <- "Intercept basis options are only available for the nominal model."
} else {
feedback[['focusedItemModelTc']] <- ''
}
})
observe({
fi <- getFocusedItems(input, rawData, permuteTable)
if (length(fi) == 0) return()
Tsel <- 'as is'
Tchoices <- c('as is', 'trend', 'id', 'partial credit')
if (length(fi) > 1) {
sel <- 'as is'
choices <- c('as is', 'drm', 'grm', 'nrm')
} else {
fi <- fi[[1]]
outcomeMap <- recodeOutcomes(input, rawData, recodeTable, permuteTable)
outcomes <- length(outcomeMap[[fi]])
choices <- c('grm')
if (outcomes == 2) choices <- c('drm', choices)
if (outcomes > 2) choices <- c(choices, 'nrm')
im <- isolate(itemModel[[fi]])
sel <- im$model
if (length(sel) && sel == 'nrm') {
Tsel <- im$Tc
} else {
Tchoices <- 'as is'
}
}
updateSelectInput(session, "focusedItemModel", choices=choices, selected=sel)
updateSelectInput(session, "focusedItemModelTc", choices=Tchoices, selected=Tsel)
})
output$itemStartingValuesTable <- renderTable({
if (length(names(itemModel)) == 0) return(NULL)
sv <- buildParameterTable(input, rawData, permuteTable, itemModel, "starting")
# adjust for equality constraints
labels <- buildParameterTable(input, rawData, permuteTable, itemModel, "labels")
ltbl <- table(labels)
if (any(ltbl > 1)) {
hasLabel <- !is.na(labels)
for (lab in names(ltbl[ltbl > 1])) {
sv[hasLabel & labels== lab] <-
sample(sv[hasLabel & labels==lab], 1)
}
}
sv
})
output$itemFreeTable <- renderTable({
if (length(names(itemModel)) == 0) return(NULL)
buildParameterTable(input, rawData, permuteTable, itemModel, "free")
})
output$itemLabelTable <- renderTable({
if (length(names(itemModel)) == 0) return(NULL)
buildParameterTable(input, rawData, permuteTable, itemModel, "labels")
})
output$itemPriorTable <- renderTable({
if (length(names(itemModel)) == 0) return(NULL)
tbl <- buildParameterTable(input, rawData, permuteTable, itemModel, "labels")
map <- bayesianPrior$map
mapped <- match(tbl[,], names(map))
mapped[!is.na(mapped)] <- unlist(map[ mapped[!is.na(mapped)] ])
tbl[,] <- mapped
for (rx in rownames(tbl)) {
if (rx == 'g' || rx == 'u') {
# OK
} else {
tbl[rx,] <- sapply(tbl[rx,], function(pr) ifelse(is.na(pr), NA, "??"))
}
}
tbl
})
observe({
im <- getFocusedItem(input, rawData, permuteTable, itemModel)
if (is.null(im)) return()
pname <- getFocusedParameterNames(input, im)
prevSelect <- match(isolate(input$focusedItemParameter), pname)
if (is.na(prevSelect)) prevSelect <- 1
updateSelectInput(session, "focusedItemParameter",
choices=pname, selected=pname[prevSelect])
})
observe({
im <- getFocusedItem(input, rawData, permuteTable, itemModel)
if (is.null(im)) return()
fx <- match(input$focusedItemParameter,
isolate(getFocusedParameterNames(input, im)))
if (is.na(fx)) return()
spec <- itemToSpec(im)
if (fx > rpf.numParam(spec)) return()
choices <- c("Free", 0, 1)
pi <- rpf.paramInfo(spec, fx)
if (pi$type == "bound") choices <- c(choices, "inf")
sel <- computeFreeSelected(im, fx)
allFocused <- length(getFocusedItems(input, rawData, permuteTable)) > 1
if (allFocused) {
choices <- c("as is", choices)
sel <- "as is"
}
updateSelectInput(session, "focusedParameterFree", choices=choices,
selected=sel)
label <- im$labels[fx]
if (is.na(label)) label <- "none"
if (allFocused) {
label <- "as is"
}
updateTextInput(session, "focusedParameterLabel", value=label)
})
observe({
if (input$focusedParameterFree == "as is" ||
input$focusedParameterFree == "No parameter selected") return()
im <- isolate(getFocusedItem(input, rawData, permuteTable, itemModel))
if (is.null(im)) return()
origFx <- isolate(match(input$focusedItemParameter,
getFocusedParameterNames(input, im)))
if (is.na(origFx)) return()
pname <- names(im$starting)[origFx]
dcols <- isolate(getFocusedItems(input, rawData, permuteTable))
for (col in dcols) {
maybeUpdateFree(input, itemModel, isolate(itemModel[[col]]), pname)
}
})
observe({
hit <- input$changeLabelAction
if (hit == 0 || isolate(input$focusedParameterLabel) == "as is") return()
im <- isolate(getFocusedItem(input, rawData, permuteTable, itemModel))
if (is.null(im)) return()
origFx <- isolate(match(input$focusedItemParameter,
getFocusedParameterNames(input, im)))
if (is.na(origFx)) return()
pname <- names(im$starting)[origFx]
dcols <- isolate(getFocusedItems(input, rawData, permuteTable))
for (col in dcols) {
maybeUpdateLabel(input, itemModel, isolate(itemModel[[col]]), pname)
}
})
output$focusedParameterPriorFeedback <- renderText(feedback[["focusedParameterPrior"]])
observe({
hit <- input$focusedParameterPriorSetAction
if (hit == 0) return()
im <- isolate(getFocusedItem(input, rawData, permuteTable, itemModel))
if (is.null(im)) return()
origFx <- isolate(match(input$focusedItemParameter,
getFocusedParameterNames(input, im)))
if (is.na(origFx)) return()
pname <- names(im$starting)[origFx]
dcols <- isolate(getFocusedItems(input, rawData, permuteTable))
for (col in dcols) {
feedback[["focusedParameterPrior"]] <-
updatePriorMode(input, bayesianPrior, itemModel, isolate(itemModel[[col]]), pname, set=TRUE)
}
})
observe({
hit <- input$focusedParameterPriorClearAction
if (hit == 0) return()
im <- isolate(getFocusedItem(input, rawData, permuteTable, itemModel))
if (is.null(im)) return()
origFx <- isolate(match(input$focusedItemParameter,
getFocusedParameterNames(input, im)))
if (is.na(origFx)) return()
pname <- names(im$starting)[origFx]
dcols <- isolate(getFocusedItems(input, rawData, permuteTable))
for (col in dcols) {
updatePriorMode(input, bayesianPrior, itemModel, itemModel[[col]], pname, set=FALSE)
}
feedback[["focusedParameterPrior"]] <- ''
})
output$excludePicker <- renderUI({
cols <- dataColumnNames(input, rawData, permuteTable)
exNames <- isolate(permuteTable$exclude)
emask <- !is.na(match(cols, exNames))
chooserInput("excludeChooser", "Included", "Excluded",
cols[!emask], cols[emask], size = 16, multiple = TRUE)
})
observe({
got <- input$excludeChooser
if (is.null(got)) return()
oldRev <- isolate(permuteTable$exclude)
newRev <- setdiff(union(oldRev, got$right), got$left)
if (length(oldRev) == length(newRev) && all(oldRev == newRev)) return()
if (verbose) cat("exclude chooser", paste(newRev, collapse=","), fill=TRUE)
permuteTable$exclude <- newRev
})
output$itemModelAssignment <- renderTable({
if (length(names(itemModel)) == 0) return(NULL)
outcomes <- recodeOutcomes(input, rawData, recodeTable, permuteTable)
massign <- mapply(function (col, cname) {
im <- itemModel[[cname]]
c(Outcomes=length(col),
Model=im$model, T.a=im$Ta, T.c=im$Tc,
Reversed=cname %in% permuteTable$reversed,
Excluded=cname %in% permuteTable$exclude)
}, outcomes, names(outcomes), SIMPLIFY=FALSE)
tbl <- t(mxSimplify2Array(massign))
for (bcol in c('Reversed','Excluded')) {
tbl[tbl[,bcol] == "FALSE", bcol] <- NA
}
tbl
})
# ------------------------------------------------------------------ Preview & Download
output$debugScriptOutput <- renderText({
input$debugScriptAction
validate(need(nrow(rawData$val), "No data is loaded"))
str <- try(isolate(toScript(input, rawData, recodeTable, permuteTable, itemModel, bayesianPrior)), silent=TRUE)
validate(need(!inherits(str, "try-error"),
paste("An error occurred. Please report this to the development team.",
str, sep="\n")))
str
})
output$downloadScript <- downloadHandler(
filename = function() {
validate(need(!is.null(rawData$stem), "No data is loaded")) # TODO, fix
paste(rawData$stem, '.Rmd', sep='')
},
content = function(file) {
write(isolate(toScript(input, rawData, recodeTable, permuteTable, itemModel, bayesianPrior)), file=file)
}
)
})
Try the ifaTools package in your browser
Any scripts or data that you put into this service are public.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Embedding an R snippet on your website
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.