Nothing
## Simple Dynamic Models dialog
## output has regular model methods defined for it except update()
dModelsDialog = function() {
## list of avail. models
models = list(
"linear regression"= "gui.lm",
"robust regresion" = "gui.rlm",
"-----" = "-----",
"Analysis of variance"="gui.aov"
)
## main groups
win = pmgWC$new("Models",v=T)
gp = ggroup(horizontal=FALSE, container=win, raise.on.dragmotion = TRUE)
popupGroup = ggroup(container=gp)
addSpring(popupGroup)
testPopup = gdroplist(c("",names(models)), container=popupGroup)
gseparator(container=gp)
testWindow = ggroup(container=gp)
obj = list(ref=testWindow)
class(obj) = c("gDynamicModelDialog")
dialogList = list()
dialogList[["FirstOne"]] = glabel("Select a model from popup")
add(testWindow,dialogList[["FirstOne"]], expand=TRUE)
tag(testWindow, "dialogList") <- dialogList
tag(testWindow,"currentTest") <- dialogList[["FirstOne"]]
addhandlerchanged(testPopup, handler = function(h,...) {
popupValue = svalue(testPopup)
if(!is.empty(popupValue) || popupValue != "-----") {
delete(testWindow,tag(testWindow,"currentTest"))
dialogList = tag(testWindow, "dialogList")
if(is.null(dialogList[[popupValue]])) {
dialogList[[popupValue]] <- do.call(models[[popupValue]],list())
tag(testWindow, "dialogList") <- dialogList
}
add(testWindow,dialogList[[popupValue]]$ref, expand=TRUE)
tag(testWindow,"currentTest") <- dialogList[[popupValue]]$ref
}
})
## tidy up on uneralize. Need to get afresh
addhandlerdestroy(win, handler = function(h,...) {
for(i in dialogList) {
dropHandlers = tag(i,"dropHandlers")
if(length(dropHandlers) > 0) {
for(i in 1:length(dropHandlers)) {
removehandler(dropHandlers[[i]]$view.col,dropHandlers[[i]]$id)
}
}
}
})
return(obj)
}
## The regular R model methods
summary.gDynamicModelDialog = function(object, ...)
summary(tag(object$ref,"currentTest"), ...)
anova.gDynamicModelDialog = function(object, ...)
anova(tag(object$ref,"currentTest"), ...)
coefficients.gDynamicModelDialog = function(object,...)
coefficients(tag(object$ref,"currentTest"), ...)
effects.gDynamicModelDialog = function(object,...)
effects(tag(object$ref,"currentTest"), ...)
fitted.values.gDynamicModelDialog = function(object,...)
fitted.values(tag(object$ref,"currentTest"), ...)
residuals.gDynamicModelDialog = function(object, ...)
residuals(tag(object$ref,"currentTest"), ...)
predict.gDynamicModelDialog = function(object, ...)
predict(tag(object$ref,"currentTest"), ...)
plot.gDynamicModelDialog = function(x, ...) {
print(list(...))
plot(tag(x$ref,"currentTest"), ...)
}
##################################################
## wrappers
## use lm function
gui.lm = function(container=NULL) {
actions =list(
"drop1" = list(
FUN = "drop1"
),
"plot: Residuals vs Fitted" =list(
FUN="plot",
ARGS = list(which=1)
),
"plot: Normal Q-Q"=list(
FUN="plot",
ARGS = list(which=2)
),
"plot: Scale-Location"=list(
FUN="plot",
ARGS = list(which=3)
),
"plot: Cook's distance"=list(
FUN="plot",
ARGS = list(which=4)
),
"plot: Residuals vs Leverage"=list(
FUN="plot",
ARGS = list(which=5)
),
"plot: Cook's distance vs Leverage"=list(
FUN="plot",
ARGS = list(which=6)
)
)
dynamicModelWidget(FUN="lm", actions=actions, container=container)
}
gui.rlm = function(container=NULL) {
require(MASS)
## actions inherit from lm. -- sublcass?
actions =list(
"plot: Residuals vs Fitted" =list(
FUN="plot",
ARGS = list(which=1)
),
"plot: Normal Q-Q"=list(
FUN="plot",
ARGS = list(which=2)
),
"plot: Scale-Location"=list(
FUN="plot",
ARGS = list(which=3)
),
"plot: Cook's distance"=list(
FUN="plot",
ARGS = list(which=4)
),
"plot: Residuals vs Leverage"=list(
FUN="plot",
ARGS = list(which=5)
),
"plot: Cook's distance vs Leverage"=list(
FUN="plot",
ARGS = list(which=6)
)
)
dynamicModelWidget(FUN="rlm", actions=actions, container=container)
}
## use aov
gui.aov = function(container=NULL) {
## actions inherit from lm. -- sublcass?
actions =list(
"plot: Residuals vs Fitted" =list(
FUN="plot",
ARGS = list(which=1)
),
"plot: Normal Q-Q"=list(
FUN="plot",
ARGS = list(which=2)
),
"plot: Scale-Location"=list(
FUN="plot",
ARGS = list(which=3)
),
"plot: Cook's distance"=list(
FUN="plot",
ARGS = list(which=4)
),
"plot: Residuals vs Leverage"=list(
FUN="plot",
ARGS = list(which=5)
),
"plot: Cook's distance vs Leverage"=list(
FUN="plot",
ARGS = list(which=6)
)
)
dynamicModelWidget(FUN="aov", actions=actions, container=container)
}
##################################################
### workhorse functino
dynamicModelWidget = function(
FUN = "lm",
extra.args = NULL,
actions = c(), # for actions window. Called on obj
container = NULL,
...) {
group = ggroup(horizontal=FALSE, container = container)
obj = list(ref=group)
class(obj) = c("gDynamicModel","gComponent","gWidget")
## store values
tag(obj$ref,"FUN") <- FUN
tag(obj$ref,"extra.args") <- extra.args
formulaGroup = ggroup(container=group)
## key widgets:
responseVar = glabel("response", container=formulaGroup,editable=TRUE)
font(responseVar) <- c(style="bold")
tag(obj$ref,"responseVar") <- responseVar
tag(obj$ref, "responseVarData") <- NA
glabel(" ~ ", container=formulaGroup)
intercept = gdroplist(c("1","-1"), container=formulaGroup)
tag(obj$ref,"intercept") <- intercept
predictorVars = glabel("predictor(s)",container=formulaGroup, editable=TRUE)
font(predictorVars) <- c(style="bold")
tag(obj$ref,"predictorVars") <- predictorVars
tag(obj$ref,"predictorVarsData") <- list()
addSpring(formulaGroup)
actionPopup = gdroplist(c(
"Select an action","Clear formula","Save model object",
names(actions)),
container = formulaGroup)
tag(obj$ref,"actionPopup") <- actionPopup
tag(obj$ref,"actions") <- actions
gseparator(container=group)
outputArea = gtext("")
size(outputArea) <- c( 300,300)
add(group, outputArea, expand=TRUE)
tag(obj$ref, "outputArea") <- outputArea
tag(obj$ref, "res") <- NA
## store the drop handlers in the main object.
tag(obj$ref, "dropHandlers") <- list()
## add droptargets, handlers
addhandlerchanged(responseVar,
handler = function(h,...) {
# cat("This doesn't work with dynamic data\n")
ids = tag(obj$ref,"dropHandlers")
if(length(ids) > 0) {
removehandler(obj$ref,ids)
tag(obj$ref,"dropHandlers") <- list()
}
tag(obj$ref, "responseVarData") <- svalue(responseVar)
## put popup on 1
svalue(tag(obj$ref,"actionPopup"),index=TRUE) <- 1
update(obj)
})
adddroptarget(responseVar,
handler=function(h, ...) {
tag(obj$ref,"responseVarData") <- h$dropdata
svalue(tag(obj$ref, "responseVar")) <- id(h$dropdata)
## put popup on 1
svalue(tag(obj$ref,"actionPopup"),index=TRUE) <- 1
update(obj)
## now bind to be dynamic *if* a treeviewcolumn
if(is.gdataframecolumn(h$dropdata)) {
view.col = h$dropdata
id = addhandlerchanged(view.col,
signal = "edited",
handler=function(h,...) update(obj)
)
dropHandlers = tag(obj$ref,"dropHandlers")
dropHandlers[[length(dropHandlers)+1]] = list(
view.col = view.col,
id = id
)
tag(obj$ref,"dropHandlers") <- dropHandlers
}
})
addhandlerchanged(intercept, handler=function(h,...) {
## put popup on 1
svalue(tag(obj$ref,"actionPopup"),index=TRUE) <- 1
update(obj)
})
addhandlerchanged(predictorVars,
handler = function(h,...) {
## we need to be careful here. This overwrites any drop data.
cat("This doesn't work with dynamic data\n")
ids = tag(obj$ref,"dropHandlers")
if(length(ids) > 0) {
removehandler(obj$ref,ids)
tag(obj$ref,"dropHandlers") <- list()
}
vals = svalue(predictorVars)
## clear out any leading or trailing +
vals = sub("\\s*[+]\\s*","",vals)
if(vals == "") # in case of cleaning
vars = NULL
else
vars = sapply(strsplit(vals,"\\+"),stripWhiteSpace)
tag(obj$ref, "predictorVarsData") <- vars
## add to predictorVars
if(is.null(vars))
svalue(predictorVars) <- "predictor(s)" # leave target
else
svalue(predictorVars) <- paste("+",paste(vars,collapse=" + "),collapse=" ")
## put popup on 1
svalue(tag(obj$ref,"actionPopup"),index=TRUE) <- 1
update(obj)
})
adddroptarget(predictorVars,
handler = function(h,...) {
varList = tag(obj$ref,"predictorVarsData")
if(!is.list(varList))
varList = list()
n = length(varList)
varList[[n+1]] = h$dropdata
tag(obj$ref,"predictorVarsData") <- varList
predictorVars = tag(obj$ref,"predictorVars")
curLabel = svalue(predictorVars)
if(curLabel == "predictor(s)")
curLabel = ""
newLabel = Paste(curLabel," + ", id(h$dropdata))
svalue(predictorVars) <- newLabel
update(obj)
## now bind to be dynamic *if* a treeviewcolumn
if(is.gdataframecolumn(h$dropdata)) {
view.col = h$dropdata
id = addhandlerchanged(view.col,
signal = "edited",
handler=function(h,...) update(obj)
)
dropHandlers = tag(obj$ref,"dropHandlers")
dropHandlers[[length(dropHandlers)+1]] = list(
view.col = view.col,
id = id
)
tag(obj$ref,"dropHandlers") <- dropHandlers
}
})
actionPopupHandler = handler = function(h,...) {
if(svalue(h$obj) == "Select an action") {
## do nothing
} else if(svalue(h$obj) == "Clear formula") {
## clear out values, labels
tag(obj$ref,"responseVarData") <- NA
svalue(responseVar) <-"response"
svalue(intercept,index=TRUE) <- 1
tag(obj$ref,"predictorVarsData") <- list()
svalue(predictorVars) <- "predictor(s)"
dispose(outputArea)
## would like to reset popup, bu tthis causes infinite loop
## clear out res
tag(obj$ref, "res") <- NA
} else if(svalue(h$obj) == "Save model object") {
## pop up a dialog to save the model object
saveHandler = function(h,...) {
varName = svalue(theName)
if(!is.empty(varName)) {
varName = make.names(varName)
assign(varName, tag(obj$ref,"res"), envir=.GlobalEnv)
dispose(win)
}
}
win = pmgWC$new("Save model object as...", visible=TRUE)
gp = ggroup(horizontal=FALSE, container=win)
glabel("Specify a variable name for the object:", container=gp)
theName = gedit("",container=gp, handler=saveHandler)
if(length(lsModels()) > 0) theName[]<- lsModels() # add to type ahead
buttonGroup = ggroup(container=gp)
addSpring(buttonGroup)
gbutton("ok", container=buttonGroup, handler =saveHandler)
gbutton("cancel", container=buttonGroup, handler = function(h,...) dispose(win))
## that's all
} else {
argList = c(list(obj),actions[[svalue(h$obj)]]$ARGS)
do.call(actions[[svalue(h$obj)]]$FUN, argList)
}
}
## how to set value of popup back to start without call ing handler?
addhandlerchanged(actionPopup,handler=actionPopupHandler)
return(obj)
}
## regular model methods
summary.gDynamicModel = function(object, ...)
summary(tag(object$ref,"res"), ...)
anova.gDynamicModel = function(object, ...)
anova(tag(object$ref,"res"), ...)
coefficients.gDynamicModel = function(object,...)
coefficients(tag(object$ref,"res"), ...)
effects.gDynamicModel = function(object,...)
effects(tag(object$ref,"res"), ...)
fitted.values.gDynamicModel = function(object,...)
fitted.values(tag(object$ref,"res"), ...)
residuals.gDynamicModel = function(object, ...)
residuals(tag(object$ref,"res"), ...)
predict.gDynamicModel = function(object, ...)
predict(tag(object$ref,"res"), ...)
plot.gDynamicModel = function(x, ...)
plot(tag(x$ref,"res"), ...)
## This is main function
## call function, update widgets
## this is *not* the update for models traditionally expected
update.gDynamicModel = function(object, ...) {
obj = object$ref # for s3 consistency
FUN = tag(obj,"FUN")
extra.args = tag(obj,"extra.args")
responseVarData = tag(obj,"responseVarData")
intercept = tag(obj,"intercept")
intercept.val = svalue(intercept) # a string
predictorVarsData = tag(obj,"predictorVarsData") # a list
## make formula
## how to avoid eval(parse... here?
if(is.na(responseVarData)) {
cat("Need a response variable\n")
return()
}
env = environment()
assign(id(responseVarData),svalue(responseVarData), envir=env)
if(length(predictorVarsData) > 0) {
sapply(predictorVarsData, function(i)
assign(id(i), svalue(i), envir=env) )
}
formula = Paste(id(responseVarData), " ~ ", intercept.val)
if(length(predictorVarsData) > 0) {
formula = Paste(formula," + ",
paste(sapply(predictorVarsData, function(i) id(i)), collapse=" + "))
}
command = Paste(FUN,"(",formula)
if(!is.null(extra.args))
command = Paste(command,",", extra.args)
command = Paste(command, ")")
res = eval(parse(text=command), envir=env)
tag(obj,"res") <- res
if(FUN == "aov")
out = c(capture.output(res),"\n","Summary:","\n", capture.output(summary(res)))
else
out = capture.output(summary(res))
outputArea = tag(obj,"outputArea")
dispose(outputArea)
for(i in out) {
if(length(grep(":$",i)) > 0)
add(outputArea,i,font.attr=c(style="monospace",color="blue"))
else
add(outputArea,i,font.attr=c(style="monospace"))
}
}
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.