RIME Screenshots

Here are a few screenshots of the application from 1-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:

1. Develop a more flexible model building interface (allowing interactions, polynomial terms,and simply interfacing to more of the lm/glm options).
2. Interfacing to GLM (not just lm, like it does now)--at least logit/probit where I know the basics will work.
3. Facilitate handling factor variables (currently this will work only with numeric).  For example, showing the predicted values for multiple groups on the same plot.
4. Adding in some more error/sanity checking for the modeling interface.
5. 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?

Thanks! I look forward to any feedback.

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()