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