diff --git a/.Rbuildignore b/.Rbuildignore index 7d0bfb6..b61e9e4 100644 --- a/.Rbuildignore +++ b/.Rbuildignore @@ -16,8 +16,9 @@ ^devel$ ^cache/$ ^cache\$ +^vignettes/.*cache/ ^cran-comments.md$ ^.*.lnk$ ^LICENSE$ ^vignettes/lemon/.*$ -^.*\.Rdata$ \ No newline at end of file +^.*\.Rdata$ diff --git a/.gitignore b/.gitignore index 989dcbc..599f9e9 100644 --- a/.gitignore +++ b/.gitignore @@ -14,5 +14,10 @@ lib/ cache/ README/cache/ vignettes/*-cache/ +vignettes/facet-rep-label* +vignettes/geoms* +vignettes/gtable_show_lemonade* +vignettes/lemon_print* + Rgui.lnk diff --git a/DESCRIPTION b/DESCRIPTION index c175f92..341199b 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -3,8 +3,8 @@ Type: Package Title: Freshing Up your 'ggplot2' Plots URL: https://github.com/stefanedwards/lemon BugReports: https://github.com/stefanedwards/lemon/issues -Version: 0.4.2 -Date: 2018-10-30 +Version: 0.4.6 +Date: 2022-11-29 Authors@R: c( person('Stefan McKinnon', 'Edwards', email='sme@iysik.com', comment=c(ORCID='0000-0002-4628-8148'), @@ -23,7 +23,7 @@ Description: Functions for working with legends and axis lines of 'ggplot2', Depends: R (>= 3.1.0) Imports: - ggplot2 (>= 2.2.0), + ggplot2 (>= 3.4.0), plyr, grid, gridExtra, @@ -34,7 +34,7 @@ Imports: License: GPL-3 Encoding: UTF-8 LazyData: true -RoxygenNote: 6.1.0.9000 +RoxygenNote: 7.2.0 Collate: 'ggplot2.r' 'lemon-plot.r' @@ -58,5 +58,7 @@ Suggests: rmarkdown, stringr, dplyr, - testthat + testthat, + vdiffr, + diffviewer VignetteBuilder: knitr diff --git a/NAMESPACE b/NAMESPACE index a4bcb45..dd258ec 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -30,7 +30,6 @@ export(coord_capped_flip) export(coord_flex_cart) export(coord_flex_fixed) export(coord_flex_flip) -export(element_render) export(facet_rep_grid) export(facet_rep_wrap) export(g_legend) diff --git a/NEWS.md b/NEWS.md index d76ba75..eff7da1 100644 --- a/NEWS.md +++ b/NEWS.md @@ -6,6 +6,23 @@ * **TODO:** Extend `lemon_print` to work on cross-tabulation tables. +* **TODO:** Add curly brackets to the axis-brackets. + See package https://cran.r-project.org/web/packages/pBrackets/index.html for drawing braces. + +# lemon 0.4.6 + +* `element_render` is not exported, but available from ggplot2. + +* Fixed facet's, capped axes and brackets cf. ggplot2 v. 3.4.0. + +* Added `vdiffr` to test suite. + +# lemon 0.4.3 + +* Bugfix on tests. + +# lemon 0.4.2 + * Added `element_render` and `render_gpar` that helps render grobs with the ggplot2 themes applied. `render_gpar` simply returns a gpar object. diff --git a/R/axis-annotation.r b/R/axis-annotation.r index 0cc1e47..526775a 100644 --- a/R/axis-annotation.r +++ b/R/axis-annotation.r @@ -7,50 +7,50 @@ NULL - + # annotated_y_axis ## adds a label # annotated_y_axis_custom ## adds a random grob -#' Annotations in the axis -#' +#' Annotations on the axis +#' #' @section: Showing values: #' See \link[grDevices]{plotmath} for using mathematical expressions. #' The function uses a simple replacement strategy where the literal strings #' \code{.(y)} and \code{.(val)} are replaced by the value after round of to #' a number of digits, as given by argument \code{digits}. -#' +#' #' @rdname annotate_axis #' @param label Text to print #' @param y,x Position of the annotation. #' @param side left or right, or top or bottom side to print annotation -#' @param parsed Logical (default \code{FALSE}), -#' when \code{TRUE}, uses mathplot for outputting expressions. +#' @param parsed Logical (default \code{FALSE}), +#' when \code{TRUE}, uses mathplot for outputting expressions. #' See section "Showing values". #' @param print_label,print_value,print_both #' Logical; what to show on annotation. Label and/or value. #' \code{print_both} is shortcut for setting both \code{print_label} and -#' \code{print_value}. When both is TRUE, uses argument \code{sep} to +#' \code{print_value}. When both is TRUE, uses argument \code{sep} to #' separate the label and value. -#' @param ... Style settings for label and tick: -#' colour, hjust, vjust, size, fontface, family, rot. +#' @param ... Style settings for label and tick: +#' colour, hjust, vjust, size, fontface, family, rot. #' When \code{waiver()} (default), #' the relevant theme element is used. #' @example inst/examples/axis-annotation-ex.r -#' @export -annotate_y_axis <- function(label, y, - side = waiver(), +#' @export +annotate_y_axis <- function(label, y, + side = waiver(), print_label = TRUE, print_value = TRUE, print_both = TRUE, parsed = FALSE, ...) { - + if (!missing(print_both)) { print_label <- print_both print_value <- print_both } - - aa <- ggplot2::ggproto(NULL, + + aa <- ggplot2::ggproto(NULL, `_inherit`=if (parsed) AxisAnnotationBquote else AxisAnnotationText, aesthetic = 'y', side = side, @@ -59,32 +59,32 @@ annotate_y_axis <- function(label, y, y = y, value = y, print_label = print_label, - print_value = print_value, + print_value = print_value, ... ) ) - - + + prependClass(aa, 'axis_annotation') } #' @rdname annotate_axis #' @export -#' @inheritParams annotate_y_axis -annotate_x_axis <- function(label, x, - side = waiver(), +# @inheritParams annotate_y_axis +annotate_x_axis <- function(label, x, + side = waiver(), print_label = TRUE, print_value = TRUE, print_both = TRUE, parsed = FALSE, ...) { - + if (!missing(print_both)) { print_label <- print_both print_value <- print_both } - - - aa <- ggplot2::ggproto(NULL, + + + aa <- ggplot2::ggproto(NULL, `_inherit`=if (parsed) AxisAnnotationBquote else AxisAnnotationText, aesthetic = 'x', side = side, @@ -93,11 +93,11 @@ annotate_x_axis <- function(label, x, x = x, value = x, print_label = print_label, - print_value = print_value, + print_value = print_value, ... ) ) - + prependClass(aa, 'axis_annotation') } @@ -129,7 +129,7 @@ AxisAnnotation <- ggplot2::ggproto('AxisAnnotation', NULL, family = waiver(), rot = waiver() ), - + get_param = function(self, x) { mine <- self$params[x] mine <- mine[!sapply(mine, is.null)] @@ -140,13 +140,13 @@ AxisAnnotation <- ggplot2::ggproto('AxisAnnotation', NULL, return(mine[[1]]) return(mine) }, - + label = function(self) { if (!self$get_param('print_label')) return(round(self$get_param('value'), self$get_param('digits'))) if (!self$get_param('print_value')) return(self$get_param('label')) - paste0(self$get_param('label'), self$get_param('sep'), + paste0(self$get_param('label'), self$get_param('sep'), round(self$get_param('value'), self$get_param('digits'))) } ) @@ -157,7 +157,7 @@ AxisAnnotationBquote <- ggplot2::ggproto('AxisAnnotationBquote', AxisAnnotation, reducible = FALSE, params = list( print_value = FALSE - ), + ), label = function(self) { l <- self$get_param('label') l <- gsub("\\.\\(y\\)", round(self$get_param('value'), self$get_param('digits')), l) @@ -207,7 +207,7 @@ ggplot_add.axis_annotation <- function(object, plot, object_name) { #' @import scales AAList <- ggplot2::ggproto("AAList", NULL, annotations = NULL, - + # self.annotations holds a heriachical list of all annotations, i.e. # self.annotations$x = list(...) # self.annotations$y = list(...) @@ -218,58 +218,58 @@ AAList <- ggplot2::ggproto("AAList", NULL, } if (!inherits(new_annotation, 'AxisAnnotation')) stop('Not sure what to do with an object of type',class(new_annotation),'.') - + new_aes <- new_annotation$aesthetic[1] - if (is.null(new_aes)) + if (is.null(new_aes)) stop('Adding a axis annotation requires an annotation class with either "x" or "y" as aesthetic.') self$annotations <- c(self$annotations, list(new_annotation)) }, - - # See ggplot2/R/scales-.r for cloning. + + # See ggplot2/R/scales-.r for cloning. # Might be necessary to avoid updating a referenced object. clone = function(self) { ggproto(NULL, self, annotations=lapply(self$annotations, as.is)) }, - + n = function(self, aesthetic=NULL) { if (is.null(aesthetic)) return(length(self$annotations)) - + res <- table(vapply(self$annotations, function(a) a$aesthetic, character(1)))[aesthetic] names(res) <- aesthetic res[is.na(res)] <- 0 res }, - - + + draw = function(self, side, is.primary=FALSE, range, theme) { annotations <- self$get_annotations(side, is.primary) if (length(annotations) == 0) return(zeroGrob()) - + #aes <- switch(side, top='x', bottom='x', left='y', right='y', NA) - + label_render <- switch(side, top = "axis.text.x.top", bottom = "axis.text.x", left = "axis.text.y", right = "axis.text.y.right" ) tick_render <- switch(side, - top = 'axis.ticks.x.top', bottom = 'axis.ticks.x', + top = 'axis.ticks.x.top', bottom = 'axis.ticks.x', left = 'axis.ticks.y', right = 'axis.ticks.y.right' ) - + default <- ggplot2::calc_element(label_render, theme) tick = is.null(render_gpar(theme, tick_render)) - - # coerce to single data.frame where possible + + # coerce to single data.frame where possible are_reducible <- vapply(annotations, function(a) a$reducible %||% FALSE, logical(1)) if (sum(are_reducible) > 0) { labels <- lapply(annotations[are_reducible], function(a) { a$label() }) - + params <- lapply(annotations[are_reducible], function(a) { data.frame( values = a$get_param('value'), @@ -283,26 +283,26 @@ AAList <- ggplot2::ggproto("AAList", NULL, tick = a$get_param('tick') %|W|% tick, stringsAsFactors = FALSE ) - }) + }) params <- do.call(rbind, params) - + params$tickcolour <- ifelse(params$tick, params$colour, NA) - + axisgrob <- guide_axis(scales::rescale(params$values, from=range), labels, side, theme, default, params) } else { axisgrob <- guide_axis(NA, NA, side, theme, element_blank(), data.frame(tickcolour=NA)) } - + gt_index <- which(axisgrob$childrenOrder == 'axis') if (sum(!are_reducible) > 0) { - + order <- switch(side, top = list(names=c('label','tick'), t=c(1,2), l=c(1,1), r=c(1,1), b=c(1,2)), bottom = list(names=c('tick','label'), t=c(1,2), l=c(1,1), r=c(1,1), b=c(1,2)), right = list(names=c('tick','label'), t=c(1,1), l=c(1,2), r=c(1,2), b=c(1,1)), left = list(names=c('label','tick'), t=c(1,1), l=c(1,2), r=c(1,2), b=c(1,1)) ) - + for (i in which(!are_reducible)) { a <- annotations[[i]] gp_df <- data.frame( @@ -317,11 +317,11 @@ AAList <- ggplot2::ggproto("AAList", NULL, tick = a$get_param('tick') %|W|% tick, stringsAsFactors = FALSE ) - + next_grobs <- guide_axis( - scales::rescale(a$get_param('value'), from=range), + scales::rescale(a$get_param('value'), from=range), a$label(), side, theme, default, gp_df) - + axisgrob$children[[gt_index]] <- gtable_add_grob( x = axisgrob$children[[gt_index]], grobs = next_grobs$children[[gt_index]]$grobs[1:2], @@ -348,22 +348,7 @@ AAList <- ggplot2::ggproto("AAList", NULL, #' side. When FALSE (default), also get those that are waiver. get_annotations = function(self, side, is.primary=FALSE) { aes <- switch(side, top='x', bottom='x', left='y', right='y', NA) - - #if (self$n(aes) == 0) - # return() - - #if (is.primary) { - # # only those with side as set - # i <- which(vapply(self$annotations[[aes]], function(a) { - # !is.waive(a$side) && a$side == side - # }, logical(1))) - #} else { - # i <- which(vapply(self$annotations[[aes]], function(a) { - # is.waive(a$side) || a$side == side - # }, logical(1))) - #} - #self$annotations[[aes]][i] - + if (is.primary) { get <- vapply(self$annotations, function(a) { a$aesthetic == aes && (!is.waive(a$side) && a$side == side) @@ -372,8 +357,8 @@ AAList <- ggplot2::ggproto("AAList", NULL, get <- vapply(self$annotations, function(a) { a$aesthetic == aes && (is.waive(a$side) || a$side == side) }, logical(1)) - } - + } + self$annotations[get] } diff --git a/R/brackets.R b/R/brackets.R index 1053d5a..da5eb2a 100644 --- a/R/brackets.R +++ b/R/brackets.R @@ -15,7 +15,7 @@ NULL #' #' It does not re-calculate tick marks, but lets \code{scale_x_*} and \code{scale_y_*} #' calculate and draw ticks and labels, and then modifies the ticks with brackets. -#' +#' #' Both \code{length} and \code{tick.length} accepts a numeric scalar instead of #' a \code{\link[grid]{unit}} object that is interpreted as an \code{"npc"} unit. #' @@ -52,29 +52,30 @@ brackets_horizontal <- function(direction = c('up','down'), if (!grid::is.unit(length)) length <- unit(as.numeric(length), 'npc') - + if (!is.waive(tick.length) && !grid::is.unit(tick.length)) tick.length <- unit(as.numeric(tick.length), 'npc') - + direction=match.arg(direction) # Returns a function - fn <- function(scale_details, axis, scale, position, theme) { - agrob <- render_axis(scale_details, axis, "x", position, theme) + fn <- function(guides, position, theme) { + guide <- guide_for_position(guides, position) + agrob <- guide_gengrob(guide, theme) if (agrob$name == 'NULL') return(agrob) ind <- names(agrob$children) == 'axis' ind.notline <- which(ind) - ind.ticks <- which(grepl('ticks', sapply(agrob$children[[ind.notline]]$grobs, `[[`, i = 'name'))) - ind.text <- which(grepl('text', sapply(agrob$children[[ind.notline]]$grobs, `[[`, i = 'name'))) + ind.ticks <- which(grepl('polyline', sapply(agrob$children[[ind.notline]]$grobs, `[[`, i = 'name'))) + ind.text <- which(grepl('title', sapply(agrob$children[[ind.notline]]$grobs, `[[`, i = 'name'))) ticksgrob <- agrob$children[[ind.notline]]$grobs[[ind.ticks]] - + # If theme(axis.ticks[.x/.y] = element_blank()), then ticksgrob is a # zeroGrob and we cannot change the ticks (polylineGrob), as $gp is NULL. if (!is.zero(ticksgrob) && !is.null(ticksgrob$gp)) { gp <- do.call(grid::gpar, ticksgrob$gp) nticks <- length(ticksgrob$id.lengths) - + x <- rep(ticksgrob$x, each = 2) + rep(unit.c(length * -1, length * -1, length, length ), times = nticks) tick.length <- tick.length %|W|% theme$axis.ticks.length @@ -84,13 +85,13 @@ brackets_horizontal <- function(direction = c('up','down'), id.lengths <- rep(4, times = nticks) brackets <- polylineGrob(x = x, y = y, id.lengths = id.lengths, gp = gp) labels <- agrob$children[[ind.notline]]$grobs[[ind.text]] - + } else { labels <- agrob$children[[ind.notline]]$grobs[[ind.text]] tick.length <- unit(0, 'npc') brackets <- zeroGrob() } - + gt <- switch(position, top = gtable::gtable_col('axis', @@ -128,35 +129,36 @@ brackets_horisontal <- brackets_horizontal #' @export #' @rdname brackets -#' @inheritParams brackets_horizontal +# @inheritParams brackets_horizontal brackets_vertical <- function(direction = c('left','right'), length = unit(0.05, 'npc'), tick.length = waiver()) { - + if (!grid::is.unit(length)) length <- unit(as.numeric(length), 'npc') - + if (!is.waive(tick.length) && !grid::is.unit(tick.length)) tick.length <- unit(as.numeric(tick.length), 'npc') - + direction=match.arg(direction) - fn <- function(scale_details, axis, scale, position, theme) { - agrob <- render_axis(scale_details, axis, "y", position, theme) + fn <- function(guides, position, theme) { + guide <- guide_for_position(guides, position) + agrob <- guide_gengrob(guide, theme) if (agrob$name == 'NULL') return(agrob) ind <- names(agrob$children) == 'axis' ind.notline <- which(ind) - ind.ticks <- which(grepl('ticks', sapply(agrob$children[[ind.notline]]$grobs, `[[`, i = 'name'))) - ind.text <- which(grepl('text', sapply(agrob$children[[ind.notline]]$grobs, `[[`, i = 'name'))) + ind.ticks <- which(grepl('polyline', sapply(agrob$children[[ind.notline]]$grobs, `[[`, i = 'name'))) + ind.text <- which(grepl('title', sapply(agrob$children[[ind.notline]]$grobs, `[[`, i = 'name'))) ticksgrob <- agrob$children[[ind.notline]]$grobs[[ind.ticks]] - + # If theme(axis.ticks[.x/.y] = element_blank()), then ticksgrob is a # zeroGrob and we cannot change the ticks (polylineGrob), as $gp is NULL. if (!is.zero(ticksgrob) && !is.null(ticksgrob$gp)) { gp <- do.call(grid::gpar, ticksgrob$gp) nticks <- length(ticksgrob$id.lengths) - + y <- rep(ticksgrob$y, each = 2) + rep(unit.c(length * -1, length * -1, length, length ), times = nticks) tick.length <- tick.length %|W|% theme$axis.ticks.length @@ -171,7 +173,7 @@ brackets_vertical <- function(direction = c('left','right'), tick.length <- unit(0, 'npc') brackets <- zeroGrob() } - + gt <- switch(position, left = gtable::gtable_row('axis', grobs = list(labels, brackets), diff --git a/R/coord-capped.r b/R/coord-capped.r index 7c18254..ca05502 100644 --- a/R/coord-capped.r +++ b/R/coord-capped.r @@ -73,7 +73,7 @@ coord_capped_cart <- function(xlim = NULL, if (is.character(right)) right <- capped_vertical(right, gap=gap) test_orientation(top, right, bottom, left) - + ggproto(NULL, CoordFlexCartesian, limits = list(x = xlim, y = ylim), expand = expand, @@ -87,7 +87,7 @@ coord_capped_cart <- function(xlim = NULL, #' @rdname coord_capped #' @export -#' @inheritParams coord_flex_cart +# @inheritParams coord_flex_cart coord_capped_flip <- function(xlim = NULL, ylim = NULL, expand = TRUE, @@ -100,9 +100,9 @@ coord_capped_flip <- function(xlim = NULL, if (is.character(bottom)) bottom <- capped_horizontal(bottom, gap=gap) if (is.character(left)) left <- capped_vertical(left, gap=gap) if (is.character(right)) right <- capped_vertical(right, gap=gap) - + test_orientation(top, right, bottom, left) - + ggproto(NULL, CoordFlexFlipped, limits = list(x = xlim, y = ylim), expand = expand, @@ -117,7 +117,7 @@ coord_capped_flip <- function(xlim = NULL, #' @param capped Which end to cap the line. Can be one of (where relevant): #' \code{both}, \code{none}, \code{left}, \code{right}, \code{top}, \code{bottom}. -#' @inheritParams coord_capped_cart +# @inheritParams coord_capped_cart #' @rdname coord_capped #' @export #' @import grid @@ -125,18 +125,14 @@ capped_horizontal <- function(capped = c('both','left','right','none'), gap = 0.01) { capped <- match.arg(capped) # scale_details: aka. panel_params - # axis: primary or secondary - # scale: "x" or "y" # position: top or bottom / left or right # theme: - fn <- function(scale_details, axis, scale, position, theme) { - agrob <- render_axis(scale_details, axis, "x", position, theme) + fn <- function(guides, position, theme) { + guide <- guide_for_position(guides, position) + agrob <- guide_gengrob(guide, theme) if (agrob$name == 'NULL') return(agrob) - r <- range(as.numeric( switch(axis, - primary=scale_details$x.major, - secondary=scale_details$x.sec.major, scale_details$x.major - ))) + r <- range(guide$key$x) i <- which(grepl('line', names(agrob$children))) agrob$children[[i]]$x <- switch(capped, none = unit(c(min(0 + gap, r[1]), max(1 - gap, r[2])), 'native'), @@ -155,7 +151,7 @@ capped_horizontal <- function(capped = c('both','left','right','none'), #' @export capped_horisontal <- capped_horizontal -#' @inheritParams capped_horizontal +# @inheritParams capped_horizontal #' @rdname coord_capped #' @export #' @import grid @@ -163,18 +159,14 @@ capped_vertical <- function(capped = c('top','bottom','both','none'), gap = 0.01) { capped <- match.arg(capped) # scale_details: aka. panel_params - # axis: primary or secondary - # scale: "x" or "y" # position: top or bottom / left or right # theme: - fn <- function(scale_details, axis, scale, position, theme) { - agrob <- render_axis(scale_details, axis, "y", position, theme) + fn <- function(guides, position, theme) { + guide <- guide_for_position(guides, position) #guides[[which(sapply(guides, `[[`, 'position') == position)]] + agrob <- guide_gengrob(guide, theme) if (agrob$name == 'NULL') return(agrob) - r <- range(as.numeric( switch(axis, - primary=scale_details$y.major, - secondary=scale_details$y.sec.major, scale_details$y.major - ))) + r <- range(guide$key$y) i <- which(grepl('line', names(agrob$children))) agrob$children[[i]]$y <- switch(capped, none = unit(c(min(0 + gap,r[1]), max(1 - gap, r[2])), 'native'), diff --git a/R/coord-flex.r b/R/coord-flex.r index c1647d8..deaf048 100644 --- a/R/coord-flex.r +++ b/R/coord-flex.r @@ -82,9 +82,9 @@ coord_flex_cart <- function(xlim = NULL, left = waiver(), bottom = waiver(), right = waiver()) { - + test_orientation(top, right, bottom, left) - + ggproto(NULL, CoordFlexCartesian, limits = list(x = xlim, y = ylim), expand = expand, @@ -97,7 +97,7 @@ coord_flex_cart <- function(xlim = NULL, #' @rdname coord_flex #' @export -#' @inheritParams coord_flex_cart +# @inheritParams coord_flex_cart #' coord_flex_flip <- function(xlim = NULL, ylim = NULL, @@ -106,9 +106,9 @@ coord_flex_flip <- function(xlim = NULL, left = waiver(), bottom = waiver(), right = waiver()) { - + test_orientation(top, right, bottom, left) - + ggproto(NULL, CoordFlexFlipped, limits = list(x = xlim, y = ylim), expand = expand, @@ -120,7 +120,7 @@ coord_flex_flip <- function(xlim = NULL, } #' @rdname coord_flex -#' @inheritParams coord_flex_cart +# @inheritParams coord_flex_cart #' @export #' @param ratio aspect ratio, expressed as \code{y / x}. coord_flex_fixed <- function(ratio = 1, @@ -131,9 +131,9 @@ coord_flex_fixed <- function(ratio = 1, left = waiver(), bottom = waiver(), right = waiver()) { - + test_orientation(top, right, bottom, left) - + ggproto(NULL, CoordFlexFixed, limits = list(x = xlim, y = ylim), ratio = ratio, @@ -154,46 +154,44 @@ coord_flex_fixed <- function(ratio = 1, # ancestral class "Coord" in coord-.r # For each top/bottom or left/right axis, they basically just call what ever # function the coord_flex classes were given. -flex_render_axis_h <- function(self, scale_details, theme) { - arrange <- scale_details$x.arrange %||% c("primary", "secondary") - top <- self$top %|W|% render_axis - bottom <- self$bottom %|W|% render_axis +flex_render_axis_h <- function(self, panel_params, theme) { + top <- self$top %|W|% panel_guides_grob + bottom <- self$bottom %|W|% panel_guides_grob list( - top = top(scale_details, arrange[1], "x", "top", theme), - bottom = bottom(scale_details, arrange[2], "x", "bottom", theme) + top = top(panel_params$guides, position = "top", theme = theme), + bottom = bottom(panel_params$guides, position = "bottom", theme = theme) ) } -flex_render_axis_v <- function(self, scale_details, theme) { - arrange <- scale_details$y.arrange %||% c("primary","secondary") - left <- self$left %|W|% render_axis - right <- self$right %|W|% render_axis +flex_render_axis_v <- function(self, panel_params, theme) { + left <- self$left %|W|% panel_guides_grob + right <- self$right %|W|% panel_guides_grob list( - left = left(scale_details, arrange[1], 'y', 'left', theme), - right = right(scale_details, arrange[2], 'y', 'right', theme) + left = left(panel_params$guides, position = "left", theme = theme), + right = right(panel_params$guides, position = "right", theme = theme) ) } # Checks that the provided axis function corresponds to the orientation of the # axis it is used upon. test_orientation <- function(top, right, bottom, left) { - if (!is.waive(top) && + if (!is.waive(top) && !is.null(attr(top, 'orientation', exact=TRUE)) && - attr(top, 'orientation', exact=TRUE) == 'vertical') + attr(top, 'orientation', exact=TRUE) == 'vertical') stop('`top` has been supplied a vertical axis function; this will not work.') - if (!is.waive(bottom) && + if (!is.waive(bottom) && !is.null(attr(bottom, 'orientation', exact=TRUE)) && - attr(bottom, 'orientation', exact=TRUE) == 'vertical') + attr(bottom, 'orientation', exact=TRUE) == 'vertical') stop('`bottom` has been supplied a vertical axis function; this will not work.') - if (!is.waive(left) && + if (!is.waive(left) && !is.null(attr(left, 'orientation', exact=TRUE)) && - attr(left, 'orientation', exact=TRUE) == 'horizontal') + attr(left, 'orientation', exact=TRUE) == 'horizontal') stop('`left` has been supplied a horizontal axis function; this will not work.') - if (!is.waive(right) && + if (!is.waive(right) && !is.null(attr(right, 'orientation', exact=TRUE)) && - attr(right, 'orientation', exact=TRUE) == 'horizontal') + attr(right, 'orientation', exact=TRUE) == 'horizontal') stop('`right` has been supplied a horizontal axis function; this will not work.') } - + # ggproto objects ------------------------------------------------------------- @@ -204,9 +202,9 @@ test_orientation <- function(top, right, bottom, left) { #' @export #' @import ggplot2 CoordFlexCartesian <- ggplot2::ggproto('CoordFlexCartesian', - `_inherit` = ggplot2::CoordCartesian, - render_axis_h = flex_render_axis_h, - render_axis_v = flex_render_axis_v + `_inherit` = ggplot2::CoordCartesian, + render_axis_h = flex_render_axis_h, + render_axis_v = flex_render_axis_v ) #' @rdname lemon-ggproto diff --git a/R/dot.r b/R/dot.r index 93b540e..295405c 100644 --- a/R/dot.r +++ b/R/dot.r @@ -1,10 +1,10 @@ #' Create paths that are safe from changing working directory. #' -#' The \code{.dot} functions creates functions that allows relative-like +#' The \code{.dot} functions creates functions that allows relative-like #' specification of paths, but are safe from changing working directory. #' #' @param x File path that is appended to \code{BASEDIR}. -#' @param root Root of your working directory, +#' @param root Root of your working directory, #' from which \code{x} is relative too. #' @param mustExist Logical value; if \code{TRUE} and the resulting path does #' not exist, it raises an error. @@ -12,19 +12,19 @@ #' For the returned function, when \code{TRUE}, the function #' returns a path relative to \code{root}. #' @param create Logical values, creates the target directory when \code{TRUE} (default). -#' @return A function that returns file paths constructed from +#' @return A function that returns file paths constructed from #' \code{root}, \code{x}, and \code{...}. -#' +#' #' \emph{Side effect:} It creates the directory. #' @export #' @rdname dot #' @examples -#' -#' .data <- .dot('data') +#' +#' .data <- .dot('data', create=FALSE) #' .data('input.txt') #' .data(c('a.txt','b.txt')) -#' -#' .dot2(c('rawdata','results')) +#' +#' .dot2(c('rawdata','results'), create=FALSE) #' .rawdata('rawfile.csv') #' .results('myresults.txt') .dot <- function(x, root=getwd(), mustExist=FALSE, relative=FALSE, create=TRUE) { @@ -43,7 +43,7 @@ return(f) } -#' \code{.dot2} allows specification of multiple .dot functions while +#' \code{.dot2} allows specification of multiple .dot functions while #' broadcasting the functions' names and target. #' This function also pushes the function into the calling environment, #' potentially overwriting previous funtions with same name. diff --git a/R/facet-rep-lab.r b/R/facet-rep-lab.r index c34b8c3..5dc72d6 100644 --- a/R/facet-rep-lab.r +++ b/R/facet-rep-lab.r @@ -7,9 +7,9 @@ NULL #' with axis lines and labels preserved on all panels. #' #' These two functions are extensions to \code{\link[ggplot2]{facet_grid}} -#' and \code{\link[ggplot2]{facet_wrap}} that keeps axis lines, ticks, and +#' and \code{\link[ggplot2]{facet_wrap}} that keeps axis lines, ticks, and #' optionally tick labels across all panels. -#' +#' #' Examples are given in the vignette \href{../doc/facet-rep-labels.html}{"Repeat axis lines on facet panels" vignette}. #' #' @param ... Arguments used for \code{\link[ggplot2]{facet_grid}} or @@ -23,23 +23,23 @@ NULL #' @export facet_rep_grid <- function(..., repeat.tick.labels=FALSE) { f <- ggplot2::facet_grid(...) - + rtl <- reduce.ticks.labels.settings(repeat.tick.labels) # if (scales %in% c('free','free_y') && !any(c('left','right') %in% rtl)) # rtl <- c(rtl, 'left') # if (scales %in% c('free','free_x') && !any(c('top','bottom') %in% rtl)) # rtl <- c(rtl, 'bottom') - + params <- append(f$params, list(repeat.tick.labels=rtl)) ggplot2::ggproto(NULL, FacetGridRepeatLabels, shrink=f$shrink, params=params) } -#' Reduces the multitude of repeat.tick.labels-settings to +#' Reduces the multitude of repeat.tick.labels-settings to #' a a combination of four sides. #' Empty vector corresponds to 'none' -#' +#' #' @noRd reduce.ticks.labels.settings <- function(ticks) { if (length(ticks) == 0) return(character(0)) @@ -66,8 +66,10 @@ remove_labels_from_axis <- function(axisgrob) { d <- grepl('titleGrob', sapply(axisgrob$children[[a]]$grobs, `[[`, i='name')) if (sum(d) > 0) { axisgrob$children[[a]] <- do.call(gList, axisgrob$children[[a]]$grobs[!d]) - if (length(axisgrob$width$arg1) == 2) axisgrob$width$arg1 <- axisgrob$width$arg1[attr(axisgrob$width$arg1, 'unit') != 'grobwidth'] - if (length(axisgrob$height$arg1) == 2) axisgrob$height$arg1 <- axisgrob$height$arg1[attr(axisgrob$height$arg1, 'unit') != 'grobheight'] + if (!inherits(axisgrob$width, 'simpleUnit') && length(axisgrob$width$arg1) == 2) + axisgrob$width$arg1 <- axisgrob$width$arg1[attr(axisgrob$width$arg1, 'unit') != 'grobwidth'] + if (!inherits(axisgrob$height, 'simpleUnit') && length(axisgrob$height$arg1) == 2) + axisgrob$height$arg1 <- axisgrob$height$arg1[attr(axisgrob$height$arg1, 'unit') != 'grobheight'] #if (length(axisgrob$children[[a]]$heights) == 2) axisgrob$children[[a]]$heights <- axisgrob$children[[a]]$heights[!d] } axisgrob @@ -102,7 +104,8 @@ FacetGridRepeatLabels <- ggplot2::ggproto('FacetGridRepeatLabels', panel_range <- find_panel(table) - panel_range[,c('col','row')] <- c(max(panels$col), max(panels$row)) + panel_range$col <- max(panels$col) + panel_range$row <- max(panels$row) l_axis_column_added <- logical(panel_range$col) r_axis_column_added <- logical(panel_range$col) diff --git a/R/facet-wrap.r b/R/facet-wrap.r index ac484fd..00373e0 100644 --- a/R/facet-wrap.r +++ b/R/facet-wrap.r @@ -2,7 +2,7 @@ NULL #' @rdname facet_rep -#' @inheritParams facet_rep_grid +# @inheritParams facet_rep_grid #' @param scales As for \code{facet_grid}, but alters behaviour of \code{repeat.tick.labels}. #' @import ggplot2 #' @export @@ -115,7 +115,7 @@ FacetWrapRepeatLabels <- ggplot2::ggproto('FacetWrapRepeatLabels', if (!'bottom' %in% params$repeat.tick.labels) axis_mat_x_bottom[-nrow,] <- lapply(axis_mat_x_bottom[-nrow,], remove_labels_from_axis) if (!'left' %in% params$repeat.tick.labels) axis_mat_y_left[,-1] <- lapply(axis_mat_y_left[,-1], remove_labels_from_axis) if (!'right' %in% params$repeat.tick.labels) axis_mat_y_right[, -ncol] <- lapply(axis_mat_y_right[, -ncol], remove_labels_from_axis) - + axis_height_top <- unit(apply(axis_mat_x_top, 1, max_height), "cm") axis_height_bottom <- unit(apply(axis_mat_x_bottom, 1, max_height), "cm") axis_width_left <- unit(apply(axis_mat_y_left, 2, max_width), "cm") diff --git a/R/geom-pointline.r b/R/geom-pointline.r index 29f651e..b332703 100644 --- a/R/geom-pointline.r +++ b/R/geom-pointline.r @@ -2,52 +2,52 @@ NULL #' Connected points -#' -#' \code{geom_pointpath} combines \code{\link[ggplot2]{geom_point}} and +#' +#' \code{geom_pointpath} combines \code{\link[ggplot2]{geom_point}} and #' \code{\link[ggplot2]{geom_path}}, such that a) when jittering is used, #' both lines and points stay connected, and b) provides a visual effect #' by adding a small gap between the point and the end of line. #' \code{geom_pointline} combines \code{\link[ggplot2]{geom_point}} and #' \code{\link[ggplot2]{geom_path}}. -#' +#' #' \code{geom_pointpath} connects the observations in the same order in which #' they appear in the data. #' \code{geom_pointline} connects them in order of the variable on the x-axis. -#' -#' Both \code{geom_pointpath} and \code{geom_pointline} will only +#' +#' Both \code{geom_pointpath} and \code{geom_pointline} will only #' connect observations within the same group! However, #' if \code{linecolour} is \emph{not} \code{waiver()}, connections #' will be made between groups, but possible in an incorrect order. -#' -#' -#' -#' -#' +#' +#' +#' +#' +#' #' @section Aesthetics: -#' \code{geom_pointline} and \code{geom_pointpath} understands the following +#' \code{geom_pointline} and \code{geom_pointpath} understands the following #' aesthetics (required aesthetics are in bold): #' \itemize{ #' \item \strong{x} #' \item \strong{y} #' \item alpha -#' \item colour -- sets colour of point. Only affects line if \code{linecolour=waiver()}. +#' \item colour -- sets colour of point. Only affects line if \code{linecolour=waiver()}. #' \item stroke #' \item shape #' \item stroke #' \item group #' \item linetype -#' \item size -- only affects point size. Width of line is set with +#' \item size -- only affects point size. Width of line is set with #' \code{linesize} and cannot be linked to an aesthetic. #' } #' @param mapping Set of aesthetic mappings created by \code{\link[ggplot2]{aes}} #' or \code{\link[ggplot2]{aes_}}. #' @param data The data to be displayed in this layer. -#' @param stat The statistical transformation to use on the data for this layer, +#' @param stat The statistical transformation to use on the data for this layer, #' as a string. -#' @param position Position adjustment, either as a string, or the result of a +#' @param position Position adjustment, either as a string, or the result of a #' call to a position adjustment function #' (e.g. \code{\link[ggplot2]{position_jitter}}). -#' Both lines and points gets the same adjustment +#' Both lines and points gets the same adjustment #' (\emph{this} is where the function excels over \code{geom_point() + geom_line()}). #' @param ... other arguments passed on to \code{\link[ggplot2]{layer}}. #' @param lineend Line end style (round, butt, square). @@ -61,7 +61,7 @@ NULL #' \code{FALSE} never includes, and \code{TRUE} always includes. #' @param inherit.aes If \code{FALSE}, overrides the default aesthetic, rather #' than combining with them. This is most useful for helper functions that -#' define both data and aesthetics and shouldn't inherit behaviour from the +#' define both data and aesthetics and shouldn't inherit behaviour from the #' default plot specification. #' @param linesize Width of of line. #' @param distance Gap size between point and end of lines; @@ -71,15 +71,15 @@ NULL #' @param shorten,threshold When points are closer than \code{threshold}, #' shorten the line by the proportion in \code{shorten} instead of adding #' a gap by \code{distance}. -#' @param linecolour,linecolor When not \code{waiver()}, the line is drawn with +#' @param linecolour,linecolor When not \code{waiver()}, the line is drawn with #' this colour instead of that set by aesthetic \code{colour}. -#' +#' #' @example inst/examples/geom-pointline-ex.r #' @export geom_pointpath <- function(mapping = NULL, data = NULL, stat = "identity", position = "identity", na.rm = FALSE, - show.legend = NA, inherit.aes = TRUE, - distance = unit(3, 'pt'), + show.legend = NA, inherit.aes = TRUE, + distance = unit(3, 'pt'), shorten = 0.5, threshold = 0.1, lineend = "butt", @@ -91,7 +91,7 @@ geom_pointpath <- function(mapping = NULL, data = NULL, stat = "identity", arrow = NULL, ...) { if (is.waive(linecolour) && !is.waive(linecolor)) linecolour <- linecolor - + layer( data = data, mapping = mapping, @@ -133,9 +133,9 @@ GeomPointPath <- ggplot2::ggproto('GeomPointPath', alpha = NA, stroke = 0.5, linetype = 1 ), - + draw_panel = function(data, panel_params, coord, na.rm = FALSE, - distance = grid::unit(3, 'pt'), + distance = grid::unit(3, 'pt'), shorten = 0.5, threshold = 0.1, linesize = 0.5, @@ -143,15 +143,14 @@ GeomPointPath <- ggplot2::ggproto('GeomPointPath', arrow = NULL, lineend = "butt", linejoin = "round", linemitre = 1 ) { - # Test input parameters if (is.null(distance) || is.na(distance)) { distance=grid::unit(0, 'pt') threshold = 0 } - if (!grid::is.unit(distance) && is.numeric(distance)) + if (!grid::is.unit(distance) && is.numeric(distance)) distance <- grid::unit(distance, 'pt') - + # Contents of GeomPoint$draw_panel in geom-point.r coords <- coord$transform(data, panel_params) coords_p <- coords @@ -169,7 +168,7 @@ GeomPointPath <- ggplot2::ggproto('GeomPointPath', ) ) # gr_points <- GeomPoint$draw_panel(data, panel_params, coord, na.rm) - + # Contents of GeomPath$draw_panel in geom-path if (!anyDuplicated(data$group)) { message_wrap("geom_path: Each group consists of only one observation. ", @@ -213,7 +212,8 @@ GeomPointPath <- ggplot2::ggproto('GeomPointPath', deltay = y1 - y; length <- sqrt(deltax**2 + deltay**2); }) - + munched <- munched[-nrow(munched), ] + if (any(munched$length > threshold, na.rm=TRUE)) { # Calculate angle between each pair of points and move endpoints: if (as.numeric(distance) != 0) { @@ -233,21 +233,21 @@ GeomPointPath <- ggplot2::ggproto('GeomPointPath', y1 = grid::unit(y1, 'native'); }) } - - gr_distant <- with(df, grid::segmentsGrob( - x0=x[!end], y0=y[!end], x1=x1[!end], y1=y1[!end], + + gr_distant <- with(df[!df$end,], grid::segmentsGrob( + x0=x, y0=y, x1=x1, y1=y1, arrow = arrow, gp = grid::gpar( - col = ggplot2::alpha(colour, alpha)[!end], - fill = ggplot2::alpha(colour, alpha)[!end], + col = ggplot2::alpha(colour, alpha), + fill = ggplot2::alpha(colour, alpha), lwd = linesize * .pt, - lty = linetype[!end], + lty = linetype, lineend = lineend, linejoin = linejoin, linemitre = linemitre ) )) - if (!is.waive(linecolour)) + if (!is.waive(linecolour)) gr_distant$gp$col <- linecolour } else { gr_distant <- zeroGrob() @@ -260,48 +260,42 @@ GeomPointPath <- ggplot2::ggproto('GeomPointPath', x1 = x1 - shorten/2 * deltax; x1 = grid::unit(x1, 'native'); y1 = y1 - shorten/2 * deltay; y1 = grid::unit(y1, 'native'); }) - - gr_short <- with(df, grid::segmentsGrob( - x0=x[!end], y0=y[!end], x1=x1[!end], y1=y1[!end], + + gr_short <- with(df[!df$end, ], grid::segmentsGrob( + x0=x, y0=y, x1=x1, y1=y1, arrow = arrow, gp = grid::gpar( - col = ggplot2::alpha(colour, alpha)[!end], - fill = ggplot2::alpha(colour, alpha)[!end], + col = ggplot2::alpha(colour, alpha), + fill = ggplot2::alpha(colour, alpha), lwd = linesize * .pt, - lty = linetype[!end], + lty = linetype, lineend = lineend, linejoin = linejoin, linemitre = linemitre ) )) - if (!is.waive(linecolour)) + if (!is.waive(linecolour)) gr_short$gp$col <- linecolour } else { gr_short <- zeroGrob() } - - - #saveRDS(munched, 'munced.rds') - - - grid::gList(gr_points, gr_distant, gr_short) }, - + draw_key = ggplot2::draw_key_point ) #' @export -#' @inheritParams geom_pointpath +# @inheritParams geom_pointpath #' @rdname geom_pointpath geom_pointline <- function(mapping = NULL, data = NULL, stat = "identity", position = "identity", na.rm = FALSE, - show.legend = NA, inherit.aes = TRUE, - distance = unit(3, 'pt'), + show.legend = NA, inherit.aes = TRUE, + distance = unit(3, 'pt'), shorten = 0.5, - threshold = 0.1, + threshold = 0.1, lineend = "butt", linejoin = "round", linemitre = 1, @@ -310,9 +304,9 @@ geom_pointline <- function(mapping = NULL, data = NULL, stat = "identity", linecolor = waiver(), arrow = NULL, ...) { - + if (is.waive(linecolour) && !is.waive(linecolor)) linecolour <- linecolor - + layer( data = data, mapping = mapping, @@ -325,13 +319,13 @@ geom_pointline <- function(mapping = NULL, data = NULL, stat = "identity", na.rm = na.rm, distance = distance, shorten = shorten, - threshold = threshold, + threshold = threshold, lineend = lineend, linejoin = linejoin, linemitre = linemitre, linesize = 0.5, linecolour = linecolour, - arrow = arrow, + arrow = arrow, ... ) ) @@ -353,12 +347,12 @@ GeomPointLine <- ggproto("GeomPointLine", GeomPointPath, -#' @inheritParams geom_pointpath +# @inheritParams geom_pointpath #' @rdname geom_pointpath geom_pointrangeline <- function(mapping = NULL, data = NULL, stat = "identity", position = "identity", na.rm = FALSE, - show.legend = NA, inherit.aes = TRUE, - distance = unit(3, 'pt'), + show.legend = NA, inherit.aes = TRUE, + distance = unit(3, 'pt'), lineend = "butt", linejoin = "round", linemitre = 1, @@ -369,7 +363,7 @@ geom_pointrangeline <- function(mapping = NULL, data = NULL, stat = "identity", ...) { stop('geom_pointrangeline has not been implemented. Sorry') if (is.waive(linecolour) && !is.waive(linecolor)) linecolour <- linecolor - + layer( data = data, mapping = mapping, @@ -386,7 +380,7 @@ geom_pointrangeline <- function(mapping = NULL, data = NULL, stat = "identity", linemitre = linemitre, linesize = 0.5, linecolour = linecolour, - arrow = arrow, + arrow = arrow, ... ) ) @@ -401,7 +395,7 @@ geom_pointrangeline <- function(mapping = NULL, data = NULL, stat = "identity", #' @import gtable GeomPointRangeLine <- ggproto("GeomPointRangeLine", GeomPointLine, required_aes = c("x", "y", "ymin", "ymax"), - + setup_data = function(data, params) { data[order(data$PANEL, data$group, data$x), ] }, diff --git a/R/geom-siderange.r b/R/geom-siderange.r index 25072de..9a7fef1 100644 --- a/R/geom-siderange.r +++ b/R/geom-siderange.r @@ -3,34 +3,34 @@ NULL #' Display range of data in side of plot -#' +#' #' Projects data onto horizontal or vertical edge of panels. -#' +#' #' The \code{geom_siderange} projects the data displayed in the panel onto the #' sides, using the same aesthetics. It has the added capability of potting a #' symbol at either end #' of the line, and lines are offset from the edge and each other. -#' +#' #' To display a symbol, specify an integer for either \code{start} or \code{end}. #' See the list for \code{pch} in \code{\link[graphics]{points}} for values to use. #' The argumetns \code{start} and \code{end} also accepts a list object with -#' named entries \code{pch}, \code{alpha}, \code{stroke}, and \code{fill}, which -#' correspond to the usual aesthetics, as well as a special named entry, +#' named entries \code{pch}, \code{alpha}, \code{stroke}, and \code{fill}, which +#' correspond to the usual aesthetics, as well as a special named entry, #' \code{sizer} (note the extra 'r'). -#' This last entry is a multiplier for enlarging the symbol relative to the +#' This last entry is a multiplier for enlarging the symbol relative to the #' linewidth, as the aesthetic \code{size} affects both linewidth and symbol size. -#' -#' The distance between the panel's edge and sideranges are specified by +#' +#' The distance between the panel's edge and sideranges are specified by #' the argument \code{distance}. If a symbol is specified, the linewidth is #' further expanded to cover the width of the symbol (including \code{sizer}). -#' -#' +#' +#' #' @inheritParams geom_pointpath #' @param sides Character including \strong{t}op, \strong{r}ight, \strong{b}ottom, and/or \strong{l}eft, #' indicating which side to project data onto. -#' @param distance Distance between edge of panel and lines, and distance +#' @param distance Distance between edge of panel and lines, and distance #' between lines, in multiples of line widths, see description. -#' @param start,end Adds a symbol to either end of the siderange. +#' @param start,end Adds a symbol to either end of the siderange. #' \code{start} corresponds to minimal value, \code{end} to maximal value. #' @section Aesthetics: #' The geom understands the following aesthetics (required are in bold): @@ -45,17 +45,17 @@ NULL #' \item size #' \item stroke #' } -#' #' -#' +#' +#' #' @seealso \code{\link[ggplot2]{geom_rug}} #' @export -#' +#' #' @example inst/examples/geom-siderange-ex.r -geom_siderange <- function(mapping = NULL, data = NULL, +geom_siderange <- function(mapping = NULL, data = NULL, stat = "identity", position = "identity", ..., - distance = 3, + distance = 3, arrow = NULL, lineend = "butt", sides = 'bl', @@ -82,7 +82,7 @@ geom_siderange <- function(mapping = NULL, data = NULL, na.rm = na.rm, ... ) - ) + ) } #' @rdname lemon-ggproto @@ -103,32 +103,31 @@ GeomSideRange <- ggplot2::ggproto('GeomSideRange', alpha = NA, stroke = 0.5, linetype = 1 ), - + draw_panel = function(data, panel_params, coord, arrow = NULL, distance = 1, start = NA, end = NA, lineend = "butt", sides='bl', na.rm = FALSE) { data <- coord$transform(data, panel_params) - save(data, coord, file='tmp.Rdata') default_point = list(pch = 19, sizer = 3, alpha = NA, stroke = 0.5, fill = NA) if (!is.list(start) && !is.na(start)) { start <- merge.list(list(pch=start), default_point) } else if (is.list(start)) { start <- merge.list(start, default_point) - + } if (!is.list(end) && !is.na(end)) { end <- merge.list(list(pch=end), default_point) } else if (is.list(end)) { end <- merge.list(end, default_point) } - + sizer <- c(NA, NA) if (is.list(start)) sizer[1] <- start$sizer if (is.list(end)) sizer[2] <- start$sizer if (!all(is.na(sizer))) distance <- distance * max(sizer, na.rm=TRUE) - + # from ggplot2/R/geom-rug.r sideranges <- list() if (!is.null(data$x) & grepl("[tb]", sides)) { @@ -137,14 +136,14 @@ GeomSideRange <- ggplot2::ggproto('GeomSideRange', gp <- grid::gpar(col=alpha(df$colour, df$alpha), lty=df$linetype, lwd=df$size * .pt) if (grepl("t", sides)) { df <- plyr::ddply(df, plyr::.(PANEL), function(x) { - x$y <- grid::unit(1, 'npc') - unit(df$size, 'pt') * order(x$group) * distance; + x$y <- grid::unit(1, 'npc') - unit(df$size, 'pt') * order(x$group) * distance; x }) sideranges$x_t <- list(grid::segmentsGrob(x0=df$min, x1=df$max, y0=df$y, y1=df$y, gp=gp, arrow=arrow), NULL, NULL) if (is.list(start)) { df_s <- merge.list(df, start) df_s$min <- with(df_s, unit(min, 'native') - unit(sizer * size * .pt / 2, 'pt')) - sideranges$x_t[[2]] <- grid::pointsGrob(x=df_s$min, y=df_s$y, pch=df_s$pch, + sideranges$x_t[[2]] <- grid::pointsGrob(x=df_s$min, y=df_s$y, pch=df_s$pch, gp = grid::gpar( col = alpha(df_s$colour, df_s$alpha), fill = alpha(df_s$fill, df_s$alpha), @@ -157,7 +156,7 @@ GeomSideRange <- ggplot2::ggproto('GeomSideRange', if (is.list(end)) { df_e <- merge.list(df, end) df_e$max <- with(df_e, unit(max, 'native') + unit(sizer * size * .pt / 2, 'pt')) - sideranges$x_t[[3]] <- grid::pointsGrob(x=df_e$max, y=df_e$y, pch=df_e$pch, + sideranges$x_t[[3]] <- grid::pointsGrob(x=df_e$max, y=df_e$y, pch=df_e$pch, gp = grid::gpar( col = alpha(df_e$colour, df_e$alpha), fill = alpha(df_e$fill, df_e$alpha), @@ -171,14 +170,14 @@ GeomSideRange <- ggplot2::ggproto('GeomSideRange', } if (grepl("b", sides)) { df <- plyr::ddply(df, plyr::.(PANEL), function(x) { - x$y <- unit(df$size, 'pt') * order(x$group) * distance; + x$y <- unit(df$size, 'pt') * order(x$group) * distance; x }) sideranges$x_b <- list(grid::segmentsGrob(x0=df$min, x1=df$max, y0=df$y, y1=df$y, gp=gp, arrow=arrow), NULL, NULL) if (is.list(start)) { df_s <- merge.list(df, start) df_s$min <- with(df_s, unit(min, 'native') - unit(sizer * size * .pt / 2, 'pt')) - sideranges$x_b[[2]] <- grid::pointsGrob(x=df_s$min, y=df_s$y, pch=df_s$pch, + sideranges$x_b[[2]] <- grid::pointsGrob(x=df_s$min, y=df_s$y, pch=df_s$pch, gp = grid::gpar( col = alpha(df_s$colour, df_s$alpha), fill = alpha(df_s$fill, df_s$alpha), @@ -191,7 +190,7 @@ GeomSideRange <- ggplot2::ggproto('GeomSideRange', if (is.list(end)) { df_e <- merge.list(df, end) df_e$max <- with(df_e, unit(max, 'native') + unit(sizer * size * .pt / 2, 'pt')) - sideranges$x_b[[3]] <- grid::pointsGrob(x=df_e$max, y=df_e$y, pch=df_e$pch, + sideranges$x_b[[3]] <- grid::pointsGrob(x=df_e$max, y=df_e$y, pch=df_e$pch, gp = grid::gpar( col = alpha(df_e$colour, df_e$alpha), fill = alpha(df_e$fill, df_e$alpha), @@ -217,7 +216,7 @@ GeomSideRange <- ggplot2::ggproto('GeomSideRange', if (is.list(start)) { df_s <- merge.list(df, start) df_s$min <- with(df_s, unit(min, 'native') - unit(sizer * size * .pt / 2, 'pt')) - sideranges$y_l[[2]] <- grid::pointsGrob(x=df_s$x, y=df_s$min, pch=df_s$pch, + sideranges$y_l[[2]] <- grid::pointsGrob(x=df_s$x, y=df_s$min, pch=df_s$pch, gp = grid::gpar( col = alpha(df_s$colour, df_s$alpha), fill = alpha(df_s$fill, df_s$alpha), @@ -230,7 +229,7 @@ GeomSideRange <- ggplot2::ggproto('GeomSideRange', if (is.list(end)) { df_e <- merge.list(df, end) df_e$max <- with(df_e, unit(max, 'native') + unit(sizer * size * .pt / 2, 'pt')) - sideranges$y_l[[3]] <- grid::pointsGrob(x=df_e$x, y=df_e$max, pch=df_e$pch, + sideranges$y_l[[3]] <- grid::pointsGrob(x=df_e$x, y=df_e$max, pch=df_e$pch, gp = grid::gpar( col = alpha(df_e$colour, df_e$alpha), fill = alpha(df_e$fill, df_e$alpha), @@ -252,7 +251,7 @@ GeomSideRange <- ggplot2::ggproto('GeomSideRange', df_s <- merge.list(df, start) df_s$min <- with(df_s, unit(min, 'native') - unit(sizer * size * .pt / 2, 'pt')) print(df_s) - sideranges$y_r[[2]] <- grid::pointsGrob(x=df_s$x, y=df_s$min, pch=df_s$pch, + sideranges$y_r[[2]] <- grid::pointsGrob(x=df_s$x, y=df_s$min, pch=df_s$pch, gp = grid::gpar( col = alpha(df_s$colour, df_s$alpha), fill = alpha(df_s$fill, df_s$alpha), @@ -265,7 +264,7 @@ GeomSideRange <- ggplot2::ggproto('GeomSideRange', if (is.list(end)) { df_e <- merge.list(df, end) df_e$max <- with(df_e, unit(max, 'native') + unit(sizer * size * .pt / 2, 'pt')) - sideranges$y_r[[3]] <- grid::pointsGrob(x=df_e$x, y=df_e$max, pch=df_e$pch, + sideranges$y_r[[3]] <- grid::pointsGrob(x=df_e$x, y=df_e$max, pch=df_e$pch, gp = grid::gpar( col = alpha(df_e$colour, df_e$alpha), fill = alpha(df_e$fill, df_e$alpha), @@ -278,13 +277,12 @@ GeomSideRange <- ggplot2::ggproto('GeomSideRange', sideranges$y_r <- grid::gTree(children=do.call(grid::gList, sideranges$y_r)) } } - save(data, coord, sideranges, file='tmp.Rdata') - + grid::gTree(children = do.call(grid::gList, sideranges)) }, - + default_aes = aes(colour = "black", size = 0.5, linetype = 1, alpha = NA, stroke=0.5, fill=NA), default_point = list(size = 1.5, alpha = NA, stroke = 0.5, stroke=0.5, fill=NA), - + draw_key = draw_key_path -) \ No newline at end of file +) diff --git a/R/ggplot2.r b/R/ggplot2.r index d0efa15..f83976d 100644 --- a/R/ggplot2.r +++ b/R/ggplot2.r @@ -38,23 +38,27 @@ is.waive <- function(x) inherits(x, "waiver") #' @keywords internal #' @rdname ggplot2-non-exports #' @name if-not-null -#' @export +#' @export "%||%" <- function(a, b) { if (!is.null(a)) a else b } # From ggplot2/R/coord-.r -render_axis <- function(panel_params, axis, scale, position, theme) { - if (axis == "primary") { - guide_axis(panel_params[[paste0(scale, ".major")]], panel_params[[paste0(scale, ".labels")]], position, theme) - } else if (axis == "secondary" && !is.null(panel_params[[paste0(scale, ".sec.major")]])) { - guide_axis(panel_params[[paste0(scale, ".sec.major")]], panel_params[[paste0(scale, ".sec.labels")]], position, theme) - } else { - zeroGrob() - } -} - - +# Renders an axis with the correct orientation or zeroGrob if no axis should be +# generated +# render_axis <- function(panel_params, axis, scale, position, theme) { +# browser() +# if (axis == "primary") { +# guide_axis(panel_params[[paste0(scale, ".major")]], panel_params[[paste0(scale, ".labels")]], position, theme) +# } else if (axis == "secondary" && !is.null(panel_params[[paste0(scale, ".sec.major")]])) { +# guide_axis(panel_params[[paste0(scale, ".sec.major")]], panel_params[[paste0(scale, ".sec.labels")]], position, theme) +# } else { +# zeroGrob() +# } +# } + + +# From ggplot2/R/utilities-grid.r #' @import grid ggname <- function (prefix, grob) { grob$name <- grid::grobName(grob, prefix) @@ -65,6 +69,30 @@ is.zero <- function (x) { is.null(x) || inherits(x, "zeroGrob") } +# From ggplot2/R/coord-cartesian-.r +panel_guide_label <- function(guides, position, default_label) { + guide <- guide_for_position(guides, position) %||% guide_none(title = waiver()) + guide$title %|W|% default_label +} + +panel_guides_grob <- function(guides, position, theme) { + guide <- guide_for_position(guides, position) %||% guide_none() + guide_gengrob(guide, theme) +} + +guide_for_position <- function(guides, position) { + has_position <- vapply( + guides, + function(guide) identical(guide$position, position), + logical(1) + ) + + guides <- guides[has_position] + guides_order <- vapply(guides, function(guide) as.numeric(guide$order)[1], numeric(1)) + Reduce(guide_merge, guides[order(guides_order)]) +} + + # From ggplot2/R/grob-absolute.r absoluteGrob <- function(grob, width = NULL, height = NULL, xmin = NULL, ymin = NULL, vp = NULL) { diff --git a/R/grob_utils.r b/R/grob_utils.r index e1186ce..4f46ba3 100644 --- a/R/grob_utils.r +++ b/R/grob_utils.r @@ -6,39 +6,36 @@ NULL # I should probably #' @include ggplot2.r +NULL -#' Given a theme object and element name, return a grob for the element -#' -#' @rdname element_render -#' @author \code{element_render} is from ggplot2 source. -#' @export +# Given a theme object and element name, return a grob for the element # From ggplot2/R/theme-elements.r element_render <- function(theme, element, ..., name = NULL) { - + # Get the element from the theme, calculating inheritance el <- ggplot2::calc_element(element, theme) if (is.null(el)) { message("Theme element ", element, " missing") return(zeroGrob()) } - + grob <- ggplot2::element_grob(el, ...) ggname(paste(element, name, sep = "."), grob) } #' Render a ggplot2 grob or retrieve its gpar object. -#' +#' #' Helps add the ggplot2-theme's look-and-feel to \code{grid}'s grob objects. #' \code{render_gpar} returns a \code{\link[grid]{gpar}}-object, #' \code{element_render} returns a \code{\link[grid]{grid.grob}}-object. -#' +#' #' @param theme A ggplot2 \link[ggplot2]{theme} #' @param element The name of an element in the theme, e.g. "axis.text". #' @param ... Additional arguments sent to grobs (e.g. \code{x} or \code{y}). #' @param name Returned grob's name.. #' @return A \code{\link[grid]{grid.grob}} or \code{\link[grid]{gpar}} object. #' @seealso \code{\link[ggplot2]{theme}} -#' @rdname element_render +#' @keywords internal #' @export render_gpar <- function(theme, element, ...) { gp <- element_render(theme, element) @@ -46,7 +43,7 @@ render_gpar <- function(theme, element, ...) { } #' Version safe(r) method to get the y- and x-range from trained scales. -#' +#' #' The names of the internal layout objects from \code{ggplot_build} changed #' slightly. #' @name get_panel_range @@ -58,14 +55,14 @@ get_panel_y_range <- function(layout, index=1) { } #' @rdname get_panel_range -#' @inheritParams get_panel_y_range +# @inheritParams get_panel_y_range #' @export get_panel_x_range <- function(layout, index=1) { layout$panel_params[[index]]$x.range %||% layout$panel_ranges[[index]]$x.range } #' @rdname get_panel_range -#' @inheritParams get_panel_y_range +# @inheritParams get_panel_y_range #' @export get_panel_params <- function(layout, index=1) { layout$panel_params[[index]] %||% layout$panel_ranges[[index]] diff --git a/R/gtable_show-.r b/R/gtable_show-.r index 4f8b873..9b1d6a6 100644 --- a/R/gtable_show-.r +++ b/R/gtable_show-.r @@ -100,7 +100,7 @@ gtable_show_grill <- function(x, plot=TRUE) { invisible(x) } -#' @inheritParams gtable_show_grill +# @inheritParams gtable_show_grill #' @param rect.gp Graphical parameters (\code{\link[grid]{gpar}}) for background drop. #' @rdname gtable_show #' @import ggplot2 gtable grid diff --git a/R/legends.r b/R/legends.r index fa542ce..03baa33 100644 --- a/R/legends.r +++ b/R/legends.r @@ -69,27 +69,26 @@ g_legend<-function(a.gplot){ } #' Guidebox as a column -#' +#' #' Takes a plot or legend and returns a single guide-box in a single column, #' for embedding in e.g. tables. -#' +#' #' @param legend A ggplot2 plot or the legend extracted with \code{\link{g_legend}}. #' \emph{Do not} provide a \code{\link[ggplot2]{ggplotGrob}} as it is indistinguisble #' from a legend. #' @param which.legend Integer, a legend can contain multiple guide-boxes (or vice versa?). #' Use this argument to select which to use. #' @param add.title Does nothing yet. -#' @return A \code{\link[gtable]{gtable}} with keys and labels reordered into +#' @return A \code{\link[gtable]{gtable}} with keys and labels reordered into #' a single column and each pair of keys and labels in the same cell. -#' @export +#' @export #' @seealso \code{\link{g_legend}} #' @import ggplot2 #' @import gtable #' @import gridExtra #' @examples #' library(ggplot2) -#' library(dplyr) -#' +#' #' p <- ggplot(diamonds, aes(x=x, y=y, colour=cut)) + geom_point() #' guidebox_as_column(p) #' p <- p + guides(colour=guide_legend(ncol=2, byrow=TRUE)) @@ -101,34 +100,34 @@ guidebox_as_column <- function(legend, which.legend=1, add.title=FALSE) { if (gtable::is.gtable(legend) & legend$name == 'guide-box') { legend <- legend$grobs[[which.legend]] } - + # deduct number of keys from legend # assumes background, labels, and keys, are all in same order (albeit intermixed) bgs <- which(grepl('-bg', legend$layout$name)) keys <- which(grepl('key-[0-9]+-[0-9]+-[0-9]+', legend$layout$name)) labels <- which(grepl('label-[0-9]+-[0-9]+', legend$layout$name)) - + all.keys <- list() label.width <- max(legend$widths[legend$layout$l[labels]]) for (i in 1:length(bgs)) { t = legend$layout$t[bgs[i]] lr = range(legend$layout[c(bgs[i], keys[i], labels[i]), c('l','r')]) b = legend$layout$b[bgs[i]] - - n <- gtable::gtable(heights = legend$heights[t:b], + + n <- gtable::gtable(heights = legend$heights[t:b], widths = unit.c(legend$widths[lr[1]:(lr[2]-1)], label.width), name = paste0(legend$layout$name[keys[i]], '-all') ) n <- gtable::gtable_add_grob(n, legend$grobs[bgs[i]], t=1, l=1, name=legend$layout$name[bgs[i]]) n <- gtable::gtable_add_grob(n, legend$grobs[keys[i]], t=1, l=1, name=legend$layout$name[keys[i]]) n <- gtable::gtable_add_grob(n, legend$grobs[labels[i]], t=1, l=3, name=legend$layout$name[labels[i]]) - + all.keys[[i]] <- n } #all.keys$size <- 'first' all.keys$ncol <- 1 do.call(gridExtra::arrangeGrob, all.keys) - + # if (add.title) { ## argument # i <- which(legend$layout$name == 'title') # if (length(i) > 0) { @@ -142,16 +141,16 @@ guidebox_as_column <- function(legend, which.legend=1, add.title=FALSE) { #' Share a legend between multiple plots #' -#' Extract legend, combines plots using \code{\link[gridExtra]{arrangeGrob}} / +#' Extract legend, combines plots using \code{\link[gridExtra]{arrangeGrob}} / #' \code{grid.arrange}, #' and places legend in a margin. #' -#' #' -#' @param ... Objects to plot. First argument should be a ggplot2 object, +#' +#' @param ... Objects to plot. First argument should be a ggplot2 object, #' as the legend is extracted from this. -#' Other arguments are passed on to -#' \code{\link[gridExtra]{arrangeGrob}}, +#' Other arguments are passed on to +#' \code{\link[gridExtra]{arrangeGrob}}, #' including named arguments that are not defined for \code{grid_arrange_shared_legend}. #' ggplot2 objects have their legends hidden. #' @param ncol Integer, number of columns to arrange plots in. @@ -159,15 +158,15 @@ guidebox_as_column <- function(legend, which.legend=1, add.title=FALSE) { #' @param position 'bottom' or 'right' for positioning legend. #' @param plot Logical, when \code{TRUE} (default), draws combined plot on a #' new page. -#' @return gtable of combined plot, invisibly. +#' @return gtable of combined plot, invisibly. #' Draw gtable object using \code{\link[grid]{grid.draw}}. #' @author #' Originally brought to you by -#' \href{http://baptiste.github.io/}{Baptiste Auguié} +#' \href{http://baptiste.github.io/}{Baptiste Auguié} #' (\url{https://github.com/tidyverse/ggplot2/wiki/Share-a-legend-between-two-ggplot2-graphs}) -#' and +#' and #' \href{http://rpubs.com/sjackman}{Shaun Jackman} -#' (\href{http://rpubs.com/sjackman/grid_arrange_shared_legend}{original}). +#' (\href{http://rpubs.com/sjackman/grid_arrange_shared_legend}{original}). #' Stefan McKinnon Edwards added left and top margins. #' @import ggplot2 gridExtra grid #' @export @@ -181,15 +180,15 @@ guidebox_as_column <- function(legend, which.legend=1, add.title=FALSE) { #' p4 <- qplot(depth, price, data = dsamp, colour = clarity) #' grid_arrange_shared_legend(p1, p2, p3, p4, ncol = 4, nrow = 1) #' grid_arrange_shared_legend(p1, p2, p3, p4, ncol = 2, nrow = 2) -#' +#' #' # Passing on plots in a grob are not touched #' grid_arrange_shared_legend(p1, gridExtra::arrangeGrob(p2, p3, p4, ncol=3), ncol=1, nrow=2) -#' +#' #' # We can also pass on named arguments to arrangeGrob: #' title <- grid::textGrob('This is grob', gp=grid::gpar(fontsize=14, fontface='bold')) #' nt <- theme(legend.position='none') -#' grid_arrange_shared_legend(p1, -#' gridExtra::arrangeGrob(p2+nt, p3+nt, p4+nt, ncol=3), ncol=1, nrow=2, +#' grid_arrange_shared_legend(p1, +#' gridExtra::arrangeGrob(p2+nt, p3+nt, p4+nt, ncol=3), ncol=1, nrow=2, #' top=title) grid_arrange_shared_legend <- function(..., ncol = length(list(...)), @@ -202,7 +201,7 @@ grid_arrange_shared_legend <- function(..., position <- match.arg(position) #g <- ggplotGrob(plots[[1]] + theme(legend.position = position))$grobs #legend <- g[[which(sapply(g, function(x) x$name) == "guide-box")]] - legend <- g_legend(plots[[1]] + theme(legend.position = position)) + legend <- g_legend(plots[[1]] + theme(legend.position = position)) lheight <- sum(legend$height) lwidth <- sum(legend$width) gl <- lapply(plots, function(x) { @@ -251,29 +250,29 @@ arrangeGrob <- gridExtra::arrangeGrob #' #' To modify the look of the legend, use themes and the natural ggplot functions #' found in \code{\link[ggplot2]{guide_legend}}. -#' +#' #' \emph{Positioning} is done by argument \code{position} which places the panel #' relative in \code{panel} (see below). #' \code{position} resolves to three variables, \code{x}, \code{y}, and \code{just}. #' \code{x} and \code{y} is the coordinate in \code{panel}, where the anchorpoint of #' the legend (set via \code{just}) is placed. -#' In other words, \code{just='bottom right'} places the bottom right corner of +#' In other words, \code{just='bottom right'} places the bottom right corner of #' the legend at coordinates \code{(x,y)}. -#' -#' The positioning can be set by argument \code{position} alone, which can be -#' further nudged by setting \code{position}, \code{x}, and \code{y}. +#' +#' The positioning can be set by argument \code{position} alone, which can be +#' further nudged by setting \code{position}, \code{x}, and \code{y}. #' Alternatively, manually positioning can be obtained by setting arguments. #' \code{x}, \code{y}, and \code{just}. #' -#' \emph{Panel} name is by default \code{panel}, but when using facets it typically +#' \emph{Panel} name is by default \code{panel}, but when using facets it typically #' takes the form \code{panel-{col}-{row}}, but not for wrapped facets. #' Either print result from \code{\link[ggplot2]{ggplotGrob}} or use -#' \code{\link{gtable_show_names}} to display all the names of the gtable +#' \code{\link{gtable_show_names}} to display all the names of the gtable #' object. #' #' \code{panel} takes multiple names, and will then use these components' #' extremes for placing the legend. -#' +#' #' If \code{panel} is an integer vector of length 2 or 4, these elements are #' used directly for top-left and bottom-right coordinates. #' @@ -291,7 +290,7 @@ arrangeGrob <- gridExtra::arrangeGrob #' @param offset Numeric vector, sets distance from edge of panel. #' First element for horisontal distance, second for vertical. #' Not used by arguments \code{x} and \code{y}. -#' @param name,clip,z Parameters forwarded to +#' @param name,clip,z Parameters forwarded to #' \code{\link[gtable]{gtable_add_grob}}. #' @param plot Logical, when \code{TRUE} (default), draws plot with legend #' repositioned on a new page. @@ -301,6 +300,7 @@ arrangeGrob <- gridExtra::arrangeGrob #' @import ggplot2 grid gridExtra gtable #' @author Stefan McKinnon Edwards #' @seealso \code{\link{g_legend}}, \code{\link{grid_arrange_shared_legend}} +#' and \code{\link{gtable_show_names}} for displaying names of facet's panels. #' @export #' @examples #' library(ggplot2) @@ -317,7 +317,7 @@ arrangeGrob <- gridExtra::arrangeGrob #' reposition_legend(d + theme(legend.position='bottom'), x=0.3, y=0, just=c(0, -0.5)) #' #' # For using with facets: -#' reposition_legend(d + facet_grid(.~cut), 'top left', panel = 'panel-3-1') +#' reposition_legend(d + facet_grid(.~cut), 'top left', panel = 'panel-1-5') reposition_legend <- function(aplot, position=NULL, legend=NULL, @@ -352,7 +352,7 @@ reposition_legend <- function(aplot, 'right' = c(x=1, y=0.5), 'center' = c(x=0.5, y=0.5) ) - if (is.null(x)) x = unit(just[1], 'npc') + offset[1] * + if (is.null(x)) x = unit(just[1], 'npc') + offset[1] * ifelse(grepl('right', position), -1, ifelse(grepl('left', position), 1, 0)) if (is.null(y)) y = unit(just[2], 'npc') + offset[2] * ifelse(grepl('top', position), -1, ifelse(grepl('bottom', position), 1, 0)) @@ -389,10 +389,10 @@ reposition_legend <- function(aplot, } name <- paste(name, add, sep='-') } - + legend$vp <- viewport(x=x, y=y, just=just, width=sum(legend$widths), height=sum(legend$heights)) legend$name <- name - + # Place legend *under* the lowest axis-line, if z is Inf if (is.infinite(z)) { axes <- grepl('axis', aplot$layout$name) @@ -401,17 +401,17 @@ reposition_legend <- function(aplot, .z <- z } .clip <- clip - + if (is.character(panel)) { pn <- which(aplot$layout$name %in% panel) if (length(pn) == 0) stop('Could not find panel named `',panel,'`.') - - aplot <- with(aplot$layout[pn,], - gtable_add_grob(aplot, - legend, - t = min(t), - l = min(l), - r = max(r), + + aplot <- with(aplot$layout[pn,], + gtable_add_grob(aplot, + legend, + t = min(t), + l = min(l), + r = max(r), b = max(b), z = .z, clip = .clip, @@ -419,18 +419,18 @@ reposition_legend <- function(aplot, )) } else if ((is.numeric(panel) | is.integer(panel)) & length(panel) %in% c(2,4)) { panel <- rep(as.integer(panel), length.out=4) - aplot <- gtable_add_grob(aplot, - legend, - t = panel[1], - l = panel[2], - b = panel[3], - r = panel[4], + aplot <- gtable_add_grob(aplot, + legend, + t = panel[1], + l = panel[2], + b = panel[3], + r = panel[4], z = .z, clip = .clip, name = legend$name ) } - + if (plot) { grid.newpage() grid.draw(aplot) diff --git a/R/lemon-plot.r b/R/lemon-plot.r index 28e00ec..174634b 100644 --- a/R/lemon-plot.r +++ b/R/lemon-plot.r @@ -13,23 +13,23 @@ NULL # Adds a classname to an object, if it does not already have it. prependClass <- function(object, new_class) { -if (!inherits(object, new_class)) +if (!inherits(object, new_class)) class(object) <- c(new_class, class(object)) object } #' Lemon plots; ggplots with extended functionality. -#' +#' #' Lemon plot basically hijacks ggplot2's building process and allows us #' to change some things. Used by \code{\link{annotate_y_axis}}. -#' +#' #' @param plot ggplot object #' @keywords internal #' @export #' @rdname lemon_plot as.lemon_plot <- function(plot) { - if (inherits(plot, 'lemon_plot')) + if (inherits(plot, 'lemon_plot')) return(plot) if (!'axis_annotation' %in% names(plot)) plot$axis_annotation <- axis_annotation_list() @@ -40,7 +40,7 @@ as.lemon_plot <- function(plot) { #' @rdname lemon_plot #' @export ggplot_build.lemon_plot <- function(plot) { - g_built <- NextMethod() + g_built <- NextMethod() prependClass(g_built, 'built_lemon') } @@ -50,20 +50,19 @@ ggplot_build.lemon_plot <- function(plot) { #' @export ggplot_gtable.built_lemon <- function(data) { gtable <- NextMethod() - - if ('axis_annotation' %in% names(data$plot) && + + if ('axis_annotation' %in% names(data$plot) && data$plot$axis_annotation$n('y') > 0) { - #right g <- data$plot$axis_annotation$draw( - side='right', - is.primary=get_panel_params(data$layout, 1)$y.arrange[2] == 'primary', - range=get_panel_y_range(data$layout, 1), + side='right', + is.primary=get_panel_params(data$layout, 1)$y$position == "right", + range=get_panel_y_range(data$layout, 1), theme=plot_theme(data$plot$theme) ) if (!all(sapply(g$children, is.zero))) { i <- which(gtable$layout$name == 'axis-r') - gtable <- gtable::gtable_add_grob(gtable, g, + gtable <- gtable::gtable_add_grob(gtable, g, t = gtable$layout$t[i], l = gtable$layout$l[i], r = gtable$layout$l[i], @@ -71,19 +70,19 @@ ggplot_gtable.built_lemon <- function(data) { name='axis2-r', clip='off') widths <- lapply(g$children[[2]]$grobs, grid::grobWidth) - gtable$widths[[gtable$layout$l[i]]] <- do.call(grid::unit.pmax, c(widths, gtable$widths[gtable$layout$l[i]])) + gtable$widths[[gtable$layout$l[i]]] <- Reduce(grid::unit.pmax, widths, gtable$widths[gtable$layout$l[i]]) } - + #left g <- data$plot$axis_annotation$draw( - side='left', - is.primary=get_panel_params(data$layout, 1)$y.arrange[1] == 'primary', - range=get_panel_y_range(data$layout, 1), + side='left', + is.primary=get_panel_params(data$layout, 1)$y$position == "left", + range=get_panel_y_range(data$layout, 1), theme=plot_theme(data$plot$theme) ) if (!all(sapply(g$children, is.zero))) { i <- which(gtable$layout$name == 'axis-l') - gtable <- gtable::gtable_add_grob(gtable, g, + gtable <- gtable::gtable_add_grob(gtable, g, t = gtable$layout$t[i], l = gtable$layout$l[i], r = gtable$layout$l[i], @@ -91,23 +90,23 @@ ggplot_gtable.built_lemon <- function(data) { name='axis2-l', clip='off') widths <- lapply(g$children[[2]]$grobs, grid::grobWidth) - gtable$widths[[gtable$layout$l[i]]] <- do.call(grid::unit.pmax, c(widths, gtable$widths[gtable$layout$l[i]])) + gtable$widths[[gtable$layout$l[i]]] <- Reduce(grid::unit.pmax, widths, gtable$widths[gtable$layout$l[i]]) } - + } - + if ('axis_annotation' %in% names(data$plot) && data$plot$axis_annotation$n('x') > 0) { # top g <- data$plot$axis_annotation$draw( - side='top', - is.primary=get_panel_params(data$layout, 1)$x.arrange[1] == 'primary', - range=get_panel_x_range(data$layout, 1), + side='top', + is.primary=get_panel_params(data$layout, 1)$x$position == "top", + range=get_panel_x_range(data$layout, 1), theme=plot_theme(data$plot$theme) ) if (!all(sapply(g$children, is.zero))) { i <- which(gtable$layout$name == 'axis-t') - gtable <- gtable::gtable_add_grob(gtable, g, + gtable <- gtable::gtable_add_grob(gtable, g, t = gtable$layout$t[i], l = gtable$layout$l[i], r = gtable$layout$l[i], @@ -115,19 +114,19 @@ ggplot_gtable.built_lemon <- function(data) { name='axis2-t', clip='off') heights <- lapply(g$children[[2]]$grobs, grid::grobHeight) - gtable$heights[[gtable$layout$l[i]]] <- do.call(grid::unit.pmax, c(heights, gtable$heights[gtable$layout$l[i]])) + gtable$heights[[gtable$layout$l[i]]] <- Reduce(grid::unit.pmax, heights, gtable$heights[gtable$layout$l[i]]) } - + # bottom g <- data$plot$axis_annotation$draw( - side='bottom', - is.primary=get_panel_params(data$layout, 1)$x.arrange[2] == 'primary', - range=get_panel_x_range(data$layout, 1), + side='bottom', + is.primary=get_panel_params(data$layout, 1)$x$position == "bottom", + range=get_panel_x_range(data$layout, 1), theme=plot_theme(data$plot$theme) ) if (!all(sapply(g$children, is.zero))) { i <- which(gtable$layout$name == 'axis-b') - gtable <- gtable::gtable_add_grob(gtable, g, + gtable <- gtable::gtable_add_grob(gtable, g, t = gtable$layout$t[i], l = gtable$layout$l[i], r = gtable$layout$l[i], @@ -135,9 +134,9 @@ ggplot_gtable.built_lemon <- function(data) { name='axis2-b', clip='off') heights <- lapply(g$children[[2]]$grobs, grid::grobHeight) - gtable$heights[[gtable$layout$l[i]]] <- do.call(grid::unit.pmax, c(heights, gtable$heights[gtable$layout$l[i]])) + gtable$heights[[gtable$layout$l[i]]] <- Reduce(grid::unit.pmax, heights, gtable$heights[gtable$layout$l[i]]) } - + } gtable } @@ -149,4 +148,4 @@ ggplot_gtable.built_lemon <- function(data) { #' plot$scales$add(object) #' plot <- prependClass(plot, 'lemon_plot') #' plot -#' } \ No newline at end of file +#' } diff --git a/R/lemon_print.r b/R/lemon_print.r index d09e108..e437866 100644 --- a/R/lemon_print.r +++ b/R/lemon_print.r @@ -4,12 +4,12 @@ #' Convenience function for working with R Notebooks that ensures data frames #' (and dplyr tables) are printed with \code{\link[knitr]{kable}} while #' allowing RStudio to render the data frame dynamically for inline display. -#' -#' -#' These functions divert data frame and summary output to +#' +#' +#' These functions divert data frame and summary output to #' \code{\link[knitr]{kable}} for nicely printing the output. -#' -#' For \emph{options to \code{kable}}, they can be given directly as +#' +#' For \emph{options to \code{kable}}, they can be given directly as #' chunk-options (see arguments to \code{\link[knitr]{kable}}), or though #' as a list to a special chunk-option \code{kable.opts}. #' @@ -23,25 +23,25 @@ #' data.frame #' ``` #' } -#' -#' \strong{Note:} We are \emph{not} calling the function, +#' +#' \strong{Note:} We are \emph{not} calling the function, #' but instead refering to it. -#' +#' #' An alternate route for specifying \code{\link[knitr]{kable}} arguments is as: -#' +#' #' \preformatted{ #' ```{r render=lemon_print,kable.opts=list(align='l')} #' data.frame #' ``` #' } -#' +#' #' The option \code{kable.opts} takes precendence over arguments given directly #' as chunk-options. -#' -#' +#' +#' #' #' To enable as default printing method for \emph{all chunks}, include -#' +#' #' \preformatted{ #' knit_print.data.frame <- lemon_print #' knit_print.table <- lemon_print @@ -50,7 +50,7 @@ #' knit_print.tbl <- lemon_print #' } #' -#' \strong{Note:} We are \emph{not} calling the function, +#' \strong{Note:} We are \emph{not} calling the function, #' but instead assigning the \code{\link[knitr]{knit_print}} functions #' for some classes. #' @@ -73,7 +73,7 @@ lemon_print <- function(x, options, ...) { UseMethod('lemon_print', x) } -#' @inheritParams lemon_print +# @inheritParams lemon_print #' @export #' @rdname lemon_print lemon_print.data.frame = function(x, options, ...) { @@ -87,22 +87,22 @@ lemon_print.data.frame = function(x, options, ...) { asis_output(res) } -#' @inheritParams lemon_print +# @inheritParams lemon_print #' @export #' @rdname lemon_print lemon_print.table <- function(x, options, ...) { # Do nothing for cross-tabulation tables. if (is.null(dimnames(x))) return(knitr::knit_print(unclass(x), options, ...)) - if (!is.null(names(dimnames(x))) & all(names(dimnames(x)) == '')) + if (!is.null(names(dimnames(x))) & all(names(dimnames(x)) == '')) return(knitr::knit_print(unclass(x), options, ...)) - + # detect if we have a summary if (length(dim(x)) == 2 & all(dimnames(x)[[1]] == '') & all(dimnames(x)[[2]] != '')) { l <- grepl("NA's[ ]+:[[:digit:]]+", x) x[l] <- gsub("NA's", "`NA`s", x[l], fixed=TRUE) x[is.na(x)] <- ' ' - options$`kable.opts` <- merge.list(options$`kable.opts`, - list(row.names=FALSE, + options$`kable.opts` <- merge.list(options$`kable.opts`, + list(row.names=FALSE, align='l')) lemon_print.data.frame(x, options, ...) } else { @@ -113,13 +113,13 @@ lemon_print.table <- function(x, options, ...) { # RCurl::merge.list merge.list <- function (x, y, ...) { - if (length(x) == 0) + if (length(x) == 0) return(y) - if (length(y) == 0) + if (length(y) == 0) return(x) i = match(names(y), names(x)) i = is.na(i) - if (any(i)) + if (any(i)) x[names(y)[which(i)]] = y[which(i)] x -} \ No newline at end of file +} diff --git a/R/scale-symmetric.r b/R/scale-symmetric.r index 5f8a77f..f6fdf9e 100644 --- a/R/scale-symmetric.r +++ b/R/scale-symmetric.r @@ -5,28 +5,28 @@ set_symmetric_scale <- function(sc, mid) { sc$mid <- mid sc$train <- function(self, x) { - if (length(x) == 0) + if (length(x) == 0) return() self$range$train(c(x, 2*self$mid-x)) } - + sc$get_limits <- function(self) { l <- ggplot2::ggproto_parent(ScaleContinuousPosition, self)$get_limits() l2 <- 2*self$mid - rev(l) #str(c(l,l2)) - + c(min(l[1],l2[1]), max(l[2],l2[2])) } - + sc } #' Symmetrix position scale for continuous x and y -#' +#' #' \code{scale_x_symmetric} and \code{scale_y_symmetric} are like the default -#' scales for continuous x and y, but ensures that the resulting scale is +#' scales for continuous x and y, but ensures that the resulting scale is #' centered around \code{mid}. Does not work when setting limits on the scale. -#' +#' #' @param mid Value to center the scale around. #' @param ... Values passed on to \code{\link[ggplot2]{scale_continuous}}. #' @rdname scale_symmetric @@ -36,13 +36,13 @@ set_symmetric_scale <- function(sc, mid) { #' library(ggplot2) #' df <- expand.grid(a=c(-1,0,1), b=c(-1,0,1)) #' rnorm2 <- function(x,y,n,sdx,sdy) { -#' if (missing(sdy)) +#' if (missing(sdy)) #' sdy <- sdx #' data.frame(a=x,b=y,x=rnorm(n,x,sdx), y=rnorm(n,y,sdy)) #' } #' df <- mapply(rnorm2,df$a, df$b, MoreArgs=list(n=30,sdx=1),SIMPLIFY=FALSE) #' df <- do.call(rbind, df) -#' (p <- ggplot(df, aes(x=x,y=y)) + geom_point() + +#' (p <- ggplot(df, aes(x=x,y=y)) + geom_point() + #' facet_grid(a~b, scales='free_x') #' ) #' p + scale_x_symmetric(mid=0) @@ -52,7 +52,7 @@ scale_x_symmetric <- function(mid=0, ...) { #' @rdname scale_symmetric #' @export -#' @inheritParams scale_x_symmetric +# @inheritParams scale_x_symmetric scale_y_symmetric <- function(mid=0, ...) { set_symmetric_scale(ggplot2::scale_y_continuous(...), mid=mid) } @@ -64,17 +64,17 @@ scale_y_symmetric <- function(mid=0, ...) { #' #' @export #' #' @import ggplot2 #' #' @import scales -#' ScaleContinuousPositionSymmetric <- ggproto("ScaleContinuousPositionSymmetric", +#' ScaleContinuousPositionSymmetric <- ggproto("ScaleContinuousPositionSymmetric", #' `_inherit`=ggplot2::ScaleContinuousPosition, -#' +#' #' range = ggplot2:::continuous_range(), #' na.value = NA_real_, #' rescaler = scales::rescale, # Used by diverging and n colour gradients x #' oob = scales::censor, #' minor_breaks = waiver(), -#' +#' #' is_discrete = function() FALSE, -#' +#' #' train = function(self, x) { #' if (length(x) == 0) return() #' self$range$train(x) diff --git a/README.Rmd b/README.Rmd index f1ed1a0..790c7f7 100644 --- a/README.Rmd +++ b/README.Rmd @@ -171,7 +171,7 @@ The legend repositioned onto the top left corner of the panel. Scavenging the Internet, we have found some functions that help work with legends. -Frequently appearing on [Stack Overflow](http://stackoverflow.com), we bring +Frequently appearing on [Stack Overflow](https://stackoverflow.com), we bring you `g_legend`: ```{r g_legend,fig.height=3,fig.width=2} library(grid) diff --git a/README.md b/README.md index 323cd57..f0c36f2 100644 --- a/README.md +++ b/README.md @@ -103,7 +103,7 @@ reposition_legend(d, 'top left') Scavenging the Internet, we have found some functions that help work with legends. -Frequently appearing on [Stack Overflow](http://stackoverflow.com), we bring you `g_legend`: +Frequently appearing on [Stack Overflow](https://stackoverflow.com), we bring you `g_legend`: ``` r library(grid) diff --git a/TODO b/TODO deleted file mode 100644 index ee9ff3b..0000000 --- a/TODO +++ /dev/null @@ -1,2 +0,0 @@ -Add curly brackets to the axis-brackets. -See package https://cran.r-project.org/web/packages/pBrackets/index.html for drawing braces. diff --git a/man/annotate_axis.Rd b/man/annotate_axis.Rd index 3f7a864..1ff59fe 100644 --- a/man/annotate_axis.Rd +++ b/man/annotate_axis.Rd @@ -3,13 +3,29 @@ \name{annotate_y_axis} \alias{annotate_y_axis} \alias{annotate_x_axis} -\title{Annotations in the axis} +\title{Annotations on the axis} \usage{ -annotate_y_axis(label, y, side = waiver(), print_label = TRUE, - print_value = TRUE, print_both = TRUE, parsed = FALSE, ...) - -annotate_x_axis(label, x, side = waiver(), print_label = TRUE, - print_value = TRUE, print_both = TRUE, parsed = FALSE, ...) +annotate_y_axis( + label, + y, + side = waiver(), + print_label = TRUE, + print_value = TRUE, + print_both = TRUE, + parsed = FALSE, + ... +) + +annotate_x_axis( + label, + x, + side = waiver(), + print_label = TRUE, + print_value = TRUE, + print_both = TRUE, + parsed = FALSE, + ... +) } \arguments{ \item{label}{Text to print} @@ -20,20 +36,20 @@ annotate_x_axis(label, x, side = waiver(), print_label = TRUE, \item{print_label, print_value, print_both}{Logical; what to show on annotation. Label and/or value. \code{print_both} is shortcut for setting both \code{print_label} and -\code{print_value}. When both is TRUE, uses argument \code{sep} to +\code{print_value}. When both is TRUE, uses argument \code{sep} to separate the label and value.} -\item{parsed}{Logical (default \code{FALSE}), -when \code{TRUE}, uses mathplot for outputting expressions. +\item{parsed}{Logical (default \code{FALSE}), +when \code{TRUE}, uses mathplot for outputting expressions. See section "Showing values".} -\item{...}{Style settings for label and tick: -colour, hjust, vjust, size, fontface, family, rot. +\item{...}{Style settings for label and tick: +colour, hjust, vjust, size, fontface, family, rot. When \code{waiver()} (default), the relevant theme element is used.} } \description{ -Annotations in the axis +Annotations on the axis } \section{}{ Showing values: @@ -71,6 +87,6 @@ p <- p + theme_light() + theme(panel.border=element_blank(), axis.line = element_line(), axis.ticks = element_line(colour='black')) p + coord_capped_cart(bottom='right') + - annotate_y_axis('More than I\\ncan afford', y=125, + annotate_y_axis('More than I\ncan afford', y=125, print_value=FALSE, tick=TRUE) } diff --git a/man/brackets.Rd b/man/brackets.Rd index 0694e27..1f70f4b 100644 --- a/man/brackets.Rd +++ b/man/brackets.Rd @@ -6,11 +6,17 @@ \alias{brackets_vertical} \title{Axis brackets instead of axis ticks and lines} \usage{ -brackets_horizontal(direction = c("up", "down"), length = unit(0.05, - "npc"), tick.length = waiver()) +brackets_horizontal( + direction = c("up", "down"), + length = unit(0.05, "npc"), + tick.length = waiver() +) -brackets_vertical(direction = c("left", "right"), length = unit(0.05, - "npc"), tick.length = waiver()) +brackets_vertical( + direction = c("left", "right"), + length = unit(0.05, "npc"), + tick.length = waiver() +) } \arguments{ \item{direction}{Which way should the opening side of the brackets point? diff --git a/man/coord_capped.Rd b/man/coord_capped.Rd index 5f8e6df..a1025cb 100644 --- a/man/coord_capped.Rd +++ b/man/coord_capped.Rd @@ -8,19 +8,31 @@ \alias{capped_vertical} \title{Cartesian coordinates with capped axis lines.} \usage{ -coord_capped_cart(xlim = NULL, ylim = NULL, expand = TRUE, - top = waiver(), left = waiver(), bottom = waiver(), - right = waiver(), gap = 0.01) +coord_capped_cart( + xlim = NULL, + ylim = NULL, + expand = TRUE, + top = waiver(), + left = waiver(), + bottom = waiver(), + right = waiver(), + gap = 0.01 +) -coord_capped_flip(xlim = NULL, ylim = NULL, expand = TRUE, - top = waiver(), left = waiver(), bottom = waiver(), - right = waiver(), gap = 0.01) +coord_capped_flip( + xlim = NULL, + ylim = NULL, + expand = TRUE, + top = waiver(), + left = waiver(), + bottom = waiver(), + right = waiver(), + gap = 0.01 +) -capped_horizontal(capped = c("both", "left", "right", "none"), - gap = 0.01) +capped_horizontal(capped = c("both", "left", "right", "none"), gap = 0.01) -capped_vertical(capped = c("top", "bottom", "both", "none"), - gap = 0.01) +capped_vertical(capped = c("top", "bottom", "both", "none"), gap = 0.01) } \arguments{ \item{xlim, ylim}{Limits for the x and y axes.} diff --git a/man/coord_flex.Rd b/man/coord_flex.Rd index d4400ed..7323b52 100644 --- a/man/coord_flex.Rd +++ b/man/coord_flex.Rd @@ -6,17 +6,36 @@ \alias{coord_flex_fixed} \title{Cartesian coordinates with flexible options for drawing axes} \usage{ -coord_flex_cart(xlim = NULL, ylim = NULL, expand = TRUE, - top = waiver(), left = waiver(), bottom = waiver(), - right = waiver()) - -coord_flex_flip(xlim = NULL, ylim = NULL, expand = TRUE, - top = waiver(), left = waiver(), bottom = waiver(), - right = waiver()) - -coord_flex_fixed(ratio = 1, xlim = NULL, ylim = NULL, - expand = TRUE, top = waiver(), left = waiver(), - bottom = waiver(), right = waiver()) +coord_flex_cart( + xlim = NULL, + ylim = NULL, + expand = TRUE, + top = waiver(), + left = waiver(), + bottom = waiver(), + right = waiver() +) + +coord_flex_flip( + xlim = NULL, + ylim = NULL, + expand = TRUE, + top = waiver(), + left = waiver(), + bottom = waiver(), + right = waiver() +) + +coord_flex_fixed( + ratio = 1, + xlim = NULL, + ylim = NULL, + expand = TRUE, + top = waiver(), + left = waiver(), + bottom = waiver(), + right = waiver() +) } \arguments{ \item{xlim, ylim}{Limits for the x and y axes.} diff --git a/man/dot.Rd b/man/dot.Rd index 9ce017d..4c17030 100644 --- a/man/dot.Rd +++ b/man/dot.Rd @@ -5,15 +5,14 @@ \alias{.dot2} \title{Create paths that are safe from changing working directory.} \usage{ -.dot(x, root = getwd(), mustExist = FALSE, relative = FALSE, - create = TRUE) +.dot(x, root = getwd(), mustExist = FALSE, relative = FALSE, create = TRUE) .dot2(names, quiet = FALSE, ...) } \arguments{ \item{x}{File path that is appended to \code{BASEDIR}.} -\item{root}{Root of your working directory, +\item{root}{Root of your working directory, from which \code{x} is relative too.} \item{mustExist}{Logical value; if \code{TRUE} and the resulting path does @@ -32,22 +31,22 @@ returns a path relative to \code{root}.} \item{...}{Arguments passed on to \code{.dot}.} } \value{ -A function that returns file paths constructed from +A function that returns file paths constructed from \code{root}, \code{x}, and \code{...}. - + \emph{Side effect:} It creates the directory. } \description{ -The \code{.dot} functions creates functions that allows relative-like +The \code{.dot} functions creates functions that allows relative-like specification of paths, but are safe from changing working directory. } \examples{ -.data <- .dot('data') +.data <- .dot('data', create=FALSE) .data('input.txt') .data(c('a.txt','b.txt')) -.dot2(c('rawdata','results')) +.dot2(c('rawdata','results'), create=FALSE) .rawdata('rawfile.csv') .results('myresults.txt') } diff --git a/man/facet_rep.Rd b/man/facet_rep.Rd index 35ff9e8..72f3f50 100644 --- a/man/facet_rep.Rd +++ b/man/facet_rep.Rd @@ -27,7 +27,7 @@ with axis lines and labels preserved on all panels. } \details{ These two functions are extensions to \code{\link[ggplot2]{facet_grid}} -and \code{\link[ggplot2]{facet_wrap}} that keeps axis lines, ticks, and +and \code{\link[ggplot2]{facet_wrap}} that keeps axis lines, ticks, and optionally tick labels across all panels. Examples are given in the vignette \href{../doc/facet-rep-labels.html}{"Repeat axis lines on facet panels" vignette}. diff --git a/man/geom_pointpath.Rd b/man/geom_pointpath.Rd index 53009ec..f0e7867 100644 --- a/man/geom_pointpath.Rd +++ b/man/geom_pointpath.Rd @@ -6,25 +6,66 @@ \alias{geom_pointrangeline} \title{Connected points} \usage{ -geom_pointpath(mapping = NULL, data = NULL, stat = "identity", - position = "identity", na.rm = FALSE, show.legend = NA, - inherit.aes = TRUE, distance = unit(3, "pt"), shorten = 0.5, - threshold = 0.1, lineend = "butt", linejoin = "round", - linemitre = 1, linesize = 0.5, linecolour = waiver(), - linecolor = waiver(), arrow = NULL, ...) - -geom_pointline(mapping = NULL, data = NULL, stat = "identity", - position = "identity", na.rm = FALSE, show.legend = NA, - inherit.aes = TRUE, distance = unit(3, "pt"), shorten = 0.5, - threshold = 0.1, lineend = "butt", linejoin = "round", - linemitre = 1, linesize = 0.5, linecolour = waiver(), - linecolor = waiver(), arrow = NULL, ...) - -geom_pointrangeline(mapping = NULL, data = NULL, stat = "identity", - position = "identity", na.rm = FALSE, show.legend = NA, - inherit.aes = TRUE, distance = unit(3, "pt"), lineend = "butt", - linejoin = "round", linemitre = 1, linesize = 0.5, - linecolour = waiver(), linecolor = waiver(), arrow = NULL, ...) +geom_pointpath( + mapping = NULL, + data = NULL, + stat = "identity", + position = "identity", + na.rm = FALSE, + show.legend = NA, + inherit.aes = TRUE, + distance = unit(3, "pt"), + shorten = 0.5, + threshold = 0.1, + lineend = "butt", + linejoin = "round", + linemitre = 1, + linesize = 0.5, + linecolour = waiver(), + linecolor = waiver(), + arrow = NULL, + ... +) + +geom_pointline( + mapping = NULL, + data = NULL, + stat = "identity", + position = "identity", + na.rm = FALSE, + show.legend = NA, + inherit.aes = TRUE, + distance = unit(3, "pt"), + shorten = 0.5, + threshold = 0.1, + lineend = "butt", + linejoin = "round", + linemitre = 1, + linesize = 0.5, + linecolour = waiver(), + linecolor = waiver(), + arrow = NULL, + ... +) + +geom_pointrangeline( + mapping = NULL, + data = NULL, + stat = "identity", + position = "identity", + na.rm = FALSE, + show.legend = NA, + inherit.aes = TRUE, + distance = unit(3, "pt"), + lineend = "butt", + linejoin = "round", + linemitre = 1, + linesize = 0.5, + linecolour = waiver(), + linecolor = waiver(), + arrow = NULL, + ... +) } \arguments{ \item{mapping}{Set of aesthetic mappings created by \code{\link[ggplot2]{aes}} @@ -32,13 +73,13 @@ or \code{\link[ggplot2]{aes_}}.} \item{data}{The data to be displayed in this layer.} -\item{stat}{The statistical transformation to use on the data for this layer, +\item{stat}{The statistical transformation to use on the data for this layer, as a string.} -\item{position}{Position adjustment, either as a string, or the result of a +\item{position}{Position adjustment, either as a string, or the result of a call to a position adjustment function (e.g. \code{\link[ggplot2]{position_jitter}}). -Both lines and points gets the same adjustment +Both lines and points gets the same adjustment (\emph{this} is where the function excels over \code{geom_point() + geom_line()}).} \item{na.rm}{If \code{FALSE} (default), missing values are removed with a warning. @@ -50,7 +91,7 @@ If \code{TRUE}, missing values are silently removed.} \item{inherit.aes}{If \code{FALSE}, overrides the default aesthetic, rather than combining with them. This is most useful for helper functions that -define both data and aesthetics and shouldn't inherit behaviour from the +define both data and aesthetics and shouldn't inherit behaviour from the default plot specification.} \item{distance}{Gap size between point and end of lines; @@ -70,7 +111,7 @@ a gap by \code{distance}.} \item{linesize}{Width of of line.} -\item{linecolour, linecolor}{When not \code{waiver()}, the line is drawn with +\item{linecolour, linecolor}{When not \code{waiver()}, the line is drawn with this colour instead of that set by aesthetic \code{colour}.} \item{arrow}{Arrow specification, as created by \code{\link[grid]{arrow}}.} @@ -78,7 +119,7 @@ this colour instead of that set by aesthetic \code{colour}.} \item{...}{other arguments passed on to \code{\link[ggplot2]{layer}}.} } \description{ -\code{geom_pointpath} combines \code{\link[ggplot2]{geom_point}} and +\code{geom_pointpath} combines \code{\link[ggplot2]{geom_point}} and \code{\link[ggplot2]{geom_path}}, such that a) when jittering is used, both lines and points stay connected, and b) provides a visual effect by adding a small gap between the point and the end of line. @@ -90,26 +131,26 @@ by adding a small gap between the point and the end of line. they appear in the data. \code{geom_pointline} connects them in order of the variable on the x-axis. -Both \code{geom_pointpath} and \code{geom_pointline} will only +Both \code{geom_pointpath} and \code{geom_pointline} will only connect observations within the same group! However, if \code{linecolour} is \emph{not} \code{waiver()}, connections will be made between groups, but possible in an incorrect order. } \section{Aesthetics}{ -\code{geom_pointline} and \code{geom_pointpath} understands the following +\code{geom_pointline} and \code{geom_pointpath} understands the following aesthetics (required aesthetics are in bold): \itemize{ \item \strong{x} \item \strong{y} \item alpha - \item colour -- sets colour of point. Only affects line if \code{linecolour=waiver()}. + \item colour -- sets colour of point. Only affects line if \code{linecolour=waiver()}. \item stroke \item shape \item stroke \item group \item linetype - \item size -- only affects point size. Width of line is set with + \item size -- only affects point size. Width of line is set with \code{linesize} and cannot be linked to an aesthetic. } } diff --git a/man/geom_siderange.Rd b/man/geom_siderange.Rd index 2d570fe..83e2d17 100644 --- a/man/geom_siderange.Rd +++ b/man/geom_siderange.Rd @@ -4,10 +4,22 @@ \alias{geom_siderange} \title{Display range of data in side of plot} \usage{ -geom_siderange(mapping = NULL, data = NULL, stat = "identity", - position = "identity", ..., distance = 3, arrow = NULL, - lineend = "butt", sides = "bl", start = NA, end = NA, - na.rm = FALSE, show.legend = NA, inherit.aes = TRUE) +geom_siderange( + mapping = NULL, + data = NULL, + stat = "identity", + position = "identity", + ..., + distance = 3, + arrow = NULL, + lineend = "butt", + sides = "bl", + start = NA, + end = NA, + na.rm = FALSE, + show.legend = NA, + inherit.aes = TRUE +) } \arguments{ \item{mapping}{Set of aesthetic mappings created by \code{\link[ggplot2]{aes}} @@ -15,18 +27,18 @@ or \code{\link[ggplot2]{aes_}}.} \item{data}{The data to be displayed in this layer.} -\item{stat}{The statistical transformation to use on the data for this layer, +\item{stat}{The statistical transformation to use on the data for this layer, as a string.} -\item{position}{Position adjustment, either as a string, or the result of a +\item{position}{Position adjustment, either as a string, or the result of a call to a position adjustment function (e.g. \code{\link[ggplot2]{position_jitter}}). -Both lines and points gets the same adjustment +Both lines and points gets the same adjustment (\emph{this} is where the function excels over \code{geom_point() + geom_line()}).} \item{...}{other arguments passed on to \code{\link[ggplot2]{layer}}.} -\item{distance}{Distance between edge of panel and lines, and distance +\item{distance}{Distance between edge of panel and lines, and distance between lines, in multiples of line widths, see description.} \item{arrow}{Arrow specification, as created by \code{\link[grid]{arrow}}.} @@ -36,7 +48,7 @@ between lines, in multiples of line widths, see description.} \item{sides}{Character including \strong{t}op, \strong{r}ight, \strong{b}ottom, and/or \strong{l}eft, indicating which side to project data onto.} -\item{start, end}{Adds a symbol to either end of the siderange. +\item{start, end}{Adds a symbol to either end of the siderange. \code{start} corresponds to minimal value, \code{end} to maximal value.} \item{na.rm}{If \code{FALSE} (default), missing values are removed with a warning. @@ -48,7 +60,7 @@ If \code{TRUE}, missing values are silently removed.} \item{inherit.aes}{If \code{FALSE}, overrides the default aesthetic, rather than combining with them. This is most useful for helper functions that -define both data and aesthetics and shouldn't inherit behaviour from the +define both data and aesthetics and shouldn't inherit behaviour from the default plot specification.} } \description{ @@ -63,13 +75,13 @@ of the line, and lines are offset from the edge and each other. To display a symbol, specify an integer for either \code{start} or \code{end}. See the list for \code{pch} in \code{\link[graphics]{points}} for values to use. The argumetns \code{start} and \code{end} also accepts a list object with -named entries \code{pch}, \code{alpha}, \code{stroke}, and \code{fill}, which -correspond to the usual aesthetics, as well as a special named entry, +named entries \code{pch}, \code{alpha}, \code{stroke}, and \code{fill}, which +correspond to the usual aesthetics, as well as a special named entry, \code{sizer} (note the extra 'r'). -This last entry is a multiplier for enlarging the symbol relative to the +This last entry is a multiplier for enlarging the symbol relative to the linewidth, as the aesthetic \code{size} affects both linewidth and symbol size. -The distance between the panel's edge and sideranges are specified by +The distance between the panel's edge and sideranges are specified by the argument \code{distance}. If a symbol is specified, the linewidth is further expanded to cover the width of the symbol (including \code{sizer}). } diff --git a/man/grid_arrange_shared_legend.Rd b/man/grid_arrange_shared_legend.Rd index 4910dca..c7c0b12 100644 --- a/man/grid_arrange_shared_legend.Rd +++ b/man/grid_arrange_shared_legend.Rd @@ -4,14 +4,19 @@ \alias{grid_arrange_shared_legend} \title{Share a legend between multiple plots} \usage{ -grid_arrange_shared_legend(..., ncol = length(list(...)), nrow = 1, - position = c("bottom", "right", "top", "left"), plot = TRUE) +grid_arrange_shared_legend( + ..., + ncol = length(list(...)), + nrow = 1, + position = c("bottom", "right", "top", "left"), + plot = TRUE +) } \arguments{ -\item{...}{Objects to plot. First argument should be a ggplot2 object, +\item{...}{Objects to plot. First argument should be a ggplot2 object, as the legend is extracted from this. -Other arguments are passed on to -\code{\link[gridExtra]{arrangeGrob}}, +Other arguments are passed on to +\code{\link[gridExtra]{arrangeGrob}}, including named arguments that are not defined for \code{grid_arrange_shared_legend}. ggplot2 objects have their legends hidden.} @@ -25,11 +30,11 @@ ggplot2 objects have their legends hidden.} new page.} } \value{ -gtable of combined plot, invisibly. +gtable of combined plot, invisibly. Draw gtable object using \code{\link[grid]{grid.draw}}. } \description{ -Extract legend, combines plots using \code{\link[gridExtra]{arrangeGrob}} / +Extract legend, combines plots using \code{\link[gridExtra]{arrangeGrob}} / \code{grid.arrange}, and places legend in a margin. } @@ -49,8 +54,8 @@ grid_arrange_shared_legend(p1, gridExtra::arrangeGrob(p2, p3, p4, ncol=3), ncol= # We can also pass on named arguments to arrangeGrob: title <- grid::textGrob('This is grob', gp=grid::gpar(fontsize=14, fontface='bold')) nt <- theme(legend.position='none') -grid_arrange_shared_legend(p1, - gridExtra::arrangeGrob(p2+nt, p3+nt, p4+nt, ncol=3), ncol=1, nrow=2, +grid_arrange_shared_legend(p1, + gridExtra::arrangeGrob(p2+nt, p3+nt, p4+nt, ncol=3), ncol=1, nrow=2, top=title) } \seealso{ @@ -58,10 +63,10 @@ grid_arrange_shared_legend(p1, } \author{ Originally brought to you by - \href{http://baptiste.github.io/}{Baptiste Auguié} + \href{http://baptiste.github.io/}{Baptiste Auguié} (\url{https://github.com/tidyverse/ggplot2/wiki/Share-a-legend-between-two-ggplot2-graphs}) - and + and \href{http://rpubs.com/sjackman}{Shaun Jackman} - (\href{http://rpubs.com/sjackman/grid_arrange_shared_legend}{original}). + (\href{http://rpubs.com/sjackman/grid_arrange_shared_legend}{original}). Stefan McKinnon Edwards added left and top margins. } diff --git a/man/gtable_show.Rd b/man/gtable_show.Rd index 1a25898..7193d9a 100644 --- a/man/gtable_show.Rd +++ b/man/gtable_show.Rd @@ -7,8 +7,11 @@ \usage{ gtable_show_grill(x, plot = TRUE) -gtable_show_names(x, plot = TRUE, rect.gp = grid::gpar(col = "black", - fill = "white", alpha = 1/4)) +gtable_show_names( + x, + plot = TRUE, + rect.gp = grid::gpar(col = "black", fill = "white", alpha = 1/4) +) } \arguments{ \item{x}{A gtable object. If given a ggplot object, it is converted to a diff --git a/man/guidebox_as_column.Rd b/man/guidebox_as_column.Rd index 58c838e..dd61190 100644 --- a/man/guidebox_as_column.Rd +++ b/man/guidebox_as_column.Rd @@ -17,7 +17,7 @@ Use this argument to select which to use.} \item{add.title}{Does nothing yet.} } \value{ -A \code{\link[gtable]{gtable}} with keys and labels reordered into +A \code{\link[gtable]{gtable}} with keys and labels reordered into a single column and each pair of keys and labels in the same cell. } \description{ @@ -26,7 +26,6 @@ for embedding in e.g. tables. } \examples{ library(ggplot2) -library(dplyr) p <- ggplot(diamonds, aes(x=x, y=y, colour=cut)) + geom_point() guidebox_as_column(p) diff --git a/man/lemon-ggproto.Rd b/man/lemon-ggproto.Rd index e2225d1..28f6c58 100644 --- a/man/lemon-ggproto.Rd +++ b/man/lemon-ggproto.Rd @@ -15,7 +15,9 @@ \alias{GeomPointRangeLine} \alias{GeomSideRange} \title{ggproto classes used in lemon!} -\format{An object of class \code{AAList} (inherits from \code{ggproto}, \code{gg}) of length 6.} +\format{ +An object of class \code{AAList} (inherits from \code{ggproto}, \code{gg}) of length 6. +} \usage{ AAList } diff --git a/man/lemon_print.Rd b/man/lemon_print.Rd index b0f5b03..57f5797 100644 --- a/man/lemon_print.Rd +++ b/man/lemon_print.Rd @@ -25,10 +25,10 @@ Convenience function for working with R Notebooks that ensures data frames allowing RStudio to render the data frame dynamically for inline display. } \details{ -These functions divert data frame and summary output to +These functions divert data frame and summary output to \code{\link[knitr]{kable}} for nicely printing the output. -For \emph{options to \code{kable}}, they can be given directly as +For \emph{options to \code{kable}}, they can be given directly as chunk-options (see arguments to \code{\link[knitr]{kable}}), or though as a list to a special chunk-option \code{kable.opts}. @@ -44,7 +44,7 @@ data.frame ``` } -\strong{Note:} We are \emph{not} calling the function, +\strong{Note:} We are \emph{not} calling the function, but instead refering to it. An alternate route for specifying \code{\link[knitr]{kable}} arguments is as: @@ -58,7 +58,7 @@ data.frame The option \code{kable.opts} takes precendence over arguments given directly as chunk-options. - + To enable as default printing method for \emph{all chunks}, include @@ -70,7 +70,7 @@ To enable as default printing method for \emph{all chunks}, include knit_print.tbl <- lemon_print } -\strong{Note:} We are \emph{not} calling the function, +\strong{Note:} We are \emph{not} calling the function, but instead assigning the \code{\link[knitr]{knit_print}} functions for some classes. diff --git a/man/element_render.Rd b/man/render_gpar.Rd similarity index 84% rename from man/element_render.Rd rename to man/render_gpar.Rd index 8848214..474d21d 100644 --- a/man/element_render.Rd +++ b/man/render_gpar.Rd @@ -1,12 +1,9 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/grob_utils.r -\name{element_render} -\alias{element_render} +\name{render_gpar} \alias{render_gpar} \title{Render a ggplot2 grob or retrieve its gpar object.} \usage{ -element_render(theme, element, ..., name = NULL) - render_gpar(theme, element, ...) } \arguments{ @@ -29,6 +26,4 @@ Helps add the ggplot2-theme's look-and-feel to \code{grid}'s grob objects. \seealso{ \code{\link[ggplot2]{theme}} } -\author{ -\code{element_render} is from ggplot2 source. -} +\keyword{internal} diff --git a/man/reposition_legend.Rd b/man/reposition_legend.Rd index fe03dd0..7eb82b4 100644 --- a/man/reposition_legend.Rd +++ b/man/reposition_legend.Rd @@ -4,10 +4,20 @@ \alias{reposition_legend} \title{Reposition a legend onto a panel} \usage{ -reposition_legend(aplot, position = NULL, legend = NULL, - panel = "panel", x = NULL, y = NULL, just = NULL, - name = "guide-box", clip = "on", offset = c(0, 0), z = Inf, - plot = TRUE) +reposition_legend( + aplot, + position = NULL, + legend = NULL, + panel = "panel", + x = NULL, + y = NULL, + just = NULL, + name = "guide-box", + clip = "on", + offset = c(0, 0), + z = Inf, + plot = TRUE +) } \arguments{ \item{aplot}{a ggplot2 or gtable object.} @@ -28,7 +38,7 @@ this is a ggplot2 object.} \item{just}{'Anchor point' of legend; it is this point of the legend that is placed at the \code{x} and \code{y} coordinates.} -\item{name, clip, z}{Parameters forwarded to +\item{name, clip, z}{Parameters forwarded to \code{\link[gtable]{gtable_add_grob}}.} \item{offset}{Numeric vector, sets distance from edge of panel. @@ -56,18 +66,18 @@ relative in \code{panel} (see below). \code{position} resolves to three variables, \code{x}, \code{y}, and \code{just}. \code{x} and \code{y} is the coordinate in \code{panel}, where the anchorpoint of the legend (set via \code{just}) is placed. -In other words, \code{just='bottom right'} places the bottom right corner of +In other words, \code{just='bottom right'} places the bottom right corner of the legend at coordinates \code{(x,y)}. -The positioning can be set by argument \code{position} alone, which can be -further nudged by setting \code{position}, \code{x}, and \code{y}. +The positioning can be set by argument \code{position} alone, which can be +further nudged by setting \code{position}, \code{x}, and \code{y}. Alternatively, manually positioning can be obtained by setting arguments. \code{x}, \code{y}, and \code{just}. -\emph{Panel} name is by default \code{panel}, but when using facets it typically +\emph{Panel} name is by default \code{panel}, but when using facets it typically takes the form \code{panel-{col}-{row}}, but not for wrapped facets. Either print result from \code{\link[ggplot2]{ggplotGrob}} or use -\code{\link{gtable_show_names}} to display all the names of the gtable +\code{\link{gtable_show_names}} to display all the names of the gtable object. \code{panel} takes multiple names, and will then use these components' @@ -91,10 +101,11 @@ reposition_legend(d + theme(legend.position='bottom'), 'top left') reposition_legend(d + theme(legend.position='bottom'), x=0.3, y=0, just=c(0, -0.5)) # For using with facets: -reposition_legend(d + facet_grid(.~cut), 'top left', panel = 'panel-3-1') +reposition_legend(d + facet_grid(.~cut), 'top left', panel = 'panel-1-5') } \seealso{ \code{\link{g_legend}}, \code{\link{grid_arrange_shared_legend}} + and \code{\link{gtable_show_names}} for displaying names of facet's panels. } \author{ Stefan McKinnon Edwards diff --git a/man/scale_symmetric.Rd b/man/scale_symmetric.Rd index 1bd242e..4753d64 100644 --- a/man/scale_symmetric.Rd +++ b/man/scale_symmetric.Rd @@ -16,20 +16,20 @@ scale_y_symmetric(mid = 0, ...) } \description{ \code{scale_x_symmetric} and \code{scale_y_symmetric} are like the default -scales for continuous x and y, but ensures that the resulting scale is +scales for continuous x and y, but ensures that the resulting scale is centered around \code{mid}. Does not work when setting limits on the scale. } \examples{ library(ggplot2) df <- expand.grid(a=c(-1,0,1), b=c(-1,0,1)) rnorm2 <- function(x,y,n,sdx,sdy) { - if (missing(sdy)) + if (missing(sdy)) sdy <- sdx data.frame(a=x,b=y,x=rnorm(n,x,sdx), y=rnorm(n,y,sdy)) } df <- mapply(rnorm2,df$a, df$b, MoreArgs=list(n=30,sdx=1),SIMPLIFY=FALSE) df <- do.call(rbind, df) -(p <- ggplot(df, aes(x=x,y=y)) + geom_point() + +(p <- ggplot(df, aes(x=x,y=y)) + geom_point() + facet_grid(a~b, scales='free_x') ) p + scale_x_symmetric(mid=0) diff --git a/tests/testthat/_snaps/brackets/brackets-on-all-four-sides.svg b/tests/testthat/_snaps/brackets/brackets-on-all-four-sides.svg new file mode 100644 index 0000000..4a091dc --- /dev/null +++ b/tests/testthat/_snaps/brackets/brackets-on-all-four-sides.svg @@ -0,0 +1,337 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +4 +5 +6 +8 + + + + +20 +30 +40 + + + + + + +20 +30 +40 + + + + +4 +5 +6 +8 +cyl +cyl +hwy +hwy + +class + + + + + + + + + + + + + + +2seater +compact +midsize +minivan +pickup +subcompact +suv +brackets on all four sides + + diff --git a/tests/testthat/_snaps/caps/capped-axes.svg b/tests/testthat/_snaps/caps/capped-axes.svg new file mode 100644 index 0000000..f5c6a7e --- /dev/null +++ b/tests/testthat/_snaps/caps/capped-axes.svg @@ -0,0 +1,131 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +0.050 +0.075 +0.100 + + + + +0.00 +0.25 +0.50 +0.75 +1.00 + + + + + + + + + + + +0 +25 +50 +75 +100 + + + + + + + +10 +15 +20 +25 +30 +35 +Madness scale +mpg +count +capped axes + + diff --git a/tests/testthat/_snaps/facet_aux/facet-rep-grid.svg b/tests/testthat/_snaps/facet_aux/facet-rep-grid.svg new file mode 100644 index 0000000..e397cab --- /dev/null +++ b/tests/testthat/_snaps/facet_aux/facet-rep-grid.svg @@ -0,0 +1,1045 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +4 + + + + + + + + + + +5 + + + + + + + + + + +6 + + + + + + + + + + +8 + + + + + + + + + + +4 + + + + + + + + + + +f + + + + + + + + + + +r + + + + + + + + + +2 +3 +4 +5 +6 +7 + + + + + + + +2 +3 +4 +5 +6 +7 + + + + + + + +2 +3 +4 +5 +6 +7 + + + + + + + +2 +3 +4 +5 +6 +7 + +10 +15 +20 +25 +30 +35 + + + + + + + +10 +15 +20 +25 +30 +35 + + + + + + + +10 +15 +20 +25 +30 +35 + + + + + + + +10 +15 +20 +25 +30 +35 + + + + + + + + + + + + + +2 +3 +4 +5 +6 +7 + +10 +15 +20 +25 +30 +35 + + + + + + + + + + + + + +2 +3 +4 +5 +6 +7 + +10 +15 +20 +25 +30 +35 + + + + + + + +10 +15 +20 +25 +30 +35 + + + + + + + + + + + + + +2 +3 +4 +5 +6 +7 + +10 +15 +20 +25 +30 +35 + + + + + + + + + + + + + +2 +3 +4 +5 +6 +7 + +10 +15 +20 +25 +30 +35 + + + + + + + +10 +15 +20 +25 +30 +35 + + + + + + + + + + + + + +2 +3 +4 +5 +6 +7 + +10 +15 +20 +25 +30 +35 + + + + + + + + + + + + + +2 +3 +4 +5 +6 +7 + +10 +15 +20 +25 +30 +35 + + + + + + + + + + + + + +2 +3 +4 +5 +6 +7 + + + + + + + +2 +3 +4 +5 +6 +7 +displ +cty +facet_rep_grid + + diff --git a/tests/testthat/_snaps/facet_aux/facet-rep-wrap.svg b/tests/testthat/_snaps/facet_aux/facet-rep-wrap.svg new file mode 100644 index 0000000..b10cfe1 --- /dev/null +++ b/tests/testthat/_snaps/facet_aux/facet-rep-wrap.svg @@ -0,0 +1,576 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +8 + + + + + + + + + + + + + + + + + + + + + + + + + + + + +4 + + + + + + + + + + +5 + + + + + + + + + + +6 + + + + + + + + + +2 +3 +4 +5 +6 +7 + + + + + + + +2 +3 +4 +5 +6 +7 + + + + + + + +2 +3 +4 +5 +6 +7 + + + + + + + +2 +3 +4 +5 +6 +7 + +10 +15 +20 +25 +30 +35 + + + + + + + +10 +15 +20 +25 +30 +35 + + + + + + + +10 +15 +20 +25 +30 +35 + + + + + + + +10 +15 +20 +25 +30 +35 + + + + + + +displ +cty +facet_rep_wrap + + diff --git a/tests/testthat/test_brackets.R b/tests/testthat/test_brackets.R index e6706f2..a0a0734 100644 --- a/tests/testthat/test_brackets.R +++ b/tests/testthat/test_brackets.R @@ -1,11 +1,12 @@ library(testthat) -library(lemon) +library(vdiffr) +#library(lemon) expect_ggplot <- function(object, class='ggplot', ...) expect_s3_class(object, class=class, ...) my.theme <- theme_light() + - theme(panel.border=element_blank(), - axis.line = element_line(), + theme(panel.border=element_blank(), + axis.line = element_line(), axis.ticks = element_line(colour='black')) dat1 <- data.frame( @@ -17,61 +18,72 @@ dat1 <- data.frame( test_that('Brackets do not produce errors when theme(axis.ticks = element_blank()).', { - p <- ggplot(dat1, aes(gp, y)) + + p <- ggplot(dat1, aes(gp, y)) + geom_point(position=position_jitter(width=0.2, height=0)) + my.theme expect_ggplot(p) - + expect_ggplot( p + coord_capped_cart(bottom=brackets_horizontal()) + theme(axis.ticks = element_blank()) ) - + expect_ggplot( p + coord_capped_cart(bottom=brackets_horizontal()) + theme(axis.ticks.x = element_blank()) ) - + expect_ggplot( p + coord_capped_cart(bottom=brackets_horizontal()) + theme(axis.ticks.y = element_blank()) ) - + expect_ggplot( p + coord_capped_cart(bottom=brackets_horizontal(length=0)) ) - + expect_ggplot( p + coord_capped_cart(bottom=brackets_horizontal(length=0)) + theme(axis.ticks = element_blank()) ) - #p + coord_capped_cart(bottom=brackets_vertical()) + - # theme(axis.ticks = element_blank()) - #Error in unit.c(grobHeight(axis_h$top), unit(aspect_ratio, "null"), grobHeight(axis_h$bottom)) : - # it is invalid to combine 'unit' objects with other types - - expect_ggplot( + + expect_ggplot( p + coord_capped_cart(left=brackets_vertical()) + theme(axis.ticks = element_blank()) ) - - expect_ggplot( + + expect_ggplot( p + coord_capped_cart(left=brackets_vertical()) + theme(axis.ticks.x = element_blank()) ) - + expect_ggplot( p + coord_capped_cart(left=brackets_vertical()) + theme(axis.ticks.y = element_blank()) ) - + expect_ggplot( p + coord_capped_cart(left=brackets_vertical(length=0)) ) - + expect_ggplot( p + coord_capped_cart(left=brackets_vertical(length=0)) + theme(axis.ticks = element_blank()) ) }) + + +test_that('The visual object is still correct', { + data(mpg, package='ggplot2') + p <- ggplot(mpg, aes(cyl, hwy, colour=class)) + + geom_point() + + scale_x_continuous(breaks=c(4,5,6,8), sec.axis=dup_axis()) + + scale_y_continuous(sec.axis=dup_axis()) + + coord_flex_cart(bottom=brackets_horizontal(), + top=brackets_horizontal(direction='down'), + left=brackets_vertical(), + right=brackets_vertical(direction='right')) + + my.theme + expect_doppelganger("brackets on all four sides", p) +}) diff --git a/tests/testthat/test_caps.R b/tests/testthat/test_caps.R index de2db32..1d53ef6 100644 --- a/tests/testthat/test_caps.R +++ b/tests/testthat/test_caps.R @@ -1,5 +1,5 @@ library(testthat) -library(lemon) +library(vdiffr) expect_ggplot <- function(object, class='ggplot', ...) expect_s3_class(object, class=class, ...) @@ -9,7 +9,7 @@ test_that('Capped axes returns functions and have attributes', { expect_is(ch, 'function', info=paste('capped is', g)) expect_equal(attr(ch, 'orientation', exact=TRUE), 'horizontal') } - + for (g in c('both','top','bottom','none')) { ch <- capped_vertical(g) expect_is(ch, 'function', info=paste('capped is', g)) @@ -21,9 +21,20 @@ test_that('Capped axes do not work with incorrect capping argument', { for (g in c('left','right')) { expect_error(capped_vertical(g), "'arg' should be one of", info=paste('capped is', g)) } - + for (g in c('top','bottom')) { expect_error(capped_horizontal(g), "'arg' should be one of", info=paste('capped is', g)) } }) +test_that('Plot works with vdiffr', { + data(mtcars) + p <- ggplot(mtcars, aes(x = mpg)) + geom_dotplot(binwidth = 1) + + scale_y_continuous(sec.axis = sec_axis(~.*100)) + + scale_x_continuous(sec.axis = sec_axis(~1/., name='Madness scale')) + + coord_capped_cart(bottom='left', left='both', top='none', right='both') + + theme_bw() + + theme(panel.border=element_blank(), axis.line=element_line()) + expect_doppelganger("capped axes", p) + +}) diff --git a/tests/testthat/test_facet.R b/tests/testthat/test_facet.R new file mode 100644 index 0000000..1efca4a --- /dev/null +++ b/tests/testthat/test_facet.R @@ -0,0 +1,29 @@ +library(vdiffr) + +test_that('We can reproduce issue 24', { + set.seed(123) + est=rnorm(6, sd=2) + dd = data.frame(lev=rep(c("Level 1", "Level 2", "Level 3"), 2), + pos = rep(c("Pos 1", "Pos 2"), each=3), + est, + ciLow = est-abs(rnorm(6, 1, sd=3)), + ciHigh = est+abs(rnorm(6, 1, sd=3)) + ) + + p = ggplot(dd, aes(x=lev, y=est)) + + geom_point(shape=1) + + facet_rep_grid(~pos) + + geom_errorbar(aes(ymin=ciLow, ymax=ciHigh), width=0) + + coord_flip() + theme_bw() + + theme(panel.border = element_blank(), axis.line = element_line()) + + expect_doppelganger('facet_rep_grid spacing', p) + + p = ggplot(dd, aes(x=est, y=pos)) + + geom_point(shape=1) + + facet_rep_wrap(~lev,ncol=1) + + geom_errorbar(aes(ymin=ciLow, ymax=ciHigh), width=0) + + coord_flip() + theme_bw() + + theme(axis.text.x = element_text(angle = 90, hjust = 1, vjust = 0.5)) + expect_doppelganger('facet_rep_wrap spacing', p) +}) diff --git a/tests/testthat/test_facet_aux.R b/tests/testthat/test_facet_aux.R index 1c1bae3..b3a7138 100644 --- a/tests/testthat/test_facet_aux.R +++ b/tests/testthat/test_facet_aux.R @@ -1,5 +1,5 @@ library(testthat) -library(lemon) +library(vdiffr) context('Facets with repeated axes; auxillary functions') @@ -7,14 +7,14 @@ all.sides <- c('top', 'right','bottom','left') # for quicker referencing test_that('`reduce.ticks.labels.settings` returns correct value on single logicals', { r <- lemon:::reduce.ticks.labels.settings ### I'm lazy - + expect_equal(r(FALSE), character(0)) expect_equal(r(TRUE), all.sides) }) test_that('`reduce.ticks.labels.settings` returns correct value on scalars', { r <- lemon:::reduce.ticks.labels.settings ### I'm lazy - + for (s in all.sides) { expect_equal(r(s), s, info=paste0('side was ', s) ) } @@ -22,7 +22,7 @@ test_that('`reduce.ticks.labels.settings` returns correct value on scalars', { test_that('`reduce.ticks.labels.settings` returns correct values on single composites', { r <- lemon:::reduce.ticks.labels.settings ### I'm lazy - + expect_equal(r('none'), character(0)) expect_equal(r('all'), all.sides) expect_equal(r('x'), all.sides[c(1,3)]) @@ -31,7 +31,7 @@ test_that('`reduce.ticks.labels.settings` returns correct values on single compo test_that('`reduce.ticks.labels.settings` returns correct values on composites + side', { r <- lemon:::reduce.ticks.labels.settings ### I'm lazy - + for (s in all.sides) { expect_equal(r(c('none',s)), character(0), info=paste0('side was ', s) ) } @@ -47,7 +47,16 @@ test_that('`reduce.ticks.labels.settings` returns correct values on composites + test_that('`reduce.ticks.labels.settings` fails on unrecognized input', { r <- lemon:::reduce.ticks.labels.settings ### I'm lazy - + expect_error(r('cnter')) }) + +test_that('Still works with vdiffr', { + data(mpg, package='ggplot2') + p <- ggplot(mpg, aes(displ, cty)) + geom_point() + + coord_capped_cart(bottom='both', left='both') + + theme_bw() + theme(panel.border=element_blank(), axis.line=element_line()) + expect_doppelganger("facet_rep_grid", p + facet_rep_grid(drv ~ cyl, repeat.tick.labels = TRUE)) + expect_doppelganger("facet_rep_wrap", p + facet_rep_wrap(~ cyl, repeat.tick.labels = TRUE, ncol=3)) +}) diff --git a/tests/testthat/test_lemon_plot.r b/tests/testthat/test_lemon_plot.r index 6a44ea3..5cb4308 100644 --- a/tests/testthat/test_lemon_plot.r +++ b/tests/testthat/test_lemon_plot.r @@ -6,10 +6,10 @@ expect_lemon_plot <- function(object) expect_s3_class(object, 'lemon_plot') test_that('ggplot2 does not break lemon_plot by altering class', { p <- ggplot(data.frame(a=1:2, b=runif(2), c=letters[1:2]), aes(a, b, colour=c)) + geom_blank() - + l <- as.lemon_plot(p) expect_lemon_plot(l) - expect_error(l + 1, regexp = "Don't know how to add 1 to a plot", fixed=TRUE) + expect_error(l + 1, regexp = "Can't add `1`") expect_lemon_plot(l + NULL) expect_lemon_plot(l %+% data.frame(a=3, b=0, c='a')) expect_lemon_plot(l + theme_bw()) @@ -21,5 +21,5 @@ test_that('ggplot2 does not break lemon_plot by altering class', { expect_lemon_plot(l + facet_wrap(~c)) expect_lemon_plot(l + list(data=data.frame(a=3, b=0, c='a'), scale_x_continuous())) expect_lemon_plot(l + geom_point()) - -}) \ No newline at end of file + +}) diff --git a/vignettes/capped-axes.Rmd b/vignettes/capped-axes.Rmd index fc29ea7..34919e2 100644 --- a/vignettes/capped-axes.Rmd +++ b/vignettes/capped-axes.Rmd @@ -100,6 +100,8 @@ relevant axis drawing function is used. You can however choose to use e.g. ### The axis drawing functions +** Following section no longer applicable as of ggplot2 v. 3.3.0 (-ish)! ** + The functions `capped_horizontal` or `brackets_vertical` returns a function that is called when ggplot2 prints the plot. In this package, we use ggplot2 to build the axes, then modify in place the diff --git a/vignettes/gtable_show_lemonade.Rmd b/vignettes/gtable_show_lemonade.Rmd index 3b2ebd8..ed84bf0 100644 --- a/vignettes/gtable_show_lemonade.Rmd +++ b/vignettes/gtable_show_lemonade.Rmd @@ -15,7 +15,7 @@ vignette: > library(knitr) knitr::opts_chunk$set(fig.height=4, fig.width=6, - cache=TRUE, autodep = TRUE, cache.path = 'show_lemonade/') + cache=TRUE, autodep = TRUE, cache.path = 'gtable_show_lemonade/') ``` ```{r} @@ -40,17 +40,16 @@ my.theme <- theme_light() ```{r} g <- ggplotGrob(p) +nul <- unit(1, 'null') for (i in 1:nrow(g$layout)) { if (g$layout$name[i] == 'lemon') next h <- g$heights[[g$layout$t[i]]] rot <- 0 - if (class(h)[1] == 'unit') { - rot <- ifelse(as.numeric(h) == 1 & attr(h, 'unit') == 'null', 90, 0) - } + rot <- ifelse(as.character(h) == '1null', 90, 0) w <- g$widths[[g$layout$l[i]]] - if (rot == 90 & class(w)[1] == 'unit') { - rot <- ifelse(as.numeric(w) == 1 & attr(w, 'unit') == 'null', 0, rot) + if (rot == 90) { + rot <- ifelse(as.character(w) == '1null', 0, rot) } r <- rectGrob(gp=gpar(col='black', fill='white', alpha=1/4)) t <- textGrob(g$layout$name[i], rot = rot) diff --git a/vignettes/legends.Rmd b/vignettes/legends.Rmd index 4dab94c..3c3bd63 100644 --- a/vignettes/legends.Rmd +++ b/vignettes/legends.Rmd @@ -169,14 +169,14 @@ If using facetting, the panels are typically named `panel-{column}-{row}`. We use `gtable_show_names` to display the names of the facetted panels. ```{r fig.cap="Facetted panels' names."} -d2 <- d + facet_grid(.~cut) +d2 <- d + facet_grid(.~cut, ) gtable_show_names(d2) ``` So to place the legend in a specific panel, give its name: ```{r reposition_legend_facet1,fig.cap='Placing the legend in a facet panel.'} -reposition_legend(d2, 'top left', panel = 'panel-3-1') +reposition_legend(d2, 'top left', panel = 'panel-1-5') ``` Likewise for `facet_wrap`. Incidentally, empty panels are also named here: @@ -338,7 +338,7 @@ g <- reposition_legend(p, 'top left', plot=TRUE) (http://baptiste.github.io/) on [ggplot2's wiki](https://github.com/tidyverse/ggplot2/wiki/Share-a-legend-between-two-ggplot2-graphs/047381b48b0f0ef51a174286a595817f01a0dfad). It has since propogated throughout -[Stack Overflow](http://www.stackoverflow.com) answers. +[Stack Overflow](https://stackoverflow.com) answers. Originally brought to you by (Baptiste Auguié)[http://baptiste.github.io/] diff --git a/vignettes/lemon_print.Rmd b/vignettes/lemon_print.Rmd index aa03b6c..11f83be 100644 --- a/vignettes/lemon_print.Rmd +++ b/vignettes/lemon_print.Rmd @@ -27,7 +27,7 @@ knitr::opts_chunk$set(fig.height=4, fig.width=6, verbatim=FALSE, cache=FALSE, autodep = TRUE, cache.path='lemon_print-cache/') # Show chunk verbatim -# Source: http://stackoverflow.com/questions/19908158/show-an-r-markdown-chunk-in-the-final-output +# Source: https://stackoverflow.com/questions/19908158/show-an-r-markdown-chunk-in-the-final-output # Set verbatim option as last and it will not be printed. ;) hook_source_def = knit_hooks$get('source') knit_hooks$set(source = function(x, options){