.packageName <- "gWidgetsWWW"
#line 1 "d:/RCompile/CRANpkg/local/2.13/gWidgetsWWW/R/LocalVersion.R"
##  Copyright (C) 2010 John Verzani
##
##  This program is free software; you can redistribute it and/or modify
##  it under the terms of the GNU General Public License as published by
##  the Free Software Foundation; either version 2 of the License, or
##  (at your option) any later version.
##
##  This program is distributed in the hope that it will be useful,
##  but WITHOUT ANY WARRANTY; without even the implied warranty of
##  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
##  GNU General Public License for more details.
##
##  A copy of the GNU General Public License is available at
##  http://www.r-project.org/Licenses/



##' Environment to hold different sessions
assign("..gWidgets_sessionEnv", new.env(), envir=.GlobalEnv)

##' remove session from list to free up memory
clearSessionId <- function(ID) {
  sessionEnv <- get("..gWidgets_sessionEnv",  envir=.GlobalEnv)
  sessionEnv[[ID]] <- NULL
  assign("..gWidgets_sessionEnv", sessionEnv, envir=.GlobalEnv)
}

##' This lists the gwindow objects and matches against ID
getBaseObjectFromSessionID <- function(sessionID, envir=.GlobalEnv) {
  sessionEnv <- get("..gWidgets_sessionEnv",  envir=.GlobalEnv)  
  return(sessionEnv[[sessionID]])
}

##' return all gWindow instances in an environment
##'
##' @param environment to search in
getBaseObjectsFromEnvironment <- function(envir=.GlobalEnv) {
  vars <- ls(envir=envir)
  ind <- sapply(vars, function(i) inherits(get(i, envir=envir), "gWindow"))
  if(any(ind))
    gWindowObjects <- vars[ ind ]
  else
    gWindowObjects <- character(0)
  return(gWindowObjects)
}
  
##' escape brackets in a string
##'
##' @param x character value to escape
##' @return character
escapeBrackets <- function(x) gsub("(\\{|\\})", "\\\\\\1", x)


##' From dynamicHelp in tools:
##'
##' Find mime type from file extension
##' (Taken from Duncan Murdoch's work)
##' @param path file name
##' @return mime type
mime_type <- function(path) {
  ext <- strsplit(path, ".", fixed = TRUE)[[1L]]
  if(n <- length(ext)) ext <- ext[n] else ""
  switch(ext,
         "css" = "text/css",
         "gif" = "image/gif", # in R2HTML
         "jpg" = "image/jpeg",
         "svg"="image/svg+xml",
         "html" = "text/html",
         "js" = "text/javascript",
         "pdf" = "application/pdf",
         "eps" = "application/postscript",
         "ps" = "application/postscript", # in GLMMGibbs, mclust
         "sgml"= "text/sgml", # in RGtk2
         "xml" = "text/xml",  # in RCurl
         "text/plain")
}



##' return an error
##' 
##' @param msg String. error message
##' @param status_code Integer. use to specify status code. Default if 400L
##' @return Returns a list with components indicating the payload (the
##' text to display), the content type and the status code. 
makeErrorPage <- function(msg, status_code=400L) {
  list(payload=paste(msg, collase="\n"),
       "content-type"="text/html",
       "status code"=status_code)
}

##' Process a script through source and capture ouutput
##'
##' @param file filename of script
##' @param content_type MIME type of output
##' @return list containng output and status
processScript <- function(file, content_type="text/html") {
  ## source file, capture output
  out <- capture.output(source(file))

  list(payload=paste(out, collapse="\n"),
       "content-type" = mime_type(file),
       "headers" = NULL,
       "status code"=200L
       )
}
  


##' process file from basehtml (ext/, images/, ...)
##' @param path path to file
##' @param query query string (path?var1=x&var2=u) -> path=path; query=c(var1="x", var2="u")
##' @param ... ignored
##' @return payload to send to web server
processBasehtmlFile <- function(path, query, ...) {
  f <- sprintf("/basehtml/%s", strip_slashes(paste(path, collapse="/")))
  f <- gsub("//","/", f)                # just in case
  f <- system.file(f, package="gWidgetsWWW")

  if(!file.exists(f))
    return(makeErrorPage(sprintf("Can't find %s", f)))

  ## see https://code.google.com/speed/page-speed/docs/caching.html
  ## doesn't seem to work with firefox
  temp <- "%a %b %e %Y %H:%M:%S GMT%z (%Z)"

  cacheControl <- "Cache-Control: max-age=31536000"
  expires <- sprintf("Expires: %s", format(Sys.time() + 60*60*24, temp))
  lastModified <- sprintf("Last-Modified: %s", format(file.info(f)$mtime, temp))

  list(file=f, 
       "content-type" = mime_type(f),
       "headers" = c(cacheControl, expires, lastModified),
       "status code"=200L
       )

}

##' process file from static directory
##' @param path path to file
##' @param query query string (path?var1=x&var2=u) -> path=path; query=c(var1="x", var2="u")
##' @param ... ignored
##' @return payload to return to web server
processStaticFile <- function(path, query, ...) {
  f <- sprintf("%s%s",.Platform$file.sep, Reduce(file.path, path))
  if(!file.exists(f))
    return(makeErrorPage(sprintf("Can't find %s", f)))

  ## see https://code.google.com/speed/page-speed/docs/caching.html
  ## doesn't seem to work with firefox
  temp <- "%a %b %e %Y %H:%M:%S GMT%z (%Z)"

  cacheControl <- "Cache-Control: max-age=31536000"
  expires <- sprintf("Expires: %s", format(Sys.time() + 60*60*24, temp))
  lastModified <- sprintf("Last-Modified: %s", format(file.info(f)$mtime, temp))

  list(file=f, 
       "content-type" = mime_type(f),
       "headers" = c(cacheControl, expires, lastModified),
       "status code"=200L
       )

}

##' Stub to inspect path, query, ... values
##' @param path path to file
##' @param query query string (path?var1=x&var2=u) -> path=path; query=c(var1="x", var2="u")
##' @param ... ignored
##' @return payload to send to web server
processPath <- function(path, query, ...) {
  l <- list(...)
  l$path <- path
  out <- paste(capture.output(str(l)), collapse="\n<br>")

  list(payload=out,
       "content-type" = "text/html",
       "headers" = NULL,
       "status code"=200L
       )
}

##' Source file then make page
##'
##' @param path a file or sure. (Passed to source)
##' @param mimeType to specify mime type
##' @return payload to send to web server
processSource <- function(path, mimeType=mime_type(path)) {
  e <- new.env()
  results <- try(capture.output(do.call("source", list(path, local=TRUE), envir=e)), silent=TRUE)

  ## check that it worked
  if(inherits(results, "try-error")) 
    return(makeErrorPage(results))
                         
  ## OK
  ## scan through e looking for gWindow object
  objs <- getBaseObjectsFromEnvironment(e)

  w <- get(objs[1], envir=e)
  ID <- w$sessionID
  ## assign by session ID to some list
  sessionEnv <- get("..gWidgets_sessionEnv",  envir=.GlobalEnv)
  sessionEnv[[ID]] <- w
  assign("..gWidgets_sessionEnv", sessionEnv, envir=.GlobalEnv)
  
  ##    results <- capture.output(source(path))
  results <- paste(results, collapse="\n")
  out <- gWidgetsWWW:::makegWidgetsWWWpage(results, script=TRUE, .=w)
  ret <- list(payload=out,
              "content-type" = mimeType,
              "headers" = NULL,
              "status code"=200L
              )

}

##' run a gWidgetsWWW script
##' 
##' @param path path to file
##' @param query query string (path?var1=x&var2=u) -> path=path; query=c(var1="x", var2="u")
##' @param ... ignored
##' @return payload to send to web server
processRun <- function(path, query, ...) {
  path <- paste(path, collapse=.Platform$file.sep)
  if(!file.exists(path))
    return(makeErrorPage(sprintf("Can't find %s", path)))
  ## if mime_type is text/plain, otherwise we pass through
  if(mime_type(path) == "text/plain") {
    ret <- processSource(path, "text/html")
  } else {
    ret <- list(file=path,
                "content-type"=mime_type(path),
                "status code" = 200L)
  }
  return(ret)
}

##' run an external file (from a url)
##' 
##' query passes in url: /custom/gw/gWidgetsWWWRunExternal?url=http://www.math.csi.cuny.edu/test
##' @param path ignored
##' @param query the path is the first entry.
##' @return calls processSource
processExternalRun <- function(path, query, ...) {
  path <- ourURLdecode(query[1])
  ret <- processSource(path, "text/html")
  return(ret)
}

##' process an AJAX call
##'
##' @param path ignored
##' @param query ignored
##' @param ... Passes in detail abou tPOST event
##' @details These all come as POST requests. This information is
##' passed through ..., not query. We call it query below, nonetheless
##' @return a payload to send to web server
processAJAX <- function(path, query, ...) {
  if(is.null(query))
    query <- list(...)[[1]]               # query passed in body, not query (POST info, not GET)

  
  ## rstudio passes query as an object with a attr "application/x-www-form-urlencoded; charset=UTF-8"
  if(is.raw(query)) {
    out <- rawToChar(query)
    tmp <- unlist(strsplit(out, "&"))
    l <- list()
    for(i in tmp) {
      i <- ourURLdecode(i)
      a <- strsplit(i, "=")[[1]]
      if(length(a) > 1 && !is.na(a[2]))
        l[[a[1]]] <- a[2]
    }

    query <- l
  }

  query <- lapply(query, function(i) i) # make a list


  type <- query$type

  if(is.null(type))
    type <- path[1]                     # for calling in url

  switch(type,
         "runHandler"= {
           l <- gWidgetsWWW:::localRunHandler(query$id, query$context, query$sessionID)
           ret <- list("payload"=l$out,
                       "content-type"="application/javascript",
                       "headers"=NULL,
                       "status code"=l$retval
                       )
           return(ret)
         },
         "assign" = {
           ## pass back return value. Assign does nothing otherwise
           l <- gWidgetsWWW:::localAssignValue(query$variable, ourURLdecode(query$value), query$sessionID)
           ret <- list(payload=l$out,
#                       "content-type"="text/html",
                        "content-type"="application/javascript",
                       "headers"=paste(
                         "<?xml version='1.0' encoding='ISO-8859-1'?>",
                         "<responseText></responseText>",
                         "<readyState>4</readyState>",
                         sep="\n"),
                       "status code"=l$retval
                       )
         },
         "clearSession"={
           ## clear out session
           ## For some reason this setup gives a SIGPIPE error and it isn't in the call to clearSessionID
           clearSessionId(query$sessionID)
           ret <- list(payload="", 
                       "content-type"="text/html",
                       "headers"=paste(
                         "<?xml version='1.0' encoding='ISO-8859-1'?>",
                         "<responseText></responseText>",
                         "<readyState>4</readyState>",
                         sep="\n"),
                       "status code"=200L
                       )
         },
         "proxystore"={
           ## localProxyStore dispatches to a method of the store which considers query
           ## path[2] is the id of the widget, path[3] is the sessionID. These are passed
           ## in via the URL -- not the query
           l <- gWidgetsWWW:::localProxyStore(path[2], path[3], query)
           ret <- list(payload=l$out,
                       "content-type"="application/json",
                       "headers"=NULL,
                       "status code"=200L
                       )
         },
         "fileupload"={
           ret <- makeErrorPage(sprintf("Don't know how to process type %s.", type))
         })
  return(ret)
}


##' basic handler to arrange for dispatch based on URL
##'
##' @param path passes in path including custom/gw bit
##' @param query passes in GET info
##' @param ... passes in post information (for AJAX calls!)
##' @return output of functions is a payload list.
gw.httpd.handler <- function(path, query, ...) {


  ## here path is path, query contains query string, ... ???
  path <- ourURLdecode(path)
  query <- ourURLdecode(query)

  
  ## strip off /custom/url_base/
  path <- gsub(sprintf("^/custom/%s/",url_base), "", path)
  ## strip any trailing slash
  path <- gsub("[/]*$", "", path)
  path <- unlist(strsplit(path, "/"))


  ## Dispatch on value of path[1]
  out <- switch(path[1],
                "ext"=processBasehtmlFile(path, query, ...),
                "images"=processBasehtmlFile(path, query, ...),
                "static"=processStaticFile(path[-1], query, ...),
                "gWidgetsWWWRun"=processRun(path[-1], query, ...),
                "gWidgetsWWW" = processAJAX(path[-1], query, ...),
                "gWidgetsWWWRunExternal"=processExternalRun(path[-1], query, ...),
                processBasehtmlFile(c("",path), query,  ...)
                )
  return(out)
}



##' is the server running
##'
##' @return logical
isServerRunning <- function() {
  tools:::httpdPort > 0L
}

## for testing from outside package
##' global value for base url
url_base <- NULL
##' global value for AJAX url
gWidgetsWWWAJAXurl <- NULL

##' global for image directory url
gWidgetsWWWimageUrl <- NULL

##' global for directory where static files are to go
gWidgetsWWWStaticDir <- NULL

##' global variable to indicate if running locally or via rapache server
.gWidgetsWWWisLocal <- NULL

##' start the local server for gWidgetsWWW
##'
##' @param file optional name of file to open
##' @param port ignored now
##' @param package If file specified and package given, the file looked up within package through system.file
##' 
##' @details Starts help server if not already done, then loads custom http handler
localServerStart <- function(file="", port=8079, package=NULL, ...) {
  if(!isServerRunning()) {
    tools:::startDynamicHelp()
  }

  if(!isServerRunning()) {
    ## XXX error didn't start
    gettext("XXX Server won't start")
    return()
  }

  ## store handler to respond to /custom/gw url
  if( exists( ".httpd.handlers.env", tools <- asNamespace("tools") ) ){
    e <- get( ".httpd.handlers.env", tools )
    e[["gw"]] <- gw.httpd.handler
  } else {
    gettext("XXX Odd, environment of httpd handlers is absent")    
    return()
  }

  ## configure some package-local variables
  assignInNamespace("url_base", "gw", ns="gWidgetsWWW")
  assignInNamespace("gWidgetsWWWAJAXurl",sprintf("/custom/%s/gWidgetsWWW", url_base), ns="gWidgetsWWW")
  assignInNamespace("gWidgetsWWWimageUrl", sprintf("/custom/%s/images/", url_base), ns="gWidgetsWWW")
  assignInNamespace(".gWidgetsWWWisLocal", TRUE, ns="gWidgetsWWW")

  ## global variables
  assign("gWidgetsWWWStaticDir", (tmp <- tempdir()), envir=.GlobalEnv)
  assign("gWidgetsWWWStaticUrlBase", sprintf("/custom/%s/static/%s", url_base, tmp), envir=.GlobalEnv)
  
  ## open if called to
  if(!is.null(file) && file != "") {
    localServerOpen(file, package, ...)
  } else {
    if(!is.null(file)) {
      ## make a message
      msg <- gettext(paste("You may create a web page from a file in your working directory via:",
                           "",
                           "     localServerOpen('filename')",
                           "",
                           "Otherwise, you can load a file from a package via:",
                           "",                           
                           "      localServerOpen('filename', package='pkgName')",
                           "",                           
                           "For example, to see a simple GUI try this:",
                           "",                           
                           "      localServerOpen('Examples/ex-simple-gui.R', package='gWidgetsWWW')",
                           "\n\n",
                           sep="\n"))
      cat(msg)
    }
  }
}


##' Load a file in gWidgets by calling gWidgetsWWWRun
##' @param file filename to open
##' @note  XXX Unix only? Test this
##' @return NULL
gWloadFile <- function(file, ...) {
  localServerStart(file=NULL)
  .url <- sprintf("http://127.0.0.1:%s/custom/%s/gWidgetsWWWRun/%s",
                  tools:::httpdPort,
                  url_base,
                  strip_slashes(ourURLencode(file), leading=FALSE))
  browseURL(.url)
}

##' Load from a URL
##'
##' First downloads to a temporary file, then loads that
##' @param file a url for the script
gWloadFromURL <- function(file, ...) {
  tmp <- tempfile()
  out <- download.file(file, tmp)
  if(out == 0L) {
    localServerStart(file=NULL)
    .url <- sprintf("http://127.0.0.1:%s/custom/%s/gWidgetsWWWRun/%s",
                    tools:::httpdPort,
                    url_base,
                    tmp)
    browseURL(.url)
  } else {
    cat(sprintf("Error downloading %s.", file))
  }
}

##' Load file from pacakge
##' @param file, url or connection. File is full file path or if package is
##' non-NULL found from system.file(file, package=package). If a
##' connection, a temporary file is found to use and the connection is
##' closed.
##' @param package to look for file
##' @return NULL (opens page or gives message)
##' @note at this point, we should have written this to dispatch on the type of file.
localServerOpen <- function(file, package=NULL, ...) {
  if(missing(file))
    return()
  
  if(is(file, "connection")) {
    f <- tempfile(".R")
    cat("", file=f)
    sapply(readLines(file, warn=FALSE), function(i) cat(i,"\n", file=f, append=TRUE))
    close(file)
    file <- f
  } else if(isURL(file)) {
    localServerSource(file)
  } else if(!is.null(package)) {
    file <- system.file(file, package=package)
  }
  if(file.exists(file))
    gWloadFile(file, ...)
  else
    cat(sprintf("Can't find file %s\n", file))
}

##' return values
##'
##' Return error code if TRUE, OK if FALSE
##' $param val logical TRUE if there was an error
##' @return integer the status code of error or not
wasError <- function(val) {
  ifelse(val, 419L, 200L)
}


##' Source a file or url to write the web page
##'
##' @param file_or_url A file or url passed to source to produce the gWidgetsWWW web page
##' @return Opens a browser page
localServerSource <- function(file_or_url) {
  localServerStart(file=NULL)
  
  .url <- sprintf("http://127.0.0.1:%s/custom/%s/gWidgetsWWWRunExternal?url=%s",
                  tools:::httpdPort,
                  url_base,
                  ourURLencode(file_or_url))
  browseURL(.url)
}

##' Is gWidgetsWW running from the local server
##'
##' @return logical
gWidgetsWWWIsLocal <- function() {
  !is.null(getFromNamespace(".gWidgetsWWWisLocal", ns="gWidgetsWWW"))
}


##' Called by AJAX script to assign a value in the local session
##'
##' @return list with error code and message
##' @TODO should assign using svalue method. This just puts into local environment to be picked up later
localAssignValue <- function(id, value, sessionID) {
  e <- getBaseObjectFromSessionID(sessionID)
  l <- list(out="", retval=wasError(FALSE))
  if(is.null(e)) {
    l$out <- sprintf("Error: can't find session for", sessionID, "\n")
    l$retval <- wasError(TRUE)
  } else {
    out <- ourFromJSON(value)
    e$assignValue(id, out)
    
    if(is.list(out)) {
      tmp <- try(assign(id, out$value, envir=e), silent=TRUE)
      if(inherits(tmp, "try-error")) {
        l$out <- tmp
        l$retval <- wasError(TRUE)
      }
    }
  }
  return(l)
}

##' Called to run a handler
##'
##' @id widget id
##' @param context passed into give context
##' @sessionID sessionID used to find the environment
##' @return payload to send to web server
localRunHandler <- function(id, context=NULL, sessionID) {

  if(!is.null(context)) {
    context <- ourURLdecode(context)
    if(context == "\"\"")
      context <- NULL
  }

  ## return 200 if ok, 419 if no
  OK <- 200L; ERROR <- 419L
  ret <- list(out="", retval=OK)
  
  e <- getBaseObjectFromSessionID(sessionID)
  ## sanity checks
  if(is.null(e)) {
    ret$out <- "alert('No session for this id');"
    ret$retval <- wasError(TRUE)
  } else {
    ## runHandler calls methods which first send javascript to the queue
    ## then we run the queue
    if(!(is.null(context) || context == ""))
      ret$out <- try(e$runHandler(id, ourFromJSON(context)), silent=TRUE)
    else
      ret$out <- try(e$runHandler(id), silent=TRUE)
    if(inherits(ret$out, "try-error")) {
      ret$out <- sprintf("<br />Error: %s", paste(ret$out,collapse="<br />"))
      ret$retval <- wasError(TRUE)
    }
  }
  return(ret)
}

##' return data from proxy store
##'
##' Calls the stores parseQuery method 
##' @param id id of store
##' @param sessionID session id to look up store
##' @param query  Contains parameters passed by ext. Passed to parseQuery method of store
##' @return payload to send to server
localProxyStore <- function(id, sessionID, query) {
  e <- getBaseObjectFromSessionID(sessionID)
  store <- e$getStoreById(id)

  ## return 200 if ok, 419 if no
  OK <- 200L; ERROR <- 419L
  ret <- list(out="", retval=OK)
  
  ## sanity checks
  if(is.null(e)) {
    ret$out <- "alert('No session for this id');"
    ret$retval <- ERROR
  } else {
    ## set ret$out. If an error set ret$reval <- ERROR
    x <- paste(capture.output(query), collapse="\n")
    ret$out <- x
  }

  out <- try(store$parseQuery(query), silent=TRUE)
  ret <- list(out=out,
              retval=wasError(inherits(out, "try-error")))
  return(ret)
}
  

##' Make a page header for a locally served script
##'
##' @return html code for the page header
makegWidgetsWWWPageHeader <- function(.) {
  ## XXX This needs work!! The proper combination here could make things work for Chrome, safari, Opera and IE?
  out <- paste(
#               "<!DOCTYPE html PUBLIC '-//W3C//DTD HTML 4.01 Transitional//EN'>",
#               "<!DOCTYPE html PUBLIC '-//W3C//DTD XHTML 1.0 Strict//EN' 'http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd'>",
#               '<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.1//EN" "http://www.w3.org/TR/xhtml11/DTD/xhtml11.dtd">',
#               "<html xmlns='http://www.w3.org/1999/xhtml' xmlns:v='urn:schemas-microsoft-com:vml'>",
#               "<html xmlns:v=urn:schemas-microsoft-com:vml>",
               "<html>",
               "<head>",
               "<meta http-equiv='Content-Type' content='text/html; charset=UTF-8' />",
               "<!-- Call in Ext style sheet -->",
               "<link rel='stylesheet' type='text/css' href='/custom/gw/ext/resources/css/ext-all.css' />",
#               "<link rel='stylesheet' type='text/css' href='/custom/gw/ext/examples/ux/css/ux-all.css' />",
               "</head>",
               "<body>",
               "<!-- Call in Ext files -->",               
               "<div id='loading'>",
               "<div class='loading-indicator'>",
               "<img src='/custom/gw/images/extanim32.gif' width='32' height='32' style='margin-right:8px;float:left;vertical-align:top;'/>",
               "gWidgetsWWW",
               "<br />",
               "<span id='loading-msg'>Loading styles and images...</span>",
               "</div>",
               "<span id='loading-msg'></span>",
               "</div>",
               "<script type='text/javascript'>document.getElementById('loading-msg').innerHTML = 'Loading Core API...';</script>",
               "<script type='text/javascript' src='/custom/gw/ext/adapter/ext/ext-base.js'></script>",
#               "<script type='text/javascript' src='/custom/gw/ext/adapter/ext/ext-base-debug.js'></script>",
               "<script type='text/javascript'>document.getElementById('loading-msg').innerHTML = 'Loading UI Components...';</script>",

               "<script type='text/javascript' src='/custom/gw/ext/ext-all.js'></script>",
#               "<script type='text/javascript' src='/custom/gw/ext/ext-all-debug-w-comments.js'></script>",
               "<script type='text/javascript'>document.getElementById('loading-msg').innerHTML = 'Loading extra libraries...';</script>",

               "<script type='text/javascript' src='/custom/gw/ext/examples/ux/ux-all.js'></script>",
               "<script type='text/javascript'>document.getElementById('loading-msg').innerHTML = 'Loading gWidgetsWWW...';</script>",
               
               ## conditional includes -- values set in constructor on toplevel
               "<script type='text/javascript' src='/custom/gw/gWidgetsWWW.js'></script>",
               ## ## google stuff -- move out
               ## if(exists("ggooglemaps_key", .) && exists("do_googlemaps", .)) {
               ##   paste(
               ##         ## sprintf('<script type=\'text/javascript\' src=http://www.google.com/jsapi?key=%s></script>',.$ggooglemaps_key),
               ##         ## '<script type="text/javascript">  google.load("maps", "2"); </script>',
               ##         "<script type='text/javascript' src='/custom/gw/ggooglemaps/ext.ux.gmappanel.js'></script>" ,
               ##         '<meta name="viewport" content="initial-scale=1.0, user-scalable=no" />',
               ##         '<script type="text/javascript" src="http://maps.google.com/maps/api/js?sensor=false"></script>',
               ##         sep="\n")
               ## },
               ## end google
               ## webvis stuff move out
               ## if(exists("do_gwebvis", envir=.)) {
               ##   "<script type='text/javascript' src='/custom/gw/protovis/protovis-d3.1.js'></script>"
               ## },
               ##
               "<script type='text/javascript'>Ext.onReady(function(){Ext.get('loading').remove();});</script>",
               sep="\n")
  return(out)
}

##' Make a web page for the results
##'
##' @param results results of source a script file
##' @param script logical If TRUE wrap in script tags
##' @param . Ignored. Might be usefule for conditionally making the page header
##' @return HTML+javasscript code to write out to the server
makegWidgetsWWWpage <- function(results, script=TRUE, .=new.env()) {
  out <- makegWidgetsWWWPageHeader(.)
  out <-  paste(out,
               if(script) {
                 "<script type='text/javascript'>"
               },
               results,
               if(script) {
                 "</script>"
               },
                ## XXX This gives issues with the canvas example. Not sure why
                ## Causes SIGPIPE ERROR. Not the clearSession call, this invocation?
                ## "<script type='text/javascript'>Ext.EventManager.on(Ext.getBody() , 'unload', clearSession)</script>",
               "</body>",
               "</html>",
               sep="\n")
  return(out)
}

##################################################
## These are the exported files

##' start local server.
##' @param file file to open with. If file not null, then calls makeIndex on current directory
##' @param port port to open. May conflict with help server,
##' @param package If file and package  not given, opens default. Otherwise, file and package combined through localServerOpen
##' @export
## localServerStart <- function(file="", port=8079, package=NULL) {
##   startRpadServer("index.gWWW", port)   # just to keep it quiet
##   if(file == "" && is.null(package)) {
##     file <- "basehtml/makeIndex.R"
##     package <- "gWidgetsWWW"
##   }
##   localServerOpen(file, package)
## }

##' stop local server
##'
##' Deprecated
localServerStop <- stopRpadServer <- function() .Deprecated("",msg="No longer needed")

##' restart local server
##'
##' Deprecated
localServerRestart <- restartRpadServer <- function() .Deprecated("",msg="No longer needed")

##' open file wihin an optional package
##'
##' @param file name of file If package is null, relative to current directory
##' @param package optional package to look file up in.
##' @export
## localServerOpen <- function(file, package=NULL) {
##   ## open file
##   ## if package, then open from package found through
##   ## system.file(file, package=package)
##   ## if file matches R$, then use gWidgetsWWWrun
##   ## else pass through
##   if(!missing(package) && !is.null(package))
##     file <- sprintf("/custom/gw/gWidgetsWWWRunFromPackage/%s?package=%s",file, package)
  
##   if(length(grep("[rR]$", file)))
##     file <- sprintf("/custom/gw/gWidgetsWWWrun/%s", file)

##   port <- get("RpadPort", envir = .RpadEnv)
##   browseURL(sprintf("http://127.0.0.1:%s/%s", port, file))
## }


## Some "apps" from the apps directory

##' a package browser/installer
##'
##' Available for local installs only
##' @return makes a web page for managing installation/loading of packages
##' @export
gw_package <- function() {
  localServerOpen("apps/gw_package.R", package="gWidgetsWWW")
}

##' A simple workspace browser
##'
##' Available for local use
##' @return Creates a web page for browsing objects in the workspace
##' @export
gw_browseEnv <- function() {
  localServerOpen("apps/gw_browse.R", package="gWidgetsWWW")
}
  
#line 1 "d:/RCompile/CRANpkg/local/2.13/gWidgetsWWW/R/aaa.R"
##  Copyright (C) 2010 John Verzani
##
##  This program is free software; you can redistribute it and/or modify
##  it under the terms of the GNU General Public License as published by
##  the Free Software Foundation; either version 2 of the License, or
##  (at your option) any later version.
##
##  This program is distributed in the hope that it will be useful,
##  but WITHOUT ANY WARRANTY; without even the implied warranty of
##  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
##  GNU General Public License for more details.
##
##  A copy of the GNU General Public License is available at
##  http://www.r-project.org/Licenses/

require(proto, quietly=TRUE)

## Three main classes
## EXTWidget
##   EXTComponent
##   EXTContainer

## The double dot is meant to indicate an instance variable/method as
## opposed to a "class" variable/method. It seems that proto does not
## propogate the double dot, so these are set in the widget constructor (as
## they should be

## > a = proto(..test = TRUE, test = TRUE, new = function(.) .$proto())
## > b = a$new()
## > b$test
## [1] TRUE
## > b$..test
## Error in get(x, env = this, inherits = inh) : 
##   variable "..test" was not found
##
## so we check for ..test using exists and inherits = FALSE

##' Base trait for all widget/components/stores etc
EXTWidget <-
  proto(new = function(.,...) {
    obj <- .$proto(...)
    class(obj) <- c("gWidget",class(obj))
    return(obj)
  },
        ## properties
        toplevel = NULL,                # stores top gwindow instance
        parent = NULL,                  # stores parent (sub)window
        ID = "",                        # what am i, IDXXX
        .tag=list(),                    # for tag<-
        ..data = NULL,                  # for svalue
        ..values = NULL,                # for [
        ..enabled = TRUE,               # is enabled (or grayed out)
        ..visible = TRUE,               # logical, false if don't show
        ..shown = FALSE,                # is this object shown (rendered)?
        css = NULL,
        scripts = NULL,                 # javascript stuff per widget
        style = c(),                    # style options
        ExtConstructor = NULL,          # eg. Ext.Button
        ExtCfgOptions = NULL,           # config options -- fn returns a list
        ..ExtCfgOptions = NULL,         # additional options per instance
        getValueJSMethod = NULL,        # name of method, eg. "getValue"
        setValueJSMethod = NULL,        # name of method, eg. "setValue"
        coerce.with = NULL,             # coerce FUN or string
        transportSignal = NULL          # possibly a vector
        )


### methods ##################################################
##' has a slot? mapping of exists. From mutatr
##' 
##' @param key name of slot
##' @return logical
EXTWidget$has_slot <- function(., key) exists(key, envir=.)

##' is slot local to object (not inherited)
##' 
##' @param key name of slot
##' @return logical
EXTWidget$has_local_slot <- function(., key) exists(key, envir=., inherits=FALSE)

## or puts onto JS queue
##' @param ... pasted together to form a string
##' @param queue to we push onto JSQueue or print out. (Pushing is used if returning JS)
EXTWidget$Cat <- function(.,..., queue=FALSE) {
  out <- paste(..., collapse="\n")
  if(queue)
    .$addJSQueue(out)
  else
    cat(out)
}

## Cat either a string or function
##' Helper to cat out part of webpge
##' @param part name of part or function defining part
##' @param queue passed to Cat method of .
##' @return will print out page or queue it
EXTWidget$showPart <- function(.,part, queue=FALSE) {
  ## part may be property of function. This checks
  if(!is.null(part))
    if(is.function(part))
      .$Cat(part(), queue=queue)
    else
      .$Cat(part, queue=queue)
}

## instead of pasting "o" in front of ID
## we have Ext Object "o" + ID and DOM object "ID" to consider
## XXX This is misnamed (toString?)

##' Represent object as character, similar to tcltk ID
##'
##' The character is usually the name of the object in EXT.
##' @return a character
EXTWidget$asCharacter <- function(.) {String('o') +  .$ID}

##' Some widgets are found within a panel. This allows one to override
EXTWidget$asCharacterPanelName <- function(.) .$asCharacter()

##' simple function to call an Ext method on the corresponding object
##'
##' @param methodname name of method
##' @param args arguments -- a string! such as "e,w"
##' @return a string, JS, to call method
EXTWidget$callExtMethod <- function(., methodname, args) {
  if(missing(args))
    args <- ""
  out <- sprintf("%s.%s(%s);\n", .$asCharacter(), methodname, args)
  return(out)
}

##' Is this a toplevel widget?
##'
##' @param . self
##' @return logical
EXTWidget$isToplevel <- function(.) .$identical(.$toplevel)


## We have both S3 methods and their proto counterparts

## Here we have getValue, setValue for svalue, svalue<-
## svalue, svalue<-

##' EXT widget for svalue
##'
##' @param index see svalue
##' @param drop see svalue
EXTWidget$getValue <- function(., index=NULL,drop=NULL, ...) {
  ## if(exists("..shown",envir=.,inherits=FALSE)) {
     ## ## get from widget ID
     ## out <- try(get(.$ID,envir=.$toplevel),silent=TRUE) ## XXX work in index here?
     ## if(inherits(out,"try-error")) {
     ##   out <- .$..data
     ## } else {
     ##   .$..data <- out                  # update data
     ## }
  ## } else {

  out <- .$..data
  ## if(is.null(index) || !index) {
  ##   out <- .$..data
  ## } else {
  ##   values <- .$getValues()
  ##   if(is.data.frame(values))
  ##     values <- values[,1, drop=TRUE]
  ##   out <- which(.$..data %in% values)
  ## }
  ##}
  out <- .$coerceValues(out)
  return(out)
}

##' Set the widget value
##'
##' have we shown the widget? if so, we set in document too
##' We need to also assign to .$ID in . as otherwise
##' we don't get the getValue right
##' @param index see \code{svalue<-}
##' @param value what will be set
##' @return sets value quietly, Adds to JS queue if apt
EXTWidget$setValue <- function(., index=NULL, ..., value) {
  ## override locally if desired
  if(exists("..setValue",envir=., inherits=FALSE)) {
    .$..setValue(index=index, ..., value=value)
  } else {
    
    ## store index
    if(!is.null(index)) {
      items <- .$getValues();  d <- dim(items)
      if(is.null(d) || d == 1)
        newVal <- items[value,1]
      else
        newVal <- items[value,]
    } else {
      newVal <- value
    }
    .$..data <- newVal
  }
  ## now process if shown
  if(exists("..shown",envir=., inherits=FALSE)) 
    .$addJSQueue(.$setValueJS(index=index, ...))

 }
## create javascript code to write Javascript to set
## the value of a widget
## properties setValueMethod,

##' property for where to set javascript when outside the Ext methods/properties
EXTWidget$setValueJSAttribute = "innerHTML"



##' Method call to create JavaScript to set a value
##'
EXTWidget$setValueJS <- function(.,...) {
  if(exists("..setValueJS", envir=., inherits=FALSE)) .$..setValueJS(...)
  
  ## default method to set the value using setValue
  value <- .$..data                     # don't use svalue here
  
  ##' this uses the DOM value -- not the Ext widget. EXTComponent
  ##' overrides this.
  out <- sprintf("var widget= EXT.get(%s).%s = %s;", shQuote(.$ID), .$setValueJSAttribute, shQuote(value))
  return(out)                            
}


##' method to coerce values using either coerce.with or ..coerce.with
##'
##' @param values can override or take \code{..values} from object
EXTWidget$coerceValues <- function(.,values = .$..values) {
  coerce.with = NULL
  if(exists("..coerce.with", envir=., inherits=FALSE))
    coerce.with <- .$..coerce.with
  else if (exists("coerce.with", envir=., inherits=TRUE))
    coerce.with <- .$coerce.with
  
  if(is.null(coerce.with)) return(values)

  if(is.character(coerce.with))
    return(do.call(coerce.with, list(values)))
  else
    return(coerce.with(values))
}
  


## getValues = [; setValues = [<-
## [, [<-

##' method for \code{[}
EXTWidget$getValues <- function(., ...) .$..values

##' method for \code{[<-}
##' @param i ignored -- XXX FIX THIS
##' @param j ignored -- XXX fix this
##' @param ... passed to setValuesJS
##' @param value value to set
##' @return adds to JS queue if shown
EXTWidget$setValues <- function(.,i,j,...,value) {
  ## XXX Need to include i,j!
  .$..values <- value
  if(.$has_local_slot("..shown"))
    .$addJSQueue(.$setValuesJS(...))
}

##' call to set values via JS
##' @param ... passed to local function
EXTWidget$setValuesJS <- function(.,...) {
  if(.$has_local_slot("..setValuesJS"))
     .$addJSQueue(.$..setValuesJS(...))
}

## length, dim -- issue with recursion if given full name

##' length method for gWidget class
##' 
##' @param x gWidgets instance.
length.gWidget <- function(x) {. = x; .$.length()}

##' EXT length method
##'
##' @return length of object
EXTWidget$.length <- function(.) {vals <- .$..values; length(vals)}

##' dim method for gWidget
##' @param x gWidget object
dim.gWidget <- function(x) {. = x; .$.dim()}

##' EXT dim method
EXTWidget$.dim <- function(.) {vals <- .$..values; dim(vals)}

## names, names<-
EXTWidget$getNames <- function(.) .$..names
EXTWidget$setNames <- function(.,value) {
  .$..names <- value
  if(exists("..shown",envir=., inherits=FALSE)) {
    .$addJSQueue(.$setNamesJS())
  }
}
##' Method to set names attribute of object in Javascript
EXTWidget$setNamesJS <- function(.) {}    # set names


##' Method for visible()
EXTWidget$getVisible <- function(.) return(.$..visible )

##' method to set visibility visible<-
##'
##' @param value logical
EXTWidget$setVisible <- function(.,value) {
  .$..visible <- as.logical(value)
  if(exists("..shown",envir=., inherits=FALSE)) {
    .$addJSQueue(.$setVisibleJS())
  }
}

##' javascript to synchronize widget with R value
EXTWidget$setVisibleJS <- function(.) {
  if(exists("..setVisibleJS", envir=., inherits=FALSE))
    .$..setVisibleJS()
  
  value <- .$..visible
  if(as.logical(value))
    action = "show"
  else
    action = "hide"
  .$callExtMethod(action)
}

## enabled<-

##' is widget enabled
##' 
##' @return logical
EXTWidget$getEnabled <- function(.) return(.$..enabled )

##' method to set if widget is enabled
##' @param value logical
EXTWidget$setEnabled <- function(.,value) {
  .$..enabled <- as.logical(value)
  if(.$has_local_slot("..shown"))
    .$addJSQueue(.$setEnabledJS())
}
##' method to write javascript to synchronize widget with R value
EXTWidget$setEnabledJS <- function(.) {
  if(exists("..enabled", envir=., inherits=FALSE))
    value <- as.logical(.$..enabled)
  else
    value <- TRUE

  ## which method
  out <- sprintf("%s.%s()\n", .$asCharacter(), ifelse(value, "enable", "disable"))
  return(out)
}


## ..style covers fonts, size, and others
## font uses this
EXTWidget$setFont <- function(.,value) {
  
}
## XXX integrate with setStylesJS
EXTWidget$setStyleJS <- function(.,styles = NULL) {
  ## styles
  if(is.null(styles)) {
    styles <- .$style
  }
  if(exists("..style",envir=., inherits=FALSE)) {
    for(i in names(.$..style))
      styles[i] <- .$..style[i]
  }
  
  if(length(styles) > 0) {
    out <- String() 
    
    for(i in names(styles)) {
      out <- out +
        'Ext.get(' + shQuote(.$ID) + ').setStyle(' + shQuote(i) + ',' +
          coerceToJSString(styles[i]) + ');\n'
    }
  } else {
    out <- String()
  }
  return(out)
}
  

##' set size fo widget
##' 
##' calls setStyle
##' @param value a vector c(width), c(width, height)
EXTWidget$setSize <- function(., value) {
  ## fix size in ..style
  if(exists("..style",envir=., inherits=FALSE))
    curStyle <- .$..style
  else
    curStyle <- c()
  
  n <- length(value)
  if(n == 0) return()
  
  curStyle["width"] <- .$..width <- value[1]
  
  
  if(n > 1) {
    curStyle["height"] <- .$..height <- value[2]
  }
  
  .$..style <- curStyle
  return()
}

##' method to return size (in pixels) of widget
##'
##' @return integer vector with two components
EXTWidget$getSize <- function(.) {
  if(!exists("..style",envir=., inherits=FALSE))
    return(c(width=NULL,height=NULL))
  
  curStyle <- .$..style
  return(c(width=curStyle$width,height=curStyle$height))
}


## Methods to print out the javascript to create a widget
## using Ext. There are several stages that can be overridden. For
## example, see EXTComponentWithStore where writeConstructor is overridden.

## these options are inherited by others. Can be overridden
## by the widget
## Standard Configuration options
## also have ExtCfgOptions for each widget (class based)
## and ..ExtCfgOptions for instances

## The function mapRtoObjectLiteral pieces together the list.
## The one subtlety is that characters get quoted, String()'s do not.
## the function is recursive, as some options may be given as
## object literals in Ext

##' Create a list of standard configuration options
##'
##' Can be overridden, subclasses, ...
##' @return a list with the options. List is passed to mapRtoObjectLiteral
EXTWidget$ExtStdCfgOptions <- function(.) {
  out <- list(
              "id"=.$ID
              )
  out[["renderTo"]] <- String(.$toplevel$..renderTo) #String("Ext.getBody()"),

  if(exists("..enabled",envir=., inherits = FALSE))
    if(!.$..enabled)
      out[['disabled']] <- !.$..enabled   # in Ext.Component
  if(exists("..visible",envir=., inherits = FALSE))
    if(!.$..visible)
      out[['hidden']] <- !.$..visible   # in Ext.Component
  if(exists("..tpl", envir=., inherits=FALSE)) {
    out[['tpl']] <- .$..tpl()
  } else if(exists("tpl", envir=., inherits =FALSE)) {
    out[['tpl']] <- .$tpl()
  }
  
  ## XXX how to integrate styles into this?
  return(out)
}


       
##' method to coerce ExtCfgOptions into a string
##' 
##' ExtCfgOptions is a list. The names are passed as keys and the values
##' are assigned.
##' Object Literals in Ext are like passing lists through the ... argument
##' characters are quoted, String()s are not. Sometimes
##' as.character(String() + "...") is useful.
##' This function recurses when the value is a list
##' method coerceToJSString is in common.R
##' @param values value to be mapped
##' @param doBraces if TRUE will wrap in {}
##' @return javascript string 
EXTWidget$mapRtoObjectLiteral <- function(.,values,doBraces=TRUE) {
  
  if(missing(values)) {
    ## pull in from std, class configuration, instance values
    values <- .$ExtStdCfgOptions()

    if(exists("ExtCfgOptions", envir=., inherits=TRUE) &&
       !is.null(.$ExtCfgOptions)) {

      cfgValues <- .$ExtCfgOptions()
      for(i in names(cfgValues))
        values[[i]] <- cfgValues[[i]]
    }
    ## add to values if some there
    if(exists("..ExtCfgOptions", envir=., inherits=FALSE)) {
      instanceValues <- .$..ExtCfgOptions()
      for(i in names(instanceValues)) {
        if(!is.null(instanceValues[[i]]))
          values[[i]] <- instanceValues[[i]]
      }
    }
  }
  

  ## values is a list, we need to make a vector of strings
  out <- c()
  for(i in names(values)) {
    if(!is.null(values[[i]])) {
      ## recurse if a list
      if(is.list(values[[i]])) {
        out[i] <- .$mapRtoObjectLiteral(values[[i]], doBraces=TRUE)
      } else {
        out[i] <- coerceToJSString(values[[i]])
      }
    }
  }

  res <- paste(names(out), out, sep=":", collapse=",\n\t")
  if(doBraces)
    res <- String('{\n\t') + res + '\n}'

  return(res)
}

## Basic template for a EXT widget.
## There are several stages.
## header and footer are used to wrap the object if desired

##' header for a widget.
##'
##' Meant to be overridden in subclass
##' @return returns text to be placed in the header
EXTWidget$header <- function(.) return("")

##' footer for the widget
##'
##' Meant to be overridden in subclass
##' @return returns text to be placed in the header
EXTWidget$footer <- function(.) return("")

##' widget separator
EXTWidget$separator <- function(.) return("")

##' Method to write out the constructor
##'
##' Assumes property \code{ExtConstructor} is set
##' @return string container JS code for constructor
EXTWidget$writeConstructor <- function(.) {
  out <- String() + "\n" +
### var creates a *local* variable -- issues with safari here
###    'var o' + .$ID +
    .$asCharacterPanelName() +
      ##'o' + .$ID +
      ' = new ' +.$ExtConstructor + '(' +
        .$mapRtoObjectLiteral() +
          ');\n'

  ## write out x-hidden unless requested not to.
  ## x-hidden causes the widget not to display until added to parent
  if(!.$has_local_slot("..shown") && (.$has_local_slot("x.hidden") && .$x.hidden))
    out <- out +
      sprintf("Ext.get('%s').addClass('x-hidden');\n", .$ID)

  
  ## add in at the end 
  if(exists("..writeConstructor", envir=., inherits=FALSE)) {
    out <- out + .$..writeConstructor() + "\n"
  }

  return(out)
}

## For controls whose value may be changed by the GUI, we write out changes
## immediately back to R so that R handlers will be aware of the changes. We
## call this transport. The method assignValue is used within R to assign these values into the widget
## The basic call involves  Ext.util.JSON.encode({value:value}) on one end
## and this decode by fromJSON on the other end.

##' code to write out value definition of transport function
##' 
##' called in writeHandlers
##' @param ... ignored
##' @return javascript string
EXTWidget$transportValue <- function(.,...) {
  out <- sprintf("var value = %s.%s();\n", .$asCharacter(), .$getValueJSMethod)
  return(out)
}

##' write out transport function
##'
##' @return javascript string
EXTWidget$transportFUN <- function(.) {
  out <- sprintf("_transportToR(%s, Ext.util.JSON.encode({value:value}) );", shQuote(.$ID))
  return(out)
}

##' piece together transport string
##'
##' @return javascript string writing out body of transport function
EXTWidget$writeTransport <- function(.,ext="",signal=NULL) {
  ## transport to R
  if(!is.null(.$transportSignal)) {
    out <- String() +
      .$transportValue(i = ext,signal=signal) + # (For EXTComponentWithItems)
        .$transportFUN() +
          '\n'
  } else {
    out <- String("")
  }
  return(out)
}

### Tooltip
##' property for width of tooltip
EXTWidget$tooltipWidth <- 200
##' propert to hide tooltip after time out
EXTWidget$tooltipAutoHide <- TRUE # override to

##' method to write out tooltip padded with \code{tooltip<-} method.
##'
##' writes tooltip. Tooltips are added with tooltip<- function
##' value can be a URL (isURL == TRUE) or a string or a character vector which
##' gets pasted together to be a string
##' @return javascript string
EXTWidget$writeTooltip <- function(.) {
  out <- String()
  ## tooltip
  if(exists("..tooltip", envir=., inherits=FALSE)) {
    lst <- list(target=.$ID,
                showDelay=100,
                hideDelay=50,
                autoHide = .$tooltipAutoHide,
                trackMouse = TRUE,
                width = .$tooltipWidth)            # default size?

    if(isURL(.$..tooltip)) {
      lst[["autoLoad"]] <- String('{url:') + shQuote(.$..tooltip) + '}'
    } else {
      ## ..tooltip can be a) a string, b) a character vector of c) a list with components title and message
      if(is.list(.$..tooltip)) {
        lst[['title']] <- .$..tooltip$title
        message <- .$..tooltip$message
      } else {
        message <- .$..tooltip
      }
      lst[["html"]] <- paste(escapeQuotes(message), collapse="<BR>")
    }

    if(!.$tooltipAutoHide) {
      lst[["closable"]] <- TRUE
      lst[["draggable"]] <- TRUE
    }
    out <- out +
      'var tooltip' + .$ID + '= new Ext.ToolTip(' +
        +  .$mapRtoObjectLiteral(lst) + ');' + '\n'
  }
  return(out)
}

##' show object,
##' 
##' Called by show(). This method cat's out value
##' Called once while GUI is drawn, so catted out, not added to queue
EXTWidget$show <- function(., queue=FALSE) {
  out <- String("\n") +
    .$writeConstructor() +
      .$setStyleJS(styles=.$style) +
          .$writeTooltip() +
            .$writeHandlersJS()           # includes transport

  if(.$has_local_slot("..visible"))
    .$setVisibleJS()
  
  .$..shown <- TRUE
  .$Cat(out, queue=queue)
}

##' An init method
##'
##' Adds instance to toplevel list of children
##' @param . self
EXTWidget$init <- function(.) {
  if(.$has_local_slot("toplevel")) {
    .$toplevel$addChild(.)
  }
}

##' Assign value passed in from browser via transportToR
##'
##' Default is just svalue, but many other widgets require more than this
##' @param . self
##' @param value value to assign. May be a vector or list (from JSON conversion)
EXTWidget$assignValue <- function(., value) {
  .$..data <- value[[1]]
#  svalue(., index=TRUE) <- value[[1]]   # value is a list
}

##################################################
## Some "subclasses" of EXTWidget defined below

##' EXT Component -- for controls, etc. Main subclass
EXTComponent <- EXTWidget$new()

## public API. Call Show which wraps show withing header, tooltip,
## separators, footer,
## A widget will show
## header
## css (gwindow)
## scripts (gwindow)
## tooltip
## .$show()
## setHandlers (gwindow)
## footer

## unlike a Container, these have no children

##' Show method for cmponents
##'
##' Shows components, sets ..shown property
##' @param ... pass in queue=TRUE to queue up, otherwise cat's out
##' @return NULL
EXTComponent$Show <- function(.,...) {        # wraps Show
  ## add in any instance specific scripts
  ## component specific scripts written out once in gwindow
  if(exists("..scripts",envir=., inherits=FALSE)) 
    .$showPart(.$..scripts, ...)
  
  ## make an object with method?
  if(exists("..header",envir=.,inherits=FALSE))  .$showPart(.$..header, ...)
  .$showPart(.$header, ...)

  
  .$show(...)                   # show self
  
  if(exists("..footer",envir=.,inherits=FALSE))  .$showPart(.$..footer, ...)
  .$showPart(.$footer, ...)

  .$..shown <- TRUE             # set shown (rendered)

}


##' 
### Methods have two parts
### * one for first showing (sets value in R)
### * one after shown -- returns string with javascript to synchronize R to browser

##' Property for setValue if assigning to a property
EXTComponent$setValueJSAttribute <- "value"
##' method call for setting values
EXTComponent$setValueJSMethod = "setValue"  # oID.method()

##' javascript to synchronize main value of component
##'
##' @return javascript string
EXTComponent$setValueJS <- function(.,...) {
  if(exists("..setValueJS", envir=., inherits=FALSE)) .$..setValueJS(...)
   ## default method to set the value using setValue
   value <- .$..data                     # don't use svalue here


   ## use Ext object and a method directly -- no DOM
   out <- String() +
     'o' + .$ID +'.' + .$setValueJSMethod +
       '(' + toJS(.$..data) + ');' + '\n'
   
   return(out)                              # to browser, not filewi
 }



### Different components ##################################################

##' A component without items (so can't set value the same way)
##'
##' Examples are buttons, statusbar, ... These don't have a \code{[} method or a getValues/setValues bit
EXTComponentNoItems <- EXTComponent$new()
EXTComponentNoItems$x.hidden <- FALSE

##' setValue for componets without items
##'
##' setValue just stuffs into \code{..data}
EXTComponentNoItems$setValue <- function(., index=NULL, ..., value) {
  ## override locally if desired
  if(exists("..setValue",envir=., inherits=FALSE)) {
    .$..setValue(index=index, ..., value=value)
  } else {
    .$..data <- value
  }
  ## now process if shown
  if(exists("..shown",envir=., inherits=FALSE)) 
    .$addJSQueue(.$setValueJS(index=index, ...))
}


##################################################
##' a resizable component
EXTComponentResizable <- EXTComponent$new()

## footer adds in a resizable conainer -- not working?
EXTComponentResizable$footer <- function(.) {
  lst <- list(id  = as.character(.$ID + 'resizer'),
              wrap = TRUE,
              pinned = TRUE)
  if(inherits(.,"gImage"))
    lst[['preserveRatio']] <- TRUE

  out <- String() +
    'new Ext.Resizable(' + shQuote(.$ID) + ',' +
      .$mapRtoObjectLiteral(lst) + ');\n'

  return(out)
  }

### Text component ##################################################
##
## We have gedit, gtext with key events, that are a bit different for handlers
## as we want to intercept the event with javascript

##' main trait for text components
EXTComponentText <- EXTComponent$new()

##' Assign value -- coerce to text
EXTComponentText$assignValue <- function(., value) {
  .$..data <- paste(value[[1]], collapse="\n")
}

##' method to write handler
##'
##' @return javascript string function(...) {...} NO ; at end
EXTComponentText$writeHandlerFunction <- function(., signal, handler) {
   out <- String()  +
     sprintf("function(%s) {runHandlerJS(%s%s);",
             .$handlerArguments(signal),
             handler$handlerID,
             ifelse(!is.null(handler$handlerExtraParameters),
                    paste(",", handler$handlerExtraParameters, sep=""),
                    "")
             )
     
   ## 'function(' + .$handlerArguments(signal) + ') {'
   ## tmp <- String() +
   ##   'runHandlerJS(' + handler$handlerID
   ## if(!is.null(handler$handlerExtraParameters)) {
   ##   tmp <- tmp + "," + handler$handlerExtraParameters
   ## }
   ## tmp <- tmp + ');'

   ## need to do transport
   ## tmp1 <- sprintf("var value = escape(%s.getValue());_transportToR(%s, Ext.util.JSON.encode({value:value}));",
   ##                 .$asCharacter(), shQuote(.$ID))


   if(!is.null(handler$args$key)) {

     keyMatch <- ""
     if(!is.null(key <- handler$args$key)) {
       keyMatch <- ifelse(is.numeric(key) || nchar(key) == 1, shQuote(key), key)
     } else if(!is.null(key <- handler$args$charCode)) {
       keyMatch <- ifelse(nchar(key) == 1, shQuote(key), key)
     }
     
     out <- out +
       paste(sprintf("if(e.getCharcode() == %s) {",keyMatch),
             sprintf("var value = escape(%s.getValue());", .$asCharacter()),
             sprintf("_transportToR('%s', EXT.util.JSON.encode({value:value}));", .$ID),
             "}",
           sep="\n")
   }

   out <- out + "}\n\n"
   
   ## ## wrap inside conditional
   ## if(!is.null(handler$args$key)) {
   ##   key <- handler$args$key
   ##   out <- out + "if(e.getCharCode() ==" +
   ##     ifelse(is.numeric(key) || nchar(key) == 1, shQuote(key),key) +
   ##     ") {" +
   ##       tmp1 +
   ##         tmp +
   ##         "};"
   ## } else if(!is.null(handler$args$charCode)) {
   ##   key <- handler$args$charCode
   ##   out <- out + "if(e.getCharCode() ==" +
   ##     ifelse( nchar(key) == 1, shQuote(key),key) + ") {" +
   ##       tmp1 + tmp +
   ##       "};"
   ## } else {
   ##   out <- out + tmp
   ## }
   ## ## close up
   ## out <- out + '}' + '\n\n'

   return(out)
}

### Container Trait.  ##################################################
## Main methods are:
## newID -- ID for a widget generated when added to a container.
##   This also copies over stuff to
## add -- adds to list for later rendering
## Show -- to show object -- loops over children

EXTContainer <- EXTWidget$new(children = list(),
##XXX                              width = "auto",
##                              height = "auto",
                              width=NULL, height=NULL, ## JV XXX
                              makeItemsFixedItems = "" # to make items[]
                              )
##' A new id
##'
##' Each child gets its own ID
##' @return a new id (gWidgetID##)
EXTContainer$newID <- function(.) {
  IDS <- .$toplevel$..IDS
  n <- length(IDS)
  newID <- sprintf("gWidgetID%s", n+1)
  .$toplevel$..IDS <- c(IDS, newID)     # append
  return(newID)
}

##' Add child widget to a container
##' 
##' add for a container does several things:
##' * set toplevel for each child
##' * add css to toplevel if applicable
##' * add javascript to toplevel if applicable
##' * set object into child
##' @param child child object to add
##' @param ... is not used XXX should fix this.
##' @return NULL
EXTContainer$add <- function(.,child,...) {

   ## add an ID
   child$ID <- .$newID()

   ## add parent to child for traversal
   child$parent = .
   child$toplevel = .$toplevel         # pass in toplevel window
   child$init()                        # initialize
   
   ## pass along parent properties
##XXX   child$titlename <- .$titlename

   ## Move scripts, css to toplevel
   if(!is.null(child$css)) {
     css <- .$toplevel$css
     if(is.function(child$css))
       css[[class(child)[1]]] <- list(obj = child, FUN = get("css",child))
     else if(is.character(child$css))
       css[[class(child)[1]]] <- child$css
   .$toplevel$css <- css
   }
   

   ## scripts
   if(!is.null(child$scripts)) {
     scripts <- .$toplevel$scripts
     if(is.null(scripts[[class(child)[1]]])) {
       ## not show, add
       if(is.function(child$scripts))
         scripts[[class(child)[1]]] <-
           list(obj = child, FUN = get("scripts",child))
       else if(is.character(child$scripts))
         scripts[[class(child)[1]]] <- child$scripts
       
       .$toplevel$scripts <- scripts

       ### XXX JV -- need to update for new way of handling JS .$addJSQueue...
       if(exists("..shown", envir=.$toplevel, inherits=FALSE) && .$toplevel$..shown) {
         ## need to cat this script out now,
         ## This prevents things being defined in subwindows
         ## for first time
         i <- scripts[[class(child)[1]]]
         if(is.list(i))
           i <- i$FUN(i$obj)
         ## show now
         .$Cat(i, queue=.$has_local_slot("..shown"))
       }
     }
   }
   

   
   ## add to children
   lst <- .$children
   .$children <- c(lst, child)

   if(exists("..shown",envir=., inherits=FALSE)) {
     if(!inherits(child,"gSubwindow")) {
       child$Show(queue=TRUE)
       .$addJSQueue(.$addJS(child))
     }
   }
}


##' Write javascipt code to add containers after the GUI has been shown
##'
##'  this is likely not perfect!
##' @param child gWidget instance
EXTContainer$addJS <- function(., child) {
  out <- String() +
    sprintf("%s.add(%s); %s.doLayout();",
            .$asCharacter(), child$asCharacter(), .$asCharacter())
  ## walk back tree
  toplevel <- .$toplevel
  parent <- .$parent
  while(!parent$identical(toplevel)) {
    out <- out +
      sprintf("%s.doLayout();\n", parent$asCharacter())
    parent <- parent$parent
  }
  
  return(out)
}

##' remove a widget
##'
##' @param widget widget to remove
EXTContainer$delete <- function(., widget) {
  ## remove widget from obj
  if(exists("..shown", envir=., inherits=FALSE)) {
    .$addJSQueue(.$deleteJS(widget))
  }
}

##' javascript to synchronize R with GUI
##'
##' @param widget to be removed
##' @return javascript code
EXTContainer$deleteJS <- function(., widget) {
  sprintf("%s.remove(%s);", .$asCharacter(), widget$asCharacter())
}
      

##' Set size for containers width and height are properties, not in .style
##'
##' @param value vector of width [height]
##' @return sets properties
EXTContainer$setSize <- function(., value) {
  .$width <- value[1]
  if(length(value) > 1)
    .$height <- value[2]
}

##' return size of widget
##'
##' @return integer width and height
EXTContainer$getSize <- function(.) c(width=.$width,height=.$height)

##' Create list with standard configurations
##'
##' We use a list to store configurations. This returns some defaults
EXTContainer$ExtStdCfgOptions <- function(.) {
  out <- get("ExtStdCfgOptions",EXTWidget)(.)
  out[['width']] <- .$width
  out[['height']] <- .$height
  
  ## menubar, toolbar, statusbar
  if(exists("..menuBar",envir=., inherits=FALSE)) {
    out[['tbar']] <- .$..menuBar$writeMenu()
    .$..menuBar$..shown <- TRUE
  }
  
  if(exists("..statusBar",envir=., inherits=FALSE)) {
    sbText <- String() +
      'new Ext.ux.StatusBar({' +
        'id: "' + .$ID + 'statusBar",' +
          'defaultText: "",' +
            'text:' + shQuote(.$..statusBarText) +
              '})'
    out[['bbar']] <- sbText
    .$..statusBar$..shown <- TRUE
    
  }
    
  return(out)
}



##' Show method for containers
##' Containers have children to show too.
##' also a separator is possible to display between the children,
##' although this should go
##' @param queue to we add to queue or simple cat out
EXTContainer$Show <- function(., queue=FALSE) {
  ## css -- use createStyleSheet method of Ext JS to write out
  if(exists("css",envir=., inherits=FALSE)) {
    out <- String() 
    for(i in .$css) {
      if(is.list(i))
        out <- out + i$FUN(i$obj)
      else if(is.character(i))
        out <- out + i
    }
    ## wrap in EXT JS function
    if(nchar(out)) {
      out <- String('Ext.util.CSS.createStyleSheet("') + out + '");'
      .$Cat(out, queue=queue)                        # these are printed out
    }
  }

  
  ## scripts
  if(exists("scripts", envir=., inherits=FALSE)) {
    out <- String() 
    for(i in .$scripts) {
      if(is.list(i))
        out <- out + i$FUN(i$obj)
      else if(is.character(i))
        out <- out + i
    }
    .$Cat(out, queue=queue)
  }


  ## now show container
  if(exists("..header",envir=.,inherits=FALSE))
    .$showPart(.$..header, queue=queue)
  .$showPart(.$header,queue=queue)

  
  ## write out actions if present
  if(exists("..actions", envir = ., inherits = FALSE)) {
    if(length(.$..actions) > 0) {
      for(i in .$..actions) {
        i$Show(queue=queue);
        i$..shown <- TRUE
      }
    }
  }

  

  children <- .$children
  if((n <- length(children)) > 0) {
    for(i in 1:n) {
      children[[i]]$Show(queue=queue)              # Show children
      if(i < n) {
        if(exists("..separator",envir=.,inherits=FALSE))
          .$showPart(.$..separator, queue=queue)       # widget specific
        .$showPart(.$separator, queue=queue)
      }
    }
  }

  .$show(queue=queue)                      # show self
  .$..shown <- TRUE                     # set shown

  ## handlers ## gwindow only
  ## if(exists("..setHandlers",envir=.,inherits=FALSE)) # gwindow only
  ##    .$showPart(.$..setHandlers, queue=queue)

  if(exists("..footer",envir=.,inherits=FALSE))  .$showPart(.$..footer, queue=queue)
  .$showPart(.$footer, queue=queue)

}

##' shows the child items
##' 
##' items are how containers refer to their children
##' this will be overridden more than likely
EXTContainer$makeItems <- function(.) {
  childIDs <- sapply(.$children, function(i) i$ID)
  isResizable <- sapply(.$children, function(i)
                        inherits(i,"gWidgetResizable"))
  if(any(isResizable))
    childIDs[isResizable] <- paste(childIDs[isResizable],"resizer",sep="")

  
  n <- length(.$children)
  if(n == 0)
    return("{}")
  
  ## contentEl specifies where to get values
  contentEls <- paste('contentEl:', shQuote(childIDs), sep="")
  ## labels are for notebooks
  theLabels <- character(n)
  for(i in 1:n) {
    if(exists("..label",envir=.$children[[i]],inherits=FALSE))
      theLabels[i] <- String("title:") + shQuoteEsc(.$children[[i]]$..label)
  }
  ## tabTooltips are for notebooks
  tabTooltips <- character(n)
  for(i in 1:n) {
    if(exists("..tabTooltip",envir=.$children[[i]],inherits=FALSE))
      tabTooltips[i] <- String("tabTip:") + shQuoteEsc(.$children[[i]]$..tabTooltip)
  }

  itemContent <- character(n)
  for(i in 1:n) {
    if(theLabels[i] == "" && tabTooltips[i] == "")
      itemContent[i] <- paste(contentEls[i],sep=",")
    else if(theLabels[i] == "") 
      itemContent[i] <- paste(contentEls[i],tabTooltips[i],sep=",")
    else if(tabTooltips[i] == "")
      itemContent[i] <- paste(contentEls[i],theLabels[i],sep=",")
    else
      itemContent[i] <- paste(contentEls[i],theLabels[i],tabTooltips[i],sep=",")
  }
  if(!exists("makeItemsFixedItems",.,inherits=FALSE))
    .$..fixedItems <-  ""               # ends with ",".


  
  tmp <- String('{') +  .$makeItemsFixedItems

  items <- paste(paste(tmp,itemContent,'}',
                  sep=""),
            collapse=",")
  return(items)
}

##' override of EXTWidget$show,
##' 
##' unlike a EXTComponent, here we need to add in the items too
##' @param queue do we cat or queue
EXTContainer$show <- function(., queue=FALSE) {
 ## out <- String() + "\n\n" +
 ##   'o' + .$ID + '= new ' + .$ExtConstructor + '({' + '\n' +
 ##       .$mapRtoObjectLiteral(doBraces=FALSE) +
 ##         ',' + '\n' +
 ##           'items:[' +.$makeItems() +
 ##             ']' + '});' + "\n"

 out <- String() +
   sprintf("%s = new %s({\n\t%s,\n\titems:[%s]});\n",
           .$asCharacter(), .$ExtConstructor,
           .$mapRtoObjectLiteral(doBraces=FALSE),
           .$makeItems())

 ## Wanted to add dynamically, but this just doesn't work for all children (combobx, tables, ...)
 ##  out <- String() +
 ##    sprintf("%s = new %s({%s});\n",
 ##            .$asCharacter(), .$ExtConstructor,
 ##            .$mapRtoObjectLiteral(doBraces=FALSE)
 ##            )
 ## childIDs <- sapply(.$children, function(i) as.character(i$asCharacter()))
 ##  for(i in childIDs) {
 ##    out <- out + sprintf("%s.add(%s);\n", .$asCharacter(), i)
 ##  }
 ##  out <- out + sprintf("%s.doLayout();\n", .$asCharacter())

 if(!.$has_local_slot('..shown') && (.$has_local_slot("x.hidden") && .$x.hidden))
   out <- out +
     sprintf("%s.addClass('x-hidden');\n", .$asCharacter())
 
  if(.$has_local_slot("..visible"))
    out <- out + .$setVisibleJS()
  
  .$..shown <- TRUE
  .$Cat(out, queue=queue)
}

##################################################
##
## Some widget have a data store associated with them
## eg. gcombobox, gtable, gdf 

##' Main trait to hold a data store
EXTStore <- EXTWidget$new()

##' new method for a data store.
##'
##' Sets classname, toplevel widget
##' @param toplevel toplevel window
EXTStore$new <- function(., toplevel=NULL) {
  obj <- .$proto(toplevel=toplevel)
  class(obj) <- c("gWidgetStore",class(obj))
  invisible(obj)
}
## properties
## the data frame (or vector)

##' the ID for the store
EXTStore$ID <- NULL                      # get from newID
##' property. The data held in the store
EXTStore$data <- NULL
##' property. For some stores, a chosen column is designtated
EXTStore$chosenCol <- NULL               # selected column

## Store methods
##' set data into store
##'
##' @param d the data
EXTStore$setData <- function(.,d) .$data <- d

##' get Data from store
##'
##' @return the data
EXTStore$getData <- function(.) .$data

##' dimension of store
##'
##' @return dimension (from dim())
EXTStore$dim <- function(.) dim(.$getData())

##' set the chosen column property
##'
##' @param value the chosen column
EXTStore$setChosenCol <- function(.,value) .$chosenCol <- value

##' get the chosen column
##'
##' @return the value of chosen column
EXTStore$getChosenCol <- function(.).$chosenCol

##' method to coerce data to javascript array
##'
##' @param val if missing using data, otherwise will coerce this
##' @return javascript to display
EXTStore$asJSArray <- function(.,val) {
  if(missing(val))
    val <- .$data
  toJSArray(val)
}

##' method to get ID for object
##'
##' @return the ID of the object
EXTStore$asCharacter <- function(.) String('o') + .$ID + 'store'

##' which field to display. (In gcombobox)
EXTStore$displayField <- function(.) .$chosenCol

##' names of fields
##'
##' In ext "fields" are just columns. This gives  names of data
EXTStore$fieldNames <- function(.) {names(.$data)}

##' Make the javascript code to make the fields
##' 
##' for combo tihs is just an array, 
##' for a grid object it is more work
##' @return javascript string
EXTStore$makeFields <- function(.) {
  .$asJSArray(.$fieldNames())
}

##' show method for stores
##'
##' cats or queues the javascript code to show the widget
##' @param cat or queue
EXTStore$show <- function(., queue=FALSE) {
  out <- String() + "\n" +
    .$asCharacter() + '= new Ext.data.ArrayStore({' +
      'fields:  ' + .$makeFields() + ',' + '\n' +
        'data: ' + .$asJSArray() +
          '});' + '\n'
  .$Cat(out, queue=queue)
}

##' replace the store with this data
##'
##' @param data data to replace
##' @return javascript string to replace values
EXTStore$replaceStore <- function(., data) {
  if(!missing(data)) .$data <- data
  out <- String() +
    .$asCharacter() + '.removeAll();' +
      .$asCharacter() + '.loadData(' +
        .$asJSArray() + ');'
  return(out)
}
## XXX need more granular approach

## A proxy store XXX
EXTStoreWithProxy <- EXTStore$new()



##################################################
##' A proxy store will call back into the server to fetch more data.
##' We use a different handler for thes.
EXTProxyStore <- EXTStore$new()

##' initialization method for a proxy store
##'
##' A proxy store queries the server for more information. Used by
##' gbigtable and (in the future) gtree
##' @param toplevel The proxy stores are cached in the toplevel window
##' so that during the callback they can be referenced by ID.
##' @param pageSize The size of the page for a request to a data frame
##' @return a proxy store  instance
EXTProxyStore$new <- function(., toplevel=NULL, pageSize=25, ...) {
  obj <- .$proto(toplevel=toplevel, pageSize=as.numeric(pageSize))
  class(obj) <- c("gWidgetProxyStore",class(obj))
  invisible(obj)
}

##' Create javacript code to show store
##'
##' @param queue if FALSE, will cat out, otherwise queues up the javascript
##' @return NULL
EXTProxyStore$show <- function(., queue=FALSE) {
  out <- String() + "\n" +
    .$asCharacter() + '= new Ext.data.ArrayStore({' +
#    .$asCharacter() + '= new Ext.data.JsonStore({' +
#      "totalProperty: 'totalCount', root:'data'," +
      'fields:  ' + .$makeFields() + ',' + '\n' +
        'proxy: new Ext.data.HttpProxy({' +
          sprintf("url: '%s/%s/%s/%s',",  .$toplevel$..gWidgetsWWWAJAXurl,"proxystore", .$asCharacter(), .$toplevel$sessionID) +
            "method: 'POST'" +         # use POST, not GET as this makes processing easier
              "})" +
                  "})" + "\n"
  out <- out +
    sprintf("%s.getTotalCount = function() {return %s};", .$asCharacter(), nrow(.$data))
  
  .$Cat(out, queue=queue)
}

##' Parse the query and return data as json
##'
##' Very ext specific. Raise error if not correct
##' @param query a list, typically the POST variable
##' @return the data in javascript or json encoded form
EXTProxyStore$parseQuery <- function(., query) {
  df <- .$getData()
  m <- nrow(df)
  if(!is.null(query$start)) {
    ## start limit query
    start <- as.numeric(query$start); limit <- as.numeric(query$limit)
    if(m == 0 || m < start) {
      stop("Data store wrong size for request")
    } else {
      ind <- seq(start, min(m, start+limit))
      out <- toJSArray.data.frame(df[ind,,drop=FALSE]) # not .$toJSArray
#      out <- ourToJSON(df[ind,,drop=FALSE])
#      out <- sprintf("{'totalCount':'%s', 'data':%s}", nrow(df), out)
    }
  } else {
    out <- ""
  }
  return(out)
}

##' javascript code to replace data
##'
##' Adds in getTotalCount redeifintion
##' @param data Replaces data in store and updates total count. 
##' @TODO The latter is useful for arrays it may need to be moved out to a subclass
EXTProxyStore$replaceData <- function(., data) {
  out <- get("replaceData", "EXTStore")(., data)
  out <- out +
    sprintf("%s.getTotalCount = function() {return %s};", .$asCharacter(), nrow(.$data))
  out
}

### Proxy Tree Store
##' A proxy tree store
EXTProxyTreeStore <- EXTStore$new()

##' new method. Needs toplevel, like proxystore
EXTProxyTreeStore$new <- function(., toplevel=NULL, ...) {
  obj <- .$proto(toplevel=toplevel)
  class(obj) <- c("gWidgetProxyTreeStore",class(obj))
  invisible(obj)
}

##' Create javacript code to show store
##'
##' @param queue if FALSE, will cat out, otherwise queues up the javascript
##' @return NULL
EXTProxyTreeStore$show <- function(., queue=FALSE) {
  if(!exists("gWidgetsWWWAJAXurl") || is.null(gWidgetsWWWAJAXurl))
    gWidgetsWWWAJAXurl <- getOption("gWidgetsWWWAJAXurl")
  if(is.null(gWidgetsWWWAJAXurl))  {
    gWidgetsWWWAJAXurl <- "/gWidgetsWWW"
  }

  out <- String()
  
  .$Cat(out, queue=queue)
}

## tree passes in id We need to compute based on that and return a value looking like:
##     [{
##     "text": "adapter",
##     "id": "source\/adapter",
##     "cls": "folder"
## }, {
##     "text": "dd",
##     "id": "source\/dd",
##     "cls": "folder"
## }, {
##     "text": "debug.js",
##     "id": "source\/debug.js",
##     "leaf": true,
##     "cls": "file"
## }]

##' Parse the query and return data as json
##'
##' Very ext specific. Raise error if not correct
##' @param query a list, typically the POST variable
##' @return the data in javascript or json encoded form, set the ..data variable to a list

EXTProxyTreeStore$parseQuery <- function(., query) {
  df <- .$getData()
  m <- nrow(df)

  ## kludgy bit to put in icons
  si <- getStockIcons()
  hasIcon <- function(i) i %in% names(si)
  
  makeItemWithIcon <- function(base, id, leaf=FALSE,  icon="",  value) {
    sprintf('{"text":"%s","id":"%s:%s","leaf":%s, "icon":"%s"}',
            ifelse(missing(value), id, paste(id, paste(value, collapse="\t"), sep="\t")),
            base, id,
            tolower(as.character(!leaf)),
            ifelse(hasIcon(icon), si[icon], si["blank"])
            )
  }
  makeItem <- function(base, id, leaf=FALSE, value) {
    sprintf('{"text":"%s","id":"%s:%s","leaf":%s}',
            ifelse(missing(value), id, paste(id, paste(value, collapse="\t"), sep="\t")),
            base, id,
            tolower(as.character(!leaf))
            )
  }
  if(!is.null(query$node)) {
    path <- strsplit(query$node, ":")[[1]][-1]         # strip off 1
    .$..path <- path
    .$..node <- query$node
    odata <- get("..offspring.data", .)
    children <- get("..offspring",.)(path, odata)         # returns data frame: id, offspring, [icon], text
    m <- nrow(children)
    if(m == 0) {
      out <- "[]"
    } else {
      icon.FUN <- .$..icon.FUN
      if(!is.null(icon.FUN)) {
        if(is.function(icon.FUN)) {
          icons <- icon.FUN(children)
        } else {
          icons <- children[,3]
          children[[3]] <- NULL
        }
      }
      
      out <- sprintf("[%s]", paste(sapply(1:m, function(i) {
        if(is.null(icon.FUN)) {
          if(ncol(children) > 2)
            makeItem(query$node, children[i,1], children[i,2], children[i,-(1:2)])
          else
            makeItem(query$node, children[i,1], children[i,2])
        } else {
          if(ncol(children) > 2)
            makeItemWithIcon(query$node, children[i,1], children[i,2], icons[i], children[i,-(1:2)])
          else
            makeItemWithIcon(query$node, children[i,1], children[i,2], icons[i])
        }
      }), collapse=","))
    }
    out
  } else {
    out <- ""
    .$..path <- character(0)                     # the path
    .$..node <- character(0)
  }
  return(out)
}




##################################################
##' Base trait for components with stores
##' 
##' extends Component to handle a data store
EXTComponentWithStore <- EXTComponent$new()

## additional properties

## property store -- holds an EXTStore instance
EXTComponentWithStore$..store <- NULL

## methods

##' Assign Value -- clicks sends back rowindex
##' 
##' @param . self
##' @param value value, list with initial component the row number
EXTComponentWithStore$assignValue <- function(., value) {
  .$..data <- as.numeric(value[[1]])
}

##' Get value (savlue)
##'
##' @param index logical. If TRUE return index
##' @param drop logical. If TRUE drop dimensions when possible
##' @return the main value associated with the widget
EXTComponentWithStore$getValue <- function(., index=NULL, drop=NULL,...) {
  ## we store value as an index
  out <- .$..data
  values <- .$..store$data

  ## hack to make chosenCol work with combobox
  chosenCol <- getWithDefault(.$..store$chosenCol, 1)
  if(is.character(chosenCol) && !(chosenCol %in% names(values)))
    chosenCol <- 1

  if(!is.numeric(out)) {
    if(any(tmp <- out == values[,chosenCol]))
      out <- min(which(tmp))
    else
      return(out)                         # a character not in store
  }
  out <- as.numeric(out)


  
  ## no index -- return values
  if(!is.null(index) && index) {
    return(out)
  } else {

    if(is.null(drop) || drop) {
      return(values[out, chosenCol, drop=TRUE])
    } else {
      return(values[out,])
    }
  }      
}


##' getValue method for component with stores
##'
##' @returns values in store dropping __index
EXTComponentWithStore$getValues <- function(., ...) {
  tmp <- .$..store$data
  if(names(tmp)[1] == "__index")
    tmp <- tmp[,-1, drop=FALSE]
  tmp
}

##' length of items in store
##'
##' @returns length
EXTComponentWithStore$getLength <- function(.)
  length(.$getValues())

##' size of data frame
EXTComponentWithStore$.dim <- function(.) dim(.$getValues())

##' names of values in store
##'
##' @return character names
EXTComponentWithStore$getNames <- function(.)
  names(.$getValues())

## XXX names<- not defined

##' getValue
##'
##' ..data holds indices, here we can return either
EXTComponentWithStore$getValue <- function(.,index=NULL ,drop=NULL,...) {
  ## we store value as an index
  out <- .$..data
  if(!is.null(index) && index) {
    return(as.numeric(out))
  } else {
    ## depends on drop
    values <- .$getValues()
    if(is.null(drop) || drop) {
      return(values[as.numeric(out),.$..store$chosenCol,drop=TRUE])
    } else {
      return(values[as.numeric(out),])
    }
  }      
}


##' setValue in widget. Values stored are the indices that are selected
EXTComponentWithStore$setValue <- function(., index=NULL, ..., value) {
  if(.$has_local_slot("..setValue")) {
    .$..setValue(index=index, ..., value=value)
  } else{
    index <- getWithDefault(index, FALSE)
    if(index) {
      .$..data <- as.integer(value)
    } else {
      ## must match value against first column
      values <- .$getValues()[,.$..store$chosenCol,drop=TRUE]
      tmp <- unique(match(value, values))
      .$..data <- tmp[!is.na(tmp)]
    }
  }
  ## now process if shown
  if(.$has_local_slot("..shown"))
    .$addJSQueue(.$setValueJS(index=index, ...))

}

##' Synchronize the values in the R widget with the GUI
##'
##' @param . object
##' @param ... passed to serValueJS of any instance overrides
EXTComponentWithStore$setValueJS <- function(., ...) {
    if(.$has_local_slot("..setValueJS"))
      .$..setValueJS(...)
  
  ind <- sort(.$getValue(index=TRUE, drop=TRUE))
  if(length(ind) == 0 || ind[1] <= 0)
    out <- sprintf("%s.clearValue()", .$asCharacter())
  else
    out <- sprintf("%s.getSelectionModel().selectRows(%s);", .$asCharacter(), toJSON(ind-1))

  return(out)
}

##' Set values in store
##'
##' @param i index XXX not implemented
##' @param j index XXX not implemented
##' @param ... passed to setValueJS
##' @param value values to store
EXTComponentWithStore$setValues <- function(.,i,j,...,value) {
  ## XXX need to include i,j stuff
  items <- cbind("__index"=seq_len(nrow(value)), value)
  .$..store$data <- value
  if(.$has_local_slot("..shown"))
    .$addJSQueue(.$setValuesJS(...))
}

##' produce javascript to synchronize R with GUI
##'
##' @return javascript
EXTComponentWithStore$setValuesJS <- function(., ...) {
  if(exists("..setValuesJS", envir=., inherits=FALSE)) .$..setValuesJS(...)
  
  out <- String() +
    .$..store$asCharacter() + '.removeAll();' +
      .$..store$asCharacter() + '.loadData(' +
        .$asJSArray(.$..store$data) +');'

  return(out)
}

##' Write out transport value part.
##'
##' Just defines the value variable in javascript to pass back to R via _transportToR
EXTComponentWithStore$transportValue <- function(.,...) {
  ## we packed in __index so we can get the index even if we've sorted
  if(.$has_local_slot("..multiple") &&.$..multiple) {
    ## work a bit to get the value
    out <- String() +
      paste('var store = w.getStore();',
            'var selModel = w.getSelectionModel();',
            'var values = selModel.getSelections();',
            'var value = new Array();', # value is return value
            'for(var i = 0, len=values.length; i < len; i++) {',
            '  var record = values[i];',
            '  var data = record.get("__index");',
            '  value[i] = data',
            '};',
            sep="")
  } else {
    out <- String() +
      paste('var record = w.getStore().getAt(rowIndex);',
            'var value = record.get("__index");',
            sep="")
  }
  return(out)
}


##' set the size of component with store.
##'
##' @param value Can be a vector, as usual, or a list. If the latter,
##' the components width, height and columnWidths are of interest. The
##' latter to set the column widths -- in pixels -- as opposed to
##' having it determined
##' @return NULL
EXTComponentWithStore$setSize <- function(., value) {
  if(is.list(value)) {
    width <- value$width
    height <- value$height
    columnWidths <- value$columnWidths
  } else {
    width <- value[1]
    height <- value[2]
    columnWidths <- NULL
  }
  get("setSize", EXTWidget)(., c(width,height))
  if(!is.null(columnWidths))
    .$..columnWidths <- rep(columnWidths, length.out=.$getLength())

  ## Has local slot shown ...if(
}


##' visible<- is not implemented, use \code{$filter} proto instead
EXTComponentWithStore$setVisibleJS <- function(., ...) {}

##' filter is used to filter our values matching regular expression in the given column
##' @param . component with store
##' @param colname name of column to match regular expression agains
##' @param regex regular expression to match against, If empty, skip
##' @return javascript code to produce the changes is added to the
##' queue. This is called only after GUI is rendered.
EXTComponentWithStore$filter <- function(., colname, regex) {
    if(!exists("..shown",envir=., inherits=FALSE)) {
      ## "Can only filter once object is shown"
      out <- ""
    }

    if(missing(colname) || !colname %in% names(.$..store$data))  {
       ## Need colname to match one of the names of the data set
      out <- ""
    }

    ## should check for regex via ^/(.*)/$ but instead we just assume a regular expression
    if(missing(regex) || regex=="") {
      out <- sprintf("o%s.getStore().clearFilter();", .$ID)
    } else {
      out <- sprintf("o%s.getStore().filter('%s',RegExp('%s'));", .$ID, colname, regex)
    }
    .$addJSQueue(out)
  }

##' visibility
##'
##' Use filter method and initil ..inaex column to implment filtering
##' @param . self
##' @param value Logical, recycled to number of rows. TRUE for rows to display
EXTComponentWithStore$setVisible <- function(., value) {
  n <- dim(.)[1]
  value <- rep(value, length.out=n)
  .$..visible <- value                # XXX???
  inds <- which(value)
  reg <- paste("^",inds,"$", sep="", collapse="|")
  .$filter("__index", reg)
}



##' Wrapper to turn an object into an JS array
##'
##' @param ... passed to store's methods
EXTComponentWithStore$asJSArray <- function(.,...) {
  .$..store$asJSArray(...)
}

##' Show method for component.
##'
##' show needs to show store and component
##' @param queue if FALSE will cat out result otherwise queues it
##' @return NULL
EXTComponentWithStore$show <- function(., queue=FALSE) {
  .$..store$show(queue=queue)
  get("show",EXTComponent)(., queue=queue)       # call up
}

##' make the column model for display
##'
##' This creates meta information about the store needed by ext
##' @return javascript code
EXTComponentWithStore$makeColumnModel <- function(.) {
    ## return array for columns
    ## id, header, sortable, renderer, dataIndex, tooltip
##     columns: [
##               {id:'company',header: "Company", sortable: true, dataIndex: 'company'},
##               {header: "Price",  sortable: true, renderer: 'usMoney', dataIndex: 'price'},
##               {header: "Change", sortable: true, renderer: change, dataIndex: 'change'},
##               {header: "% Change", sortable: true, renderer: pctChange, dataIndex: 'pctChange'},
##               {header: "Last Updated", sortable: true, renderer: Ext.util.Format.dateRenderer('m/d/Y'), dataIndex: 'lastChange'}
##               ],

    mapRenderer <- function(type) {
      switch(type,
             "character"="",
             "String" = "",
             "integer" = ",renderer:gtableInteger",
             "numeric" = ",renderer:gtableNumeric",
             "logical" = ",renderer:gtableLogical",
             "factor" = "",
             "icon" = ",width: 16,renderer:gtableIcon",              # for icons(we create this)
             "date" = ",renderer:gtableDate",               # we create this?
             "")
    }

    df <- .$..store$data
    renderers <- sapply(df[,-1, drop=FALSE], function(i) mapRenderer(class(i)[1]))
    colNames <- names(df)[-1]           # XXX
    colNames <- shQuoteEsc(colNames)

    ## widths
    if(.$has_slot("..columnWidths")) {
      colWidths <- .$..columnWidths
    } else {
      
      fontWidth <- 10
      colWidths <- sapply(df[,-1, drop=FALSE], function(i) {
        if(length(i))
           max(nchar(as.character(i))) + 1
        else
          20
      })
      colWidths <- pmax(colWidths, nchar(names(df[,-1, drop=FALSE])) + 1)
      totalWidth <- ifelse(exists("..width", envir=., inherits=FALSE), .$..width, "auto")
      if(totalWidth == "auto" || fontWidth * sum(colWidths) > totalWidth)
        colWidths <- colWidths * fontWidth       # fontWidth pixels per character
      else
                                        #      colWidths <- floor(fontWidth * colWidths * totalWidth/sum(colWidths))
        colWidths <- colWidths * fontWidth       # fontWidth pixels per character
    }
    ## didn't work for header:
    trimDD <- function(x) {
      ind <- grep("^..", x)
      if(length(ind) > 0)
        x[ind] <- "''"
      return(x)
    }

    tmp <- paste('{',
                 'id:',colNames,
                 ', header:',colNames,
                 ', sortable:true',
                 ', width:', colWidths,
                 ', dataIndex:',colNames,
                 renderers,
                 '}',
                 sep="")
    out <- paste('[\n', paste(tmp,collapse=",\n"), ']', collapse="")

    return(out)
  }


##' Make fields for the store
##'
##' Makes javascript code to specify the fields
##' @return javascript code
EXTComponentWithStore$makeFields <- function(.) {
  ## return something like this with name, type
  ##     fields: [
  ##            {name: 'company'},
  ##            {name: 'price', type: 'float'},
  ##            {name: 'change', type: 'float'},
  ##            {name: 'pctChange', type: 'float'},
  ##            {name: 'lastChange', type: 'date', dateFormat: 'n/j h:ia'}
  ##         ]
  ## types in DataField.js
  mapTypes <- function(type) {
    switch(type,
           "character"="",
           "String" = ",type: 'string'",
           "integer" = ",type: 'int'",
           "numeric" = ",type: 'float'",
           "logical" = ",type: 'boolean'",
           "factor"  = "",
           "date" = ",type:date",
           "")
  }
  df <- .$..store$data
  types <- sapply(df[,-1, drop=FALSE], function(i) mapTypes(class(i)[1]))
  colNames <- shQuoteEsc(names(df)[-1])
  tmp <- paste("{name:", colNames, types, "}", sep="")
  out <- paste("[",tmp,"]", collapse="\n")
  
  return(out)
}

##' Property. Transport signal -- when to send back info
##' This does cell click (for gtable, gbigtable) 
EXTComponentWithStore$transportSignal <- c("cellclick")

##' method to transport values back to R
##'
##' Javascript to get value from widget passes back to R session
##' @param ... ignored
##' @return javascript string
EXTComponentWithStore$transportValue <- function(.,...) {
    ## we packed in __index so we can get the index even if we've sorted
    if(.$..multiple) {
       ## work a bit to get the value
       out <- String() +
         'var store = w.getStore();' +
           'var selModel = w.getSelectionModel();' +
             'var values = selModel.getSelections();' +
               'var value = new Array();' +
                 'for(var i = 0, len=values.length; i < len; i++) {' +
                   'var record = values[i];' +
                     'var data = record.get("__index");' +
                         'value[i] = data' +
                           '};'
     } else {
       out <- String() +
         'var record = w.getStore().getAt(rowIndex);' +
           'var value = record.get("__index");' 
     }
    return(out)
  }

##' method to add a click handler
##'
##' @param handler a gWidgets type handler
##' @param action passed to handler
##' @param ... ignored
##' @return code to add handler
EXTComponentWithStore$addHandlerClicked <- function(.,handler, action=NULL, ...) {
  ## we need to set up some stuff
  .$addHandler(signal="cellclick",
               handler = handler,
               action = action,
               handlerArguments = "grid, rowIndex, colIndex, e",
               handlerValue = "var value = rowIndex + 1;"
               )
}

##' Method to add double click handler
##'
##' @param handler a gWidgets type handler
##' @param action passed to handler
##' @param ... ignored
##' @return code to add handler
EXTComponentWithStore$addHandlerDoubleclick  <- function(.,handler, action=NULL, ...) {
  ## we need to set up some stuff
  .$addHandler(signal="dblclick",
               handler = handler,
               action = action,
               handlerArguments = "grid, rowIndex, colIndex, e",
               handlerValue = "var value = rowIndex + 1;")
}
 
  
##################################################
  
##' Sub Trait for gdf -- allows editing
EXTComponentDfStore <- EXTComponentWithStore$new()


##' set values in store; ([<-)
##'
##' @param i row index
##' @param j column index
##' @param ... ignored
##' @param value value to set
##' @return sets the values in the store and if needed add javascript to queue
EXTComponentDfStore$setValues <- function(., i, j, ..., value) {

  if(missing(i))  i <- seq_len(nrow(.$..store$data))
  if(missing(j))  j <- seq_len(ncol(.$..store$data))

  d <- .$..store$getData()
  d[i,j] <- value
  .$..store$setData(d)
  if(exists("..shown", envir=., inherits=FALSE)) {
    .$addJSQueue(.$setValuesJS(i,j,value=value))
  }
}

##' write java script to set the values
##'
##' Called by setValues method to write out javascript
##' @param i row index
##' @param j column index
##' @param value value to set
##' @return javascript code is queued up
EXTComponentDfStore$setValuesJS <- function(., i,j,..., value) {
  if(missing(i) && missing(j)) {
    .$..store$replaceStore()
    return()
  }
  ## make value have i,j
  if(!is.matrix(value) || !is.data.frame(value))
    value <- data.frame(value=value, stringsAsFactors=FALSE)
  
  ## set i,j elements of store
  ## get record (getAt)
  ## set record by column name
  ## commit record
  out <- String() + "\n"
  for(row in seq_along(i)) {
    out <- out + sprintf("rec = %s.getAt(%s);", .$..store$asCharacter(), i[row] - 1)
    for(col in seq_along(j)) {
      out <- out + sprintf("rec.set('%s', '%s');", names(.)[j[col]], escapeQuotes(value[row,col]))
    }
    out <- out + "rec.commit();" + "\n"
  }

  .$addJSQueue(out)
}
  

##################################################

##' Extend ComponentWithStore to handl proxy stores
EXTComponentWithProxyStore <- EXTComponentWithStore$new()

##' property store -- holds an EXTStore instance
EXTComponentWithProxyStore$..store <- NULL

##' show method for Proxy stores
##'
##' Adds a call to load method of show
EXTComponentWithProxyStore$show <- function(., queue=FALSE) {
  .$..store$show(queue=queue)
  get("show",EXTComponentWithStore)(., queue=queue)       # call up
  .$Cat(sprintf("%s.load({params:{start:0, limit:%s}});",
                .$..store$asCharacter(), .$..store$pageSize),
        queue=queue)
}

## Tree STore
##' Extend ComponentWithStore to handl proxy stores
EXTComponentWithProxyTreeStore <- EXTComponentWithStore$new()

##' property store -- holds an EXTStore instance
EXTComponentWithProxyTreeStore$..store <- NULL

##' show method for Proxy stores
##'
##' Adds a call to load method of show
EXTComponentWithProxyTreeStore$show <- function(., queue=FALSE) {
  .$..store$show(queue=queue)
  get("show",EXTComponentWithStore)(., queue=queue)       # call up
  .$Cat(sprintf("",""), queue=queue)
}

##' method to add a click handler
##'
##' @param handler a gWidgets type handler
##' @param action passed to handler
##' @param ... ignored
##' @return code to add handler
EXTComponentWithProxyTreeStore$addHandlerClicked <- function(.,handler, action=NULL, ...) {
  ## we need to set up some stuff
  .$addHandler(signal="click",
               handler = handler,
               action = action,
               handlerArguments = "node, e",
               handlerValue = "var value = node.id;"
               )
}

##' Method to add double click handler
##'
##' @param handler a gWidgets type handler
##' @param action passed to handler
##' @param ... ignored
##' @return code to add handler
EXTComponentWithProxyTreeStore$addHandlerDoubleclick  <- function(.,handler, action=NULL, ...) {
  ## we need to set up some stuff
  .$addHandler(signal="dblclick",
               handler = handler,
               action = action,
               handlerArguments = "node, e",
               handlerValue = "var value = node.id;")
}
 

### Components in  a panel ##################################################

### Some widgets render better in a panel
## This overrides the writeConstructor method to show the object
## in ExtStdCfgOptions use an xtype and override renderTo with NULL
## see gcheckbox for an example

##' Base trait for a component in a panel container. Used for some widgets to render better.
EXTComponentInPanel <- EXTComponent$new()

##' get item ID
##'
##' Different from asCharacter call, as that is ID of panel not component
##' @return character ID of item 
EXTComponentInPanel$getItemID <- function(.) String(.$ID) + 'item'

##' override of writeConstructor method, called by show
##' @return javascript code to write out the constructor
EXTComponentInPanel$writeConstructor <- function(.) {
  lst <- list(id = as.character(.$ID),
              xtype = "panel",
              layout = "fit",
              border = FALSE,
              hideBorders = TRUE,
              width = ifelse(exists("..width", ., inherits=FALSE),
                .$..width,"auto"),
              renderTo = String(.$toplevel$..renderTo), #String("Ext.getBody()"),
              items = String("[") + .$mapRtoObjectLiteral() + ']'
              )
  out <- String() + "\n" +
    'o' + .$ID + 'panel = new Ext.Panel(' + # no var -- global
      .$mapRtoObjectLiteral(lst) +
        ');' + '\n'

 if(!.$has_local_slot('..shown') && (.$has_local_slot("x.hidden") && .$x.hidden))  
   out <- out +
     sprintf("%s.addClass('x-hidden');\n", .$asCharacter())
  
  ## get component from first child object
  out <- out +
    'o' + .$ID + ' = ' +                # no var -- global
      'o' + .$ID + 'panel.getComponent("' + .$getItemID() + '");' + '\n'
  return(out)
}

##' Base trait for a component with items like gradio and gcheckboxgroup
##' 
##' we use a panel and use the items to store the values
##' the handlers need to be assigned to each 
EXTComponentWithItems <- EXTComponent$new()

##' propoerty xtype property,
EXTComponentWithItems$xtype <- ""       # eg "checkbox", "radio"
##' property itemname
EXTComponentWithItems$itemname <- "item"
##' property Which ext constructor to use
EXTComponentWithItems$ExtConstructor <- "Ext.Panel"
## ##' property. The x.hidden property, when TRUE, will first hide widget
EXTComponentWithItems$x.hidden <- FALSE

##' assign value
EXTComponentWithItems$assignValue <- function(., value) {
  svalue(., index=NULL) <- value[[1]]
}



##' Is i checked
##'
##' @return logical indicating if item i is checked
EXTComponentWithItems$checked <- function(.,i) {
  ## return TRUE if checked o/w false
}
##' Make the items for display. Called by show method
##'
##' @return javascript code to make the items
EXTComponentWithItems$makeItems <- function(.) {
  out <- String()
  
  values <- .$getValues()
  if((n <- length(values)) < 2)  return(out)
    
  tmp <- list()                          # store items as String
  for(i in 1:n) {
    lst <- list(xtype = .$xtype,
                name = as.character(String() + .$ID + .$itemname),
                boxLabel = as.character(values[i]),
                checked = .$checked(i)
                )
    tmp[[i]] <- .$mapRtoObjectLiteral(lst)
  }

  out <- out +
    '[' + paste(tmp,collapse=",") + ']'
  
  return(out)
}

##' Write out javascript handlers.
##'
##' Must add to each item, not just one
##' @return javascript code
EXTComponentWithItems$writeHandlersJS <- function(.) {
  if(exists("..handlers", envir=., inherits=FALSE))
    allHandlers <- .$..handlers
  else
    allHandlers <- list()

  ## get all signals
  signals <- c()
  if(!is.null(.$transportSignal))
    signals <- .$transportSignal
  if(length(allHandlers) > 0)
    signals <- union(signals, names(allHandlers))

  if(length(signals) == 0) return(String(""))     # nothing to do
  
  out <- String()
  for(sig in signals) {
    for(i in 1:(n <- length(.))) {
      out <- out +
        paste(sprintf("var widget = %s.getComponent(%s);",.$asCharacter(), as.character(i-1)),
              sprintf("widget.on('%s', function(%s) {%s}, this, {delay:1, buffer:1, single:false});",
                      sig,
                      .$handlerArguments(sig),
                      ifelse(!is.null(.$transportSignal) && sig %in% .$transportSignal,
                             .$writeTransport(ext = shQuote(i), signal=sig),
                             "")
                      ),
              sep="")
      ## out <- out +
      ##   'var widget = ' + .$asCharacter() + '.getComponent(' +
      ##     as.character(i - 1) + ');' +
      ##       'widget.on(' +
      ##         ## XXX transport args needs to be siganl dependent!!
      ##         shQuote(sig) + ','  +
      ##           'function(' + .$handlerArguments(sig) + ') {\n'

      ## ## write out transport if necessary
      ## ## XXX code to pass values createDelegate ....
      ## if(!is.null(.$transportSignal) && sig %in% .$transportSignal) {
      ##   out <- out + .$writeTransport(ext = shQuote(i), signal=sig) # ## pass this in
      ## }
      ## out <- out +'}' +
      ##   ',this, {delay:1,buffer:1, single:false});' + '\n'
      

      ## write out handler if needed
      if(!is.null(allHandlers[[sig]])) {
        handler <- allHandlers[[sig]]
        out <- out +
          paste(sprintf("var widget = %s.getComponent(%s);", .$asCharacter(), as.character(i-1)),
#                sprintf("widget.on('%s', function(%s) {%s}, this, {delay:1, buffer:1, single:false});",
                sprintf("widget.on('%s', %s, this, {delay:1, buffer:1, single:false});",
                        sig,
                        .$writeHandlerFunction(signal=sig, handler=handler)),
                sep="")
##           'var widget = ' + .$asCharacter() + '.getComponent(' + as.character(i - 1) + ');' +
##             'widget.on(' +
##             ## XXX transport args needs to be siganl dependent!!
##             shQuote(sig) + ',' +
## #              'function(' + .$handlerArguments(sig) + ') {\n' +
##                 .$writeHandlerFunction(signal=sig, handler=handler) +
##                   '\n'
##         ##           'runHandlerJS(' + handler$handlerID  +
##         ##             handler$handlerExtraParameters + ');' + '\n' +
##         ##               'true;' + '\n'
##         out <- out +
## #          '}' +
##             ',this, {delay:100,buffer:100, single:false});' + '\n'
      }
    }
  }

  return(out)
}






##############################
## gwidget methods

##' Generic to get primary value for widget
svalue <- function(obj,index=NULL, drop=NULL,...) UseMethod("svalue")


##' gWidget implementation of svalue method
##'
##' Calls getValue method
svalue.gWidget <- function(obj,index=NULL, drop=NULL,...) {
  obj$getValue(index=index,drop=drop,...)
}

##' Generic to set primary value for a widget
"svalue<-" <- function(obj,index=NULL, ...,value) UseMethod("svalue<-")

##' gWidget class implementation
##'
##' Calls setValue method
"svalue<-.gWidget" <- function(obj,index=NULL, ..., value) {
  obj$setValue(index=index,..., value=value)
  return(obj)
}

##' add is used by gtext atleast. $add implicitly used by contaienrs
"add" <- function(obj,value,...) UseMethod("add")

##' gWidget lcass add method.
##'
##' Calls add method
"add.gWidget" <- function(obj, value, ...) {
  if(exists("add",envir=obj, inherits=TRUE))
    obj$add(child=value,...)
}

## delete removes add -- in this case we hide
"delete" <- function(obj, widget, ...) UseMethod("delete")
delete.gWidget <- function(obj, widget, ...) {
  if(exists("delete",envir=obj, inherits=TRUE))
    obj$delete(widget,...)
}
  

## insert is new name for add for gtext
"insert" <- function(obj, value, where = c("end","beginning","at.cursor"),
                     font.attr = NULL,
                     do.newline = TRUE, ...) UseMethod("insert")
"insert.gWidget" <- function(obj, value, where = c("end","beginning","at.cursor"),
                             font.attr = NULL,
                             do.newline = TRUE, ...) {
  where = match.arg(where)
  add(obj, value, where=where, font.attr=font.attr, do.newline=do.newline,...)
}
                       

## toggle whether widget can receive input
"enabled" <- function(obj) UseMethod("enabled")
"enabled.gWidget" <- function(obj) {
  . <- obj
  if(exists("..enabled", envir=., inherits =FALSE))
    return(.$..enabled)
  else
    return(TRUE)
}
"enabled<-" <- function(obj,...,value) UseMethod("enabled<-")
"enabled<-.gWidget" <- function(obj,..., value) {
  . <- obj
  .$setEnabled(value)

  obj
}


## dispose of widget. We simply hide it here
## no method until created
"dispose" <- function(obj,...) UseMethod("dispose")
"dispose.gWidget" <- function(obj,...) {
  . = obj

  if(exists("dispose", envir=.)) {
    .$dispose()
  } else if(exists("..shown",envir=., inherits=FALSE)) {
    .$addJSQueue(.$callExtMethod("hide"))
  }
}

 ## focus
"focus<-" <- function(obj,...,value) UseMethod("focus<-")
"focus<-.gWidget" <- function(obj,..., value) {
  . = obj
  value <- as.logical(value)
  ## set ..focus attribute -- not implemented
  if(value) .$..focus <- TRUE
  
  if(exists("..shown",envir=., inherits=FALSE) && value)
    .$addJSQueue(.$callExtMethod("focus",tolower(as.character(value))))

  return(obj)
}

## tag
tag <- function(obj, key, ...) UseMethod("tag")
tag.gWidget <- function(obj, key, ...)  {
  attr(obj, key)
}
"tag<-" <- function(obj, key,...,value) UseMethod("tag<-")
"tag<-.gWidget" <- function(obj, key, ..., value) {
  attr(obj, key) <- value
  obj
}

## id
id <- function(obj, ...) UseMethod("id")
id.gWidget <- function(obj, ...) obj$asCharacter()

## visible, visible<-
visible <- function(obj) UseMethod("visible")
visible.gWidget <- function(obj) obj$getVisible()
"visible<-" <- function(obj,...,value) UseMethod("visible<-")
"visible<-.gWidget" <- function(obj,..., value) {
  obj$setVisible(value)
  return(obj)
}



"[.gWidget" <- function(x,i,j,drop = TRUE) {
##  if (missing(i)) TRUE else length(cols) == 1) {
  . = x
  values <- .$getValues()
  
  if(missing(i)) {
    if(is.null(dim(values)))
      return(values)
    else if(missing(j))
      return(values[,,drop=drop])
    else
      return(values[,j,drop=drop])
  } else {
    if(is.null(dim(values)))
      return(values[i])
    else if(missing(j))
      return(values[i,,drop=drop])
    else
      return(values[i,j,drop=drop])
  }
}

"[<-.gWidget" <- function(x,i,j,...,value) {
  . = x
  if(missing(i) && missing(j))
    .$setValues(..., value=value)
  else if(missing(i))
    .$setValues(j =j,..., value=value)
  else if(missing(j))
    .$setValues(i = i,..., value=value)
  else
    .$setValues(i = i, j =j,..., value=value)
  return(x)
 }

## names
"names.gWidget" <- function(x) {
  . <-  x
  .$getNames()
}
"names<-.gWidget" <- function(x, value) {
  . = x
  .$setNames(value)
  return(x)
}


## size of widget
"size" <- function(obj) UseMethod("size")
"size.gWidget" <- function(obj) {
  obj$getSize()
}
"size<-" <- function(obj,value) UseMethod("size<-")
"size<-.gWidget" <- function(obj,value) {
  obj$setSize(value)
  return(obj)
}

## set font -- use stylesheet
## eg:
## font(l) <- c("font-family"="Verdana, Arial, Helvetica, sans-serif",
## 	   "font-size" = "large",
## 	   "font-style" = "italic",
## 	   "font-weight" = "bold")
## cf: http://www.yourhtmlsource.com/stylesheets/csstext.html
"font<-" <- function(obj,value) UseMethod("font<-")
"font<-.gWidget" <- function(obj,value) {
  . <- obj
  ## gWidgets names are family, size, style, weigth, ala X11
  changeThese <- c("family","size","style","weight")
  
  vals <- intersect(names(value), changeThese)
  for(i in vals)
    names(value)[which(names(value) == i)] <- paste("font-",i,sep="")

  if(!exists("..style",envir=., inherits=FALSE))
    .$..style <- value
  else
    .$..style <- c(.$..style,value)
  
  if(exists("..shown",., inherits=FALSE)) {
    .$addJSQueue(.$setStyleJS())
   }
  
  return(obj)
}

## we use print for gwindow and gsubwindow as a more natural alias
## than $Show() i.e. after storing objects into the toplevel window or
## its subwindos, we need to be able to show the contents to the
## brower. This is done with the proto method $#Show(), which here is
## aliased to theprint method of the proto objects.
print.gWindow <- print.gSubwindow <- function(x,...) {
  . = x;
  .$Show()
}
  


## Method to set a tooltip on an object
## if isURL(value) == TRUE, then loads from website
## value can be a list with title, message or just a message
"tooltip<-" <- function(obj,value) UseMethod("tooltip<-")
"tooltip<-.gWidget" <- function(obj,value) {
  if(isURL(value)) {
    obj$..tooltip <- value
  } else {
    obj$..tooltip <- value
  }
  return(obj)
}

## addSpring and addSpace are used to align children within the group
## containers. These are not defined, but should be in ggroup.R
addSpace <- function(obj, value, horizontal=TRUE, ...) UseMethod("addSpace")
addSpace.gWidget <- function(obj, value, horizontal=TRUE, ...) 
  obj$addSpace(value, horizontal = horizontal, ...)

addSpring <- function(obj, ...) UseMethod("addSpring")
addSpring.gWidget <- function(obj,  ...) 
  obj$addSpring(...)



## DND -- XXX not defined
addDropSource <- function(obj, targetType = "text", handler = NULL, action = NULL, ...) UseMethod("addDropSource")
addDropMotion <- function(obj, handler = NULL, action = NULL, ...) UseMethod("addDropMotion")
addDropTarget <- function(obj, targetType = "text", handler = NULL, action = NULL,  ...) UseMethod("addDropTarget")


## always true, but gWidgets methods
isExtant <- function(x,...) UseMethod("isExtant")
isExtant.gWidget <- function(x,...) TRUE


blockHandler <- function(obj, ID=NULL, ...) UseMethod("blockHandler")
blockHandler.gWidget <- function(obj, ID=NULL, ...) {
  w <- obj$toplevel
  if(is.null(ID))
    ID <- seq_along(w$jscriptHandlers)
  ID <- as.numeric(ID)
  w$..blocked_handlers <- unique(c(w$..blocked_handlers, ID))
}

unblockHandler <- function(obj, ID=NULL,...) UseMethod("unblockHandler")
unblockHandler.gWidget <- function(obj, ID=NULL, ...) {
  w <- obj$toplevel  
  if(is.null(ID)) {
    w$..blocked_handlers <- c()
  } else {
    ID <- as.numeric(ID)
    if(ID %in% w$..blocked_handlers)
      w$..blocked_handlers <- unique(setdiff(w$..blocked_handlers, ID))
  }
}



##################################################
## Javascript handlers -- not submit handlers for buttons etc.


## Handler code

## code to run a handler.
## This must be exported.
## Called from www page
## worry about scope!! XXX -- doesn't seem to work

## XXX replaces by runHandler in proto gwindow object
runHandler <- function(obj, id, context) {
  obj <- get(obj, envir = .GlobalEnv)
  lst <- obj$jscriptHandlers[[as.numeric(id)]]
  h <- list(obj=lst$obj, action = lst$action)
  if(!missing(context) && context != "") {
    ## context is a list passed in through a JSON object converted into a list
    ## we pass this list into h object as context
    h$context <- context
  }
  return(lst$handler(h))
}



##' the Javascript queue
##'
##' When a handler is called there are two parts: one internal to the
##' R session, one to create javascript to output to the browser. This
##' queue stores the latter. Depending on how gWidgetsWWW is run it
##' either returns a string (help server) qor cats out a string
##' (RApache)

##' Add string to current queue
##' @param . EXTWidget
##' @param x code from xxxJS (setValueJS, ...), String() class
##' @return void
EXTWidget$addJSQueue <- function(., x) {
  parent <- .$toplevel
  curQueue <- parent$JSQueue
  if(length(curQueue) == 0)
    curQueue <- x
  else
    curQueue <- c(curQueue, x)
  parent$JSQueue <- curQueue
}

##' run the queue. Called by gwindow::runHandler, and by hanging event (ala r-studio)
##'
##' @param . EXTWidget
##' @return clears queue, then returns string with handler's output pasted together
EXTWidget$runJSQueue <- function(.) {
  parent <- .$toplevel
  curQueue <- parent$JSQueue
  if(is.null(curQueue))
    out <- ""
  else
    out <- paste(curQueue, collapse="\n")
  
  parent$JSQueue <- character(0)        # clear queue
  return(out)
}

  


## code to write out JS for the handlers on a object
## tricky part is that handlers must also be called for
## transport signals

## can override this per widget if desired!
## These were cherry picked from the Ext docs. Some may be missing,
## many are only available through the addHandler() method.

EXTWidget$handlerArgumentsList <-
  list(afteredit = "e",                 # for gdf cell editing
       blur="w",                        # w = "this"
       bodyresize = "w, width, height",
       bodyscroll = "scrollLeft, scrollRight",
       cellcontextmenu = "w, rowIndex, cellIndex, e",
       cellclick = "w, rowIndex, columnIndex, e", # grid
       celldblclick = "w, rowIndex, columnIndex, e", # grid
       cellmousedown = "w, rowIndex, columnIndex, e", # grid
       change="w, newValue, oldValue", beforechange = "w, newValue, oldValue",
       check = "w, checked",
       collapse = "w",                  # combobox
       columnmove = "oldIndex, newIndex",
       columnresize = "columnIndex, newSize",
       dblclick = "e",                  # grid -- not celldblclick
       destroy="w", beforedestroy = "w",
       disable="w",
       drag = "w, e", dragend = "w,e", dragstart = "w,e",
       enable = "w",
       expand = "w",                    # combobox
       fileselected = "w, s",               # FileUploadField
       focus = "w",
       headerclick = "w, columnIndex, e", # grid
       headercontextmenu = "w, columnIndex, e", # grid
       headerdblclick = "w, columnIndex, e", # grid
       headermousedown = "w, columnIndex, e", # grid       
       hide = "w", beforehide = "w",
       invalid = "w",
       keydown = "w,e",                 # e Ext.EventObject
       keypress = "w,e",
       keyup = "w,e",
       mousedown = "e",
       mouseover = "e", 
       mousemove = "e", 
       move = "w, x, y",
       render = "w", beforerender = "w",
       resize = "w, adjWidth, adjHeight, rawWidth, rawHeight",
       rowclick = "w, rowIndex, e", # grid
       rowcontextmenu = "w, rowIndex, e", # grid
       rowdblclick = "w, rowIndex, e", # grid
       rowmousedown = "w, rowIndex, e", # grid       
       select = "w,record,index", beforeselect = "w, record, index",
       selectionchange = "selModel",    # gcheckboxgrouptable
       show = "w", beforeshow = "w", 
       specialkey = "w, e",
       toggle = "w, value",             # gtogglebutton
       valid = "w")

##' process the list above allowing for local overrides                                       
EXTWidget$handlerArguments <- function(.,signal) {
  out <- .$handlerArgumentsList
  if(exists("..handlerArgumentsList", envir=., inherits = FALSE)) {
    for(i in names(.$..handlerlArgumentsList))
      out[[i]] <- .$..handlerlArgumentsList[[i]]
  }
  val <- ifelse(is.null(out[[signal]]), "", out[[signal]])
  return(val)
}

##' Write the handler part of the call function(...) (define_value;runHandlerJS(...))
##'
##' No trailing ; after function(...) {...}
##' @param . self
##' @param signal signal for handler to be called on.
##' @param handler handler list, prepared elsewhere
EXTWidget$writeHandlerFunction <- function(., signal, handler) {

  out <- String() +
    sprintf("function(%s) {runHandlerJS(%s%s);}",
            .$handlerArguments(signal),
            handler$handlerID,
            ifelse(!is.null(handler$handlerExtraParameters),
                   paste(",", handler$handlerExtraParameters, sep=""),
                   "")
            )

  out <- out + "\n"
  ## out <- String() +
  ##   'function(' + .$handlerArguments(signal) + ') {'  +
  ##     'runHandlerJS(' + handler$handlerID
  ## if(!is.null(handler$handlerExtraParameters)) {
  ##   out <- out + "," + handler$handlerExtraParameters
  ## }
  ## out <- out + ');' +  '}' + '\n'
  return(out)
}





## write out a single handler passed as a list
## the special case signal=idle is different
EXTWidget$writeHandlerJS <- function(.,signal="",handler=NULL) {
  if(is.null(signal))                   # errors?
    return()
  out <- String()
  if(signal == "idle") {
    out <- out +
      sprintf("setInterval(function() {runHandlerJS(%s%s)}, %s)\n",
              handler$handlerID,
              ifelse(!is.null(handler$handlerExtraParameters),
                     paste(",", handler$handlerExtraParameters, sep=""),
                     ""),
              handler$handlerArguments                     # duration
              )

    ## out <- out +
    ##   'setInterval(function() {' +
    ##     'runHandlerJS(' + handler$handlerID
    ## if(!is.null(handler$handlerExtraParameters))
    ##   out <- out + "," + handler$handlerExtraParameters
    ## out <- out +
    ##   ');' +
    ##     '},' + handler$handlerArguments + ');' + '\n'
  } else {
    
    ## write out transport if necessary
    ## XXX code to pass values createDelegate ....
    if(!is.null(.$transportSignal) && signal %in% .$transportSignal) {
      out <- out +
        sprintf("%s.on('%s', function(%s) {%s}, this, {delay:1, buffer:1, single:false});\n",
                .$asCharacter(),
                signal,
                .$handlerArguments(signal),
                .$writeTransport(signal=signal))
        
        ## 'o' + .$ID + '.on(' +
        ##   ## XXX transport args needs to be siganl dependent!!
        ##   shQuote(signal) + ', ' +
        ##     'function(' + .$handlerArguments(signal) + ') {\n' +
        ##       .$writeTransport(signal = signal) +
        ##         '}' +
        ##           ',this, {delay:1,buffer:1, single:false});' + '\n'
    }

    
    ## write out handler if needed
    if(!is.null(handler)) {
      out <- out +
        sprintf("%s.on('%s', %s, this, {delay:100, buffer:100, single:false});\n",
                .$asCharacter(),
                signal,
                .$writeHandlerFunction(signal=signal, handler=handler) ## includes function() {}
                )
##         'o' + .$ID + '.on(' +
##           ## XXX transport args needs to be siganl dependent!!
##           shQuote(signal) + ',' +
##             .$writeHandlerFunction(signal=signal, handler=handler) +
## ',this, {delay:100,buffer:100, single:false});' + '\n'

    }
#  
#    out <- out +
#      '},this, {delay:100,buffer:100, single:false});' + '\n'
  }

  return(out)
}

##' Loops to write out all handlers
EXTWidget$writeHandlersJS <- function(.) {
  if(exists("..handlers", envir=., inherits=FALSE))
    allHandlers <- .$..handlers
  else
    allHandlers <- list()

  ## get all signals
  signals <- c()
  if(!is.null(.$transportSignal))
    signals <- .$transportSignal
  if(length(allHandlers) > 0)
    signals <- union(signals, names(allHandlers))

  if(length(signals) == 0) return(String(""))     # nothing to do
  
  out <- String()
  for(sig in signals) {
    out <- out + .$writeHandlerJS(sig, allHandlers[[sig]])
  }

  return(out)
}
      
## handlerExtraParameters is NULL or a JSON string to evaluate to a list
## it is passed into the handler in the $context component
EXTWidget$addHandler <- function(., signal, handler, action=NULL,
                                 handlerArguments="w",
                                 handlerExtraParameters=NULL,
                                 handlerValue = NULL,
                                 ...
                                 ) {

  lst <- list(obj = .,
              signal=signal,
              handler=handler,
              action=action,
              scope = parent.frame(),
              handlerArguments = handlerArguments, # eg "widget,evt"
              handlerExtraParameters = handlerExtraParameters, # eg ", Ext.util.JSON.encode({keypress:evt.getKey()})"
              handlerValue = handlerValue,                      # eg "var value = rowIndex -1" for GridPanel instances
              args = list(...)
              )

  ## we put handlers into parent widget
  ## regardless of whether we have shown the object or not
  parent <- .$toplevel
  curHandlers <- parent$jscriptHandlers
  n <- length(curHandlers)
  lst$handlerID <- n + 1
  if(n > 0) {
    parent$jscriptHandlers[[n+1]] <- lst
  } else {
    parent$jscriptHandlers <- list(lst)
  }
  
  ## add handler to list of handlers in object
  if(!is.null(signal)) {
    if(exists("..handlers", envir=., inherits = FALSE))
      curHandlers <- .$..handlers
    else
      curHandlers <- list()
    ## add handler
    curHandlers[[signal]] <- lst
    ## add back to object
    .$..handlers <- curHandlers
  }

  
  ## there are, as with other cases, two states
  ## if widget is not shown, then we
  ## a) add handler to parent so that it cna be written out.
  ## b) the actual handler code will be written out in gwindow
  ## If the widget is shown, then we need to
  ## a) store the handler in the global variable w$titlename
  ## b) write out the Javascript to
  ##    1) set the transport function (if necessary)
  ##    2) write the handler

  if(exists("..shown", envir=., inherits = FALSE)) {
    ## need to write out the JS to show the handler
    ## cat(.$writeHandlerJS(signal, lst))          # a single handler
    out <- .$writeHandlerJS(signal, lst)
    .$addJSQueue(out)
    ##cat(out)
  }
    
  ## we return the ID
  return(invisible(lst$handlerID))
}

"addHandler" <- function(obj,signal, handler, action=NULL,...)
  UseMethod("addHandler")
addHandler.gWidget <- function(obj,signal,handler, action=NULL,...)
  obj$addHandler(signal, handler, action,...)


## instances
## addHandlerBlur
EXTWidget$addHandlerBlur <- function(., handler, action=NULL) {
  .$addHandler(signal="blur",handler, action)
 }

"addHandlerBlur" <- function(obj, handler, action=NULL)
  UseMethod("addHandlerBlur")
addHandlerBlur.gWidget <- function(obj,handler, action=NULL)
  obj$addHandlerBlur(handler, action)


## addHandlerChanged
EXTWidget$addHandlerChanged <- function(., handler, action=NULL) {
  .$addHandler(signal="change",handler, action)
}

"addHandlerChanged" <- function(obj, handler, action=NULL)
  UseMethod("addHandlerChanged")
addHandlerChanged.gWidget <- function(obj,handler, action=NULL)
  obj$addHandlerChanged(handler, action)

## addHandlerClicked
EXTWidget$addHandlerClicked <- function(., handler, action=NULL) {
  .$addHandler(signal="click",handler, action)
}

"addHandlerClicked" <- function(obj, handler, action=NULL)
  UseMethod("addHandlerClicked")
addHandlerClicked.gWidget <- function(obj,handler, action=NULL)
  obj$addHandlerClicked(handler, action)

## addHandlerDoubleclick
EXTWidget$addHandlerDoubleclick <- function(., handler, action=NULL) {
  .$addHandler(signal="dblclick",handler, action)
}

"addHandlerDoubleclick" <- function(obj, handler, action=NULL)
  UseMethod("addHandlerDoubleclick")
addHandlerDoubleclick.gWidget <- function(obj,handler, action=NULL)
  obj$addHandlerDoubleclick(handler, action)


## addHandlerMouseclick
EXTWidget$addHandlerMouseclick <- function(., handler, action=NULL) {
  .$addHandler(signal="mousedown",handler, action,
               handlerArguments="e",
               handlerExtraParameters = "Ext.util.JSON.encode({xy:[e.layerX,e.layerY]})"
               )
  
}

"addHandlerMouseclick" <- function(obj, handler, action=NULL)
  UseMethod("addHandlerMouseclick")
addHandlerMouseclick.gWidget <- function(obj,handler, action=NULL)
  obj$addHandlerMouseclick(handler, action)

## addHandlerKeystroke
## key passed in is ASCII code.
EXTWidget$addHandlerKeystroke <- function(., handler, action=NULL,...) {
  .$addHandler(signal="keydown",handler, action,
               handlerArguments="b,e",
               handlerExtraParameters = "Ext.util.JSON.encode({key: e.getKey()})",
               ...
               )
}

## This handler shows how we can pass in extra information to the handler and then
## use this by writing a custom writeHandlerFunction.
## For EXTComponentText we do so to handle the key events as doing so by calling back into
## R each time is too expensive.
## Here *if* we pass either key (which should be of the form "A" or "a", but likely won't work unless
## it is of the form "e.ENTER, or
## BACKSPACE:8,TAB:9,NUM_CENTER:12,ENTER:13,RETURN:13,SHIFT:16,CTRL:17,CONTROL:17,ALT:18,PAUSE:19,CAPS_LOCK:20,ESC:27,SPACE:32,PAGE_UP:33,PAGEUP:33,PAGE_DOWN:34,PAGEDOWN:34,END:35,HOME:36,LEFT:37,UP:38,RIGHT:39,DOWN:40,PRINT_SCREEN:44,INSERT:45,DELETE:46,ZERO:48,ONE:49,TWO:50,THREE:51,FOUR:52,FIVE:53,SIX:54,SEVEN:55,EIGHT:56,NINE:57,A:65,B:66,C:67,D:68,E:69,F:70,G:71,H:72,I:73,J:74,K:75,L:76,M:77,N:78,O:79,P:80,Q:81,R:82,S:83,T:84,U:85,V:86,W:87,X:88,Y:89,Z:90,CONTEXT_MENU:93,NUM_ZERO:96,NUM_ONE:97,NUM_TWO:98,NUM_THREE:99,NUM_FOUR:100,NUM_FIVE:101,NUM_SIX:102,NUM_SEVEN:103,NUM_EIGHT:104,NUM_NINE:105,NUM_MULTIPLY:106,NUM_PLUS:107,NUM_MINUS)
## or charCode which can be a numeric value, eg ENTER = 13, then before running the handler, in javasscript land a check will be made. It seems that Ctrl+Enter, say, is not detected as such.


"addHandlerKeystroke" <- function(obj, handler, action=NULL,key=NULL, charCode=NULL, ...)
   UseMethod("addHandlerKeystroke")
 addHandlerKeystroke.gWidget <- function(obj, handler, action=NULL, key=NULL, charCode=NULL, ...)
   obj$addHandlerKeystroke(handler, action, key=key, charCode=charCode, ...)

 ## addHandlerSelect
 EXTWidget$addHandlerSelect <- function(., handler, action=NULL) {
   .$addHandler(signal="onselect",handler, action)
 }

 "addHandlerSelect" <- function(obj, handler, action=NULL)
   UseMethod("addHandlerSelect")
 addHandlerSelect.gWidget <- function(obj,handler, action=NULL)
   obj$addHandlerSelect(handler, action)


 ## addHandlerDestroy
 EXTWidget$addHandlerDestroy <- function(., handler, action=NULL) {
   .$addHandler(signal="onunload",handler, action)
 }

 "addHandlerDestroy" <- function(obj, handler, action=NULL)
   UseMethod("addHandlerDestroy")
 addHandlerDestroy.gWidget <- function(obj,handler, action=NULL)
   obj$addHandlerDestroy(handler, action)

 ## addHandlerExposed
 EXTWidget$addHandlerExposed <- function(., handler, action=NULL) {
   .$addHandler(signal="onLoad",handler, action)
 }

 "addHandlerExposed" <- function(obj, handler, action=NULL)
   UseMethod("addHandlerExposed")
 addHandlerExposed.gWidget <- function(obj,handler, action=NULL)
   obj$addHandlerExposed(handler, action)

 ## addHandlerMouseMotion
 EXTWidget$addHandlerMouseMotion <- function(., handler, action=NULL) {
   .$addHandler(signal="mousemove",handler, action,
                handlerArguments="e",
                handlerExtraParameters = "EXT.util.JSON.encode({xy:[e.layerX, e.layerY]})"
                )
 }

"addHandlerMouseMotion" <- function(obj, handler, action=NULL)
  UseMethod("addHandlerMouseMotion")
addHandlerMouseMotion.gWidget <- function(obj,handler, action=NULL)
  obj$addHandlerMouseMotion(handler, action)


## not implemented
"addHandlerIdle" <- function(obj, handler = NULL, action = NULL, interval = 1000,   ...)
  UseMethod("addHandlerIdle")
addHandlerIdle.gWidget <- function(obj, handler=NULL, action=NULL,interval = 1000, ...)
  obj$addHandlerIdle(handler, action,interval,...)

EXTWidget$addHandlerIdle <- function(., handler=NULL, action=NULL, interval=1000, ...) {
  ## setInterval(expression, interval) is the javascript to call here
  ## Need to trap this signal, as it doesn't fit the typical pattern
  .$addHandler(signal="idle", handler = handler, action=action, handlerArguments=interval,...)
}




#line 1 "d:/RCompile/CRANpkg/local/2.13/gWidgetsWWW/R/dialogs.R"
##  Copyright (C) 2010 John Verzani
##
##  This program is free software; you can redistribute it and/or modify
##  it under the terms of the GNU General Public License as published by
##  the Free Software Foundation; either version 2 of the License, or
##  (at your option) any later version.
##
##  This program is distributed in the hope that it will be useful,
##  but WITHOUT ANY WARRANTY; without even the implied warranty of
##  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
##  GNU General Public License for more details.
##
##  A copy of the GNU General Public License is available at
##  http://www.r-project.org/Licenses/


##################################################
## Dialogs
## Dialogs are called from a handler. They output
## javascript code only.
## The respond to the handler

## parent can be a container or a widget
##' A basic dialog called by others
##'
##' 
##' @param type type of dialog
##' @param message message for dialog
##' @param text secondary text message. Ignored
##' @param title title is for title bar of dialog's window
##' @param icon icon to accompany dialog
##' @param parent Used for animation
##' @param handler Called when dialog is activated
##' @param action passed to handler
##' @param ... 
##' @param doanimEl gWidgetsWWW option. Logical. Do we animate?
.gshowdialog <- function(type=c("message","confirm","input"),
                        message, text, title=type,
                        icon = c("info","warning","error","question"),
                        parent,
                        handler = NULL, action = NULL,
                         ...,
                         doanimEl=TRUE) {

  ## make object to get ID, assign handlers to
  widget <- EXTWidget$new(toplevel=parent$toplevel)
  class(widget) <- c("gDialog",class(widget))
  ## since we don't "add" we pass in id and toplevel
  id <- widget$ID <- parent$toplevel$newID()
  widget$toplevel <- parent$toplevel

  widget$..defaultTextHeight <- 40      # if input
  
  ## fix icon
  if(missing(icon)) {
    icon = "QUESTION"
  } else {
    icon <- toupper(match.arg(icon))
  }

  ## Define handler callback
  handlerFunction = ""
   if(!is.null(handler)) {
     ## add handler and define string to call handler for constructor
     handlerid <- widget$addHandler(signal=NULL, handler=handler, action=action)
     if(type == "confirm") {
       handlerFunction <- String() +
         paste('function(btn) {',
               '  if(btn == "ok") {',
               sprintf('    runHandlerJS("%s","","");',handlerid),
               '  }',
               '}',
               sep="\n")
     } else if(type == "input") {
       ## Here we call the handler with the value from the widget passed in through
       ## h$context -- not h$input
       handlerFunction <- String() +
         paste('function(btn,text) {',
               '  if(btn == "ok") {',
               sprintf('runHandlerJS(%s,Ext.util.JSON.encode({input:text}));', handlerid), 
               '  }',
               '}',                     # no trailing ";"
               sep="\n")
     }
   }
     
  ## doesn't like \n below
  message <- gsub("\n","<p>",message)
  
  lst <- list(id = id,
              title = escapeHTML(title),
              msg = escapeHTML(message),
              buttons = String(ifelse(type == "message","Ext.Msg.CANCEL","Ext.Msg.OKCANCEL")),
              animEl = parent$ID,
              icon =  String("Ext.MessageBox.") + icon
              )
  if(!doanimEl) 
    lst[["animEl"]] <- NULL
  
  if(handlerFunction != "")
    lst[['fn']] = handlerFunction

  if(type == "input") {
    lst[["multiline"]] <- TRUE
    lst[["defaultTextHeight"]] <- widget$..defaultTextHeight
  }
  
  out <- sprintf("Ext.MessageBox.show(%s);\n",
                 widget$mapRtoObjectLiteral(lst))
  widget$addJSQueue(out)
}

##' A simple message dialog.
##' 
##' @param message main message.
##' @param title Title for dialog's window
##' @param icon icon to decorate dialog
##' @param parent parent container (the main window instance)
##' @param handler handler passed to dialog when confirmed
##' @param action action passed to handler
##' @param ... ignored
##' @export
gmessage <- function(message, title="message",
                     icon = c("info", "warning", "error", "question"),
                     parent = NULL,
                     handler = NULL,
                     action = NULL,...) {
  ## parent must be non-NULL
  out <- .gshowdialog(type="message",message=message,
               title=title, icon=icon,parent=parent,
               handler=handler, action=action, ...)
  
}

##' Confirmation dialog
##' 
##' @param message message
##' @param title title for dialog's window
##' @param icon icon
##' @param parent parent container (main window instance)
##' @param handler handler passed to dialog if confirmed
##' @param action passed to any handler
##' @param ... ignored
##' @export
gconfirm <- function(message, title="Confirm",
                     icon = c("info", "warning", "error", "question"),
                     parent = NULL,
                     handler = NULL,
                     action = NULL,...) {
  ## parent must be non-NULL
  .gshowdialog(type="confirm",message=message,
                      title=title, icon=icon,parent=parent,
                      handler=handler, action=action,...)
}

##' input dialog.
##'
##' Used for getting a text string to pass to a handler
##' @param message message
##' @param title title for dialog's window
##' @param icon icon
##' @param parent parent container (main window instance)
##' @param handler handler passed to dialog if confirmed
##' @param action passed to any handler
##' @param ... ignored
##' @export
ginput <- function(message, text="", title="Input",
                   icon = c("info", "warning","error", "question"),
                   parent=NULL,
                   handler = NULL, action = NULL,...) {
  ## parent must be non-NULL
  out <- .gshowdialog(type="input",message=message,
                      title=title, icon=icon,parent=parent,
                      handler=handler, action=action,...)
}
  

##' means to turn a widget into a dialog
##'
##' Not written
##' @param title title
##' @param widget widget
##' @param parent parent
##' @param handler handler
##' @param action action
gbasicdialog <- function(title = "Dialog", widget,
                         parent=NULL, handler = NULL, action=NULL) {
  stop("XXX not written")
}


## gfile in gfile.R

##' quick alert message -- not modal or obtrusive (dropped from above in extjs)
##' 
##' @param message message to display
##' @param title title of message
##' @param delay delay in seconds
##' @param parent parent window, typically gwindow instance. Necessary
galert <- function(message, title = "message", delay=3, parent=NULL) {
  ## parent not used here
  if(missing(message))
    message <- ""

  message <- paste(message, collapse="<br />")
  
  if(is.null(parent)) {
    stop("Needs parent")
  }
  
  out <- sprintf("Ext.example.msg(%s, %s, %s);",
                 shQuoteEsc(title),
                 shQuoteEsc(message),
                 delay)

  parent$addJSQueue(out)
}
#line 1 "d:/RCompile/CRANpkg/local/2.13/gWidgetsWWW/R/gaction.R"
##  Copyright (C) 2010 John Verzani
##
##  This program is free software; you can redistribute it and/or modify
##  it under the terms of the GNU General Public License as published by
##  the Free Software Foundation; either version 2 of the License, or
##  (at your option) any later version.
##
##  This program is distributed in the hope that it will be useful,
##  but WITHOUT ANY WARRANTY; without even the implied warranty of
##  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
##  GNU General Public License for more details.
##
##  A copy of the GNU General Public License is available at
##  http://www.r-project.org/Licenses/

## make an action
## want to be able to use as
## a) menu/tool item as in Ext
## b) as action= argument to addHandler
## c) the method svalue<- should update instances of action (in Ext)
## d) the enabled<- should set for all instances
## XXX Actions *must* be added prior to showing the window (integrate into gsubwindow otherwise)

##' Trait for action instances
EXTAction = EXTComponentNoItems$new()

##' method to set javascript when value (label) for action is set
##'
##' @param . self
##' @param ... ignored

EXTAction$setValueJS <- function(.,...) {
  out <- sprintf("%s.setText(%s)", .$asCharacter(), shQuoteEsc(svalue(.)))
  return(out)
}

##' method for \code{enabled<-} interaction
##'
##' @param . self
##' @param ... ignored
EXTAction$setEnabledJS <- function(.,...) {
  val <-  tolower(as.character(!.$..enabled))
  out <- sprintf("%s.setDisabled(%s)", .$asCharacter(), val)
  ## out <- String() +
  ##   .$asCharacter() + '.setDisabled(' + tolower(as.character(!.$..enabled)) + ');'
  return(out)
}

##' Method so set icon class
##'
##' @param . self
##' @param icon class of icon. Url is not class, rather name of class)
##' @param ... ignored
##' @note no S3 method
EXTAction$extSetIconClassJS <- function(.,icon,...) {
  out <- String() +
    .$asCharacter() + '.setIconClass(' + svalue(.) + ');'
  return(out)
}

##' Javascript code to override  handler
##'
##' @param . self
##' @param handler handler to call
##' @param ... ignored
EXTAction$extSetHandlerJS <- function(.,handler,...) {
  .$handlerID <- .$window$addHandler(signal = NULL, handler = handler)
  handlerString <- String() +
    'function() {runHandlerJS(' +
      .$handlerID + ',\'""\',\'""\')}'
  out <- String() +
    .$asCharacter() + '.setHandler(' + handlerString + ');'
  return(out)
  
}

##' gaction implementation
##'
##' actions are reusable encapsulations of actions
##' @param label Text for action
##' @param tooltip tooltip
##' @param icon action icon
##' @param handler handler called when action activated
##' @param parent toplevel window of action (where it can be
##' called). Required here
##' @param ... ignored
gaction <- function(label, tooltip=label, icon=NULL, handler, parent, ...) {

  ## parent should be a toplevel container
  if(inherits(parent,"gSubwindow"))
    window <- parent
  else
    window <- parent$toplevel
  
  ## make a class
  widget <- EXTAction$new(label=label,tooltip=tooltip, icon=icon, handler=handler)
  class(widget) <- c("gAction",class(widget))

  widget$toplevel <- parent$toplevel
  widget$setValue(value = label)
  widget$window <- window
  
  ## get ID without adding to container
  widget$ID <- window$newID()
  
  window$addAction(widget)              # for printing
  widget$handlerID <- window$addHandler(signal = NULL, handler = handler)
  widget$x.hidden <- FALSE              # not for actinos, undefined.
  
  ## make Show method -- will call show when added as a handler?
#  widget$x.hidden <- TRUE
  widget$ExtConstructor <- "Ext.Action"
  widget$ExtCfgOptions <- function(.) {
    handlerString <- String() +
      sprintf("function() {runHandlerJS(%s, '', '')}", .$handlerID)
      ## 'function() {runHandlerJS(' +
      ##   .$handlerID + ',\'""\',\'""\')}'

    out <- list(id = NULL,
                renderTo = NULL,
                text = svalue(.),
                handler = handlerString
                )
    if(exists("icon",envir=., inherits=FALSE))
      out[['iconCls']] <- .$icon

    return(out)
  }



  return(widget)


}


#line 1 "d:/RCompile/CRANpkg/local/2.13/gWidgetsWWW/R/gbigtable.R"
##  Copyright (C) 2010 John Verzani
##
##  This program is free software; you can redistribute it and/or modify
##  it under the terms of the GNU General Public License as published by
##  the Free Software Foundation; either version 2 of the License, or
##  (at your option) any later version.
##
##  This program is distributed in the hope that it will be useful,
##  but WITHOUT ANY WARRANTY; without even the implied warranty of
##  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
##  GNU General Public License for more details.
##
##  A copy of the GNU General Public License is available at
##  http://www.r-project.org/Licenses/

##' Show big data tables using paging features of ext
##'
##' @param items data frame to display
##' @param multiple logical can select one or more
##' @param chosencol for svalue method when \code{index=FALSE}
##' @param pageSize number of items to display per page
##' @param handler double click handler
##' @param action passed to handler
##' @param container standard container object
##' @param ... passed to add method
##' @param width integer pixel width. A grid object must have width and height
##' @param height integer pixel height
##' @return a widget instance
##' @examples
##' \dontrun{
##' require(MASS, quietly=TRUE)
##' w <- gwindow("test")
##' g <- ggroup(horizontal=FALSE, cont=w)
##' tbl <- gbigtable(Aids2, cont=g)
##' addHandlerDoubleclick(tbl, handler=function(h,...) {
##'   gmessage(svalue(h$obj), parent=w)
##' })
##' size(tbl) <- list(width=800,height=400, columnWidths=c(100))
##' visible(w) <- TRUE
##' }
## @seealso \code{\link{gtable}}
gbigtable <- function(items, multiple = FALSE, chosencol = 1,
                      pageSize = 25, handler = NULL, action = NULL,
                      container = NULL, ...,
                      width=200, height=200
                      ) {
  
  widget <- EXTComponentWithProxyStore$new(toplevel=container$toplevel,
                                           ..multiple = multiple,
                                           ..width=width, ..height=height
                                           )

  class(widget) <- c("gTable",class(widget))

  theArgs <- list(...)
  
  ## set up store
  store <- EXTProxyStore$new(toplevel=container$toplevel, pageSize=pageSize)
  store$ID <- container$newID()       # set ID
  container$toplevel$addStore(store)
  store$chosenCol <- chosencol

  
  ## load in items
  if(!is.data.frame(items)) {
    items <- data.frame(items, stringsAsFactors=FALSE)
  }
  
  items <- cbind("__index"=seq_len(nrow(items)), items)
  store$data <- items
  widget$..store <- store

  ## set up widget
  widget$setValue(value = 1)            # first column is selected on startup

  
  widget$setValues <- function(.,i,j,...,value) {
    ## XXX need to include i,j stuff
    ## XXX value must be a data frame of the same size as original
    ## add in icons if present
    items <- value
    items <- cbind("__index"=seq_len(nrow(items)), items)
    .$..store$data <- items

    if(exists("..shown",envir=., inherits=FALSE))
      .$addJSQueue(.$setValuesJS(...))
  }

  widget$setValuesJS <- function(., ...) {
    ## get browser to reload itself
    out <- String() +
      sprintf("%s.getTotalCount = function() {return %s};", .$..store$asCharacter(), nrow(.$..store$data)) +
        sprintf("%s.load({params:{start:0, limit:%s}});",
                .$..store$asCharacter(), .$..store$pageSize)
    .$addJSQueue(out)
  }
  
  ##' visibility
  widget$setVisible <- function(., value) {
    ## XXX nothing to do here, can't find the visible (setHidden? method we need)
    ## use $filter instead.
  }


  widget$ExtConstructor <- "Ext.grid.GridPanel"
  widget$ExtCfgOptions <- function(.) {
    out <- list(store = String(.$..store$asCharacter()),
                columns = String(.$makeColumnModel()),
                stripeRows = TRUE,
                enableRowBody = TRUE, 
                frame = FALSE
                ,autoExpandColumn=tail(names(.$..store$data), n=1)
                ) ## also autoExpandColumn, XXX
    

    out[['bbar']] = String() +
      paste("new Ext.PagingToolbar({",
            sprintf("pageSize: %s,",.$..store$pageSize),
            (String("store:") + .$..store$asCharacter() + ','),
            "displayInfo: true,",
            "displayMsg: 'Displaying topics {0} - {1} of {2}',",
            "emptyMsg: 'No topics to display',",
#            "items:[",
#            "'-', {",
#            "pressed: true,",
#            ## XXX still need to get rid of button for preview.
#            "enableToggle:true,",
#            "text: 'Show Preview',",
#            "cls: 'x-btn-text-icon details',",
#            "toggleHandler: function(btn, pressed){",
#            (String("var view =") + .$asCharacter() + ".getView();"),
#            "view.showPreview = pressed;",
#            "view.refresh();",
#            "}",
#          "}]",
          "})",
            collapse="\n")

    
    if(.$..multiple) {
      out[["sm"]] <- String() +
        'new Ext.grid.RowSelectionModel({singleSelect:false})'
    } else {
      out[["sm"]] <- String() +
        'new Ext.grid.RowSelectionModel({singleSelect:true})'
    }

    ## size in panel config, not setStyle
    if(exists("..width",envir = .,inherits=FALSE))
      out[["width"]] <- .$..width
    else
      out[["width"]] <- "auto"
    
    if(exists("..height",envir = .,inherits=FALSE))
      out[["height"]] <- .$..height
    else
        out[["height"]] <- "auto"
    
    return(out)
  }


  ## select first row
  widget$footer <- function(.) {
    sprintf("%s.getSelectionModel().selectFirstRow();\n", .$asCharacter())
  }
  
  ## ## changed = double clicked
  ## double click is default
  widget$addHandlerDoubleclick <- widget$addHandlerChanged <- function(.,handler, action=NULL, ...) {
    ## we need to set up some stuff
    .$addHandler(signal="dblclick",
                 handler = handler,
                 action = action,
                 handlerArguments = "grid, rowIndex, colIndex, e",
                 handlerValue = "var value = rowIndex + 1;")
  }


  
  ###
  container$add(widget,...)

  if(!is.null(handler))
    widget$addHandlerChanged(handler, action=action)
  
  
  invisible(widget)
  
}
#line 1 "d:/RCompile/CRANpkg/local/2.13/gWidgetsWWW/R/gbutton.R"
##  Copyright (C) 2010 John Verzani
##
##  This program is free software; you can redistribute it and/or modify
##  it under the terms of the GNU General Public License as published by
##  the Free Software Foundation; either version 2 of the License, or
##  (at your option) any later version.
##
##  This program is distributed in the hope that it will be useful,
##  but WITHOUT ANY WARRANTY; without even the implied warranty of
##  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
##  GNU General Public License for more details.
##
##  A copy of the GNU General Public License is available at
##  http://www.r-project.org/Licenses/


## button -
## methods
## svalue works
## svalue<- works
## addHandlerClicked works

## *IF* handler = NULL and action a gaction instance then
## will use that action. Not for addHandlerClicked though.

##' button widget
##'
##' 
##' @param text button text. See \code{svalue} to change
##' @param border logical. If \code{FALSE} will not draw border
##' @param handler click handler
##' @param action passed to handler
##' @param container parent container
##' @param ... passed to \code{add} method of container
##' @export
gbutton <- function(text="", border=TRUE,
                    handler = NULL, action=NULL, container, ...) {
  ## components
  widget <- EXTComponentNoItems$new(toplevel=container$toplevel,
                             ..handler = handler,
                             ..action=action
                             )
  class(widget) <- c("gButton",class(widget))
  widget$setValue(value=text)

  ## function to check is we have a gaction object
  widget$doAction <- function(.) {
    if(!exists("..handler", envir=., inherits=FALSE) &&
       exists("..action", envir=., inherits=FALSE) &&
       !is.null(.$..action) &&
       inherits(.$..action,"gAction")
       ) return(TRUE)
    if(is.null(.$..handler) &&
       exists("..action", envir=., inherits=FALSE) &&
       !is.null(.$..action) &&
       inherits(.$..action,"gAction")
       ) return(TRUE)
    return(FALSE)
  }
  ## properties
  widget$getValueJSMethod <- "getText"
  widget$setValueJSMethod <- "setText"
  widget$transportSignal <- NULL        # no transport
  widget$ExtConstructor <- "Ext.Button"
  widget$ExtCfgOptions <- function(.) {
    out <- list("text" = svalue(.))
    if(.$doAction())
      out[['text']] <- svalue(.$..action)
    ## add an icon
    text <- svalue(.)
    si <- getStockIcons()
    if(!is.na(si[text])) {
      out[['cls']] <- "x-btn-text-icon"
      out[['icon']] <- si[text]
    }

    return(out)
  }

  ## intercept action possibility
  ## XXX Issue here -- doesn't work with subwindows/
  widget$writeConstructor <- function(.) {
    ID <- .$asCharacter()
    if(.$doAction()) {
      out <- paste(sprintf("%s = new %s(%s);", ID, .$ExtConstructor, .$..action$asCharacter()),
                   sprintf("%s.id = %s;", ID, shQuote(.$ID)),
                   sprintf("%s.render(document.body);", ID),
                   sep="\n")
    } else {
      out <- get("writeConstructor",envir=EXTWidget)(.)
    }
    return(out)
  }

  
  ## add after CSS, scripts defined
  container$add(widget,...)

  if(!is.null(handler))
    widget$addHandlerClicked(handler=handler,action=action)
  
  invisible(widget)
}
  
#line 1 "d:/RCompile/CRANpkg/local/2.13/gWidgetsWWW/R/gcalendar.R"
##  Copyright (C) 2010 John Verzani
##
##  This program is free software; you can redistribute it and/or modify
##  it under the terms of the GNU General Public License as published by
##  the Free Software Foundation; either version 2 of the License, or
##  (at your option) any later version.
##
##  This program is distributed in the hope that it will be useful,
##  but WITHOUT ANY WARRANTY; without even the implied warranty of
##  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
##  GNU General Public License for more details.
##
##  A copy of the GNU General Public License is available at
##  http://www.r-project.org/Licenses/

##' calendar widget
##'
##' @param text date as text
##' @param format formate of date
##' @param handler handler called when date changed
##' @param action action passed to handler
##' @param container parent container
##' @param ... passed to \code{add} method of container
##' @export
gcalendar <- function(text = "", format = "%Y-%m-%d",
                      handler=NULL, action=NULL, container = NULL, ... ) {


    widget <- EXTComponentNoItems$new(toplevel=container$toplevel,
                               ..format = format)
    class(widget) <- c("gCalendar",class(widget))

    widget$extDateFormat <- "%a %b %d %Y %H:%M:%S"
    
    if(text != "") {
      tmp <- as.Date(text, widget$..format)
      if(!is.na(tmp))
        text <- format(tmp, widget$extDateFormat)
    }
    
    widget$setValue(value=text)           # no day
    widget$getValueJSMethod <- "getValue"
    widget$transportSignal <- c("change")
    ## coerceValues calls ..format

    widget$coerceValues <- function(., value) {
      ## Wed Jun 11 2008 00:00:00 GMT-0400 (EDT) -- ext format
      theDate = as.Date(value,.$extDateFormat)
      if(is.na(theDate))
        as.Date(value, .$..format)
      else
        format(theDate,.$..format)
    }
      
      
    
    ## override writeConstructor of show method
    widget$writeConstructor <- function(.) {
      lst <- list(xtype = "datefield",
                  
                  id =  as.character(String(.$ID) + "date"))
      if(is.na(.$getValue()) || .$getValue() == "") {
        lst['emptyText'] <- "Select a date..."
      } else {
        lst['emptyText'] <- format(as.Date(.$..data, .$extDateFormat),"%m/%d/%Y")
        lst['value'] <- String('new Date("') + .$..data +'")'#.$..text,
      }


      ## size doesn't work here, as we the style thing isn't
      ## applied to 
      if(exists("..width",envir = .,inherits=FALSE))
        lst[["width"]] <- .$..width
      else
        lst[["width"]] <- "auto"

      if(exists("..height",envir = .,inherits=FALSE))
        lst[["height"]] <- .$..height
      else
        lst[["height"]] <- "auto"
      
      out <- String() +
        paste(sprintf("%sdate = new Ext.Panel({\n", .$asCharacter()),
              sprintf("id: '%s',", .$ID),
              sprintf("renderTo: %s,",.$toplevel$..renderTo),
              sprintf("items:[%s]", .$mapRtoObjectLiteral(lst)),
              "});\n",
              sep="")

      out <- out +
        sprintf("%sdate.addClass('x-hidden');\n", .$asCharacter())
      
      out <- out +
        sprintf("%s = %sdate.getComponent(0);\n", .$asCharacter(), .$asCharacter())
      return(out)
    }
        

    container$add(widget,...)

      
    if(!is.null(handler))
      widget$addHandlerChanged(handler, action=action)
    
    
    invisible(widget)
  }

#line 1 "d:/RCompile/CRANpkg/local/2.13/gWidgetsWWW/R/gcanvas.R"
##  Copyright (C) 2010 John Verzani
##
##  This program is free software; you can redistribute it and/or modify
##  it under the terms of the GNU General Public License as published by
##  the Free Software Foundation; either version 2 of the License, or
##  (at your option) any later version.
##
##  This program is distributed in the hope that it will be useful,
##  but WITHOUT ANY WARRANTY; without even the implied warranty of
##  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
##  GNU General Public License for more details.
##
##  A copy of the GNU General Public License is available at
##  http://www.r-project.org/Licenses/

##' widget to be used as a device. Uses \pkg{canvas} pacakge
##' @param f a file name
##' @param width width of widget in pixels
##' @param height heighto f widget in pixels
##' @param container parent container
##' @param ... passed to add method of container
##' @export
gcanvas <- function(f, width=480, height=400,
##                    handler = NULL, action = NULL,
                    container = NULL,...) {

  if(!bypassRequire("canvas"))
    return(glabel(gettext("gcanvas needs the canvas package to be installed"), cont=container))

  
  widget <- EXTComponent$new(toplevel=container$toplevel,
                             ..width=as.numeric(width),
                             ..height=as.numeric(height))
  
  class(widget) <- c("gCanvas",class(widget))
  if(!missing(f))
    widget$setValue(value=f)

  widget$ExtConstructor <- "Ext.Panel"
  widget$ExtCfgOptions <-  function(.) {
    out <- list()
    out[['border']] <- FALSE
    
    out[['html']] <- String() +
      '\'<canvas id="gWidgetsCanvas' + .$ID + '" width=' + .$..width + ' height=' + .$..height +
        '>' + gettext("If you see this, your browser does not support the canvas tag.") + '</canvas>\''

    out[["width"]] <- .$..width         # for panel size
    out[["height"]] <- .$..height
    
    return(out)
  }

  
  widget$footer <- function(.) {
    out <- String(sep="") +
      'var ctx = document.getElementById("gWidgetsCanvas' + .$ID + '").getContext("2d");' +
        'if(!ctx.fillText) {ctx.fillText =function() {};};' + '\n' +
          .$setValueJS() 
    return(out)
  }

  widget$setValueJS <- function(.,...) {
    if(exists("..data", envir=., inherits=FALSE)) {
      value <- .$..data
      out <- String()
      if(!is.null(value)) {
        ## clear out
        out <- out + "ctx.clear = true;" + '\n' +
          paste(readLines(value, warn=FALSE)[-1], collapse="\n") +
            '\n'
      }
      return(out)
    } else {
      return("")
    }
  }

  
  ## add after CSS, scripts defined
  container$add(widget,...)
  invisible(widget)
  
}


##' ggraphics is a pass through for gcanvas
##' @alias gcanvas
ggraphics <- function(width = 480, height=400, container=NULL, ...) {
  gcanvas(width=width, height=height, container=container, ...)
}
#line 1 "d:/RCompile/CRANpkg/local/2.13/gWidgetsWWW/R/gcheckbox.R"
##  Copyright (C) 2010 John Verzani
##
##  This program is free software; you can redistribute it and/or modify
##  it under the terms of the GNU General Public License as published by
##  the Free Software Foundation; either version 2 of the License, or
##  (at your option) any later version.
##
##  This program is distributed in the hope that it will be useful,
##  but WITHOUT ANY WARRANTY; without even the implied warranty of
##  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
##  GNU General Public License for more details.
##
##  A copy of the GNU General Public License is available at
##  http://www.r-project.org/Licenses/


## gcheckbox
## uses a button with different shading (YAHOO style)
## methods
## svalue works
## svalue<- works
## names 
## names<-  NO METHOD setBoxLabel

##' checkbox widget
##' 
##' @param text character. text label for checkbox. (Should be that it
##' can be set later with \code{[<-}, but this isn't implemented)
##' @param checked logical. initial state (Set later with \code{svalue<-})
##' @param use.togglebutton logical. If TRUE, represent with a togglebutton, else use check box 
##' @param handler handler called when state is toggled. Check value
##' @param action action passed to handler
##' @param container parent container
##' @param ... passed to \code{add} method of container.
##' @export
##' @note No method to set label (need setBoxLabel)
gcheckbox = function(text, checked = FALSE, use.togglebutton=FALSE,
  handler = NULL, action = NULL,  container = NULL,...) {

  ## dispatch elsewhere if a togglebutton
  if(use.togglebutton) {
    return(gtogglebutton(text, checked, handler,action,container, ...))
  }
  
  widget <- EXTComponentInPanel$new(toplevel=container$toplevel)
  class(widget) <- c("gCheckbox",class(widget))
  widget$setValue(value=checked)
  widget$setValues(value = text)

  ## give a default size, as otherwise panel will spread across screen
  widget$..width <- 200                 # use size()<- to set otherwise
  
  ## define methods

  ## this returns via cat, javascript to set the buttons value
  widget$coerce.with = function(.,x) {
    if(is.character(x)) x <- toupper(x)
    return(as.logical(x))
  }
  widget$getValueJSMethod = "getValue"
  widget$setValueJSMethod = "setValue"
  widget$transportSignal <- "check"   

  ## rather than use   widget$ExtConstructor <- "Ext.form.Checkbox"
  ## we use EXTComponentInPanel and set the xtype here
  widget$ExtCfgOptions <- function(.) {
    list(xtype = "checkbox",
         renderTo = NULL,               # override value
         id = as.character(String(.$ID) + "item"),
         "checked" = svalue(.),
         "boxLabel" = .$getValues()[1]
         )
  }

  ## assign value
  ## we untaint by coercion
  widget$assignValue <- function(., value) {
    svalue(.) <- as.logical(toupper(value[[1]]))
  }
  
  ## Doesn't work
  widget$setValuesJS <- function(., ...) {
    out <- sprintf("%s.boxLabel = '%s';", .$asCharacter(), .$getValues()[1])
    .$addJSQueue(out)
  }

  
  
  ## add after CSS, scripts defined
  container$add(widget,...)


  if(!is.null(handler))
    widget$addHandler("check",handler=handler,action=action)

  invisible(widget)
}

##' use toggle button to indicate checkbox state
##' 
##' @param text  button text, use [<- to set
##' @param checked value checked or not. Use svalue<- to set
##' @param handler 
##' @param action 
##' @param container 
##' @param ... 
gtogglebutton <- function(text="", checked=TRUE,
                    handler = NULL, action=NULL, container, ...) {
  ## components
  widget <- EXTComponent$new(toplevel=container$toplevel,
                             ..handler = handler,
                             ..action=action
                             )
  class(widget) <- c("gToggleButton",class(widget))

  widget$setValue(value=checked)
  widget$setValues(value=text)
  

  widget$setValueJS <- function(., ...) {
    out <- String() +
      sprintf("var widget = %s;", .$asCharacter()) +
        sprintf("widget.pressed(%s);", tolower(as.character(.$getValue())))
    .$addJSQueue(out)
  }

  widget$setValuesJS <- function(., ...) {
    out <- sprintf("%s.setText('%s');", .$asCharacter(), .$getValues()[1])
    .$addJSQueue(out)
  }
  
  widget$transportSignal <- "toggle"
  widget$ExtConstructor <- "Ext.Button"
  widget$ExtCfgOptions <- function(.) {
    out <- list("text" = .$getValues()[1],
                "enableToggle"=TRUE,
                "pressed"=svalue(.)
                )
    return(out)
  }


  
  ## add after CSS, scripts defined
  container$add(widget,...)

  if(!is.null(handler))
    widget$addHandlerClicked(handler=handler,action=action)
  
  invisible(widget)
}
  


#line 1 "d:/RCompile/CRANpkg/local/2.13/gWidgetsWWW/R/gcheckboxgroup.R"
##  Copyright (C) 2010 John Verzani
##
##  This program is free software; you can redistribute it and/or modify
##  it under the terms of the GNU General Public License as published by
##  the Free Software Foundation; either version 2 of the License, or
##  (at your option) any later version.
##
##  This program is distributed in the hope that it will be useful,
##  but WITHOUT ANY WARRANTY; without even the implied warranty of
##  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
##  GNU General Public License for more details.
##
##  A copy of the GNU General Public License is available at
##  http://www.r-project.org/Licenses/

##'
##' @param items vector of items to select from
##' @param checked initial value of checked state. Recycled
##' @param horizontal Layout horizontally?
##' @param use.table If TRUE, uses a grid widget with checkboxes to
##' display. If TRUE, horizontal is ignored, and items may be a data
##' frame.
##' @param handler handler called when state changes
##' @param action passed to handler
##' @param container parent container
##' @param ... passed to add method of container
##' @export
gcheckboxgroup = function (items, checked = FALSE, horizontal = FALSE, use.table=FALSE,
  handler = NULL, action = NULL,
  container = NULL, ...) {

  ## use.table?
  if(use.table) {
    out <- gcheckboxgrouptable(items, checked=checked, handler=handler, action=action, container=container, ...)
    return(out)
  }

  
  ## use a checkbox if only one item
  if(length(items) == 1) {
    out <- gcheckbox(items, checked = checked, handler=handler, action=action, container = container, ...)
    return(out)
  }

  widget <- EXTComponentWithItems$new(toplevel=container$toplevel,
                                      ..checked = checked,
                                      ..horizontal = horizontal,
                                      ..handler = handler,
                                      ..action = action
                                      )
  class(widget) <- c("gCheckboxgroup",class(widget))

  

  widget$assignValue <- function(., value) {
    value <- value$value     # a list
    .$..data <- as.logical(value)
  }


  widget$setValue <- function(., index=NULL,..., value) {
    ## values can be set by index, logical, or names

    n <- length(.); items <- .$getValues()
    if(is.character(value)) {
      value <- sapply(items, function(i) i %in% value)
    } else if(is.numeric(value) || (!is.null(index) && index)) {
      value <- sapply(1:n, function(i) i %in% value)
    } else if(!is.logical(value)) {
      ## error
      cat("Value should be logical vector, vector of indices, or character vector of names\n")
    }

    .$..data <- rep(value, length=n)

    if(exists("..shown",envir=., inherits=FALSE))
      ##cat(.$setValueJS())
      .$addJSQueue(.$setValueJS())
  }
  widget$setValueJS <- function(., ...) {
    out <- String() +
      paste(sprintf("var ans = [%s];", paste(tolower(as.character(.$..data)), collapse=",")),
            sprintf("for(var i=0; i < %s; i++) {", .$length()),
            sprintf("  %s.getComponent(i).setValue(ans[i]);", .$asCharacter()),
            sprintf("};"),
            collapse="")
      ## 'var ans = [' + paste(tolower(as.character(.$..data)),collapse=",") +
      ##   '];' +
      ##     'for( var i = 0; i < ' + .$length() + ';i++) {' +
      ##       .$asCharacter() + '.getComponent(i).setValue(ans[i]);' +
      ##         '};'
    return(out)
  }

  widget$getValue <- function(.,index=NULL ,drop=NULL,...) {
    ## we need to reverse logic from AWidgtet$getValue
    out <- .$..data

    index <- getWithDefault(index, FALSE)
    if(index)
      return(which(out))                # indices -- not logical
    else
      return(.$..values[out])
  }

  widget$xtype <- "checkbox"
  widget$transportSignal <- "check"
  widget$checked <- function(.,i) .$..data[i]

  widget$ExtCfgOptions <- function(.) {
    out <- list(border = FALSE,
                bodyStyle = list(padding = "5px"),
                items = .$makeItems()
                )
    if(.$..horizontal)
      out[['layout']] <- "column"
    
    return(out)
  }

  ## value is array of logicals to transport  back
  widget$transportValue <- function(.,...) {
    out <- String() +
      paste('var value = new Array();',
            sprintf('for(var i = 0; i < %s; i++) {', length(.)),
            sprintf('value[i] = %s.getComponent(i).getValue();', .$asCharacter()),
            '};',
            sep="")
    return(out)
  }



  if(length(checked) != length(items))
    checked <- rep(checked, length=length(items))
  widget$setValues(value = items)       # need values before value!
  widget$setValue(value= checked) ## store logical vector -- might be string

  widget$addHandlerChanged <- function(., handler, action=NULL)
    .$addHandler(signal="check", handler, action)

  container$add(widget, ...)
  
  if(!is.null(handler))
    addHandlerChanged(widget, handler=handler, action=action)

  invisible(widget)

}



##################################################
## gcheckboxgroup with table
##'
##' @param items A vector (or data frame with items to select from)
##' @param checked Logical indicating if values are checked. Recyled. Only FALSE works now!
##' @param handler handler to call when check is done (or undone)
##' @param action passed to handler
##' @param container parent container
##' @param ... passed to add method of parent container
##' @TODO checked isn't working; [<- isn't working, is [?
gcheckboxgrouptable <- function(items,
                                 checked = FALSE,
                                 handler = NULL, action = NULL,
                                 container = NULL, ...) {

  widget <- EXTComponentWithStore$new(toplevel=container$toplevel)
  
  class(widget) <- c("gCheckboxGroupTable",class(widget))
  
  ## set up store
  store <- EXTStore$new(toplevel=container$toplevel)
  store$ID <- container$newID()       # set ID
  
  ## load in items
  if(!is.data.frame(items)) {
    items <- data.frame(items, stringsAsFactors=FALSE)
  }
  
  items <- cbind("__index"=seq_len(nrow(items)), items) # a data frame
  store$data <- items
  widget$..store <- store


  ## assign vlaue
  ## we untaint by coercion to integer indices
  widget$assignValue <- function(., value) {
    value <- value$value    
    .$..data <- sort(as.integer(value))
  }
  

  ## values refer to indices
  widget$setValue <- function(., index=NULL,..., value) {
    ## if index --
    index <- getWithDefault(index, is.numeric(value))
    if(index) {
      .$..data <- as.integer(value)
    } else if(is.logical(value)) {
      .$..data <- which(value)
    } else {
      ## match on first column
      values <- .$..store$data[,1, drop=TRUE]
      .$..data <- which(as.character(value) %in% as.character(values))
    }
    
    ## now process if shown
    if(exists("..shown",envir=., inherits=FALSE)) 
      .$addJSQueue(.$setValueJS(index=index, ...))
  }


  widget$setValueJS <- function(., ...) {
    if(exists("..setValueJS", envir=., inherits=FALSE)) .$..setValueJS(...)

    ind <- .$..data                     # indices
    if(length(ind))
      out <- sprintf("%s.getSelectionModel().selectRows(%s);", .$asCharacter(), toJSON(ind - 1))
    else
      out <- sprintf("%s.getSelectionModel().selectRows([]);", .$asCharacter())

    return(out)
   }

    
  widget$getValue <- function(.,index=NULL ,drop=NULL,...) {
    ## we store value as an index
    ind <- as.numeric(.$..data)

    index <- getWithDefault(index, FALSE)

    if(length(ind) == 0) {
      if(index)
        return(numeric(0))
      else
        return(NA)
    }

    
    ## no index -- return values
    if(index) {
      return(ind)
    } else {
      ## depends on drop
      values <- .$..store$data
      values <- values[,-1, drop=FALSE]             # drop __index
      if(is.null(drop) || drop) {
        return(values[ind,1,drop=TRUE])
      } else {
        return(values[ind,])
      }
    }      
  }

  ## should have same dimension as items
  ## i,j ignored here
  widget$setValues <- function(.,i,j,...,value) {
    items <- value
    items <- cbind("__index"=seq_len(nrow(items)), items)
    .$..store$data <- items

    if(exists("..shown",envir=., inherits=FALSE))
      .$addJSQueue(.$setValuesJS(...))
  }

  ## need code to update
  widget$setValuesJS <- function(., ...) {
    ### XXX what to do to set values?
  }
  
  widget$transportSignal <- 'cellclick'

  widget$ExtConstructor <- "Ext.grid.GridPanel"
  ## convenience like asCharacter
  widget$selectionModel <- function(.) String() + sprintf("o%sSelectionModel", .$ID)

  widget$header <- function(.) {
    out <- String()

    ## write out selection model instance
    out <- out + sprintf("\n\n%s = new Ext.grid.CheckboxSelectionModel({});\n", .$selectionModel())

    return(out)
  }

  widget$footer <- function(.) {
    out <- String()

    ## not working?
    ## Calls handler but does not check states
    ## Set initial selection
    if(length(ind <- .$getValue(index=TRUE))) {
      out <- out +
        sprintf("o%sSelectionModel.suspendEvents();", .$ID) +
          sprintf("o%sSelectionModel.selectRows(%s);", .$ID,
                  toJSON(ind - 1)) +
                    sprintf("o%sSelectionModel.resumeEvents();\n", .$ID) 
    }  
    return(out)
  }

  ## similar to gtable, only we specify selection model
  widget$ExtCfgOptions <- function(.) {
    out <- list(store = String(.$..store$asCharacter()),
                columns = String(.$makeColumnModel()),
                stripeRows = TRUE,
                enableRowBody = TRUE, 
                frame = FALSE
                ,autoExpandColumn=tail(names(.$..store$data), n=1)
                ) ## also autoExpandColumn, XXX

    ## The selection model is the checkbox selection model
    out[["sm"]] <- .$selectionModel()

    ## size in panel config, not setStyle
    if(exists("..width",envir = .,inherits=FALSE))
      out[["width"]] <- .$..width
    else
      out[["width"]] <- "auto"
    
    if(exists("..height",envir = .,inherits=FALSE))
      out[["height"]] <- .$..height
    else
        out[["height"]] <- "auto"
    
    return(out)
  }

  ## modified slightly from gdf to put in selection model for first column
  widget$makeColumnModel <- function(.) {
    
    
    df <- .$..store$data
    colNames <- names(df)[-1]           # no __index
    colNames <- shQuoteEsc(colNames)

    
    tmp <- paste('{',
                 'id:',colNames,
                 ', header:',colNames,
                 ', sortable:true',
                 if(!.$has_slot("..columnWidths")) "" else 
                        sprintf(", width: %s",rep(.$..columnWidths, length.out=ncol(df))),
                 ', dataIndex:',colNames,
                 '}',
                 sep="")
    out <- paste('[\n',
                 .$selectionModel(), ",", # add this in from gtable
                 paste(tmp,collapse=",\n"),
                 ']',
                 collapse="")

    return(out)
  }




  ##' override need to put  on selection model
  widget$writeHandlerJS <- function(.,signal="",handler=NULL) {
    if(is.null(signal))                   # errors?
      return()
    out <- String()

    out <- out +
      paste(
            sprintf("%s.on('selectionchange',",.$selectionModel()),
            "function(selModel) {",
            '  var value = new Array();',
            '  if(selModel.hasSelection()) {',
            '    var sels =  selModel.getSelections();',
            '    for(var i = 0, len=sels.length; i < len; i++) {',
            '      var record = sels[i];',
            '      var data = record.get("__index");',
            '      value[i] = data;',
            '    };',
            '  };',
            sprintf("  _transportToR('%s', Ext.util.JSON.encode({value:value}) );",.$ID),
            "},",
            "this, {delay:1,buffer:1, single:false});",
            sep="")
    
    if(!is.null(handler)) {
      out <- out +
        sprintf("%s.on('selectionchange',", .$selectionModel()) +
            .$writeHandlerFunction(signal=signal, handler=handler) +
              ',this, {delay:100,buffer:100, single:false});' + '\n'
    }
    
    return(out)
  }
  

  ## changed = clicked
  widget$addHandlerClicked <- widget$addHandlerChanged <-function(.,handler, action=NULL, ...) {
    .$addHandler(signal="selectionchange",
                 handler = handler,
                 action = action,
                 handlerArguments = "selModel"
                 )
  }


  ## set up widget
  n <- nrow(items); checked <- rep(checked, length.out=n)
  widget$setValue(value = which(checked), index=FALSE)
  
  
  if(!is.null(handler))
    widget$addHandlerChanged(handler, action=action)

  ##
  container$add(widget,...)

  
  invisible(widget)
  
}
#line 1 "d:/RCompile/CRANpkg/local/2.13/gWidgetsWWW/R/gcombobox.R"
##  Copyright (C) 2010 John Verzani
##
##  This program is free software; you can redistribute it and/or modify
##  it under the terms of the GNU General Public License as published by
##  the Free Software Foundation; either version 2 of the License, or
##  (at your option) any later version.
##
##  This program is distributed in the hope that it will be useful,
##  but WITHOUT ANY WARRANTY; without even the implied warranty of
##  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
##  GNU General Public License for more details.
##
##  A copy of the GNU General Public License is available at
##  http://www.r-project.org/Licenses/


## gcombobox aka gdroplist
## XXX -- needs two or more values

##' combobox implementation
##'
##' The \code{svalue<-} method is used to specify value by name or by
##' index. The \code{[<-} method can be used to update the data to
##' select from.
##' @param items a vector of items to choose from. Or a data frame with 1 column (items), two columns (items, icons), or three columns (items, icons, tooltip)
##' @param selected initially selected item, by index. Use \code{0L} for none.
##' @param editable logical. Does combobox allow editing
##' @param coerce.with Function. If given, called on value before returning
##' @param handler handler
##' @param action action
##' @param container parent container
##' @param ... passed to \code{add} method of parent
##' @note See the  \code{..tpl} to modify template for what is
##' displayed. Override \code{..hideTrigger} and \code{..typeAhead} to
##' change behaviours.
##' @export
gcombobox <- function(items, selected=1, editable=FALSE, coerce.with=NULL,
           handler = NULL, action = NULL, container=NULL,...) {

    widget <- EXTComponentWithStore$new(toplevel=container$toplevel,
                               ..editable = editable,
                               ..selected = selected)
    class(widget) <- c("gComboBox",class(widget))
    
    store <- EXTStore$new(toplevel=container$toplevel)
    store$ID <- container$newID()       # set ID

    ## we have possible a multicolumn items
    ## we want
    ## a) vector or 1-col -- just text
    ## b) 2 cols: first text, second url of icon
    ## c) 3 cols: first text, second url, third quick tip
    ## d) 4 cols: user can use template


 
    
    if(!is.data.frame(items) ||  ncol(items) == 1)
      widget$..type <- 1
    else
      widget$..type <- ncol(items)

    if(!is.data.frame(items)) {
      if(is.numeric(items))
        widget$coerce.with = "as.numeric"
      items <- data.frame(values=items, stringsAsFactors=FALSE)
    }
    
    ## double up first column
    items <- items[, c(1, 1:ncol(items))]
    
    ## get names right
    ## if not type 1,2 or 3 or we override in ..tpl this is ignored
    nms <- c("value","text","iconurl","qtip")
    if(widget$..type %in% 1) {
      if(ncol(items) == 1)
        items[,2] <- items[,1]
      names(items) <- nms[1:2]
    } else if(widget$..type == 2) {
      names(items) <- nms[1:3]
    } else if(widget$..type >= 3) {
      names(items)[1:4] <- nms
    }

    ## fix up icons
    if(widget$..type >= 2) {
      if(!isURL(items[1,3,drop=TRUE])) {
        ## assume a stock icon
        items[,3] <- getStockIcons(items[,3,drop=TRUE])
      }
    }
    
    ## store has a data frame for its "data" property
    store$setData(items)
    store$setChosenCol(store$fieldNames()[1])


    widget$..store <- store
    ## properties 
    widget$..width <- 200
    widget$..emptyText <- ""
    widget$..hideTrigger <- FALSE
    widget$..typeAhead <- FALSE
    ## return a string
    widget$..tpl <- function(.) {
      ## return string
      if(.$..type == 1) {
        out <- String() + '<div class="x-combo-list-item">{text}</div>'
      } else if(.$..type == 2) {
        out <- String() + '<div class="x-combo-list-item"><img src="{iconurl}">{text}</div>'
      } else if(.$..type >= 3) {
        out <- String() + '<div ext:qtip="{qtip}" class="x-combo-list-item"><img src="{iconurl}">{text}</div>'
      }

      out <- String('\'<tpl for=".">') + out + '</tpl>\''
      return(out)
    }
    
    ## CSS
    ## Scripts

    ## methods

    widget$getValueJSMethod <- "getRawValue"
    widget$setValueJSMethod <- "setValue"

    ## we redefine the setvalue bit. We use the raw value here so that
    ## editable and not are the same. In get value we coerce to index,
    ## if possible, to make sure value is one we want
    widget$assignValue <- function(., value) {
      .$..data <- value[[1]]
    }

    ##' we override get value to make sure we check that value is in
    widget$getValue <- function(.,index=NULL ,drop=NULL,...) {
      ## we store value as an index
      index <- getWithDefault(index, FALSE)
      
      out <- .$..data
      values <- .$getValues()
      ## hack to make chosenCol work with combobox
      chosenCol <- 1
      values <- values[, chosenCol, drop=TRUE]

      ## if editable then we just return
      if(.$..editable) {
        if(index) {
          ind <- values %in% out
          if(any(ind))
            return(ind[1])
          else
            return(0L)
        } else {
          return(out)
        }
      }

      ## otherwise, we get the index first (to untaint) then go from there
      ind <- which(as.character(values) %in% as.character(out))

      if(length(ind) == 0)              # no match
        if(index)
          return(0)
        else
          return("")                    # not editable, so we clobber

      ind <- ind[1]
      ## no index -- return values
      if(index) {
        return(ind)
      } else {
        values <- .$..store$data
        ## depends on drop
        if(names(values)[1] == "__index")
          values <- values[,-1, drop=FALSE]             # drop __index
        
        if(is.null(drop) || drop) {
          return(values[ind, chosenCol, drop=TRUE])
        } else {
          return(values[ind,])
        }
      }      
    }


    widget$setValue <- function(., index=NULL, ..., value) {
      
      ## can set by text or by index.
      index <- getWithDefault(index, FALSE)
      if(index) {
        values <- .$getValues()
        if(value >= 1)
          value <- values[value,1]        # get from data frame
        else
          value = ""                    # empty if selected = 0
      }
      .$..data <- value
      
      ## now process if shown
      if(.$has_local_slot("..shown"))
        .$addJSQueue(.$setValueJS(index=index, ...))
    }
    
    widget$setValueJS <- function(., ...) {
      if(exists("..setValueJS", envir=., inherits=FALSE)) .$..setValueJS(...)
      ind <- .$getValue(index=TRUE)
      
      if(ind <= 0)
        out <- sprintf("%s.clearValue()", .$asCharacter())
      else
        out <- sprintf("%s.setValue('%s');", .$asCharacter(), .$getValue(index=FALSE))
  return(out)
}


    widget$setValues <- function(.,i,j,...,value) {
      ## intercept value if not data frame or if only 1 d
      if(!is.data.frame(value)) {
        value <- data.frame(values=value, labels=value,stringAsFactors=FALSE)
      } else if(ncol(value) == 1) {
        value <- data.frame(values = value[,1,drop=TRUE], labels  = value[,1,drop=TRUE])
      } else {
        ## double up
        value <- value[,c(1,1:ncol(value))]
      }
        

      
      ## XXX need to include i,j stuff
      .$..store$data <- value
      if(exists("..shown",envir=., inherits=FALSE))
        ##cat(.$setValuesJS(...), file=stdout())
        .$addJSQueue(.$setValuesJS(...))
    }
    widget$ExtConstructor <- "Ext.form.ComboBox"
    widget$ExtCfgOptions <- function(.) {
      out <- list(renderTo = NULL,      # override
                  id = as.character(String(.$ID) + "item"),
                  xtype = "combo",
                  store = String(.$..store$asCharacter()),
                  displayField = .$..store$displayField(),
                  valueField = .$..store$displayField(),
                  editable = .$..editable,
                  mode = "local",
                  triggerAction = "all",
                  hideTrigger  = .$..hideTrigger,
                  typeAhead = .$..typeAhead,
                  emptyText = .$..emptyText,
                  selectOnFocus = TRUE,
                  tpl =  .$..tpl
                  )
      if(!is.na(svalue(.)))
        out[['value']] <- svalue(.)     # string, not index
      
      if(exists("..width",envir = .,inherits=FALSE))
        out[["width"]] <- .$..width
      else
        out[["width"]] <- "auto"
      
      if(exists("..height",envir = .,inherits=FALSE))
        out[["height"]] <- .$..height
      else
        out[["height"]] <- "auto"

      return(out)
    }

    ## we need to override methods of EXTComponent$Show
    widget$writeConstructor <- function(.) {
      out <- String() +
        'o' + .$ID + 'panel = new Ext.Panel({' + # no var -- global
          'id:' + shQuote(.$ID) + ',' +
            'xtype:"panel",' +
              'layout:"fit",' +
                'width:' + .$..width + ',' +
                  'height: "auto",' +
                    sprintf('renderTo: %s,', .$toplevel$..renderTo) +
                      'items: [' + '\n' + 
                        .$mapRtoObjectLiteral() +
                          ']' + '\n' +
                            '});' + '\n'

      out <- out + sprintf("o%spanel.addClass('x-hidden');\n", .$ID)

      out <- out +
        'o' + .$ID + ' = ' + # no var -- global
                    'o' + .$ID + 'panel.getComponent(0);' + '\n'

      
      return(out)
    }

    widget$transportSignal <- c("blur" ,"select", "change")
    widget$transportValue <- function(., ..., signal=NULL) {
      out <- String()
      if(signal == "change") {
        out <- out + 'var value = newValue;' + '\n'
      } else {
        out <- out + 'var value = o' + .$ID + '.getRawValue();' + '\n'
      }
      return(out)
    }
        
    
    ## initialize after methods are defined.
    ## This is why we need to make a Trait
    if(selected >= 1) {
      widget$setValue(value=items[selected,1,drop=TRUE]) # items is a data frame!
    } else {
      widget$setValue(value="")         # selected == 0 --> no entry
    }


    
    ## methods

    container$add(widget,...)

    widget$addHandlerChanged <- function(.,handler=NULL, action=NULL, ...) {
      .$addHandler("select",handler=handler,action=action)
      .$addHandler("change",handler=handler,action=action)
    }
      
    if(!is.null(handler))
      widget$addHandlerChanged(handler, action=action)
    
    
    invisible(widget)
  }

##' Old name for widget
##'
##' Deprecated
gdroplist <- gcombobox
#line 1 "d:/RCompile/CRANpkg/local/2.13/gWidgetsWWW/R/gcommandline.R"
##  Copyright (C) 2010 John Verzani
##
##  This program is free software; you can redistribute it and/or modify
##  it under the terms of the GNU General Public License as published by
##  the Free Software Foundation; either version 2 of the License, or
##  (at your option) any later version.
##
##  This program is distributed in the hope that it will be useful,
##  but WITHOUT ANY WARRANTY; without even the implied warranty of
##  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
##  GNU General Public License for more details.
##
##  A copy of the GNU General Public License is available at
##  http://www.r-project.org/Licenses/


##' A Commandline for gWidgetsWWW
##'
##' @param container a container object to place commandline into
##' @param width width of group holding commandline notebook
##' @param graphic_size Size of svg objects
##' @detail This widget provides a notebook like interface for running
##' R commands for the local server. Graphics -- and only one graphic
##' per cell -- are displayed through a gsvg widget, so the \pkg{RSVGTipsDevice} must
##' be installed.
##' @note This widget implements no gWidgets methods
gcommandline <- function(container, width=NULL, graphic_size=c(480,480), ...)  {
  
  if(!gWidgetsWWWIsLocal()) {
    glabel("gcommandline can only be run locally.", cont=container)
    return()
  }
  

  ##' code for a cell
  aCell <- proto(
                 ##' a new object
                 new=function(., parent, container, n) {
                   .$id <- n
                   .$parent <- parent
                   .$container <- container
                   .$g <- gexpandgroup(sprintf("[%s]", n), cont=container, horizontal=FALSE)
                   .$cmdBox <- gtext("", height=16*4, width=8*80, cont=.$g) # 8 pixels * 80 characters
                   .$evalButton <- gbutton("Evaluate", cont=.$g)
                   .$output <- ghtml("", cont=.$g) # output holder
                   .$graphics <- ggroup(cont=.$g)  # graphics holder
                   
                   focus(.$cmdBox) <- TRUE
                   ## handlers: keyboard, eval button, ...
                   addHandlerClicked(.$evalButton, handler=function(h,...) {
                     . <- h$action
                     .$evalCmdLine()
                   }, action=.)
                   addHandlerKeystroke(.$cmdBox, key="e.ENTER", handler=function(h,...) {
                     . <- h$action
                     chunk <- svalue(.$cmdBox)
                     chunk <- paste(chunk, collapse="\n")
                     chunkexps <- try(parse(text=chunk), silent=TRUE)
                     if(!inherits(chunkexps, "try-error")) {
                       .$evalCmdLine()
                     }
                   },
                                       action=.)

                 },
                 ##' remove from parent container
                 remove=function(.) delete(.$container, .$g),
                 ##' how many lines to show
                 maxLines = 25,
                 ##' evaluate command. Place output into cell, do graphics f there
                 evalCmdLine=function(.) {
                   
                   ## set device and directory for graphics
                   ## requires  RSVGTipsDevice
                   curDevice <- getOption("device")
                   options(device=svg)
                   
                   curDirectory <- getwd()
                   curdir <- tempdir()
                   setwd(curdir)
                   
                   on.exit({
                     options(Device=curDevice)
                     setwd(curDirectory)
                   })
                   
                   ## check to see if we have new devices
                   noDevs <- length(dev.list())
                   
                   sapply(list.files(pattern="Rplot*"), unlink)
                   
                   ## parse to check for errors
                   ## eval and check for errors XXX
                   chunk <- svalue(.$cmdBox)
                   chunk <- paste(chunk, collapse="\n")
                   ## in Opera a mysterious %0D is added, need to delete
                   chunk <- gsub("%0D", "", chunk, fixed=TRUE)

                   
                   chunkexps <- try(parse(text=chunk), silent=TRUE)
                   if(inherits(chunkexps, "try-error")) {
                     out <- try(capture.output(eval(parse(text=chunk), envir=.GlobalEnv)), silent=TRUE)
                     if(inherits(out, "try-error"))
                       out <- sprintf("Houston, we have a problem parsing:<br>%s",
                                      chunkexps)
                   } else if(length(chunkexps) == 0) {
                     out <- ""
                   } else {
                     out <- character()
                     for(i in chunkexps) {
                       tmp <- try(capture.output(eval(i, envir=.GlobalEnv)), silent=TRUE)
                       if(inherits(tmp, "try-error")) {
                         out <- c(out, "error")
                       } else{
                         if(length(tmp))
                           out <- c(out, paste(tmp, collapse="<br>"))
                       }
                     }
                     out <- paste(out, collapse="<hr>")
                   }
                   
                   if(length(out) > .$maxLines)
                     out <- c(out[1:.$maxLines], gettext("... 8< snip >% ..."))
                   out <- paste(out, collapse="<br>")
                   out <- gsub("\\s","&nbsp;", out)
                   
                   svalue(.$output) <- sprintf("<code>%s</code>",out)
                   
                   ## handle graphics
                   if((noDevs1 <- length(dev.list())) > noDevs) {
                     for(i in (noDevs + 1):noDevs1) {
                       dev.off()
                     }
                     k <- list.files(pattern="Rplot*", path=curdir, full.names=TRUE)
                     if(length(k) > 0) {
                       if(!exists("ge",envir=.) || is.null(.$ge)) {
                         .$ge <- gexpandgroup(gettext("Plot"), cont=.$graphics)
                         .$canvas <- gsvg(cont=.$ge, label="fred", width=graphic_size[1], height=graphic_size[2])
                       } 
                         
                       visible(.$ge) <- TRUE
                       ## we hard code url for now -- abstract this for local
                       svalue(.$canvas) <- sprintf("http://127.0.0.1:%s/custom/%s/gWidgetsWWWRun/%s",
                                                   tools:::httpdPort, url_base,
                                                   ourURLencode(k[1]) # escapes "+"
                                                   )
                     }
                   } else {
                     ## we don't have graphics
                     if(exists("ge",envir=.)) {
                       delete(.$graphics,.$ge) # just remove
                       .$ge <- NULL
                     }
                   }
                   
                   ## make a new cell
                   if(.$parent$no_cells() <= .$parent$get_cell_index(.))
                     .$parent$new_cell()
                   
                   
                 })
  
  NotebookCells <- proto(
                         ##' list containing cells
                         cells=list(),
                         add_cell=function(., cell) {
                           tmp <- .$cells
                           tmp <- c(tmp, cell)
                           .$cells <- tmp
                         },
                         init=function(., container, width=width) {
                           .$container <- ggroup(container=container, width=width, expand=TRUE, spacing=0)
                           ## b <- gbutton("New cell", cont=.$container, handler=function(h,...) {
                           ##   . <- h$action
                           ##   .$new_cell()
                           ## }, action=.)
                         },
                         ##' make new cell
                         new_cell=function(., i) {
                           if(missing(i))
                             i <- length(.$cells) + 1
                           newCell <- aCell$proto()
                           newCell$new(., .$container, i)
                           .$add_cell(newCell)
                         },
                         ##' return cell by index
                         get_cell = function(., i) {
                           if(is.numeric(i)) {
                             .$cells[[i]]
                           } else {
                             ## i is a cell object
                             ind <- sapply(.$cells, function(j) j$identical(i))
                             if(length(ind))
                               .$cells[[which(ind)]]
                             else
                               NULL
                           }
                         },
                         get_cell_index =function(., cell) {
                           ind <- sapply(.$cells, function(j) {
                             j$identical(cell)
                           })
                           which(ind)
                         },
                         ##' remove cell by index
                         remove_cell=function(., i) {
                           cell <- .$get_cell(i)
                           cell$remove()
                           l <- .$cells
                           l[[i]] <- NULL
                           .$cells <- l
                         },
                         ## move to cell by index
                         move_to_cell=function(., i) {
                           cell <- .$get_cells(i)
                           focus(cell$cmdBox) <- TRUE
                         },
                         ## how many cells
                         no_cells=function(.) length(.$cells)
                         )
  
  
  nb <- NotebookCells$proto()
  nb$init(container=container, width=width)
  nb$new_cell()

  ## return notebook. No gWidgets methods defined though
  nb
}
#line 1 "d:/RCompile/CRANpkg/local/2.13/gWidgetsWWW/R/gdf.R"
##  Copyright (C) 2010 John Verzani
##
##  This program is free software; you can redistribute it and/or modify
##  it under the terms of the GNU General Public License as published by
##  the Free Software Foundation; either version 2 of the License, or
##  (at your option) any later version.
##
##  This program is distributed in the hope that it will be useful,
##  but WITHOUT ANY WARRANTY; without even the implied warranty of
##  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
##  GNU General Public License for more details.
##
##  A copy of the GNU General Public License is available at
##  http://www.r-project.org/Licenses/


## use EditorGridView to edit a data frame

## working

## svalue
## transport
## click and double click handler
## icon fun: use class(icon) to mark
## multiple is working
## [<- : needs to have data frame with same column types, no. of columns

## get working:
## names<-, names for headers
## integrate -- filter fun: maybe never

     
gdf <- function(items = NULL, name = deparse(substitute(items)),
                do.subset = FALSE,
                container = NULL, ...,
                width=200, height=200   # gWidgetsWWW defaults
                ) {

  
  widget <- EXTComponentDfStore$new(toplevel=container$toplevel,
                                      ..name = name,
                                      ..do.subset = do.subset,
                                    ..width = width,
                                    ..height= height
                                      )
  class(widget) <- c("gDf",class(widget))



  
  ## set up store
  store <- EXTStore$new(toplevel=container$toplevel)
  store$ID <- container$newID()       # set ID

  ## load in items
  if(!is.data.frame(items)) items <- as.data.frame(items)
  
  store$data <- items
  widget$..store <- store
  widget$..data <- numeric(0)           # we store indices
  ## set up widget


  widget$assignValue <- function(., value) {
    ## assign value. Here values i list value, row, column
    coerceValue <- function(x, value) UseMethod("coerceValue")
    coerceValue.default <- function(x, value) format(value)
    coerceValue.character <- function(x, value) as.character(value)
    coerceValue.integer <- function(x, value) as.integer(value)
    coerceValue.numeric <- function(x, value) as.numeric(value)
    coerceValue.logical <- function(x, value)  as.logical(toupper(value))
    coerceValue.factor <- function(x, value) ifelse(value %in% levels(x), value, NA)
  

    df <- .$..store$data
    i <- as.numeric(value[[2]])
    j <- as.numeric(value[[3]])
    val <- value[[1]]
    df[i,j] <- coerceValue(df[[j]], val)
    .$..store$data <- df
  }

  ## return data frame
  widget$getValues <- function(., ...) {
    items <- .$..store$data
    return(items)
  }

  ## transport
  widget$transportSignal <- c("afteredit")
  widget$transportValue <- function(.,...) {
    ## XXX use id.row.col <- value to update cell
  }
  widget$writeTransport <- function(.,ext="",signal=NULL) {
  ## transport to R
    ## We have rowIndex, colIndex and value to work with here
    ## write to id.row.col

    out <- String() +
      sprintf("_transportToR('%s', Ext.util.JSON.encode({value:e.value,row:e.row + 1, column:e.column+1}));", .$ID)
    return(out)
  }

  widget$ExtConstructor <- "Ext.grid.EditorGridPanel"
  widget$ExtCfgOptions <- function(.) {
    out <- list(store = String(.$..store$asCharacter()),
                columns = String(.$makeColumnModel()),
                stripeRows = TRUE,
                frame = FALSE
                ) ## also autoExpandColumn, XXX
    if(.$..name != "")
      out[["title"]] <- .$..name
    
    ## size in panel config, not setStyle
    if(exists("..width",envir = .,inherits=FALSE))
      out[["width"]] <- .$..width
    else
      out[["width"]] <- "auto"
    
    if(exists("..height",envir = .,inherits=FALSE))
      out[["height"]] <- .$..height
    else
        out[["height"]] <- "auto"
    
    return(out)
  }

  ## The map editor
  widget$mapEditor <- function(., x) {
    type <- class(x)[1]
    switch(type,
           "integer" = ",editor: new Ext.form.NumberField({allowBlank: true,allowDecimals: false,nanText: 'NA'})",
           "numeric" = ",editor: new Ext.form.NumberField({allowBlank: true,allowDecimals: true,nanText: 'NA'})",
           "logical" = String(",editor:") + "new Ext.form.ComboBox({typeAhead: true,editable: false,triggerAction: 'all',store: ['true','false'],lazyRender:true,listClass: 'x-combo-list-small'})",
           "factor" = String(",editor:") + "new Ext.form.ComboBox({typeAhead: true,editable: false,triggerAction: 'all',store: [" + paste(shQuote(levels(x)),collapse=",") + "],lazyRender:true,listClass: 'x-combo-list-small'})",
           "date" = "",               # we create this?
           ",editor: new Ext.form.TextField()") # default is text
  }

  widget$makeColumnModel <- function(.) {
    ## return array for columns
    ## id, header, sortable, renderer, dataIndex, tooltip
##     columns: [
##               {id:'company',header: "Company", sortable: true, dataIndex: 'company'},
##               {header: "Price",  sortable: true, renderer: 'usMoney', dataIndex: 'price'},
##               {header: "Change", sortable: true, renderer: change, dataIndex: 'change'},
##               {header: "% Change", sortable: true, renderer: pctChange, dataIndex: 'pctChange'},
##               {header: "Last Updated", sortable: true, renderer: Ext.util.Format.dateRenderer('m/d/Y'), dataIndex: 'lastChange'}
##               ],


    df <- .$..store$data
    editors <- sapply(df, function(i) .$mapEditor(i))
    colNames <- names(df)
    colNames <- shQuoteEsc(colNames)

    
    tmp <- paste('{',
                 'id:',colNames,
                 ', header:',colNames,
                 ', sortable:true',
                 if(!.$has_slot("..columnWidths")) "" else 
                        sprintf(", width: %s",rep(.$..columnWidths, length.out=ncol(df))),
                 ', dataIndex:',colNames,
                 editors,
                 '}',
                 sep="")
    out <- paste('[\n', paste(tmp,collapse=",\n"), ']', collapse="")

    return(out)
  }
  widget$makeFields <- function(.) {
    ## return something like this with name, type
    ##     fields: [
    ##            {name: 'company'},
    ##            {name: 'price', type: 'float'},
    ##            {name: 'change', type: 'float'},
    ##            {name: 'pctChange', type: 'float'},
    ##            {name: 'lastChange', type: 'date', dateFormat: 'n/j h:ia'}
    ##         ]
    ## types in DataField.js
    mapTypes <- function(type) {
      switch(type,
             "character"="",
             "String" = ",type: 'string'",
             "integer" = ",type: 'int'",
             "numeric" = ",type: 'float'",
             "logical" = ",type: 'boolean'",
             "factor"  = "",
             "date" = ",type:date",
             "")
    }
    df <- .$..store$data
    types <- sapply(df, function(i) mapTypes(class(i)[1]))
    colNames <- shQuoteEsc(names(df))
    tmp <- paste("{name:", colNames, types, "}", sep="")
    out <- paste("[",tmp,"]", collapse="\n")

    return(out)
  }

  widget$footer <- function(.) {}
  
  
  ###
  container$add(widget,...)

  ## handler definitions
  widget$addHandlerChanged <- function(., handler, action = NULL, ...)
    .$addHandler(signal = "afteredit", handler, action=action, ...)
  
  invisible(widget)
  
}
#line 1 "d:/RCompile/CRANpkg/local/2.13/gWidgetsWWW/R/gedit.R"
##  Copyright (C) 2010 John Verzani
##
##  This program is free software; you can redistribute it and/or modify
##  it under the terms of the GNU General Public License as published by
##  the Free Software Foundation; either version 2 of the License, or
##  (at your option) any later version.
##
##  This program is distributed in the hope that it will be useful,
##  but WITHOUT ANY WARRANTY; without even the implied warranty of
##  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
##  GNU General Public License for more details.
##
##  A copy of the GNU General Public License is available at
##  http://www.r-project.org/Licenses/


## gedit
## svalue works
## svalue<- works
## autocomplete code not in Ext??? Use gcombobox for that.
## add handlerKeyPress works but value is the keycode (ASCII?) not the character
## change handler called after change and losing focus.

##' gedit widget
##'
##' No [<- method. This can be done with a combobox though.
##' @param text initial text
##' @param width width in characters. Converted to pixels by multiplying by 8.
##' @param coerce.with Function to call for coercion from text. If no
##' coercion be careful when using the values, as the user can potentiall type in malicious things.
##' @param handler Change handler. Change is a "blur" event (when widget loses focus) and when key is activated.
##' @param action passed to handler
##' @param container parent container
##' @param ... passed to add method of parent container
gedit <- function (text = "", width = 25, coerce.with = NULL,
                   handler = NULL,  action = NULL, container = NULL, ...) {
  
  widget <- EXTComponentText$new(toplevel=container$toplevel,
                             ..width = width * 8, # 8 pixels per character?
                           ..coerce.with=coerce.with)
  class(widget) <- c("gEdit",class(widget))
  widget$setValue(value=text)
  

  ## CSS

  ## Scripts

  ## methods
  widget$getValueJSMethod = "getValue"
  widget$setValueJSMethod = "setValue"
  widget$transportSignal <- "change"
#  widget$transportSignal <- "keyup" ## this gets sent too often, but will addHandlerKeystroke work w/o?
  widget$ExtConstructor <- "Ext.form.TextField"
  widget$ExtCfgOptions <- function(.) {
    out <- list("value"= svalue(.),
                "enableKeyEvents"= TRUE)
    if(exists("..width", ., inherits=FALSE))
      out[['width']] <- .$..width
    return(out)
  }



  ## add after CSS, scripts defined
  container$add(widget,...)


  if(!is.null(handler))
    widget$addHandler("change",handler=handler,action=action)
  
  invisible(widget)
}

#line 1 "d:/RCompile/CRANpkg/local/2.13/gWidgetsWWW/R/gfile.R"
##  Copyright (C) 2010 John Verzani
##
##  This program is free software; you can redistribute it and/or modify
##  it under the terms of the GNU General Public License as published by
##  the Free Software Foundation; either version 2 of the License, or
##  (at your option) any later version.
##
##  This program is distributed in the hope that it will be useful,
##  but WITHOUT ANY WARRANTY; without even the implied warranty of
##  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
##  GNU General Public License for more details.
##
##  A copy of the GNU General Public License is available at
##  http://www.r-project.org/Licenses/


## XXX only for local

##' File selection function
##'
##' This allows a local user to select a file. It does not do file
##' upload (yet!).  The \code{svalue} method only returns the
##' filename, not the path to the file. The behaviour under some
##' browser, such as Chrome, actually puts in a fakepath.
##' @param text Instructional text. Ignored.
##' @param type only "open" implemented
##' @param filter ignored
##' @param handler called when file is selected
##' @param action passed to handler
##' @param container parent container
##' @param ... passed to add method of parent container
gfile <- function(text="Choose a file",
                  type = c("open"),
                  filter = NULL, 
                  handler = NULL, action = NULL, container = NULL, ...) {

  if(!gWidgetsWWWIsLocal())
    stop("Not for non-local user")

  
  widget <- EXTComponentNoItems$new(toplevel=container$toplevel,
                             ..text = text, ..type=type, ..filter=filter
                             )
  class(widget) <- c("gFile", class(widget))
  widget$setValue(value="")             # empty, set on fileselected
  widget$..width <- getFromDots(..., var="width", default=300) # width is funny

  widget$emptyText <- text;#'select a file'
  widget$buttonText <- 'Browse...'
  
  ## CSS
  widget$css <- function(.) {
    out <- paste(
                 ## from http://www.extjs.com/deploy/dev/examples/form/file-upload.html
                 ##                 "/*",
                 ##                 "* FileUploadField component styles",
                 ##                 "*/",
                 ".x-form-file-wrap {",
                 "position: relative;",
                 "height: 22px;",
                 "}",
                 ".x-form-file-wrap .x-form-file {",
                 "position: absolute;",
                 "right: 0;",
                 "-moz-opacity: 0;",
                 "filter:alpha(opacity: 0);",
                 "opacity: 0;",
                 "z-index: 2;",
                 "height: 22px;",
               "}",
                 ".x-form-file-wrap .x-form-file-btn {",
                 "position: absolute;",
                 "right: 0;",
                 "z-index: 1;",
               "}",
                 ".x-form-file-wrap .x-form-file-text {",
                 "position: absolute;",
                 "left: 0;",
                 "z-index: 3;",
                 "color: #777;",
               "}",
                 sep=" ")
    return(out)
  }
                 
  ## methods
  widget$getValueJSMethod <- "getValue"
  widget$setValueJSMethod <- "setValue"
#  widget$ExtConstructor <- "Ext.ux.form.FileUploadField"
  
  widget$transportSignal <- c("fileselected")
  widget$transportValue <- function(.,...) {
    out <- 'var value = s;'
    return(out)
  }

widget$ExtConstructor <- "Ext.FormPanel"
widget$ExtCfgOptions <- function(.) {
  out <- list(fileUpload=TRUE,
                                      #                height=30,
              frame=FALSE,
              autoHeight=TRUE,
              items=list(
                xtype='fileuploadfield',
                width=.$..width,
                empytText=.$emptyText,
                buttonText=.$buttonText
                )
              )
  return(out)
}

widget$asCharacterPanelName <- function(.) .$asCharacter() + "Panel"
widget$..writeConstructor <- function(.) {
  out <- String() +
    sprintf("%s = %s.getComponent(0);", .$asCharacter(), .$asCharacterPanelName())
}


  

  ## add after CSS, scripts defined
  container$add(widget,...)
  
  widget$addHandlerChanged <- function(., handler, action=NULL) 
    .$addHandler("fileselected",handler=handler,action=action)
  
  if(!is.null(handler))
    widget$addHandlerChanged(handler, action)
  
  invisible(widget)
}

#line 1 "d:/RCompile/CRANpkg/local/2.13/gWidgetsWWW/R/gformlayout.R"
##  Copyright (C) 2010 John Verzani
##
##  This program is free software; you can redistribute it and/or modify
##  it under the terms of the GNU General Public License as published by
##  the Free Software Foundation; either version 2 of the License, or
##  (at your option) any later version.
##
##  This program is distributed in the hope that it will be useful,
##  but WITHOUT ANY WARRANTY; without even the implied warranty of
##  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
##  GNU General Public License for more details.
##
##  A copy of the GNU General Public License is available at
##  http://www.r-project.org/Licenses/

## use gformlayout from gWidgets -- which was inspired by extjs fieldset
## changes should synchronize with gWidgets file

## helper functions
.makeForm <- function(., lst, parent, ...) {
  g <- ggroup(cont = parent, expand=TRUE,...)

  ## make a local copy of lst and modify for do.call
  tmp <- lst;
  tmp$name <- tmp$type <- tmp$children <- NULL
  tmp$depends.on <- tmp$depends.FUN <- tmp$depends.signal <- NULL
  tmp$container <- g; tmp$expand <- TRUE
  ## expand functions
  for(i in names(tmp)) {
    if(is.function(tmp[[i]]))
      tmp[[i]] <- tmp[[i]]()
  }
  
  ## treat fieldset differently
  if(lst$type == "fieldset") {
    .$makeFieldset(lst, g, label = lst$label, width=lst$width, height=lst$height)
    return()
  } else {  
    ## make object
    ## evaluate quoted functions
    tmp <- lapply(tmp, function(i) if(is.name(i)) eval(i)() else i)
    newObject <- do.call(lst$type, tmp)
    ## store if a name is given
    if(!is.null(lst$name)) {
      tmp <- .$..widgets
      tmp[[lst$name]] <- newObject
      .$..widgets <- tmp
    }
    ## do we enable new object
    if(!is.null(lst$depends.on)) {
      widget <- .$..widgets[[lst$depends.on]]
      if(is.null(lst$depends.signal))
        lst$depends.signal <- "addHandlerChanged"
      do.call(lst$depends.signal,list(obj=widget, handler =  function(h,...) {
        value <- svalue(h$obj)
        enabled(newObject) <- lst$depends.FUN(value)
      }))
      enabled(newObject) <- lst$depends.FUN(svalue(widget))
    }
  }
   


  
  ## show children if there
  ## this recurses except on "fieldset"
  if(!is.null(lst$children)) {
    for(i  in 1:length(lst$children)) {
      l <- lst$children[[i]]
      if(l$type == "fieldset") {
        if(lst$type == "gnotebook")
          .$makeFieldset(l, newObject, label = l$label)
        else
          .$makeFieldset(l, newObject, width = l$width, height = l$height)
      } else {
        if(lst$type == "gnotebook")
          .$makeForm(l, newObject, label = l$label)
        else
          .$makeForm(l, newObject)
      }
    }
  }
}


## fieldset does not recurse
.makeFieldset <- function(., lst, parent, width=NULL, height=NULL, ...) {
  ## parent is parent container
  ## lst is list as above

  
  ## outer container
  if(!is.null(lst$label)) 
    g <- gframe(lst$label, cont=parent, width=width, height=height,...)
  else
    g <- ggroup(cont=parent,  width=width, height=height, ...)
  ## main table
  tbl <- glayout(cont = g)
  
  ## do we enable new object
  if(!is.null(lst$depends.on)) {
    widget <- .$..widgets[[lst$depends.on]]
    if(is.null(lst$depends.signal))
      lst$depends.signal <- "addHandlerChanged"
    do.call(lst$depends.signal, list(obj = widget,handler = function(h,...) {
      value <- svalue(h$obj)
      enabled(g) <- lst$depends.FUN(value)
    }))
    enabled(g) <- lst$depends.FUN(svalue(widget))
  }
  
  ## fix label adjust
  if(is.null(lst$label.pos))
    lst$label.pos <- "left"
  if(lst$label.pos == "top") {
    label.anchor <- c(-1,0)
  } else {
    if(is.null(lst$label.just) || lst$label.just == "left")
      label.anchor <- c(-1,1)
    else if(lst$label.just == "center")
      label.anchor <- c(0,1)
    else
      label.anchor <- c(1,1)
  }
  
  if(is.null(lst$columns)) 
    no.columns <- 1
  else
    no.columns <- lst$columns
  
  ## add children
  for(i in 1:length(lst$children)) {
    l <- lst$children[[i]]
    ## each child is a list with name, label, type, then arguments
    ## make new list for do.call
    tmp <- l;
    tmp$name <- tmp$label <- tmp$type <- NULL
    tmp$depends.on <- tmp$depends.FUN <- tmp$depends.signal <- NULL
    tmp$container <- tbl

    newWidget <- do.call(l$type, tmp)

    ## store
    if(!is.null(l$name)) {
      tmp <- .$..widgets
      tmp[[l$name]] <- newWidget
      .$..widgets <- tmp
    }
    ## do we enable new object
    if(!is.null(l$depends.on)) {
      widget <- .$..widgets[[l$depends.on]]
      if(is.null(l$depends.signal))
        l$depends.signal <- "addHandlerChanged"
      do.call(l$depends.signal, list(obj = widget, handler =  function(h,...) {
        value <- svalue(h$obj)
        enabled(newWidget) <- l$depends.FUN(value)
      }))
      enabled(newWidget) <- l$depends.FUN(svalue(widget))
    }

    
    ## add to table
    col <- 1 + (i - 1) %% no.columns    #1, ..., no.columns
    row <- 1 + (i - 1) %/% no.columns   #1, ...
    newLabel <- glabel(l$label, cont = tbl)
    if(!is.null(lst$label.font))
      font(newLabel) <- lst$label.font
    if(is.null(lst$label.pos) || lst$label.pos == "left") {
      tbl[row, 2 * (col - 1) + 1, anchor=label.anchor] <- newLabel
      if(l$type %in% c("gcombobox","gdroplist"))
        tbl[row, 2 * (col - 1) + 2, anchor=c(-1,1), expand=TRUE] <- newWidget
      else
        tbl[row, 2 * (col - 1) + 2, anchor=c(-1,1)] <- newWidget
    } else {
      tbl[2 * (row - 1) + 1, col, anchor=label.anchor] <- newLabel
      if(l$type %in% c("gcombobox","gdroplist"))
        tbl[2 * (row - 1) + 2, col, anchor=c(-1,1), expand=TRUE] <- newWidget
      else
        tbl[2 * (row - 1) + 2, col, anchor=c(-1,1)] <- newWidget
    }
  }
}



gformlayout <- function(lst, container = NULL, ...) {
  obj <- ggroup(cont = container, ...)
  g <- ggroup(cont = obj, expand=TRUE)

  class(obj) <- c("gFormLayout",class(obj))

  obj$..widgets <- list()
  obj$makeForm <- .makeForm
  obj$makeFieldset <- .makeFieldset

  obj$makeForm(lst, g)

  obj$getValue <- function(., index=NULL, drop=NULL)
    return(lapply(.$..widgets, svalue))
  obj$getNames <- function(.)
    return(names(.$..widgets))
  
  
  return(obj)
}
#line 1 "d:/RCompile/CRANpkg/local/2.13/gWidgetsWWW/R/ggooglemaps.R"
##  Copyright (C) 2010 John Verzani
##
##  This program is free software; you can redistribute it and/or modify
##  it under the terms of the GNU General Public License as published by
##  the Free Software Foundation; either version 2 of the License, or
##  (at your option) any later version.
##
##  This program is distributed in the hope that it will be useful,
##  but WITHOUT ANY WARRANTY; without even the implied warranty of
##  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
##  GNU General Public License for more details.
##
##  A copy of the GNU General Public License is available at
##  http://www.r-project.org/Licenses/

## DEPRECATED

## Simple interface to googlemaps

## Can show a map with some programmatic markup possible
## The API key is set in the RApache configuration.
## the key comes from google : http://code.google.com/apis/maps

## XXX The handler code is not currently working. XXX

## see the footer for ideas on how to access GMap2 API
## Use obj[,] <- data.frame(lat,long,title) to set markers
## * markers: [geoCodeAddr], [geoCodeAddr, title], [lat, long], [lat,long,title]

## center and markers set *prior* to rendering. No methods after (possible, not done)


ggooglemaps <- function(x, title = "",  type = c("map","panorama"),
                        key="ABQIAAAAYpRTbDoR3NFWvhN4JrY1ahS5eHnalTx_x--TpGz1e2ncErJceBS7FrNBqzV5DPxkpbheIzZ9nTJPsQ", # for 127.0.0.1:8079; only for local. For server, set in RApache.conf
                        container, ...) {
  
  return(glabel("XXX This needs updating to version 3 of ggoglemaps", cont=container))

  
  widget <- EXTComponent$new(toplevel=container$toplevel,
                             ..title = title,
                             ..key = key,
                             ..gmapType = match.arg(type))
  class(widget) <- c("gGoogleMap",class(widget))
  widget$toplevel$ggooglemaps_key <- key
  
  widget$setValue(value = x)
  ## default is 0-row set of marks
  widget$setValues(value = data.frame(lat=0,long=0,title="")[0,])
  widget$..runCmds <- c()
  

  ## widget$scripts <- function(.) {
  ##   ## we run this on creation. We also set key here:
  ##   ## works for local
  ##   ## server has key set in RApache.conf
  ##   options(gWidgetsWWWGoogleAPI=.$..key)

    
  ##   f <- system.file("javascript","GMapPanel.js", package="gWidgetsWWW")
  ##   out <- paste(readLines(f), collapse="\n")
    
  ##   return(out)
  ## }

  ## svalue -- location of map
  ## [] -- extra markers specified by lat and long vector. Names of vector gives
  ##       title attribute


  ## markers are set with a data frame.
  ## [geoCodeAddr]
  ## [geoCodeAddr, title] ## first col is non-numeric
  ## [lat, long]
  ## [ lat, long, title]
 
widget$makeMarkers <- function(.) {
    values <- .$getValues()
    out <- String("")
    if(nrow(values) > 0) {
      if(ncol(values) == 1) {
        ## geoCodeAddr
        out <- paste("{ geoCodeAddr:",shQuoteEsc(values[,1]),
                     "}",
                     collapse=",")
      } else if(ncol(values) == 2) {
        if(!is.numeric(values[,1])) {
          ## geoCodeAddr, title
          out <- paste("{ geoCodeAddr:",shQuoteEsc(values[,1]),",",
                       "marker:{title:", shQuoteEsc(values[,2]),"}",
                       "}",
                       collapse=",")
        } else {
          ## no title, lat and long
          out <- paste("{ lat:",values[,1],",'long':",values[,2],
                       '}',
                       collapse=",")
        }
      } else {
        out <- paste("{ lat:",values[,1],",'long':",values[,2],",",
                     "marker:{title:", shQuoteEsc(values[,3]),"}",
                     "}",
                     collapse=",")
      }
      
    }
    return(String("[") + out + "]")
  }

  ## XXX set defaults for width and height -- doesn't like auto
  widget$..width <- 600
  widget$..height <- 400
  ## can override
  widget$..zoomLevel <- 14

  
  widget$makeMapCommands <- function(.) {
    lst <- list(xtype = "gmappanel",
                region = "center",
                zoomLevel = .$..zoomLevel,
                gmapType = .$..gmapType,
                width = .$..width,
                height = .$..height #,
#                addControl = String("new GSmallMapControl()")
                )
    val <- svalue(.)
    if(length(val) == 1) {
      lst[["setCenter"]] = list(
           geoCodeAddr = val,
           marker = list(title = .$..title)
           )
    } else {
      lst[["setCenter"]] = list(
           lat = val[1],
           long = val[2],
           marker = list(title = .$..title)
           )
    }

    if(length(.$getValues()) > 0)
      lst[["markers"]] <- .$makeMarkers()

    return(.$mapRtoObjectLiteral(lst))

  }
  widget$ExtConstructor <- "Ext.Panel"
  widget$ExtCfgOptions <- function(.) {
    ## out <- list(autoLoad=String('http://www.google.com/jsapi?key=' +
    ##               getOption("gWidgetsWWWGoogleAPI" + '"></script>' +
    ##       '<script type="text/javascript">  google.load("maps", "2"); </script>' + '\n'

    out <- list(items = .$makeMapCommands())
                  
    return(out)
  }
  ## this is an exampe of a footer
  ## more API at http://code.google.com/apis/maps/documentation/reference.html#GMap2
  widget$footer <- function(.) {
    out <- String() +
      ## how to get the map
      .$setgmapID() +
        .$gmapID() + '.enableGoogleBar();' +
          .$gmapID() + '.enableScrollWheelZoom();'

    if(length(.$..runCmds)) {
      for(i in .$..runCmds) out <- out + i
    }

    return(out)
  }

  widget$setValueJS <- function(., ...) {
    value <- svalue(.)
    if(length(value) == 2)
      .$panTo(value)
  }
  widget$setValuesJS <- function(.,...) {
    if(exists("..setValuesJS", envir=., inherits=FALSE)) .$..setValuesJS(...)
  
    values <- .$getValues()
    for(i in 1:nrow(values))
      widget$addMarker(values[i,3:4])
    
  }

  
  ## some non-gWidgets methods to access *some* of the google maps API

  ## return bounds of map
  ## write bounds in a transport function
  widget$setgmapID <- function(.) {
    out <- String() +
      'gmap' + .$ID +' = ' + 'o' + .$ID + '.getComponent(0).gmap;'
    return(out)
  }
  widget$gmapID <- function(.) {
    out <- String() +
      'gmap' + .$ID
    return(out)
  }

  ## bounds
  ## javascript transport to write bounds
  widget$transportBounds <- function(.) {
    out <- String() +
      .$setgmapID() +
        'var bounds = ' + .$gmapID() + '.getBounds();' +
          '_transportToR("' + .$ID + '.SouthWest",' +
            '{value:bounds.getSouthWest().toString()});' +
              '_transportToR("' + .$ID + '.NorthEast",' +
                '{value:bounds.getNorthEast().toString()});'
    return(out)
  }

  widget$getBounds <- function(.) {
    pat.sw = String(.$ID) + '.SouthWest'
    pat.ne = String(.$ID) + '.NorthEast'

    sw <- unlist(pat.sw[3:4])
    ne <- unlist(pat.ne[3:4])

    ## return
    list(southwest = sw, northeast = ne)
  }

  ## set center
  ## latlng <- c(lat=xxx, lng = yyy)
  widget$panTo <- function(., latlng) {
    out <- String() +
      .$setgmapID() +
        .$gmapID() + '.panTo(' +
          'new GLatLng(' + latlng[1] + ',' + latlng[2] + '));'

    if(exists("..shown", envir=., inherits = FALSE))
      .$addJSQueue(out)
    else
      .$setValue(value = latlng)
  }
  ## zoom in or out
  widget$setZoom <- function(., zoom=14) {
    out <- String() +
      .$setgmapID() +
        .$gmapID() + '.setZoom(' + zoom + ');'

    if(exists("..shown", envir=., inherits = FALSE))
      .$addJSQueue(out)
    else
      .$..zoomLevel <- zoom

  }

  ## popup a message at a point
  widget$openInfoWindow <- function(., latlng, myHTML) {
    out <- String() +
      .$setgmapID() +
        'var point = new GLatLng(' + latlng[1] + ',' + latlng[2] + ');' +
          .$gmapID() + '.openInfoWindow(point,' +
            shQuoteEsc(myHTML) + ');'

    if(exists("..shown", envir=., inherits = FALSE))
      .$addJSQueue(out)
    else
      .$..runCmds <- c(.$..runCmds, out)
  }

  ## methods to add to map: marker, Polyline, Polygon
  
  ## addMarker
  widget$addMarker <- function(., latlng, title="", draggable = FALSE) {

    ## append to markers
    marks <- .$getValues()
    if(nrow(marks) == 0) {
      marks <- data.frame(latlng[1], latlng[2], latlng[3], latlng[4], title)
    } else {
      n <- nrow(marks)
      marks[n+1, 1:4] <- unlist(latlng)
      if(ncol(marks) == 5)
        marks[n+1, 5] <- title
    }
    .$..values <- marks                 # bypass setValues, as it would recurse

    ## make JS
    lst <- list(draggable = draggable)
    if(title != "")
      lst[["title"]] <- title
    out <- String() +
      .$setgmapID() +
        'var point = new GLatLng(' + latlng[1] + ',' + latlng[2] + ');' +
          'var marker = new GMarker(point,' +
            .$mapRtoObjectLiteral(lst) +
              ');'
    if(draggable) {
      ##     ## add handlers
      out <- out +
        'GEvent.addListener(marker, "dragstart", function() {' +
          .$gmapID() + '.closeInfoWindow();' +
            '});'
      
      ## XXX dragend should also update marks position
      out <- out +
        'GEvent.addListener(marker, "dragend", function() {' +
          'myHtml = "new latitude and longitude:<br>" + this.getLatLng().toString();' +
            'this.openInfoWindowHtml(myHtml);' +
              '});'
    }

    out <- out +
      .$gmapID() + '.addOverlay(marker);'
    
    if(exists("..shown", envir=., inherits = FALSE))
      .$addJSQueue(out)
    else
      .$..runCmds <- c(.$..runCmds, out)
  }

  ## polyLine
  ## latlng matrix or data frame of lat and lng
  widget$addPolyline <- function(., latlng,
                                 color="#ff0000", pixel.width = 5, opacity=1) {
    if(missing(latlng))
      latlng <- .$getValues()
    if(! (is.matrix(latlng) || is.data.frame(latlng))) return()
    if(nrow(latlng) == 0) return()
    
    out <- String() +
      .$setgmapID() +
        'var polyline = new GPolyline(['
    tmp <- c()
    for(i in 1:nrow(latlng))
      tmp[i] <- String("new GLatLng(") +
        latlng[i,1] + ',' + latlng[i,2] + ')'

    out <- out + paste(tmp, collapse=", ") +
      '], ' + shQuote(color) + ',' + pixel.width + ',' + opacity +
        ', {clickable: true, geodesic: true}' +
        ');'
    ## add a handler to show length
     out <- out +
       'GEvent.addListener(polyline, "click", function(latlng) {' +
         'var dist = (this.getLength()/1000).toFixed(2);' +
           'myHtml = "length (meters):<br>" + dist.toString();' +
             .$gmapID() + '.openInfoWindowHtml(latlng, myHtml);' +
              '});'
    
    out <- out +
      .$gmapID() + '.addOverlay(polyline);'

    if(exists("..shown", envir=., inherits = FALSE))
      .$addJSQueue(out)
    else
      .$..runCmds <- c(.$..runCmds, out)
  }
    
        

  ## drawPolygon
  widget$addPolygon <- function(., latlng,
                                border.color="#ff0000", border.pixel.width = 5,
                                border.opacity = 1,
                                region.color = "#000000", region.opacity = .1
                                ) {

    if(missing(latlng))
      latlng <- .$getValues()
    if(! (is.matrix(latlng) || is.data.frame(latlng))) return()
    if(nrow(latlng) == 0) return()
    

    out <- String() +
      .$setgmapID() +
        'var polygon = new GPolygon(['
    tmp <- c()
    for(i in 1:nrow(latlng))
      tmp[i] <- String("new GLatLng(") +
        latlng[i,1] + ',' + latlng[i,2] + ')'
    ## terminate
    tmp[nrow(latlng) + 1] <- String("new GLatLng(") +
        latlng[1,1] + ',' + latlng[1,2] + ')'

    out <- out + paste(tmp, collapse=", ") +
      '], ' +
        shQuote(border.color) + ',' + border.pixel.width + ',' +
          border.opacity +
            ',' + shQuote(region.color) + ',' + region.opacity +
              ');'

    ## add a handler to show area
     out <- out +
       'GEvent.addListener(polygon, "click", function(latlng) {' +
         'var area = (this.getArea()/(1000*1000)).toFixed(2);' +
           'myHtml = "Area (sq. kms):<br>" + area.toString();' +
             .$gmapID() + '.openInfoWindowHtml(latlng, myHtml);' +
               '});'

    
    out <- out +
      .$gmapID() + '.addOverlay(polygon);'

    if(exists("..shown", envir=., inherits = FALSE))
      .$addJSQueue(out)
    else
      .$..runCmds <- c(.$..runCmds, out)
  }
    

  ## ???

  ## handlers -- these call back into R.
  ## this should work for click and dblclick
  widget$writeHandlerJS <- function(., signal, handler=NULL) {
    out <- String() +
      .$setgmapID() +
        'GEvent.addListener(' + .$gmapID() + ',' + shQuote(signal) +
          ',function(overlay, point) {' +
            ## transport bounds
            'var bounds = ' + .$gmapID() + '.getBounds();' +
              'var SW = bounds.getSouthWest();' +
                'var NE = bounds.getNorthEast();' +
                  '_transportToR("' + .$ID + '.SouthWest",Ext.util.JSON.encode({value:SW}));' +
                    '_transportToR("' + .$ID + '.NorthEast",Ext.util.JSON.encode({value:NE}));' +
                      'runHandlerJS(' + handler$handlerID + ',Ext.util.JSON.encode({latlng:point}))' +
                        '});'
    return(out)
  }

  
  container$add(widget, ...)
  invisible(widget)

}
#line 1 "d:/RCompile/CRANpkg/local/2.13/gWidgetsWWW/R/ggroup.R"
##  Copyright (C) 2010 John Verzani
##
##  This program is free software; you can redistribute it and/or modify
##  it under the terms of the GNU General Public License as published by
##  the Free Software Foundation; either version 2 of the License, or
##  (at your option) any later version.
##
##  This program is distributed in the hope that it will be useful,
##  but WITHOUT ANY WARRANTY; without even the implied warranty of
##  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
##  GNU General Public License for more details.
##
##  A copy of the GNU General Public License is available at
##  http://www.r-project.org/Licenses/

## Box Containers for gWidgetsWWW
##
## The container code in Ext is very similar.
## All use Ext.Panel with some different configuration options
## this code tries to take advantage of that  by introducing some sub"traits".
## the tricky thing is the call up to ExtCfgOptions from the inherited trait.
## just calling with .super didn't work

EXTPanel <- EXTContainer$new()
EXTPanel$ExtConstructor <- "Ext.Panel"



EXTGroup <- EXTPanel$new(children=list())
EXTGroup$ExtCfgOptions <-  function(.) {
  out <- list(
              border = FALSE,
              hideBorders=TRUE,          # key to getting rid of blud
              collapsed=!.$..visible
              )
  ## We consulted:
  ## http://stackoverflow.com/questions/2479342/problem-with-extjs-vbox-layout-nested-in-a-hbox-layout
  ## There had been an issue and for some odd reason these argument
  ## were a bit fussy -- put in the wrong ones and thewhole thing
  ## blows up. Anyways, these seem to work, although there are issues with some nested ggroup containers.
  if(exists("..horizontal",envir=., inherits=FALSE)) {


    frame <- !is.null(getOption("gWidgetsWWW_debug"))

    if(.$..horizontal) {

      ## was
#      out[['layout']] <- "column"

      out[['layout']] <- "hbox"
      out[['defaults']] <- list(frame=frame, defaultAnchor="t", flex=0)
      
      if(exists("..use.scrollwindow", envir=., inherits=FALSE))
        out[['autoScroll']] <- .$..use.scrollwindow
    } else {

      out[['layoutConfig']] <-  list(type="vbox", pack="start") #, align="stretch")
      out[['defaults']] <- list(flex=0, defaultAnchor="l", frame=frame)

      
      ## This is  wierd -- vbox fails here. What is right for vertical layout
#      out[['layout']] <- "vbox"
#      out[['autoscroll']] <- TRUE
    }
  }
  ## size
  ## out[['autoWidth']] <- TRUE
  if(exists("..width", envir = ., inherits =FALSE))
    out[["width"]] <- .$..width
  if(exists("..height", envir = ., inherits =FALSE))
    out[["height"]] <- .$..height
  spacing <- 10
  if(exists("..spacing", envir=., inherits=FALSE)) spacing <- .$..spacing
##  out[['spacing']] <- spacing
#  out[["bodyStyle"]] = String('{') + 'padding:"' + spacing + 'px"}'
    out[["bodyStyle"]] = list('padding' = String('"') + spacing + 'px"'  )
  return(out)
}
## even group can be made visible/hidden
EXTGroup$setVisibleJS <- function(.) {
  if(exists("..setVisibleJS", envir=., inherits=FALSE))
    .$..setVisibleJS()
  if(.$..visible)
    .$callExtMethod("expand","true")
  else
    .$callExtMethod("collapse","true")
}

EXTGroup$addSpace <- function(., value, horizontal=TRUE, ...) {
  n <- ceiling(value/8)
  ghtml(paste(rep("&nbsp", n), sep="", collapse=""), cont=.)
}
## this is not defined
EXTGroup$addSpring <- function(.) {invisible("")}

##' ggroup is the basic box container
##'
##' Basic box container.
##' Warning: When groups are nested, it may be necessary to
##' set the width of a horizontal box container, as otherwise sibling
##' components to the right of the container will not be displayed.
##' @param horizontal logical. If True a hbox, else a vbox
##' @param spacing spacing between child components
##' @param use.scrollwindow ignored
##' @param container parent container
##' @param ... passed to \code{add} method of parent
##' @example Tests/test-ggroup.R
##' @export
ggroup <- function(horizontal=TRUE, spacing=5, use.scrollwindow = FALSE,
                    container,...) {
   ## a group
  cont <- EXTGroup$new(toplevel = container$toplevel,
                     ..horizontal = horizontal,
                     ..spacing = spacing,
                     ..use.scrollwindow = use.scrollwindow
                     )
  cont$..visible <- TRUE
  
  theArgs <- list(...)
  if(!is.null(theArgs$width)) cont$..width <- theArgs$width
  if(!is.null(theArgs$height)) cont$..height <- theArgs$height

  class(cont) <- c("gGroup",class(cont))
   container$add(cont,...)
   invisible(cont)
 }

##################################################
EXTFrame <- EXTGroup$new(children=list())
EXTFrame$ExtCfgOptions <- function(.) {
  out <- EXTGroup[['ExtCfgOptions']](.)
  out[['title']] <- escapeHTML(svalue(.))
  return(out)
}
EXTFrame$setValueJSMethod = "setTitle"

##' gframe is a title-decorated ggroup box container
##'
##' Use \code{svalue<-} to adjust the title
##' @param text label text
##' @param pos position of label. Ignored?
##' @param horizontal logical. A hbox or vbox?
##' @param container parent container
##' @param ... passed to add method of parent
##' @rdname ggroup
gframe <- function(text = "", pos = 0, horizontal=TRUE, container=NULL,...) {

  cont <- EXTFrame$new(toplevel = container$toplevel,
                    ..horizontal = horizontal)
                    
  cont$..visible <- TRUE

  theArgs <- list(...)
  if(!is.null(theArgs$width)) cont$..width <- theArgs$width
  if(!is.null(theArgs$height)) cont$..height <- theArgs$height

  
  class(cont) <- c("gFrame",class(cont))
  cont$setValue(value=text)
  cont$..pos <- pos

  cont$..ExtCfgOptions <- function(.)
    list(border=TRUE)
  
  container$add(cont,...)  
  invisible(cont)
}

##################################################
EXTExpandGroup <- EXTFrame$new(children=list())
EXTExpandGroup$ExtCfgOptions <- function(.) {
  out <- .super$ExtCfgOptions(.)
  out[['collapsible']] <- TRUE
  out[['titleCollapse']] <- TRUE
  return(out)
}

##' gexpandgroup is a group with trigger icon and label
##'
##' Use \code{svalue<-} to adjust the title. The \code{visible<-}
##' method is used to programatically change display
##' @param text label text
##' @param horizontal logical. Indicates direction children are added
##' @param handler Called when expanded or closed
##' @param action passed to handler
##' @param container parent container
##' @param ... passed to add method of parent
##' @rdname ggroup
##' @export
gexpandgroup <- function(text = "", horizontal = TRUE,
                         handler = NULL, action=NULL,
                         container=NULL, ...) {

  cont <- EXTExpandGroup$new(toplevel=container$toplevel,
                            ..horizontal=horizontal)
  cont$..visible <- TRUE
  
  theArgs <- list(...)
  if(!is.null(theArgs$width)) cont$..width <- theArgs$width
  if(!is.null(theArgs$height)) cont$..height <- theArgs$height

  class(cont) <- c("gExpandgroup",class(cont))
  cont$setValue(value=text)

  cont$..ExtCfgOptions <- function(.) {
    out <- list(border=TRUE)
    out
  }

  if(!is.null(handler))
    addHandlerClicked(cont, handler = handler, action=action)

  container$add(cont,...)    
  invisible(cont)
}
  
#line 1 "d:/RCompile/CRANpkg/local/2.13/gWidgetsWWW/R/ghtml.R"
##  Copyright (C) 2010 John Verzani
##
##  This program is free software; you can redistribute it and/or modify
##  it under the terms of the GNU General Public License as published by
##  the Free Software Foundation; either version 2 of the License, or
##  (at your option) any later version.
##
##  This program is distributed in the hope that it will be useful,
##  but WITHOUT ANY WARRANTY; without even the implied warranty of
##  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
##  GNU General Public License for more details.
##
##  A copy of the GNU General Public License is available at
##  http://www.r-project.org/Licenses/

## Show marked up text -- or show url
## svalue<- only works for urls, not for text
## pass object of S3 class URL if want url and not absolute  (eg. http:///)

##' widget to render HTML text pages
##'
##' 
##' @param x an HTML string or a URL. (However, URL's are not working!)
##' \code{svalue<-}. If an HTML fragment, then assumed to be HTML. THe
##' \code{svalue<-} method has an extra argument \code{encode}, which
##' if \code{TRUE} will encode the HTML bits. This is \code{FALSE} by
##' default.
##' @param container parent container
##' @param ... passed to add method of parent container
##' @export
ghtml <- function(x, container = NULL,  ...) {
  ## x is a url or a character vector to show
  ## components

  
  widget <- EXTComponentNoItems$new(toplevel=container$toplevel)
  class(widget) <- c("gHtml",class(widget))
  widget$setValue(value=x)

  ## helper function
  widget$htmlEscape <- function(., val) {
    val <- gsub("\n","<br />", val)
    val <- gsub("'", "&#146;", val)   # get rid of ' issue
    val <- escapeQuotes(val)
    val
  }


  widget$setValueJS <- function(.,...) {
    if(exists("..setValueJS", envir=., inherits=FALSE)) .$..setValueJS(...)
    
    val <- .$..data
    out <- String() + 'o' + .$ID
    if(isURL(val)) {
      out <- sprintf("%s.load(%s); %s.update();", .$asCharacter(), ourQuote(val), .$asCharacter())
    } else {
      ## this depends on local or non-local
      ## if(gWidgetsWWWIsLocal()) {
      ##   val <- paste(val, collapse="\\\\n")
      ## } else {
      ##   val <- paste(val, collapse="\\n")
      ## }

      ## do we encode? By default false
      doEncode <- ifelse(getFromDots(..., var="encode", default=FALSE), "true", "false")

      ## was stripSlashN bit
      out <- sprintf("%s.setText('%s', %s);", .$asCharacter(), paste(.$htmlEscape(svalue(.)), collapse=" "), doEncode)
    }
    return(out)
  }

  if(isURL(x)) 
    widget$ExtConstructor <- "Ext.Panel"
  else
    widget$ExtConstructor <- "Ext.form.Label"
  widget$ExtCfgOptions <-  function(.) {
    out <- list()
    out[['border']] <- FALSE
    
    if(isURL(svalue(.)))
      out[['autoLoad']] <- list(url=svalue(.))
    else
      out[['html']] <- paste(.$htmlEscape(svalue(.)), collapse=" ") # was \\\\n but gives issues locally
    
    return(out)
  }
  
  ## add after CSS, scripts defined
  container$add(widget,...)
  invisible(widget)
}
#line 1 "d:/RCompile/CRANpkg/local/2.13/gWidgetsWWW/R/gimage.R"
##  Copyright (C) 2010 John Verzani
##
##  This program is free software; you can redistribute it and/or modify
##  it under the terms of the GNU General Public License as published by
##  the Free Software Foundation; either version 2 of the License, or
##  (at your option) any later version.
##
##  This program is distributed in the hope that it will be useful,
##  but WITHOUT ANY WARRANTY; without even the implied warranty of
##  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
##  GNU General Public License for more details.
##
##  A copy of the GNU General Public License is available at
##  http://www.r-project.org/Licenses/

## Right way is to extend EXT.Component

##' Container for an image
##'
##' 
##' @param filename A url or file in static temp file
##' @param dirname prepended to filename if non empty
##' @param size passed to \code{size<-} method if given
##' @param handler ignored
##' @param action ignored
##' @param container parent container
##' @param ... passed to parent container's \code{add} method
##' @param resizable if widget resizable. Buggy?
##' @export
gimage <- function(filename = "", dirname = "",  size = "",
                   handler = NULL, action = NULL, container = NULL,...,
                   resizable =FALSE     # WWW option. Keep?
                   ) {

  if(!resizable) {
    widget <- EXTComponentNoItems$new(toplevel=container$toplevel)
    class(widget) <- c("gImage", class(widget))
  } else {
    widget <- EXTComponentResizable$new(toplevel=container$toplevel)
    class(widget) <- c("gImage","gWidgetResizable", class(widget))
  }

  ## append dirname if non empty
  if(dirname != "")
    filename <- String(dirname) + filename
  widget$setValue(value=filename)

  widget$getValue <- function(., ...) {
    ## need to be a URL, so we convert if necessary
    val <- .$..data
    if(isURL(val))
      return(val)
    if(file.exists(val))
      return(convertStaticFileToUrl(val))

    return(val)
  }

  
      
  widget$setValueJSMethod = "setValue"
  widget$getValueJSMethod = "setValue"
  widget$ExtConstructor <- "Ext.ux.imageBox"
  widget$ExtCfgOptions <-  function(.) {
    out <- list()
    out[["value"]] = svalue(.)
    return(out)
  }
  if(size != "")
    size(widget) <- size
  
  ## add after CSS, scripts defined
  container$add(widget,...)

  ## no handler
  
  invisible(widget)
}
#line 1 "d:/RCompile/CRANpkg/local/2.13/gWidgetsWWW/R/glabel.R"
##  Copyright (C) 2010 John Verzani
##
##  This program is free software; you can redistribute it and/or modify
##  it under the terms of the GNU General Public License as published by
##  the Free Software Foundation; either version 2 of the License, or
##  (at your option) any later version.
##
##  This program is distributed in the hope that it will be useful,
##  but WITHOUT ANY WARRANTY; without even the implied warranty of
##  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
##  GNU General Public License for more details.
##
##  A copy of the GNU General Public License is available at
##  http://www.r-project.org/Licenses/

##' A label widget
##' 
##' @param text text for label. If multiline will be joined with " " or "<br />" (when \code{markup=TRUE})
##' @param markup If \code{TRUE} then text can be HTML. Useful for
##' newlines. A value of \code{FALSE} will cause HTML constructs to be
##' escaped. This is useful if user-supplied values are being
##' displayed.
##' @param editable 
##' @param handler 
##' @param action 
##' @param container 
##' @param ... 
glabel <- function(text = "", markup = FALSE, editable = FALSE,
                   handler = NULL, action = NULL, container = NULL,...) {

  widget <- EXTComponentNoItems$new(toplevel=container$toplevel,
                             ..editable = editable,
                             ..markup = markup
                             )
  
  class(widget) <- c("gLabel",class(widget))
  if(!markup)
    text <- escapeHTML(text)
  widget$setValue(value=text)


  ## strip of \n so we can push thourgh '' in one line.
  
  widget$getValue <- function(.,...) paste(.$..data, collapse=ifelse(.$..markup, "<br />", " "))

  widget$setValueJSMethod = "setValue"
  ##' ensure we strip off \n values
  widget$setValueJS <- function(., ...) {
    out <- sprintf("%s.setValue('%s');", .$asCharacter(), stripSlashN(svalue(.), encode=!.$..markup, dostrwrap=FALSE))
    return(out)
  }
  widget$getValueJSMethod = "setValue"
  widget$ExtConstructor <- "Ext.ux.labelBox"
  widget$ExtCfgOptions <-  function(.) {
    out <- list(
                value=stripSlashN(svalue(.), encode=!.$..markup, dostrwrap=FALSE)
                ) ## was unescapeURL(svalue(.)
    return(out)
  }
  
  
  
  ## add after CSS, scripts defined
  container$add(widget,...)
  invisible(widget)
  
}
#line 1 "d:/RCompile/CRANpkg/local/2.13/gWidgetsWWW/R/glayout.R"
##  Copyright (C) 2010 John Verzani
##
##  This program is free software; you can redistribute it and/or modify
##  it under the terms of the GNU General Public License as published by
##  the Free Software Foundation; either version 2 of the License, or
##  (at your option) any later version.
##
##  This program is distributed in the hope that it will be useful,
##  but WITHOUT ANY WARRANTY; without even the implied warranty of
##  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
##  GNU General Public License for more details.
##
##  A copy of the GNU General Public License is available at
##  http://www.r-project.org/Licenses/


## glayout
## use TableLayout  -- need algorithm to write out widgets


glayout <- function(homogeneous = FALSE, spacing = 5, # 10 is too big here
                    container = NULL, ...) {



  tbl <- EXTContainer$new(toplevel=container$toplevel,
                          ..spacing = as.numeric(spacing),
                          ..noRows = 0, ..noCols = 0
                         )
  class(tbl) <- c("gLayout",class(tbl))

  ## methods
  tbl$setValues <- function(.,i,j,...,value) {
    ## if character make a glabel object
    if(is.character(value))
      value <- glabel(value, cont = .)
    
    value$..tblLocationRow <- i
    value$..tblLocationCol <- j
    value$..tblSeen <- FALSE
    .$..noRows <- max(i,.$..noRows)
    .$..noCols <- max(j,.$..noCols)

    theArgs <- list(...)
    ## anchor
    if(exists("..style",envir=value,inherits=FALSE))
      style <- value$..style
    else
      style <- c()
    if(!is.null(anchor <- theArgs$anchor)) {
      if(anchor[1] == -1)
        style["text-align"] = "left"
      else if(anchor[1] == 0)
        style["text-align"] = "center"
      else if(anchor[1] == 1)
        style["text-align"] = "right"
      if(anchor[2] == -1)
        style["text-valign"] = "bottom"
      else if(anchor[2] == 0)
        style["text-valign"] = "center"
      else if(anchor[2] == 1)
        style["text-valign"] = "top"
      
    }
    value$..style <- style
  }

  ## css to style alignment
  tbl$footer <- function(.) {
    out <- paste("Ext.util.CSS.createStyleSheet('",
                 ".td-northwest {vertical-align: top; align: left} ",
                 ".td-north {vertical-align: top} ",
                 ".td-northeast {vertical-align: top; align: right} ",
                 ".td-west {align: left} ",
                 ".td-center {} ",
                 ".td-east {align: right} ",
                 ".td-southwest {vertical-align: bottom; align: left} ",
                 ".td-south {vertical-align: bottom} ",
                 ".td-southeast {vertical-align: bottom; align: right} ",
                 "');",
                 sep="")
    return(out)
  }

  tbl$x.hidden <- FALSE
  tbl$ExtConstructor <- "Ext.Panel" ## inherits
  tbl$ExtCfgOptions <- function(.) { ## ih
#    defaults <- String('{') +
#      'bodyStyle:"padding:' + .$..spacing + 'px"}'
    defaults <- list(bodyStyle = sprintf("padding:%spx", .$..spacing))
    layoutConfig <- list(columns=.$..noCols,
                         align="left",
                         valign="top")

      String('{') +
      'columns:' + .$..noCols + '}'
    
    out <- list(layout="table",
                defaults = defaults,
                border=FALSE,
                layoutConfig = layoutConfig
                )
    return(out)
   
  }

  tbl$makeItemsFixedItems <- "border:false,"
  tbl$makeItems <- function(.) {
    ## helper function
    mapAnchorToCSSClass <- function(anchor) {
      if(is.null(anchor))
        return("td-northwest")

      out <-
        if(anchor[2] == 1) {
          if(anchor[1] == -1)
            "td-northwest"
          else if(anchor[1] == 0)
            "td-north"
          else
            "td-northeast"
        } else if(anchor[2] == 0) {
          if(anchor[1] == -1)
            "td-west"
          else if(anchor[1] == 0)
            "td-center"
          else
            "td-east"
        } else if(anchor[2] == -1) {
          if(anchor[1] == -1)
            "td-southwest"
          else if(anchor[1] == 0)
            "td-south"
          else
            "td-southeast"
        }
    }
        


    ## key to this is a simple algorithm which could be optimized
    ## but likely isn't worth the trouble

    children <- .$children; n <- length(children)
    if(n == 0) {
      return("")
    }

    sapply(children, function(i) i$..tblSeen <- FALSE)
    
    allRows <- lapply(children, function(i) i$..tblLocationRow)
    allCols <- lapply(children, function(i) i$..tblLocationCol)

    items <- list(); ctr <- 1
    for(row in 1:.$..noRows) {
      for(col in 1:.$..noCols) {
        gotOne <- FALSE
        for(i in 1:n) {
          if(row %in% allRows[[i]] && col %in% allCols[[i]]) {
            if(children[[i]]$..tblSeen) {
              gotOne <- TRUE
              break
            } else {
              child <- children[[i]]
              items[[ctr]] <- list(rowspan=length(allRows[[i]]),
                                   colspan=length(allCols[[i]]),obj=child)
              ctr <- ctr + 1
              child$..tblSeen <- TRUE
              gotOne <- TRUE
              break
            }
          }
        }
        if(!gotOne) {
          items[[ctr]] <- list(rowspan=1, colspan = 1, obj = NULL)
          ctr <- ctr+1
        }
      }
    }

    tmp <- lapply(items, function(i) {
      if(is.null(i$obj)) {
        contentEl <- String('html:"&nbsp;"')
      } else {
        contentEl <- String('contentEl:') + shQuote(i$obj$ID)
      }

      out <- String(.$makeItemsFixedItems)

      if(i$rowspan > 1 && i$colspan > 1) {
        out <- out +
          'rowspan:' + i$rowspan + ',' +
            'colspan:' + i$colspan + ',' +
              contentEl
      } else if(i$rowspan > 1) {
        out <- out +
          'rowspan:' + i$rowspan + ',' +
            contentEl
      } else if(i$colspan > 1) {
        out <- out +
          'colspan:' + i$colspan + ',' +
            contentEl
      } else {
        out <- out + contentEl
      }
      out <- out + "," + sprintf("cellCls:'%s'", mapAnchorToCSSClass(i$anchor))
      
      return(out)
    })

    out <- paste('{',tmp,'}',sep="",collapse=",")
    return(out)
  }
        
  
  container$add(tbl,...)
  invisible(tbl)
  
}

#line 1 "d:/RCompile/CRANpkg/local/2.13/gWidgetsWWW/R/gmenu.R"
##  Copyright (C) 2010 John Verzani
##
##  This program is free software; you can redistribute it and/or modify
##  it under the terms of the GNU General Public License as published by
##  the Free Software Foundation; either version 2 of the License, or
##  (at your option) any later version.
##
##  This program is distributed in the hope that it will be useful,
##  but WITHOUT ANY WARRANTY; without even the implied warranty of
##  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
##  GNU General Public License for more details.
##
##  A copy of the GNU General Public License is available at
##  http://www.r-project.org/Licenses/

## XXX no methods defined here!!!

##' Menubar implementation
##' 
##' @param menulist list of actions. Actions must have parent specified
##' @param popup ignored. Logical indicating if this is a popup widget
##' @param action parameterizes handler in action
##' @param container parent container
##' @param ... passed to add method of parent container
##' @export
gmenu <- function(menulist,  popup = FALSE, action=NULL, container = NULL,...) {

  if(popup) {
    warning("gmenu: popup is not implemented")
    return()
  }
  

  
  widget <- EXTComponent$new(toplevel=container$toplevel)
  class(widget) <- c("gMenu",class(widget))
  ## for menubar, we get ID not from adding, but directly
  widget$ID <- container$newID()

  widget$setValue(value=menulist)

  ## put into subwindow?
  if(inherits(container,"gSubwindow")) {
    widget$mbContainer <- container
  } else {
    widget$mbContainer <- widget$toplevel
  }

  widget$mbContainer$..menuBar <- widget

  widget$writeMenu <- function(., menulist= svalue(.), out) {
    ## write out menu in Ext tbar format
    ## this menu gets called recursively
    if(missing(out)) out <- String("[")
    
    for(i in names(menulist)) {
      data <- menulist[[i]]
      if(is(data,"gSeparator"))
        data <- list(separator=TRUE)
      
      if(inherits(data, "gAction")) {
        out <- out + data$asCharacter() + ','
      } else if(!is.null(data$separator)) {
        out <- out + '"-"' + ','
      } else if(!is.null(data$handler)) {
        ## make an action, add
        label <- ifelse(is.null(data$label), i, data$label)
        a <- gaction(label=label,
                     tooltip = ifelse(is.null(data$tooltip),label, data$tooltip),
                     icon = data$icon,
                     handler = data$handler,
                     parent = .$toplevel)
        out <- out + a$asCharacter() + ','
      } else if(is.list(data)) {
        ## recurse, wrap in text and {}
        out <- out + '{text:' + shQuote(i) + ', menu: ['
        out <- .$writeMenu(menulist = data, out)
        out <- out + '}' + ','
      } else {
        ## do nothing
      }
    }

    ## if ends in ',' chop
    out <- gsub(',$','',out)
    ## add in trailing "]"
    out <- out + ']'
    
    return(out)
  }

  invisible(widget)
}
  
  
#line 1 "d:/RCompile/CRANpkg/local/2.13/gWidgetsWWW/R/gnotebook.R"
##  Copyright (C) 2010 John Verzani
##
##  This program is free software; you can redistribute it and/or modify
##  it under the terms of the GNU General Public License as published by
##  the Free Software Foundation; either version 2 of the License, or
##  (at your option) any later version.
##
##  This program is distributed in the hope that it will be useful,
##  but WITHOUT ANY WARRANTY; without even the implied warranty of
##  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
##  GNU General Public License for more details.
##
##  A copy of the GNU General Public License is available at
##  http://www.r-project.org/Licenses/

## gnotebook
## when adding, can pass in label= and tooltip= arguments for tooltip on tab
## XXX needs to addJS method
gnotebook <- function(tab.pos = 3, close.buttons = FALSE, container, ...) {

   ## a notebook
   widget <- EXTContainer$new(toplevel=container$toplevel,
                        ..closeButtons=close.buttons,
                        ..tabPos = tab.pos)
   class(widget) <- c("gNotebook",class(widget))

   widget$setValue(value=1)             # current tab
   ## Methods
   ## how to set a value
   widget$setValueJS <- function(., ...) {
     if(exists("..setValueJS", envir=., inherits=FALSE)) .$..setValueJS(...)
       
     ind <- as.numeric(.$..data - 1)
     
     out <- String() +
       'o' + .$ID + '.setActiveTab(' + ind + ');' 

     return(out)
   }
   widget$disposeJS <- function(.,ind) {
     if(missing(ind)) {
       ind <- length(.) 
     }
     ind <- ind - 1                     # 0 based
     out <- String() +
       'tab = o' + .$ID + '.getComponent(ind);' +
         'o' + .$ID + '.remove(tab);'
     return(out)
   }
   
   ## label names stored in children
   widget$getNames <- function(.) {
     n <- length(.$children)
     val <- character(n)
     for(i in 1:n)
       val[i] <- .$children[[i]]$..label
     return(val)
   }

   ## XXX not updated
   widget$setNames <- function(., value) {
     n <- length(.$children)
     if(length(value) == n) {
       for(i in 1:n) {
         .$children[[i]]$..label <- value[i]
       }
     }
     if(exists("..shown",envir=., inherits=FALSE)) {
       .$setNamesJS()
     }

   }
   widget$setNamesJS <- function(.) {
     ## must reset all the names in a loop
     out <- String()
     n <- length(.$children)
     for(i in 1:n) {
       out <- out +
         'var tab = ' + 'o' + .$ID + '.getTab('+ (i-1) + ');' +
           'tab.get("labelEl").innerHTML =' + shQuote(.$children[[i]]$..label) + ';'
     }
     return(out)
   }


   ## how to add children -- need label, etc
   ## override add
   widget$add <- function(.,child,...) {
     parent <- .$parent                  # to dispatch add method
     theArgs <- list(...)
     ## labels
     if(!is.null(theArgs$label))
       label <- theArgs$label
     else
       label <- "tab"
     child$..label <- label
     child$x.hidden <- TRUE
     ## tooltips
     if(!is.null(theArgs$tooltip))
       child$..tabTooltip <- theArgs$tooltip
     addFUN <- get("add",envir=parent)   # call add for parent widget
     addFUN(.,child)                     # call
   }

   widget$ExtConstructor <- "Ext.TabPanel" ## inherits
   widget$ExtCfgOptions <- function(.) { ## ih
     tabpos <- "top"
     if(.$..tabPos == 1)
       tabpos <- "bottom"
     tabNo <- svalue(.) - 1
     out <- list(frame = TRUE,
                 activeTab = tabNo,
                 enableTabScroll = TRUE,
                 defaults = String("{autoScroll: true}"),
                 tabPosition = tabpos
                 )

     return(out)
     
   }
   widget$makeItemsFixedItems <- 'border:false,'

  ## add after CSS, scripts defined
  container$add(widget,...)
  

##   if(!is.null(handler))
##     widget$addHandlerClicked(handler=handler,action=action)
  
  invisible(widget)
  
}
#line 1 "d:/RCompile/CRANpkg/local/2.13/gWidgetsWWW/R/gpanedgroup.R"
##  Copyright (C) 2010 John Verzani
##
##  This program is free software; you can redistribute it and/or modify
##  it under the terms of the GNU General Public License as published by
##  the Free Software Foundation; either version 2 of the License, or
##  (at your option) any later version.
##
##  This program is distributed in the hope that it will be useful,
##  but WITHOUT ANY WARRANTY; without even the implied warranty of
##  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
##  GNU General Public License for more details.
##
##  A copy of the GNU General Public License is available at
##  http://www.r-project.org/Licenses/

## gpanedgroup
gpanedgroup <- function(...) stop("no gpanedgroup available in Ext.")

#line 1 "d:/RCompile/CRANpkg/local/2.13/gWidgetsWWW/R/gprocessingjs.R"
##  Copyright (C) 2010 John Verzani
##
##  This program is free software; you can redistribute it and/or modify
##  it under the terms of the GNU General Public License as published by
##  the Free Software Foundation; either version 2 of the License, or
##  (at your option) any later version.
##
##  This program is distributed in the hope that it will be useful,
##  but WITHOUT ANY WARRANTY; without even the implied warranty of
##  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
##  GNU General Public License for more details.
##
##  A copy of the GNU General Public License is available at
##  http://www.r-project.org/Licenses/


## interface to Processing.js
## handlers of processingEvents return javascript using processing. Use <<p>> to refer to processing
## object. For instance
## p$mouseMoved <- function(.) {
##  paste("<<p>>.background(0)",
##        "<<p>>.line(1,2,4,5)
## }

##' Widget to allow low-level graphics commands through processingjs.
##'
##' The advantage over gcanvas is that this has more interactivity
##' defined for it.  The use of this is different though. The basic
##' idea is that several of the lowlevel plot commands are
##' implemented. For exmaple plot.new, plot.window, axis, title,
##' lines, polygon etc. These are called differently though. They are
##' implemented as proto methods of the gprocessingjs object, so are
##' called as in p\$plot.window().  The method addHandlerClick passes
##' back a value xy wich contains the position of the mouse click in
##' pixel coordinates. One can use the method pixelsToXY to covert to
##' usr coordinates.
##' @param width of graphic
##' @param height height of graphic (pixels)
##' @param pointsize size of fonts
##' @param container parent container
##' @param ... passed to container's add method
##' @export
gprocessingjs <- function(width=400, height=400, pointsize= 12, container = NULL, ...) {
  widget <- EXTComponentNoItems$new(toplevel = container$toplevel,
                             ..width = width,
                             ..height = height,
                             ..pointsize = pointsize)
  class(widget) <- c("gProcessingJS", class(widget))


  ## addHandlerMouseMove
  EXTWidget$addHandlerMousemove <- function(., handler, action=NULL) {
    .$addHandler(signal="mousemove",handler, action,
                 handlerArguments="e",
                 handlerExtraParameters = "Ext.util.JSON.encode({xy:[e.layerX,e.layerY]})"
                 )
    
  }


  
  ## properties
  widget$..margin <- as.integer(c(1,2,1.5,3) * pointsize * 1.2)
  widget$..background <- 250 ## passed to .$background via plot.new
  
  ## holds value as string
  widget$out <- String()
  

  widget$ExtConstructor <- "Ext.ux.Canvas"
  widget$ExtCfgOptions <- function(.) {
    out <- list()

    return(out)
  }


  widget$asProcessingCharacter <- function(.) sprintf("processing%s", .$ID)
  widget$..writeConstructor <- function(.) {
    ## create element
    out <- String() + "\n" + "// ------- \n" +
      sprintf("var %s = new Processing(document.getElementById('%s'));", .$asProcessingCharacter(), .$ID) +
        sprintf("%s.size(%s, %s);", .$asProcessingCharacter(), .$..width, .$..height) +
          .$out + "\n"
    out
  }
    
  widget$footer <- function(.) {
    ID <- .$ID
    pID <- .$asCharacter()

    out <- String()
    
    ## for i in handlers, call
    ## these are javascript to call direct avoiding R handlers.
    for(i in .$processingEvents) {
      f <- .[[i]]
      if(!is.null(f)) {
         val <- f()
         pID <- String("processing") + ID
         fnHead <- pID + "." + i + "= function() {\n"
         val <- gsub("<<p>>",pID, val) ## sub for processing ID
         val <- paste(val, collapse="\n")
         out <- out + fnHead + val + "};\n"
       }
     }
     ## call init
#    out <- out + sprintf("%s.init();", .$asCharacter())
    out
  }
  
  ## turn method into javascript command from Processing.js
  widget$makeCommand <- function(.,name, ...) {
    args <- list(...)
    
    vals <- paste(args, collapse=", ")

    val <-  String() +
      "processing" + .$ID +  "." + name + "(" + vals + ");\n"

    if(.$has_local_slot("..shown"))
      .$addJSQueue(val)
    else
      .$out <- .$out + val
  }

  ## if these are defined, then they are to be functions returning
  ## javascript code the interactive handlers can be **really slow**
  ## if sent back into R. Use gWidgets Handlers to put in interactive
  ## code with R commands. These allow interactive demos at the expense
  ## of being able to program in javascript The value <<p>> will
  ## expand to the appropriate object ID.
  ## 
  widget$processingEvents <- c("mouseDragged","mouseMoved", "mousePressed", "mouseReleased",
                               "keyPressed","keyReleased","draw","setup")
  
  for(i in widget$processingEvents) widget[[i]] <- NULL

  ## functions for mouse positions when making javascript handlers
  widget$pmouseX <- function(.) String("processing") + .$ID + ".pmouseX"
  widget$pmouseY <- function(.) String("processing") + .$ID + ".pmouseY"
  widget$mouseX <- function(.) String("processing") + .$ID + ".mouseX"
  widget$mouseY <- function(.) String("processing") + .$ID + ".mouseY"
  widget$mouseButton <- function(.) String("processing") + .$ID + ".mouseButton"

  ##################################################
  ## Make functions for processing commands
  ## Mostly copied over from Processing.js. Most aren't used
  ## ???
  widget$color <- function(., aValue1, aValue2, aValue3, aValue4)
    .$makeCommand("color", aValue1, aValue2, aValue3, aValue4)

  ## pad with leading 0's
  widget$nf <- function(., num, pad) .$makeCommand("nf", num, pad)

  ## ??
  widget$AniSprite <- function(., prefix, frames)
    .$makeCommand("AniSprite", prefix, frames)

  ## How would this work -- obj is a javascript object?
  widget$buildImageObject <- function(., obj)
    .$makeCommand("buildImageObject", obj)

  ## build image
  widget$createImage <- function(., w, h, mode)
    .$makeCommand("createImage", w, h, mode)

  ## stub -- handled through gWidgets
  widget$createGraphics <- function(., w, h) ""
  widget$beginDraw <- function(.) .$makeCommand("beginDraw")
  widget$endDraw <- function(.) .$makeCommand("endDraw")

  widget$loadImage <- function(.,file)
    .$makeCommand("loadImage", file)
  
  widget$loadFont <- function(., name)
    .$makeCommand("loadFont", shQuote(name))
  widget$textFont <- function(., name, size)
    .$makeCommand("textFont", shQuote(name), as.integer(size))
  widget$textSize <- function(., size)
    .$makeCommand("textSize", as.integer(size))
  widget$textAlign <- function(.)
    .$makeCommand("textAlign")
  ## ptext - -so text will be R function
  widget$ptext <- function(., str, x, y) 
    .$makeCommand("text", str, x, y)
  widget$char <- function(., key)
    .$makeCommand("char", key)
  widget$println <- function(.)
    .$makeCommand("println")
  
  widget$map <- function(., value, istart, istop, ostart, ostop )
    .$makeCommands("map", value, istart, istop, ostart, ostop )

  widget$Point <- function(., x, y)
    .$makeCommands("Point", x, y)

  widget$Random <- function(.)
    .$makeCommands("Random")

  widget$ArrayList <- function(., size, size2, size3)
    .$makeCommands("ArrayList",size, size2, size3)

  widget$colorMode <- function(., mode, range1, range2, range3, range4 ) 
    .$makeCommand("colorMode", mode, range1, range2, range3, range4 )

  widget$beginShape <- function(., type )
    .$makeCommand("beginShape",type)

  widget$endShape <- function(., close="true" )
    .$makeCommand("endShape",close)

  widget$vertex <- function(., x, y) #x2, y2, x3, y3 )
  .$makeCommand("vertex",  x, y) #, x2, y2, x3, y3 )

  widget$curveVertex <- function(., x, y, x2, y2 )
    .$makeCommand("curveVertex", x, y, x2, y2 )

  widget$curveTightness <- function(., tightness)
    .$makeCommand("curveTightness", tightness)

  widget$rectMode <- function(., aRectMode)
    .$makeCommand("rectMode", aRectMode)

  widget$imageMode <- function(.)
    .$makeCommand("imageMode")

  widget$ellipseMode <- function(., aEllipseMode)
    .$makeCommand("ellipsMode", aEllipseMode)
  
  ## skip math ones
  
  widget$translate <- function(., x, y)
    .$makeCommand("translate", x,y)
  
  widget$scale <- function(., x,y)
    .$makeCommand("scale", x, y)
  
  widget$rotate <- function(., aAngle)
    .$makeCommand("rotate", aAngle)
  
  widget$redraw <- function(.) 
    .$makeCommand("redraw")

 widget$loop <- function(.)
   .$makeCommand("loop")

 widget$frameRate <- function(., aRate)
   .$makeCommand("frameRate", aRate)

 ## set background image, or color (gray scale 0 to 256?)
 widget$background <- function(., img=0) ## img could be image?
   .$makeCommand("background", img)



  widget$size <- function(., aWidth, aHeight) 
    .$makeCommand("size", aWidth, aHeight)

  widget$noStroke <- function(.) .$makeCommand("noStroke")

  widget$noFill <- function(.) .$makeCommand("noFill")

  widget$smooth <- function(.) .$makeCommand("smooth")

  widget$noLoop <- function(.) .$makeCommand("noLoop")

  widget$fill <- function(.,...) .$makeCommand("fill",...)

  widget$stroke <- function(.,...) .$makeCommand("stroke",...)

  widget$strokeWeight <- function(., w) .$makeCommand("strokeWeight", w)
  
  widget$point <- function(., x, y) .$makeCommand("point", x, y)
  
  ## rename with p -- otherwise get is an issue
  widget$pget <- function(., x, y) .$makeCommand("get", x, y)
   widget$pset <- function(., x, y, obj) .$makeCommand("set", x, y, obj)

  widget$arc <- function(., x, y, width, height, start, stop )
    .$makeCommand("arc",x, y, width, height, start, stop )

  ## draw a line. Make R like c(x,y), c(x1,y1)
  widget$line <- function(., x1, x2, y1, y2) {
    if(length(x1) == 2) 
      .$makeCommand("line", x1[1], x2[1], x1[2], x2[2])
    else
      .$makeCommand("line", x1,x2,y1,y2)
  }

  ## draw Bezier curve
  ## if x1 length 4, assume y1 is and replace
  widget$bezier <- function(.,x1,y1,x2,y2,x3,y3,x4,y4) {
    if(length(x1) == 4) {
      x2 <- x1[2]; x3 <- x1[3]; x4 <- x1[4]; x1 <- x1[1]
      y2 <- y1[2]; y3 <- y1[3]; y4 <- y1[4]; y1 <- y1[1]
    }
    .$makeCommand("bezier", x1, y1, x2, y2, x3, y3, x4, y4)
  }

  widget$triangle <- function(.,  x1, y1, x2, y2, x3, y3 )
    .$makeCommand("triangle", x1, y1, x2, y2, x3, y3 )

  widget$quad <- function(., x1, y1, x2, y2, x3, y3, x4, y4 )
    .$makeCommand("quad", x1, y1, x2, y2, x3, y3, x4, y4 )

  ## rect -> prect
  widget$prect <- function(., x,y, width, height)
    .$makeCommand("rect",  x, y, width, height)

  ## draw ellipse or circle
  widget$ellipse <- function(., x, y, width=10, height=width)
    .$makeCommand("ellipse", x, y, width, height)


  ##################################################
  ## Familiar R methods for plot devices, using those above
  ## not exactly a device interface, but not hard to use either.

  ## Some helper functions
  ## The canvas uses pixels, R uses coordinates within xlim/ylim. This converts x to Pixels
  ## separate --but identical -- function for y to pixels
  ## Respects p$..margin <- c(left, top, right, bottom) in pixels
  widget$xToPixels <- function(., x) {
    xlim <- .$getXlim()
    margin <- .$..margin

    for(k in 2:4)
      if(length(margin) == k - 1) margin[k] <- margin[k-1]
    .$..margin <- margin
    
    m <- (.$..width - margin[3] - margin[1]) / diff(xlim)
    px <- round(margin[1] + m * (x - xlim[1]))
    px
  }
  widget$yToPixels <- function(., y) {
    ylim <- .$getYlim()

    margin <- .$..margin

    for(k in 2:4)
      if(length(margin) == k - 1) margin[k] <- margin[k-1]
    .$..margin <- margin
    
    m <- (.$..height - margin[2] - margin[4]) / diff(ylim)
    py <- round(margin[2] + m * (y - ylim[1]))
    ## flip
    .$..height - py
    
  }

  ## convert back into XY form pixes
  ## mouse handlers return h$xy = c(x,y) for coordinates in pixels
  widget$pixelsToXY <- function(., pxy) {
    px <- pxy[1]; py <- pxy[2]
    xlim <- .$xlim; ylim <- .$ylim
    widget <- .$..width; height <- .$..height

    margin <- .$..margin

    mx <- (.$..width - margin[3] - margin[1]) / diff(xlim)
    my <- (.$..height - margin[2] - margin[4]) / diff(ylim)

    x <- (px - margin[1])/mx + xlim[1]
    y <- ((height -py) - margin[2])/my + ylim[1]
    return(c(x,y))
  }
  ## xlim -- if not set.
  widget$getXlim <- function(.) {
    if(!exists("xlim",env=., inherits=FALSE))
      .$xlim <- c(1,.$..width)
    .$xlim
  }
  widget$getYlim <- function(.) {
    if(!exists("ylim",env=., inherits=FALSE))
      .$ylim <- c(1,.$..height)
    .$ylim
  }
  ## covert color into rgb for use with col=NA argument
  widget$fixColor <- function(., col) {
    if(col %in% colors())
      col <- paste(col2rgb(col), collapse=",")
    col
  }

  ####
  ## The basic R plot commands as methods for the processing object
  ## several argument are not implemented. -- LAZY --
  ## plot.new -- just sets p$background(). The default background has no method to set
  ##             one can set via p$..background <- "..."
  widget$plot.new <- function(., ...) {
    .$background(.$..background)
  }
  ## set xlim and ylim. missing  log = "", asp=NA, 
  widget$plot.window <- function(., xlim, ylim,...) {
    .$xlim <- xlim
    .$ylim <- ylim
  }
  ## title: ylab does not turn text
  widget$title <- function(., main = NULL, sub = NULL, xlab = NULL, ylab = NULL,
                           cex = 1, ...) {
    margin <- .$..margin
    xlim <- .$getXlim(); ylim <- .$getYlim()
    width <- .$..width; height <- .$..height
    if(!is.null(main)) {
      .$textSize(cex * 1.2 * .$..pointsize)
      .$ptext(shQuote(main), width/2, margin[2]/2)
    }
    if(!is.null(sub)) {
      .$textSize(cex * .$..pointsize)
      .$ptext(shQuote(sub), width/2, height)
    }

    if(!is.null(xlab)) {
      .$textSize(cex * .8 * .$..pointsize)
      .$ptext(shQuote(xlab), width/2, height - margin[4]/2)
    }
    if(!is.null(ylab)) {
      .$textSize(cex * .8 * .$..pointsize)
      .$ptext(shQuote(ylab), margin[1]/2, height/2)
    }
  }

  ## axis
  widget$axis <- function(.,side,...) {

    if(missing(side)) side <- 1:2
    xlim <- .$getXlim(); ylim <- .$getYlim()
    px <- pretty(xlim); py <- pretty(ylim)
    
    if(1 %in% side) {
      .$lines(xlim, c(ylim[1], ylim[1]))
      for(i in 1:length(px)) 
        .$text(px[i], ylim[1], px[i], pos=1)
    }
    if(2 %in% side) {
      .$lines(c(xlim[1], xlim[1]), ylim)
      for(i in 1:length(py)) 
        .$text(xlim[1],py[i], py[i], pos=2)
    }
    if(3 %in% side) {
      .$lines(xlim, c(ylim[2], ylim[2]))
    }
    if(4 %in% side) {
      .$lines(c(xlim[2], xlim[2]), ylim)
    }
  }

  ### draw box using lines
  widget$box <- function(., ... ) {
    xlim <- .$getXlim(); ylim <- .$getYlim()
    .$lines(xlim[c(1,2,2,1,1)], ylim[c(1,1,2,2,1)], col=col, ...)
  }

  widget$points <- function(., x, y = NULL, cex=1, col = NA, ...) {
    xy <- xy.coords(x,y)
    xy$x <- .$xToPixels(x)
    xy$y <- .$yToPixels(y)

    ## recycle cex
    cex <- rep(cex, length.out=length(xy$x))
    ## fix and recycle col
    if(is.na(col))
      col <- "black"
    col <- .$fixColor(col)
    col <- rep(col, length.out=length(xy$x))

    for(i in seq_along(xy$x))  {
      .$fill(col[i])
      .$ellipse(xy$x[i], xy$y[i], width=round(cex[i] * 5))
    }
  }
  

  ##
  widget$lines <- function(., x, y = NULL, col=NA, lwd=1, ...) {
    xy <- xy.coords(x,y)
    xy$x <- .$xToPixels(x)
    xy$y <- .$yToPixels(y)

    ## fix and recycle col
    if(is.na(col))
      col <- "black"
    col <- .$fixColor(col)
    col <- rep(col, length(xy$x) - 1)
    ## ditto  lwd
    lwd <- rep(lwd, length(xy$x) -1)

    for(i in 2:length(xy$x)) {
      .$stroke(col[i-1])
      .$strokeWeight(lwd[i-1])
      .$line(xy$x[i-1], xy$y[i-1], xy$x[i], xy$y[i])
    }
    .$stroke(0)
    .$strokeWeight(1)
    
  }

  widget$polygon <- function(., x, y=NULL, col=NA, ...)  {
    ## XXX add in other args later
    xy <- xy.coords(x,y)
    xy$x <- .$xToPixels(x)
    xy$y <- .$yToPixels(y)
    
    if(!is.na(col))
      .$fill(.$fixColor(col))

    .$beginShape(type="'polygon'")
    for(i in 1:length(xy$x))
      .$vertex(xy$x[i], xy$y[i])
    .$endShape()
  }
  widget$rect <- function(., xleft, ybottom, xright, ytop, col=NA, ...) {
    ## recycle col
    col <- rep(col, length=length(xleft))
    ## can be vectorid
    for(i in 1:length(xleft))
    .$polygon(c(xleft[i], xright[i], xright[i], xleft[i]),
              c(ybottom[i], ybottom[i], ytop[i], ytop[i]),
              col=col[i], ...)
  }

  widget$abline <- function(., a = NULL, b = NULL, h = NULL, v = NULL, coef = NULL, ...) {
    ## draws line depending
    if(!is.null(coef))
      a <- coef[1]; b <- coef[2]
    if(inherits(a,"lm")) {
      b <- coef(a)[2]; a <- coef(a)[1]
    }
    xlim <- .$getXlim()
    if(!is.null(a)) {
      y <- a + b*xlim
      .$lines(xlim, y, ...)
    } else if(!is.null(h)) {
      .$lines(xlim, c(h,h), ...)
    } else if(!is.null(v)) {
      ylim <- .$getYlim()
      .$lines(c(v,v), ylim, ...)
    }
    
  }
  widget$text <- function(., x, y = NULL, labels = seq_along(x), 
          cex = 1, col = NULL, pos = NULL, ...) {

    ## XXX add in other args later
    xy <- xy.coords(x,y)
    xy$x <- .$xToPixels(x)
    xy$y <- .$yToPixels(y)
    
    ## recycle labels if needed
    labels <- rep(labels, length=length(xy$x))
    labels <- as.character(labels)
    labels <- shQuote(labels)
    ## recyle size
    size <- round(.$..pointsize * cex)
    size <- rep(size, length=length(xy$x))

    ## recycle cex
    cex <- rep(cex, length=length(xy$x))
    ## fix and recycle col
    if(is.null(col))
      col <- "black"
    col <- .$fixColor(col)
    col <- rep(col, length(xy$x))

    ## recycle pos
    if(is.null(pos)) pos <- 0
    pos <- rep(pos, length(xy$x))
    
    for(i in 1:length(xy$x)) {
      .$textSize(size[i])
##       if(!is.null(font))
##         .$textFont(font, size[i])
##       else if(is.numeric(cex))
##         .$textSize(size[i])

      .$fill(col[i])

      xoff <- 0; yoff <- 0
      if(pos[i] == 1)
        yoff <-  cex[i]* .$..pointsize
      else if(pos[i] == 2)
        xoff <- -cex[i] * .$..pointsize
      else if(pos[i] == 3)
        yoff <- -cex[i]* .$..pointsize
      else if(pos[i] == 4)
        xoff <- cex[i] * .$..pointsize
      .$ptext(labels[i], xy$x[i] + xoff, xy$y[i] + yoff)
    }
  }


  ##################################################
  ## add after CSS, scripts defined
  container$add(widget,...)

  return(widget)
}

#line 1 "d:/RCompile/CRANpkg/local/2.13/gWidgetsWWW/R/gradio.R"
##  Copyright (C) 2010 John Verzani
##
##  This program is free software; you can redistribute it and/or modify
##  it under the terms of the GNU General Public License as published by
##  the Free Software Foundation; either version 2 of the License, or
##  (at your option) any later version.
##
##  This program is distributed in the hope that it will be useful,
##  but WITHOUT ANY WARRANTY; without even the implied warranty of
##  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
##  GNU General Public License for more details.
##
##  A copy of the GNU General Public License is available at
##  http://www.r-project.org/Licenses/

## gradio
## XXX no [<- method!!!
## size?,
## XXX transport is off the ranch -- is this necessary?


gradio <- function(items, selected = 1, horizontal=FALSE,
       handler = NULL, action = NULL, container = NULL, ...) {

  ## use a checkbox if only one item
  if(length(items) == 1) {
    out <- gcheckbox(items, checked = selected == 1, handler=handler, action=action, container = container, ...)
    return(out)
  }

  widget <- EXTComponentWithItems$new(toplevel=container$toplevel,
                                      ..selected = selected,
                                      ..horizontal = horizontal,
                                      ..handler = handler,
                                      ..action = action
                                      )
  class(widget) <- c("gRadio",class(widget))
  
  widget$setValue(value = selected) ## store the index
  widget$setValues(value = items)

  ## define methods
  ## The value stored is the index -- not the text
  ## this way we are untainted.
  widget$assignValue <- function(., value) {
    .$..data <- as.numeric(value[[1]])
  }
  ## we store values by index
  widget$getValue <- function(.,index=NULL ,drop=NULL,...) {
    ## we need to revers logic from AWidgtet$getValue
    out <- .$..data
 
    ## no index -- return values
    if(is.null(index)) index <- FALSE
    if(index)
      return(as.numeric(out))
    else
      return(.$..values[as.numeric(out)])
  }
  
  ## override setValue
  ## We store the index
  widget$setValue <- function(., index=NULL,..., value) {
    ## values can be set by index or character
    if(is.null(index) || !index) {
      ind <- which(value == .$getValues())
      if(length(ind) == 0) return()
      ind <- ind[1]
    } else {
      ind <- value
    }
     
    ## we store the index
    .$..data <- ind

    if(exists("..shown",envir=., inherits=FALSE))
      ##cat(.$setValueJS(index=ind), file=stdout())
      .$addJSQueue(.$setValueJS(index=ind))
  }

  widget$setValueJS <- function(.,..., index) {
    if(exists("..setValueJS", envir=., inherits=FALSE)) .$..setValueJS(...)
    
    out <- String() +
      .$asCharacter() + '.getComponent(' + as.character((index-1)) +
        ')' + '.setValue(true);'
    return(out)
  }
  
  ## to set values we a) remove old values b) add new ones c) handlers?
  ## XXX doesn't work!!!
##   widget$setValuesJS <- function(.,...) {
##     out <- String()

##     ## JS to remove values
##     out <- out +
##       'var n = ' + 'o' + .$ID + '.items.getCount();' +
##         'var i = 0;' +
##           'while(i < n) {' +
##             'var rb = ' + 'o' + .$ID + '.getComponent(n - i - 1);' +
##               'o' + .$ID + '.remove(rb);' +
##                 'i = i + 1;' +
##                   ' };' + '\n'

##     ## JS to add new ones
##     out <- out + .$makeRadioButtons()
##     out <- out + .$addRadioButtons()
##     out <- out + .$addRadioButtonHandlers()
##     return(out)
##   }

  widget$xtype <- "radio"
  widget$transportSignal <- "check"
  widget$checked <- function(.,i) (i == .$..selected)
  widget$ExtCfgOptions <- function(.) {
    out <- list(border = FALSE,
                hideBorders = TRUE,
                shim = FALSE,
                bodyStyle = list(padding = "5px"),
                items = .$makeItems()
                )
    if(.$..horizontal)
      out[['layout']] <- "column"
    return(out)
  }

  ## transport
  widget$transportValue <- function(.,...,i) {
    out <- String() +
      paste("if(checked==true) {",
            sprintf("_transportToR('%s', Ext.util.JSON.encode({value:%s}))",
                    .$ID,               # i passed into transportValue
                    i),
            "}",
            sep="\n")
    
      ## 'if(checked === true) {' +
      ##   '_transportToR(' + shQuote(.$ID) +
      ##     ',' +
      ##       'Ext.util.JSON.encode({value:' + i + '})' +
      ##       ');}' + '\n'         # i passed into transportValue()!

    return(out)
  }

  ## kludgy override of where transport is written
  widget$transportFUN <- function(.) return(String(""))
  ## override to put with checked===true
  widget$writeHandlerFunction <- function(., signal, handler) {
    out <- String() +
      'function(' + .$handlerArguments(signal) + ') {' +
        'if(checked === true) {' +
          'runHandlerJS(' + handler$handlerID
    if(!is.null(handler$handlerExtraParameters))
      out <- out + ',' + handler$handlerExtraParameters
    out <- out + ');' + 
      '};}' + '\n'
    return(out)
  }

  ## add after CSS, scripts defined
  container$add(widget,...)


  ## add Handler
##   widget$addRadioButtonHandlers <- function(.) {
##     out <- String()
##     values <- .$getValues(); n <- length(values)
##     for(i in 1:n) {
##       out <- out +
##         .$ID + 'radiobutton' + i +
##           '.on("check",function(e,check) {' +
##             'if(check === true) {' +
##               ## do transport
##               '_transportToR(' + shQuote(.$ID) +
##                 ',' + i + ');' + '\n'
##       if(!is.null(.$..handler)) {
##         out <- out +
##           'runHandlerJS(' + .$..handlerID + ',\'""\', \'""\', true,this,{delay:100,buffer:100, single:false});'
##       }
##       out <- out +'}});' + '\n'
##     }
##     ## we need to add this handler for *each* radio button
##     ## we add transport to R and handler if present.
##     return(out)
##   }

##   widget$addHandler <- function(.,signal, handler, action=NULL,...) {
##     id <- get("addHandler",envir=EXTWidget, inherits=FALSE)(.,
##                                               signal=NULL, handler,action,...)
##     .$..handlerID <- id
##     invisible(id)
##   }

  widget$addHandlerChanged <- function(., handler, action=NULL, ...) 
    .$addHandler(signal="check", handler, action=NULL, ...)
  
  
  widget$addHandlerClicked <- widget$addHandlerChanged
  

  ## we add handler regardless, as this introduces transport function
  if(is.null(handler))
    signal <- NULL
  else
    signal <- "check"
  id <- widget$addHandler(signal=signal, handler, action)
  invisible(widget)

}
#line 1 "d:/RCompile/CRANpkg/local/2.13/gWidgetsWWW/R/gseparator.R"
##  Copyright (C) 2010 John Verzani
##
##  This program is free software; you can redistribute it and/or modify
##  it under the terms of the GNU General Public License as published by
##  the Free Software Foundation; either version 2 of the License, or
##  (at your option) any later version.
##
##  This program is distributed in the hope that it will be useful,
##  but WITHOUT ANY WARRANTY; without even the implied warranty of
##  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
##  GNU General Public License for more details.
##
##  A copy of the GNU General Public License is available at
##  http://www.r-project.org/Licenses/

## hack to add separator
gseparator <- function(horizontal = TRUE, container = NULL, ...)  {
  if(is.null(container)) {
    obj <- "gseparator stub"
    class(obj) <- c("gSeparator", class(obj))
    return(obj)
  }
    
  if(horizontal)
    return(ghtml("<hr>",cont=container))
  else
    return()
}

#line 1 "d:/RCompile/CRANpkg/local/2.13/gWidgetsWWW/R/gslider.R"
##  Copyright (C) 2010 John Verzani
##
##  This program is free software; you can redistribute it and/or modify
##  it under the terms of the GNU General Public License as published by
##  the Free Software Foundation; either version 2 of the License, or
##  (at your option) any later version.
##
##  This program is distributed in the hope that it will be useful,
##  but WITHOUT ANY WARRANTY; without even the implied warranty of
##  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
##  GNU General Public License for more details.
##
##  A copy of the GNU General Public License is available at
##  http://www.r-project.org/Licenses/


## others
## propert ..length is added

## TODO: from being a vecto argument and using indices for slider...

##' slider widget
##'
##' Shows sequence of values. Can modify the tooltip via the tooltipTemplate argument (hidden)
##' @param from starting point
##' @param to ending point
##' @param by step size
##' @param value initial value
##' @param horizontal orientation
##' @param handler called when slider moved
##' @param action passed to handler
##' @param container parent container
##' @param ... passed to \code{add} method of container
##' @export
gslider <- function(from = 0, to = 100, by = 1, value = from,
                    horizontal = TRUE,
                    handler = NULL, action = NULL, container = NULL, ...) {

  widget <- EXTComponent$new(toplevel=container$toplevel,
                             ..from = from, ..to = to, ..by=by,
                             ..horizontal=horizontal
                             )
  class(widget) <- c("gSlider",class(widget))
  widget$setValue(value=value)
  widget$..coerce.with="as.numeric"
  widget$..length = if(horizontal) 300 else 100
  ## modify this. It needs to have {0} somewhere
  widget$..tooltipTemplate <- getFromDots(..., var="tooltipTemplate", default="{0}")

  ## CSS
  
  
  ## methods
  widget$getValueJSMethod <- "getValue"
  widget$setValueJSMethod <- "setValue"

  ## No methods in extjs to set the values (minValue, maxValue, increment) after construction
  ## so we can't implement [<- method

  ## coerce to numeric -- stores a value
  widget$assignValue <- function(., value) {
    .$..data <- as.numeric(value[[1]])
  }

  
  widget$transportSignal <- "change"
  widget$transportValue <- function(.,...) {
    out <- String() +
      'var value = newValue;'
    return(out)
  }
  widget$ExtConstructor <- "Ext.Slider"
  widget$ExtCfgOptions <- function(.) {
    out <- list("value"= svalue(.),
                "increment" = .$..by,
                "minValue" =  .$..from,
                "maxValue" = .$..to,
                "enableKeyEvents"=TRUE,
                "vertical"= !.$..horizontal,
                ## This works with 3.3.0,
                plugins = String(sprintf("new Ext.slider.Tip({getText: function(thumb){return String.format('%s', thumb.value)}})", .$..tooltipTemplate))
                ## needed for 3.0.0
#                plugins = String("new Ext.ux.SliderTip()")
              )

    if(.$..horizontal)
      out[['width']] <- .$..length
    else
      out[['height']] <- .$..length

    return(out)
  }


  ## add after CSS, scripts defined
  container$add(widget,...)


  if(!is.null(handler))
    widget$addHandler("change",handler=handler,action=action)
  
  invisible(widget)
}



#line 1 "d:/RCompile/CRANpkg/local/2.13/gWidgetsWWW/R/gspinbutton.R"
##  Copyright (C) 2010 John Verzani
##
##  This program is free software; you can redistribute it and/or modify
##  it under the terms of the GNU General Public License as published by
##  the Free Software Foundation; either version 2 of the License, or
##  (at your option) any later version.
##
##  This program is distributed in the hope that it will be useful,
##  but WITHOUT ANY WARRANTY; without even the implied warranty of
##  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
##  GNU General Public License for more details.
##
##  A copy of the GNU General Public License is available at
##  http://www.r-project.org/Licenses/

## Works as of Ext-3.0
## why are there no arrows???

## others

##' Basic spinbutton
##'
##' For some reason the images don't work!
##' @param from from value
##' @param to to
##' @param by by. From to by are same as seq() usage
##' @param value initial value
##' @param handler handler for when change is made
##' @param action passed to the handler, if given
##' @param container parent container
##' @param ... passed to add method of parent
##' @export
##' @examples /Tests/test-gspinbutton.R
##' @TODO get icons working. Not sure why they dont (positioning is the likely culprit)
gspinbutton <- function(from = 0, to = 100, by = 1, value = from,
                    handler = NULL, action = NULL, container = NULL, ...) {
  widget <- EXTComponent$new(toplevel=container$toplevel,
                             ..from = from, ..to = to, ..by=by
                             )
  class(widget) <- c("gSpinbutton",class(widget))
  widget$setValue(value=value)
  widget$..coerce.with="as.numeric"

  ## no index
  widget$assignValue <- function(., value) {
    .$..data <- as.numeric(value[[1]])
  }

  ## CSS
  ## XXX Get this css to work to get trigger icon for spin
  ##   widget$css <- function(.) {
##     out <- String()
##     f <- system.file("css","ext.ux.spinner.css", package="gWidgetsWWW")
##     out <- out + "\n" + paste(readLines(f), collapse="\n")
##     out
##   }
  widget$css <- function(.) {
    ## can't have comments etc., as this goes into one line.
    out <- paste(
#                 ".x-form-spinner-proxy{",
#                 "/*background-color:#ff00cc;*/",
#                 "}",
                 ".x-form-field-wrap .x-form-spinner-trigger {",
                   sprintf("background:transparent url('%s/spinner.gif') no-repeat 0 0;",gWidgetsWWWimageUrl),
                 "}",
                 ".x-form-field-wrap .x-form-spinner-overup{",
                 "background-position:-17px 0;",
               "}",
                 ".x-form-field-wrap .x-form-spinner-clickup{",
                 "background-position:-34px 0;",
               "}",
                 ".x-form-field-wrap .x-form-spinner-overdown{",
                 "background-position:-51px 0;",
               "}",
                 ".x-form-field-wrap .x-form-spinner-clickdown{",
                 "background-position:-68px 0;",
               "}",
                 "",
                 "",
                 ".x-trigger-wrap-focus .x-form-spinner-trigger{",
                 "background-position:-85px 0;",
               "}",
                 ".x-trigger-wrap-focus .x-form-spinner-overup{",
                 "background-position:-102px 0;",
               "}",
                 ".x-trigger-wrap-focus .x-form-spinner-clickup{",
                 "background-position:-119px 0;",
               "}",
                 ".x-trigger-wrap-focus .x-form-spinner-overdown{",
                 "background-position:-136px 0;",
               "}",
                 ".x-trigger-wrap-focus .x-form-spinner-clickdown{",
                 "background-position:-153px 0;",
               "}",
                 ".x-trigger-wrap-focus .x-form-trigger{",
                 "border-bottom: 1px solid #7eadd9;",
               "}",
                 "",
                 ".x-form-field-wrap .x-form-spinner-splitter {",
                 "line-height:1px;",
                 "font-size:1px;",
                 sprintf("background:transparent url('%s/spinner-split.gif') no-repeat 0 0;",gWidgetsWWWimageUrl),
                 "position:absolute;",
                 "cursor: n-resize;",
               "}",
                 ".x-trigger-wrap-focus .x-form-spinner-splitter{",
                 "background-position:-14px 0;",
               "}",
                 sep="")
    return(out)
  }
  ## methods
  widget$getValueJSMethod <- "getValue"

  widget$setValueJSMethod <- "setValue"
  widget$transportSignal <- c("spin")
  widget$ExtConstructor <- "Ext.ux.form.SpinnerField"
  widget$ExtCfgOptions <- function(.) {
    out <- list("value"= svalue(.),
                "minValue" =  .$..from,
                "maxValue" = .$..to,
                "allowDecimals"=TRUE,
                "decimalPrecision"=1,
                "accelerate"=TRUE,
                "incrementValue" = .$..by,
                "enableKeyEvents"=TRUE,
                "triggerClass"='x-form-spinner-trigger',
                "splitterClass"='x-form-spinner-splitter'
                )

    return(out)
  }


  ## add after CSS, scripts defined
  container$add(widget,...)

  widget$addHandlerChanged <- function(., handler, action=NULL) 
    .$addHandler(signal="spin",handler, action)
  

  if(!is.null(handler))
    addHandlerChanged(widget, handler, action)
  
  invisible(widget)
}

#line 1 "d:/RCompile/CRANpkg/local/2.13/gWidgetsWWW/R/gstatusbar.R"
##  Copyright (C) 2010 John Verzani
##
##  This program is free software; you can redistribute it and/or modify
##  it under the terms of the GNU General Public License as published by
##  the Free Software Foundation; either version 2 of the License, or
##  (at your option) any later version.
##
##  This program is distributed in the hope that it will be useful,
##  but WITHOUT ANY WARRANTY; without even the implied warranty of
##  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
##  GNU General Public License for more details.
##
##  A copy of the GNU General Public License is available at
##  http://www.r-project.org/Licenses/


## this adds text to toplevel's ..statusBarText
## and puts widget into ..statusBar so that ..shown can be set.
## if toplevel is a
## statusbar is different from gstatusbar -- does not pop to last message
gstatusbar <- function(text = "", container=NULL, ...) {

  widget <- EXTComponentNoItems$new(toplevel=container$toplevel)
  class(widget) <- c("gStatusbar",class(widget))

  widget$setValue(value=text)

  ## where to put. Here we make a distinction between
  ## subwindows and windows (which are toplevel component
  if(inherits(container,"gSubwindow")) {
    widget$sbContainer <- container
  } else {
    widget$sbContainer <- widget$toplevel
  }

  widget$sbContainer$..statusBarText <- text
  widget$sbContainer$..statusBar <- widget
  

  ## for statusbar, we get ID not from adding, but directly
  widget$ID <- container$newID()


  ## ## need to load in ux code, as of 3.0 status bar is not ext native
  ## widget$scripts <- function(.) {
  ##   f <- system.file("javascript","ext.ux.statusbar.js", package="gWidgetsWWW")
  ##   out <- paste(readLines(f), collapse="\n")
    
  ##   return(out)
  ## }

  
  ## helper to get status bar by its ID
  widget$getSBJS <- function(.) {
    out <- String() +
      'var widget = Ext.getCmp("' +
        .$sbContainer$ID + 'statusBar' + '");'
    return(out)
  }

  widget$setValue <- function(., index=NULL, ..., value) {
    .$..data <- value
    if(exists("..shown",envir=., inherits=FALSE)) 
      .$addJSQueue(.$setValueJS(index=index, ...))
  }
  widget$setValueJS <- function(.,...) {
    if(exists("..setValueJS", envir=., inherits=FALSE)) .$..setValueJS(...)

    out <- paste(sprintf("var widget = Ext.getCmp('%sstatusBar');", .$sbContainer$ID),
                 sprintf("widget.setText(%s);", ourQuote(svalue(.))),
                 sep="")

    ## 'text:' + shQuote(svalue(.)) + ',' +
    ##        'clear: true, iconCls: "x-status-valid" });' + '\n'
    
    return(out)
  }

  ## XXX Extra API
  ## a statusbar had *lots* of other things we could do here through Ext:
  ## menus, toolbars, busy signals, a clear after a certain time period
  ## we add these here as extra methods not in API
  widget$showBusy <- function(., text="Busy...") {
    out <- 
      paste(sprintf("var widget = Ext.getCmp('%sstatusBar');", .$sbContainer$ID),
            sprintf('widget.setBusyText("%s");', text),
            sep="")
    
    .$addJSQueue(out)
  }
  widget$clearBusy <- function(.) {
    out <- 
      paste(sprintf("var widget = Ext.getCmp('%sstatusBar');", .$sbContainer$ID),
            'widget.setBusyText("");',
            sep="")
    
    .$addJSQueue(out)
  }
  widget$clearStatus <- function(.) {
    out <- paste(sprintf("var widget = Ext.getCmp('%sstatusBar');", .$sbContainer$ID),
          'widget.clearStatus();',
          sep="")
#    out <- .$getSBJS() +
#      'widget.clearStatus();';
#      sprintf('widget.showStatus({text: "%s", iconCls:"x-status-valid"});', .$getValue())
    .$addJSQueue(out)
  }

  invisible(widget)
}
#line 1 "d:/RCompile/CRANpkg/local/2.13/gWidgetsWWW/R/gsvg.R"
##  Copyright (C) 2010 John Verzani
##
##  This program is free software; you can redistribute it and/or modify
##  it under the terms of the GNU General Public License as published by
##  the Free Software Foundation; either version 2 of the License, or
##  (at your option) any later version.
##
##  This program is distributed in the hope that it will be useful,
##  but WITHOUT ANY WARRANTY; without even the implied warranty of
##  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
##  GNU General Public License for more details.
##
##  A copy of the GNU General Public License is available at
##  http://www.r-project.org/Licenses/


##' widget to display svg files
##'
##' Used like a non-interactive device: create file
##' (\code{getStaticTmpFil(ext=".svg")}), use this with the svg device
##' (such as \code{devSVGTips} from the \pkg{RSVGTipsDevice} package),
##' then pass to \code{f} or use \code{svalue<-} to assign.
##' @param f filename
##' @param width width of widget in pixels
##' @param height height of widget in pixels
##' @param container parent container
##' @param ... passed to \code{add} method of parent container
##' @export
gsvg <- function(f, width=480, height=400,
##                 handler = NULL, action = NULL,
                 container = NULL,...) {

  ## put this into code
  ## require(RSVGTipsDevice, quietly=TRUE, warn=FALSE)
  if(!bypassRequire("RSVGTipsDevice"))
    return(glabel(gettext("gsvg needs the RSVGTipsDevice package to be installed"), cont=container))

  widget <- EXTComponentNoItems$new(toplevel=container$toplevel,
                             ..width=as.numeric(width),
                             ..height=as.numeric(height))
  
  class(widget) <- c("gSvg",class(widget))
  if(!missing(f))
    widget$setValue(value=f)

  widget$ExtConstructor <- "Ext.Panel"
  widget$ExtCfgOptions <-  function(.) {
    out <- list()
    out[['border']] <- FALSE
    
    out[['html']] <- paste(             # so we get quotes
                           "<div id=\"svg", .$ID, "\"></div>",
                           sep="")
    
    return(out)
  }

  
  widget$footer <- function(.) {
    out <- String(sep="\n") +
      .$setValueJS() 
    return(out)
  }

  widget$setValueJS <- function(.,...) {
    if(exists("..data", envir=., inherits=FALSE)) {
      ## need to write handlers here by munging svg file
      ## Issue here is the javascript code in the gWidgetsWWW page is not
      ## known to the SVG page so the following doesn't work
      ## One needs to write the AJAX call directly
      ## XXX Leaving this for later
      ##       if(exists("..handlers", envir=., inherits=FALSE)) {
      ##         allHandlers <- .$..handlers
      ##         handler <- allHandlers[[1]]

      ## XXX If we require XML add to dependencies for the package
      ##         require(XML, quietly=TRUE, warn=FALSE)
      ##         doc <- xmlParse(.$..data)
      ##         d <- xmlRoot(doc)
      ##         out <- String() +
      ##           'runHandlerJS(' + handler$handlerID + ",\'\',\'\');"
      ##         xmlAttrs(d[[4]]) <- c(onclick=as.character(out))
      ##         saveXML(doc, .$..data)
      ##       }
      
      value <- .$..data ## function name
      ## convert to URL -- it is in static directory
      value <- convertStaticFileToUrl(value)
      out <- String() +
        paste(sprintf("var el%s = document.getElementById('svg%s');", .$ID, .$ID),
              sprintf("el%s.innerHTML = '<embed src=\"%s\" width=%s height=%s type=\"image/svg+xml\">';",
                      .$ID,
                      escapeQuotes(value),
                      .$..width, .$..height),
              collapse="")
        ## "var el = document.getElementById('svg" + .$ID + "');" + "\n" +
        ##   "el.innerHTML =  '<embed src=\"" + value + "\" " +
        ##     "width=" + .$..width + " " +
        ##       "height=" + .$..height + " " +
        ##         "type=\"image/svg+xml\">';"
      .$addJSQueue(out)
      ## cat(out)
    } else {
      return("")
    }
  }

  ## Handler code needs to be written. This stub just ensures it isn't
  ## written out if specified.
  widget$writeHandlersJS <- function(., signal, handler=NULL) { return("")}

  ## XXX replace when handler code added
  ##   if(!is.null(handler)) 
  ##     widget$addHandlerClicked(handler, action)

  
  ## add after CSS, scripts defined
  container$add(widget,...)
  invisible(widget)
  
}

#line 1 "d:/RCompile/CRANpkg/local/2.13/gWidgetsWWW/R/gtable.R"
##  Copyright (C) 2010 John Verzani
##
##  This program is free software; you can redistribute it and/or modify
##  it under the terms of the GNU General Public License as published by
##  the Free Software Foundation; either version 2 of the License, or
##  (at your option) any later version.
##
##  This program is distributed in the hope that it will be useful,
##  but WITHOUT ANY WARRANTY; without even the implied warranty of
##  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
##  GNU General Public License for more details.
##
##  A copy of the GNU General Public License is available at
##  http://www.r-project.org/Licenses/


## use GridView to show a table

## working

## svalue
## transport
## click and double click handler
## icon fun: use class(icon) to mark
## multiple is  working
## [<- : needs to have data frame with same column types, no. of columns

## get working:
## names<-, names for headers


##' A table widget
##'
##' A widget for displaying a data frame in tabular format
##' The \code{[<-} method is only for replacing the data frame and must have the same class columns as the original. One can load the inital data frame with a 0-row data frame
##' @param items items (data frame) to display. Can be modified with
##' \code{[<-} method. Changing column types is not supported.
##' @param multiple logical. Do we allow multiple selection
##' @param chosencol The svalue() method returns a single value, by default. This species column of that value.
##' @param icon.FUN A function to generate icons given by items. Icons should return urls, as does getStockIcons()
##' @param filter.column Ignored in gWidgetsWWW
##' @param filter.labels Ignored in gWidgetsWWW
##' @param filter.FUN Ignored in gWidgetsWWW. Implement filtering manually. The visible<- method is automatically available (some toolkits need \code{filter.FUN="manual"}). Also there is a \code{$filter} proto method for filtering by a regular expression. Sorting is enabled through the headers
##' @param handler single click handlers
##' @param action action passed to handler
##' @param container parent container
##' @param ... passed to parent container's \code{add} method
##' @note The default size of the widget is lacking. The \code{size<-}
##' method is often needed for proper layout. No \code{names} or
##' \code{names<-} method.
##' @export
gtable <- function(items, multiple = FALSE, chosencol = 1,
                   icon.FUN = NULL,
                   filter.column = NULL, filter.labels = NULL,
                   filter.FUN = NULL, handler = NULL, action = NULL,
                   container = NULL, ...,
                   width=200, height=200
                   ) {

  widget <- EXTComponentWithStore$new(toplevel=container$toplevel,
                                      ..multiple = multiple,
                                      ..icon.FUN = icon.FUN,
                                      ..width=width, ..height=height
                                      )

  class(widget) <- c("gTable",class(widget))

  theArgs <- list(...)
  
  ## set up store
  store <- EXTStore$new(toplevel=container$toplevel)
  store$ID <- container$newID()       # set ID

  ## load in items
  if(!is.data.frame(items)) {
    items <- data.frame(items, stringsAsFactors=FALSE)
  }
  
  store$chosenCol <- chosencol
  if(!is.null(icon.FUN)) {
    n <- length(items)
    icons <- icon.FUN(items)
    class(icons) <- c("icon",class(icons)) # to render as icon
    items$..icons <- icons
    items <- items[,c(n+1,1:n)]
    ## must up the chosen col by 1
    store$chosenCol <- store$chosenCol + 1
  }
  items <- cbind("__index"=seq_len(nrow(items)), items)
  store$data <- items
  widget$..store <- store

  ## set up widget
  widget$setValue(value = 1)            # first column is selected on startup
  
  

  ## setValues need to add in icons.
  widget$setValues <- function(.,i,j,...,value) {
    ## XXX need to include i,j stuff
    ## XXX value must be a data frame of the same size as original
    ## add in icons if present
    items <- value
    if(exists("..icon.FUN", envir=., inherits=FALSE)) {
      if(!is.null(.$..icon.FUN)) {        # adjust icons
        icon.FUN <- get("..icon.FUN",.)
        icons <- icon.FUN(items)
        class(icons) <- c("icon",class(icons)) # to render as icon
        n <- length(items)
        items$..icons <- icons
        items <- items[,c(n+1,1:n)]
      }
    }
    items <- cbind("__index"=seq_len(nrow(items)), items)
    .$..store$data <- items

    if(exists("..shown",envir=., inherits=FALSE))
      ##cat(.$setValuesJS(...), file=stdout())
      .$addJSQueue(.$setValuesJS(...))
  }

 

  ## transport mouse clicks back as row indices. Can be multiple or single
  widget$transportSignal <- c("cellclick")
  widget$ExtConstructor <- "Ext.grid.GridPanel"
  widget$ExtCfgOptions <- function(.) {
    out <- list(store = String(.$..store$asCharacter()),
                columns = String(.$makeColumnModel()),
                stripeRows = TRUE,
                enableRowBody = TRUE, 
                frame = FALSE,
                autoExpandColumn=tail(names(.$..store$data), n=1)
                ) ## also autoExpandColumn, XXX
    
    if(.$..multiple) {
      out[["sm"]] <- String() +
        'new Ext.grid.RowSelectionModel({singleSelect:false})'
    } else {
      out[["sm"]] <- String() +
        'new Ext.grid.RowSelectionModel({singleSelect:true})'
    }

    ## size in panel config, not setStyle
    if(exists("..width",envir = .,inherits=FALSE))
      out[["width"]] <- .$..width
    else
      out[["width"]] <- "auto"
    
    if(exists("..height",envir = .,inherits=FALSE))
      out[["height"]] <- .$..height
    else
        out[["height"]] <- "auto"
    
    return(out)
  }

  widget$footer <- function(.) {
    sprintf('%s.getSelectionModel().selectFirstRow();',.$asCharacter())
  }
  
  ## changed = clicked
  widget$addHandlerClicked <- function(.,handler, action=NULL, ...) {

    ## we need to set up some stuff
    .$addHandler(signal="cellclick",
                 handler = handler,
                 action = action,
                 handlerArguments = "grid, rowIndex, colIndex, e",
                 handlerValue = "var value = rowIndex + 1;"
                 )
  }

  ## double click is default
  widget$addHandlerDoubleclick <- widget$addHandlerChanged <- function(.,handler, action=NULL, ...) {
    ## we need to set up some stuff
    .$addHandler(signal="dblclick",
                 handler = handler,
                 action = action,
                 handlerArguments = "grid, rowIndex, colIndex, e",
                 handlerValue = "var value = rowIndex + 1;")
  }
  
  
  ###
  container$add(widget,...)

  if(!is.null(handler))
    widget$addHandlerChanged(handler, action=action)
  
  
  invisible(widget)
  
}
#line 1 "d:/RCompile/CRANpkg/local/2.13/gWidgetsWWW/R/gtext.R"
##  Copyright (C) 2010 John Verzani
##
##  This program is free software; you can redistribute it and/or modify
##  it under the terms of the GNU General Public License as published by
##  the Free Software Foundation; either version 2 of the License, or
##  (at your option) any later version.
##
##  This program is distributed in the hope that it will be useful,
##  but WITHOUT ANY WARRANTY; without even the implied warranty of
##  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
##  GNU General Public License for more details.
##
##  A copy of the GNU General Public License is available at
##  http://www.r-project.org/Licenses/

## no wrap argument in Ext
## font.attr not implemented -- use markup
## svalue
## svalue<-
## add (one line at end only)
## handlers?
gtext <- function(text = NULL, width = NULL, height = 300,
                  font.attr = NULL, wrap = TRUE,
                  handler = NULL, action = NULL, container = NULL,...,
                  resizable = FALSE     # gWidgetsWWW arg. Keep?
                  ) {

  if(!resizable) {
    widget <- EXTComponentText$new(toplevel=container$toplevel,
                               ..width = width,..height=height,
                               ..wrap = wrap)
    class(widget) <- c("gText", class(widget))
  } else {
    widget <- EXTComponentResizable$new(toplevel=container$toplevel,
                                        ..width = width,..height=height,
                                        ..wrap = wrap)
    class(widget) <- c("gText","gWidgetResizable", class(widget))
    
  }
  widget$setValue(value=text)
  

  ## CSS

  ## Scripts

  ## methods
  widget$add <- function(.,child, where="end", ...) {
    ## warp around svalue<-
    if(where == "end")
      svalue(.) <- c(svalue(.), child)
    else
      svalue(.) <- c(child,svalue(.))
  }
  widget$insert <- widget$add
  
  ## methods
  ## getValue must escape the strings -- they are URL encoded by escape()
  widget$coerce.with <- function(., val) unescapeURL(val)
  
  
  widget$getValueJSMethod <- "getValue"
  widget$setValueJSMethod <- "setValue"

  ## lots of escapes for multiline stuff
  widget$setValueJS <- function(.,...) {
    if(exists("..setValueJS", envir=., inherits=FALSE)) .$..setValueJS(...)

    ## if(gWidgetsWWWIsLocal()) {
    ##   theData <- paste(.$..data, collapse="\\n")
    ## } else {
    ##   theData <- paste(.$..data, collapse="\\n")
    ## }

    out <- sprintf("%s.setValue('%s');", .$asCharacter(), stripSlashN(.$..data, sep=" ", dostrwrap=FALSE))
    ## out <- String() +
    ##   .$asCharacter() + '.setValue(' +
    ##     shQuote(theData) + ');' + '\n'

    return(out)

  }

  widget$transportSignal <- "change"
  widget$transportValue <- function(.,...) {
    out <- String() +
      sprintf("var value=escape(%s.%s());",
              .$asCharacter(), .$getValueJSMethod)
##      'var value = escape(' + .$asCharacter() + '.' +
##        .$getValueJSMethod + '());' + '\n'
    return(out)
  }
  widget$ExtConstructor <- "Ext.form.TextArea"
  widget$ExtCfgOptions <- function(.) {
    out <- list()
    out[["value"]] = stripSlashN(svalue(.), sep="\\\\n", dostrwrap=FALSE)
    if(!is.null(.$..width)) {
      out[["width"]] <- .$..width
    } else {
      out[["width"]] <-  "auto"
    }
    if(!is.null(.$..height)) {
       out[["height"]] <- .$..height
     } else {
       out[["height"]] <-  "auto"
     }
    out[["selectOnFocus"]] <- TRUE
    out[["enableKeyEvents"]] <- TRUE
    return(out)
  }

  ## add after CSS, scripts defined
  container$add(widget,...)


  if(!is.null(handler))
    widget$addHandler("change",handler=handler,action=action)
  
  invisible(widget)
}

#line 1 "d:/RCompile/CRANpkg/local/2.13/gWidgetsWWW/R/gtree.R"
##  Copyright (C) 2010 John Verzani
##
##  This program is free software; you can redistribute it and/or modify
##  it under the terms of the GNU General Public License as published by
##  the Free Software Foundation; either version 2 of the License, or
##  (at your option) any later version.
##
##  This program is distributed in the hope that it will be useful,
##  but WITHOUT ANY WARRANTY; without even the implied warranty of
##  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
##  GNU General Public License for more details.
##
##  A copy of the GNU General Public License is available at
##  http://www.r-project.org/Licenses/


##' gtree widget
##'
##' Widget to create atree dynamically by specifying the offspring. This implementation
##' does not allow for grids.
##' @param offspring Function with signature (path, data). Returns a
##' data frame with columns: id (which create the path), hasOffspring
##' (logical indicating if it has children), optionally an icon (a
##' stock icon name) and values (since a grid is not used, these are
##' pasted onto the id string.) The path comes from the id values. Can
##' be updated through proto method \method{setOffspring}. The
##' id's must not have a ':' as that is chosen as a delimiter.
##' @param offspring.data passed to offspring call so that the offspring function can be parameterized if desired. Can be updated through proto method \method{setOffspringData}.
##' @param icon.FUN NULL, function or logical. If a function then will
##' compute icons from calling this on offspring, if logical (and
##' TRUE) then third column is assumed to be a stock icon, if NULL
##' then no icons.
##' @param chosencol (if/when?) grid is implemented will work with svalue method
##' @param multiple for multiple selection (not implemented)
##' @param handler called on double click
##' @param action passed to handler
##' @param container container object
##' @param ... passed to containers add method
##' @TODO implement multiple
##' @example
##' \dontrun{
##' # galton watson
##' p <- .5 
##' offspring <- function(path, ...) {
##'   x <- rbinom(2, 1, p)
##'   nms <- paste(path, 0:1, sep=":")
##'   icons <- c("dismiss","ok")[x+1]
##'   data.frame(id=nms, hasoffspring=as.logical(x), icons=icons, stringsAsFactors=FALSE)
##' }
##' 
##' w <- gwindow("Galton Watson tree")
##' g <- ggroup(cont=w, horizontal=FALSE)
##' ghtml("A node in a Galton-Watson tree has 0 or 2 offspring.<br /> In this case each has equal chance.", cont=g)
##' gseparator(cont=g)
##' tr <- gtree(offspring=offspring, icon.FUN=TRUE, cont=g)
##' size(tr) <- c(300,300)
##' b <- gbutton("Try again", cont=g, handler=function(h,...) tr$update())
##' visible(w) <- TRUE
##' }
gtree <- function(offspring = NULL,
                  offspring.data = NULL,
                  icon.FUN = NULL,
                  chosencol = 1,
                  multiple = FALSE, 
                  handler = NULL, action = NULL,
                  container = NULL,
                  ...) {

  widget <- EXTComponentWithProxyTreeStore$new(toplevel=container$toplevel,
                                               ..multiple = multiple
                                               )

  class(widget) <- c("gTree",class(widget))

  theArgs <- list(...)
  
  ## set up store
  store <- EXTProxyTreeStore$new(toplevel=container$toplevel)
  store$ID <- container$newID()       # set ID
  container$toplevel$addStore(store)
  store$chosenCol <- chosencol

  store$..offspring <- offspring        
  store$..offspring.data <- offspring.data
  store$..icon.FUN <- icon.FUN
  store$..path <- character(0)
  widget$..store <- store

  
  widget$..data <- list(path="0", text=NA)             # base node with no value
  ## will need setValues method, ...

  
  widget$ExtConstructor <- "Ext.tree.TreePanel"
  widget$ExtCfgOptions <- function(.) {
    out <- list(useArrows=TRUE,
                autoScroll=TRUE,
                animate=TRUE,
                border=FALSE,
                enableDrag=TRUE,
                trackMouseOver=TRUE,
                rootVisible=FALSE,
                dataUrl=sprintf('%s/%s/%s/%s',
                  .$toplevel$..gWidgetsWWWAJAXurl,"proxystore", .$..store$asCharacter(), .$toplevel$sessionID),
                root=list(
                  expanded=TRUE,
                  nodeType='async',
                  draggable=FALSE,
                  id= '0'
                  )
                )
    

    
    ## size in panel config, not setStyle
    if(exists("..width",envir = .,inherits=FALSE))
      out[["width"]] <- .$..width
    else
      out[["width"]] <- "auto"
    
    if(exists("..height",envir = .,inherits=FALSE))
      out[["height"]] <- .$..height
    else
      out[["height"]] <- "auto"
    
    return(out)
  }

  ## what to do with this?
  widget$assignValue <- function(., value) {
    value <- value[[1]]                 # could tidy up
    .$..data <- list(path=strsplit(value[[1]], ":")[[1]][-1], text=value[[2]])
  }
  
  ## index=TRUE -- return path
  ## otherwise (default) return text of selected
  ## no means to return the whole path, but could get with offpring and a loop
  widget$getValue <- function(., index=NULL, drop=NULL, ...) {
    ## if(exists("..shown",envir=.,inherits=FALSE)) {
    ##   ## get from widget ID
    ##   out <- try(get(.$ID, envir=.$toplevel),silent=TRUE)
    ##   if(inherits(out,"try-error")) {
    ##     out <- .$..data
    ##   } else {
    ##     .$..data <- out                  # update data
    ##   }
    ## } else {
    ##   out <- .$..data
    ## }
    ## out is in form 0:path:text

    out <- .$..data

    index <- getWithDefault(index, FALSE)
    drop <- getWithDefault(drop, TRUE)

    if(index) {
      ind <- out[[1]]
      if(drop)
        tail(ind,n=1)
      else
        ind
    } else {
      out[[2]]
    }

  }

  ## update tree. Simply collapses values and when reexpanded will be all new
  widget$update <- function(x, ...) {
    . <- x
    if(.$has_local_slot("..shown")) {
      out <- String() +
        sprintf("%s.getRootNode().collapse();", .$asCharacter()) +
          sprintf("%s.getLoader().load(%s.getRootNode());", .$asCharacter(),.$asCharacter()) +
            sprintf("%s.getRootNode().expand();", .$asCharacter()) 
      .$addJSQueue(out)
    }
  }

  ## Can update after widget is shown through these proto methods
  widget$setOffspring <- function(., offspring) {
    .$..store$..offspring <- offspring
    .$update()
  }
  widget$setOffspringData <- function(., offspring.data)  {
    .$..store$..offspring.data <- offspring.data
    .$update()
  }
  
  ## XXX TODO: send back [path:path,text:text]

  widget$transportSignal <- c("click")
  widget$handlerArguments <- function(...) "node, e"
  widget$transportValue <- function(.,...) {
    ## we pass back both node and the text here
    out <- "var value = {id: node.id, text: node.text};"
    return(out)
  }

  ## add
  container$add(widget,...)

  ## changed = double clicked
  widget$addHandlerChanged <- function(., handler, action=NULL)
      .$addHandler(signal="dblclick",handler, action)

  if(!is.null(handler))
    widget$addHandlerChanged(handler, action=action)
  
  
  invisible(widget)
  
}
#line 1 "d:/RCompile/CRANpkg/local/2.13/gWidgetsWWW/R/gwebvis.R"
##  Copyright (C) 2010 John Verzani
##
##  This program is free software; you can redistribute it and/or modify
##  it under the terms of the GNU General Public License as published by
##  the Free Software Foundation; either version 2 of the License, or
##  (at your option) any later version.
##
##  This program is distributed in the hope that it will be useful,
##  but WITHOUT ANY WARRANTY; without even the implied warranty of
##  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
##  GNU General Public License for more details.
##
##  A copy of the GNU General Public License is available at
##  http://www.r-project.org/Licenses/

##'
##' ##' interface to the webvis package
##'
##' @param wv If present, a webvis object
##' @param handler Not implemented
##' @param action Not implemented
##' @param container A container to place graphic into
##' @export
gwebvis <- function(wv,
                    handler=NULL, action=NULL,
                    container=NULL, ...) {

  unfold.webvis <- NULL                 # quiet down check
  if(!bypassRequire("webvis"))
    return(glabel(gettext("gwebvis needs the webvis package to be installed"), cont=container))

  
  widget <- EXTComponentNoItems$new(toplevel=container$toplevel)
  
  class(widget) <- c("gWebvis",class(widget))
  widget$toplevel$do_gwebvis <- TRUE
  if(!missing(wv))
    widget$setValue(value=wv)


  
  widget$ExtConstructor <- "Ext.Panel"
  widget$ExtCfgOptions <-  function(.) {
    out <- list()
    out[['border']] <- FALSE
    out$width <- 800; out$height <- 800
    
    out[['html']] <- String() +
      sprintf('"<div id=\'gWidgetsWebvis_%s\'><scr" + "ipt type=\'text/javascript+protovis\'></scr" + "ipt></div>"', .$ID)

    return(out)
  }
  ##' for initial graphic
  widget$footer <- function(.) {
    out <- String() +
      .$setValueJS() 
    return(out)
  }
  ##' produce javascript
  widget$setValueJS <- function(.,...) {
    out <- ""

    if(exists("..data", envir=., inherits=FALSE)) {
      value <- .$..data

      if(!is.null(value) && is(value, "webvis")) {
        ## clear out
        value$render <- "vis.root.render();"
        value <- as.character(unfold.webvis(value))
        value <- paste(value, collapse=";")
        value <- gsub("\\n",";",value)
        ## call update from Element.js (html, loadScripts, callback)
        out <- String() +
          ## note hack to avoid nesting script tags
          sprintf("val=\"<scr\" + \"ipt type='text/javascript+protovis'>%s</scr\"+\"ipt>\";", value) + "\n" +
            sprintf("Ext.fly('%s').update(val,true);", .$ID) #gWidgetsWebvis_
      }
    }
    return(out)
  }
    

  ## Handler code needs to be written. This stub just ensures it isn't
  ## written out if specified.
  widget$writeHandlersJS <- function(., signal, handler=NULL) { return("")}

    ## XXX replace when handler code added
    ##   if(!is.null(handler)) 
    ##     widget$addHandlerClicked(handler, action)
    
  
  ## add after CSS, scripts defined
  container$add(widget,...)
  invisible(widget)
  
  }


#line 1 "d:/RCompile/CRANpkg/local/2.13/gWidgetsWWW/R/gwindow.R"
##  Copyright (C) 2010 John Verzani
##
##  This program is free software; you can redistribute it and/or modify
##  it under the terms of the GNU General Public License as published by
##  the Free Software Foundation; either version 2 of the License, or
##  (at your option) any later version.
##
##  This program is distributed in the hope that it will be useful,
##  but WITHOUT ANY WARRANTY; without even the implied warranty of
##  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
##  GNU General Public License for more details.
##
##  A copy of the GNU General Public License is available at
##  http://www.r-project.org/Licenses/


## XXX would like to integrate layout manager into this
## Should be a big panel with menubar and toolbar and statusbar areas
## ... contains width=, height= for gsubwindow call
## if container is not null, then a subwindow is made
## handler called on unload

## Trait for top-level windows
EXTTopLevel <- EXTContainer$new()

##' Property. Where to render this window to. Default is the entire webpage
##'
##' May not work otherwise, needs testing
EXTTopLevel$..renderTo <- "Ext.getBody()"

##' assign values
##' 
##' @param . self
##' @param id id of widget
##' @param value value to assign
EXTTopLevel$assignValue <- function(., id, value) {
  widget <- .$getWidgetByID(id)
  widget$assignValue(value)
}

## track Children
##' Add a child to list of children
##' @param . self
##' @param child child to add (widget instance)
EXTTopLevel$addChild <- function(., child) {
  if(!.$has_local_slot("..children"))
    l <- list()
  else
    l <- .$..children
  l[[child$ID]] <- child
  .$..children <- l
}

##' retrieve child instance from its ID
##' 
##' @param .  self
##' @param id id of child (child$ID yields this)
EXTTopLevel$getWidgetByID <- function(., id) {
  if(.$has_local_slot("..children")) {
    l <- .$..children
    l[[id]]
  } else {
    NULL
  }
}

## handlers for proxy stores
## These methods are used by gbigtable and by gtree to dynamically populate data
## XXX Might make sense to make all objects with stores use this (gcombobox, ...)

##' Property. We need to look up proxy stores when we process. This needs to be set in widget
EXTTopLevel$proxyStores <- list()

##' add a proxy store for later lookup
##' 
##' @param . self
##' @param store store instance. Stores within list
EXTTopLevel$addStore <- function(., store) {
  l <- .$proxyStores
  l[[store$asCharacter()]] <- store
  .$proxyStores <- l
}

##' get a proxy store from its id
##'
##' @param . self
##' @param id id of store, eg. gWidget34store
##' @return store instance
EXTTopLevel$getStoreById <- function(., id) {
  .$proxyStores[[id]]
}


##' Reload the window
EXTTopLevel$reload <- function(.) {
  if(.$has_local_slot("..shown")) {
    .$addJSQueue("document.location.reload(true);")
  }
}

##' Main top level window
##'
##' Each script needs to have one and only one instance as a global
##' variable. The visible argument is ignored. One must call
##' \code{visible<-} with a value of \code{TRUE} after the page is
##' layed out. (This prints the javascript to the browser).
##'
##' @param title Page title
##' @param visible ignored. Must set visibility TRUE after GUI construction is done.
##' @param width size in in pixels. (Mostly only for a subwindow)
##' @param height size in pixels (For subwindows)
##' @param parent If non-\code{NULL} creates a sub window.
##' @param handler assigned to page unload event
##' @param action passed to handler
##' @param ... ignored
##' @return a gwindow instance. Many methods but key one is \code{visible<-}.
##' @note There are some \pkg{proto} properties that can be set to adjust the values. These are \code{loadingText}; \code{doLoadingText}; \code{..show\_error\_message}; \code{AJAXtimeout}
##' @examples
##' \dontrun{
##' w <- gwindow("hello test")  ## must be global
##' gbutton("Click me", cont=w, handler=function(h,...) galert("Hello world", parent=w))
##' visible(w) <- TRUE          ## call to cat out values to web browser
##' }
##' @export
gwindow <- function(title="title", visible=TRUE,
                    name=title,
                    width = NULL, height = NULL, parent = NULL,
                    handler=NULL, action=NULL,...) {

  ## width, height  for subwindows
  ## changed container argument to  parent to match gWidgets
  container <- parent

   ## make a subwindow?
   if(!is.null(container))
     return(gsubwindow(title=title,handler=handler, action=action,
                        visible=visible,
                        width = width, height = height,
                        container=container,...))

  w <- EXTTopLevel$new(
                        visible=visible,
                        ..actions = list(),
                       ..children = list())
  class(w) <- c("gWindow",class(w))


  
  ## no parent container -- so no ID. We fix this
  w$ID <- "gWidgetID0"                  # XXX Issue if more than one per page!
  w$sessionID <- makeSessionID()
  w$toplevel <- w
  w$..renderTo <- String("Ext.getBody()") # can override
  w$..show_error_messages <- gWidgetsWWWIsLocal()         # set to NULL to not show
  w$doLoadingText <- gWidgetsWWWIsLocal() # do we print a message when calling a handler
  w$loadingText <- gettext("Loading...")  # prints when a handler is called to indicate a request.
  ##  w$..visible <- FALSE
  w$x.hidden <- FALSE                   # don't hide.

  

  w$setValue(value=title)
  w$jscriptHandlers <- list()        # handlers in parent winoow
  w$JSQueue <- character()           # output of JS handlers
  w$toplevel <- w
  w$..IDS <- c()
  w$..blocked_handlers <- c()           # IDs of handlers not to call
  theArgs <- list(...)
  w$..AJAXtimeout <- ifelse(is.null(theArgs$AJAXtimeout), 10000, theArgs$AJAXtimeout)
  w$proxyStores <- list()         # local instance
  
  ## store name in title for handlers.
##XXX  w$titlename <- make.names(title)
##XXX  assign(w$titlename,w, enxvir=.GlobalEnv)

  ## Find values from apache config or from local config

  ## find URL for AJAX call, place into toplevel for later reference
  if(!exists("gWidgetsWWWAJAXurl") || is.null(gWidgetsWWWAJAXurl))
    gWidgetsWWWAJAXurl <- getOption("gWidgetsWWWAJAXurl")
  if(is.null(gWidgetsWWWAJAXurl))  {
    gWidgetsWWWAJAXurl <- "/gWidgetsWWW"
  }
  w$..gWidgetsWWWAJAXurl <- gWidgetsWWWAJAXurl
  w$..gWidgetsWWWrunUrl <- getWithDefault(getOption("gWidgetsWWWrunUrl"), "/gWidgetsWWWrun")
  #### methods ####
  
  ##' run a handler
  ##' id is id of handler. Can be used for blocked handlers
  ##' context is named list of values to pass into "h" object
  ##' Handlers that don't run raise an error
  w$runHandler <- function(., id, context) {
    id <- as.numeric(id)
    if(! (id %in% .$..blocked_handlers)) {
      lst <- .$jscriptHandlers[[as.numeric(id)]]
      h <- list(obj=lst$obj, action = lst$action)
      if(!missing(context) &&  is.list(context)) {
        for(i in names(context)) 
          h[[i]] <- context[[i]]
      }
      ## Each XXXJS call  adds to the JSQueue, it isn't done here
      out <- try(lst$handler(h), silent=TRUE)          # add to JS Queue
      if(inherits(out, "try-error"))
        stop(sprintf("<br />Error running handler: %s", out))
    }
    .$runJSQueue()                      # run the queue
  }
  

  
  ## for top-level window visible same as print
  w$setVisible <- function(., value) {
    if(as.logical(value)) 
      .$Show()
    else 
      stop(sprintf("Can't hide top level window"))
  }
  ## can't dispose of top-level window
  w$visible <- function(.) {}

  w$addAction <- function(., action) 
    .$..actions <- c(.$..actions, action)
  
  ## set title
  ## XX should this be just for Ext.getBody() cases?
  w$setValueJS <- function(.,...) {
    if(exists("..setValueJS", envir=., inherits=FALSE))
      .$..setValueJS(...)
    
    out <- sprintf("document.title = %s;", ourQuote(.$..data))
    
    return(out)
  }
  
  
   ## css and scripts are different for gwindow instances, as these
   ## are the toplevel instances -- sub classes place there values into
   ## these lists.
   ## css is a list keyed by class.
   w$css <- list("gWindow"=list(obj=w,FUN=function(.) {return("")}))
   
   w$scripts <-
     list("gWindow" = list(obj=w,
            FUN = function(.) {
              ## Scripts, this gets placed into a
              ## list keyed by the class of the object
              
              out <- String()

              ## add Library and Style Sheets
              ## use "script" to add library
              ## use "link" to add style sheet for type
##               out <- out +
##                 'AddLibrary = function(type, file){' +
##                   'var NewNode=document.createElement(type);' +
##                     'NewNode.src=file;' +
##                        'document.body.appendChild(NewNode);' +
##                          '};' + '\n'
              

              
              ## runHandlerJS is key to linking in R with the web page
              ## we pass in an ID and optionally some values with keys.


              ## Some javascript functions
              ## XXX make better

              if(.$has_local_slot("..show_error_messages")) {
                processFailure <-
                  paste("function processFailure(response, options) {",
                        "Ext.example.msg('Error:', response.responseText, 4);",
                        if(.$has_local_slot("..statusBar")) {
                          sprintf("sbwidget=Ext.getCmp('%sstatusBar');sbwidget.clearBusy();", .$ID)
                        },
                        "};",
                        sep="\n")
              } else {
                processFailure <-
                  paste("function processFailure(response, options) {",
                        "eval(response.responseText);",
                        if(.$has_local_slot("..statusBar")) {
                          sprintf("sbwidget=Ext.getCmp('%sstatusBar');sbwidget.clearBusy();", .$ID)
                        },
                        "};",
                        sep="\n")                
              }
              out <- out +
                processFailure +
                  "\n" +
                    paste("function evalJSONResponse(response, options) {",
                          "  eval(response.responseText);",
                          ifelse(.$has_local_slot("..statusBar"),
                                 sprintf("sbwidget=Ext.getCmp('%sstatusBar');sbwidget.clearBusy();", .$ID),
                                 ""),
                          "};\n",
                          sep="")
              
              ## code to run a javascript handler
              out <- out +
                paste('runHandlerJS = function(id,context) {',
                      ifelse(.$doLoadingText,
                             ifelse(.$has_local_slot("..statusBar"),
                                    sprintf("sbwidget=Ext.getCmp('%sstatusBar'); sbwidget.setBusyText('busy...   ');", .$ID),
                                    sprintf("Ext.getBody().mask('%s');", .$loadingText)
                                    ),
                             ""),
                      "\n",
                      "Ext.Ajax.request({",
                      sprintf("  url: '%s',",.$..gWidgetsWWWAJAXurl),
                      "  success: evalJSONResponse,",
                      "  failure: processFailure,",
                      "  method: 'POST', " ,
                      sprintf("  timeout: %s,", .$..AJAXtimeout),
                      "  params: { type: 'runHandler', ",
                      "    sessionID: sessionID,",
                      "    id: id,",
                      "    context: context",
                      "  }",
                      "});",
                      '};',
                      "\n",
                      sep="")

              ## show loading text box if requested
              if(.$doLoadingText) {
                out <- out +
                  paste("Ext.Ajax.on('requestcomplete', function() {Ext.getBody().unmask() }, this);",
                        "Ext.Ajax.on('requestexception', function() {Ext.getBody().unmask()}, this);",
                        "\n", sep="")
              }
              
              ## transportToR copies data in widget back into R
              ## using a global variable IDXXX
              ## We don't expect a return value
              out <- out +
                paste('_transportToR = function(id, val) {',
                      ifelse(.$has_local_slot("..statusBar"),
                             sprintf("sbwidget=Ext.getCmp('%sstatusBar'); sbwidget.setBusyText('Transferring...   ');", .$ID),                             
                             ""),
                      "Ext.Ajax.request({",
                      sprintf("  url: '%s',", gWidgetsWWWAJAXurl),

                      ## What to do with return value. This commented out code ignores.
                      ## we added in an eval in case there is some reason we want to return from an assign
                      ## it makes sense as then R can communicate back to WWW when a value is assigned
                      ## we get some XML back, not JSON
                      ## "  success: function(response, opts)",
                      ## ifelse(.$has_local_slot("..statusBar"),
                      ##        sprintf("{sbwidget=Ext.getCmp('%sstatusBar');sbwidget.setText(sbwidget.oldtext);},", .$ID),
                      ##        "{},"),
                      "  success: evalJSONResponse,",
                      "  failure: processFailure,",
                      sprintf("timeout: %s,", .$..AJAXtimeout),
                      "  method: 'POST'," ,
                      "  params: { type: 'assign', ",
                      "    sessionID: sessionID,",
                      "    variable: id,",
                      "    value: val",
                      "  }",
                      "})",
                      "};",
                      "\n",
                      sep="")
              
              out <- out +
                paste('function clearSession() {',
                      "Ext.Ajax.request({",
                      sprintf("  url: '%s',", gWidgetsWWWAJAXurl),
                      "  method: 'POST',",
                      "  params: {",
                      "    type: 'clearSession', ",
                      "    sessionID: sessionID",
                      "  }",
                      "})",
                      "};",
                      "\n",
                      sep="")
              

              
              ## this is for tooltips in, say, gnotebook tabs.
              out <- out +
                "Ext.QuickTips.init();\n"

              return(out)
            })
          )

   w$ExtConstructor <- "Ext.Panel" ## inherits
   w$ExtCfgOptions <- function(.) { ## ih
     out <- list(
                 renderTo= .$..renderTo,
                 border = TRUE,
#                 bodyBorder = FALSE,
                 hideBorders = FALSE,
                 autoScroll = TRUE
#                 ,layout="fit"           # one item only, will expand
                 )
     
     return(out)
   }

   ## code to set up iconclasses for use with buttons, toolbar, menubar
   w$iconDir <- ""
   w$makeIconClasses <- function(.) {
     ## XXX -- this doesn't work with IE so we cut it out.
     return("")
     ## old below
     out <- String()
     x <- getStockIcons();
     nms <- names(x)
     for(i in 1:length(x)) {
       out <- out +
         'Ext.util.CSS.createStyleSheet("' +
           paste("button.",nms[i], "{background-image:url(",x[i],")};", sep="",
                 collapse="") +
           '");' + '\n'
     }

     return(out)
   }

  ## simple header
   w$header <- function(.) {
     out <- String() + .$makeIconClasses()
     .$Cat(out)
   }

   
  w$footer <- function(.) {
  
     ## ## clear out any old IDS
     ## remove(list=ls(pat="^gWidgetID",envir=.),envir=.)

     ## doLayout()
     out <- String()

     out <- out +
       sprintf("%s.doLayout();\n", .$asCharacter())


     ## hide children if requested
     hide <- function(.) {
       if(.$has_local_slot("children")) {
         sapply(.$children, hide)
       }
       if(.$has_local_slot("..visible") && !.$..visible) {
         out <<- out + .$setVisibleJS()
       }
     }
     hide(.)


     
     ## set title 
     out <- out +
       sprintf("document.title=%s;\n",ourQuote(.$getValue()))

     ## write out sessionID
     out <- out +
       sprintf("var sessionID = %s;\n", ourQuote(.$sessionID))
     
     .$Cat(out)
   }
  

  ## w$..setHandlers <- function(.) {
  ##    ## deprecated, see addHandler now
  ##    return("")
  ##  }

  
  ## unload handler
  if(!is.null(handler)) 
    w$addHandler("onunload",handler, action=action)

   
  invisible(w)
 }

##' gsubwindow
##' 
##' a subwindow appears on top of a regular window
##' style properties width, height (size) and x, y are used
##' should be draggable -- but doesn't seem to work
##' svalue<- sets title
##' visible(obj) TRUE is showing
##' visible(obj) <- FALSE/TRUE hides/shows
##' @param title title of window
##' @param visible ignored
##' @param width width of subwindow
##' @param height height of subwindow
##' @param handler close handler
##' @param action value passed to handler
##' @param container parent container for subwindow
##' @param ... passed to container's add method
gsubwindow <- function(title="Subwindow title", visible=TRUE,
                        width=500, height=300,
                        handler = NULL, action=NULL, container=NULL,...) {

  widget <- EXTContainer$new(toplevel=container$toplevel,
                             ..visible = as.logical(visible)
                             ) 
  class(widget) <- c("gSubwindow",class(widget))
  widget$setValue(value=title)
  
  if(is.null(width)) width <- 500
  if(is.null(height)) height <- 300
  widget$..style <- c("width"=width, height=height)
  ## methods
  widget$addAction <- function(., action) 
     .$..actions <- c(.$..actions, action)


  widget$dispose <- function(.) visible(.) <- FALSE

  ## set title
  widget$setValueJS <- function(., ...) {
  if(.$has_local_slot("..setValueJS"))
    .$..setValueJS(...)
  
  out <-  sprintf("%s.setTitle(%s);\n", .$asCharacter(), ourQuote(escapeHTML(.$..data)))
  .$addJSQueue(out)
  }


  ## visible
  widget$setVisible <- function(., value) {
    value <- as.logical(value)
    .$..visible <- value
    if(.$has_local_slot("..shown"))
      .$addJSQueue(.$setVisibleJS())
    else 
      .$Show(queue=TRUE)
  }

  widget$setVisibleJS <- function(.) {
    if(.$has_local_slot("..setVisibleJS"))
      .$..setVisibleJS()
    
    ## opposite -- we already changed if we got here
    out <- sprintf("%s.%s();", .$asCharacter(),
                   ifelse(.$..visible, "show", "hide"))
## XXX    .$addJSQueue(out)
  }


  widget$ExtConstructor = "Ext.Window"
  widget$ExtCfgOptions <- function(.) {
    style <- .$..style
    width <- style['width']
    height <- style['height']
    
    out <- list(
                'title' = .$..data,
                'layout' = "auto",      # not fit
                'width' = as.numeric(width),
                'height' =  as.numeric(height),
                'closeAction' = "hide",
                'autoScroll' = TRUE,
                'plain' = TRUE,
                'button' = String('[{text: "Close", handler: function(){') +
                'o' + .$ID + '.hide();}}]'
                )
    ## statusbar. Menu? Tool?
    if(.$has_local_slot("..statusBar")) {
      sbText <- String() +
        paste('new Ext.ux.StatusBar({',    # as of 3.0 not in ext -- uses toolbar instead
              sprintf('  id: "%sstatusBar",', .$ID),
              sprintf('defaultText: "Powered by %s, extjs and gWidgetsWWW."',
                      ifelse(gWidgetsWWWIsLocal(), "the R help server",
                             "RApache")),
              sprintf('text: %s', ourQuote(.$..statusBarText)),
              '})',
              sep="")
      out[['bbar']] <- sbText
      .$..statusBar$..shown <- TRUE
    }
    
    return(out)
  }

  widget$header <- function(.) {}
  widget$footer <- function(.) {
    ## render and show
    out <- String() +
      sprintf("%s.render();", .$asCharacter())

    ## show if ready
    if(visible(.))
      out <- out +
        sprintf("%s.show();", .$asCharacter())

    out
  }

  ## we don't add. The subwindow prints out
  container$add(widget, ...)


  ## return
  invisible(widget)
}


##' Reload document
##'
##' Reloads document from server
##' @param object gwindow object
##' @param ... ignored
##' @export
update.gWindow <- function(object, ...) object$reload()
#line 1 "d:/RCompile/CRANpkg/local/2.13/gWidgetsWWW/R/icons.R"
##  Copyright (C) 2010 John Verzani
##
##  This program is free software; you can redistribute it and/or modify
##  it under the terms of the GNU General Public License as published by
##  the Free Software Foundation; either version 2 of the License, or
##  (at your option) any later version.
##
##  This program is distributed in the hope that it will be useful,
##  but WITHOUT ANY WARRANTY; without even the implied warranty of
##  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
##  GNU General Public License for more details.
##
##  A copy of the GNU General Public License is available at
##  http://www.r-project.org/Licenses/

addStockIcons <- function(iconNames, iconFiles) {
  ## Files is a url
  si <- getStockIcons()
  for(i in 1:length(iconNames))
    si[iconNames[i]] <- iconFiles[i]
  .stockicons$si <- si
}

## return list of icons
## Assumes the files in images are installed in base URL
## otherwise paste in prefix.
.stockicons <- proto()
.stockicons$si <- NULL

getStockIcons <- function(icons) {
  gWidgetsWWWimageUrl <- getOption("gWidgetsWWWimageUrl")
  if(is.null(gWidgetsWWWimageUrl))
    gWidgetsWWWimageUrl <- "/custom/gw/images"
  
  if(is.null(.stockicons$si)) {
    files <- list.files(path = system.file(paste("basehtml","images",sep=.Platform$file.sep),
                          package = "gWidgetsWWW"))
    newfiles <- gsub("\\.gif$|\\.jpg$|\\.jpeg$|\\.png$","",files)
    ##XX was <<- below
    si <<- paste(gWidgetsWWWimageUrl,strip_slashes(files), sep="/")
    class(si) <- c("URL",class(si))
    names(si) <- newfiles
    .stockicons$si <- si
  }

  if(missing(icons))
    return(.stockicons$si)
  else
    return(.stockicons$si[icons])
}


#line 1 "d:/RCompile/CRANpkg/local/2.13/gWidgetsWWW/R/string.R"
##  Copyright (C) 2010 John Verzani
##
##  This program is free software; you can redistribute it and/or modify
##  it under the terms of the GNU General Public License as published by
##  the Free Software Foundation; either version 2 of the License, or
##  (at your option) any later version.
##
##  This program is distributed in the hope that it will be useful,
##  but WITHOUT ANY WARRANTY; without even the implied warranty of
##  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
##  GNU General Public License for more details.
##
##  A copy of the GNU General Public License is available at
##  http://www.r-project.org/Licenses/

## String related functions

##################################################
## string class

##' String constructor -- gives some methods for character data
##'
##' A string is a length 1 character vector with additional methods
##' @param x a string
##' @param sep Passed to \code{paste} call when string is created
##' @param common Passed to \code{paste} call when string is created
##' @return a "String" instance. See is \code{+.String} method
String <- function(x,sep="",collapse="") {
  if(missing(x)) x <- ""
  x <- as.character(paste(x, collapse=collapse))
  class(x) <- c("String","character")
  attr(x,"..sep") <- sep
  attr(x,"..collapse") <- collapse
  return(x)
}

##' concatenate strings
##'
##' @param x String class object
##' @param ... added to x
##' @return a String class object
"+.String" <- function(x,...) {
  sep <- attr(x,"..sep"); collapse <- attr(x,"..collapse")
  out <- paste(x,paste(...,sep="",collapse=""),sep=sep,collapse=collapse)
  invisible(String(out,sep=attr(x,"..sep"), collapse = attr(x,"..collapse")))
}

##' combine strings with +
##' @param x a String object
##' @param ... combined with x
##' @return a String object 
c.String <- function(x,...) {
  sep <- attr(x,"..sep"); collapse <- attr(x,"..collapse")
  out <- x + paste(..., sep=sep, collapse=collapse)
  return(out)
}

##' print method for String class
##'
##' @param x String object
##' @param ... ignored
print.String <- function(x,...) cat(x)

##' length method for String class
##'
##' @param x String object
##' @return number of characters in x
length.String <- function(x) nchar(x)
"[.String" <- function(x,i,j,...,drop=TRUE) {
  if(missing(i)) i <- 1:length(x)
  unlist(strsplit(x,""))[i]
}

##' Assign into a string object
##'
##' The string is indexed by position of character
##' @param i indices to slice into. Replaces if not specified
##' @param j ignored
##' @param ... ignored
##' @param value inserts value into this position
"[<-.String" <- function(x,i,j,...,value) {
  tmp <- x[]
  if(missing(i))
    tmp <- String(value)
  else
    tmp[i] <- String(value)

  return(String(paste(tmp,collapse="")))
}


##################################################
## Quotes etc.

##' escaping strings
##' 
##' we use shQuote as a convenience for
##' word -> 'word' however, it doesn't escape values as we would like, hence
##' this one.
##' @param x character
##' @return character has single quotes escaped
shQuoteEsc <- function(x) {
  out <- gsub("\'","\\\\'",x)
  out <- paste("'",out,"'",sep="")
  return(out)
}


##' replace ' with \\'
##' Also can replace ' with &143; type thingy
escapeQuotes <- function(x) UseMethod("escapeQuotes")
escapeQuotes.default <- function(x) x
escapeQuotes.character <- function(x) {
  for(i in 1:length(x)) {
    chars <- unlist(strsplit(x[i],""))
    ind <- grep("'", chars)
    if(length(ind) > 0) {
      for(j in ind) {
        if(j < 3 || (chars[j-2] != "/" && chars[j-1] != "/"))
          if(gWidgetsWWWIsLocal())
            chars[ind] <- "\\'"
          else
            chars[ind] <- "\'"
      }
      x[i] <- paste(chars, collapse="")
    }
  }
  return(x)
}
#line 1 "d:/RCompile/CRANpkg/local/2.13/gWidgetsWWW/R/utils.R"
##  Copyright (C) 2010 John Verzani
##
##  This program is free software; you can redistribute it and/or modify
##  it under the terms of the GNU General Public License as published by
##  the Free Software Foundation; either version 2 of the License, or
##  (at your option) any later version.
##
##  This program is distributed in the hope that it will be useful,
##  but WITHOUT ANY WARRANTY; without even the implied warranty of
##  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
##  GNU General Public License for more details.
##
##  A copy of the GNU General Public License is available at
##  http://www.r-project.org/Licenses/

## utility functions

##' make a session id for keeping track of different instances
##'
##' @return character. a session id
makeSessionID <- function() {
  ## get key
  key <- "123456"
  if(!is.null(tmp <- getOption("sessionSecretKey"))) {
    key <- tmp
  } else if(exists("sessionSecretKey", envir=.GlobalEnv)) {
    key <- get("sessionSecretKey", envir=.GlobalEnv)
  }
  txt <- as.character(as.numeric(runif(1) + Sys.time()))
  key <- paste(key, txt, sep="")
  ID <- digest(key, algo="md5")
  return(ID)
}



##' are we online?
##'
##' Returns TRUE is online. Deprecate?
gWidgetsWWWIsOnline <- function() FALSE

##' bypass require so that we can put optional packages in different fields in DESCRIPTION
##'
##' From Henrik Bengtsson
##' @param pkg package name
bypassRequire <- function(pkg) {
  path <- system.file(package=pkg);
  (path != "");
}


##' get with a default
getWithDefault <- function(x, default) {
  if(is.null(x))
    default
  else
    x
}

##' get from ...
getFromDots <- function(..., var, default) getWithDefault(list(...)[[var]], default)
#line 1 "d:/RCompile/CRANpkg/local/2.13/gWidgetsWWW/R/www-utils.R"
##  Copyright (C) 2010 John Verzani
##
##  This program is free software; you can redistribute it and/or modify
##  it under the terms of the GNU General Public License as published by
##  the Free Software Foundation; either version 2 of the License, or
##  (at your option) any later version.
##
##  This program is distributed in the hope that it will be useful,
##  but WITHOUT ANY WARRANTY; without even the implied warranty of
##  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
##  GNU General Public License for more details.
##
##  A copy of the GNU General Public License is available at
##  http://www.r-project.org/Licenses/

##' Encode a URL
##'
##' like URLencode, but takes care of plus signs
##' @param x character
##' @return character. Has entities inserted
##' @export
ourURLencode <- function(x) {
  ## handle + signs too
  x <- URLencode(x)
  x <- gsub("+","&2B;", x, fixed=TRUE)
  x
}

##' Decode a URL
##'
##' same as URLdecode, but takes care of plus signs
##' @param x character
##' @return calls URLdecode then decodes plus signs
ourURLdecode <- function(x) {
  if(is.null(x))
    return(x)
  x <- URLdecode(x)
  x <- gsub("&2B;", "+", x, fixed=TRUE)
  x
}


##' function to escapeHTML characters
##'
##' @param x character
##' @return character. Replaces characters with HTML entitities
##' @export
escapeHTML <- function(x) {
  translations <- function(i) {
    switch(i,
           '<' = "&lt;",
           '>' = "&gt;",
           '&' = "&amp;",
           '"' = "&quot;",
           "'" = "&#39;",
           ## nee3d ASCII equivalents
           ##            'à' = "&agrave;",
##            'À' = "&Agrave;",
##            'â' = "&acirc;",
##            'Â' = "&Acirc;",
##            'ä' = "&auml;",
##            'Ä' = "&Auml;",
##            'å' = "&aring;",
##            'Å' = "&Aring;",
##            'æ' = "&aelig;",
##            'Æ' = "&AElig;",
##            'ç' = "&ccedil;",
##            'Ç' = "&Ccedil;",
##            'é' = "&eacute;",
##            'É' = "&Eacute;",
##            'è' = "&egrave;",
##            'È' = "&Egrave;",
##            'ê' = "&ecirc;",
##            'Ê' = "&Ecirc;",
##            'ë' = "&euml;",
##            'Ë' = "&Euml;",
##            'ï' = "&iuml;",
##            'Ï' = "&Iuml;",
##            'ô' = "&ocirc;",
##            'Ô' = "&Ocirc;",
##            'ö' = "&ouml;",
##            'Ö' = "&Ouml;",
##            'ø' = "&oslash;",
##            'Ø' = "&Oslash;",
##            'ß' = "&szlig;",
##            'ù' = "&ugrave;",
##            'Ù' = "&Ugrave;",        
##            'û' = "&ucirc;",      
##            'Û' = "&Ucirc;",
##            'ü' = "&uuml;",
##            'Ü' = "&Uuml;",
##            '®' = "&reg;",       
##            '©' = "&copy;",   
##            '€' = "&euro;",
##              ' ' = "&nbsp;",
           i)
  }
  tmp <- unlist(strsplit(x, ""))
  tmp <- sapply(tmp, translations)
  x = paste(tmp, collapse="")
  return(x)
}

##' reverse for escapeURL
##'
##' @param x character
##' @return character
unescapeURL <- function(x) {
  codes <- c("%20" = " ",
             "%22" = '"',
             "%3C" = "<",
             "%3E" = ">",
             "%23" = "#",
             "%25" = "%",
             "%28" = "(",
             "%29" = ")",
             "%2B" = "+",
             "%2C" = ",",
             "%7B" = "{",
             "%7D" = "}",
             "%7C" = "|",
             "%5C" = "\\",
             "%5E" = "^",
             "%7E" = "~",
             "%5B" = "[",
             "%5D" = "]",
             "%60" = "`",
             "%3B" = ";",
             "%2F" = "/",
             "%3F" = "?",
             "%3A" = ":",
             "%40" = "@",
             "%3D" = "=",
             "%26" = "&",
             "%27" = "\\'",
             "%24" = "$",
             "%0A" = "\n")
  
  for(i in names(codes)) 
    x <- gsub(i,codes[i],x)
  return(x)
}

##' strip leading and trailing slashes (/) from character
##' 
##' @param x string to trim
##' @param leading logical. If TRUE stripleading slashes
##' @param trailing logical. If TRUE strip trailing slashes
strip_slashes <- function(x, leading=TRUE, trailing=TRUE) {
  if(leading)
    x <- gsub("^[/]{1,}","",x)
  if(trailing)
    x <- gsub("[/]{1,}$","", x)
  x
}
  
##' make a string safe to pass in as HTML fragment.
##'
##' We pass in strings that work with '....' so we replace ' with \" an d" with \"
##' @param x a string to replace ' with
##' @result string with quotes escaped and placed within ''
ourQuote <- function(x) {
  x <- gsub("'",'"',x)
  sprintf("'%s'", x)
}

##' strip off \n and turn ' into \' so that value can be assigned withing javascript call
##'
##' Used by ghtml, glabel, gtext, ...
##' @param x a character vector
##' @param encode do we escape HTML bits
stripSlashN <- function(x, encode=FALSE, sep=c("\\n", "<br />"), dostrwrap=TRUE) {
  x <- gsub("\n"," ", x)
  x <- gsub("'", "\\\\'",x)
  if(dostrwrap) {
    x <- paste(x, collapse="")
    x <- strwrap(x)
  }
  if(encode)
    x <- gWidgetsWWW:::escapeHTML(x)
  x <- paste(x, collapse=sep)

  x
}

##################################################
## Helpers
## see source defn.
##' Is value a URL: either of our class URL or matches url string: ftp://, http:// or file:///
##'
##' @param x length 1 character value to test
##' @return Logical indicating if a URL.
isURL <- function(x) {

  ## we can bypass this by setting a value to have this class
  ## as in isURL((class(x) <- "URL"))
  if(is(x,"URL")) return(TRUE)
  if (is.character(x) && length(x) == 1) 
    out <- length(grep("^(ftp|http|file)://", x)) > 0
 else
   out <- FALSE
  return(out)
}

##' Add URL to class of object if not already
##'
##' @param x object to add class to. Should be length 1 character
##' @return returns object
asURL <- function(x) {
  if(!is(x,"URL"))
    class(x) <- c("URL",class(x))
  return(x)
}


##################################################
## JSON stuff

##' take value from JSON
##'
##' Same as rjon's fromJSON only deals with ""
##' @param x character string containin JSON code
##' @param ... passed to fromJSON
##' @return character
##' @export
ourFromJSON <- function(x, ...) {
  if(x == "") return(x)
  fromJSON(x, ...)
}

##' make toJSON a method
##' Failed? Wasn't dispatching right, so hard code in classes
ourToJSON <- function(x, ...) {
  f <- function(x) {
    if(is(x, "logical"))
      x <- tolower(as.character(x))
    if(is(x, "factor"))
      x <- as.character(x)
    if(is(x, "character"))
      x <- shQuote(x)
    
    sprintf("[%s]", paste(as.character(x), collapse=","))
  }
  if(is(x, "data.frame"))
    out <- sprintf("[%s]",
            paste(shQuote(names(x)), sapply(x, f), sep=":", collapse=","))
  else
    out <- f(x)
}

##' coerce an object into a JSStrig
## String here is misnamed --
## this function creates JS values
coerceToJSString <- function(x) UseMethod("coerceToJSString")
coerceToJSString.default <- function(x) x # no quote
coerceToJSString.character <- function(x) shQuoteEsc(x)
coerceToJSString.factor <- function(x) shQuoteEsc(as.character(x))
coerceToJSString.logical <- function(x) tolower(as.character(x))
coerceToJSString.function <- function(x) coerceToJSString(x())
coerceToJSString.String <- function(x) x # to avoid quoting



## coerce a single value to javascript with quotes
## logical is buggy
toJS <- function(x) UseMethod("toJS")
toJS.default <- function(x) shQuoteEsc(x)
toJS.logical <- function(x) tolower(as.character(x))
toJS.integer <- toJS.numeric <- function(x) x
toJS.factor <- function(x) toJS(as.character(x))


##' Make a JS array from an R object
##'
##' @param x R object to make into an array
##' @param doBrackets logical Use brackets in ouput []
##' @return JSON encoded
emptyJSArray <- function(doBrackets=TRUE)  ifelse(doBrackets, "[]", "")
toJSArray <- function(x, doBrackets=TRUE) UseMethod("toJSArray")
toJSArray.default <- function(x, doBrackets=TRUE) stop("no default method")
toJSArray.integer <- toJSArray.numeric <- function(x, doBrackets=TRUE) {
  if(!length(x)) return(emptyJSArray(doBrackets))
  x <- as.character(x)
  x[is.na(x)] <- "'NA'"
  out <- paste(x, collapse=",")
  if(doBrackets)
    out <- paste("[",out,"]", sep="")
  return(out)
}
toJSArray.factor <- toJSArray.character <- function(x, doBrackets=TRUE) {
  if(!length(x)) return(emptyJSArray(doBrackets))
  x <- gsub("\\n", " ", x)              # \n messes up JS parsing
  out <- paste(shQuoteEsc(as.character(x)), collapse=",")
  if(doBrackets) out <- paste("[", out,"]",sep="")
  return(out)
}
toJSArray.String <- function(x, doBrackets=TRUE) {
  if(!length(x)) return(emptyJSArray(doBrackets))  
  x <- gsub("\\n", " ", x)              # \n messes up JS parsing
  out <- paste(x, collapse=",")
  if(doBrackets) out <- paste("[", out,"]",sep="")
  return(out)
}

toJSArray.logical <- function(x,doBrackets=TRUE) {
  if(!length(x)) return(emptyJSArray(doBrackets))
  x <- tolower(as.character(x))
  x[is.na(x)] <- "'NA'"
  toJSArray.String(x, doBrackets)
}

toJSArray.character <- function(x, doBrackets=TRUE) {
  if(!length(x)) return(emptyJSArray(doBrackets))  
  x <- sprintf("%s", ourQuote(x))
  toJSArray.String(x, doBrackets)
}

toJSArray.matrix <- function(x, doBrackets=TRUE) {
  out <- paste(apply(x,1,toJSArray), collapse=",")
  if(doBrackets) out <- paste("[", out, "]", sep="")
  return(out)
}


  
toJSArray.list <- function(x, doBrackets=TRUE) {
  sapply(x, function(i) toJSArray(i,doBrackets))
}
       
## This needs work
toJSArray.data.frame <- function(x,doBrackets=TRUE) {
  if(nrow(x) == 0) {
    n <- ncol(x)
    out <- paste(rep("[]", n), collapse=",")
    if(doBrackets)
      out <- sprintf("[%s]", out)
    return(out)
  }
  ## depends on number of cols
  if(ncol(x) == 1)
    return(toJSArray(x[,1,drop=TRUE]))

  ## otherwise, we need to work
  tmp <- sapply(x, function(y) toJSArray.list(y, doBrackets=FALSE))
  if(!is.matrix(tmp))
    tmp <- matrix(tmp, ncol=length(tmp))

  tmp1 <- apply(tmp,1,function(i) paste("[",paste(i,collapse=","),"]",sep=""))
  out <- paste(tmp1, collapse=",")
  if(doBrackets) out <- paste("[",out,"]",sep="")
  return(out)
}

##' Get a static file that can be served by the browser
##'
##' @param ext file extension. Leading dot unnecessary
##' @param filename If given uses this filename, otherwise calls tempfile
##' @return the the file name.
##' @seealso \code{\link{convertStaticFileToUrl}} to get corresponding url for serving through the browser.
##' @examples
##' ## a basic usage:
##' \dontrun{
##' f <- getStaticTempFile(".svg")
##' svg(f)
##' hist(rnorm(100))
##' dev.off
##' svalue(gsvg_instance) <- convertStaticFileToUrl(f)
##' }
##' @export
getStaticTmpFile <- function(ext="", filename)  {
  if(gWidgetsWWWIsLocal()) {
    gWidgetsWWWStaticDir <- get("gWidgetsWWWStaticDir", envir=.GlobalEnv)
  } else {
    gWidgetsWWWStaticDir <- getOption("gWidgetsWWWStaticDir")
  }

  try(dir.create(gWidgetsWWWStaticDir, showWarnings=FALSE), silent=FALSE)
  ext <- gsub("^[.]{1,}","",ext)        # remove do if there
  
  if(missing(filename)) {
    out <- paste(tempfile(tmpdir=gWidgetsWWWStaticDir),ext,sep=".")
  } else {
    filename <- sprintf("%s.%s", filename, ext)
    out <- file.path(gWidgetsWWWStaticDir,filename)
  }
  return(out)
}

##' convert static file from local file system to url for serving in browser
##'
##' @param val filename, usuallly given by getStaticTmpFile
##' @return a url to serve through browser
##' @export
convertStaticFileToUrl <- function(val) {
  if(gWidgetsWWWIsLocal()) {
    gWidgetsWWWStaticDir <- get("gWidgetsWWWStaticDir", envir=.GlobalEnv)
    gWidgetsWWWStaticUrlBase <- get("gWidgetsWWWStaticUrlBase", envir=.GlobalEnv)
  } else {
    gWidgetsWWWStaticDir <- getOption("gWidgetsWWWStaticDir")
    gWidgetsWWWStaticUrlBase <- getOption("gWidgetsWWWStaticUrlBase")
  }
  ## strip off static dir from val, append on static url base
#  val <- gsub(gWidgetsWWWStaticDir, gWidgetsWWWStaticUrlBase, val)

  
  if(grepl(gWidgetsWWWStaticDir, val, fixed=TRUE))
    val <- gsub(gWidgetsWWWStaticDir, gWidgetsWWWStaticUrlBase, val, fixed=TRUE) # fixed!

  ourURLencode(val)
}

