@@ -61,94 +61,88 @@ 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- # '
105- # ' data(mpg)
106- # '
106+ # ' \donttest{
107107# ' p1 <- ggplot(mpg, aes(cty, hwy)) + geom_point()
108- # '
109- # '
110108# ' p1 + facet_grid(cyl ~ class, labeller=label_both)
111- # '
112109# ' 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,
110+ # '
111+ # ' ggplot(mtcars, aes(x = mpg, y = wt)) + geom_point() +
112+ # ' facet_grid(vs + am ~ gear, margins=TRUE,
116113# ' labeller=labeller(vs=label_both, am=label_both))
117- # '
118- # '
119- # '
120- # ' data(msleep)
114+ # '
121115# ' capitalize <- function(string) {
122116# ' substr(string, 1, 1) <- toupper(substr(string, 1, 1))
123- # ' string
117+ # ' string
124118# ' }
125119# ' conservation_status <- c('cd'='Conservation Dependent',
126- # ' 'en'='Endangered',
120+ # ' 'en'='Endangered',
127121# ' 'lc'='Least concern',
128- # ' 'nt'='Near Threatened',
122+ # ' 'nt'='Near Threatened',
129123# ' 'vu'='Vulnerable',
130124# ' 'domesticated'='Domesticated')
131- # ' ## Source: http://en.wikipedia.org/wiki/Wikipedia:Conservation_status
132- # '
133- # ' p2 <- ggplot(msleep, aes(x=sleep_total, y=awake)) + geom_point()
134- # ' p2 + facet_grid(vore ~ conservation, labeller= labeller(vore= capitalize))
135- # '
136- # ' p2 + facet_grid(vore ~ conservation,
137- # ' labeller=labeller(vore= capitalize, conservation= conservation_status ))
138- # '
139- # ' # We could of course have renamed the levels;
140- # ' # then we can apply another nifty function:
141- # ' library( plyr)
142- # ' msleep$conservation2 <- revalue(msleep$conservation, conservation_status)
143- # '
144- # ' p2 %+% msleep + facet_grid(vore ~ conservation2, labeller= labeller(vore= capitalize))
145- # '
146- # ' p2 %+% msleep + facet_grid(vore ~ conservation2,
147- # ' labeller=labeller(conservation2= label_wrap_gen(10) ))
148- # '
125+ # ' ## Source: http://en.wikipedia.org/wiki/Wikipedia:Conservation_status
126+ # '
127+ # ' p2 <- ggplot(msleep, aes(x=sleep_total, y=awake)) + geom_point()
128+ # ' p2 + facet_grid(vore ~ conservation, labeller = labeller(vore = capitalize))
129+ # '
130+ # ' p2 + facet_grid(vore ~ conservation,
131+ # ' labeller=labeller(vore = capitalize, conservation = conservation_status ))
132+ # '
133+ # ' # We could of course have renamed the levels;
134+ # ' # then we can apply another nifty function
135+ # ' msleep$conservation2 <- plyr::revalue(msleep$conservation, conservation_status )
136+ # '
137+ # ' p2 %+% msleep +
138+ # ' facet_grid(vore ~ conservation2, labeller = labeller(vore = capitalize))
139+ # ' p2 %+% msleep +
140+ # ' facet_grid(vore ~ conservation2, labeller = labeller(conservation2 =
141+ # ' label_wrap_gen(10)))
142+ # ' }
149143labeller <- function (... , keep.as.numeric = FALSE ) {
150144 args <- list (... )
151-
145+
152146 function (variable , values ) {
153147 if (is.logical(values )) {
154148 values <- as.integer(values ) + 1
@@ -157,27 +151,27 @@ labeller <- function(..., keep.as.numeric=FALSE) {
157151 } else if (is.numeric(values ) & ! keep.as.numeric ) {
158152 values <- as.character(values )
159153 }
160-
154+
161155 res <- args [[variable ]]
162-
156+
163157 if (is.null(res )) {
164158 # If the facetting margin (i.e. `variable`) was not specified when calling
165159 # labeller, default to use the actual values.
166160 result <- values
167-
161+
168162 } else if (is.function(res )) {
169163 # How should `variable` and `values` be passed to a function? ------------
170- arguments <- length(formals(res ))
164+ arguments <- length(formals(res ))
171165 if (arguments < 2 ) {
172166 result <- res(values )
173167 } else {
174168 result <- res(variable , values )
175- }
176-
169+ }
170+
177171 } else {
178172 result <- res [values ]
179173 }
180-
174+
181175 return (result )
182176 }
183177}
0 commit comments