Merge branch 'master' of https://github.com/lindsaycarr/gsplot

Lindsay Carr · Lindsay Carr · commit 378cf6a974e6 · 2015-12-14T11:02:06.000-06:00
diff --git a/DESCRIPTION b/DESCRIPTION
@@ -1,8 +1,8 @@
 Package: gsplot
 Type: Package
 Title: Geological Survey Plotting
-Version: 0.4.4
-Date: 2015-09-16
+Version: 0.5.1
+Date: 2015-12-13
 Authors@R: c( person("Jordan", "Read", role = "aut",
     email = "jread@usgs.gov"),
     person("Laura", "DeCicco", role = c("aut","cre"),
diff --git a/R/access-gsplot.R b/R/access-gsplot.R
@@ -82,7 +82,7 @@ logged.gsplot <- function(object, side=NULL){
 #' @return data frame with one row per view. Each view has an x side, y side, the log command, and the view index.
 #' @export
 view_info <- function(object){
-  j <- which(names(object) %in% 'view')
+  j <- which_views(object)
   viewSides <- sapply(j, function(x) object[[x]][['window']][['side']])
   viewLogs <- sapply(j, function(x) object[[x]][['window']][['log']])
   viewInfo <- data.frame(t(rbind(viewSides, viewLogs, j)), stringsAsFactors = FALSE)
diff --git a/R/calc_views.R b/R/calc_views.R
@@ -24,12 +24,18 @@ calc_views <- function(gsplot){
   return(views)
 }
 
+which_views <- function(gsplot){
+  grep('view.', names(gsplot))
+}
+
 views <- function(gsplot){
-  gsplot[names(gsplot) %in% 'view']
+  gsplot[which_views(gsplot)]
 }
 
 non_views <- function(gsplot){
-  gsplot[!names(gsplot) %in% 'view']
+  non.views <- gsplot
+  non.views[which_views(non.views)] <- NULL
+  return(non.views)
 }
 
 group_views <- function(gsplot){
@@ -50,7 +56,9 @@ group_views <- function(gsplot){
       views[[v.i]] <- append(views[[v.i]], to_draw)
       views[[v.i]][['window']][['par']] <- append_replace(views[[v.i]][['window']][['par']], tail.gs[['gs.config']][['par']])
     } else{
-      views <- append(views, list(view = append(to_draw, list(window=list(side=add_sides,par=tail.gs[['gs.config']][['par']])))))
+      new.view <- list(append(to_draw, list(window=list(side=add_sides,par=tail.gs[['gs.config']][['par']])))) %>% 
+        setNames(sprintf('view.%s.%s',add_sides[1],add_sides[2]))
+      views <- append(views, new.view)
     }
   } else {
     # // if field isn't associated with a side(s), it is moved up to top level (e.g., legend)
@@ -88,7 +96,7 @@ which_reals <- function(values, na.value){
   
 }
 set_view_window <- function(views, param, na.value=NA, remove=TRUE, ignore=NULL){
-  view_i <- which(names(views) %in% "view")
+  view_i <- which_views(views)
   for (i in view_i){
     values <- lapply(views[[i]][!names(views[[i]]) %in% ignore], function(x) strip_pts(x, param))
     val.i <- which_reals(values, na.value)
@@ -117,16 +125,18 @@ set_view_lab <- function(views){
 
 
 set_view_lim <- function(views){
+  y.include <- c('y','y1','y0','ytop','ybottom')
+  x.include <- c('x','x1','x0','xleft','xright')
   views <- set_view_window(views, param = 'xlim', na.value=NA, ignore='window', remove=FALSE)
   views <- set_view_window(views, param = 'ylim', na.value=NA, ignore='window', remove=FALSE)
   
-  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')))
+  data <- list(y=summarize_args(views, y.include, ignore=c('window','gs.config')), 
+               x=summarize_args(views, x.include, 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')))
+  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 <- unlist(c_unname(views), recursive = FALSE)
   definedSides <- unique(unname(unlist(definedSides[grep("side", names(definedSides))])))
 
   for(param in c('y','x')){
@@ -192,15 +202,15 @@ views_with_side <- function(views, side){
   if(length(side) > 1)
     stop('side can only be length of 1')
   with.side = lapply(views, function(x) any(x[['window']][['side']] %in% side))
-  view.match = unname(unlist(with.side[names(with.side) == 'view']))
+  view.match = unname(unlist(with.side[which_views(views)]))
   if (is.null(view.match) || !any(view.match))
     return(NULL)
   else
     return(which(view.match))
 }
 
 get_view_side <- function(views, view_i, param){
-  i = which(names(views) %in% 'view')[view_i]
+  i = which_views(views)[view_i]
   sides <- views[[i]][['window']][['side']]
   if (param=='y')
     return(sides[which(sides %% 2 == 0)])
@@ -210,9 +220,9 @@ get_view_side <- function(views, view_i, param){
     stop('view side undefined for ',param)
 }
 
-summarize_args <- function(views, param, na.value,ignore='gs.config'){
+summarize_args <- function(views, param, na.value, ignore='gs.config'){
   
-  view_i <- which(names(views) %in% "view")
+  view_i <- which_views(views)
   values <- list()
   for (i in view_i){
     x <- views[[i]][!names(views[[i]]) %in% ignore]
@@ -254,7 +264,7 @@ set_window <- function(list){
   listOut <- list
   pars <- list[['par']]
   
-  for(j in which(names(list) == "view")){
+  for(j in which_views(list)){
     
     window <- list[[j]][['window']]
     plots <- list[[j]]
diff --git a/R/callouts.R b/R/callouts.R
@@ -38,10 +38,11 @@ callouts.gsplot <- function(object, ..., side=c(1,2)){
 #' @param labels text to be added to callout
 #' @param length relative (percentage of window width and height) distance for callout
 #' @param angle callout line angle
+#' @param cex passed to text for font size formatting
 #' 
 #' @rdname callouts
 #' @export
-callouts.default <- function(x, y=NULL, labels=NA, length=0.1, angle='auto', cex=1, ...){
+callouts.default <- function(x, y=NULL, labels=NA, length=0.1, angle='auto', cex=par()$cex, ...){
   
   if (is.null(y)) {
     warning("y=NULL not currently supported in callouts.default")
diff --git a/R/mtext.R b/R/mtext.R
@@ -43,7 +43,6 @@ mtext.gsplot <- function(object, ..., legend.name=NULL, side = 3){
     setNames(fun.name)
   
   object <- append(object, to.gsplot)
-  object <- 
     
   return(gsplot(object))
   
diff --git a/R/points.R b/R/points.R
@@ -27,8 +27,8 @@
 #' 
 #' gs <- gsplot() %>% 
 #'          points(x=1:5, y=1:5, xlim=c(0,10), ylim=c(0,10), 
-#'                callouts=list(labels=c(rep(NA, 4), "oh")), 
-#'                error_bar=list(y.high=1))
+#'                callouts(labels=c(rep(NA, 4), "oh")), 
+#'                error_bar(y.high=1))
 #' gs
 #' 
 #' gs2 <- gsplot() %>%
diff --git a/README_files/figure-markdown_github/unnamed-chunk-2-1.png b/README_files/figure-markdown_github/unnamed-chunk-2-1.png
diff --git a/README_files/figure-markdown_github/unnamed-chunk-3-1.png b/README_files/figure-markdown_github/unnamed-chunk-3-1.png
diff --git a/README_files/figure-markdown_github/unnamed-chunk-4-1.png b/README_files/figure-markdown_github/unnamed-chunk-4-1.png
diff --git a/man/callouts.Rd b/man/callouts.Rd
diff --git a/man/points.Rd b/man/points.Rd
diff --git a/tests/testthat/test-mtext.R b/tests/testthat/test-mtext.R
@@ -11,15 +11,7 @@ test_that("mtext on correct side", {
   expect_false(gs[[i]][['window']][['axes']])
 })
 
-test_that("mtext las defined for both mtext calls", {
-  gs <- gsplot() %>% 
-    points(1,2) %>% 
-    mtext(text=c(1,2,3,4), at=c(0.7,0.9,1.1,1.3), cex=0.5, las=2, side=1, line=1) %>% 
-    mtext(text=c("yr1", "yr2"), at=c(0.8, 1.2), las=1, side=1, line=3)
-  
-  expect_true(names(gs[['view']][[2]]) %in% "las")
-  expect_true(names(gs[['view']][[3]]) %in% "las")
-})
+
 
 test_that("multiple mtext are on correct sides", {
   gs <- gsplot() %>% 
diff --git a/tests/testthat/test-rect.R b/tests/testthat/test-rect.R
@@ -0,0 +1,20 @@
+context("test rect")
+
+test_that("testing rectangle arguments for limits", {
+  
+  gs <- gsplot()  %>% 
+    rect(1,5,2,7, col="pink", border=NA) %>%
+    points(1:5, 1:5, pch=5, col="blue") %>%
+    lines(3:7, 1:5, col="darkgreen") %>%
+    error_bar(x=4, y=4, y.high=0.5, y.low=0.7, epsilon=0.5) 
+
+  expect_equal(ylim(gs)$side.2, c(1,7))
+  
+  gs <- gsplot()  %>% 
+    rect(-1,5,2,7, col="pink", border=NA) %>%
+    points(1:5, 1:5, pch=5, col="blue") %>%
+    lines(3:7, 1:5, col="darkgreen") %>%
+    error_bar(x=4, y=4, y.high=0.5, y.low=0.7, epsilon=0.5) 
+  
+  expect_equal(xlim(gs)$side.1, c(-1,7))
+})
diff --git a/tests/testthat/tests-abline.R b/tests/testthat/tests-abline.R
@@ -46,7 +46,7 @@ test_that("arrows gsplot",{
   ## draw arrows from point to point :
   s <- seq(length(x)-1)  # one shorter than data
   gs = arrows(gs, x[s], y[s], x[s+1], y[s+1], col= 1:3)
-  expect_equal(gs$view$arrows$col, 1:3) 
+  expect_equal(gs$view.1.2$arrows$col, 1:3) 
 })
 
 test_that("grid",{
@@ -59,7 +59,7 @@ test_that("grid",{
          axis(side=3, labels=FALSE) %>%
          grid(side=c(1,2),col="green") %>%
          grid(side=c(3,4))
-  expect_equal(names(gs$view),c("points","grid","window"))
-  expect_equal(gs$view$grid$col,"green")
+  expect_equal(names(gs$view.1.2),c("points","grid","window"))
+  expect_equal(gs$view.1.2$grid$col,"green")
   
 })
diff --git a/tests/testthat/tests-axis.R b/tests/testthat/tests-axis.R
@@ -12,14 +12,14 @@ test_that("axis",{
 })
 
 test_that("axis gsplot",{
-  gs = points(gsplot(), c(-2,3), c(-1,5)) %>% 
+  gs = points(gsplot(mar=c(1,1,1,1)), c(-2,3), c(-1,5)) %>% 
     axis(3)
-  expect_equal(names(gs), c("view","par","axis"))
+  expect_equal(names(gs), c("view.1.2","par","axis"))
   
   gs <- gsplot() %>%
      lines(1:5, c(1,10,100,1000,10000), log="y", axes=FALSE) %>%
      axis(side=c(2,4), labels=FALSE, n.minor=4)
   
-  expect_false(gs$view$window$axes)
+  expect_false(gs$view.1.2$window$axes)
   
 })
diff --git a/tests/testthat/tests-error_bars.R b/tests/testthat/tests-error_bars.R
@@ -9,7 +9,7 @@ test_that("testing content of gsplot list for multiple error bars defined", {
   gs <- points(gs, c(0,3), c(2,4)) %>% 
     error_bar(c(0,3), c(2,4), y.high=c(2,2), x.low=c(NA,1))
   
-  expect_true(length(which(names(gs[['view']]) == "arrows"))==2)
+  expect_true(length(which(names(gs[['view.1.2']]) == "arrows"))==2)
   
 })
 
