Merge pull request #305 from lindsaycarr/master

edit formals call for error_bar + handling multiple legend.names

Author: Lindsay Carr

R/callouts.R

@@ -49,11 +49,12 @@ callouts.default <- function(x, y=NULL, labels=NA, length=0.1, angle='auto', cex
     return()
   }
 
-  stopifnot(angle=='auto' | (angle >= 0 & angle <= 360))
+  stopifnot(all(angle=='auto' | is.na(angle) | (angle >= 0 & angle <= 360)))
 
   x <- x[!is.na(labels)]
   y <- y[!is.na(labels)]
   labels <- labels[!is.na(labels)]
+  if(length(angle) > 1){angle[!is.na(labels)]}
 
   # // to do: possibly support angle and length as vectors equal in length to x 
   x.usr <- par("usr")[c(1,2)]
@@ -66,30 +67,58 @@ callouts.default <- function(x, y=NULL, labels=NA, length=0.1, angle='auto', cex
   xrange <- diff(x.usr)
   yrange <- diff(y.usr)
 
-  if (angle != "auto") {
-    x1 <- x + length * xrange * cos(2*pi*(angle/360))
-    y1 <- y + length * yrange * sin(2*pi*(angle/360))
+  calc_x1y1 <- function(x, y, angle, length, xrange, yrange, x.usr, y.usr){
+    
+    if (is.na(angle) | angle == "auto") {
+      auto.angle <- c(30, 330, 150, 210)
+      x1 <- sapply(auto.angle, function(a) {
+        x + length * xrange * cos(2*pi*(a/360))
+      })
+      y1 <- sapply(auto.angle, function(a) {
+        y + length * yrange * sin(2*pi*(a/360))
+      })
+      
+      good.y1 <- y1 >= y.usr[1] & y1 <= y.usr[2]
+      good.x1 <- x1 >= x.usr[1] & x1 <= x.usr[2]
+      good.pt <- good.y1 & good.x1
+      if (!is.null(dim(good.pt))){
+        angle <- auto.angle[apply(good.pt, 1, function(z){
+          ifelse(!any(z), 1, min(which(z)))
+        })]
+      } else { 
+        angle <- auto.angle[ifelse(!any(good.pt), 1, min(which(good.pt)))]
+      }
+      x1 <- x + length * xrange * cos(2*pi*(angle/360))
+      y1 <- y + length * yrange * sin(2*pi*(angle/360))
+    } else {
+      x1 <- x + length * xrange * cos(2*pi*(angle/360))
+      y1 <- y + length * yrange * sin(2*pi*(angle/360))
+    }
+    
+    return(list(x1 = x1, y1 = y1, angle = angle))
+  }
+  
+  if(length(angle) == 1){
+    x1_y1_angle <- calc_x1y1(x = x, y = y, angle = angle, 
+                       length, xrange, yrange, x.usr, y.usr)
+    x1 <- x1_y1_angle$x1
+    y1 <- x1_y1_angle$y1
+    angle <- x1_y1_angle$angle
   } else {
-    auto.angle <- c(30, 330, 150, 210)
-    x1 <- sapply(auto.angle, function(a) {
-      x + length * xrange * cos(2*pi*(a/360))
-    })
-    y1 <- sapply(auto.angle, function(a) {
-      y + length * yrange * sin(2*pi*(a/360))
-    })
+    stopifnot(length(x)%%length(angle) == 0) #stop if the defined angles aren't a multiple of the points
+    stopifnot(!is.character(angle)) #stop if it's not a numeric vector ('auto' is not used for the vector)
+  
+    num_pts <- length(x)
+    x1 <- vector(mode = "numeric", length = num_pts)
+    y1 <- vector(mode = "numeric", length = num_pts)
 
-    good.y1 <- y1 >= y.usr[1] & y1 <= y.usr[2]
-    good.x1 <- x1 >= x.usr[1] & x1 <= x.usr[2]
-    good.pt <- good.y1 & good.x1
-    if (!is.null(dim(good.pt))){
-      angle <- auto.angle[apply(good.pt, 1, function(z){
-        ifelse(!any(z), 1, min(which(z)))
-      })]
-    } else { 
-      angle <- auto.angle[ifelse(!any(good.pt), 1, min(which(good.pt)))]
+    for(r in seq(num_pts)){
+      x1_y1_angle <- calc_x1y1(x = x[r], y = y[r], angle = angle[r], 
+                         length, xrange, yrange, x.usr, y.usr)
+      x1[r] <- x1_y1_angle$x1
+      y1[r] <- x1_y1_angle$y1
+      angle[r] <- x1_y1_angle$angle
     }
-    x1 <- x + length * xrange * cos(2*pi*(angle/360))
-    y1 <- y + length * yrange * sin(2*pi*(angle/360))
   }
 
   pos <- rep(1, length(angle))  

R/config.R

@@ -69,7 +69,7 @@ config <- function(type, ..., persist=FALSE){
                          mtext=names(formals(graphics::mtext)),
                          grid=names(formals(graphics::grid)),
                          segments=names(formals(graphics::segments)),
-                         error_bar=c('x', 'y', '...', 'y.high', 'y.low', 'x.high', 'x.low', 'epsilon'),
+                         error_bar=names(formals(error_bar.default)),
                          bgCol=names(formals(bgCol.default)),
                          callouts=names(formals(callouts.default)),
                          rect=names(formals(graphics::rect)),

R/set_args.R

@@ -54,6 +54,23 @@ set_legend_args <- function(object, fun.name, ..., legend.name) {
 
   paramsAll <- set_args(fun.name, list(...))
 
+  if(length(legend.name) > 1){
+    paramsAll_df <- as.data.frame(paramsAll, stringsAsFactors = FALSE)
+
+    for(p in seq(nrow(paramsAll_df))) {
+      paramsAll_list <- as.list(paramsAll_df[p,])
+      object <- get_legend_args(object, fun.name, paramsAll_list, legend.name[p])
+    }
+    
+  } else {
+    object <- get_legend_args(object, fun.name, paramsAll, legend.name)
+  }
+  
+  return(object)
+}
+
+get_legend_args <- function(object, fun.name, paramsAll, legend.name){
+  
   fun.default <- list(legend=legend.name,
                       fill=quote(par("bg")),
                       col=par("col"),
@@ -68,7 +85,7 @@ set_legend_args <- function(object, fun.name, ..., legend.name) {
                       pt.lwd=NA,
                       text.col=par("col"),
                       text.font=1)
-
+  
   type <- paramsAll[['type']]
   if(!is.null(type)){
     type.name <- switch(type, p='p', b='bo', o='bo', l='lchsS', 
@@ -81,7 +98,7 @@ set_legend_args <- function(object, fun.name, ..., legend.name) {
     paramsAll <- set_type_params(paramsAll, type.name, params.needed)
     if(type.name %in% c('p', 'lchsS')) {fun.name <- switch(type.name, p="points", lchsS="lines")}
   }
- 
+  
   if (fun.name == "points") {
     pt.names <- c("lwd","bg","cex")
     names(paramsAll) <- replace(names(paramsAll), which(names(paramsAll) %in% pt.names), 
@@ -91,7 +108,7 @@ set_legend_args <- function(object, fun.name, ..., legend.name) {
                          pt.bg=quote(par("bg")),
                          pt.cex=par("cex"),
                          pt.lwd=par("lwd"))
-
+    
   } else if (fun.name %in% c("lines", "abline", "arrows", "segments")) {
     fun.specific <- list(border=quote(par("bg")),
                          lty=1,
@@ -108,13 +125,14 @@ set_legend_args <- function(object, fun.name, ..., legend.name) {
   fun.all <- replace(fun.default, match(names(fun.specific), names(fun.default)), fun.specific)
   add.args <- fun.all[!names(fun.all) %in% names(usr.args)]
   fun.legend.args <- append(usr.args, add.args)  
-
+  
   if(!is.character(fun.legend.args$lty)){
     lineTypes <- c("blank", "solid", "dashed", "dotted", "dotdash", "longdash", "twodash")
     fun.legend.args$lty <- lineTypes[fun.legend.args$lty + 1]
   }
 
   object[['legend']] <- append(object[['legend']], list(legend.args=fun.legend.args))
+  
   return(object)
 }