Monday, January 2, 2012
Please have a look and share any comments!
See the R code for this little application in the earlier post.
Thanks for taking the time to have a look at this attempt at developing a GUI app do so some model evaluation in R. I'd appreciate any comments that you have.
I'm not a programmer, so any hints on how to better implement this would be useful as well as comments about additional features that would make this more useful. As much as anything, I'm using this as an opportunity to learn more about GUI development--so if I've ignored a lot of good practices, feel free to let me know!
As far as extending this, right now, I can see wanting to do the following:
Thanks for taking the time to have a look at this attempt at developing a GUI app do so some model evaluation in R. I'd appreciate any comments that you have.
I'm not a programmer, so any hints on how to better implement this would be useful as well as comments about additional features that would make this more useful. As much as anything, I'm using this as an opportunity to learn more about GUI development--so if I've ignored a lot of good practices, feel free to let me know!
As far as extending this, right now, I can see wanting to do the following:
- Develop a more flexible model building interface (allowing interactions, polynomial terms,and simply interfacing to more of the lm/glm options).
- Interfacing to GLM (not just lm, like it does now)--at least logit/probit where I know the basics will work.
- Facilitate handling factor variables (currently this will work only with numeric). For example, showing the predicted values for multiple groups on the same plot.
- Adding in some more error/sanity checking for the modeling interface.
- Just how the heck can I get summary(lm) to display in the gedit widget the same way that it does in the R console?
RIME Source Code
library(gWidgets)
library(gregmisc)
options("guiToolkit"="RGtk2")
data(attitude,trees,swiss)
RIME<-function(){
#R Interactive Model Evaluation
#Brett Magill
#1-2-2012
null_option<-"-None Selected "
dataset<-data.frame(variables=character(0))
varlist<-null_option
xvarlist<-null_option
yvarlist<-null_option
png("rplot0.png")
par(mfrow=c(1,1))
plot(0)
dev.off()
plot0<-'rplot0.png'
eh.setactvdata<-
function(h,...) {
setx[]<-null_option
sety[]<-null_option
setxs[]<-null_option
setys[]<-null_option
svalue(mdldgn)<-'rplot0.png'
svalue(evlmod)<-'rplot0.png'
svalue(mdlsumry)<-null_option
if (length(setactvdata[])==1 && svalue(setactvdata)==null_option)
{dataset<-data.frame(variables=character(0))
svalue(nb)<-5
dispose(nb)
actvdata<-add(nb,gtable(dataset,chosencol=1), label="Active Dataset")
svalue(nb)<-1
svalue(dispactdata)<-null_option}
else
dataset<-mget(svalue(setactvdata),envir=.GlobalEnv)[[1]]
varlist<-colnames(dataset)
svalue(dispactdata)<-c(svalue(setactvdata))
setx[]<-varlist
sety[]<-varlist
svalue(nb)<-5
dispose(nb)
actvdata<-add(nb,gtable(dataset,chosencol=1), label="Active Dataset")
svalue(nb)<-1
}
eh.setxy<-
function(h,...) {
if (h$action=="setx") trgt<-setxs
if (h$action=="sety") trgt<-setys
if (trgt[]==null_option)
{ if (is.null(svalue(h$obj))) trgt[]<-null_option
else
{if (sum(setxs[]==svalue(h$obj))>0) return()
if (sum(setys[]==svalue(h$obj))>0) return()
trgt[]<-svalue(h$obj)}
return()}
if (h$action=="sety" && trgt[]!=null_option)
{if (sum(setxs[]==svalue(h$obj))>0) return()
trgt[]<-svalue(h$obj)
return()}
else
{if (sum(setys[]==svalue(h$obj))>0) return()
if (sum(setxs[]==svalue(h$obj))>0) return()
trgt[]<-c(trgt[],svalue((h$obj)))}
}
eh.gomodl<-
function(h,...){
mod<- fitmod()
svalue(mdlsumry)<-summary(mod)
png("rplot.png")
par(mfrow=c(2,2))
plot(mod)
dev.off()
svalue(mdldgn)<-'rplot.png'
}
eh.evlmodel<-
function(h,...){
eh.eval<-function(h,...)
{
fittedmodel<-fitmod()
evalvarval<-nb[5][][svalue(setevalvar)]
yvarval<-nb[5][][setys[]]
sim.evalvar<-data.frame(seq(from=min(evalvarval),
to=max(evalvarval),
by=((max(evalvarval)-min(evalvarval))/50)))
names(sim.evalvar)<- svalue(setevalvar)
othrvarval<-nb[5][][setxs[]]
sim.xdata<-othrvarval[names(othrvarval) != names(evalvarval)]
sim.data<-data.frame(sim.evalvar,
data.frame(t(mean(sim.xdata))) )
#Construct plot
sim.est<-predict(fittedmodel,newdata=sim.data,type="response",se.fit=T)
pntest<- sim.est$fit
errors<- qnorm(.975) * sim.est$se.fit
titlexs<-NULL
for (i in names(sim.xdata)) titlexs<-{paste(titlexs,i)}
png("rplot_eval.png")
par(mfrow=c(1,1))
plotCI(sim.evalvar[,1],
pntest,
uiw=errors,liw=errors,
type="p",ylim=c(min(yvarval),max(yvarval)),xlim=c(min(evalvarval),max(evalvarval)),col="black",
ylab=names(yvarval),xlab=names(sim.evalvar),
main=paste(names(yvarval),"~",names(sim.evalvar),"|" , titlexs ) )
dev.off()
svalue(evlmod)<-'rplot_eval.png'
}
evldlggrp = ggroup(horizontal=FALSE, cont=TRUE,label="Evaluation Options")
tbl = glayout(cont=evldlggrp,spacing=10)
tbl[1,1, anchor=c(1,0)] <- "Select X Var"
tbl[1,2] <- setevalvar<- gdroplist(setxs[], cont=tbl,handler=eh.eval)
size(setevalvar)<-c(200,-1)
return()
}
get.data.names<-function(){
objcls.chk<- function(list) class(get(list,envir=.GlobalEnv))
obj.names<-ls(envir=.GlobalEnv)
obj.clses<-sapply(obj.names,objcls.chk)
datanames<-c(null_option,obj.names[obj.clses=="data.frame"])
return(datanames)
}
fitmod<-function(h,...){
yvar<-setys[1]
xvars<-"1"
for (i in setxs[])
xvars<-paste(xvars,"+",i)
modcall<-paste(yvar,"~",xvars)
data=nb[5][]
args <- list(formula=modcall,data=data)
fitmod<-do.call(lm,args=args)
return(fitmod)
}
# GUI Layout
win = gwindow("RIME")
nb = gnotebook(cont=win)
fitmodgrp = ggroup(horizontal=FALSE, cont=nb, label="Fit GLM Model")
tbl = glayout(cont=fitmodgrp,spacing=10)
tbl[1,1, anchor=c(1,0)] <- "data"
tbl[1,2] <- setactvdata<- gdroplist(get.data.names(), cont=tbl,handler=eh.setactvdata)
size(setactvdata)<-c(200,-1)
tbl[1,3, anchor=c(1,0)] <- "active"
tbl[1,4] <- dispactdata<- glabel(text=svalue( setactvdata), cont=tbl,editable=FALSE)
size(dispactdata)<-c(200,-1)
tbl[2,1, anchor=c(1,0)] <- "x"
tbl[2,2] <- setx<-gdroplist(varlist,editable=FALSE,cont=tbl,handler=eh.setxy,action="setx")
tbl[2,3, anchor=c(1,0)] <- "y"
tbl[2,4] <- sety<-gdroplist(varlist,editable=FALSE,cont=tbl,handler=eh.setxy,action="sety")
tbl[3,1, anchor=c(1,0)] <- "xvars"
tbl[3,2]<-setxs<-gtable(xvarlist, cont=tbl,size=c(100,-1))
size(setxs)<-c(200,300)
rmxvar<-addHandlerDoubleclick(setxs,handler=eh.rmxvar<-
function(h,...) { if (length(setxs[])==1 | setxs[]==null_option)
{setxs[]<-null_option
return ()}
setxs[]<-setxs[][setxs[]!=svalue(setxs)] } )
tbl[3,3, anchor=c(1,0)] <- "yvars"
tbl[3,4]<-setys<-gtable(yvarlist, cont=tbl)
rmyvar<-addHandlerDoubleclick(setys,handler=eh.rmyvar<-
function(h,...) { if (length(setys[])==1 | setys[]==null_option)
{setys[]<-null_option
return ()}
setys[]<-setys[][setys[]!=svalue(setys)] } )
size(setys)<-c(200,300)
tbl[4,4]<-gomodl<-gbutton(text="OK", cont=tbl,handler=eh.gomodl)
size(gomodl)<-c(50,50)
mdlsumry = gtext("No Model", cont=nb, label="Model Summary")
size(mdlsumry)<-c(500,500)
mdldgn<-gimage( plot0,cont=nb,label="Diagnostic plots")
mdlevlgrp = ggroup(horizontal=FALSE, cont=nb, label="Evaluate Model")
tbl2 = glayout(cont=mdlevlgrp,spacing=10)
tbl2[2,1]<-evlmod <- gimage( plot0,cont=tbl2)
size(evlmod)<-c(500,500)
tbl2[3,1]<-s.goevl<-gbutton(text="Start Interactive Evaluation", cont=tbl2,handler=eh.evlmodel)
size(s.goevl)<-c(50,50)
actvdata<-add(nb,gtable(dataset,chosencol=1), label="Active Dataset")
svalue(nb)<-1
}
RIME()
library(gregmisc)
options("guiToolkit"="RGtk2")
data(attitude,trees,swiss)
RIME<-function(){
#R Interactive Model Evaluation
#Brett Magill
#1-2-2012
null_option<-"-None Selected "
dataset<-data.frame(variables=character(0))
varlist<-null_option
xvarlist<-null_option
yvarlist<-null_option
png("rplot0.png")
par(mfrow=c(1,1))
plot(0)
dev.off()
plot0<-'rplot0.png'
eh.setactvdata<-
function(h,...) {
setx[]<-null_option
sety[]<-null_option
setxs[]<-null_option
setys[]<-null_option
svalue(mdldgn)<-'rplot0.png'
svalue(evlmod)<-'rplot0.png'
svalue(mdlsumry)<-null_option
if (length(setactvdata[])==1 && svalue(setactvdata)==null_option)
{dataset<-data.frame(variables=character(0))
svalue(nb)<-5
dispose(nb)
actvdata<-add(nb,gtable(dataset,chosencol=1), label="Active Dataset")
svalue(nb)<-1
svalue(dispactdata)<-null_option}
else
dataset<-mget(svalue(setactvdata),envir=.GlobalEnv)[[1]]
varlist<-colnames(dataset)
svalue(dispactdata)<-c(svalue(setactvdata))
setx[]<-varlist
sety[]<-varlist
svalue(nb)<-5
dispose(nb)
actvdata<-add(nb,gtable(dataset,chosencol=1), label="Active Dataset")
svalue(nb)<-1
}
eh.setxy<-
function(h,...) {
if (h$action=="setx") trgt<-setxs
if (h$action=="sety") trgt<-setys
if (trgt[]==null_option)
{ if (is.null(svalue(h$obj))) trgt[]<-null_option
else
{if (sum(setxs[]==svalue(h$obj))>0) return()
if (sum(setys[]==svalue(h$obj))>0) return()
trgt[]<-svalue(h$obj)}
return()}
if (h$action=="sety" && trgt[]!=null_option)
{if (sum(setxs[]==svalue(h$obj))>0) return()
trgt[]<-svalue(h$obj)
return()}
else
{if (sum(setys[]==svalue(h$obj))>0) return()
if (sum(setxs[]==svalue(h$obj))>0) return()
trgt[]<-c(trgt[],svalue((h$obj)))}
}
eh.gomodl<-
function(h,...){
mod<- fitmod()
svalue(mdlsumry)<-summary(mod)
png("rplot.png")
par(mfrow=c(2,2))
plot(mod)
dev.off()
svalue(mdldgn)<-'rplot.png'
}
eh.evlmodel<-
function(h,...){
eh.eval<-function(h,...)
{
fittedmodel<-fitmod()
evalvarval<-nb[5][][svalue(setevalvar)]
yvarval<-nb[5][][setys[]]
sim.evalvar<-data.frame(seq(from=min(evalvarval),
to=max(evalvarval),
by=((max(evalvarval)-min(evalvarval))/50)))
names(sim.evalvar)<- svalue(setevalvar)
othrvarval<-nb[5][][setxs[]]
sim.xdata<-othrvarval[names(othrvarval) != names(evalvarval)]
sim.data<-data.frame(sim.evalvar,
data.frame(t(mean(sim.xdata))) )
#Construct plot
sim.est<-predict(fittedmodel,newdata=sim.data,type="response",se.fit=T)
pntest<- sim.est$fit
errors<- qnorm(.975) * sim.est$se.fit
titlexs<-NULL
for (i in names(sim.xdata)) titlexs<-{paste(titlexs,i)}
png("rplot_eval.png")
par(mfrow=c(1,1))
plotCI(sim.evalvar[,1],
pntest,
uiw=errors,liw=errors,
type="p",ylim=c(min(yvarval),max(yvarval)),xlim=c(min(evalvarval),max(evalvarval)),col="black",
ylab=names(yvarval),xlab=names(sim.evalvar),
main=paste(names(yvarval),"~",names(sim.evalvar),"|" , titlexs ) )
dev.off()
svalue(evlmod)<-'rplot_eval.png'
}
evldlggrp = ggroup(horizontal=FALSE, cont=TRUE,label="Evaluation Options")
tbl = glayout(cont=evldlggrp,spacing=10)
tbl[1,1, anchor=c(1,0)] <- "Select X Var"
tbl[1,2] <- setevalvar<- gdroplist(setxs[], cont=tbl,handler=eh.eval)
size(setevalvar)<-c(200,-1)
return()
}
get.data.names<-function(){
objcls.chk<- function(list) class(get(list,envir=.GlobalEnv))
obj.names<-ls(envir=.GlobalEnv)
obj.clses<-sapply(obj.names,objcls.chk)
datanames<-c(null_option,obj.names[obj.clses=="data.frame"])
return(datanames)
}
fitmod<-function(h,...){
yvar<-setys[1]
xvars<-"1"
for (i in setxs[])
xvars<-paste(xvars,"+",i)
modcall<-paste(yvar,"~",xvars)
data=nb[5][]
args <- list(formula=modcall,data=data)
fitmod<-do.call(lm,args=args)
return(fitmod)
}
# GUI Layout
win = gwindow("RIME")
nb = gnotebook(cont=win)
fitmodgrp = ggroup(horizontal=FALSE, cont=nb, label="Fit GLM Model")
tbl = glayout(cont=fitmodgrp,spacing=10)
tbl[1,1, anchor=c(1,0)] <- "data"
tbl[1,2] <- setactvdata<- gdroplist(get.data.names(), cont=tbl,handler=eh.setactvdata)
size(setactvdata)<-c(200,-1)
tbl[1,3, anchor=c(1,0)] <- "active"
tbl[1,4] <- dispactdata<- glabel(text=svalue( setactvdata), cont=tbl,editable=FALSE)
size(dispactdata)<-c(200,-1)
tbl[2,1, anchor=c(1,0)] <- "x"
tbl[2,2] <- setx<-gdroplist(varlist,editable=FALSE,cont=tbl,handler=eh.setxy,action="setx")
tbl[2,3, anchor=c(1,0)] <- "y"
tbl[2,4] <- sety<-gdroplist(varlist,editable=FALSE,cont=tbl,handler=eh.setxy,action="sety")
tbl[3,1, anchor=c(1,0)] <- "xvars"
tbl[3,2]<-setxs<-gtable(xvarlist, cont=tbl,size=c(100,-1))
size(setxs)<-c(200,300)
rmxvar<-addHandlerDoubleclick(setxs,handler=eh.rmxvar<-
function(h,...) { if (length(setxs[])==1 | setxs[]==null_option)
{setxs[]<-null_option
return ()}
setxs[]<-setxs[][setxs[]!=svalue(setxs)] } )
tbl[3,3, anchor=c(1,0)] <- "yvars"
tbl[3,4]<-setys<-gtable(yvarlist, cont=tbl)
rmyvar<-addHandlerDoubleclick(setys,handler=eh.rmyvar<-
function(h,...) { if (length(setys[])==1 | setys[]==null_option)
{setys[]<-null_option
return ()}
setys[]<-setys[][setys[]!=svalue(setys)] } )
size(setys)<-c(200,300)
tbl[4,4]<-gomodl<-gbutton(text="OK", cont=tbl,handler=eh.gomodl)
size(gomodl)<-c(50,50)
mdlsumry = gtext("No Model", cont=nb, label="Model Summary")
size(mdlsumry)<-c(500,500)
mdldgn<-gimage( plot0,cont=nb,label="Diagnostic plots")
mdlevlgrp = ggroup(horizontal=FALSE, cont=nb, label="Evaluate Model")
tbl2 = glayout(cont=mdlevlgrp,spacing=10)
tbl2[2,1]<-evlmod <- gimage( plot0,cont=tbl2)
size(evlmod)<-c(500,500)
tbl2[3,1]<-s.goevl<-gbutton(text="Start Interactive Evaluation", cont=tbl2,handler=eh.evlmodel)
size(s.goevl)<-c(50,50)
actvdata<-add(nb,gtable(dataset,chosencol=1), label="Active Dataset")
svalue(nb)<-1
}
RIME()
Subscribe to:
Posts (Atom)