Skip to content
Browse files

new Guides implementation using R5 class with a little performance im…

…provement.
  • Loading branch information...
1 parent e4a176c commit 147f025941c37ff5b72ab47817352a40e0508ad0 @kohske kohske committed Apr 26, 2011
Showing with 591 additions and 511 deletions.
  1. +2 −2 DESCRIPTION
  2. +4 −0 NAMESPACE
  3. +29 −1 R/grob-absolute.r
  4. +528 −0 R/guides-.r
  5. +0 −426 R/guides-legend.r
  6. +6 −6 R/plot-render.r
  7. +6 −4 R/scale-.r
  8. +2 −2 R/scale-hue.r
  9. +6 −6 R/scale-identity.r
  10. +1 −1 R/scale-linetype.r
  11. +5 −5 R/scale-manual.r
  12. +1 −1 R/scale-shape.r
  13. +1 −1 R/scale-size.r
  14. +0 −56 R/scales-.r
View
4 DESCRIPTION
@@ -43,7 +43,7 @@ Collate: 'aaa-.r' 'aaa-constants.r' 'aaa-html.r' 'aes.r'
'geom-segment.r' 'geom-smooth.r' 'geom-text.r'
'geom-tile.r' 'geom-vline.r' 'ggplot2.r'
'grob-absolute.r' 'grob-grid.r' 'grob-null.r'
- 'guides-axis.r' 'guides-grid.r' 'guides-legend.r'
+ 'guides-axis.r' 'guides-grid.r'
'labels.r' 'layer.r' 'limits.r' 'matrix.r'
'plot-build.r' 'plot-construction.r' 'plot-last.r'
'plot-render.r' 'plot.r' 'position-.r'
@@ -70,4 +70,4 @@ Collate: 'aaa-.r' 'aaa-constants.r' 'aaa-html.r' 'aes.r'
'utilities-layer.r' 'utilities-matrix.r'
'utilities-position.r' 'utilities-resolution.r'
'utilities.r' 'xxx-codegen.r' 'xxx-digest.r' 'xxx.r'
- 'zxx.r'
+ 'zxx.r' 'guides-.r'
View
4 NAMESPACE
@@ -170,3 +170,7 @@ S3method(cweave, list)
S3method(cweave, matrix)
S3method(interleave, list)
S3method(interleave, default)
+
+export(guide_legend)
+export(guide_colorbar)
+
View
30 R/grob-absolute.r
@@ -36,4 +36,32 @@ grobY.absoluteGrob <- function(x, theta) {
grid.draw.absoluteGrob <- function(x, recording = TRUE) {
grid:::drawGTree(x)
-}
+}
+
+
+## gTree with absolute size specification
+##
+## this should be removed in future.
+sizedGTree <- function(...) {
+ gTree(..., cl=c("sizedGTree"))
+}
+grobHeight.sizedGTree <- function(x) {
+ nulldefault(x$height, nulldefault(x$vp$height, nulldefault(sum(x$vp$layout$heights), grobHeight(x$children))))
+}
+grobWidth.sizedGTree <- function(x) {
+ nulldefault(x$width, nulldefault(x$vp$width, nulldefault(sum(x$vp$layout$widths), grobWidth(x$children))))
+}
+
+if(0){
+grobX.sizedGTree <- function(x, theta) {
+ if (!is.null(x$xmin) && theta == "west") return(x$xmin)
+ grobX(x$children, theta)
+}
+grobY.sizedGTree <- function(x, theta) {
+ if (!is.null(x$ymin) && theta == "south") return(x$ymin)
+ grobY(x$children, theta)
+}
+}
+grid.draw.sizedGTree <- function(x, recording = TRUE) {
+ grid:::drawGTree(x)
+}
View
528 R/guides-.r
@@ -0,0 +1,528 @@
+## classes w.r.t. guides
+
+# encupsles all guides but positions (x, y, date)
+Guides <- setRefClass("Guides",
+ fields = list(
+ hashes = "character", # hash list as char vector
+ guides = "list", # list of guides.
+ scales = "Scales",
+ layers = "list",
+ default_mapping = "ANY",
+ horizontal = "logical",
+ theme = "list"),
+
+ methods = list(
+
+ # arrange all guides
+ build_guides = function() {
+
+ # override alignment of legends box if theme$legend.box is specified
+ if (!is.na(theme$legend.box)) {
+ horizontal <<- 1 == charmatch(theme$legend.box, c("horizontal","vertical"))
+ }
+
+ #
+ # parse scale and generate guide objects
+ #
+
+ # note that number of guides can be less than that of scales because of
+ # 1) no guide scale
+ # 2) common guide for multiple scale
+
+ parse_scales()
+ n <- length(guides)
+ if (length(guides) == 0) return(zeroGrob()) # return zero grob if no guide.
+
+ #
+ # arrange the guides
+ #
+
+ # now it would be possible to specify position/direction for each guide,
+ # by guide_XXX(pos="bottom/top/left/right", dir="horizontal/vertical"), not yet implemented.
+ # in that case, arrange them by rewrite the following codes.
+ #
+ # now, all guides are placed on a same space and in sa same direction,
+ # which is specified in opts(legend.direction, legend.position)
+
+ box_nrow <- if (horizontal) 1 else n
+ box_ncol <- if (horizontal) n else 1
+
+ # guide -> grob of guide
+ legs <- lapply(guides, function(g)g$buildGuide(layers, default_mapping, theme))
+
+ # create viewport for the guide grobs
+ if (!horizontal) {
+ widths <- do.call("max", lapply(legs, function(leg) sum(leg$vp$layout$widths)))
+ heights <- do.call("unit.c", lapply(legs, function(leg) sum(leg$vp$layout$heights) * 1.1))
+ legend.layout <- grid.layout(nrow=n, ncol=1, widths=widths, heights=heights)
+ for (i in seq_along(legs)) {
+ legs[[i]]$vp <- viewport(layout.pos.col = 1, layout.pos.row = i, layout = legs[[i]]$vp$layout)
+ }
+ } else {
+ heights <- do.call("sum", lapply(legs, function(leg) sum(leg$vp$layout$heights)))
+ widths <- do.call("unit.c", lapply(legs, function(leg) sum(leg$vp$layout$widths) * 1.1))
+ legend.layout <- grid.layout(nrow=1, ncol=n, widths=widths, heights=heights)
+ for (i in seq_along(legs)) {
+ legs[[i]]$vp <- viewport(layout.pos.col = i, layout.pos.row = 1, layout = legs[[i]]$vp$layout)
+ }
+ }
+
+ #
+ # return the all guides
+ #
+
+ # somewhat wired trick here...
+ # maybe this can be improved.
+ sizedGTree(children = gList(gTree(children=do.call("gList", legs), vp=viewport(layout=legend.layout))), width=sum(widths), height=sum(heights))
+ },
+
+ # extract information from scale and generate guide object
+ parse_scales = function() {
+ for(scale in scales$scales) {
+
+ # this should be changed to test guide == "none"
+ if (!scale$legend || is.null(scale_limits(scale))) next
+
+ # this should be implemented in more general way
+ if (is.character(scale$guide)) {
+ guide_name <- paste("guide_", scale$guide, sep="")
+ if (!exists(guide_name)) stop("No guide called ", guide_name, call.=FALSE)
+ else scale$guide <- eval(call(guide_name))
+ }
+
+ scale$guide$parseScale(scale = scale, theme = theme)
+ guide_hash <- scale$guide$hash()
+
+ guide_dest <- which(guide_hash== hashes)
+
+ if (length(guide_dest) > 1) {
+ stop("Failed to set up guides")
+ }
+ else if (length(guide_dest) == 1) {
+ guides[[guide_dest]]$mergeGuide(scale$guide)
+ } else {
+ hashes[length(hashes)+1] <<- guide_hash
+ guides[[length(guides)+1]] <<- scale$guide
+ }
+ }
+ }
+ )
+ )
+
+# guide
+#
+# name
+# scale -> guide
+# hash generator
+# guide builder
+
+# abstract class for a guide
+Guide <- setRefClass("Guide",
+ fields = list(
+ name = "character",
+ title = "ANY", # character or expression
+ key = "ANY"
+ ),
+
+ methods = list(
+ parseScale = function(...) stop(""),
+ hash = function() digest(list(title, key$.label, name)),
+ mergeGuide = function(new_guide) {stop("")},
+ buildGuide = function(...) stop("")
+ )
+)
+
+GuideLegend <- setRefClass("GuideLegend",
+ contains = c("Guide"),
+
+ methods = list(
+
+ parseScale = function(..., scale, theme) {
+ if (!scale$legend || is.null(scale_limits(scale))) return(NULL)
+
+ output <- scale$aesthetics[1]
+
+ .title <- scale$name %||% theme$labels[[output]]
+ .key <- data.frame(
+ scale_map(scale, scale_breaks(scale)), I(scale_labels(scale)),
+ stringsAsFactors = FALSE)
+ names(.key) <- c(output, ".label")
+
+ title <<- .title
+ key <<- .key
+ },
+
+ mergeGuide = function(new_guide) {
+ key <<- merge(key, new_guide$key)
+ },
+
+ buildGuide = function(layers, default_mapping, theme) {
+
+ # grid::unit calculation is so slow
+ #
+ # here all units but originally "mm" are converted into "mm" first,
+ # and all caulucation is done for raw numeric.
+ # this save the time up to approx. 20-30%.
+ # but also, conversion takes some time.
+ # it is better to develop light-weight fast unit system.
+
+ legend_data <- llply(layers, .self$build_legend_data, default_mapping)
+
+ # Determine key width and height
+ if (is.na(theme$legend.key.width)) {
+ theme$legend.key.width <- theme$legend.key.size
+ }
+ key.width <- c(convertWidth(theme$legend.key.width, "mm"))
+
+ if (is.na(theme$legend.key.height))
+ theme$legend.key.height <- theme$legend.key.size
+ key.height <- c(convertHeight(theme$legend.key.height, "mm"))
+
+ ## Calculate sizes for keys - mainly for v. large points and lines
+ size_mat <- do.call("cbind", llply(legend_data, "[[", "size"))
+ if (is.null(size_mat)) {
+ key_sizes <- rep(0, nrow(key))
+ } else {
+ key_sizes <- apply(size_mat, 1, max)
+ }
+
+ ## Determine the direction of the elements of legend.
+ if (theme$legend.direction == "horizontal") {
+ direction <- "horizontal"
+ } else {
+ direction <- "vertical"
+ }
+
+ ## gap between keys etc
+ hgap <- c(convertWidth(unit(0.3, "lines"), "mm"))
+ vgap <- hgap
+
+ ## hjust for title of legend
+ ## if direction is vertical, then title is left-aligned
+ ## if direction is horizontal, then title is centre-aligned
+ ## if legend.title.align is specified, then title is alinged using the value
+ if (is.na(theme$legend.title.align)) {
+ if (direction == "vertical") {
+ grob.title <- theme_render(theme, "legend.title", title, x = 0, y = 0.5)
+ } else if (direction == "horizontal") {
+ grob.title <- theme_render(theme, "legend.title", title, hjust = 0.5, x = 0.5, y = 0.5)
+ }
+ } else {
+ grob.title <- theme_render(
+ theme, "legend.title", title,
+ hjust = theme$legend.title.align,
+ x = theme$legend.title.align, y = 0.5
+ )
+ }
+
+ ## Compute heights and widths of legend table
+ title_width <- c(convertWidth(grobWidth(grob.title), "mm"))
+ title_height <- c(convertHeight(grobHeight(grob.title), "mm"))
+
+ ## text label alignment
+ if (is.na(theme$legend.text.align)) {
+ numeric_labels <- all(sapply(key$.label, is.language)) || suppressWarnings(all(!is.na(sapply(key$.label, "as.numeric"))))
+ hpos <- numeric_labels * 1
+ } else {
+ hpos <- theme$legend.text.align
+ }
+
+ grob.labels <- lapply(key$.label, function(label) {
+ theme_render(theme, "legend.text", label, hjust = hpos, x = hpos, y = 0.5)
+ })
+
+ ## geometory calculation
+ if (direction == "vertical") {
+ label_width <- do.call("max", lapply(grob.labels, grobWidth))
+ label_width <- c(convertWidth(label_width, "mm"))
+ label_heights <- do.call("unit.c", lapply(grob.labels, grobHeight))
+ label_heights <- c(convertHeight(label_heights, "mm"))
+
+ width <- max(unlist(llply(legend_data, "[[", "size")), 0)
+ key_width <- max(key.width, width)
+
+ widths <- c(hgap, key_width, hgap, label_width, max(title_width - key_width - label_width, hgap))
+ heights <- c(vgap, title_height, vgap, pmax(key.height, label_heights, key_sizes), vgap)
+
+ } else if(direction == "horizontal") {
+ label_width <- do.call("unit.c", lapply(grob.labels, grobWidth))
+ label_width <- convertWidth(label_width, "mm")
+ label_heights <- do.call("max", lapply(grob.labels, grobHeight))
+ label_heights <- convertHeight(label_heights, "mm")
+
+ height <- max(unlist(llply(legend_data, "[[", "size")), 0)
+ key_heights <- max(key.height, height)
+ key_width <- pmax(key.width, key_sizes)
+ # width of (key gap label gap) x nkeys
+ kglg_width <- do.call("c",lapply(1:length(key_width), function(i)c(key_width[i], hgap, label_width[i], hgap)))
+ widths <- c(max(hgap, (title_width - (sum(kglg_width) - hgap)) * 0.5),
+ kglg_width,
+ max(hgap, (title_width - (sum(kglg_width) - hgap)) * 0.5))
+ heights <- c(vgap, title_height, vgap, max(key.height, height, label_heights), vgap)
+ }
+
+ ## horizontally center is pretty when direction is horizontal
+ if (direction == "vertical") {
+ hjust <- "left"
+ } else if (direction == "horizontal") {
+ hjust <- "centre"
+ }
+
+ .grobs <- list()
+ .grobs[[length(.grobs)+1]] <- theme_render(theme, "legend.background")
+
+ for (i in 1:nrow(key)) {
+ if (direction == "vertical") {
+ .grobs[[length(.grobs)+1]] <- theme_render(theme, "legend.key", vp = viewport(layout.pos.col = 2, layout.pos.row = i+3))
+ } else if (direction == "horizontal") {
+ .grobs[[length(.grobs)+1]] <- theme_render(theme, "legend.key", vp = viewport(layout.pos.col = 1+(i*4)-3, layout.pos.row = 4))
+ }
+ for(j in seq_along(layers)) {
+ if (!is.null(legend_data[[j]])) {
+ legend_geom <- Geom$find(layers[[j]]$geom$guide_geom())
+ .key <- legend_geom$draw_legend(legend_data[[j]][i, ],
+ c(layers[[j]]$geom_params, layers[[j]]$stat_params))
+ if (direction == "vertical") {
+ .key$vp <- viewport(layout.pos.col = 2, layout.pos.row = i+3)
+ } else if (direction == "horizontal") {
+ .key$vp <- viewport(layout.pos.col = 1+(i*4)-3, layout.pos.row = 4)
+ }
+ .grobs[[length(.grobs)+1]] <- .key
+ }
+ }
+ grob.labels[[i]]$vp <- if (direction == "vertical")
+ viewport(layout.pos.col = 4, layout.pos.row = i+3)
+ else if (direction == "horizontal")
+ viewport(layout.pos.col = 1+(i*4)-1, layout.pos.row = 4)
+ }
+
+ ## Layout the legend table
+ legend.layout <- grid.layout(
+ length(heights), length(widths),
+ widths = unit(widths, "mm"), heights = unit(heights, "mm"),
+ just = c(hjust, "centre")
+ )
+ grob.title$vp <- viewport(layout.pos.col = 2:(length(widths)-1), layout.pos.row = 2)
+ .grobs[[length(.grobs)+1]] <- grob.title
+ .grobs <- c(.grobs, grob.labels)
+
+ gt <- gTree(children = do.call("gList", .grobs),
+ vp = viewport(layout=legend.layout)
+ )
+ gt
+ },
+
+ build_legend_data = function(layer, default_mapping) {
+ all <- names(c(layer$mapping, default_mapping, layer$stat$default_aes()))
+ geom <- c(layer$geom$required_aes, names(layer$geom$default_aes()))
+
+ matched <- intersect(intersect(all, geom), names(key))
+ matched <- setdiff(matched, names(layer$geom_params))
+
+ if (length(matched) > 0) {
+ ## This layer contributes to the legend
+ if (is.na(layer$legend) || layer$legend) {
+ ## Default is to include it
+ layer$use_defaults(key[matched])
+ } else {
+ NULL
+ }
+ } else {
+ ## This layer does not contribute to the legend
+ if (is.na(layer$legend) || !layer$legend) {
+ ## Default is to exclude it
+ NULL
+ } else {
+ layer$use_defaults(NULL)[rep(1, nrow(key)), ]
+ }
+ }
+ }
+
+ )
+)
+
+GuideColorbar <- setRefClass("GuideColorbar",
+ contains = c("Guide"),
+
+ fields = list(
+ nbin = "integer",
+ nbreak = "integer",
+ bar = "data.frame",
+ nodraw.ul = "logical",
+ nodraw.ll = "logical"
+ ),
+
+ methods = list(
+
+ parseScale = function(..., scale, theme) {
+
+ if (!scale$legend || is.null(scale_limits(scale))) return(NULL)
+
+ output <- scale$aesthetics[1]
+ title <<- scale$name %||% theme$labels[[output]]
+
+ if (is.null(scale$breaks)) {
+ breaks <- pretty(scale_limits(scale), nbreak)
+ } else if (is.function(scale$breaks)) {
+ breaks <- scale$breaks(limits)
+ } else {
+ breaks <- scale$breaks
+ }
+ breaks <- discard(breaks, scale_limits(scale))
+
+ key <<- data.frame(
+ scale_map(scale, breaks), I(scale_labels(scale, breaks)), breaks,
+ stringsAsFactors = FALSE)
+ names(key) <<- c(output, ".label", ".value")
+
+ ## bar specification (number of divs etc)
+ .bar <- discard(pretty(scale_limits(scale), n = nbin), scale_limits(scale))
+ bar <<- data.frame(colour=scale_map(scale, .bar), value=.bar, stringsAsFactors = FALSE)
+ },
+
+ hash = function() digest(list(title, key$.label, bar, name)),
+
+ mergeGuide = function(new_guide) {
+ },
+
+ buildGuide = function(layers, default_mapping, theme) {
+
+ ## gap between keys etc
+ hgap <- c(convertWidth(unit(0.3, "lines"), "mm"))
+ vgap <- hgap
+
+ # Determine key width and height
+ if (is.na(theme$legend.key.width)) {
+ theme$legend.key.width <- theme$legend.key.size
+ }
+ key.width <- convertWidth(theme$legend.key.width, "mm")
+ key.width.c <- c(key.width)
+
+ if (is.na(theme$legend.key.height))
+ theme$legend.key.height <- convertHeight(theme$legend.key.size, "mm")
+ key.height <- convertHeight(theme$legend.key.height, "mm")
+ key.height.c <- c(key.height)
+
+ ## Determine the direction of the elements of legend.
+ if (theme$legend.direction == "horizontal") {
+ direction <- "horizontal"
+ } else {
+ direction <- "vertical"
+ }
+
+ if (direction=="vertical") {
+ bar_height.c <- key.height.c * 5
+ bar_width.c <- key.width.c
+
+ grob.bar <- rasterGrob(image = bar$colour, width=bar_width.c, height=bar_height.c, default.units = "mm", gp=gpar(col=NA), interpolate = TRUE)
+
+ tic_pos_y.c <- rescale(key$.value, c(0.5, nbin-0.5), range(bar$value)) * bar_height.c / nbin
+ label_pos_y <- unit(tic_pos_y.c, "mm")
+ if (nodraw.ul) tic_pos_y.c <- tic_pos_y.c[-1]
+ if (nodraw.ll) tic_pos_y.c <- tic_pos_y.c[-length(tic_pos_y.c)]
+
+
+ grob.title <- theme_render(
+ theme, "legend.title",
+ title, hjust = 0, x = 0, y = 0.5)
+ ## Compute heights and widths of legend table
+ title_width <- convertWidth(grobWidth(grob.title), "mm")
+ title_width.c <- c(title_width)
+ title_height <- convertHeight(grobHeight(grob.title), "mm")
+ title_height.c <- c(title_height)
+
+ grob.label <- theme_render(
+ theme, "legend.text",
+ key$.label, x = 0.5, y = label_pos_y)
+ label_width <- convertWidth(grobWidth(grob.label), "mm")
+ label_width.c <- c(label_width)
+ label_height <- convertHeight(grobHeight(grob.label), "mm")
+ label_height.c <- c(label_height)
+
+ legend.layout <- grid.layout(
+ 5, 5,
+ widths = c(hgap, bar_width.c, hgap, label_width.c, hgap),
+ heights = c(vgap, title_height.c, vgap, bar_height.c, vgap),
+ just = "left",
+ default.unit = "mm")
+
+ grob.title$vp <- viewport(layout.pos.col = 2:4, layout.pos.row = 2)
+ grob.bar$vp <- viewport(layout.pos.col = 2, layout.pos.row = 4)
+ grob.label$vp <- viewport(layout.pos.col = 4, layout.pos.row = 4)
+
+ grob.segments <- segmentsGrob(
+ x0 = c(rep(0, nbin), rep(bar_width.c * (4/5), nbin)),
+ y0 = rep(tic_pos_y.c, 2),
+ x1 = c(rep(bar_width.c * (1/5), nbin), rep(bar_width.c, nbin)),
+ y1 = rep(tic_pos_y.c, 2),
+ default.units = "mm",
+ gp = gpar(col="white", lwd=0.5, lineend="butt"),
+ vp = viewport(layout.pos.col = 2, layout.pos.row = 4)
+ )
+ } else if (direction=="horizontal") {
+
+ bar_height.c <- key.height.c
+ bar_width.c <- key.width.c * 5
+
+ grob.bar <- rasterGrob(image = t(bar$colour), width=bar_width.c, height=bar_height.c, default.units = "mm", gp=gpar(col=NA), interpolate = TRUE)
+
+ tic_pos_y.c <- rescale(key$.value, c(0.5, nbin-0.5), range(bar$value)) * bar_height.c / nbin
+ label_pos_y <- unit(tic_pos_y.c, "mm")
+ if (nodraw.ul) tic_pos_y.c <- tic_pos_y.c[-1]
+ if (nodraw.ll) tic_pos_y.c <- tic_pos_y.c[-length(tic_pos_y.c)]
+
+ tic_pos_x.c <- rescale(key$.value, c(0.5, nbin-0.5), range(bar$value)) * bar_width.c / nbin
+ label_pos_x <- unit(tic_pos_x.c, "mm")
+ if (nodraw.ul) tic_pos_x.c <- tic_pos_x.c[-1]
+ if (nodraw.ll) tic_pos_x.c <- tic_pos_x.c[-length(tic_pos_x.c)]
+
+ grob.title <- theme_render(
+ theme, "legend.title",
+ title, hjust = 1, x = 1, y = 0.5)
+ ## Compute heights and widths of legend table
+ title_width <- convertWidth(grobWidth(grob.title), "mm")
+ title_width.c <- c(title_width)
+ title_height <- convertHeight(grobHeight(grob.title), "mm")
+ title_height.c <- c(title_height)
+
+ grob.label <- theme_render(
+ theme, "legend.text",
+ key$.label, x = label_pos_x, y = 0.5)
+ label_width <- convertWidth(grobWidth(grob.label), "mm")
+ label_width.c <- c(label_width)
+ label_height <- convertHeight(grobHeight(grob.label), "mm")
+ label_height.c <- c(label_height)
+
+ legend.layout <- grid.layout(
+ 5, 5,
+ widths = c(hgap, title_width.c, hgap, bar_width.c, hgap),
+ heights = c(vgap, bar_height.c, vgap, label_height.c, vgap),
+ just = "left",
+ default.unit = "mm")
+
+ grob.title$vp <- viewport(layout.pos.col = 2, layout.pos.row = 2:4)
+ grob.bar$vp <- viewport(layout.pos.col = 4, layout.pos.row = 2)
+ grob.label$vp <- viewport(layout.pos.col = 4, layout.pos.row = 4)
+
+ grob.segments <- segmentsGrob(
+ x0 = rep(tic_pos_x.c, 2),
+ y0 = c(rep(0, nbin), rep(bar_height.c * (4/5), nbin)),
+ x1 = rep(tic_pos_x.c, 2),
+ y1 = c(rep(bar_height.c * (1/5), nbin), rep(bar_height.c, nbin)),
+ default.units = "mm",
+ gp = gpar(col="white", lwd=0.5, lineend="butt"),
+ vp = viewport(layout.pos.col = 4, layout.pos.row = 2)
+ )
+ }
+
+ gTree(
+ children = gList(grob.title, grob.bar, grob.label, grob.segments),
+ vp = viewport(layout=legend.layout)
+ )
+ }
+ )
+)
+
+guide_legend <- function(...) GuideLegend$new(...)
+guide_colorbar <- function(nbin = 20, nbreak = 5, nodraw.ul = FALSE, nodraw.ll = FALSE, ...)
+ GuideColorbar$new(nbin = nbin, nbreak = nbreak, nodraw.ul = nodraw.ul, nodraw.ll = nodraw.ll, ...)
View
426 R/guides-legend.r
@@ -1,426 +0,0 @@
-# Legends
-# Create and arrange legends for all scales.
-#
-# This function gathers together all of the legends produced by
-# the scales that make up the plot and organises them into a
-# \code{\link[grid]{frameGrob}}.
-#
-# If there are no legends to create, this function will return \code{NULL}
-#
-# @param scales object
-# @param direction of scales, vertical by default
-# @keyword hplot
-# @value frameGrob, or NULL if no legends
-# @keyword internal
-#X theme_update(legend.background = theme_rect(size = 0.2))
-#X mtcars$long <- factor(sample(3, nrow(mtcars), TRUE),
-#X labels = c("this is very long label", "this is very long label2", "this is\nvery long\nlabel3"))
-#X mtcars$short_elements_with_long_title <- factor(sample(2, nrow(mtcars), TRUE), labels = c("s1", "s2"))
-#X
-#X # with short title and long key/values
-#X p <- qplot(mpg, wt, data = mtcars, colour = factor(cyl), shape = long)
-#X p
-#X p + opts(legend.direction = "horizontal", legend.position = "bottom")
-#X p + opts(legend.direction = "horizontal", legend.position = "bottom", legend.box = "vertical")
-#X
-#X # with long title and short key/values
-#X p <- qplot(mpg, wt, data = mtcars, colour = factor(cyl), shape = short_elements_with_long_title)
-#X p
-#X p + opts(legend.direction = "horizontal", legend.position = "bottom") # to be fixed
-#X p + opts(legend.direction = "horizontal", legend.position = "bottom", legend.box = "vertical")
-#X theme_set(theme_grey())
-#X
-#X # color bar
-#X
-#X # colorbar legend (vertical)
-#X p + scale_fill_continuous(legend_param=list(colorbar=T))
-#X # colorbar legend (horizontal)
-#X p + scale_fill_continuous(legend_param=list(colorbar=T)) + opts(legend.position="bottom", legend.direction="horizontal")
-#X # change the size of legend
-#X p + scale_fill_continuous(legend_param=list(colorbar=T)) + opts(legend.key.width=unit(0.5, "line"), legend.key.height=unit(2, "line"))
-#X # specify the number of breaks of legend
-#X p + scale_fill_continuous(legend_param=list(colorbar=T, colorbar_nbreaks=10))
-#X # manually specify the breaks
-#X p + scale_fill_continuous(legend_param=list(colorbar=T), breaks=c(1,4,9,16))
-#X # manually specify the breaks and labels
-#X p + scale_fill_continuous(legend_param=list(colorbar=T), breaks=c(1,4,9,16), labels=c("one^2", "two^2", "three^2", "four^2"))
-#X # change the resolution of colorbar (default = 20)
-#X p + scale_fill_continuous(legend_param=list(colorbar=T, colorbar_nbin=3))
-#X p + scale_fill_continuous(legend_param=list(colorbar=T, colorbar_nbin=100))
-#X # combine with other scales
-#X p + scale_fill_continuous(legend_param=list(colorbar=T)) + geom_point(aes(x=X1, y=X2, size=value))
-guide_legends_box <- function(scales, layers, default_mapping, horizontal = FALSE, theme) {
-
- # override alignment of legends box if theme$legend.box is specified
- if (!is.na(theme$legend.box)) {
- horizontal <- 1 == charmatch(theme$legend.box, c("horizontal","vertical"))
- }
-
- legs <- guide_legends(scales, layers, default_mapping, theme=theme)
-
- n <- length(legs)
- if (n == 0) return(zeroGrob())
-
- if (!horizontal) {
- width <- do.call("max", lapply(legs, widthDetails))
- heights <- do.call("unit.c", lapply(legs, function(x) heightDetails(x) * 1.1))
- fg <- frameGrob(grid.layout(nrow=n, 1, widths=width, heights=heights, just="centre"), name="legends")
- for(i in 1:n) {
- fg <- placeGrob(fg, legs[[i]], row=i)
- }
- } else {
- height <- do.call("sum", lapply(legs, heightDetails))
- widths <- do.call("unit.c", lapply(legs, function(x) widthDetails(x) * 1.1))
- fg <- frameGrob(grid.layout(ncol=n, 1, widths=widths, heights=height, just="centre"), name="legends")
- for(i in 1:n) {
- fg <- placeGrob(fg, legs[[i]], col=i)
- }
- }
- fg
-}
-
-# Build all legend grob
-# Build legends, merging where possible
-#
-# @param list of legend descriptions
-# @param list description usage of aesthetics in geoms
-# @keyword internal
-# @value A list of grobs
-# @alias build_legend
-# @alias build_legend_data
-#X theme_update(legend.background = theme_rect(size = 0.2))
-#X qplot(mpg, wt, data = mtcars)
-#X qplot(mpg, wt, data = mtcars, colour = cyl)
-#X
-#X # Legend with should expand to fit name
-#X qplot(mpg, wt, data = mtcars, colour = factor(cyl))
-#X
-#X qplot(mpg, wt, data = mtcars, colour = cyl) +
-#X opts(legend.position = c(0.5, 0.5),
-#X legend.background = theme_rect(fill = "white", col = NA))
-#X
-#X mtcars$cyl2 <- factor(mtcars$cyl,
-#X labels = c("a", "loooooooooooong", "two\nlines"))
-#X qplot(mpg, wt, data = mtcars, colour = cyl2)
-#X theme_set(theme_grey())
-guide_legends <- function(scales, layers, default_mapping, theme) {
- legend <- scales_legend_desc(scales, theme)
- if (length(legend$titles) == 0) return()
-
- hashes <- unique(legend$hash)
- lapply(hashes, function(hash) {
- keys <- legend$keys[legend$hash == hash]
- title <- legend$title[legend$hash == hash][[1]]
- guide <- legend$guide[legend$hash == hash][[1]]
-
- if (guide == "default" && length(keys) > 1) {
- # Multiple scales for this legend
- keys <- merge_recurse(keys, by = ".label")
- } else {
- keys <- keys[[1]]
- }
-
- if (guide == "colorbar") {
- build_legend_colorbar(title, keys, layers, default_mapping, theme)
- } else {
- build_legend(title, keys, layers, default_mapping, theme)
- }
- })
-}
-
-build_legend_colorbar <- function(name, mapping, layers, default_mapping, theme) {
-
- hgap <- vgap <- unit(0.3, "lines")
-
- # Determine key width and height
- if (is.na(theme$legend.key.width)) {
- theme$legend.key.width <- theme$legend.key.size
- }
- if (is.na(theme$legend.key.height)) {
- theme$legend.key.height <- theme$legend.key.size
- }
-
- # Determine the direction of the elements of legend.
- if (theme$legend.direction == "horizontal") {
- direction <- "horizontal"
- } else {
- direction <- "vertical"
- }
-
- if (direction=="vertical") {
-
- bar <- attr(mapping, "bar")
- bar_div_n <- nrow(bar)
- bar_height <- convertHeight(theme$legend.key.height * 5, "mm")
- bar_width <- convertWidth(theme$legend.key.width, "mm")
- bargrob <- rasterGrob(bar$colour, 0.5, 0.5, width=bar_width, height=bar_height, gp=gpar(col=NA), interpolate = TRUE)
- tic_pos_y <- rescale(mapping$.value, c(0.5, bar_div_n-0.5), range(bar$value)) * bar_height * (1/bar_div_n)
-
- title <- theme_render(
- theme, "legend.title",
- name, hjust = 0, x = 0, y = 0.5)
-
- label <- theme_render(
- theme, "legend.text",
- mapping$.label, x = 0.5, y = tic_pos_y)
-
- legend.layout <- grid.layout(
- 3, 3,
- widths = unit.c(grobWidth(bargrob), hgap, grobWidth(label)),
- heights = unit.c(grobHeight(title), vgap, grobHeight(bargrob)))
-
- fg <- ggname("legend", frameGrob(layout = legend.layout))
- fg <- placeGrob(fg, title, row=1)
- fg <- placeGrob(fg, bargrob, col=1, row=3)
- fg <- placeGrob(fg, segmentsGrob(bar_width * 0, tic_pos_y, bar_width * (1/5), tic_pos_y, gp=gpar(col="white", lwd=0.5, lineend="butt")), col=1, row=3)
- fg <- placeGrob(fg, segmentsGrob(bar_width * (4/5), tic_pos_y, bar_width * 1, tic_pos_y, gp=gpar(col="white", lwd=0.5, lineend="butt")), col=1, row=3)
- fg <- placeGrob(fg, label, col=3, row=3)
-
- } else if (direction=="horizontal") {
-
- bar <- attr(mapping, "bar")
- bar_div_n <- nrow(bar)
- bar_height <- convertHeight(theme$legend.key.height, "mm")
- bar_width <- convertWidth(theme$legend.key.width * 5, "mm")
- bargrob <- rasterGrob(t(bar$colour), 0.5, 0.5, width=bar_width, height=bar_height, gp=gpar(col=NA), interpolate = TRUE)
- tic_pos_x <- rescale(mapping$.value, c(0.5, bar_div_n-0.5), range(bar$value)) * bar_width * (1/bar_div_n)
-
- title <- theme_render(
- theme, "legend.title",
- name, x = 1, y = 0.5, hjust=1)
-
- label <- theme_render(
- theme, "legend.text",
- mapping$.label, x = tic_pos_x, y = 0.5)
-
- legend.layout <- grid.layout(
- 3, 3,
- widths = unit.c(grobWidth(title), hgap, grobWidth(bargrob)),
- heights = unit.c(grobHeight(bargrob), vgap, grobHeight(label)))
-
- fg <- ggname("legend", frameGrob(layout = legend.layout))
- fg <- placeGrob(fg, title, col=1)
- fg <- placeGrob(fg, bargrob, col=3, row=1)
- fg <- placeGrob(fg, segmentsGrob(tic_pos_x, bar_height * 0, tic_pos_x, bar_height * (1/5), gp=gpar(col="white", lwd=0.5, lineend="butt")), col=3, row=1)
- fg <- placeGrob(fg, segmentsGrob(tic_pos_x, bar_height * (4/5), tic_pos_x, bar_height * 1, gp=gpar(col="white", lwd=0.5, lineend="butt")), col=3, row=1)
- fg <- placeGrob(fg, label, col=3, row=3)
-
- }
-
-
- fg
-}
-
-build_legend <- function(name, mapping, layers, default_mapping, theme) {
- legend_data <- llply(layers, build_legend_data, mapping, default_mapping)
-
- # Determine key width and height
- if (is.na(theme$legend.key.width)) {
- theme$legend.key.width <- theme$legend.key.size
- }
- if (is.na(theme$legend.key.height)) {
- theme$legend.key.height <- theme$legend.key.size
- }
-
- # Determine the direction of the elements of legend.
- if (theme$legend.direction == "horizontal") {
- direction <- "horizontal"
- } else {
- direction <- "vertical"
- }
-
- # Calculate sizes for keys - mainly for v. large points and lines
- size_mat <- do.call("cbind", llply(legend_data, "[[", "size"))
- if (is.null(size_mat)) {
- key_sizes <- rep(0, nrow(mapping))
- } else {
- key_sizes <- apply(size_mat, 1, max)
- }
-
- # hjust for title of legend
- # if direction is vertical, then title is left-aligned
- # if direction is horizontal, then title is centre-aligned
- # if legend.title.align is specified, then title is alinged using the value
- if (is.na(theme$legend.title.align)) {
- if (direction == "vertical") {
- title <- theme_render(
- theme, "legend.title",
- name, x = 0, y = 0.5
- )
- } else if (direction == "horizontal") {
- title <- theme_render(
- theme, "legend.title",
- name, hjust = 0.5, x = 0.5, y = 0.5
- )
- }
- } else {
- title <- theme_render(
- theme, "legend.title",
- name, hjust = theme$legend.title.align, x = theme$legend.title.align, y = 0.5
- )
- }
-
- # Compute heights and widths of legend table
- nkeys <- nrow(mapping)
- hgap <- vgap <- unit(0.3, "lines")
-
- if (is.na(theme$legend.text.align)) {
- numeric_labels <- all(sapply(mapping$.label, is.language)) || suppressWarnings(all(!is.na(sapply(mapping$.label, "as.numeric"))))
- hpos <- numeric_labels * 1
- } else {
- hpos <- theme$legend.text.align
- }
-
- labels <- lapply(mapping$.label, function(label) {
- theme_render(theme, "legend.text", label, hjust = hpos, x = hpos, y = 0.5)
- })
-
- if (direction == "vertical") {
- label_width <- do.call("max", lapply(labels, grobWidth))
- label_width <- convertWidth(label_width, "cm")
- label_heights <- do.call("unit.c", lapply(labels, grobHeight))
- label_heights <- convertHeight(label_heights, "cm")
-
- width <- max(unlist(llply(legend_data, "[[", "size")), 0)
- key_width <- max(theme$legend.key.width, unit(width, "mm"))
-
- widths <- unit.c(
- hgap, key_width,
- hgap, label_width,
- max(
- unit(1, "grobwidth", title) - key_width - label_width,
- hgap
- )
- )
- widths <- convertWidth(widths, "cm")
-
- heights <- unit.c(
- vgap,
- unit(1, "grobheight", title),
- vgap,
- unit.pmax(
- theme$legend.key.height,
- label_heights,
- unit(key_sizes, "mm")
- ),
- vgap
- )
- heights <- convertHeight(heights, "cm")
-
- } else if(direction == "horizontal") {
- label_width <- do.call("unit.c", lapply(labels, grobWidth))
- label_width <- convertWidth(label_width, "cm")
- label_heights <- do.call("max", lapply(labels, grobHeight))
- label_heights <- convertHeight(label_heights, "cm")
-
- height <- max(unlist(llply(legend_data, "[[", "size")), 0)
- key_heights <- max(theme$legend.key.height, unit(height, "mm"))
-
- key_width <- unit.pmax(theme$legend.key.width, unit(key_sizes, "mm"))
- # width of (key gap label gap) x nkeys
- kglg_width <- do.call("unit.c",lapply(1:length(key_width), function(i)unit.c(key_width[i], hgap, label_width[i], hgap)))
- widths <- unit.c(
- max(
- hgap,
- (unit.c(unit(1, "grobwidth", title) - (sum(kglg_width) - hgap))) * 0.5
- ),
- kglg_width,
- max(
- hgap,
- (unit.c(unit(1, "grobwidth", title) - (sum(kglg_width) - hgap))) * 0.5
- )
- )
- widths <- convertWidth(widths, "cm")
-
- heights <- unit.c(
- vgap,
- unit(1, "grobheight", title),
- vgap,
- max(
- theme$legend.key.height,
- label_heights,
- key_heights
- ),
- vgap
- )
- heights <- convertHeight(heights, "cm")
-
- }
-
- # horizontally center is pretty when direction is horizontal
- if (direction == "vertical") {
- hjust <- "left"
- } else if (direction == "horizontal") {
- hjust <- "centre"
- }
-
- # Layout the legend table
- legend.layout <- grid.layout(
- length(heights), length(widths),
- widths = widths, heights = heights,
- just = c(hjust, "centre")
- )
-
- fg <- ggname("legend", frameGrob(layout = legend.layout))
- fg <- placeGrob(fg, theme_render(theme, "legend.background"))
-
- fg <- placeGrob(fg, title, col = 2:(length(widths)-1), row = 2)
- for (i in 1:nkeys) {
-
- if (direction == "vertical") {
- fg <- placeGrob(fg, theme_render(theme, "legend.key"), col = 2, row = i+3)
- } else if (direction == "horizontal") {
- fg <- placeGrob(fg, theme_render(theme, "legend.key"), col = 1+(i*4)-3, row = 4)
- }
-
- for(j in seq_along(layers)) {
- if (!is.null(legend_data[[j]])) {
- legend_geom <- Geom$find(layers[[j]]$geom$guide_geom())
- key <- legend_geom$draw_legend(legend_data[[j]][i, ],
- c(layers[[j]]$geom_params, layers[[j]]$stat_params))
- if (direction == "vertical") {
- fg <- placeGrob(fg, ggname("key", key), col = 2, row = i+3)
- } else if (direction == "horizontal") {
- fg <- placeGrob(fg, ggname("key", key), col = 1+(i*4)-3, row = 4)
- }
- }
- }
- label <- theme_render(
- theme, "legend.text",
- mapping$.label[[i]], hjust = hpos,
- x = hpos, y = 0.5
- )
- if (direction == "vertical") {
- fg <- placeGrob(fg, label, col = 4, row = i+3)
- } else if (direction == "horizontal") {
- fg <- placeGrob(fg, label, col = 1+(i*4)-1, row = 4)
- }
- }
- fg
-}
-
-build_legend_data <- function(layer, mapping, default_mapping) {
- all <- names(c(layer$mapping, default_mapping, layer$stat$default_aes()))
- geom <- c(layer$geom$required_aes, names(layer$geom$default_aes()))
-
- matched <- intersect(intersect(all, geom), names(mapping))
- matched <- setdiff(matched, names(layer$geom_params))
-
- if (length(matched) > 0) {
- # This layer contributes to the legend
- if (is.na(layer$legend) || layer$legend) {
- # Default is to include it
- layer$use_defaults(mapping[matched])
- } else {
- NULL
- }
- } else {
- # This layer does not contribute to the legend
- if (is.na(layer$legend) || !layer$legend) {
- # Default is to exclude it
- NULL
- } else {
- layer$use_defaults(NULL)[rep(1, nrow(mapping)), ]
- }
- }
-}
View
12 R/plot-render.r
@@ -56,13 +56,13 @@ ggplotGrob <- function(plot, drop = plot$options$drop, keep = plot$options$keep,
# Generate grobs -----------------------------------------------------------
# each of these grobs has a vp set
-
legend_box <- if (position != "none") {
- guide_legends_box(scales, plot$layers, plot$mapping, horiz, theme)
+ guides <- Guides$new(scales=scales, layers=plot$layers, default_mapping=plot$mapping, horizontal=horiz, theme=theme)
+ guides$build_guides()
} else {
zeroGrob()
- }
-
+ }
+
title <- theme_render(theme, "plot.title", plot$options$title)
labels <- cs$labels(list(
@@ -126,8 +126,9 @@ ggplotGrob <- function(plot, drop = plot$options$drop, keep = plot$options$keep,
} else {
legend_vp <- viewport(name = "legend_box")
}
+
vp <- surround_viewports(position, widths, heights, legend_vp)
-
+
# Assign grobs to viewports ------------------------------------------------
edit_vp <- function(x, name) {
editGrob(x, vp=vpPath("background", name))
@@ -136,7 +137,6 @@ ggplotGrob <- function(plot, drop = plot$options$drop, keep = plot$options$keep,
list(theme_render(theme, "plot.background", vp = "background")),
mlply(cbind(x = grobs, name = names(grobs)), edit_vp)
)
-
gTree(children = do.call("gList", grobs), childrenvp = vp)
}
View
10 R/scale-.r
@@ -28,7 +28,7 @@ NULL
#' @paramCopy na.value scales::cscale
#' @paramCopy trans scales::cscale
#' @export
-continuous_scale <- function(aesthetics, scale_name, palette, name = NULL, breaks = NULL, nbreaks = NULL, labels = NULL, legend = TRUE, limits = NULL, rescaler = rescale, oob = censor, expand = c(0, 0), na.value = NA, trans = "identity", guide="default") {
+continuous_scale <- function(aesthetics, scale_name, palette, name = NULL, breaks = NULL, nbreaks = NULL, labels = NULL, legend = TRUE, limits = NULL, rescaler = rescale, oob = censor, expand = c(0, 0), na.value = NA, trans = "identity", guide="legend") {
trans <- as.trans(trans)
if (!is.null(limits)) {
@@ -60,7 +60,7 @@ continuous_scale <- function(aesthetics, scale_name, palette, name = NULL, break
}
#' @export
-discrete_scale <- function(aesthetics, scale_name, palette, name = NULL, breaks = NULL, labels = NULL, legend = TRUE, limits = NULL, expand = c(0, 0), na.value = NA, drop = TRUE) {
+discrete_scale <- function(aesthetics, scale_name, palette, name = NULL, breaks = NULL, nbreaks = NULL, labels = NULL, legend = TRUE, limits = NULL, expand = c(0, 0), na.value = NA, drop = TRUE, guide="legend") {
structure(list(
call = match.call(),
@@ -74,10 +74,12 @@ discrete_scale <- function(aesthetics, scale_name, palette, name = NULL, breaks
expand = expand,
name = name,
- breaks = breaks,
+ breaks = breaks,
+ nbreaks = nbreaks,
labels = labels,
legend = legend,
- drop = drop
+ drop = drop,
+ guide = guide
), class = c(scale_name, "discrete", "scale"))
}
View
4 R/scale-hue.r
@@ -28,11 +28,11 @@
#' d + geom_point(alpha = 0.5)
#' d + geom_point(alpha = 0.2)
scale_colour_hue <- function(..., h = c(0, 360) + 15, c = 100, l = 65, h.start = 0, direction = 1) {
- discrete_scale("colour", "hue", hue_pal(h, c, l, h.start, direction))
+ discrete_scale("colour", "hue", hue_pal(h, c, l, h.start, direction), ...)
}
scale_fill_hue <- function(..., h = c(0, 360) + 15, c = 100, l = 65, h.start = 0, direction = 1) {
- discrete_scale("fill", "hue", hue_pal(h, c, l, h.start, direction))
+ discrete_scale("fill", "hue", hue_pal(h, c, l, h.start, direction), ...)
}
icon.hue <- function() {
View
12 R/scale-identity.r
@@ -16,23 +16,23 @@
#' # cyl used as point size
#' qplot(mpg, wt, data = mtcars, size = cyl) + scale_size_identity()
scale_colour_identity <- function(...) {
- discrete_scale("colour", "identity", identity_pal())
+ discrete_scale("colour", "identity", identity_pal(), ...)
}
scale_fill_identity <- function(...) {
- discrete_scale("fill", "identity", identity_pal())
+ discrete_scale("fill", "identity", identity_pal(), ...)
}
scale_shape_identity <- function(...) {
- discrete_scale("shape", "identity", identity_pal())
+ discrete_scale("shape", "identity", identity_pal(), ...)
}
scale_linetype_identity <- function(...) {
- discrete_scale("linetype", "identity", identity_pal())
+ discrete_scale("linetype", "identity", identity_pal(), ...)
}
scale_alpha_identity <- function(...) {
- continuous_scale("alpha", "identity", identity_pal())
+ continuous_scale("alpha", "identity", identity_pal(), ...)
}
scale_size_identity <- function(...) {
- continuous_scale("size", "identity", identity_pal())
+ continuous_scale("size", "identity", identity_pal(), ...)
}
icon.identity <- function() textGrob("f(x) = x", gp=gpar(cex=1.2))
View
2 R/scale-linetype.r
@@ -17,7 +17,7 @@
#'
#' # See scale_manual for more flexibility
scale_linetype_discrete <- function(...) {
- discrete_scale("linetype", "linetype_d", linetype_pal())
+ discrete_scale("linetype", "linetype_d", linetype_pal(), ...)
}
scale_linetype_continuous <- function(...) {
stop("A continuous variable can not be mapped to linetype", call. = FALSE)
View
10 R/scale-manual.r
@@ -20,19 +20,19 @@
#' p + scale_colour_manual(values = cols, limits = c("4", "8"))
#' p + scale_colour_manual(values = cols, limits = c("4", "6", "8", "10"))
scale_colour_manual <- function(..., values) {
- discrete_scale("colour", "manual", manual_pal(values))
+ discrete_scale("colour", "manual", manual_pal(values), ...)
}
scale_fill_manual <- function(..., values) {
- discrete_scale("fill", "manual", manual_pal(values))
+ discrete_scale("fill", "manual", manual_pal(values), ...)
}
scale_size_manual <- function(..., values) {
- discrete_scale("size", "manual", manual_pal(values))
+ discrete_scale("size", "manual", manual_pal(values), ...)
}
scale_shape_manual <- function(..., values) {
- discrete_scale("shape", "manual", manual_pal(values))
+ discrete_scale("shape", "manual", manual_pal(values), ...)
}
scale_linetype_manual <- function(..., values) {
- discrete_scale("linetype", "manual", manual_pal(values))
+ discrete_scale("linetype", "manual", manual_pal(values), ...)
}
icon.manual <- function() textGrob("DIY", gp=gpar(cex=1.2))
View
2 R/scale-shape.r
@@ -20,7 +20,7 @@
#' # Or for short:
#' d %+% dsmall
scale_shape <- function(..., solid = TRUE) {
- discrete_scale("shape", "shape_d", shape_pal(solid))
+ discrete_scale("shape", "shape_d", shape_pal(solid), ...)
}
scale_shape_discrete <- scale_shape
View
2 R/scale-size.r
@@ -33,7 +33,7 @@ scale_size <- scale_size_continuous
#' @export
scale_size_discrete <- function(..., range = c(1, 6)) {
discrete_scale("size", "size_d",
- function(n) seq(range[1], range[2], length = n))
+ function(n) seq(range[1], range[2], length = n), ...)
}
icon.size <- function() {
View
56 R/scales-.r
@@ -92,59 +92,3 @@ scales_add_defaults <- function(scales, data, aesthetics, env) {
}
}
}
-
-scales_legend_desc <- function(scales, theme) {
- # Loop through all scales, creating a list of titles, and a list of keys
- keys <- titles <- vector("list", length(scales$scales))
- hash <- character(length(scales$scales))
- guide <- character(length(scales$scales))
-
- for(i in seq_along(hash)) {
- scale <- scales$scales[[i]]
- if (!scale$legend || is.null(scale_limits(scale))) next
-
- # Figure out legend title
- output <- scale$aesthetics[1]
- titles[[i]] <- scale$name %||% theme$labels[[output]]
-
- guide[i] <- nulldefault(scale$guide, "default")
-
- if (guide[i] == "colorbar") {
-
- if (is.null(scale$breaks)) {
- breaks <- pretty(scale_limits(scale), nulldefault(scale$nbreak, 5))
- } else if (is.function(scale$breaks)) {
- breaks <- scale$breaks(limits)
- } else {
- breaks <- scale$breaks
- }
- breaks <- discard(breaks, scale_limits(scale))
- key <- data.frame(
- scale_map(scale, breaks), I(scale_labels(scale, breaks)), breaks,
- stringsAsFactors = FALSE)
- names(key) <- c(output, ".label", ".value")
-
- bar <- discard(pretty(scale_limits(scale), n = nulldefault(theme$legend.colorbar.nbin, 20)), scale_limits(scale))
- attr(key, "bar") <- data.frame(colour=scale_map(scale, bar), value=bar, stringsAsFactors = FALSE)
-
- hash[i] <- digest(list(titles[[i]], key$.label, key[[output]], guide[i]))
-
- } else if (guide[i] == "default") {
-
- key <- data.frame(
- scale_map(scale, scale_breaks(scale)), I(scale_labels(scale)),
- stringsAsFactors = FALSE)
- names(key) <- c(output, ".label")
-
- hash[i] <- digest(list(titles[[i]], key$.label, guide[i]))
- } else {
- warning("Unknown guide type:", guide[i], call. = FALSE)
- }
-
- keys[[i]] <- key
- }
-
- empty <- sapply(titles, is.null)
-
- list(titles = titles[!empty], keys = keys[!empty], hash = hash[!empty], guide=guide[!empty])
-}

0 comments on commit 147f025

Please sign in to comment.
Something went wrong with that request. Please try again.