Merge pull request #373 from jiwalker-usgs/master

Legend!

Author: wdwatkins

R/abline.R

@@ -21,7 +21,7 @@
 #' gsNew <- points(gs, y=1, x=2, col="blue", pch=18, legend.name="Points")
 #' gsNew <- lines(gsNew, c(3,4,3), c(2,4,6), legend.name="Lines")
 #' gsNew <- abline(gsNew, b=1, a=0, legend.name="1:1")
-#' gsNew <- legend(gsNew, "topleft",title="Awesome!")
+#' gsNew <- legend(gsNew, location="topleft",title="Awesome!")
 #' gsNew
 abline <- function(object, ...) {
   override("graphics", "abline", object, ...)

R/legend.R

@@ -61,9 +61,7 @@ legend <- function(object, ...){
 
 
 legend.gsplot <- function(object, ..., location="topright", legend_offset=0.3) {
-  
   object <- modify_legend(object, location = location, legend_offset = legend_offset, draw = TRUE, ...)
-
   return(object)
 }
 
@@ -76,78 +74,78 @@ legend.gsplot <- function(object, ..., location="topright", legend_offset=0.3) {
 
 draw_legend <- function(gsplot) {
 
+  default.args <- formals(graphics::legend)
 
-  draw <- gsplot[['legend']][['gs.config']][['draw']]
-  legend_args_exist <- FALSE
-  if (exists('legend', gsplot)){
-    legend_args_exist <- exists('legend.args', gsplot[['legend']])
-  }
-  if (is.null(draw) || !draw || !legend_args_exist){ return() }
+  if ("legend" %in% names(gsplot)){
 
-  oldXPD <- par()$xpd
-  oldBg <- par('bg')
-  
-  for(index in which(names(gsplot[['legend']]) %in% "gs.config")){
-    
-    par(xpd=TRUE)
+    # TODO rather than preserve individual pars we should par-scope this draw_legend call
+    # and par scope each run of the for loop
+    oldXPD <- par()$xpd
+    oldBg <- par('bg')
 
-    if("legend.args" %in% names(gsplot[['legend']])) {
-    
-      default.args <- formals(graphics::legend)
-      legendParamsALL <- gsplot[['legend']][['legend.args']]
+    for (legend.name in names(gsplot[['legend']])) {
 
-      overallLegendArgs <- appendLegendPositionConfiguration(gsplot[['legend']][['gs.config']])
-      legendParamsALL <- append(legendParamsALL, overallLegendArgs)
-      legendOrdered <- legendParamsALL[na.omit(match(names(default.args), names(legendParamsALL)))]
-
-      #for above/below, dynamically set the number of columns
-      location <- gsplot[['legend']][['gs.config']][['location']]
-      if(location == "below" || location == "above") {
-        itemsPerCol <- 3 #TODO load this from config
-        cols <- length(legendOrdered$legend) %/% 3;
-        if(length(legendOrdered$legend) %% 3 > 0) {
-          cols <- cols + 1
+      par(xpd=TRUE)
+      
+      legend <- gsplot[['legend']][[legend.name]]
+      if (legend$draw) {
+        legend <- appendLegendColumnInfo(legend)
+        legend <- appendLegendPositionConfiguration(legend)
+        # set required legend argument to NA if not exists
+        if (!"legend" %in% names(legend)) {
+         legend$legend <- NA
         }
-        legendOrdered$ncol <- ifelse(is.null(legendOrdered$ncol), cols, legendOrdered$ncol)
-      }
 
-      #set bg so that fill/border/etc args are correct, then evaluate any quoted list items
-      if(any(names(overallLegendArgs) %in% c("bg"))) {
-        par(bg=overallLegendArgs$bg)
+        #set bg so that fill/border/etc args are correct, then evaluate any quoted list items
+        if (any(names(legend) %in% c("bg"))) {
+          par(bg=legend$bg)
+        }
+        legend <- lapply(legend, function(x) {unname(sapply(x, function(x) {eval(x)}))})
+        # clean out arguments not allowed by legend 
+        legend <- legend[na.omit(match(names(default.args), names(legend)))]
+        legend(legend)
+        par(xpd=oldXPD)
+        par(bg=oldBg)
       }
-      legendComplete <- lapply(legendOrdered, function(x) {unname(sapply(x, function(x) {eval(x)}))})
-    
-    } else {
-      legendComplete <- appendLegendPositionConfiguration(gsplot[['legend']][[index]])
     }
-    
-    legend(legendComplete)
-    par(xpd=oldXPD)
-    par(bg=oldBg)
   }
-
 }
 
-appendLegendPositionConfiguration <- function(gsConfig) {
+appendLegendPositionConfiguration <- function(legend) {
   #TODO support explicit x/y coords
-  legend_offset <- gsConfig$legend_offset
-  location <- gsConfig$location
-  gsConfig$legend_offset <- NULL
-  gsConfig$location <- NULL
+  legend_offset <- legend$legend_offset
+  location <- legend$location
+  legend$legend_offset <- NULL
 
   if(location == "below") {
-    return(append(gsConfig, list(x = "bottom", y = NULL, inset=c(0, -legend_offset), bty="n")))
+    return(append(legend, list(x = "bottom", y = NULL, inset=c(0, -legend_offset), bty="n")))
   } else if(location == "above") {
-    return(append(gsConfig, list(x = "top", y = NULL, inset=c(0, -legend_offset), bty="n")))
+    return(append(legend, list(x = "top", y = NULL, inset=c(0, -legend_offset), bty="n")))
   } else if(location == "toright") {
-    return(append(gsConfig, list(x = "right", y = NULL, inset=c(-legend_offset, 0), bty="n")))
+    return(append(legend, list(x = "right", y = NULL, inset=c(-legend_offset, 0), bty="n")))
   } else if(location == "toleft") {
-    return(append(gsConfig, list(x = "left", y = NULL, inset=c(-legend_offset, 0), bty="n")))
-  } else if("x" %in% names(gsConfig)){
-    return(gsConfig)
+    return(append(legend, list(x = "left", y = NULL, inset=c(-legend_offset, 0), bty="n")))
+  } else if("x" %in% names(legend)){
+    return(legend)
   } else {
-    return(append(gsConfig, list(x = location)))
+    return(append(legend, list(x = location)))
+  }
+}
+
+#' Based on location set legend columns
+#' 
+#' @param legend to set columns on
+appendLegendColumnInfo <- function(legend) {
+  location <- legend[['location']]
+  if (location == "below" || location == "above") {
+    itemsPerCol <- 3 # TODO load this from config
+    cols <- length(legend$legend) %/% itemsPerCol;
+    if(length(legend$legend) %% itemsPerCol > 0) {
+      cols <- cols + 1
+    }
+    legend$ncol <- ifelse(is.null(legend$ncol), cols, legend$ncol)
   }
+  return(legend)
 }
 
 

R/modify_legend.R

@@ -23,27 +23,22 @@ add_to_legend <- function(object, fun.name, legend.name, call.args, option.args)
     if(is.null(legend.name)) {
       return(object)
     }
-    
-    
-    # add legend$gs.config if it does not already exist
-    legend.exists <- "legend" %in% names(object)
-    legend.args.exist <- "legend.args" %in% names(object[['legend']])
-    if(!legend.exists){object <- modify_legend(object)}
-    
-    # add/add to legend$legend.args
+    if(!exists("legend", object)) {object$legend <- list()}
+    if(!exists("legend.auto", object$legend)) {object$legend$legend.auto <- create_empty_legend()}
+
+    # add/add to legend$legend.auto
     if(length(legend.name) > 1){
       call.args.df <- as.data.frame(call.args, stringsAsFactors = FALSE)
 
       for(p in seq(nrow(call.args.df))) {
-        if(p > 1){ legend.args.exist <- TRUE } #legend args will exist after the first loop
         call.args.list <- as.list(call.args.df[p,])
         fun.legend.args <- get_legend_args(fun.name, call.args.list, legend.name[p], option.args)
-        object[['legend']][['legend.args']] <- combine_legend_args(object, fun.legend.args, legend.args.exist)
+        object[['legend']][['legend.auto']] <- combine_legend_args(object, fun.legend.args)
       }
 
     } else {
       fun.legend.args <- get_legend_args(fun.name, call.args, legend.name, option.args)
-      object[['legend']][['legend.args']] <- combine_legend_args(object, fun.legend.args, legend.args.exist)
+      object[['legend']][['legend.auto']] <- combine_legend_args(object, fun.legend.args)
     }
 
   return(object)
@@ -85,7 +80,7 @@ get_legend_args <- function(fun.name, call.args, legend.name, option.args){
     call.args <- set_type_params(call.args, type.name, params.needed)
     if(type.name %in% c('p', 'lchsS')) {fun.name <- switch(type.name, p="points", lchsS="lines")}
   }
-  
+  fun.specific <- list()
   if (fun.name == "points") {
     pt.names <- c("lwd","bg","cex")
     names(call.args) <- replace(names(call.args), which(names(call.args) %in% pt.names), 
@@ -145,46 +140,61 @@ set_type_params <- function(list, type.name, params){
 #' @param legend.args.exist
 #' @param .dots lazy_dots
 #' @keywords internal
-combine_legend_args <- function(object, new.legend.args, legend.args.exist, ...){
+combine_legend_args <- function(object, new.legend.args, ...){
 
-  # look for existing list of legend args in the object
-  if(!legend.args.exist){
-    default.args <- formals(graphics::legend)
-    overall.legend <- c("x", "y", "bty", "bg", "box.lty", "box.lwd", "box.col", "cex",
-                        "xjust", "yjust", "x.intersp", "y.intersp", "adj", "text.width", 
-                        "merge", "trace", "plot", "ncol", "horiz", "title", "inset", 
-                        "xpd", "title.col", "title.adj", "seg.len")  
-    not.overall <- default.args[which(!names(default.args) %in% overall.legend)]
-    legend.args <- vector("list", length(not.overall))
-    names(legend.args) <- names(not.overall)
-    # // set up config legend stuff
-  } else {
-    legend.args <- object[['legend']][['legend.args']]
-  }
+  legend.args <- object[['legend']][['legend.auto']]
 
-  orderedParams <- new.legend.args[match(names(legend.args), names(new.legend.args))]    
+  orderedParams <- new.legend.args[match(names(legend.args), names(new.legend.args))]
   for (j in seq_along(legend.args)) {
     legend.args[[j]] <- c(legend.args[[j]], orderedParams[[j]])
   }
 
   return(legend.args)
 }
 
+#' Set up an empty legend
+#'
+create_empty_legend <- function() {
+  default.args <- formals(graphics::legend)
+  overall.legend <- c("x", "y", "bty", "bg", "box.lty", "box.lwd", "box.col", "cex",
+                      "xjust", "yjust", "x.intersp", "y.intersp", "adj", "text.width", 
+                      "merge", "trace", "plot", "ncol", "horiz", "title", "inset", 
+                      "xpd", "title.col", "title.adj", "seg.len")  
+  not.overall <- default.args[which(!names(default.args) %in% overall.legend)]
+  legend <- vector("list", length(not.overall))
+  names(legend) <- names(not.overall)
+  
+  # add draw = FALSE as default
+  legend$draw <- FALSE
+  
+  return(legend)
+}
+
 #' add legend configs
 #' 
 #' @param object
 #' @keywords internal
 modify_legend <- function(object, location="topright", legend_offset=0.3, draw=FALSE, ...){
   # // this should be shared between add_to_legend and legend
   # // check if legend exists, if not add it (someone could call legend before any legend.names)
-  gsConfig <- list(location = location, legend_offset = legend_offset, draw = draw, ...)
-  
+  legend.config <- list(location = location, legend_offset = legend_offset, draw = draw, ...)
+
   arguments <- list(...)
-  if("x" %in% names(arguments)){
-    gsConfig$location <- gsConfig$x
-    gsConfig$x <- NULL
-  }
+  # auto is used when "legend" arg comes from "legend.name" in gsplot calls
+  legend.index <- ifelse("legend" %in% names(legend.config),length(grep("legend.\\d+", names(object$legend))) + 1, "auto")
 
-  object[['legend']][['gs.config']] <- gsConfig
+  if ("x" %in% names(arguments)){
+    legend.config$location <- legend.config$x
+    legend.config$x <- NULL
+  }
+  if (legend.index == 'auto') {
+    # Merge new legend config into existing auto legend if it exists
+    auto.legend <- object$legend$legend.auto
+    # if draw is true, stay true
+    legend.config$draw <- legend.config$draw || is.null(auto.legend) || auto.legend$draw
+    auto.legend[names(legend.config)] <- legend.config
+    legend.config <- auto.legend
+  }
+  object[['legend']][[paste0("legend.", legend.index)]] <- legend.config
   return(object)
 }