Merge pull request #276 from lindsaycarr/master

xaxs='o' test; fixed pt.lwd/bg issue; cex is formal of callouts.default

Author: ldecicco-USGS

R/calc_views.R

@@ -123,8 +123,8 @@ set_view_lim <- function(views){
   data <- list(y=summarize_args(views,c('y','y1','y0'),ignore=c('window','gs.config')), 
                x=summarize_args(views,c('x','x1','x0'),ignore=c('window','gs.config')))
 
-  axs <- list(yaxs=summarize_args(views,c('yaxs'),ignore=c('window','gs.config')),
-              xaxs=summarize_args(views,c('xaxs'),ignore=c('window','gs.config')))
+  axs <- list(yaxs=summarize_args(views,c('yaxs'),ignore=c('gs.config')),
+              xaxs=summarize_args(views,c('xaxs'),ignore=c('gs.config')))
 
   definedSides <- unlist(c_unname(views),recursive = FALSE)
   definedSides <- unique(unname(unlist(definedSides[grep("side", names(definedSides))])))
@@ -158,16 +158,17 @@ set_view_lim <- function(views){
 
       usr.axs <- axs[[axs.name]][[n.i]]
 
-      if (!is.na(usr.axs) && usr.axs == 'o') {
+      if (any(!is.na(usr.axs)) && any(usr.axs == 'o')) {
         if (all(!is.na(usr.lim)))
           stop('no NA given to distinguish buffered limit')
 
         view.i <- which(!names(views[[n.i]]) %in% c('window', 'gs.config'))
         buffer <- 0.04*diff(views[[n.i]][['window']][[lim.name]])
         lim <- views[[n.i]][['window']][[lim.name]][[which(is.na(usr.lim))]]
         buffered.lim <- ifelse(which(is.na(usr.lim)) == 1, lim - buffer, lim + buffer)
+        views[[n.i]][[view.i]][[lim.name]][[which(is.na(usr.lim))]] <- buffered.lim
         views[[n.i]][['window']][[lim.name]][[which(is.na(usr.lim))]] <- buffered.lim
-        views[[n.i]][[view.i]][[axs.name]] <- NULL
+        views[[n.i]][['window']][['par']][[axs.name]] <- NULL
         views[['par']][[axs.name]] <- 'i'
       }
 

R/callouts.R

@@ -41,7 +41,7 @@ callouts.gsplot <- function(object, ..., side=c(1,2)){
 #' 
 #' @rdname callouts
 #' @export
-callouts.default <- function(x, y=NULL, labels=NA, length=0.1, angle='auto', ...){
+callouts.default <- function(x, y=NULL, labels=NA, length=0.1, angle='auto', cex=1, ...){
 
   if (is.null(y)) {
     warning("y=NULL not currently supported in callouts.default")
@@ -97,6 +97,6 @@ callouts.default <- function(x, y=NULL, labels=NA, length=0.1, angle='auto', ...
   pos[angle > 135 & angle <= 225] <- 2
 
   segments(x0=x, y0=y, x1=x1, y1=y1, ...)
-  text(x=x1, y=y1, labels=labels, pos=pos,...)
+  text(x=x1, y=y1, labels=labels, pos=pos, cex=cex, ...)
 
 }

R/set_args.R

@@ -85,7 +85,7 @@ set_legend_args <- function(object, fun.name, ..., legend.name) {
   if (fun.name == "points") {
     pt.names <- c("lwd","bg","cex")
     names(paramsAll) <- replace(names(paramsAll), which(names(paramsAll) %in% pt.names), 
-                                paste0("pt.", pt.names[which(pt.names %in% names(paramsAll))]))
+                                paste0("pt.", pt.names[na.omit(match(names(paramsAll), pt.names))]))
     fun.specific <- list(border=quote(par("bg")),
                          pch=1,
                          pt.bg=quote(par("bg")),

man/callouts.Rd

@@ -8,7 +8,7 @@
 callouts(object, ...)
 
 callouts.default(x, y = NULL, labels = NA, length = 0.1, angle = "auto",
-  ...)
+  cex = 1, ...)
 }
 \arguments{
 \item{object}{gsplot object}

tests/testthat/test-set_view_lim.R

@@ -0,0 +1,41 @@
+context("set_view_lim")
+
+test_that("gsplot xaxs = 'o' works", {
+  gs <- gsplot() %>%
+    points(1:4,1:4, xlim=c(NA,10), xaxs='o') %>%
+    lines(1:6,1:6)
+  
+  beforeBuffer <- c(1,10)
+  buffer <- diff(beforeBuffer)*0.04
+  afterBuffer <- c(beforeBuffer[1]-buffer, beforeBuffer[2])
+  
+  expect_equal(xlim(gs), afterBuffer)
+  expect_equal(par(gs)$xaxs, "i")
+})
+
+
+test_that("gsplot yaxs = 'o' works", {
+  gs <- gsplot() %>%
+    points(1:4,1:4, ylim=c(0,NA), yaxs='o') %>%
+    lines(1:6,1:6)
+  
+  beforeBuffer <- c(0,4)
+  buffer <- diff(beforeBuffer)*0.04
+  afterBuffer <- c(beforeBuffer[1], beforeBuffer[2]+buffer)
+  
+  expect_equal(ylim(gs), afterBuffer)
+  expect_equal(par(gs)$yaxs, "i")
+})
+
+test_that("gsplot yaxs = 'o' works in gsplot()", {
+  gs <- gsplot(ylim=c(0,NA), yaxs='o') %>%
+    points(1:4,1:4) %>%
+    lines(1:6,1:6)
+  
+  beforeBuffer <- c(0,6)
+  buffer <- diff(beforeBuffer)*0.04
+  afterBuffer <- c(beforeBuffer[1], beforeBuffer[2]+buffer)
+  
+  expect_equal(ylim(gs), afterBuffer)
+  expect_equal(par(gs)$yaxs, "i")
+})