@@ -61,94 +61,96 @@ label_bquote <- function(expr = beta ^ .(x)) {
6161 eval(substitute(bquote(expr , list (x = x )), list (expr = quoted ))))
6262 }
6363}
64+ globalVariables(" x" )
65+
6466
6567# ' Label facets with a word wrapped label.
66- # '
68+ # '
6769# ' Uses \code{\link[base]{strwrap}} for line wrapping.
6870# ' @param width integer, target column width for output.
6971# ' @export
7072# ' @seealso , \code{\link{labeller}}
7173label_wrap_gen <- function (width = 25 ) {
7274 function (variable , values ) {
73- vapply(strwrap(as.character(values ), width = width , simplify = FALSE ),
75+ vapply(strwrap(as.character(values ), width = width , simplify = FALSE ),
7476 paste , vector(' character' , 1 ), collapse = " \n " )
7577 }
7678}
7779
7880# ' Generic labeller function for facets
79- # '
81+ # '
8082# ' One-step function for providing methods or named character vectors
8183# ' for displaying labels in facets.
82- # '
84+ # '
8385# ' The provided methods are checked for number of arguments.
84- # ' If the provided method takes less than two
85- # ' (e.g. \code{\link[Hmisc]{capitalize}}),
86+ # ' If the provided method takes less than two
87+ # ' (e.g. \code{\link[Hmisc]{capitalize}}),
8688# ' the method is passed \code{values}.
87- # ' Else (e.g. \code{\link{label_both}}),
89+ # ' Else (e.g. \code{\link{label_both}}),
8890# ' it is passed \code{variable} and \code{values} (in that order).
8991# ' If you want to be certain, use e.g. an anonymous function.
90- # ' If errors are returned such as ``argument ".." is missing, with no default''
92+ # ' If errors are returned such as ``argument ".." is missing, with no default''
9193# ' or ``unused argument (variable)'', matching the method's arguments does not
9294# ' work as expected; make a wrapper function.
93- # '
9495# '
95- # ' @param ... Named arguments of the form \code{variable=values},
96- # ' where \code{values} could be a vector or method.
97- # ' @param keep.as.numeric logical, default TRUE. When FALSE, converts numeric
96+ # '
97+ # ' @param ... Named arguments of the form \code{variable=values},
98+ # ' where \code{values} could be a vector or method.
99+ # ' @param keep.as.numeric logical, default TRUE. When FALSE, converts numeric
98100# ' values supplied as margins to the facet to characters.
99101# ' @family facet labeller
100- # ' @return Function to supply to
102+ # ' @return Function to supply to
101103# ' \code{\link{facet_grid}} for the argument \code{labeller}.
102- # ' @export
104+ # ' @export
103105# ' @examples
104- # '
106+ # '
105107# ' data(mpg)
106- # '
108+ # '
107109# ' p1 <- ggplot(mpg, aes(cty, hwy)) + geom_point()
108- # '
109- # '
110+ # '
111+ # '
110112# ' p1 + facet_grid(cyl ~ class, labeller=label_both)
111- # '
113+ # '
112114# ' p1 + facet_grid(cyl ~ class, labeller=labeller(cyl=label_both))
113- # '
114- # ' ggplot(mtcars, aes(x = mpg, y = wt)) + geom_point() +
115- # ' facet_grid(vs + am ~ gear, margins=TRUE,
115+ # '
116+ # ' ggplot(mtcars, aes(x = mpg, y = wt)) + geom_point() +
117+ # ' facet_grid(vs + am ~ gear, margins=TRUE,
116118# ' labeller=labeller(vs=label_both, am=label_both))
117- # '
118- # '
119- # '
119+ # '
120+ # '
121+ # '
120122# ' data(msleep)
121123# ' capitalize <- function(string) {
122124# ' substr(string, 1, 1) <- toupper(substr(string, 1, 1))
123- # ' string
125+ # ' string
124126# ' }
125127# ' conservation_status <- c('cd'='Conservation Dependent',
126- # ' 'en'='Endangered',
128+ # ' 'en'='Endangered',
127129# ' 'lc'='Least concern',
128- # ' 'nt'='Near Threatened',
130+ # ' 'nt'='Near Threatened',
129131# ' 'vu'='Vulnerable',
130132# ' 'domesticated'='Domesticated')
131- # ' ## Source: http://en.wikipedia.org/wiki/Wikipedia:Conservation_status
133+ # ' ## Source: http://en.wikipedia.org/wiki/Wikipedia:Conservation_status
132134# '
133- # ' p2 <- ggplot(msleep, aes(x=sleep_total, y=awake)) + geom_point() +
135+ # ' p2 <- ggplot(msleep, aes(x=sleep_total, y=awake)) + geom_point() +
134136# ' p2 + facet_grid(vore ~ conservation, labeller=labeller(vore=capitalize))
135- # '
136- # ' p2 + facet_grid(vore ~ conservation,
137+ # '
138+ # ' p2 + facet_grid(vore ~ conservation,
137139# ' labeller=labeller(vore=capitalize, conservation=conservation_status ))
138- # '
139- # ' # We could of course have renamed the levels;
140+ # '
141+ # ' # We could of course have renamed the levels;
140142# ' # then we can apply another nifty function:
141143# ' library(plyr)
142- # ' msleep$conservation2 <- revalue(msleep$conservation, conservation_status)
144+ # ' msleep$conservation2 <- revalue(msleep$conservation, conservation_status)
143145# '
144146# ' p2 + facet_grid(vore ~ conservation2, labeller=labeller(vore=capitalize))
145- # '
146- # ' p2 + facet_grid(vore ~ conservation2,
147+ # '
148+ # ' p2 + facet_grid(vore ~ conservation2,
147149# ' labeller=labeller(conservation2=label_wrap_gen(10) ))
148- # '
150+ # '
149151labeller <- function (... , keep.as.numeric = FALSE ) {
150152 args <- list (... )
151-
153+
152154 function (variable , values ) {
153155 if (is.logical(values )) {
154156 values <- as.integer(values ) + 1
@@ -157,27 +159,27 @@ labeller <- function(..., keep.as.numeric=FALSE) {
157159 } else if (is.numeric(values ) & ! keep.as.numeric ) {
158160 values <- as.character(values )
159161 }
160-
162+
161163 res <- args [[variable ]]
162-
164+
163165 if (is.null(res )) {
164166 # If the facetting margin (i.e. `variable`) was not specified when calling
165167 # labeller, default to use the actual values.
166168 result <- values
167-
169+
168170 } else if (is.function(res )) {
169171 # How should `variable` and `values` be passed to a function? ------------
170- arguments <- length(formals(res ))
172+ arguments <- length(formals(res ))
171173 if (arguments < 2 ) {
172174 result <- res(values )
173175 } else {
174176 result <- res(variable , values )
175- }
176-
177+ }
178+
177179 } else {
178180 result <- res [values ]
179181 }
180-
182+
181183 return (result )
182184 }
183185}
0 commit comments