Merge pull request #255 from lindsaycarr/master

wip for legend refactor (part 2)

Author: ldecicco-USGS

R/abline.R

@@ -11,8 +11,9 @@
 #'  \item{\code{h}} {the y-value specifying a horizontal line}
 #'  \item{\code{v}} {the x-value specifying a vertical line}
 #'  \item{\code{col, lty, lwd}} {parameters describing the color, type, and width of the line, respectively}
-#'  \item{\code{legend.name}} {name that appears the legend, see \code{\link{legend}}}
-#'  } 
+#'  \item{\code{legend.name}} {name that appears in the legend, see \code{\link{legend}} for more legend parameters}
+#' } 
+#'  
 #'
 #' @export
 #' @examples
@@ -28,5 +29,7 @@ abline <- function(object, ...) {
 
 
 abline.gsplot <- function(object, ..., legend.name=NULL, side=c(1,2)){
-  set_window_args(object, fun.name='abline', ..., legend.name=legend.name, side=side, def.funs=c(graphics::abline, graphics::plot.xy))
+  fun.name <- 'abline'
+  object <- set_window_args(object, fun.name=fun.name, ..., legend.name=legend.name, side=side, def.funs=c(graphics::abline, graphics::plot.xy))
+  object <- set_legend_args(object, fun.name=fun.name, ..., legend.name=legend.name)
 }

R/arrows.R

@@ -10,6 +10,7 @@
 #'  \item{\code{x0, y0}} {position of the arrow tail}
 #'  \item{\code{x, y}} {position of the arrow head}
 #'  \item{\code{col, lty, lwd}} {parameters describing the color, type, and width of the arrow, respectively}
+#'  \item{\code{legend.name}} {name that appears in the legend, see \code{\link{legend}} for more legend parameters}
 #' }
 #' 
 #' @export
@@ -33,5 +34,7 @@ arrows <- function(object, ...) {
 
 
 arrows.gsplot <- function(object, ..., legend.name=NULL, side=c(1,2)){
-  set_window_args(object, fun.name='arrows', ..., legend.name=legend.name, side=side, def.funs=graphics::arrows)
+  fun.name <- 'arrows'
+  object <- set_window_args(object, fun.name=fun.name, ..., legend.name=legend.name, side=side, def.funs=graphics::arrows)
+  object <- set_legend_args(object, fun.name=fun.name, ..., legend.name=legend.name)
 }

R/curve.R

@@ -19,6 +19,7 @@
 #'  \item{\code{col}} {line color}
 #'  \item{\code{lty}} {line type}
 #'  \item{\code{lwd}} {line width}
+#'  \item{\code{legend.name}} {name that appears in the legend, see \code{\link{legend}} for more legend parameters}
 #'  }
 #'    
 #' @rdname curve
@@ -56,6 +57,9 @@ curve.gsplot <- function(object, expr, ..., legend.name=NULL, side=c(1,2)){
     setNames('lines')
 
   object <- gsplot(append(object, to.gsplot))
+  
+  fun.name <- 'lines'
+  object <- set_legend_args(object, fun.name=fun.name, ..., legend.name=legend.name)
 
   return(object)
 }

R/error_bars.R

@@ -4,6 +4,16 @@
 #' 
 #' @param object gsplot object
 #' @param \dots Further graphical parameters may also be supplied as arguments. See 'Details'.
+#' 
+#' @details Additional graphical parameter inputs:
+#' \itemize{
+#'  \item{\code{x, y}} {location of error_bar origin}
+#'  \item{\code{y.high, y.low}} {the y-value specifying the error above the point (high) and below the point (low)}
+#'  \item{\code{x.high, x.low}} {the x-value specifying the error above the point (high) and below the point (low)}
+#'  \item{\code{epsilon}} {width of the end of the error bar (in inches)}
+#'  \item{\code{col, lty, lwd}} {parameters describing the color, type, and width of the line, respectively}
+#'  \item{\code{legend.name}} {name that appears in the legend, see \code{\link{legend}} for more legend parameters}
+#' } 
 #'
 #' @rdname error_bar
 #' @export
@@ -49,7 +59,8 @@ error_bar.gsplot <- function(object, x, y, y.high=0, y.low=0, x.high=0, x.low=0,
     y.low.coord <- y.low.coord[errorIndex]
     y.error <- y[errorIndex]
     x.error <- x[errorIndex]
-    object <- arrows(object, x0=x.error, y0=y.error, x1=x.error, y1=y.low.coord, length=epsilon, angle=90, ...)
+    object <- arrows(object, x0=x.error, y0=y.error, x1=x.error, y1=y.low.coord, 
+                     length=epsilon, angle=90, ..., legend.name=legend.name)
   }
 
   if(!all(y.high == 0)){
@@ -58,7 +69,8 @@ error_bar.gsplot <- function(object, x, y, y.high=0, y.low=0, x.high=0, x.low=0,
     y.high.coord <- y.high.coord[errorIndex]
     y.error <- y[errorIndex]
     x.error <- x[errorIndex]
-    object <- arrows(object, x0=x.error, y0=y.error, x1=x.error, y1=y.high.coord, length=epsilon, angle=90, ...)
+    object <- arrows(object, x0=x.error, y0=y.error, x1=x.error, y1=y.high.coord, length=epsilon, 
+                     angle=90, ..., legend.name=check_legend_name(legend.name, y.low))
   }
 
   if(!all(x.low == 0)){
@@ -67,7 +79,8 @@ error_bar.gsplot <- function(object, x, y, y.high=0, y.low=0, x.high=0, x.low=0,
     x.low.coord <- x.low.coord[errorIndex]
     x.error <- x[errorIndex]
     y.error <- y[errorIndex]
-    object <- arrows(object, x0=x.error, y0=y.error, x1=x.low.coord, y1=y.error, length=epsilon, angle=90, ...)
+    object <- arrows(object, x0=x.error, y0=y.error, x1=x.low.coord, y1=y.error, length=epsilon, 
+                     angle=90, ..., legend.name=check_legend_name(legend.name, c(y.low, y.high)))
   }
 
   if(!all(x.high == 0)){
@@ -76,7 +89,8 @@ error_bar.gsplot <- function(object, x, y, y.high=0, y.low=0, x.high=0, x.low=0,
     x.high.coord <- x.high.coord[errorIndex]
     x.error <- x[errorIndex]
     y.error <- y[errorIndex]
-    object <- arrows(object, x0=x.error, y0=y.error, x1=x.high.coord, y1=y.error, length=epsilon, angle=90, ...)
+    object <- arrows(object, x0=x.error, y0=y.error, x1=x.high.coord, y1=y.error, length=epsilon, 
+                     angle=90, ..., legend.name=check_legend_name(legend.name, c(y.low, y.high, x.low)))
   }
 
   return(object)
@@ -87,4 +101,8 @@ error_bar.default <- function(x, y, y.high, y.low, x.high, x.low, epsilon=0.1, .
   return()
 }
 
-
+#don't use legend.name more than once
+check_legend_name <- function(legend.name, prev_calls){
+  if(!is.null(legend.name) && sum(prev_calls != 0)){ legend.name <- NULL }
+  return(legend.name)
+}

R/legend.R

@@ -4,13 +4,22 @@
 #' for legends. See \code{\link[graphics]{legend}} for more details.
 #'
 #' @param object gsplot object
-#' @param \dots Further graphical parameters may also be supplied as arguments. See 'Details'.
+#' @param \dots Overall legend parameters may also be supplied as arguments. See 'Details'.
 #' 
-#' @details Additional graphical parameter inputs:
-#' \itemize{
-#'  \item{\code{location}} {position of the legend, specified by x- and y-coordinates or by keyword ("bottomright", "bottom", "bottomleft", "left", "topleft", "top", "topright", "right", or "center")}
-#'  \item{\code{title}} {character string indicating the legend title}
-#' }
+#' @details 
+#' Overall legend inputs:
+#' 
+#' \code{x, y} coordinates OR use \code{location} which is a character string indicating the legend location: above, toright, toleft, or below (see \code{\link[graphics]{legend}} for more)
+#'
+#' \code{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}
+#'
+#' Parameter inputs for each graphics call (use inside of lines, points, curve, etc):
+#' 
+#' \code{legend.name, fill, col, border, lty, lwd, pch, angle, 
+#' density, pt.bg, pt.cex, pt.lwd, text.col, text.font}
 #'  
 #' @export
 #' @importFrom graphics par
@@ -51,44 +60,19 @@ legend <- function(object, ...){
 }
 
 
-legend.gsplot <- function(object, ..., location="topright", title="EXPLANATION", legend_offset=0.3) {
+legend.gsplot <- function(object, ..., location="topright", legend_offset=0.3) {
   arguments <- list(...)
 
-#   current_list <- config("legend")  # grabbing yaml defaults
-#   title <- current_list$title
-#   location <- current_list$location
+  gsConfig <- list(location = location, legend_offset = legend_offset, ...)
 
   if("x" %in% names(arguments)){
-    location <- arguments$x
+    gsConfig$location <- gsConfig$x
+    gsConfig$x <- NULL
   }
 
-  gsConfig <- list(location = location, legend_offset = legend_offset, title = title)
-  
-  arguments <- appendLegendPositionConfiguration(location, gsConfig, arguments)
-  arguments <- append(arguments, list(title=title))
-  
-  object <- append(object, list(legend = list(arguments = arguments, gs.config = gsConfig)))
-  
-  return(gsplot(object))
-}
-
-appendLegendPositionConfiguration <- function(location, gsConfig, arguments) {
-  #TODO support explicit x/y coords
-  legend_offset <- gsConfig$legend_offset
+  object[['legend']] <- append(object[['legend']], list(gs.config = gsConfig))
 
-  if(location == "below") {
-    return(append(arguments, list(x = "bottom", y = NULL, inset=c(0, -legend_offset), bty="n")))
-  } else if(location == "above") {
-    return(append(arguments, list(x = "top", y = NULL, inset=c(0, -legend_offset), bty="n")))
-  } else if(location == "toright") {
-    return(append(arguments, list(x = "right", y = NULL, inset=c(-legend_offset, 0), bty="n")))
-  } else if(location == "toleft") {
-    return(append(arguments, list(x = "left", y = NULL, inset=c(-legend_offset, 0), bty="n")))
-  } else if("x" %in% names(arguments)){
-    return(arguments)
-  } else {
-    return(append(arguments, list(x = location)))
-  }
+  return(object)
 }
 
 #' gsplot draw_legend
@@ -100,98 +84,90 @@ appendLegendPositionConfiguration <- function(location, gsConfig, arguments) {
 
 draw_legend <- function(gsplot) {
 
+  if (all(!names(gsplot[['legend']]) %in% "gs.config")){
+    return()
+  }
+  
   oldXPD <- par()$xpd
+  oldBg <- par('bg')
 
-  for(index in which(names(gsplot) %in% "legend")){
-    
-    legendParams <- gsplot[[index]][['arguments']]
+  for(index in which(names(gsplot[['legend']]) %in% "gs.config")){
 
     par(xpd=TRUE)
 
-    if(!("legend" %in% names(legendParams))){
+    if (any(names(gsplot[['legend']]) == "legend.args")) {
+    
+      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)]
+      legendParamsALL <- vector("list", length(not.overall))
+      names(legendParamsALL) <- names(not.overall)
 
-      if(!is.null(legendParams)) {
-        
-        smartLegend <- data.frame(row.names=names(formals(graphics::legend)), stringsAsFactors = FALSE)	
-        views = views(gsplot)
-        for (v in seq_len(length(views))){
-          for (i in seq_len(length(names(views[[v]])))) {
-            
-            plotElement <- names(views[[v]][i])
-            
-            params <- c('legend'=views[[v]][[i]][['legend.name']])
-            if (is.null(params)) {next}
-            
-            params <- append(params, views[[v]][[i]][which(names(views[[v]][[i]]) %in% names(formals(graphics::legend))[-c(1,2)])])
-            type <- views[[v]][[i]][['arguments$type']]
-            
-            if (plotElement == "points") {
-              names(params)[which(names(params) %in% "bg")] <- 'pt.bg'
-              names(params)[which(names(params) %in% "cex")] <- 'pt.cex'
-              names(params)[which(names(params) %in% "lwd")] <- 'pt.lwd'
-              if (!is.null(type) && type %in% c("l", "o", "b", "c", "s", "S", "h")) {
-                if (all(!names(params) %in% c("lty"))) {params <- append(params, list(lty=par("lty")))}
-              } 
-            }
-            if (plotElement == "lines" && !is.null(type) && type %in% c("p", "o", "b", "c")) {
-              if (all(!names(params) %in% c("pch"))) {params <- append(params, list(pch=par("pch")))}
-              params <- append(params, list(pt.lwd=params$lwd))
-              if (type == "p") {params <- params[-which(names(params) %in% c('lty', 'lwd'))]}
-              names(params)[which(names(params) %in% "bg")] <- 'pt.bg'
-              names(params)[which(names(params) %in% "cex")] <- 'pt.cex'
-            }  
-            if (plotElement %in% c("rect", "polygon")) {
-              names(params)[which(names(params) %in% "col")] <- 'fill'
-            }
-            
-            ifelse(length(smartLegend) == 0, smartLegendNames <- row.names(smartLegend), smartLegendNames <- names(smartLegend))
-            newsmartLegend <- match(smartLegendNames, names(params))
-            newsmartLegend[which(!is.na(newsmartLegend))] <- params[newsmartLegend[which(!is.na(newsmartLegend))]]
-            names(newsmartLegend) <- smartLegendNames
-            
-            smartLegend <- rbind(smartLegend, as.data.frame(newsmartLegend, stringsAsFactors = FALSE))
-            
-          }
-        }
-        
-        
-        
-        #take out any calls with all NA, and add overall legend calls from legendParams
-        indices <- unlist(sapply(seq_len(length(smartLegend)), function(x) {!all(is.na(smartLegend[[x]]))}))
-        legendParams <- append(legendParams, smartLegend[indices])
-        
-        # change any numeric linetypes to character
-        lineTypes <- c("blank", "solid", "dashed", "dotted", "dotdash", "longdash", "twodash")
-        if (any(legendParams$lty %in% c(as.character(1:6)))) { 
-          ltyIndices <- which(legendParams$lty %in% c(as.character(1:6)))
-          legendParams$lty[ltyIndices] <- sapply(as.numeric(legendParams$lty[ltyIndices]), function(x) lineTypes[x+1])
+      for(i in which(names(gsplot[['legend']]) %in% 'legend.args')) {
+        orderedParams <- gsplot[['legend']][[i]][match(names(legendParamsALL), names(gsplot[['legend']][[i]]))]    
+        for (j in seq_along(legendParamsALL)) {
+          legendParamsALL[[j]] <- c(legendParamsALL[[j]], orderedParams[[j]])
         }
-        
-        #if density is specified, default should be "NULL"
-        #if (!is.null(legendParams$density)) {legendParams$density[which(is.na(legendParams$density))] <- par("bg")}
-        
-        #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 <- NROW(smartLegend) %/% 3;
-          if(NROW(smartLegend) %% 3 > 0) {
-            cols <- cols + 1
-          }
-          legendParams <- append(legendParams, list(ncol=cols))
+      }
+      
+      #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(legendParamsALL$legend) %/% 3;
+        if(length(legendParamsALL$legend) %% 3 > 0) {
+          cols <- cols + 1
         }
-        
-        legend(legendParams) 
-        
+        legendParamsALL <- append(legendParamsALL, list(ncol=cols))
+      }
+      
+      overallLegendArgs <- appendLegendPositionConfiguration(gsplot[['legend']][['gs.config']])
+      legendParamsALL <- append(legendParamsALL, overallLegendArgs)
+      legendOrdered <- legendParamsALL[na.omit(match(names(default.args), names(legendParamsALL)))]
+  
+      #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)
       }
+      legendComplete <- lapply(legendOrdered, function(x) {unname(sapply(x, function(x) {eval(x)}))})
+    
     } else {
-      legend(legendParams)
+      legendComplete <- appendLegendPositionConfiguration(gsplot[['legend']][[index]])
     }
+    
+    legend(legendComplete)
+    par(xpd=oldXPD)
+    par(bg=oldBg)
   }
+
+}
+
+appendLegendPositionConfiguration <- function(gsConfig) {
+  #TODO support explicit x/y coords
+  legend_offset <- gsConfig$legend_offset
+  location <- gsConfig$location
+  gsConfig$legend_offset <- NULL
+  gsConfig$location <- NULL
 
-  par(xpd=oldXPD)
+  if(location == "below") {
+    return(append(gsConfig, 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")))
+  } else if(location == "toright") {
+    return(append(gsConfig, 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)
+  } else {
+    return(append(gsConfig, list(x = location)))
+  }
 }
 
+# What is this for?
 legend_adjusted_margins <- function(gsPlot) {
   defaults <- config("plot")
   defaultMargins <- c(3, 3, 3, 3) #default margins should come from config

R/lines.R

@@ -9,8 +9,8 @@
 #' \itemize{
 #'  \item{\code{x}} {vector of x-coordinates for points that make up the line}
 #'  \item{\code{y}} {vector of y-coordinates for points that make up the line}
-#'  \item{\code{legend.name}} {a character vector of length one to be used in the legend}
 #'  \item{\code{side}} {vector specifying the side(s) to use for axes (1,2,3,4 for sides, or 5,6,7,8 for outward offsets of those)}
+#'  \item{\code{legend.name}} {name that appears in the legend, see \code{\link{legend}} for more legend parameters}
 #'  \item{\code{error_bar}} {add error bars to the defined line, see \code{\link{error_bar}} 
 #'  for arguments, must add arguments as a list}
 #'  \item{\code{callouts}} {add callouts and text to the defined line, see \code{\link{callouts}} 
@@ -43,5 +43,8 @@ lines <- function(object, ...) {
 
 
 lines.gsplot <- function(object, ..., legend.name=NULL, side=c(1,2)){
-  set_window_args(object, fun.name='lines', ..., legend.name=legend.name, side=side, def.funs=c(graphics::plot.xy, graphics::lines.default))
-}
+  fun.name <- 'lines'
+  object <- set_window_args(object, fun.name=fun.name, ..., legend.name=legend.name, side=side, def.funs=c(graphics::plot.xy, graphics::lines.default))
+  object <- set_legend_args(object, fun.name=fun.name, ..., legend.name=legend.name)
+}
+