.packageName <- "traitr"
#line 1 "/private/tmp/RtmpA4c7nI/R.INSTALL10d63af1/traitr/R/helpers.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/

## Some helper functions
## avoid loading in roxygen by user
if(!exists("roxygen"))
  roxygen <- function() NULL

#' Function to return value or an object (or default if value is null, NA or "")
#'
#' @param x object
#' @param default default value
#' @return Returns default if x is NA, null or "", otherwise x
get_with_default = function(x, default) {
  if(is.null(x) || is.na(x) || x == "")
    default
  else
    x
}



## doc writing helpers
## eg.
## paste(desc("A description"),param("param: a paramter"),returns("some return value"))

#' write values in paired tags with optional class
#'
#' internal function for writing proto docs
#' @param tag tag to wrap in, eg. "ul"
#' @param ... values to be wrapped. Pasted together
#' @param class optional call to add to tag
#' @return a string
wrap_in_tag <- function(tag,..., class="") {
  if(class != "")
    class=paste("class=",class,sep="")
  paste("<",tag," ", class,">",paste(...),"</",tag,">",sep="")
}
#' specify a description for documentation
#'
#' internal function for writing proto docs.
#' @param ... Values pasted in
#' return a string
desc <- function(...) wrap_in_tag("p", "Description:", ..., class="description")
#' specify a method paramter
#'
#' internal function for writing proto docs.
#' @param value name of parameter
#' @param ... Values pasted in
#' return a string
param <- function(value, ...) {
  value <- paste("<code class='param'>",value,"</code>", paste(..., sep=" ", collapse=" "))
  wrap_in_tag("p",value)
}
#' Document return value
#'
#' internal function for writing proto docs.
#' @param ... Values pasted in
#' return a string
returns <- function(...) wrap_in_tag("p", "Returns:", ..., class="returns")
#' write <ul> 
#'
#' internal function for writing proto docs.
#' @param values values to form items
#' @return returns a string
ul <- function(values) 
  wrap_in_tag("ul", paste(wrap_in_tag("li", values), collapse="\n"), "ul")

## merge
#' merge two lists, possibly overwriting
#'
#' @param x  a list
#' @param y a list. Named values of \code{y} are assigned to \code{x} and then \code{x} is returned.
#' @param overwrite If \code{TRUE} named values in \code{y} clobber similarly named values in \code{x}
#' @return Returns a list
merge.list <- function(x,y, overwrite=TRUE) {
  for(i in names(y)) {
    if(is.null(x[[i]]) || overwrite)
      x[[i]] <- y[[i]]
  }
  x
}
#line 1 "/private/tmp/RtmpA4c7nI/R.INSTALL10d63af1/traitr/R/base.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/


#' @include helpers.R
roxygen()
## to quiet down some errors and notes in R CMD check:
require(proto)
assign(".super", NULL)


#' Base Trait to place common properties and methods
#' @export
BaseTrait <- proto(
                    ## we add a class to our objects to mimic class behavior (not dispatch though)
                    .doc_class=paste(
                      desc("There is no class information from <code>class()</code> for <code>proto</code> objects",
                           "this propertys allows us, in a lightweight manner, to keep track of a class for them.")
                      ),
                    class="TraitR",
                   ## identify as a traitr proto object
                   traitr=TRUE,
                    ## Convenience method to add to the class.
                    ## Not documented
                    add_class = function(., newclass) .$class <- c(newclass, .$class),
                    ## some methods to simplify tasks
                    ## make a new child object and call its initialization method if present
                    .doc_new=paste(
                      desc("Creates clone of proto object and calls the <code>init</code> method, if defined."),
                      param("...", "passed to <code>proto</code> call.")
                      ),
                    new = function(., ...) {
                      obj <- .$proto(...)
                      obj$do_call("init")
                      obj
                    },
                   ## assign if not null
                   .doc_assign_if_null=paste(
                     desc("Assign value or method to proto object if not present"),
                     param("key","Key to assign to"),
                     param("value", "Value to assign")
                     ),
                   assign_if_null=function(., key, value) {
                     if(!.$has_local_slot(key))
                       assign(key, value, envir=.)
                   },
                    ## append to a property list
                    ## if a list, then optional key will set key for lookup
                    .doc_append=paste(
                      desc("Append a value to a property list."),
                      param("name","Property name"),
                      param("value","value"),
                      param("key","If a list, this adds a key for lookup by name. Otherwise, appended to end of list.")
                      ),
                    append=function(., name, value, key) {
                      val <- get(name, envir=.)
                      if(is.list(val)) {
                        if(!missing(key))
                          val[[key]] <- value
                        else
                          val[[length(val)+1]] <- value
                      } else {
                        val <- c(val, value)
                      }
                      assign(name, val, envir=.)
                    },

                    ## is method to check if the proto object has a class
                    ## the class is something we set, not an R class
                    .doc_is=paste(
                      desc("A function to test if object has any of classes specified."),
                      param("class","A character vector containing class names. (Not real classes, but those",
                            "defined within this package.)",
                            "Function returns <code>TRUE</code> if any mathches exists.")
                      ),
                    is = function(., class=NULL) {
                      if(!is.null(class))
                        any(class %in% .$class)
                      else
                        TRUE
                    },
                   ## some mutatr like methods
                   ## has_slot <--> exists
                   .doc_has_slot=paste(
                     desc("Does slot (property) exist?"),
                     param("key","Name of property"),
                     param("inherits","Look into ancestry?")
                   ),
                   has_slot=function(., key) {
                     exists(as.character(key), envir=.)
                   },
                   .doc_has_local_slot=paste(
                     desc("Same as has_slot, only looks only in present object, not ancestors")
                     ),
                   has_local_slot=function(.,key) {
                     exists(as.character(key), envir=., inherits=FALSE)
                   },
                   ## get slot
                   .doc_get_slot=paste(
                     desc("Get slot (property) by name. Can be used to get a method to call with different context."),
                     param("key", "slot name"),
                     returns("Returns the method or NULL")
                     ),
                   get_slot=function(., key) {
                     if(.$has_slot(key))
                       get(as.character(key), envir=.)
                     else
                       NULL
                   },
                   .doc_get_local_slot=paste(
                     desc("Get slot if in local object, not ancestors"),
                     param("key", "slot name")
                     ),                     
                   get_local_slot = function(., key) {
                     if(.$has_local_slot(key))
                       get(as.character(key), envir=.)
                     else
                       NULL
                   },
                   .doc_set_slot=paste(
                     desc("Set slot (property) value"),
                     param("key","Property name"),
                     param("value","Value to set in slot"),
                     param("initialize","If <code>TRUE</code> assign even if not already present.")
                     ),
                   set_slot=function(., key, value, initialize=TRUE) {
                     key <- as.character(key)
                     if(!initialize && !.$has_slot(key)) {
                       warning(sprintf("property %s not intialized. Call with initialize=TRUE to set", key))
                       return()
                     } 
                     assign(key, value, envir=.)
                   },
                    ## return all objects in the widget
                    ## if class is non-null will return only our proto objects of that "class"
                    .doc_list_objects=paste(
                      desc("List all objects in the widget."),
                      returns("Returns a list with components methods and properties")
                      ),
                   list_objects = function(., all.names=FALSE) {
                     s <- .
                     is_method <- function(lst, env) {
                       if(length(lst) == 0)
                         return(logical())
                       ind <- sapply(lst, function(i) {
                         is.function(get(i,envir=env))
                       })
                       ind
                     }
                     out <- ls(s, all.names=all.names)
                     ind <- is_method(out, s)
                     methods <- out[ind]
                     properties <- out[!ind]
                     while(is.proto(s <- s$parent.env())) {
                       if(s$has_slot("class")) {
                         out <- ls(s, all.names=all.names)
                         ind <- is_method(out, s)
                         methods <- unique(c(methods, out[ind]))
                         properties <- unique(c(properties, out[!ind]))
                       }
                     }
                     return(list(methods=methods,
                                 properties=setdiff(properties, c("class","traitr","slot"))))
                   },
                   
                   ## return non functions (properties)
                    ## will return objects or just names if return_names=TRUE
                    ## can pass class= value if desired
                    .doc_list_properties=paste(
                      desc("Return all properties (non-methods) for this proto object."),
                      param("class","If non-NULL, returns only from objects of this class.")
                      ),
                    list_properties=function(., all.names=FALSE) .$list_objects(all.names)$properties,
                   ## list methods
                   .doc_list_methods=paste(
                      desc("Method to list all possible methods for object")
                      ),
                   list_methods=function(., all.names=FALSE) .$list_objects(all.names)$methods,
                   ## find next method that is different or return NULL
                   .doc_next_method=paste(
                     desc("Find next method for this object with same name by recursing up through parent",
                          "environments. Checks equivalence of methods after stripping out environment info."),
                     param("meth_name", "Name of method to find next one of"),
                     returns("The method or <code>NULL</code> if unable to find one.")
                     ),
                   next_method = function(.,meth_name) {
                     e <- new.env()
                     get_meth <- function(.) {
                       f <- get(meth_name,envir=.)
                       environment(f) <- e
                       f
                     }
                     cur_meth <- get_meth(.)

                     find_meth <- function(s,meth_name) {
                       p <- s$.super
                       if(exists(meth_name, envir=p)) {
                         f1 <- get_meth(p)
                         if(digest(cur_meth) != digest(f1)) {
                           return(get(meth_name, p))
                         } else {
                           find_meth(p, meth_name)
                         }
                       } else {
                         return(NULL)
                       }
                     }
                     find_meth(., meth_name)
                   },
                   
                   ## call a method if it is present. Basically do.call with
                    ## a check that the function exists
                    .doc_do_call=paste(
                      desc("Function to call method if the method exists."),
                      param("fun","method name as character"),
                      param("lst","List of arguments. Default is empty list")
                      ),
                    do_call = function(., fun, lst=list()) {
                      fun <- as.character(fun)
                      if(.$has_slot(fun) && is.function(FUN <- .$get_slot(fun))) {
                        do.call(FUN, c(., lst))
                      }
                    },
                    ## doc stuff
                    ## produce a list with doc strings for each object
                    create_doc_list = function(.) {
                      ## get properties/methods with .doc_ entries
                      f <- function(s) {
                        tmp <- ls(s, all.names=TRUE)
                        ind <- grepl("^\\.doc_",tmp)
                        tmp[ind]
                      }
                      l <- list(); l$properties <- list(); l$methods <- list()
                      s <- .
                      while(is.proto(s)) {
                        for(i in f(s)) {
                          nm <- gsub("^\\.doc_","",i)
                          obj <- get(nm,envir=s)
                          if(is.function(obj) || is.null(obj))
                            type <- "methods"
                          else
                            type <- "properties"
                          if(is.null(l[[i]]))
                            l[[type]][[i]] <- list(class = s$class,
                                                   doc = get(i, envir=s))
                        }
                        s <- s$parent.env()
                      }
                      l
                    },
                    .doc_show_help = paste(
                      desc("Create HTML web page listing documented methods and properties for",
                           "the  given <code>proto</code> object"),
                      returns("Opens browser to help page.")
                      ),
                    show_help = function(.) {
                      tmpfile <- tempfile()
                      l <- .$create_doc_list()
                      cat("<html><head><style type=text/css>", file=tmpfile)
                      cat(readLines(system.file("css","traitr.css",package="traitr")),
                          sep="\n", file=tmpfile, append=TRUE)
                      ## cat("add css here", file=tmpfile, append=TRUE)
                      cat("</style></head><body>",
                          sep="\n", file=tmpfile, append=TRUE)
                      for(type in c("methods","properties")) {
                        cat("<h2>List of",type,"for object</h2>",
                            file=tmpfile, append=TRUE)
                        for(i in names(l[[type]])) {
                          if(!grepl("^\\.doc\\_Class",i)) {
                            nm <- gsub("^\\.doc\\_", "", i)
                            cat("<div class='traitrdoc'>",
                                "<h1 class='traitr'>",nm,"(",l[[type]][[i]]$class[1],")","</h1>",
                                "<div class='traitrdoc'>",l[[type]][[i]]$doc,"</div>",
                                "</div>",
                                "<hr></hr>",
                                sep="\n", file=tmpfile, append=TRUE)
                          }
                        }
                      }
                      cat("</body></html>",
                          sep="\n", file=tmpfile, append=TRUE)
                      ## browse
                      browseURL(tmpfile)
                    }
                    )

#line 1 "/private/tmp/RtmpA4c7nI/R.INSTALL10d63af1/traitr/R/model.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/

#' @include base.R
roxygen()

## Make a MVC framework using proto


#' Trait for a model object.
#'
#' Model objects consist of properties and the methods that manipulate them
#' Models are initialized by \code{init} so that getter and setter pairs are made
#' When setter functions are called, the model's observers are notified
#' @export
Model <- BaseTrait$proto(class=c("Model", BaseTrait$class),
                          ## properties are added to children of this
                          ## eg value="some_value",
                          ##### Methods ###
                          ## call observers
                          ## if key is passed in we notify that property was changed -- if it was
                          ## we notify controllers that model_value_changed happened
                         .doc_notify_observers=paste(
                           desc("This function is used to notify observers. It calls the observer methods",
                                "<code>property_PROPERTYNAME_value_changed</code> and <code>model_value_changed</code>",
                                "if they exist in the observer.",
                                "For private use, the method <code>.property_PROPERTY_value_cahnged</code>",
                                "is also called."),
                           param("key", "if non-null is used to signal propery method"),
                           param("value","is new value"),
                           param("old_value","is old value, useful if an undo mechanism is desired."),
                           param("notify_private","There for undo mechanism"),
                           returns("No return value")
                           ),
                          notify_observers = function(., key=NULL, value=NA, old_value=NA, notify_private=TRUE) {
                            sapply(.$.observers, function(i) {
                              if(digest(value) != digest(old_value)) { #serialize, then compare
                                if(!is.null(key)) {
                                  ## call private ones if...
                                  if(notify_private)
                                    i$do_call(sprintf(".property_%s_value_changed",key),
                                              list(value=value, old_value=old_value))
                                  ## call public ones
                                  i$do_call(sprintf("property_%s_value_changed",key),
                                            list(value=value, old_value=old_value))
                                }
                                ## always call these for new values
                                i$do_call("model_value_changed", list())
                              }
                            })
                            invisible()
                          },
                          ## add an observer -- a Controller instance or a child such as an adapter
                          .doc_add_observer=paste(
                            desc("This method adds an observer to the model."),
                            param("observer","A Controller instance or Model instance is the observer"),
                            returns("no return value")
                            ),
                          add_observer = function(., observer) {
                            if(is.proto(observer) && observer$is(c("Controller","Model"))) {
                              ## don't double up.
                              ind <- sapply(.$.observers, function(i) i$identical(observer))
                              if(!any(ind)) {
                                id <- length(.$.observers) + 1
                                .$.observers[[id]] <- observer
                              }
                            }
                          },
                          ## remove observer
                          .doc_remove_observer=paste(
                            desc("This method removes an observer from the model."),
                            param("observer"," observer to remove")
                            ),
                          remove_observer = function(., observer) {
                            if(!missing(observer) && (is.proto(observer) && observer$is("Controller"))) {
                              ind <- sapply(.$.observers, function(i) i$identical(observer))
                              if(any(ind))
                                sapply(which(ind), function(i) .$.observers[[i]] <- NULL)
                            }
                          },
                          ## list observers
                         .doc_list_observers=paste(
                           desc("Return all observers of the model as a list")
                           ),
                         list_observers=function(.) .$.observers,
                          ## observables have getter/setter methods defined for them
                          ## on the fly when init is called on Modal instance
                          ## these refer to properties of the model
                          ## methods
                          .doc_getattr=paste(
                            desc("Method to get an attribute (property) value from the object. That is,",
                                 "<code>.$getattr('value')</code> is same as <code>.$value</code>"),
                            param("key","Name of property")
                            ),
                          getattr = function(., key) get(key, envir=.),
                          .doc_setattr=paste(
                            desc("Method to set a value for an attribute (property) in the object.",
                                 "Unlike assignment with <code>.$value = key </code>, this calls the",
                                 "<code>notify_observers</code>method to notify observers of a property",
                                 "value being changed."),
                            param("key","Name of property"),
                            param("value","New value of property")
                            ),
                          setattr = function(., key, value, notify_private=TRUE) {
                            old_value <- .$getattr(key)
                            assign(key, value, envir=.)
                            if(digest(value) != digest(old_value)) {#serialize, then compare
                              .$notify_observers(key=key, value=value, old_value=old_value, notify_private)
                            }
                          },
                          ## init makes getter/setter variables for all properties in the model
                          .doc_init=paste(
                            desc("Initialization method for models. Creates get_PROPERTY and set_PROPERTY methods",
                            "to access model values. These simply pass to getattr and setattr methods")
                            ),
                          init = function(.) {
                            sapply(.$list_properties(), function(i) {
                              .$assign_if_null(sprintf("get_%s",i),
                                               function(.,...) .$getattr(i)
                                               )
                              .$assign_if_null(sprintf("set_%s",i),
                                               function(., value, ...) {
                                                 .$setattr(i,value)
                                               })
                            })
                            invisible()
                          },

                          ## private
                          ## properties
                          .observers = list()
                          )

#' Constructor for a Model proto objects
#'
#' Simply provides a more typical calling interface for the Model proto object
#' @param ... passed to proto method for
#' @return returns the Model object. Call \code{obj$show_help()} to view its methods and properties.
#' @export
aModel <- function(...) Model$new(...)
#line 1 "/private/tmp/RtmpA4c7nI/R.INSTALL10d63af1/traitr/R/view.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/

#' @include model.R
roxygen()

## Use makeUI to makeUI components, updateUI to update them

##################################################
#' Trait for View objects.
#'
#' A view "displays" the values in an associated model. The association is through a controller
#' the view does not know the controller or the model
#' Views are initialized through the \code{make_ui} method.
#' @export
View <- BaseTrait$proto(class=c("View", BaseTrait$class),
                        ## properties
                        ## list of widgets in view for access by controller by name
                        ## layout
                        .doc_attr=paste(
                          desc("Property list of attributes for constructor")
                          ),
                        attr=list(),
                        ## widgets
                        .doc_widgets=paste(
                          desc("Property list of widgets in view, see <code>get_widget_by_name</code>")
                          ),
                        widgets=list(),
                        ## methods
                        ## get all widgets
                        get_widgets = function(.) .$widgets,
                        ## get widget  by name
                        .doc_get_widget_by_name=paste(
                          desc("Look up widget by name")
                          ),
                        get_widget_by_name= function(., key) .$get_widgets()[[key]],
                        
                        ## makeUI sets up widget.
                        ## store widgets into .$widgets by name
                        .doc_make_ui=paste(
                          desc("Initialize user interface provided by the view"),
                          param("cont","gWidgets container"),
                          param("attr","attributes passed constructor")
                          ),
                        make_ui= function(., cont, attr=.$attr) {},
                         ## is_realized is TRUE if widget is realized
                        .doc_is_realized=paste(
                          desc("Is view realized and still extant?")
                          ),
                         is_realized=function(.) {
                           length(.$get_widgets()) && isExtant(.$get_widgets()[[1]])
                         },
                         ## communication between view and model done through controller
                         ## these are generic functions for a view to get and set the main value
                         ## others are specific to sub instances
                         ## These should not be called by users, they do not sychronize with model, but instead
                         ## the value refers to the view. Basic call is svalue, or svalue<-
                        .doc_get_value_from_view=paste(
                          desc("For simple views, used to transport values from view to model by the controller")
                          ),
                        get_value_from_view = function(.) {},
                        .doc_set_value_in_view=paste(
                          desc("Method to set a value in the view. Called by controller"),
                          param("widget_name","Name of widget to look up"),
                          param("value","Value to set")
                          ),
                        set_value_in_view = function(., widget_name, value) {
                          if(.$is_realized()) {
                            widget <- .$get_widget_by_name(widget_name)
                            blockHandler(widget)
                            try(svalue(widget) <- value, silent=TRUE)
                            unblockHandler(widget)
                          }
                        },
                         ## methods to change visibility, enabled of the widgets
                         ## gWidgets specific
                        .doc_enabled=paste(
                          desc("Is view enabled"),
                          param("value","logical value")
                          ),
                         enabled = function(., value) {
                           invisible(sapply(.$get_widgets(), function(i) enabled(i) <- as.logical(value)))
                         },
                        .doc_visible=paste(
                          desc("Set if view is visible"),
                          param("value","logical value")
                          ),
                         visible = function(., value) {
                           invisible(sapply(.$get_widgets(), function(i) visible(i) <- as.logical(value)))
                         }
                         )

## constructor
#' Constructor for a View proto object
#'
#' Simply provides a more typical calling interface for the View proto object
#' @param ... passed to proto method for
#' @return Returns the View object. Call \code{obj$show_help()} to view its methods and properties.
#' @export
aView <- function(...) View$new(...)
#line 1 "/private/tmp/RtmpA4c7nI/R.INSTALL10d63af1/traitr/R/controller.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/

#' @include view.R
roxygen()

##################################################
#' Trait for Controller objects
#'
#' A controller connects a model and an associated view to synchronize changes in one with another
#' This implementation rests on the controller having some suitably named methods
Controller <- BaseTrait$proto(class=c("Controller", BaseTrait$class),
                               ## list of adapters. Each adapter specified with a list.
                               ## list(property="propname",
                               ##      view_name="viewname",
                               ##      add_handler_name=c("addHandlerChanged"), # or NULL to suppress
                               ##      handler_user_data=NULL
                               ##      )
                               adapters=list(),  
                               ## Methods
                               ## make a new controller child must override some methods

                               ## get/set model
                               model=NULL,
                               get_model=function(.) .$model,
                               set_model = function(., model) {
                                 if(is.proto(model) && model$is("Model")) {
                                   .$model$remove_observer(.)
                                   .$model <- model
                                   .$model$add_observer(.)
                                   sapply(.$.adapters, function(i) i$set_model(model))
                                 }
                               },
                               ## get/set view controller object
                               view=NULL,
                               get_view=function(.) .$view,
                               ## set view, remove old if present
                               set_view = function(., view) {
                                 if(is.proto(view) && view$is("View")) {
                                   if(is.proto(.$get_view()) && .$get_view()$is("View"))
                                     .$remove_view()
                                   .$view <- view
                                   sapply(.$.adapters, function(i) i$set_view(view))
                                 }
                               },
                               ## function call to remove view -- disconnect handlers
                               remove_view=function(.) {
                                 sapply(.$.adapters, function(i) i$remove_view())
                               },
                                
                               ## sets function to listen for changes to view
                               ## might just define .$property_NAME_value_changed method
                               update_from_model=function(.) {},

                               ## transfers changes to model back from view
                               update_from_view = function(.) {},

                               ## function to register adapters if .$adapters non empty
                               register_adapters = function(.) {
                                 if(length(.$adapters) && !length(.$.adapters)) {
                                   .$.adapters <- lapply(.$adapters, function(i) {
                                     Adapter$proto(model=.$get_model(),
                                                   view=.$get_view(),
                                                   property=i$property,
                                                   view_widget_name=i$view_widget_name,
                                                   add_handler_name=i$add_handler_name,
                                                   handler_user_data=i$handler_user_data
                                                   )
                                   })
                                 }
                                 if(length(.$.adapters))
                                   sapply(.$.adapters, function(i) i$init())
                               },
                               ## intialize controller
                               ## updates model, view and any adapters
                               init = function(.) {
                                 if(!is.null(.$get_model())) {
                                   .$update_from_model()
                                   .$get_model()$init()
                                   .$get_model()$add_observer(.)
                                 }
                                 if(!is.null(.$get_view())) {
                                   .$update_from_view()
                                 }
                                 .$register_adapters()
                                 ## call value_changed methods to update any views
                                 nms <- .$list_methods()
                                 sapply(nms[grep("property_(.*)_value_changed$", nms)],
                                        function(i) {
                                          prop <-  gsub("property_(.*)_value_changed$","\\1",i)
                                          .$get_slot(i)(., .$get_model()$getattr(prop),NA)
                                        })
                                 invisible()
                               },
                               ## when a model changes, this function is called
                               ## if the controller is an observer
                              ## model_value_changed= function(.) {},

                               ## When a property of a model is changed through set_PROPERTYNAME
                               ## then methods of this type are called
                              ## property_PROPERTYNAME_value_changed = function(., value, old_value) {},

                               ## Private properties
                               .adapters=list(), # actual instances
                               .handlerIDs=list()
                               ## private methods
                               )

#' Trait for Adapter object
#' An adapter is a simple controller connecting one model property with a widget in a view
#' by default the adapter synchronizes changes
#' @export
Adapter <- Controller$proto(class=c("Adapter", Controller$class),
                            property=NULL, # property in model
                            # name of widget in view, otherwise last one
                            view_widget_name=NULL,
                            add_handler_name=c("addHandlerChanged"), ## "" for no view->model
                            handler_user_data=NULL,               # passed through to handler call
                            .handlerIDs=c(),                       # store IDs of handlers
                            ## Methods. init does the work
                            update_from_model = function(.) {
                              ## set up model to notify view For example:
                              view <- .$get_view()
                              meth_name<- sprintf("property_%s_value_changed", .$property)
                              .$set_slot(meth_name,
                                         function(., value, old_value) {
                                           view$set_value_in_view(.$view_widget_name, value)
                                         })
                                     
                              ## call method
                              .$get_slot(meth_name)(., .$get_model()$getattr(.$property), NA)
                            },
                            ## this propogates changes from the view back to the model
                            update_from_view = function(.) {
                              ## here view knows about model through controller (this adapter)
                              if(!.$get_view()$is_realized()) return()
                              if(!is.null(.$view_widget_name))
                                widget <- .$get_view()$get_widget_by_name(.$view_widget_name)
                              else
                                widget <- tail(.$get_view()$get_widgets(), n=1)[[1]]
                              ## gWidgets specific call to set up control between model and
                              ## view
                              if(is.null(.$add_handler_name))
                                .$add_handler_name="addHandlerChanged"
                              sapply(.$add_handler_name, function(i) {
                                if(i != "") {
                                  lst <- list(obj=widget,
                                              handler=function(h,...) {
                                                . <- h$action$adapter
                                                
                                                ## set property in model using name
                                                value <- svalue(h$obj)
                                                if(isExtant(h$obj)) {
                                                  .$model$setattr(.$property, value)
                                                }
                                              },
                                              action=list(adapter=.))
                                  .$append(".handlerIDs", do.call(i, lst))
                              }
                              })
                            },
                            ## remove the view -- say be removeHandler call.
                            remove_view=function(.) {
                              if(.$has_slot(".handlerIDs"))
                                sapply(.$.handlerIDs, function() removeHandler(.$get_view(), i))
                            },
                            init=function(.) {
                              ## check that we are all there
                              if(!is.null(.$property) &&
                                 (is.proto(model <- .$get_model()) && model$is("Model")) &&
                                 (is.proto(view <- .$get_view()) && view$is("View"))) {
                                .$update_from_model()
                                .$update_from_view()
                              } else {
                                warning("Adapter does not have view, model and property")
                              }
                              .$model$add_observer(.)
                            }
                            )

## constructor
#' Constructor for a Controller proto objects
#'
#' Simply provides a more typical calling interface for the Controller proto object
#' @param ... passed to proto method for
#' @return returns the Controller object
#' @export
aController <- function(...) {
  obj <- aController$new(...)
  ## adjust class
  obj
}

#line 1 "/private/tmp/RtmpA4c7nI/R.INSTALL10d63af1/traitr/R/container.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/

#' @include controller.R
roxygen()

## Layouts for specifying how items get put

## Container objects are for layouts.
#' Base Trait for Container objects.
#'
#' Basic container is a glayout object for tabular layout
Container <- BaseTrait$proto(class=c("Container", BaseTrait$class),
                              .doc_container=paste(
                                desc("property to store base gWidgets container")
                                ),
                              container=NULL,  # stores base container
                              children=list(),     # stores children
                              type="glayout",
                              attr=list(horizontal=FALSE),
                              .doc_context=paste(
                                desc("Context for container to look up values, such as whether to draw a label",
                                     "Usually inherited from calling object")
                                ),
                              context=NULL,
                              no_cols=1, # for glayout containers
                              .doc_is_realized=paste(
                                desc("Method to check if container has been realized (drawn as GUI)")
                              ),
                              is_realized=function(.) !is.null(.$container) && isExtant(.$container),

                              make_container=function(., container, attr=.$attr) {
                                ## check if container is traitr object
                                if(is.proto(container) && exists("traitr", container)) {
                                  if(container$is("Container"))
                                    container <- container$container # should be gWidgets object
                                  else
                                    stop(gettext("The container argument, if a proto object, needs to be a Container"))
                                }
                                
                                .$validate_ui()
                                
                                if(.$type=="") {
#                                  .$container <- cont
                                  return(container) # for aContext
                                }
                                attr$container <- container
                                if(inherits(container,"gLayout") ||
                                   (inherits(container,"guiContainer") && grepl("^gLayout", class(container@widget)))
                                   ) {
                                  row_no <- get_with_default(tag(container, "row_no"), 1)
                                  col_no <- get_with_default(tag(container, "col_no"), 1)
                                  no_cols <- get_with_default(tag(container, "no_cols"), 1)
                                  row_no <- tag(container, "row_no")

                                  container[row_no, 2*(col_no-1) + 1:2] <- (new_cont <- do.call(.$type, attr))
                                  tag(container, "row_no") <- row_no + (col_no == no_cols)
                                  tag(container, "col_no") <- (col_no %% no_cols) + 1
                                } else {
                                  ## if a notebook grab the label property
                                  if(inherits(container, "gNotebook") ||
                                     (inherits(container, "guiContainer") && grepl("^gNotebook", class(container@widget)))
                                     ) {
                                    attr$label <- get_with_default(.$label, "")
                                  }
                                  new_cont <- do.call(.$type, attr)
                                  ## catch gWidgetsWwW and other
                                  if(inherits(new_cont,"gLayout") ||
                                     (inherits(new_cont,"guiContainer") &&grepl("^gLayout", class(new_cont@widget)))
                                     ) {
                                    tag(new_cont, "row_no") <- 1
                                    tag(new_cont, "col_no") <- 1
                                    tag(new_cont, "no_cols") <- .$no_cols
                                  }
                                }
                                .$container <- new_cont
                                new_cont
                              },
                             .doc_init_ui=paste(
                               desc("If non <code>NULL</cod> called on intial drawing of container")
                               ),
                             init_ui=function(.) {},
                              ## context an ItemGroup instance to look up strings in.
                              .doc_make_ui=paste(
                                desc("Method to make user interface. Makes container,",
                                     "then makes UI for each child"),
                                param("cont","gWidgets container to place user interface into"),
                                param("attr", "Attribute list for gWidgets constructor"),
                                param("context","Context to find labels, etc from")
                                ),
                             make_ui = function(., container, attr=.$attr, context, ...) {
                                if(missing(context)) {
                                  if(!is.null(.$context))
                                    context <- .$context
                                  else
                                    context <- .
                                }

                                cont <- .$make_container(container, attr)
                                sapply(.$children, function(i) {
                                  if(is.null(i))
                                    return()

                                  ## first, if a character, convert to the object
                                  if(is.character(i)) {
                                    i <- context$get_item_by_name(i)
                                  }
                                  if(!is.proto(i)) {
                                    stop("Should be Item, ItemGroup or Container")
                                  }
                                  ## Now dispatch one of several ways.
                                  ## either an Item, ItemGroup or Container
                                  if(is.proto(i) && i$is("Item")) {
                                    i$make_ui(cont)
                                    i$init_ui()
                                  } else if(is.proto(i) && i$is("ItemGroup")) {
                                    i$make_ui(cont)
                                  } else if(is.proto(i) && i$is("Container")) {
                                    ## if non-trivial context in container, pass in
                                    if(i$has_slot("context") && !is.null(i$context)) {
                                      i$make_ui(cont)
                                    } else {
                                      i$context <- context
                                      i$make_ui(cont)
                                    }
                                  }
                                })
                                ## intialize ui if present
                                .$do_call("init_ui")
                                ## update if present
                                .$update_ui()
                              },
                              ## return TRUE to make container sensitive to events, FALSE to disable
                              .doc_enabled_when=paste(
                                desc("Method defining when a container should be enabled (sensitive to user",
                                     "input. Returns logical")
                                ),
                              enabled_when = function(.) {
                                ## . is from context
                                TRUE
                              },
                              ## method to call to make container enabled/disabled
                              enabled = function(., value) {
                                enabled(.$container) <- value
                              },
                              ## checked to see if container should be visible
                              .doc_visible_when=paste(
                                desc("Method to call to check if container should be visible.",
                                     "Returns a logical")
                                ),
                              visible_when = function(.) { TRUE },
                              ## method to call to make container visible/invisible
                              visible = function(., value) {
                                visible(.$container) <- value
                              },
                              .doc_validate_ui=paste(
                                desc("Method called by make_ui",
                                     "Gives warning if not valid")
                                ),
                              validate_ui=function(.) {},
                              ## override to make this update
                              .doc_update_ui=paste(
                                desc("Method to update user interface")
                                ),
                              update_ui = function(.) {
                                if(.$is_realized()) {
                                  if(!is.null(.$children) && length(.$children) > 0)
                                    sapply(.$children, function(i) {
                                      if(is.character(i))
                                        i <- .$context$get_item_by_name(i)
                                      if(is.proto(i))
                                        i$do_call("update_ui", list())
                                    })

                                
                                  ## set enabled
                                  ## call passing in the context (an itemgroup, say), not
                                  ## the container
                                  
                                  ## wrap in try -- sometimes issue with update_ui call before
                                  ## model values are initialized
                                  try({
                                    .$enabled(.$get_slot("enabled_when")(.$context))
                                    .$visible(.$get_slot("visible_when")(.$context))
                                  }, silent=TRUE)
                                }
                              },
                             .doc_instance=paste(
                               desc("A copy of container that can be reused.")
                               ),
                             instance=function(.) {
                               ## clear out container, context
                               obj <- .$proto()
                               obj$container <- NULL
                               obj$context <- NULL
                               ## For each child, call instance if not character
                               for(i in seq_along(length(obj$children))) {
                                 j <- obj$children[[i]]
                                 if(is.proto(j))
                                   obj$children[[i]] <- j$do_call("instance")
                               }
                               return(obj)
                             }
                             )

## Various container constructors

## this is technical to give some children a context
#' A container to give a different context that the default for a set of items
#'
#' @param context ItemGroup or item to get context from
#' @param enabled_when Method to determine when items in container should be enabled
#' @param visible_when Method to determine when items in container should be visible
#' @param ... children items specified by character strings
#' @return Returns a \code{proto} object. Call \code{obj$show_help()} to view its methods and properties.
#' @export
aContext <- function(..., 
                     context, enabled_when, visible_when) {
  obj <- Container$proto(children=list(...),
                  type="",              # empty so no parent made
                  context=context)
  obj$class <- c("Context", obj$class)
  obj$is_realized <- function(.) TRUE
  obj$visible <- function(., value) {
    ## apply to children
    invisible(
              sapply(.$children, function(i) {
                if(is.character(i)) {
                  i <- context$get_item_by_name(i)
                }
                if(!is.proto(i)) {
                  stop("Should be Item, ItemGroup or Container")
                }
                i$visible(value)
              })
              )
  }
  obj$enabled <- function(., value) {
    ## apply to children
    invisible(
              sapply(.$children, function(i) {
                if(is.character(i)) {
                  i <- context$get_item_by_name(i)
                }
                if(!is.proto(i)) {
                  stop("Should be Item, ItemGroup or Container")
                }
                i$enabled(value)
              })
              )
  }       
  
  if(!missing(enabled_when)) obj$enabled_when <- enabled_when
  if(!missing(visible_when)) obj$visible_when <- visible_when
  obj
}

## Basic container uses a "1" column table layout
#' A container to give a different context that the default for a set of items
#'
#' @param context ItemGroup or item to get context from
#' @param enabled_when Method to determine when items in container should be enabled
#' @param visible_when Method to determine when items in container should be visible
#' @param ... children items specified by character strings
#' @return Returns a \code{proto} object. Call \code{obj$show_help()} to view its methods and properties.
#' @export

#' @examples
#' \dontrun{
#' i <- anItemGroup(x=numericItem(1), y=stringItem("a"))
#' lay <- aContainer("x","y")
#' makeGUI(i, gui_layout=lay)
#' }

aContainer <- function(..., context=NULL, enabled_when, visible_when) {
  obj <- Container$proto(children=list(...),
                  context=context)
  if(!missing(enabled_when)) obj$enabled_when <- enabled_when
  if(!missing(visible_when)) obj$visible_when <- visible_when
  obj
}

## Same as aContainer, only one can specify the number of columns
#' A container for tabular layout
#'
#' @param no_cols Number of columns. Fills in row by row.
#' @param context ItemGroup or item to get context from
#' @param enabled_when Method to determine when items in container should be enabled
#' @param visible_when Method to determine when items in container should be visible
#' @param ... children items specified by character strings
#' @return Returns a \code{proto} object. Call \code{obj$show_help()} to view its methods and properties.
#' @export

aTableLayout <- function(..., no_cols=1,# no_cols is really 2 * no_cols, we don't count labels here
                         context=NULL, enabled_when, visible_when) { 
  obj <- Container$proto(class=c("TableContainer", Container$class),
                  children=list(...),
                  no_cols=no_cols,
                  context=context)
  if(!missing(enabled_when)) obj$enabled_when <- enabled_when
  if(!missing(visible_when)) obj$visible_when <- visible_when
  obj

}

## a box container
#' A box container. Packs in items left to right or top to bottom
#'
#' @param horizontal If \code{TRUE} left to right, if \code{FALSE} top to bottom
#' @param spacing Space in pixels between items
#' @param context ItemGroup or item to get context from
#' @param enabled_when Method to determine when items in container should be enabled
#' @param visible_when Method to determine when items in container should be visible
#' @param ... children items specified by character strings
#' @return Returns a \code{proto} object. Call \code{obj$show_help()} to view its methods and properties.
#' @export

aGroup <- function(..., horizontal=TRUE, spacing=10,
                   context=NULL, enabled_when, visible_when) {
  obj <- Container$proto(children=list(...),
                  type="ggroup",
                  attr=list(horizontal=horizontal, spacing=spacing),
                  context=context
                  )
  if(!missing(enabled_when)) obj$enabled_when <- enabled_when
  if(!missing(visible_when)) obj$visible_when <- visible_when
  obj
}

#' Box container with label and visual separator to indicate grouping
#'
#' @param label label for frame
#' @param horizontal If \code{TRUE} left to right, if \code{FALSE} top to bottom
#' @param spacing Space in pixels between items
#' @param context ItemGroup or item to get context from
#' @param enabled_when Method to determine when items in container should be enabled
#' @param visible_when Method to determine when items in container should be visible
#' @param ... children items specified by character strings
#' @return Returns a \code{proto} object. Call \code{obj$show_help()} to view its methods and properties.
#' @export

aFrame <- function(..., label="frame label", horizontal=FALSE, spacing=10,
                   context=NULL, enabled_when, visible_when) {
  obj <- Container$proto(class=c("Frame",Container$class),
                  children=list(...),
                  type="gframe",
                  attr=list(text=label, horizontal=horizontal, spacing=spacing),
                  context=context)

  if(!missing(enabled_when)) obj$enabled_when <- enabled_when
  if(!missing(visible_when)) obj$visible_when <- visible_when
  obj
}


## XXX Need to work out how update_ui is done, put in model
## An expanding group with a trigger to show/hide its children
#' Expanding group. Has trigger to show/hide its children
#'
#' @param label label for trigger
#' @param horizontal If \code{TRUE} left to right, if \code{FALSE} top to bottom
#' @param expanded Initial state of children. Set to \code{TRUE} to show
#' @param context ItemGroup or item to get context from
#' @param enabled_when Method to determine when items in container should be enabled
#' @param visible_when Method to determine when items in container should be visible
#' @param ... children items specified by character strings
#' @return Returns a \code{proto} object. Call \code{obj$show_help()} to view its methods and properties.
#' @export

anExpandGroup <- function(..., label="", horizontal=FALSE, expanded=TRUE,
                          context=NULL, enabled_when, visible_when) {
  ## set expanded property to toggle
  obj <- Container$proto(children=list(...),
                  type="gexpandgroup",
                  attr=list(text=label, horizontal=horizontal),
                  context=context,
                  expanded=expanded,
                  update_ui=function(.) {
                    visible(.$container) <- .$expanded
                  })

  if(!missing(enabled_when)) obj$enabled_when <- enabled_when
  if(!missing(visible_when)) obj$visible_when <- visible_when
  obj
}                    

#' A two panel paned group container.
#'
#' @param horizontal If \code{TRUE} left to right, if \code{FALSE} top to bottom
#' @param context ItemGroup or item to get context from
#' @param enabled_when Method to determine when items in container should be enabled
#' @param visible_when Method to determine when items in container should be visible
#' @param ... children items specified by character strings
#' @return Returns a \code{proto} object. Call \code{obj$show_help()} to view its methods and properties.
#' @export

aPanedGroup <- function(..., horizontal=TRUE,
                        context=NULL, enabled_when, visible_when) {
  obj <- Container$proto(children=list(...),
                  type="gpanedgroup",
                  attr=list(horizontal=horizontal),
                  context=context,
                  validate_ui=function(.) {
                    if(length(.$children) !=2)
                      warning("aPanedGroup should have two children only")
                  }
                  )
  
  if(!missing(enabled_when)) obj$enabled_when <- enabled_when
  if(!missing(visible_when)) obj$visible_when <- visible_when
  obj
}

#' A notebook container.
#'
#' Pages of notebook are aNotebookPage container, which in turn can hold other items
#' @param close_buttons Logical indicating if close buttons should be added (RGtk2 only)
#' @param initial_page Which page to open on
#' @param context ItemGroup or item to get context from
#' @param enabled_when Method to determine when items in container should be enabled
#' @param visible_when Method to determine when items in container should be visible
#' @param ... children items specified by character strings
#' @return Returns a \code{proto} object. Call \code{obj$show_help()} to view its methods and properties.
#' @export

aNotebook <- function(..., close_buttons=FALSE, initial_page=1,
                      context=NULL, enabled_when, visible_when) {
  obj <- Container$proto(children=list(...),
                         type="gnotebook",
                         attr=list(closebuttons=close_buttons),
                         initial_page=initial_page,
                         context=context,
                         validate_ui = function(.) {
                           out <- sapply(.$children, function(i) {
                             if(is.character(i) ||
                                !i$is("NotebookPage"))
                               FALSE
                             else
                               TRUE
                           })
                           if(any(!out))
                             warning(gettext("Notebook children should be aNotebookPage instances"))
                         },
                         init_ui = function(.) svalue(.$container) <- initial_page
                         )
  
  if(!missing(enabled_when)) obj$enabled_when <- enabled_when
  if(!missing(visible_when)) obj$visible_when <- visible_when

  return(obj)
}

#' A page in a notebook
#'
#' @param label Tab label
#' @param context ItemGroup or item to get context from
#' @param enabled_when Method to determine when items in container should be enabled
#' @param visible_when Method to determine when items in container should be visible
#' @param ... children items specified by character strings
#' @return Returns a \code{proto} object. Call \code{obj$show_help()} to view its methods and properties.
#' @export

aNotebookPage <- function(..., label,
                          context=NULL, enabled_when, visible_when) {
  obj <- aContainer(..., context)
  obj$add_class("NotebookPage")
  
  obj$label <- label
  if(!missing(enabled_when)) obj$enabled_when <- enabled_when
  if(!missing(visible_when)) obj$visible_when <- visible_when

  return(obj)
}
#line 1 "/private/tmp/RtmpA4c7nI/R.INSTALL10d63af1/traitr/R/editor.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/

#' @include container.R
roxygen()

## Basic editor is a view only. The Item is the model and controller

#' Base Trait for Editor.
#'
#' An editor is a basic view for a widget, essentially a map from gedit, say, to a view
#' @export
Editor <- View$proto(class=c("Editor", View$class),
                     ## used in make_ui to make widget, or override make_ui ifd esird
                     .doc_editor_name=paste(
                       desc("Name of gwidget constructor for basic use of make_ui")
                       ),
                     editor_name = "gedit",
                     .doc_editor_style=paste(
                       desc("If non <code>NULL</code>, calls method <code>make_ui_STYLE</code>, if present,",
                            "instead of <code>make_ui</code> method. Example use might be to offer a compact",
                            "style.")
                       ),
                     editor_style=NULL,
                     ## widget name
                     .doc_view_widget_name=paste(
                       desc("Name of primary widget for lookup for setting value from controller")
                       ),
                     view_widget_name="editor",
                     ## attributes are used to specify arguments for constructor
                     attr = list(expand=FALSE),
                     ##
                     ## make_ui sets up widget.
                     .doc_make_ui=paste(
                       desc("Makes widget. Store in widgets property by name",
                            "The container is just a ggroup instance. The container already knows to",
                            "place in a table, notebook etc along with a label. That is handled in the",
                            "Item constructor. This just creates the widget")
                     ),
                     make_ui = function(., container, attr=.$attr, context=., ...) {
                       attr$container <- container
                       widget <- do.call(.$editor_name, attr)
                       if(!is.null(attr$size))
                         size(widget) <- attr$size

                       if(!is.null(context$tooltip) && nchar(context$tooltip) > 0)
                         tooltip(widget) <- context$tooltip
                     
                       .$append("widgets", widget, key=.$view_widget_name)

                     },
                     ## this is called by container.R, then it calls make_ui
                     ## once the the object is ready to go
                     .make_ui = function(., cont, attr=.$attr, context=., ...) {
                       ## check if container is traitr object
                       if(is.proto(cont) && exists("traitr", cont)) {
                         if(cont$is("Container"))
                           cont <- cont$container # should be gWidgets object
                         else
                           stop(gettext("The container argument, if a proto object, needs to be a Container"))
                       }
                       
                       ## XXX should add label etc. 
                       ## set up labels, etc. Here context may be item to grab label, ...
                       if(!.$is_realized()) {

                         .$append("widgets", cont, key="parent_container") # useful for enabled, ...
                         
                         

                         ## we need to know if this is a table, or not
                         ## this uses gWidgets hack
                         if(inherits(cont, "gLayout") ||
                            (inherits(cont, "guiContainer") &&grepl("^gLayout", class(cont@widget)))
                            ) {
                           row_no <- get_with_default(tag(cont, "row_no"), 1)
                           col_no <- get_with_default(tag(cont, "col_no"), 1)
                           no_cols <- get_with_default(tag(cont, "no_cols"), 1)

                           if(context$show_label) {
                             ## add label and group for widget
                             cont[row_no, 2*(col_no-1) + 1, anchor=c(1,1)] <-
                               (label <- glabel(context$label, cont = cont))
                             cont[row_no, 2*(col_no-1) + 2, anchor=c(-1,1), expand=TRUE] <-
                               (g <- ggroup(cont=cont, horizontal=FALSE, expand=TRUE))
                           } else {
                             ## add group object to hold widget, spread over 2 columns
                             cont[row_no, 2*(col_no-1) + 1:2, anchor=c(-1,1), expand=TRUE] <-
                               (g <- ggroup(cont=cont, horizontal=FALSE, expand=TRUE))
                           }
                           tag(cont, "row_no") <- row_no + (col_no == no_cols)
                           tag(cont, "col_no") <- (col_no %% no_cols) + 1
                         } else if(inherits(cont, "gNotebook") ||
                                   (inherits(cont, "guiContainer") && grepl("^gNotebook", class(cont@widget)))
                                   ) { 
                           attr$label <- get_with_default(context$label, "")
                           g <- ggroup(cont=cont, expand=TRUE, horizontal=FALSE)
                         } else {
                           cont <- ggroup(cont=cont, horizontal=TRUE, expand=TRUE)
                           if(context$show_label)
                             glabel(context$label, cont = cont, anchor=c(1,1))
                           g <- ggroup(cont=cont, horizontal=FALSE, expand=TRUE)
                         }
                         ## now make widget
                         ## check for editor_style
                         if(context$has_slot("editor_style") &&
                            !is.null(editor_style <- context$editor_style) &&
                            .$has_slot(paste("make_ui_",editor_style, sep=""))) {
                           .$do_call(paste("make_ui_",editor_style, sep=""), list(cont=g, attr=attr, context=context))
                         } else {
                           .$make_ui(cont=g, attr=attr, context=context, ...)
                         }
                       }
                     },
                     visible = function(., value) {
                       sapply(.$get_widgets(), function(i) visible(i) <- value)
                     },
                     enabled = function(., value) {
                       sapply(.$get_widgets(), function(i) enabled(i) <- value)
                     },
                     ## These are for the view, not the model -- they shouldn't be used
                     ## by end users.
                     .doc_get_value_from_view=paste(
                       desc("Private method for getting value from view (editor) for controller")
                       ),
                     get_value_from_view = function(.) {
                       nm <- if(!is.null(.$view_widget_name))
                         .$view_widget_name
                       else
                         1
                       if(isExtant(.$widgets[[nm]]))
                          svalue(.$widgets[[nm]])
                     },
                     ## set value in view by name. If name is NULL, gets first
                     .doc_set_value_from_view=paste(
                       desc("Private method for setting value from view (editor) for controller"),
                       param("widget_name"," name of widget, default for simple case"),
                       param("value"," value to be set into editor")
                       ),

                     set_value_in_view = function(.,widget_name=.$view_widget_name, value) {
                       if(.$is_realized()) {
                         widget <- .$get_widget_by_name(widget_name)
                         cur_val <- svalue(widget)
                         if(digest(cur_val) != digest(value)) {
                           blockHandler(widget)
                           try(svalue(widget) <- value, silent=TRUE)
                           unblockHandler(widget)
                         }
                       }
                     },
                     ## instance
                     .doc_instance=paste(
                       desc("Create a new instance of the editor. Does not share widgets")
                       ),
                     instance=function(.) {
                       obj <- .$proto()
                       obj$widgets <- list()
                       obj
                     },
                     .doc_set_valid=paste(
                       desc("Method to set editor to indicate valid value")
                       ),
                     set_valid=function(.) {},
                     .doc_set_invalid=paste(
                       desc("Method to indicate invalid value")
                       ),
                     set_invalid=function(., mesg) {
                       if(!missing(mesg))
                         galert(mesg)
                     }
                     )

#' A Base Trait for an editor using the entry widget
#' @export
EntryEditor <- Editor$proto(class=c("EntryEditor", Editor$class),
                            .doc_format_fun=paste(
                              desc("A function to call to coerce the value before displaying in entry",
                                   "widget."),
                              param("value"," value to coerce")
                              ),
                            format_fun = function(., value) sprintf("%s",value),
                            make_ui = function(., container, attr=.attr, context=., ...) {
                              if(!is.null(.$format_fun))
                                attr$text <- .$format_fun(context$value)
                              else
                                attr$text <- context$value
                              .$next_method("make_ui")(., container, attr, context, ...)

                            },
                            ## draw widget in valid state

                            set_valid=function(.) {
                              widget <- .$get_widget_by_name(.$view_widget_name)
                              if(!is.proto(widget)) {
                                e <- getToolkitWidget(widget)
                                if(inherits(e, "RGtkObject")) {
                                  require(RGtk2)
                                  ## set backgroup
                                  e$modifyBg(GtkStateType['normal'],NULL)
                                }
                              }
                            },
                            .doc_set_invalid=paste(
                              desc("Method call to set widget in an invalid state. The item should do",
                              "validation during the call that takes values from the view to the model."),
                              param("mesg","Optional message to display if value for entry is invalid")
                              ),
                            set_invalid=function(., mesg) {
                              widget <- .$get_widget_by_name(.$view_widget_name)
                              if(!is.proto(widget)) {
                                e <- getToolkitWidget(widget)
                                if(inherits(e, "RGtkObject")) {
                                  ## set backgroup
                                  require(RGtk2)
                                  e$modifyBg(GtkStateType['normal'],"red")
                                } else {
                                  .$next_method("set_invalid")(., mesg)
                                }
                              }
                            }
                            )
                            

#' Base trait for editor where there are underlying values to choose from
#'
#' editor has regular or compact style
#' @export
ObjectWithValuesEditor <- Editor$proto(class=c("ObjectWithValuesEditor", Editor$class),
                                       editor_name="gradio",
                                       by_index=FALSE, # select, set by index
                                       ## need to put in index=FALSE here
                                       set_value_in_view = function(.,widget_name=.$view_widget_name, value) {
                                         if(.$is_realized()) {
                                           widget <- .$get_widget_by_name(widget_name)
                                           ## XXX Hack to avoid errors with svalue <- call
                                           if(is.null(value) || is.na(value) ||
                                              (is.character(value) && length(value) == 0)
                                              )
                                             return()
                                           curVal <- svalue(widget, .$by_index)
                                           if(digest(curVal) != digest(value))
                                             svalue(widget, index=.$by_index) <- value
                                         }
                                         invisible()
                                       },

                                       set_values_in_view = function(., values) {
                                         widget <- .$get_widget_by_name(.$view_widget_name)
                                         if(!is.null(widget) && isExtant(widget)) {
                                           curVal <- svalue(widget, index=.$by_index)
                                           widget[] <- values
                                           if(.$by_index) {
                                             svalue(widget, index=.$by_index) <- curVal
                                           } else {
                                             if(length(values) > 0 &&
                                                length(curVal) > 0 && nchar(curVal) > 0 &&
                                                curVal %in% values)
                                               try(svalue(widget, index=.$by_index) <- curVal, silent=TRUE)
                                           }
                                         }
                                         invisible()
                                       },
                                       set_invalid=function(., ...) {},
                                       make_ui=function(., container, attr=.$attr, context=., ...) {
                                         attr$items <- context$get_values()
                                         attr$selected = if(context$get_value() %in% context$get_values())
                                           min(which(context$get_value() == context$get_values()))
                                         else
                                           1
                                         .$next_method("make_ui")(., container, attr, context, ...)
                                       },
                                       ## compact style is a label and button to pop up choice
                                       make_ui_compact=function(., container, attr=.$attr, context=., ...) {
                                         .$set_values_in_view <- function(...) {} # override
                                         cont <- ggroup(cont=container, horizontal=TRUE, expand=TRUE)
                                         
                                         attr$items <- context$get_values()
                                         attr$selected = if(context$get_value() %in% context$get_values())
                                           min(which(context$get_value() == context$get_values()))
                                         else
                                           1
                                         .$widgets[[.$view_widget_name]] <-
                                           glabel(context$value, cont=cont, expand=TRUE)
                                         .$widgets[["button"]] <- (b <- gbutton("Select value", cont=cont))
                                         addHandlerClicked(b, function(h,...) {
                                           obj <- h$action$obj
                                           context <- h$action$context
                                           widget <- obj$widgets[[obj$view_widget_name]]
                                           msg <- gettext("Select an item by double-clicking")
                                           dlg <- aDialog(items=list(item=choiceItem(context$get_value(),
                                                                       by_index=FALSE,
                                                                       values=context$get_values(),
                                                                       editor_type="gtable",
                                                                       tooltip=msg,
                                                                       show_label=FALSE,
                                                                       attr=list(size=c(300,300)))),
                                                          buttons=c("Cancel"),
                                                          title=msg
                                                          )
                                           dlg$label_widget <- widget
                                           dlg$label_context <- context
                                           dlg$make_gui(parent=container)
                                           dlg$property_item_value_changed <- function(., value, old_value) {
                                             svalue(.$label_widget) <- value
                                             context <- .$label_context
                                             context$do_call(sprintf("set_%s", context$name),list(value=value))
                                             .$close_gui()
                                           }

                                         },action=list(obj=., context=context))
                                       }
                                       )


#' Trait for Editor for TRUE/FALSE selection
#'
#' Editor has regular or compact style
#' @export
BooleanEditor <- Editor$proto(class=c("BooleanEditor", Editor$class),
                              editor_name="gcombobox",
                              make_ui=function(., container, attr=.attr, context, ...) {
                                attr$items <- c(TRUE, FALSE)
                                .$next_method("make_ui")(., container, attr, context, ...)
                              },
                              make_ui_compact=function(., container, attr=.attr, context, ...) {
                                widget <- gcheckbox("", cont=container)
                                .$append("widgets", widget, key=.$view_widget_name)
                              }
                              )

#' Trait for making a range editor (slider, spinbox)
#' @export
RangeEditor <- Editor$proto(class=c("RangeEditor", Editor$class),
                            view_widget_name="slider",
                            ## makes combo UI. Must also adjust the
                            ## set_value_in_view method
                            make_ui = function(., container, attr=.attr, context=., ...) {
                              g <- ggroup(cont=container, horizontal=TRUE)
                              l <- list(from=context$from,
                                        to=context$to,
                                        by=context$by,
                                        value=context$value,
                                        cont=g,
                                        expand=TRUE)
                              slider <- do.call("gslider",l)
                               .$append("widgets", slider, key=.$view_widget_name)
                              by <- context$by
                              if(as.integer(by) == by) {
                                l$expand <- FALSE
                                spinner <- do.call(gspinbutton,l)
                                .$append("widgets", spinner, key="spinner")
                              }
                                                
                              if(!is.null(attr$size))
                                size(g) <- attr$size
                              
                              if(!is.null(context$tooltip) && nchar(context$tooltip) > 0)
                                tooltip(slider) <- context$tooltip
                     
                            },
                            ## need to update both slider and spinner
                            set_value_in_view = function(.,widget_name=.$view_widget_name, value) {
                              if(.$is_realized()) {
                                if(is.null(value))
                                  return()
                                widget <- .$widgets[["slider"]]
                                spinner <- .$widgets[["spinner"]] # may be NULL
                                if(digest(svalue(widget)) != digest(value)) {
                                  blockHandler(widget)
                                  try(svalue(widget) <- value, silent=TRUE)
                                  unblockHandler(widget)
                                }
                                if(!is.null(spinner) && (digest(svalue(spinner)) != digest(value))) {
                                  blockHandler(widget)
                                  try(svalue(spinner) <- value, silent=TRUE)
                                  unblockHandler(widget)
                                }
                              }
                            }
                              )
                            

#' Trait for button editor
#' @export
ButtonEditor <- Editor$proto(class=c("ButtonEditor", Editor$class),
                             editor_name="gbutton",
                             attr=list(),
                             make_ui=function(., container, attr=.attr, context, ...) {
                               attr$text=context$value
                               .$next_method("make_ui")(., container, attr, context, ...)
                             }
                             )

#' Trait for embedding an image file
#'
#' @export
ImageEditor <- Editor$proto(class=c("ImageEditor", Editor$class),
                            editor_name="gimage")


#' Trait for embedding graphics (RGtk2 only)
#'
#'
#' @export
GraphEditor <- Editor$proto(class=c("GraphEditor", Editor$class),
                            editor_name="ggraphics",
                            make_ui=function(., container, attr=.attr, context, ...) {
                              .$next_method("make_ui")(., container, attr, context, ...)
                              g <- .$get_widget_by_name(.$view_widget_name)
                              dev.no <- tag(g, "device") # used within fn. scope below

                              ## get RGtk2 widget now
                              ## This only works with RGtk2
                              if(is.proto(g)) # gWidgetsWWW
                                return()
                              widget <- getToolkitWidget(g)
                              if(!inherits(widget, "GtkDrawingArea"))
                                return()
                              
                              require(RGtk2) # must be explicity loaded?
                              ## we need to wait until the device is drawn here, otherwise we
                              ## don't have a device number
                              addHandler(g, "map-event", handler=function(h,...) {
                                . <- h$action$editor
                                .$dev_no <- tag(h$obj,"device")
                              },
                                         action=list(editor=.))
                              ## handler for raising device when appropriate
                              f <- function(., ...) {
                                dev.no <- .$dev_no
                                dev.set(dev.no)
                                return(TRUE)
                              }

                              ## raise when click into window
                              gSignalConnect(widget, "button-press-event", f=f, data=., user.data.first=TRUE)
                              ## raise when motion over device
                              widget$addEvents(GdkEventMask['enter-notify-mask'])
                              gSignalConnect(widget, "enter-notify-event", f=f, data=., user.data.first=TRUE)
                              ## close device when destroyed
                              gSignalConnect(widget, "destroy-event", f=function(.,...) {
                                dev.no <- .$dev_no
                                dev.off(dev.no)
                                return(TRUE)
                              },
                                             , data=., user.data.first=TRUE)

                              invisible()
                            },
                            set_value_in_view = function(.,...) {},
                            get_value_from_view= function(.,...) {}
                            )

#' Trait for making File browser editor
#' @export
FileBrowseEditor <- Editor$proto(class=c("FileBrowseEditor", Editor$class),
                                 editor_name="gfilebrowse")

#' Trait for data selection editor
#' @export
DateEditor <- Editor$proto(class=c("DateEditor", Editor$class),
                                 editor_name="gcalendar")


#' Trait for displaying a table of information 
#'
#' No selection, just display. For selection use ChoiceItem
#' @export
TableEditor <- Editor$proto(class=c("TableEditor", Editor$class),
                            editor_name="gtable",
                            attr=list(expand=TRUE),
                            set_value_in_view=function(.,widget_name=.$view_widget_name, value) {
                              ## replace the widget -- so that size issues are there
                              widget <- .$get_widget_by_name(widget_name)
                              group <- .$get_widget_by_name(".cont")
                              if(!is.null(group) && !is.null(widget)) {
                                delete(group, widget)
                                if(!(is.data.frame(value) || is.matrix(value)))
                                  value <- as.data.frame(value)
                                .$widgets[[.$view_widget_name]] <- gtable(value, cont=group, expand=TRUE)
                              }
                            },
                            get_value_from_view=function(., ...) {},
                            make_ui=function(., container, attr=.$attr, context=., ...) {
                              df <- context$do_call(sprintf("get_%s",context$name))
                              if(!is.data.frame(df))
                                df <- data.frame(V1="", V2="")
                              .$widgets[[".cont"]] <- (g <- ggroup(cont=container, expand=TRUE))
                              attr$items <- df; attr$cont <- g
                              .$widgets[[.$view_widget_name]] <- (widget <- do.call("gtable",attr))
                              if(!is.null(attr$size))
                                size(g) <- attr$size
                            }
                            )

                              
#' Trait for a label
#' @export
LabelEditor <- Editor$proto(class=c("LabelEditor",Editor$class),
                            editor_name="glabel"
                            )


#' Trait for making a visual separator
#' @export
SeparatorEditor <- Editor$proto(class=c("SeparatorEditor",Editor$class),
                                editor_name="gseparator",
                                attr=list(expand=TRUE),
                                set_value_in_view = function(.,...) {},
                                get_value_from_view= function(.,...) {}
                                )
#line 1 "/private/tmp/RtmpA4c7nI/R.INSTALL10d63af1/traitr/R/itemgroup.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/

#' @include editor.R
roxygen()

##################################################
## An item group is the main thing. A Model with a means to be viewed and
## adapters defined automatically

#' Base Trait to group items together to form a model. ItemGroups may be viewed as a model, view and controller
#' bundled together in a tidy package.
#'
#' An item group is a collection of Item instances. These
#' are specified through the \code{items} property as a list.
#'
#' ItemGroups implement the observer pattern, so are models and can have observers listen for changes
#' ItemGroups observe themselves to update the user interface on model changes. One can add other observers if desired.
#' See the \code{init} method for an example.
#'
#' If a method \code{model_value_changed} is defined, then it will be called with the ItemGroup instance being
#' in whenever a property of the model has a new value. The handlers \code{property_NAME_value_changed} is called
#' when the main value in item NAME is changed. (An item can have several properties, one of which is the main one.)
#'
#' ItemGroups have a \code{make\_gui} method to make a view of the model. The layout of this GUI can be
#' specified through its \code{gui\_layout} argument, or by default have a simple table layout. ItemGroup instances
#' are meant to be embedded into a GUI, so the \code{cont} argument is needed to pass in the desired container.
#'
#' @export
ItemGroup <- Model$proto(class=c("ItemGroup",  Model$class),
                         ## our properties are instances of Item
                         .doc_items=paste(
                           desc("property containing items in ItemGroup")
                           ),
                         items=list(),
                         ## methods
                         ## Get items
                         ## items are Item instances *and* ItemGroup instances
                         .doc_get_items=paste(
                           desc("Return named list of items")
                           ),
                         get_items = function(.) { # all items
                           items <- .$items
                           nms <- sapply(items, function(i) i$name)
                           names(items) <- make.names(nms, unique=TRUE)
                           items
                         },
                         ## gets items, flattens out ItemGroup entries
                         ## does not return some items
                         .doc_get_items_only=paste(
                           desc("Method to return items that can have values (ignoring SeparatorItems, say)")
                           ),
                         get_items_only = function(.) {
                           not_these <- c("SeparatorItem", "GraphItem")
                           l <- list()
                           for(i in .$get_items()) {
                             if(i$is("Item"))
                               l <- c(l, i)
                             else
                               l <- c(l, i$get_items_only())
                           }
                           ind <- sapply(l, function(i) i$is(not_these))
                           l <- l[!ind]
                           l[!sapply(l, is.null)]
                         },
                         ## return items by key or name, flattened ober ItemGroups
                         .doc_get_item=paste(
                           desc("Method to retrieve item by a key")
                           ),
                         get_item = function(., key) .$items[[key]], # item by key
                         .doc_get_item_by_name = paste(
                           desc("Method to retrieve item by its name")
                           ),
                         get_item_by_name = function(., name) {      # item by name
                           .$get_items()[[name]]
                         },
                         ## to get values from the items
                         .doc_to_R=paste(
                           desc("Method to take values in model and return as a named list. Names",
                                "come from the item names. Each item returns its own value, likely after",
                                "coercion to the desired type.")
                           ),
                         to_R = function(.) {
                           sapply(.$get_items_only(), function(i) i$to_R())
                         },
                         .doc_to_string=paste(
                           desc("Method to return list of string representations of items")
                           ),
                         to_string = function(.) {
                           sapply(.$get_items_only(), function(i) i$to_string())                           
                         },

                         ## make_gui constructs the GUI from a specifed layout
                         ## parent, visible ignored
                         gui_layout=NULL, # empty by default
                         .doc_make_gui=paste(
                           desc("Method to make GUI for ItemGroup. The GUI layout is specified by a container",
                                "defaulting to a simple table listing all items (aContainer)."),
                           param("cont","container to hold the GUI. See Dialog for self contained GUIs"),
                           param("gui_layout", "A layout for the GUI. The default is a table layout"),
                           param("parent", "Not used. Here for consistency with same method in Dialog class"),
                           param("visible", "Not implemented"),
                           returns("Creates a GUI, no return value")
                           ),
                         make_gui = function(., container, gui_layout, parent=NULL, visible=TRUE, ...) {
                           .$init_model() # initialize model

                           
                           if(missing(gui_layout)) {
                             if(.$has_slot("gui_layout") && is.proto(.$gui_layout) && .$gui_layout$is("Container"))
                               gui_layout <- .$gui_layout
                             else
                               gui_layout <- .$make_default_gui_layout()
                           }

                           if(!is.proto(gui_layout))
                             stop("Layout must be a Container object")
                           if(!gui_layout$is("Container"))
                               stop("Layout must be a Container object")

                           if(is.null(gui_layout$context))
                             gui_layout$context <- .

                           gui_layout$make_ui(container=container) ## set up view
                           .$gui_layout <- gui_layout

                           .$init() ## initialize controller, ...
                         },
                         ## default layout if layout not specified
                         .doc_make_default_gui_layout=paste(
                           desc("Method describing default GUI layout. Default",
                                "is a table layout with each item being one row.")
                         ),
                         make_default_gui_layout=function(.) {
                           gui_layout <- do.call("aContainer", .$get_items())
                           gui_layout$context <- .
                           gui_layout
                         },
                         # visible
                         .doc_visible = paste(
                           desc("Method call to set visibility of items in group"),
                           param("value","A logical")
                           ),
                         visible=function(., value) {
                            sapply(.$get_items(), function(i) i$visible(value))
                         },
                         ## enabled
                         .doc_enabled = paste(
                           desc("Method call to set sensitivity of items in group"),
                           param("value","A logical")
                           ),
                         enabled=function(., value) {
                           sapply(.$get_items(), function(i) i$enabled(value))
                         },
                         ## in case itemgroup used as an item, this just passes off to make_gui
                         make_ui=function(., container, attr=.$attr, context=., ...) {
                           .$make_gui(container=container, attr=attr, context=context, ...)
                         },
                         ## init should set up the items controllers
                         ## as of now we call
                         ## make_ui which calls init


                         
                         ## initialize model
                         ## can be called before view is set
                         .doc_init_model=paste(
                           desc("Method to initialize model part of item group.",
                                "fixes names if given as named list in items",
                                "make get/set methods as part of item group",
                                "Initializes models for reach itemm")
                           ),                                
                         init_model=function(.) {
                           ## fix names in items if not specified
                           sapply(names(.$items), function(i) {
                             item <- .$items[[i]]
                             if(is.null(item$name) || (item$name == "Anonymous"))
                               item$name <- i
                             if(is.null(item$label) || (item$label == "Anonymous"))
                               item$label <- i
                           })

                           ## call init_model for each item
                           sapply(.$items, function(j) j$do_call("init_model"))
                           
                           ## make get_/set_pairs
                           sapply(.$get_items_only(), function(i) {
                             if(i$has_slot("name")) {
                               property <- i$name
                               .$assign_if_null(paste("get_", i$name, sep=""),
                                      function(.) {
                                        .$get_item_by_name(property)$getattr(property)
#                                        i$get_model()$getattr(property)
                                      })
                               .$assign_if_null(paste("set_", i$name, sep=""),
                                                function(., value) {
                                                  .$get_item_by_name(property)$setattr(property, value)
                                                }
                                                )
                            }
                           })
                           ## add in undo
                           if(.$undo_do) {
                             sapply(.$items, function(i) {
                               property <- i$name
                               meth <- sprintf(".property_%s_value_changed", property)
                               .$assign_if_null(meth, function(., value, old_value) {
                                 .$undo_add(property, value, old_value)
                               })
                             })
                           }
                           
                           invisible()
                         },
                         ## set model (the items) for the itemgroup from another
                         .doc_set_model=paste(
                           desc("Set model for the itemgroup. The set of items should match",
                                "by type and name and not include any items groups."),
                           param("itemgroup","An itemgroup or dialog instance")
                           ),
                         set_model =function(., itemgroup) {
                           old_items <- .$get_items()
                           new_items <- itemgroup$get_items()
                           if(digest(sort(names(old_items))) == digest(sort(names(new_items)))) {
                             ## names match, lets replace models
                             for(i in names(old_items)) {
                               old_items[[i]]$set_model(new_items[[i]])
                             }
                           }
                         },
                         
                         ## initialize controllers
                         ## called after view is set
                         .doc_init_controller=paste(
                           desc("Initialize controller to connect view with model")
                           ),
                         init_controller=function(.) {
                           ## make self observe itself. This way we can add handlers
                           ## without making a controller
                           .$add_observer(.)
                           ## set up controllers
                           sapply(.$get_items(), function(i) i$init())
                           ## had code to call update_ui through a controller
                           ## this code is now in the dialog code. item groups do
                           ## not automatically have there UI updated?
                         },
                         ## initialize items -- called after making GUI
                         init=function(.) {
                           .$init_model()
                           .$init_controller()
                           .$update_ui()
                         },
                         ## instance
                         instance=function(.) {
                           obj <- .$proto()
                           obj$items <- lapply(obj$items, function(i) i$instance())
                           if(!is.null(obj$gui_layout)) {
                             obj$gui_layout <- obj$gui_layout$instance()
##                              ## gui_layout children need to be instances too
##                              obj$gui_layout$container <- NULL
##                              obj$gui_layout$children <- lapply(obj$gui_layout$children, function(i) {
##                                if(is.proto(i))
##                                  i$instance()
##                                else
##                                  i
##                              })
                           }
                           obj
                         },
                         add_observer = function(., o) {
                           ## push down to models in items to add observer
                           sapply(.$get_items_only(), function(i) {
                             i$do_call("add_observer",list(o))
                           })
                           invisible()
                         },
                         remove_observer = function(., o) {
                           ## push down to models in items to add observer
                           sapply(.$get_items_only(), function(i) {
                             ## either an item or itemgroup so we push down
                               i$do_call("remove_observer",list(o))
                           })
                         },
                         
                         ## undo/redo stack implementation
                         ## THIS ISN"T WORKING
                         ## must add observer to listen for property value changes
                         ## as we don't call set_property to an itemgroup to change an item's value.
                         .doc_undo_do=paste(
                           desc("Logical property. If <code>TRUE</code> undo feature is implemented.")
                           ),
                         undo_do=TRUE,  # logical -- do we use undo.
                         undo_stack=list(),
                         undo_ptr = 0,
                         undo_stack_length=25, ## <= 0 to have unlimited
                         undo_trim_stack=function(.) {
                           if(.$undo_stack_length > 0) {
                             stack <- .$undo_stack
                             if((n <- length(stack)) > (m <- .$undo_stack_length)) {
                               .$undo_ptr <- max(0, .$undo_ptr-(n-m))
                               stack <- stack[(n-m):n]
                               .$undo_stack <- stack
                             }
                           }
                         },
                         undo_add=function(., property, value, old_value, ...) {
                           if(.$undo_ptr > 0)
                             stack <- .$undo_stack[1:.$undo_ptr]
                           else
                             stack <- list()
                           stack[[length(stack)+1]] <- merge(list(property=property, value=value, old_value=old_value),
                                                             list(...))
                           .$undo_stack <- stack
                           .$undo_ptr <- length(stack)
                           .$undo_trim_stack()
                         },
                         undo_can_undo=function(.) .$undo_ptr > 0,
                         undo=function(.) {
                           if(.$undo_can_undo()) {
                             val <- .$undo_stack[[.$undo_ptr]]
                             .$get_item_by_name(val$property)$setattr(val$property, val$old_value, notify_private=FALSE) ## by pass set_property
                             .$undo_ptr <- .$undo_ptr-1
##                             .$update_ui()
                           }
                         },
                         undo_can_redo=function(.) .$undo_ptr < length(.$undo_stack),
                         redo=function(.) {
                           if(.$undo_can_redo()) {
                             val <- .$undo_stack[[.$undo_ptr + 1]]
                             .$get_item_by_name(val$property)$setattr(val$property, val$value, notify_private=FALSE)
                             .$undo_ptr <- .$undo_ptr + 1
##                             .$update_ui()                             
                           }
                         },
                         
                         
                         ## methods to call down into items
                         .doc_update_ui=paste(
                           desc("Method to update user interface.")
                           ),
                         update_ui=function(.) {
                           ## update items
                           sapply(.$get_items(), function(i) i$update_ui())
                           ## update gui_layout
                           if(.$has_slot("gui_layout") && !is.null(.$gui_layout))
                             .$gui_layout$update_ui()
                         }
                         )

## a constructor
#' Constructor for ItemGroup instances
#'
#' An ItemGroup creates a model with properties given by the items
#' and a default layout for its items. This can also be specified
#' when the layout is drawn through \code{make\_gui}.
#' @param items List of Item instances or ItemGroup instances
#' @param name Name of ItemGroup.
#' @param ... Passed to ItemGroup proto trait
#' @seealso \code{\link{aContainer}} for specifying a layout
#     \code{\link{aDialog}} for an extension to an ItemGroup that creates its own window.
#' @export
#' @return A \code{proto} object. Call \code{obj$show_help()} to view its methods and properties.
#' @examples
#' \dontrun{
#' ## make a simple item group, show in non-default layout
#' i <- anItemGroup(items=list(
#'                  numericItem(0,"x"),
#'                  numericItem(0,"y"),
#'                  stringItem("","z")
#'                  ))
#' lay <- aContainer("x","y", aFrame("z", label="z in a box"))
#' ## some proto methods:
#' i$make_gui(cont=gwindow("Example of itemGroup"), gui_layout=lay)
#' i$get_x()     # get x value
#' i$set_x(10)   # set x value to 10
#' i$to_R()      # get list of x,y,z values
#' }


anItemGroup <- function(items=list(),
                      name, ...) {

  if(missing(name))
    name <- "Anonymous"
  
  obj <- ItemGroup$proto(items=items,
                         name=name,
                         ...)
  obj$init_model()
  return(obj)
}
#line 1 "/private/tmp/RtmpA4c7nI/R.INSTALL10d63af1/traitr/R/dialog.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/

#' @include itemgroup.R
roxygen()

##################################################
#' A Dialog wraps a top-level window around a collection of items which may be item groups
#' 
#' One can specify the parent when making the UI
#' Buttons are specified through the buttons property
#' @export
Dialog <- ItemGroup$proto(class=c("Dialog", ItemGroup$class),
                          ## window title
                          title="Dialog title",
                          ## called by default help button handler
                          help_string="",
                          ## !is.null to create a status bar
                          status_text=NULL,
                          ## If !is.null, specifies list to pass to gmenu
                          menu_list = NULL,
                          ## If !is.null, specifies list to pass to gmenu                          
                          toolbar_list=NULL,
                          ## Buttons are OK, Cancel, Help, or any other name. The button handler
                          ## is NAME_handler defined as follows
                          .doc_buttons=paste(
                            desc("A propoerty listing the buttons to place into dialog.",
                                 "A button with name <code>name</code> will call",
                                 "a method <code>name_handler</code>. Default handlers are defined for",
                                 "OK, Cancel, Help, Undo, Redo, but usually the OK handler would be ",
                                 "redefined for a dialog instance.",
                                 "The default set of buttons is OK, Cancel, Help.",
                                 "Use button named <code>SPACE</code> to add 12px space between",
                                 "buttons. Use button named <code>SPRING</code>to add spring between buttons (",
                                 "pushes buttons to left and right"
                                 )
                            ),
                          buttons=c("OK", "Cancel","SPACE", "Help"),#, "Undo","Redo"), 
                          ## Default button handlers. OK_handler needs to be
                          ## overridden in the instance
                          OK_handler=function(.) {
                            print(.$to_R())
                          },
                          Cancel_handler = function(.) {
                            dispose(.$get_widget('toplevel'))
                          },
                          Help_handler = function(.) {
                            gmessage(c("Help", .$help_string), icon="info", parent=.$get_widget('toplevel'))
                          },
                          Undo_handler=function(.) .$undo(),
                          Redo_handler=function(.) .$redo(),
                          ## on_realized is called after make_gui
                          on_realized = function(.) {
                            .$update_ui()
                          },
                          
                          ## This is a list, not named, of Items or ItemLists
                          ## names are found from items.
                          items=list(),  # Items or ItemList
                          widget_list=list(), # where widgets are stored
                          get_widget=function(.,key) .$widget_list[[key]],
                          ## make_gui makes the dialog (make_ui has different arguments)
                          ## make the dialog.
                          ## parent can be NULL, a gwindow instance, or a dialog instance
                          ## set visible to FALSE to suppress drawing. Use .$visible(TRUE) to show
                          .doc_make_gui=paste(
                            desc("Make gui for the dialog",
                                  "Creates top level window located near <code>parent</code>, if given.",
                                  "Creates buttons. When clicked, these call handlers of similar name. That is,",
                                  "'OK' button calls 'OK_handler'. Button name is stripped of non letters before call,",
                                  "so 'Next >>' would call 'Next_handler'.",
                                  "Call on_realized method, if defined after construction"
                                  )
                            ),
                          make_gui=function(., gui_layout=.$make_default_gui_layout(), parent=NULL, visible=TRUE) {
                            .$init_model() # initialize model ## also called in aDialog?

                            
                            if(!is.null(parent)) {
                              if(is.proto(parent) && exists("traitr", parent) && parent$is("Dialog"))
                                parent <- parent$get_widget("toplevel")
                            }
                            widgets <- list() # where widgets are to store
                            ## make window
                            widgets[['toplevel']] <- (w <- gwindow(.$title, parent=parent, visible=FALSE))

                            ## uses gWidgets -- not actionItems 
                            ## menu
                            if(!is.null(.$menu_list))
                              widgets[['menu']] <- gmenu(.$menu_list, container = w)
                            if(!is.null(.$toolbar_list))
                              widgets[['toolbar']] <- gtoolbar(.$toolbar_list, container = w)
                            
                            ## main part
                            g <- ggroup(horizontal=FALSE, cont=widgets[['toplevel']], spacing=10)


                            .$next_method("make_gui")(., container=g, gui_layout=gui_layout)



                            ## buttons
                            ## handlers called via buttonName_handler method defined
                            bg <- ggroup(cont=g)
                            sapply(.$buttons, function(i) {
                              if(i == "SPACE") {
                                addSpace(bg, 10)
                                return()
                              } else if(i == "SPRING") {
                                addSpring(bg)
                                return()
                              }
                              
                              widgets[[i]] <<- (b <- gbutton(i, cont=bg))
                              addHandlerClicked(b, function(h,...) {
                                . <- h$action$self
                                button_name <- h$action$button_name
                                ## strip off all but characters
                                button_name <- gsub("[^a-zA-Z]","",button_name)
                                .$do_call(sprintf("%s_handler", button_name), list())
                              }, action=list(self=., button_name=i))
                            })
                            ## status bar
                            if(!is.null(.$status_text))
                              widgets[['statusbar']] <- gstatusbar(.$status_text, cont=widgets[['toplevel']])

                            ## set visible if requested
                            visible(widgets[['toplevel']]) <- visible

                            ## set widgets
                            .$widget_list <- widgets
                            ## call hook for realized
                            .$do_call("on_realized")

                            .$assign_if_null("model_value_changed", function(.) .$update_ui())
#                            .$init() ## initialize controller, ... ## called in ItemGroup

                            ## we listen to ourselves
                            ## already in init_controller for 
#                            .$add_observer(.)

                            invisible()
                          },
                          ## close the gui
                          close_gui = function(.) {
                            l <- .$widget_list
                            try(dispose(l$toplevel), silent=TRUE)
                          },
                          ## toggle visibility of top level window of dialog
                          visible=function(., value=TRUE) {
                            widget <- .$get_widget('toplevel')
                            visible(widget) <- as.logical(value)
                          },
                          ## Set status bar text if one was added at construction time
                          .doc_update_status_text=paste(
                            desc("Method to update text in status bar, if one exists")
                            ),
                          update_status_text=function(., value) {
                            if(.$has_local_slot(".statusbar"))
                              svalue(.$.statusbar) <- value
                          },
                          ## return list of values from each Item and ItemGroup in items
                          ## should be able to pass to do.call for function evaluation
                          to_R=function(.) {
                            l <- list()
                            for(i in .$items) l <- c(l, i$to_R())
                            l
                          },
                          to_string=function(.) {
                            l <- list()
                            for(i in .$items) l <- c(l, i$to_string())
                            l
                          },
                          ##
                          update_ui=function(.) {
                            ## undo/redo buttons
                            undo <- .$get_widget("Undo");
                            redo <- .$get_widget("Redo");
                            if(!is.null(undo) && isExtant(undo))
                              enabled(undo) <- .$undo_can_undo()
                            if(!is.null(redo) && isExtant(redo))
                              enabled(redo) <- .$undo_can_redo()

                            
                            .$next_method("update_ui")(.)
                          } 
                          )

#' Create a Dialog instance
#'
#' @param items List of item instances to create the model for the dialog object
#' @param title Title of dialog
#' @param help_string String for default Help button
#' @param buttons Character vector of button names. "OK","Cancel","Help","Undo","Redo" are some standard ones.
#'        "SPACE" and "SPRING" adjust the layout.
#' @param ... How to pass in other properties and methods of the dialog object. For example \code{OK\_handler}.
#' @export
aDialog <- function(items=list(),
                    title="",
                    help_string="",
                    buttons=c("OK","SPACE","Cancel","Help"),
                    ...
                    ) {
  dlg <- Dialog$proto(items=items,
                      title=title,
                      help_string=help_string,
                      buttons=buttons,
                      ...)
  dlg$init_model()
  dlg
}

## #' Make GUI.
## #'
## #' Create a GUI for the items specified to the constructor. The default GUI is basic. Use a Container layout
## #' to design a GUI.
## #' @param obj A Dialog or ItemGroup instance
## #' @param gui.layout A Container instance to specify the layout. Default layout is a table
## #' @param parent For a Dialog, an optional window to center dialog on. For ItemGroup the parent container.
## #' @param visible For a dialog, do we view the dialog? If not, the visible method is provided
## #' @param ...
## #' @return Creates a GUI from the items as specified through the layout
## #' @export
## makeGUI <- function(obj, gui.layout=NULL, parent=NULL, visible=TRUE, ...) {
##   ## check if dialog, or item group
##   if(!is.proto(obj))
##     stop("Object must be proto object")
##   if(!obj$is(c("Dialog","ItemGroup")))
##     stop("Object must be instance of aDialog or anItemGroup")
##   if(obj$is("Dialog"))
##     obj$do_call("make_gui", list(gui_layout=gui.layout, parent=parent, visible=visible))
##   if(obj$is("ItemGroup")) 
##     obj$make_gui(gui_layout=gui.layout, cont=parent, ...)
##   stop(sprintf("makeGUI not defined for object of class %s",obj$class))
## }

## #' Get values from model
## #'
## #' @param obj a Dialog or ItemGroup instance
## #' @return A named list with the model values for each item
## getValues <- function(obj) {
##   ## check if dialog, or item group
##   if(!is.proto(obj))
##     stop("Object must be proto object")
##   if(!obj$is(c("Dialog","ItemGroup")))
##     stop("Object must be instance of aDialog or anItemGroup")

##   obj$to_R()
## }
#line 1 "/private/tmp/RtmpA4c7nI/R.INSTALL10d63af1/traitr/R/items.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/

#' @include editor.R
roxygen()

## TODO
## * Need to make more item groups:
##   * formulaItem
##   * dfeditItem

##################################################
## items

## An item is a model, a view (Editor) and a controller
## the init method should set up the controller.
## should have methods of a model

#' Base Trait for an Item
#'
#' An Item combines a model, view and controller interface into one convenient package.
#' Items may be combined into an ItemGroup or a Dialog to be shown.
#'
#' The \code{make\_ui} method creates the user interface, initializes the model and the controller.
#' The \code{init\_model}, \code{init\_controller} and \code{init\_ui} do the work.
#'
#' The model may be shared with different items. See \code{set\_model\_from\_item} or
#' the \code{instance} proto method.
#'
#' Items implement the observer interface, so one can add observers to listen for changes to
#' the properties. (Properties are listed in the property "\code{properties}".)
#'
#' Items use the Adpater interface to link the model with the view (an Editor). The "\code{properties}"
#' property lists the names of model properties. One should use "value" for the special one to be
#' returned by the method \code{to\_R}. (This method gathers values from the items after coercion)
#'
#' When an item's user interface is made, the method \code{on\_realized} is called.
#' @export
Item <- BaseTrait$proto(class=c("Item", "Model", BaseTrait$class),
                         ## item properties
                         .doc_name=paste(
                           desc("Unique name for lookup and for storing key property")
                           ),
                         name = "",           # for lookup
                        ## label
                         .doc_label=paste(
                           desc("Default label for editor")
                           ),
                         label = "label",     # for display
                        ## show label
                         .doc_show_label=paste(
                           desc("Logical indicating if label should be drawn in editor")
                           ),
                         show_label=TRUE,   # FALSE to suppress label
                        ## help string
                         .doc_help=paste(
                           desc("Property for storing help on an item")
                           ),
                         help = "",           # for documentation
                        ## tooltip string
                         .doc_tooltip=paste(
                           desc("If not an empty string, provides tooltip text for widget")
                           ),
                         tooltip = "",        # for tooltip. Shorter than help
                        ## attr
                         .doc_attr=paste(
                           desc("List of attributes to pass to constructor of editor. Include size=c(x,y) to set size")
                           ),
                         attr=list(),         # for layout of item
                        ## on realized method
                         .doc_on_realized=paste(
                           desc("Method called when widget is realized."),
                           param(".","Item object passed in, but no other")
                           ),
                         on_realized = NULL,  # call when widget is realized
                         ## Model properties
                         ## This list is used to figure out which values are in the model, if model
                         ## generated by init
                         ## "value" property should be first -- unless you want to do lots of other work
                        value="default value",
                         .doc_properties=paste(
                           desc("Character vector of property names for which this item object creates a model for.",
                                "Always a property with the value of 'name' is created. This adds other.",
                                "When <code>init_model</code>method is called",
                                "getter and setter methods are created.",
                                "The set methods call <code>notify_observers</code>")
                           ),
                         properties=c("value"),
                         ## list of properties to use to set get_/set_ methods
                         excluded_property_names=c("editor", "model"),
                         .doc_coerce_with=paste(
                           desc("function to coerce values stored in model with before returning",
                                "the value through the </code>to_R</code> method.",
                                "As with all <code>proto</code> functions, this method should have a '.' for",
                                "an initial argument"),
                           param(".","Initial argument, passes in item object"),
                           param("value","Value to be coerced")
                           ),
                         coerce_with = NULL, # a function e.g., function(., value) as.numeric(value)
                         
                         ## property for controller
                         .doc_add_handler_name=paste(
                           desc("Character vector with gWidgets addHandlerXXX names. Can be more than 1. Set to ''",
                                "if no handler is desired")
                           ),
                         add_handler_name="addHandlerChanged", ## "" for no view->model
                         handler_user_data=NULL,     
                         ## Set up widget
                         ## UI
                         .doc_editor=paste(
                           desc("Property to store instance of <code>Editor</code> class. This is",
                                "created by the item when the <code>init</code> method is called (often",
                                "by <code>make_ui</code>")
                           ),
                         editor = NULL, # editor class -- a view
                         .doc_set_editor=paste(
                           desc("Method to set an editor for the item object."),
                           param("editor","An <code>Editor</code>instance")
                           ),
                         set_editor = function(., editor) {
                           if(is.proto(editor) && editor$is("Editor")) {
                             .$editor=editor
                             if(!is.null(.$controller)) {
                               .$controller$set_view(editor)
                             }
                           }
                         },
                         .doc_get_editor=paste(
                           desc("Convenience method to return editor")
                           ),
                         get_editor = function(.) .$editor,
                         ## method to make instance, context, ... ignored
                         .doc_make_ui=paste(
                           desc("Method to create the user interface for the item."),
                           param("cont","gWidgets container to pack editor widgets into"),
                           param("attr","list of attributes to pass to gWidgets constructor."),
                           param("context","context is an <code>Item</code> or <code>ItemGroup</code>instance",
                                 "to give a context to the editor. (The editor picks up properties such as a",
                                 "label from this.")
                           ),
                         make_ui = function(., container, attr=.$attr, context, ...) {
                           .$init_model()
                           .$init_ui(container, attr, context, ...)
                           .$init_controller()
                         },
                         
                         ## When update_ui() is called, these two conditions are checked. If FALSE, then
                         ## the methods visible and enabled are called on the editor
##                          .doc_visible_when=paste(
##                            desc("Method evaluated when <code>update_ui</code> is called to determine if the",
##                                 "item should be visible. Should evaulate to a logical."),
##                            returns("A logical value to determine if item is visible")
##                            ),
##                          visible_when = function(.) {TRUE}, # function call. When update_ui called
##                          .doc_visible=paste(
##                            desc("Method to set visibility of editor"),
##                            param("value","a logical")
##                            ),
##                          visible = function(., value) {
##                            .$get_editor()$visible(as.logical(value))
##                          },
                         ## enabled
##                          .doc_enabled_when=paste(
##                            desc("Method evaluated when <code>update_ui</code> is called to determine if the",
##                                 "item should be enabled (sensitive to user input). Should evaulate to a logical."),
##                            returns("A logical value to determine if item is enabled")
##                            ),
##                          enabled_when = function(.) {TRUE}, # function call
##                          .doc_enabled=paste(
##                            desc("Method to set whether editor is enabled (sensitive to user input"),
##                            param("value","a logical")
##                            ),
##                          enabled = function(., value) {
##                            .$get_editor()$enabled(as.logical(value))
##                          },
                         ## a function(., rawvalue) return list with retval=TRUE for valid, retval=FALSE for invalid
                         ## pass message through mesg component
                         ## uses rawvalue, can coerce with .$coerce_with, which model does
                         set_validate =function(.,f) .$validate <- f,
                         .doc_validate = paste(
                           desc("Check if main value is valid. The model accepts invalid input, but when",
                                "coerced to an R object, through the to_R method, the value will not be as",
                                "expected.",
                                "In an item, the main value shares the same name as the 'name' property",
                                "to validate other properties, a method <code>validate_PROPERTYNAME</code>",
                                "can be provided.",
                                "All validate methods should return the validated value or throw an error",
                                "with message describing reason value is valid. The base validate method",
                                "applies coerce_with, This can be called with"
                                ),
                           param("rawvalue", "The value from the widget is passed in. This may be coerced through",
                                 "the <code>coerced_with</code> method directly, by calling the validate model",
                                 "in .super"
                                 )
                           ),
                         validate=function(., rawvalue) {
                           warn_val <- getOption("warn")
                           options(warn=2)
                           on.exit(options(warn=warn_val))
                           if(!is.null(.$coerce_with))
                             return(.$do_call("coerce_with",list(value=rawvalue)))
                           else
                             return(rawvalue)
                         },
                         ## keep for validation -- prevents multiple calls
                         .last_error="",
                         ## the model
                         .doc_model=paste(
                           desc("Internal property to hold model instance")
                           ),
                         model=NULL,
                         .doc_set_model=paste(
                           desc("Method to set model for item object. Model must be of correct class, ",
                                "Either Model or another Item object. In the latter case the model is",
                                "shared"),
                           param("model","Either an Model or Item instance")
                           ),
                         set_model=function(., model) {
                           if(is.proto(model) && model$is("Item")) {
                             .$set_model_from_item(model)
                           } else if(is.proto(model) && model$is("Model")) {
                             old_model <- .$get_model()
                             .$model <- model
                             ## observers
                             
                             ## controller
                             if(!is.null(.$controller)) {
                               .$controller$set_model(model)
                             }
                             ## update views
                             if(!is.null(.$get_slot("editor")) && .$editor$is_realized()) {
                               sapply(.$model$list_observers(), function(o) {
                                 nms <- o$list_methods()
                                 sapply(nms, function(i) {
                                   if(grepl("^property_(.*)_value_changed$",i)) {
                                     prop <- gsub("property_(.*)_value_changed$","\\1",i)
                                     value <- .$do_call(sprintf("get_%s",prop))
                                     do.call(o$get_slot(i),
                                             list(.=o, value=value, old_value=value))
                                   }
                                 })
                               })
                             }
                           } 
                           invisible()
                         },
                         ## Use the model from a different item
                         set_model_from_item=function(., item) {
                           if(!missing(item) && (is.proto(item) && item$is("Item"))) {
                             item$init_model() # if not initialized, needs to be
                             m <- item$get_model()
                             .$set_model(m)
                           }
                         },
                         .doc_get_model=paste(
                           desc("Return model from Item object")
                           ),
                         get_model=function(.) .$model,
                         ## observers
                         add_observer = function(., o) {
                           .$get_model()$add_observer(o)
                         },
                         remove_observer = function(., o) {
                           .$get_model()$remove_observer(o)
                         },
                         ## defines get/set values for model
                         getattr=function(., key) .$model$getattr(key),
                         .doc_setattr=paste(
                           desc("After validation, sets model attribute (property) which notifies the observers.",
                                "Also updates user interface"),
                           param("key","Property name"),
                           param("value","new model value"),
                           param("notify_private","For undo use, ignore")
                           ),
                         setattr=function(., key, value, notify_private=TRUE) {
                           ## we validate if key=name
                           ## or if there is a validate_key method
                           validate_method_name = ""
                           tmp <- sprintf("validate_%s", key)
                           if(key == .$name) {
                             validate_method_name="validate"
                           } else if (.$has_slot(tmp)) {
                             validate_method_name <- tmp
                           }
                           if(validate_method_name != "") {
                             validated_value <- try(.$do_call(validate_method_name, list(rawvalue=value)), silent=TRUE)
                             if(inherits(validated_value, "try-error")) {
                               if(digest(.$.last_error) != digest(validated_value)) {
                                 .$.last_error <- validated_value
                                 ## editor needs to be told it is invalid
                                 if(!is.null(.$editor) && .$editor$is_realized())
                                   .$editor$set_invalid(validated_value)
                                 else
                                   cat(sprintf("Not a valid value: %s\n", validated_value))
                               }
                             } else {
                               if(!is.null(.$editor) && .$editor$is_realized())
                                 .$editor$set_valid()
                             }
                           }
                           ## we store the value (a string) not the validated value
                           .$model$setattr(key, value, notify_private) 
                           .$update_ui()
                           invisible()
                         },
                         ## defines initial model if not present
                        .doc_default_get=paste(
                          desc("Return function for default get method (get_name)")
                          ),
                        default_get=function(.) {
                          function(.) {.$getattr(.$name)}
                        },
                        .doc_default_set=paste(
                          desc("Default function for set_name(., value).",
                               "This allows items to override the default behaviour which is",
                               "to return the value stored in the property <code>.$name</code>.")
                          ),
                        default_set=function(.) {
                          function(., value) {.$setattr(.$name, value)}
                        },
                         .doc_init_model=paste(
                           desc("Method to initialize the model. If overriding, must be done prior to making the",
                                "user interface",
                                "This method fixes names and makes the model store the properties, not the item",
                                "instance.")
                           ),
                         init_model=function(.) {
                           model <- .$model
                           if(is.null(model) || (is.proto(model) && !model$is("Model"))) {
                             .$model <- Model$proto()
                           }
                           ## move properties from this object to model, where it fits better
                           sapply(c(.$name, .$properties), function(i) {
                             if(i %in% .$excluded_property_names) 
                               warning(sprintf("%s is a reserved property name",i))
                           })
                           ## assign name as default if not already defined
                           ## need to not look up, as things like "mean", "sd" etc are found
                           ## here. Might need to change though to search over all proto objects?
                           if(!.$model$has_local_slot(.$name))
                             .$model$assign_if_null(.$name, .$value)

                           sapply(.$properties, function(i) {
                             if(.$has_slot(i))
                               val <- .$get_slot(i)
                             else
                               val <- NULL
                             .$model$assign_if_null(i, val)
                           })
                           .$model$init()

                           ## make get/set pairs for properties (push down to model)
                           QT <- sapply(.$properties, function(i) {
                             .$assign_if_null(paste("get_",i,sep=""),
                                    function(.) {
                                      .$getattr(i)
                                    })
                             .$assign_if_null(paste(".doc_get_",i,sep=""),"get value method")
                             ## set
                             .$assign_if_null(paste("set_",i,sep=""),
                                    function(., value) {
                                      .$setattr(i, value)
                                    })
                             .$assign_if_null(paste(".doc_set_",i,sep=""),"set value method")
                           })
                           ## default for .$name. Allows items to override default behaviour
                           .$assign_if_null(sprintf("get_%s",.$name), .$default_get())
                           .$assign_if_null(sprintf(".doc_get_%s",.$name), "Get main value")
                           .$assign_if_null(sprintf("set_%s",.$name), .$default_set())
                           .$assign_if_null(sprintf(".doc_set_%s",.$name), "Set main value")
                         },
                         ## return object stored in model
                         ## this may be coerced
                         .doc_to_R=paste(
                           desc("Method to return value item value as a named list",
                                "Name is given by <code>name<property> by default",
                                "default value is just value in this property, override in ",
                                "instances for something more interesting.",
                                "Called by <code>to_R</code>  ItemGroup method.")
                           ),
                         to_R = function(.) {
                           value <- .$do_call(sprintf("get_%s",.$name),list())
                           if(!is.null(.$coerce_with))
                             value <- .$coerce_with(value)
                           l <- list(value)
                           if(exists("name", .))
                             names(l)[1] <- .$name
                           return(l)
                         },
                         ## return string representation
                         .doc_to_string=paste(
                           desc("Return model value as a string.",
                                "Default assumes key property is",
                                "named <code>value</code>")
                           ),
                         to_string = function(.) {
                           value <- .$do_call(sprintf("get_%s",.$name),list())
                           ## any formatting??
                           return(value)
                         },


                        
                        ## controller
                         controller=NULL,
                         ## set up controller if model and editor defined
                         init_controller=function(.) {
                           ## we make adapter to link model and view by default.
                           ## sub-class can override this to be more complicated
                           .$controller <-  Adapter$proto(model=., #.$model, (force use of setattr for validation)
                                                          view=.$editor,
                                                          property=.$name,
                                                          view_widget_name=.$editor$view_widget_name,
                                                          validate = .$validate,
                                                          add_handler_name=.$add_handler_name,
                                                          handler_user_data=handler_user_data)
                           .$controller$init()
                         },
                        .doc_init_ui=paste(
                          desc("Initialize the user interface",
                               "Does not set up controller, see <code>init_controller</code> for that.",
                               "Does not set up model, see <code>init_model</code> for that.",
                               "See <code>make_ui</code> to put this all together."
                               )
                          ),
                        init_ui=function(., container, attr=.$attr, context, ...) {
                          if(is.null(.$editor) || !.$editor$is_realized()) {
                            if(is.null(.$editor) || (is.proto(.$editor) && !.$editor$is("Editor")))
                              .$editor <- Editor$proto()
                            .$get_editor()$.make_ui(container, attr, context=.,...)
                            ## call when widget is realized
                             .$do_call("on_realized", list())
                          }
                        },

                        ## init sets up model.
                        ## see make_ui to set up model, view (init_ui) and controller 
                         init=function(.) {
                           .$init_model()
                         },
                         .doc_new=paste(
                           desc("This creates the item and initializes its model")
                           ),
                         new=function(.,...) {
                           obj <- .$proto(...)
                           obj$init_model()
                           obj
                         },
                         ## instance
                         .doc_instance=paste(
                           desc("Create a new instance of an object. Shares model, controller, but not view")
                           ),
                         instance=function(.) {
                           obj <- .$proto()
                           if(!is.null(.$editor)) 
                             obj$editor <- .$editor$instance()
                           obj
                         },
                         ## used to update UI
                         .doc_update_ui=paste(
                           desc("Update the user interface. Checks visible_when and enabled_when")
                           ),
                         update_ui=function(.) {
                           ## do we need to do this? Or are only itemgroups/containers updated to be visible/enabled?
                                        #                           .$editor$visible(.$visible_when())
                                        #                           .$editor$enabled(.$enabled_when())
                           invisible()
                         }
                        )


##################################################
## Various Item instances


## Item instances
## An instance must have
## init_model, init_controller, init_ui
## the model interface: add_,remove_,notify_ observer
## a method default_get, default_set if desired

#' A string item
#' @export
#' @param value Default value for the model
#' @param regex If non \code{NULL} specifies a regular expression for validation.
#' @param name Required name for object. Names should be unique within a group of items
#' @param label Optional label, default value is the name
#' @param help Optional help string
#' @param tooltip Optional tooltip to display
#' @param eval_first Should value be run through eval/parse before coercion.
#' @param attr A list of attributes to pass to widget on construction. Eg. attr=list(size=c(100,200))
#' @param model Optional model. Useful if one wishes to use same model for multiple views
#' @param editor Specification of editor (a view) to override default
#' @param ... Passed to parent proto object during call to proto
#' @return A \code{proto} object. Call \code{obj\$show_help()} to view its methods and properties.
stringItem <- function(value="",        # initial vlaue
                       regex=NULL,      # if non-null a regular expression for validation
                       name,            # for lookup with item group
                       label=name,      # for display
                       help="",
                       tooltip="",
                       eval_first=FALSE, # call eval(parse(text=.)) before coercion
                       attr,
                       model,
                       editor,
                       ...) {


  if(missing(name))
    name <- "Anonymous"


  obj <- Item$proto(name=name, label=label, help=help,
                    tooltip=tooltip, value=value,
                    add_handler_name=paste("addHandler", c("Changed","Blur"), sep=""),
                    ...
                    )
  obj$add_class("StringItem")
  
  if(eval_first)
    obj$coerce_with <-  function(., value) {
    value <- eval(parse(text=value), envir=.GlobalEnv)
    as.character(value)
  }

  if(!is.null(regex)) {
    if(!is.character(regex))
      stop("Argument regex is a string specifying a regular expression for validation")
    obj$.regex <- regex
    obj$validate <- function(., rawvalue) {
      value <- .$next_method("validate")(., rawvalue)
      if(grepl(.$.regex, value))
        return(value)
      else
        stop(sprintf("%s does not match regular expression: %s", value, .$.regex))
    }
  }

  
  if(!missing(attr))
    obj$attr <- merge(obj$attr, attr)

  if(missing(editor))
    obj$editor <- EntryEditor$proto()
  
  if(!missing(model))
    obj$set_model(model)

  return(obj)
}

#' Item for numbers
#' @export
#' @param value Default value for the model
#' @param name Required name for object. Names should be unique within a group of items
#' @param label Optional label, default value is the name
#' @param help Optional help string
#' @param tooltip Optional tooltip to display
#' @param eval_first Should value be run through eval/parse before coercion.
#' @param attr A list of attributes to pass to widget on construction. Eg. attr=list(size=c(100,200))
#' @param model Optional model. Useful if one wishes to use same model for multiple views
#' @param editor Specification of editor (a view) to override default
#' @param ... Passed to parent proto object during call to proto
#' @return A \code{proto} object. Call \code{obj$show_help()} to view its methods and properties.
numericItem <- function(value=numeric(0), # a number
                        name,            # for lookup with item group
                        label=name,      # for display
                        help="",
                        tooltip="",
                        eval_first=FALSE, # call eval(parse(text=.), envir=.GlobalEnv) before coercion
                        attr,
                        model,
                        editor,
                        ...) {
  

  if(missing(name))
    name <- "Anonymous"

 

  obj <- Item$proto(name=name, label=label, help=help,
                    tooltip=tooltip, value=value,
                    add_handler_name=paste("addHandler", c("Changed","Blur"), sep=""),
                    ...
                    )
  obj$add_class("NumericItem")
  obj$validate <- function(., rawvalue) {
    value <- .$next_method("validate")(., rawvalue)
    if(is.numeric(value))
      return(value)
    else
      stop("Not numeric")
  }
  
  if(eval_first) {
    obj$coerce_with <- function(., value) {
      value <- eval(parse(text=value))
      as.numeric(value)
    }
  } else {
    obj$coerce_with <- function(., value) as.numeric(value)
  }
  
  if(!missing(attr))
    obj$attr <- merge(obj$attr, attr)
  
  if(missing(editor))
    obj$editor <- EntryEditor$proto()

  if(!missing(model)) 
    obj$set_model(model)

  obj$init_model()

  return(obj)
}

#' Item for integers
#' @export
#' @param value Default value for the model
#' @param name Required name for object. Names should be unique within a group of items
#' @param label Optional label, default value is the name
#' @param help Optional help string
#' @param tooltip Optional tooltip to display
#' @param eval_first Should value be run through eval/parse before coercion.
#' @param attr A list of attributes to pass to widget on construction. Eg. attr=list(size=c(100,200))
#' @param model Optional model. Useful if one wishes to use same model for multiple views
#' @param editor Specification of editor (a view) to override default
#' @param ... Passed to parent proto object during call to proto
#' @return A \code{proto} object. Call \code{obj$show_help()} to view its methods and properties.
#' @seealso numericItem
integerItem <- function(value=integer(0),
                        name,            # for lookup with item group
                        label=name,      # for display
                        help="",
                        tooltip="",
                        eval_first=FALSE, # call eval(parse(text=.)) before coercion
                        attr,
                        model,
                        editor,
                        ...) {

  if(missing(name)) {
    name <- "Anonymous"
    label <- name
  }
  l <- list(value=value, name=name, label=label, help=help, tooltip=tooltip)
  theArgs <- list(...)
  for(i in names(theArgs))
    l[[i]] <- theArgs[[i]]
  
  obj <- do.call("numericItem", l)
  obj$add_class("IntegerItem")
  obj$validate <- function(., rawvalue) {
    value <- .$next_method("validate")(., rawvalue)
    if(is.integer(value))
      return(value)
    else
      stop("Not an integer")
  }
  
  ## difference is in coercion function
  if(eval_first) 
    obj$coerce_with <- function(., value) {
      value <- eval(parse(text=value))
      as.integer(value)
    }
  else
    obj$coerce_with <- function(., value) as.integer(value)

  if(!missing(attr))
    obj$attr <- merge(obj$attr, attr)

  if(!missing(model)) 
    obj$set_model(model)

  if(missing(editor))
    obj$editor <- EntryEditor$proto()

  obj$init_model()
  return(obj)
}


#' Item for typing in R expressions. These are evaluated in .GlobalEnv prior to return
#'
#' @param value Default value for the model
#' @param name Required name for object. Names should be unique within a group of items
#' @param label Optional label, default value is the name
#' @param help Optional help string
#' @param tooltip Optional tooltip to display
#' @param attr A list of attributes to pass to widget on construction. Eg. attr=list(size=c(100,200))
#' @param model Optional model. Useful if one wishes to use same model for multiple views
#' @param editor Specification of editor (a view) to override default
#' @param ... Passed to parent proto object during call to proto
#' @return A \code{proto} object. Call \code{obj$show_help()} to view its methods and properties.
#' @seealso \code{\link{numericItem}}, \code{\link{integerItem}}, \code{\link{stringItem}}, as these are
#'    similar, but also validate the final results
expressionItem <- function(value="",
    name,            # for lookup with item group
    label=name,      # for display
    help="",
    tooltip="",
    attr,
    model,
    editor,
    ...) {


  

  if(missing(name))
    name <- "Anonymous"


  obj <- Item$proto(name=name, label=label, help=help,
                    tooltip=tooltip, value=value,
                    add_handler_name=paste("addHandler", c("Changed","Blur"), sep=""),
                    ...
                    )
  obj$add_class("ExpressionItem")
  
  obj$coerce_with <-  function(., value) {
    value <- eval(parse(text=value), envir=.GlobalEnv)
    as.character(value)
  }

  obj$validate <- NULL

  
  if(!missing(attr))
    obj$attr <- merge(obj$attr, attr)

  if(missing(editor))
    obj$editor <- EntryEditor$proto()
  
  if(!missing(model))
    obj$set_model(model)

  return(obj)
}



#' Item for Boolean values
#' @export
#' @param value Default value for the model
#' @param name Required name for object. Names should be unique within a group of items
#' @param label Optional label, default value is the name
#' @param help Optional help string
#' @param tooltip Optional tooltip to display
#' @param attr A list of attributes to pass to widget on construction. Eg. attr=list(size=c(100,200))
#' @param model Optional model. Useful if one wishes to use same model for multiple views
#' @param editor Specification of editor (a view) to override default
#' @param ... Passed to parent proto object during call to proto
#' @return A \code{proto} object. Call \code{obj$show_help()} to view its methods and properties.
trueFalseItem <- function(value=TRUE,
                          name,
                          label=name,
                          help="",
                          tooltip="",
                          attr,
                          model,
                          editor,
                          ...) {

 if(missing(name))
   name <- "Anonymous"
 
 
 obj <- Item$proto(name=name, label=label, help=help,
                   tooltip=tooltip,
                   value=value,
                   add_handler_name="addHandlerChanged",
                   ...)
 obj$add_class("BooleanItem")
 obj$validate <- function(., rawvalue) {
   value <- .$next_method("validate")(., rawvalue)
   if(is.logical(value))
     return(value)
   else
     stop("Not logical")
 }
 if(!missing(attr))
   obj$attr <- merge(obj$attr, attr)
 
 if(!missing(model)) 
   obj$set_model(model)
 
 if(missing(editor))
   obj$editor <- BooleanEditor$proto()
 
 obj$init_model()
 return(obj)
 
}




#' Item for choosing one of several values
#' @export
#' @param value Default value for the model. This is specified by index (or indices if \code{multiple=TRUE})
#' @param values Values that one can select from. May be a data frame or vector. The editor depends on the size of
#'               this: small will be radio button or checkboxes; medium is combobox; large is table
#' @param by_index  Do we get and set the main value by index or by value?
#' @param multiple Multiple selection is allowed? If so, then only checkboxes or table widget is used
#' @param editable Can user edit value to be selected? If so, the combobox is used
#' @param name Required name for object. Names should be unique within a group of items
#' @param label Optional label, default value is the name
#' @param help Optional help string
#' @param tooltip Optional tooltip to display
#' @param attr A list of attributes to pass to widget on construction. Eg. attr=list(size=c(100,200)).
#'      The \code{expand=TRUE} value is a default for this.
#' @param model Optional model. Useful if one wishes to use same model for multiple views
#' @param editor Specification of editor (a view) to override default
#' @param editor_type overide choice of editor by size of values. Must set attr to match desired.
#' @param ... Passed to parent proto object during call to proto
#' @return A \code{proto} object. Call \code{obj$show_help()} to view its methods and properties.
choiceItem <- function(value="",
                       values="",       # items to choose from
                       by_index=FALSE,  # set/get by index or value
                       multiple=FALSE,  # select more than one?
                       editable=FALSE,  # if TRUE, use editable combobox
                       name,            # for lookup with item group
                       label=name,      # for display
                       help="",
                       tooltip="",
                       attr,
                       model,
                       editor,
                       editor_type=c("","gradio","gcombobox","gtable","gedit"),
                       ...) {

 
  
  
  if(missing(name))
    name <- "Anonymous"
  
  obj <- Item$proto(name=name, label=label, help=help,
                    tooltip=tooltip,
                    value=value, values=values,
                    properties=c("value","values"),
                    add_handler_name="addHandlerChanged",
                    by_index=by_index,
                    ...)

  obj$add_class("ChoiceItem")
  obj$update_ui=function(.) {}          # no enabled, visible
  ## put this in the controller -- it doesn't belong in view (editor)
  obj$init_controller=function(.) {
    .$controller <- Controller$proto(model=.$model, view=.$editor,
                                     adapters=list(
                                       value=list(
                                         property=.$name,
                                         view_widget_name=.$editor$view_widget_name,
                                         add_handler_name=.$add_handler_name)
                                       ),
                                     property_values_value_changed=function(., value, old_value) {
                                       view <- .$get_view()
                                       view$set_values_in_view(value)
                                     }
                                     )
    .$controller$init()
  }

  ## fix attributes
  obj$attr <- merge(obj$attr, list(expand=TRUE, multiple=multiple))
  if(!missing(attr))
    obj$attr <- merge(obj$attr, attr)

  ## fix validate -- we pass in index
  obj$coerce_with <- function(., value) {
    if(.$by_index)
      value <- as.integer(value)
    value
  }
  obj$validate <- function(., rawvalue) {
    if(.$by_index)
      return(rawvalue)

    value <- .$next_method("validate")(., rawvalue)
    if(.$by_index) {
      if(is.integer(value))
        return(value)
      else
        stop("Not logical")
    } else {
      return(value)
    }
  }
  
  if(missing(editor))
    obj$editor <- ObjectWithValuesEditor$proto()
  
  ## automatically choose type of widget based on length of values and multiple/editable
  ## warning ugly dispatch ahead
  ed <- obj$get_editor()

  editor_type <- match.arg(editor_type)
  if(editor_type != "") {
    ed$editor_name <- editor_type
  } else if(editable) {
    ed$editor_name <- get_with_default(editor_type,"gcombobox")
    ed$attr <- c(ed$attr, list(editable=TRUE))
  } else if(!is.null(dim(values)) && length(dim(values)) == 2) {
    ed$editor_name <- "gtable"
    if(multiple)
      obj$attr <- merge(obj$attr, list(multiple=TRUE))
  } else {
    n <- length(values)
    if(multiple) {
      if(n > 0 && n <= 5) {
        ed$editor_name <- "gcheckboxgroup"
      } else {
        ed$editor_name <- "gtable"
        ed$attr <- merge(ed$attr, list(multiple=TRUE), overwrite=TRUE)
      }
    } else {
      if(n > 0 && n <= 3) {
        ed$editor_name <- "gradio"
      } else if (n > 0 && n <= 10) {
        ed$editor_name <- "gcombobox"
      } else {
        ed$editor_name <- "gtable"
      }
    }                  
  }

  
  ## specify how get/set is done
  obj$editor$by_index <- by_index

  if(!missing(model)) 
    obj$set_model(model)

  obj$init_model()
  
  return(obj)
}


#' A range selection item
#'
#' Editor is a slider (with spinbutton when \code{by} value is an integer.
#' @param value Default data frame for the model
#' @param from Starting value of range
#' @param to Ending value of range
#' @param by Step size to step through range. If an integer, a spinbutton is also displaye
#' @param name Required name for object. Names should be unique within a group of items
#' @param label Optional label, default value is the name
#' @param help Optional help string
#' @param tooltip Optional tooltip to display
#' @param attr A list of attributes to pass to widget on construction. Eg. attr=list(size=c(100,200))
#' @param model Optional model. Useful if one wishes to use same model for multiple views
#' @param editor Specification of editor (a view) to override default
#' @param ... Passed to Item trait
#' @return A \code{proto} object. Call \code{obj$show_help()} to view its methods and properties.
#' @export
rangeItem <- function(value="",
                      from=0,
                      to=10,
                      by=1,
                      name,            # for lookup with item group
                      label=name,      # for display
                      help="",
                      tooltip="",
                      attr,
                      model,
                      editor,
                      ...) {
  
  if(missing(name))
    name <- "Anonymous"
 
  obj <- Item$proto(value=value,
                    from=from, to=to, by=by,
                    name=name, label=label,
                    help=help, tooltip=tooltip,
                    ...)

  
  obj$add_class("RangeItem")
  obj$add_handler_name <- "addHandlerChanged"

  if(!missing(attr))
    obj$attr <- merge(obj$attr, attr)
  
  if(!missing(model))
    obj$set_model(model)
  
  if(missing(editor)) 
    obj$editor <- RangeEditor$proto()

  ## Need to add an observer so that spinner gets updated
  obj$init_controller=function(.) {
    if(as.integer(by) == by) {
      .$controller2 <-  Adapter$proto(model=.,#$model,
                                      view=.$editor,
                                      property=.$name,
                                      view_widget_name="spinner",
                                      validate = .$validate,
                                      add_handler_name=.$add_handler_name)

      .$controller2$init()
    }
    ## now call the standard one
    .$next_method("init_controller")(.)
  }
  
  obj$init_model()
  return(obj)

}


#' A calendar date selection item
#'
#' @param value Default data frame for the model
#' @param format\_string String to specify format of date to return. See \code{\link{strftime}} for codes.
#'        default value is \code{"\%Y-\%m-\%d"}
#' @param name Required name for object. Names should be unique within a group of items
#' @param label Optional label, default value is the name
#' @param help Optional help string
#' @param tooltip Optional tooltip to display
#' @param attr A list of attributes to pass to widget on construction. Eg. \code{attr=list(size=c(100,200))}
#' @param model Optional model. Useful if one wishes to use same model for multiple views
#' @param editor Specification of editor (a view) to override default
#' @param ... Passed to parent proto object during call to proto
#' @export
#' @return A \code{proto} object. Call \code{obj$show_help()} to view its methods and properties.
## @examples
##  d <- dateItem(name="d") ## basic usage, no initial date.
##  ## specify intial date and reformt -- can't start in that format, it is unamibuous
##  d <- dateItem("2000-12-25", name="d", format_string="%m-%d-%Y")
dateItem <- function(value="",
                     format_string,  # for format
                     name,            # for lookup with item group
                     label=name,      # for display
                     help="",
                     tooltip="",
                     attr,
                     model,
                     editor,
                     ...) {


  if(missing(name))
    name <- "Anonymous"

  if(missing(format_string))
    format_string="%Y-%m-%d"

  obj <- Item$proto(name=name, label=label, help=help,
                    tooltip=tooltip, value=value,
                    add_handler_name="addHandlerChanged",
                    format_string=format_string,
                    ...
                    )
  obj$add_class("DateItem")

  obj$coerce_with <- function(., value) strftime(value, format=.$format_string)
  
  if(!missing(attr))
    obj$attr <- merge(obj$attr, attr)
  
  if(missing(editor))
    obj$editor <- DateEditor$proto()

  if(!missing(model)) 
    obj$set_model(model)

  obj$init_model()

  return(obj)
}

#' A file selection item
#'
#' 
#' @param value Default data frame for the model
#' @param name Required name for object. Names should be unique within a group of items
#' @param label Optional label, default value is the name
#' @param help Optional help string
#' @param tooltip Optional tooltip to display
#' @param attr A list of attributes to pass to widget on construction. Eg. attr=list(size=c(100,200))
#' @param model Optional model. Useful if one wishes to use same model for multiple views
#' @param editor Specification of editor (a view) to override default
#' @param ... Passed to parent proto object during call to proto
#' @export
#' @return A \code{proto} object. Call \code{obj$show_help()} to view its methods and properties.
fileItem <- function(value="",
                     name,            # for lookup with item group
                     label=name,      # for display
                     help="",
                     tooltip="",
                     attr,
                     model,
                     editor,
                     ...) {
  
  if(missing(name))
    name <- "Anonymous"

  obj <- Item$proto(name=name, label=label, help=help,
                    tooltip=tooltip, value=value,
                    attr=list(quote=FALSE),
                    add_handler_name=paste("addHandler",c("Changed","Blur"), sep=""),
                    ...
                    )
  obj$add_class("FileBrowseItem")
  
  if(!missing(attr))
    obj$attr <- merge(obj$attr, attr)
  
  if(missing(editor))
    obj$editor <- FileBrowseEditor$proto()

  if(!missing(model)) 
    obj$set_model(model)

  obj$init_model()
  return(obj)
}

#' Button item to initiate an action
#'
#' @param value Default value for the model
#' @param action function to call when clicked. function(., h, ...) {} (like gWidgets with extra .)
#' @param name Required name for object. Names should be unique within a group of items
#' @param label Optional label, default value is the name
#' @param help Optional help string
#' @param tooltip Optional tooltip to display
#' @param attr A list of attributes to pass to widget on construction. Eg. attr=list(size=c(100,200))
#' @param model Optional model. Useful if one wishes to use same model for multiple views
#' @param editor Specification of editor (a view) to override default
#' @param ... Passed to parent proto object during call to proto
#' @return A \code{proto} object. Call \code{obj$show_help()} to view its methods and properties.
#' @export
buttonItem <- function(value="button label",
                       action=NULL,          # function(., h, ...) {}??
                       name,            # for lookup with item group
                       label=name,      # for display
                       help="",
                       tooltip="",
                       attr,
                       model,
                       editor,
                       ...) {
  if(missing(name))
    name <- "Anonymous"


  obj <- Item$proto(name=name, label=label, help=help,
                    tooltip=tooltip,
                    value=value, action=action,
                    properties=c("action"),
                    add_handler_name="addHandlerClicked",
                    ...
                    )

  obj$add_class("ButtonItem")
  
  ## put this in the controller -- it doesn't belong in view (editor)
  obj$init_controller=function(.) {
    ed <- .$get_editor()
    widget <- ed$get_widget_by_name(ed$view_widget_name)
    addHandlerClicked(widget, function(h,...) {
      . <- h$action
      f <- .$get_action()   # use item$set_action(function(.,h,...) {}) to change
      if(!is.null(f))
        f(.,h,...)
    }, action=.)
  }

  if(!missing(attr))
    obj$attr <- merge(obj$attr, attr)
  
  if(!missing(model)) 
    obj$set_model(model)

  if(missing(editor))
    obj$editor <- ButtonEditor$proto()
  
  obj$init_model()
  return(obj)
  
}

#' Simple label item
#'
#' @param value Default value for the label
#' @param name Required name for object. Names should be unique within a group of items
#' @param label Same as \code{value}. Here for consistency, but needn't be used
#' @param help Optional help string
#' @param tooltip Optional tooltip to display
#' @param attr A list of attributes to pass to widget on construction. Eg. attr=list(size=c(100,200))
#' @param model Optional model. Useful if one wishes to use same model for multiple views
#' @param editor Specification of editor (a view) to override default
#' @param ... Passed to parent proto object during call to proto
#' @return A proto object. Call \code{obj$show_help()} for its methods and properties
#' @export
labelItem <-  function(value="label",
                       name,            # for lookup with item group
                       label,
                       help="",
                       tooltip="",
                       attr,
                       model,
                       editor,
                       ...) {
  if(missing(name))
    name <- "Anonymous"

  if(!missing(label))
    value <- label
  
  obj <- Item$proto(name=name, label="", help=help,
                    value=value,                     
                    show_label=FALSE,
                    tooltip=tooltip,
                    add_handler_name="",
                    ...)

  obj$add_class("LabelItem")
  

  if(!missing(attr))
    obj$attr <- merge(obj$attr, attr)
  
  if(!missing(model)) 
    obj$set_model(model)

  if(missing(editor))
    obj$editor <- LabelEditor$proto()

  obj$init_model()
  return(obj)
  
}



#' Visual separator item
#'
#' @param name name of widget
#' @param attr passed to widget constructor. Use list(horizontal=FALSE) to get vertical
#' @param ... ignored
#' @return A \code{proto} object. Call \code{obj$show_help()} to view its methods and properties.
#' @export
separatorItem <- function(name=".seperator",
                          attr=list(horizontal=TRUE),
                          ...) {
  obj <- Item$proto(name=name,
                    add_handler_name="",
                    editor=SeparatorEditor$proto(),
                    show_label=FALSE,
                    init=function(.,...) {}
                    )
  obj$add_class("SeparatorItem")

  return(obj)
}

#' Item to select a data frame from the available data frames in .GlobalEnv
#'
#' This widget checks every second or so for new data frames and updates selection accordingly
#' @export
#' @param value Default data frame for the model, defaults to .GlobalEnv
#' @param name Required name for object. Names should be unique within a group of items
#' @param label Optional label, default value is the name
#' @param help Optional help string
#' @param tooltip Optional tooltip to display
#' @param attr A list of attributes to pass to widget on construction. Eg. attr=list(size=c(100,200)) This widget uses a gtable instance and specifying the size is suggested
#' @param model Optional model. Useful if one wishes to use same model for multiple views
#' @param editor Specification of editor (a view) to override default
#' @param ... Passed to parent proto object during call to proto
#' @return A \code{proto} object. Call \code{obj$show_help()} to view its methods and properties.
dataframeItem <- function(value="",     # name of data frame
                          name,            # for lookup with item group
                          label=name,      # for display
                          help="",
                          tooltip="",
                          attr,
                          model,
                          editor,
                          ...) {


  findAvailableDataFrames <- function(., envir=.GlobalEnv) {
    tmp <- ls(envir=envir)
    ind <- sapply(tmp, function(i) {
      obj <- get(i, envir=envir)
      is.data.frame(obj)
    })
    c(".GlobalEnv",tmp[ind])
  }
  
  if(missing(name))
    name <- "Anonymous"

  values <- findAvailableDataFrames()
  if(!value %in% values)
    value <- values[1]
  
  obj <- choiceItem(value=value, values=findAvailableDataFrames(),
                    name=name, label=label,
                    help=help, tooltip=tooltip,
                    by_index=FALSE,
                    ...
                    )

  obj$add_class("DataFrameItem")
    
  ## modify some properties, methods
  obj$add_handler_name="addHandlerClicked"
  obj$.find_data_frames=findAvailableDataFrames
  ## add idle timer to update data frames
  obj$on_realized=function(.) {
    ed <- .$get_editor()
    widget <- ed$get_widget_by_name(ed$view_widget_name)
    addHandlerIdle(widget, handler = function(h,...) {
      . <- h$action$item
      old_dfs <- .$get_values()
      new_dfs <- .$.find_data_frames()
      if(digest(old_dfs) != digest(new_dfs))
        .$set_values(new_dfs)
    },
                   action=list(item=.))
  }
  
  if(!missing(attr))
    obj$attr <- merge(obj$attr, attr)

  
  if(!missing(model))
    obj$set_model(model)
  

  if(missing(editor))
    obj$editor <- ObjectWithValuesEditor$proto()

  editor <- obj$get_editor()
  editor$editor_name <- "gtable"
  editor$by_index <- FALSE
  
  obj$init_model()
  return(obj)
  
}


#' Item to select a variable (or variables) from a selected data frame
#'
#' This widget checks every second or so for new data frames and updates selection accordingly
#' @export
#' @param value Default data frame for the model, defaults to .GlobalEnv
#' @param multiple Allow multiple selection?
#' @param dataframeItem A required dataframeItem instance. This need not be in same display, or even displayed
#' @param name Required name for object. Names should be unique within a group of items
#' @param label Optional label, default value is the name
#' @param help Optional help string
#' @param tooltip Optional tooltip to display
#' @param attr A list of attributes to pass to widget on construction. Eg. attr=list(size=c(100,200)) This widget uses a gtable instance and specifying the size is suggested
#' @param model Optional model. Useful if one wishes to use same model for multiple views
#' @param editor Specification of editor (a view) to override default
#' @param ... Passed to parent proto object during call to proto
#' @return A \code{proto} object. Call \code{obj$show_help()} to view its methods and properties.
variableSelectorItem <- function(value=NA,
                                 multiple=FALSE,
                                 dataframeItem, # necessary
                                 name,            # for lookup with item group
                                 label=name,      # for display
                                 help="",
                                 tooltip="",
                                 attr,
                                 model,
                                 editor,
                                 ...
                                 ) {

  list_possible_variables <- function(., dfname) {
    if(dfname == ".GlobalEnv" || dfname=="") {
      ## list all for now
      values <- ls(envir=.GlobalEnv)
    } else {
      values <- names(get(dfname, envir=.GlobalEnv))
    }
    return(values)
  }

  if(missing(name))
    name <- "Anonymous"

  dfi <- dataframeItem$instance()
  df <- dfi$getattr(dfi$name)
  obj <- choiceItem(value=value, values=list_possible_variables(NA,df),
                    name=name, label=label,
                    help=help, tooltip=tooltip,
                    by_index=FALSE,
                    multiple=as.logical(multiple),
                    ...)
  
  obj$add_class("VariableSelectorItem")
  obj$add_handler_name <- "addHandlerClicked"
  obj$.list_possible_variables <- list_possible_variables
  obj$validate = function(...) {}
  ## we need to add an observer to the dataframeItem model so we update values in obj
  ## when data frame has changed
  cont <- Controller$proto(.item = obj)
  assign(sprintf("property_%s_value_changed",dfi$name), function(., value, old_value) {
    i <- .$.item
    ## can cause error on initialization ????
    values <- try(i$.list_possible_variables(value), silent=TRUE)
    if(!inherits(values, "try-error"))
      i$set_values(values)
    invisible()
  }, envir=cont)
  
  dataframeItem$add_observer(cont)


  if(!missing(attr))
    obj$attr <- merge(obj$attr, attr)
  
  if(!missing(model))
    obj$set_model(model)

  if(missing(editor))
    obj$editor <- ObjectWithValuesEditor$proto(editor_name="gtable")

  obj$init_model()
  return(obj)
}

## graph item,  dataEditItem?, menu, toolbar for dialog

## These are kind of not needed -- we can use gWidgets gaction here.



#' A graphic device item. (Only with RGtk2 and cairoDevice!)
#'
#' This device will become the current one if the mouse clicks in the window, or even just crosses over the window.
#' This isn't perfect, but should be easy enough to get used to.
#' This only works with gWidgetsRGtk2
#' @export
#' @param value ingored
#' @param name Required name for object. Names should be unique within a group of items
#' @param label Optional label, default value is the name
#' @param help Optional help string
#' @param tooltip Optional tooltip to display
#' @param attr A list of attributes to pass to widget on construction. Eg. attr=list(size=c(100,200)).
#' @param model ignored
#' @param editor ignored
#' @param ... Passed to parent proto object during call to proto
#' @return A \code{proto} object. Call \code{obj$show_help()} to view its methods and properties.
graphicDeviceItem <- function(value="", # ignored
                              name,            # for lookup with item group
                              label=name,      # for display
                              help="",
                              tooltip="",
                              attr = list(size=c(480,480)),
                              model,   # ignored
                              editor,   # ignored
                              ...
                              ) {

  if(missing(name))
    name <- "Anonymous"
  
  obj <- Item$proto(name=name,
                    editor=GraphEditor$proto(),
                    add_handler_name="",
                    show_label=FALSE,
                    init=function(.,...) {},
                    ...
                    )
  obj$add_class("GraphItem")
  
  return(obj)
}


#' Display an image specified by its filename.
#'
#' @param value ingored
#' @param name Required name for object. Names should be unique within a group of items
#' @param label ignored
#' @param help Optional help string
#' @param tooltip Optional tooltip to display
#' @param attr A list of attributes to pass to widget on construction. Eg. attr=list(size=c(100,200)).
#' @param model ignored
#' @param editor ignored
#' @param ... Passed to parent proto object during call to proto
#' @return A \code{proto} object. Call \code{obj$show_help()} to view its methods and properties.
#' @export
imageItem <- function(value="", 
                      name,            # for lookup with item group
                      label=name,      # ignored
                      help="",
                      tooltip="",
                      attr = list(),
                      model,  
                      editor,
                      ...
                      ) {
  
  if(missing(name))
    name <- "Anonymous"
  
  obj <- Item$proto(value=value,
                    name=name,
                    help=help, tooltip=tooltip,
                    show_label=FALSE,
                    add_handler_name="", # "" for no view->model
                    ...
                    )
  obj$add_class("ImageItem")

  if(!missing(attr))
    obj$attr <- merge(obj$attr, attr)

  
  if(!missing(model))
    obj$set_model(model)
  

  if(missing(editor))
    obj$editor <- ImageEditor$proto()


  obj$init_model()
  return(obj)
}

##' List editor -- list <-> tree, must have special structure to list?


#' An item to display a table of data (given as a matrix or data.frame)
#'
#' @param value Default value of data frame
#' @param name Required name for object. Names should be unique within a group of items
#' @param label ignored
#' @param help Optional help string
#' @param tooltip Optional tooltip to display
#' @param attr A list of attributes to pass to widget on construction. Eg. attr=list(size=c(100,200)).
#' @param model ignored
#' @param editor ignored
#' @param ... Passed to parent proto object during call to proto
#' @return A \code{proto} object. Call \code{obj$show_help()} to view its methods and properties.
#' @examples
#' ## to change data frame
#' i <- tableItem(mtcars, name="a")
#' i$set_a(mtcars[1:3, 1:3])
#' @export
tableItem <- function(value=data.frame(V1="",V2=""),
                      name,            # for lookup with item group
                      label=name,      # ignored
                      help="",
                      tooltip="",
                      attr = list(),
                      model,  
                      editor,
                      ...
                      ) {
  
  if(missing(name))
    name <- "Anonymous"
  
  obj <- Item$proto(value=value,
                    name=name,
                    help=help, tooltip=tooltip,
                    show_label=FALSE,
                    add_handler_name="", # "" for no view->model
                    ...
                    )
  obj$add_class("TableItem")
  obj$coerce_with <- function(.,value, ...) value
  obj$validate <- NULL
  
  if(!missing(attr))
    obj$attr <- merge(obj$attr, attr)
  
  
  if(!missing(model))
    obj$set_model(model)

  if(missing(editor))
    obj$editor <- TableEditor$proto()
  
  obj$init_model()
  return(obj)
}



### XXX -- XXX -- WRITE ME -- XXX -- XXX
#' A formula Item
#' @export
#' @param value Default data frame for the model
#' @param dataframeItem A required dataframeItem instance. This need not be in same display, or even displayed
#' @param name Required name for object. Names should be unique within a group of items
#' @param label Optional label, default value is the name
#' @param help Optional help string
#' @param tooltip Optional tooltip to display
#' @param attr A list of attributes to pass to widget on construction. Eg. attr=list(size=c(100,200)) This widget uses a gtable instance and specifying the size is suggested
#' @param model Optional model. Useful if one wishes to use same model for multiple views
#' @param editor Specification of editor (a view) to override default
#' @param ... Passed to parent proto object during call to proto
#' @return A \code{proto} object. Call \code{obj$show_help()} to view its methods and properties.
formulaItem <- function(value="",
                        dataframeItem, # necessary
                        name,            # for lookup with item group
                        label=name,      # for display
                        help="",
                        tooltip="",
                        attr,
                        model,
                        editor,
                        ...
                        ) {
  cat("XXX This needs to be written, but first write gwidgets gformula function XXX")
  labelItem(value="no formulaItem yet", name=name)
}


  ## XXX
#' data frame editor item. Needs writing
#'
#' Write me
#' @param ... to be replaced with actual arguments
#' @export
#' @return A \code{proto} object. Call \code{obj$show_help()} to view its methods and properties.
dfEditItem <- function(...) {
  cat("XXX This needs to be written XXX")
  labelItem(value="no data frame editing item yet (gdf)", name="Anonymous")
}
#line 1 "/private/tmp/RtmpA4c7nI/R.INSTALL10d63af1/traitr/R/traitR-package.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/

#' An interface for GUI creation using gWidgets
#'
#' This package provides an alternate interface for creating graphical user interfaces. The design was
#' inspired by the Traits UI module for python developed by enthought.com.
#' The implementation uses the MVC design pattern in the background, although the user need not be
#' aware of this. For basic use, the user creates a bunch of items (the model), specifies how these will be
#' layed out in a simple manner (the view), specifies actions to happen (the controller) and then creates a dialog.
#' The package uses the \pkg{proto} package so at some level, the R user must use that OO syntax.
#' @name traitR-package
#' @docType package
roxygen()
