Feature/stefanedwards labeller

NAMESPACE

@@ -270,6 +270,8 @@ export(label_both)
 export(label_bquote)
 export(label_parsed)
 export(label_value)
+export(label_wrap_gen)
+export(labeller)
 export(labs)
 export(last_plot)
 export(layer)

NEWS

@@ -1,3 +1,13 @@
+ggplot2 0.9.3.1.99
+----------------------------------------------------------------
+
+* Added helper function `labeller` for formatting faceting values.
+  (@stefanedwards, #910)
+
+* Added `label_wrap_gen` based on 
+  https://github.com/hadley/ggplot2/wiki/labeller#writing-new-labellers
+  (@stefanedwards, #910)
+
 ggplot2 0.9.3.1
 ----------------------------------------------------------------
 

R/facet-labels.r

@@ -62,6 +62,128 @@ label_bquote <- function(expr = beta ^ .(x)) {
   }
 }
 
+#' Label facets with a word wrapped label.
+#' 
+#' Uses \code{\link[base]{strwrap}} for line wrapping.
+#' @param width integer, target column width for output.
+#' @export
+#' @seealso , \code{\link{labeller}}
+label_wrap_gen <- function(width = 25) {
+  function(variable, values) {
+    vapply(strwrap(as.character(values), width = width, simplify = FALSE), 
+           paste, vector('character', 1), collapse = "\n")
+  }
+}
+
+#' Generic labeller function for facets
+#' 
+#' One-step function for providing methods or named character vectors
+#' for displaying labels in facets.
+#' 
+#' The provided methods are checked for number of arguments.
+#' If the provided method takes less than two 
+#' (e.g. \code{\link[Hmisc]{capitalize}}), 
+#' the method is passed \code{values}.
+#' Else (e.g. \code{\link{label_both}}), 
+#' it is passed \code{variable} and \code{values} (in that order).
+#' If you want to be certain, use e.g. an anonymous function.
+#' If errors are returned such as ``argument ".." is missing, with no default'' 
+#' or ``unused argument (variable)'', matching the method's arguments does not
+#' work as expected; make a wrapper function.
+#' 
+#'
+#' @param ... Named arguments of the form \code{variable=values}, 
+#'   where \code{values} could be a vector or method.         
+#' @param keep.as.numeric logical, default TRUE. When FALSE, converts numeric 
+#'   values supplied as margins to the facet to characters.
+#' @family facet labeller
+#' @return Function to supply to 
+#'   \code{\link{facet_grid}} for the argument \code{labeller}.
+#' @export 
+#' @examples
+#' 
+#' data(mpg)
+#' 
+#' p1 <- ggplot(mpg, aes(cty, hwy)) + geom_point()
+#' 
+#' 
+#' p1 + facet_grid(cyl ~ class, labeller=label_both)
+#'   
+#' p1 + facet_grid(cyl ~ class, labeller=labeller(cyl=label_both))
+#'   
+#' ggplot(mtcars, aes(x = mpg, y = wt)) + geom_point() + 
+#'   facet_grid(vs + am ~ gear, margins=TRUE, 
+#'              labeller=labeller(vs=label_both, am=label_both))
+#' 
+#' 
+#' 
+#' data(msleep)
+#' capitalize <- function(string) {
+#'   substr(string, 1, 1) <- toupper(substr(string, 1, 1))
+#'  string 
+#' }
+#' conservation_status <- c('cd'='Conservation Dependent',
+#'                          'en'='Endangered', 
+#'                          'lc'='Least concern',
+#'                          'nt'='Near Threatened', 
+#'                          'vu'='Vulnerable',
+#'                          'domesticated'='Domesticated')
+#' ## Source: http://en.wikipedia.org/wiki/Wikipedia:Conservation_status 
+#'
+#' p2 <- ggplot(msleep, aes(x=sleep_total, y=awake)) + geom_point() + 
+#' p2 + facet_grid(vore ~ conservation, labeller=labeller(vore=capitalize))
+#'   
+#' p2 + facet_grid(vore ~ conservation, 
+#'   labeller=labeller(vore=capitalize, conservation=conservation_status ))
+#' 
+#' # We could of course have renamed the levels; 
+#' # then we can apply another nifty function:
+#' library(plyr)
+#' msleep$conservation2 <- revalue(msleep$conservation, conservation_status)                         
+#'
+#' p2 + facet_grid(vore ~ conservation2, labeller=labeller(vore=capitalize))
+#' 
+#' p2 + facet_grid(vore ~ conservation2, 
+#'   labeller=labeller(conservation2=label_wrap_gen(10) ))
+#' 
+labeller <- function(..., keep.as.numeric=FALSE) {
+  args <- list(...)
+
+  function(variable, values) {
+    if (is.logical(values)) {
+      values <- as.integer(values) + 1
+    } else if (is.factor(values)) {
+      values <- as.character(values)
+    } else if (is.numeric(values) & !keep.as.numeric) {
+      values <- as.character(values)
+    }
+
+    res <- args[[variable]]
+
+    if (is.null(res)) {
+      # If the facetting margin (i.e. `variable`) was not specified when calling
+      # labeller, default to use the actual values.
+      result <- values
+
+    } else if (is.function(res)) {
+      # How should `variable` and `values` be passed to a function? ------------
+      arguments <- length(formals(res))    
+      if (arguments < 2) {
+        result <- res(values)
+      } else {
+        result <- res(variable, values)
+      }     
+
+    } else {
+      result <- res[values]
+    }
+
+    return(result)
+  }
+}
+
+
+
 # Grob for strip labels
 ggstrip <- function(text, horizontal=TRUE, theme) {
   text_theme <- if (horizontal) "strip.text.x" else "strip.text.y"

man/label_wrap_gen.Rd

@@ -0,0 +1,17 @@
+% Generated by roxygen2 (4.0.0): do not edit by hand
+\name{label_wrap_gen}
+\alias{label_wrap_gen}
+\title{Label facets with a word wrapped label.}
+\usage{
+label_wrap_gen(width = 25)
+}
+\arguments{
+  \item{width}{integer, target column width for output.}
+}
+\description{
+Uses \code{\link[base]{strwrap}} for line wrapping.
+}
+\seealso{
+, \code{\link{labeller}}
+}
+

man/labeller.Rd

@@ -0,0 +1,82 @@
+% Generated by roxygen2 (4.0.0): do not edit by hand
+\name{labeller}
+\alias{labeller}
+\title{Generic labeller function for facets}
+\usage{
+labeller(..., keep.as.numeric = FALSE)
+}
+\arguments{
+  \item{...}{Named arguments of the form
+  \code{variable=values}, where \code{values} could be a
+  vector or method.}
+
+  \item{keep.as.numeric}{logical, default TRUE. When FALSE,
+  converts numeric values supplied as margins to the facet
+  to characters.}
+}
+\value{
+Function to supply to
+  \code{\link{facet_grid}} for the argument \code{labeller}.
+}
+\description{
+One-step function for providing methods or named character vectors
+for displaying labels in facets.
+}
+\details{
+The provided methods are checked for number of arguments.
+If the provided method takes less than two
+(e.g. \code{\link[Hmisc]{capitalize}}),
+the method is passed \code{values}.
+Else (e.g. \code{\link{label_both}}),
+it is passed \code{variable} and \code{values} (in that order).
+If you want to be certain, use e.g. an anonymous function.
+If errors are returned such as ``argument ".." is missing, with no default''
+or ``unused argument (variable)'', matching the method's arguments does not
+work as expected; make a wrapper function.
+}
+\examples{
+data(mpg)
+
+p1 <- ggplot(mpg, aes(cty, hwy)) + geom_point()
+
+
+p1 + facet_grid(cyl ~ class, labeller=label_both)
+
+p1 + facet_grid(cyl ~ class, labeller=labeller(cyl=label_both))
+
+ggplot(mtcars, aes(x = mpg, y = wt)) + geom_point() +
+  facet_grid(vs + am ~ gear, margins=TRUE,
+             labeller=labeller(vs=label_both, am=label_both))
+
+
+
+data(msleep)
+capitalize <- function(string) {
+  substr(string, 1, 1) <- toupper(substr(string, 1, 1))
+ string
+}
+conservation_status <- c('cd'='Conservation Dependent',
+                         'en'='Endangered',
+                         'lc'='Least concern',
+                         'nt'='Near Threatened',
+                         'vu'='Vulnerable',
+                         'domesticated'='Domesticated')
+## Source: http://en.wikipedia.org/wiki/Wikipedia:Conservation_status
+
+p2 <- ggplot(msleep, aes(x=sleep_total, y=awake)) + geom_point() +
+p2 + facet_grid(vore ~ conservation, labeller=labeller(vore=capitalize))
+
+p2 + facet_grid(vore ~ conservation,
+  labeller=labeller(vore=capitalize, conservation=conservation_status ))
+
+# We could of course have renamed the levels;
+# then we can apply another nifty function:
+library(plyr)
+msleep$conservation2 <- revalue(msleep$conservation, conservation_status)
+
+p2 + facet_grid(vore ~ conservation2, labeller=labeller(vore=capitalize))
+
+p2 + facet_grid(vore ~ conservation2,
+  labeller=labeller(conservation2=label_wrap_gen(10) ))
+}
+