version 0.2

DESCRIPTION

@@ -0,0 +1,13 @@
+Package: fgui
+Version: 0.2
+Date: 2007-10-23
+Title: Function GUI
+Author: Thomas Hoffmann
+Maintainer: Thomas Hoffmann <thoffman@hsph.harvard.edu>
+Imports: tcltk
+Suggests: tcltk
+Description: Rapidly create a GUI interface for a function you created by automatically creating widgets for arguments of the function. Automatically parses help routines for context-sensative help to these arguments. The interface essentially a wrapper to some tcltk routines to both simplify and facilitate GUI creation. More advanced tcltk routines/GUI objects can be incorporated into the interface for greater customization for the more experienced.
+License: GPL
+URL: http://www.people.fas.harvard.edu/~tjhoffm/fgui.html
+LazyLoad: true
+Packaged: Mon May 19 11:12:59 2008; merlin

NAMESPACE

@@ -0,0 +1,13 @@
+export(
+  gui, guiNestedF, guiExec,
+  guiGetValue, guiGetAllValues, guiSetValue,
+  guiSet, guiGet, guiGetSafe,
+  guiFrame,
+  guiTextEntry, guiSlider, guiFilename, guiOption, guiList, guiEdit, helpButton,
+  getSelectedListElements, setListElements,
+  guiFormals,
+
+  fguiWindow, fguiWindowPrint, fguiNewMenu, mgui
+)
+
+import( tcltk )

R/fguiWindow.R

@@ -0,0 +1,234 @@
+## We could call this with an empty fgui() ...
+fguiWindow <- function( basicMenu=TRUE, title="fgui", text="Please choose an option from the menu." ) {
+  require( tcltk )
+
+  ## cleanup from previous window...
+  clearMenu()
+
+  ## Create the main window
+  window <- tktoplevel()
+  tkwm.title( window, title )
+
+  ## Add the main menu to the window
+  topMenu <- tkmenu( window )
+  tkconfigure( window, menu=topMenu )
+
+
+  ##fileMenu <- tkmenu( topMenu, tearoff=FALSE )
+  ##tkadd( topMenu, "cascade", label="File", menu=fileMenu )
+
+  ##tkadd( fileMenu, "command", label="Quit", command=function() tkdestroy(window) )
+  ##tkadd( fileMenu, "command", label="Die", command=function() print("hello") )
+
+
+  ##aMenu <- tkmenu( topMenu, tearoff=FALSE )
+  ##tkadd( topMenu, "cascade", label="a", menu=aMenu )
+
+  ##abMenu <- tkmenu( aMenu, tearoff=FALSE )
+  ##tkadd( aMenu, "cascade", label="a > b", menu=abMenu )
+
+  ##tkadd( abMenu, "command", label="a > b > c", command=function(){print("hello")} )
+
+
+  guiSet( "INTERNALMENU_topMenu", topMenu )
+  tkfocus( window )
+
+
+  ## Now set the window as created
+  guiSet( "INTERNALMENU_USED", TRUE )
+
+  ## Add a destroy event to set the window as dead
+  #tcl("wm", "protocol", window, "WM_DELETE_WINDOW", quote(cat("Im staying!\n")))
+  tcl( "wm", "protocol", window, "WM_DELETE_WINDOW",
+       function() { guiSet("INTERNALMENU_USED",FALSE);tkdestroy(window);} )
+
+
+  ## Now add the real menu
+  #fguiNewMenu( c("File","me","here") )
+  #fguiNewMenu( c("File","me","there") )
+  #fguiNewMenu( c("File","clear") )
+
+  ## Maybe add a text edit box
+  scr <- tkscrollbar(window, repeatinterval=5,
+                        command=function(...)tkyview(txt,...))
+  txt <- tktext(window,yscrollcommand=function(...)tkset(scr,...))
+  tkgrid(txt,scr)
+  tkgrid.configure(scr,sticky="ns")
+  guiSet( "INTERNALMENU_TXT", txt )
+
+  if( basicMenu ) {
+    fguiNewMenu( c("File","Clear"), command=function(){gui_tkClearTextM(txt)} )
+    fguiNewMenu( c("File","Save"),
+      command=function(){
+        ## Get the text from the box
+        text <- tclvalue( tkget( guiGet("INTERNALMENU_TXT"), '@0,0', 'end' ) )
+        ## Get the filename
+        fname <- tclvalue(tkgetSaveFile(filetypes="{{Text Files} {.txt}} {{All files} *}"))
+
+        if( fname!="" ) {
+          ## Write text to fname!
+          f <- file( fname )
+          writeLines( text, con=f )
+          close(f)
+        }
+      } )
+    ##tkadd( guiGet("INTERNALMENU_File"), "separator" )
+    fguiNewMenu( c("File","SEPARATOR") )
+    fguiNewMenu( c("File","Exit"), command=function(){tkdestroy(window)} )
+  }
+
+
+
+  ## And write a little something to that text edit box
+  fguiWindowPrint( text )
+
+  return( invisible() )
+}
+
+fguiWindowPrint <- function( text, endl=TRUE ) {
+  txt <- guiGetSafe( "INTERNALMENU_TXT" )
+  #SUCCEEDED <- FALSE
+  #if( !is.na(txt[1]) ) {
+  #  try( {
+  #    gui_tkInsertText <- getFromNamespace( "gui_tkInsertText", "fgui" );
+  #    gui_tkInsertText(txt, text);
+  #    if( endl ) gui_tkInsertText(txt, "\n");
+  #    SUCCEEDED <- TRUE;
+  #    } )
+  #}
+  #if( !SUCCEEDED ) {
+  #  cat( text );
+  #  if( endl ) cat( "\n" );
+  #}
+
+  winExists <- guiGetSafe( "INTERNALMENU_USED" )
+  if( is.na( winExists ) || !winExists ) {
+    cat( text )
+    if( endl ) cat( "\n" )
+  }else{
+    gui_tkInsertText( txt, text );
+    if( endl ) gui_tkInsertText( txt, "\n" )
+  }
+}
+
+## menuText is an array of the depth
+##fguiNewMenu <- function( menuText, command=function(){print(menuText[length(menuText)])} ) {
+fguiNewMenu <- function( menuText, command=function(){print(paste(menuText,collapse=" > "))} ) {
+  ## Make sure the window existed
+  winExists <- guiGetSafe( "INTERNALMENU_USED" )
+  if( is.na( winExists ) || !winExists ) {
+    fguiWindow()
+  }
+
+  ## Previous menu should be the top menu
+  prevMenu <- guiGetSafe( "INTERNALMENU_topMenu" )
+  if( is.na( prevMenu[1] ) ) {
+    fguiWindow()
+    prevMenu <- guiGetSafe( "INTERNALMENU_topMenu" )
+  }
+
+  for( i in 1:length(menuText) ) {
+    ##print( menuText[i] )
+    ##newMenu <- NA
+
+    curName <- paste( "INTERNALMENU_", menuText[i], sep="" )
+    ##print( curName )
+    menu <- guiGetSafe( curName )
+    ##print( menu[1] )
+    if( is.na(menu[1]) ) {
+      ## how should it be added?
+      if( i==length(menuText) ) {
+        ## Then it's the end of the menu -- should be a _command_
+        ## UNLESS, it is a SEPARATOR
+        if( menuText[i]!="SEPARATOR" ) {
+          tkadd( prevMenu, "command", label=menuText[i], command=command )
+        }else{
+          tkadd( prevMenu, "separator" )
+        }
+      }else{
+        ## Contains items -- should be _cascade_
+        ## menu needs to be created!
+        menu <- tkmenu( prevMenu, tearoff=FALSE )
+        tkadd( prevMenu, "cascade", label=menuText[i], menu=menu )
+        guiSet( curName, menu )
+        registerMenu( curName ) ## so can be cleaned up...
+      }
+    }
+
+    ## and reset the previous menu
+    if( !is.na(menu[1]) )
+      prevMenu <- menu
+  }
+}
+
+## Internal -- so we can clear the menu later
+registerMenu <- function( menuName ) {
+  menuNames <- guiGetSafe( "INTERNALMENU_INTERNALNAMES" )
+  if( is.na( menuNames[1] ) ) {
+    menuNames <- menuName
+  }else{
+    menuNames <- c(menuNames,menuName)
+  }
+  guiSet( "INTERNALMENU_INTERNALNAMES", menuNames )
+  ##print( "registerMenu menuNames" )
+  ##print( menuNames )
+}
+
+## Internal -- clears the menu
+clearMenu <- function() {
+  menuNames <- guiGetSafe( "INTERNALMENU_INTERNALNAMES" )
+  ##print( "clearMenu menuNames" )
+  ##print( menuNames )
+
+  if( is.na( menuNames[1] ) )
+    return()
+
+  for( m in menuNames )
+    guiSet( m, NA ) ## kill it
+
+  guiSet( "INTERNALMENU_INTERNALNAMES", NA )
+}
+
+## Here everything is the same,
+##  _except_ title is now a vector representing the menu path
+mgui <- function( func,
+                  argOption=NULL, argFilename=NULL, argList=NULL, argSlider=NULL,
+                  argCommand=NULL, argEdit=NULL, argFilter=NULL,
+                  argText=NULL, argType=NULL,
+                  argGridOrder=1:length(formals(func)), sticky="nws",
+                  title=NULL,
+                  exec="Calculate ...",
+                  callback=NULL,
+                  output='m',
+                  helps='auto', helpsFunc=NULL,
+                  grid=TRUE, modal=TRUE, nameFix=TRUE,
+                  verbose=FALSE ) {
+  call <- match.call(expand.dots = FALSE)
+  funcName <- call[[match("func", names(call))]]
+  funcName <- as.character( as.expression( funcName ) )
+  if( length(title)==0 )
+    title <- funcName
+
+  fguiNewMenu( menuText=title,
+               command=function() {
+                 gui( func=func,
+                      argOption=argOption, argFilename=argFilename, argList=argList, argSlider=argSlider,
+                      argCommand=argCommand, argEdit=argEdit, argFilter=argFilter,
+                      argText=argText, argType=argType,
+                      argGridOrder=argGridOrder, sticky=sticky,
+                      title=title[length(title)],
+                      exec=exec,
+                      callback=callback,
+                      output=output,
+                      helps=helps, helpsFunc=helpsFunc,
+                      grid=grid, modal=modal, nameFix=nameFix,
+                      verbose=verbose )
+               } )
+}
+
+## debugging routines
+#fguiWindowPrint( "Should go to the console." )
+#####fguiWindow()
+#mgui( rnorm, title=c("Random","Normal") )
+#mgui( runif, title=c("Random","Uniform") )
+#fguiWindowPrint( "Should go to the main window." )

R/parseHelp.R

@@ -0,0 +1,128 @@
+readFile <- function( filename ) {
+  f <- file(filename)
+  lines <- readLines(filename)
+  close( f )
+  #print( lines )
+  return( lines )
+}
+
+STRTRIM <- function( str ) {
+  ## leading spaces
+  str <- sub('[[:space:]]*', '', str)
+  ## lagging spaces
+  return( sub('[[:space:]]*+$', '', str) )
+}
+
+parseArguments <- function( lines ) {
+  ## first separate into a list of strings
+  cur <- 0
+  lastEmpty <- FALSE
+  res <- c()
+  for( l in 1:length(lines) ) {
+    if( lines[l]=="" ) {
+      if( cur!=0 && lastEmpty==FALSE )
+        cur<-cur+1
+      lastEmpty<-TRUE
+    }else{
+      lastEmpty<-FALSE
+      if( cur==0 ) cur <- 1
+
+      #print( l )
+      #print( res )
+      ## ideally, we would want to trim lines[l], but I can't figure out how
+      if( length(res) < cur ) {
+        res[cur] <- STRTRIM(lines[l])
+      }else{
+        res[cur] <- paste( res[cur], STRTRIM(lines[l]), sep=" " )
+      }
+    }
+  }
+
+  ## Then split each list of strings on the _first_ ':'
+  resNames <- c()
+  for( i in 1:length(res) ) {
+    spl <- unlist( strsplit( res[i], ":" ) )
+    resNames[i] <- STRTRIM(spl[1])
+
+    spl <- spl[-1]
+    spl[1] <- STRTRIM(spl[1]) ## because of the : operator...
+    res[i] <- paste( spl, collapse=":" )
+  }
+  names(res) <- resNames
+  #print( resNames )
+
+  return(res)
+}
+
+#splitOnColons <- function( lines ) {
+#
+#  colonLines <- c( grep( ":", lines ), length(lines) )
+#
+#  res <- list()
+#  for( cl in 1:(length(colonLines)-1) ) {
+#
+#    ## split var and descr on colon
+#    spl <- unlist(strsplit(lines[colonLines[cl]],":"))
+#    print( spl )
+#    option <- spl[1]
+#    spl <- spl[-1]
+#    optionDesc <- paste( spl, collapse=":" )
+#
+#    ## and put in the rest of the descr if there is one
+#    if( colonLines[cl] != colonLines[cl+1]-1 )
+#      optionDesc <- paste( optionDesc,
+#                           subset( lines, (colonLines[cl]+1):(colonLines[cl+1]-1) ),
+#                           collapse="\n" )
+#
+#    ## and put it in the results
+#    cur <- length(res)+1
+#    res[[cur]] <- optionDesc
+#    names(res)[cur] <- option
+#  }
+#
+#  return( res )
+#}
+
+parseHelp <- function( func ) {
+  filename <- help( func, offline=FALSE, chmhelp=NA, htmlhelp=NA )[[1]]
+
+  if( !file.exists(filename) ) {
+    ## It might be in a zip file in windows, lets try to extract it
+
+    ## parse off the function name
+    funcname <- unlist( strsplit( filename, "/" ) )
+    funcname <- funcname[[length(funcname)]]
+
+    ## get the path to the zip file
+    ziparchive <- paste( substr( filename, 1, nchar(filename)-nchar(funcname) ), "Rhelp.zip", sep="" )
+    if( file.exists(ziparchive) ) {
+      ## then we _can_ extract it
+      #filename <- zip.file.extract( funcname, ziparchive )
+      ## Arghhh!!!! Sometimes I really, _really_ hate R
+      tmpd <- tempdir()
+      rc <- .Internal( int.unzip(ziparchive,funcname,tmpd) )
+      if( rc==0 )
+        filename <- attr(rc,"extracted")
+    }
+  }
+
+  ## Read in all of the lines
+  lines <- readFile( filename )
+
+  ## Extract out the relevant lines
+  lineStart <- unlist( lapply( lines, substr, start=1, stop=2 ) )
+  section <- which( lineStart == "_\b" )
+  usageSection <- which( lines == "_\bA_\br_\bg_\bu_\bm_\be_\bn_\bt_\bs:" )
+
+  sectionSection <- which( usageSection==section )
+  if( sectionSection == length(section) )
+    section <- c(section, length(lines)+1)
+  usageLinesB <- section[sectionSection]+1
+  usageLinesE <- section[sectionSection+1]-1
+  lines <- lines[usageLinesB:usageLinesE]
+
+  return( parseArguments(lines) )
+}
+
+## DEBUG ONLY
+#lmHelp <- parseHelp( "lm" )