1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
|
# Scales object encapsultes multiple scales.
# All input and output done with data.frames to facilitate
# multiple input and output variables
#' @importFrom methods setRefClass
Scales <- setRefClass("Scales", fields = "scales", methods = list(
find = function(aesthetic) {
vapply(scales, function(x) any(aesthetic %in% x$aesthetics), logical(1))
},
has_scale = function(aesthetic) {
any(find(aesthetic))
},
add = function(scale) {
prev_aes <- find(scale$aesthetics)
if (any(prev_aes)) {
# Get only the first aesthetic name in the returned vector -- it can
# sometimes be c("x", "xmin", "xmax", ....)
scalename <- scales[prev_aes][[1]]$aesthetics[1]
message("Scale for '", scalename,
"' is already present. Adding another scale for '", scalename,
"', which will replace the existing scale.")
}
# Remove old scale for this aesthetic (if it exists)
scales <<- c(scales[!prev_aes], list(scale))
},
clone = function() {
new_scales <- lapply(scales, scale_clone)
Scales$new(new_scales)
},
n = function() {
length(scales)
},
input = function() {
unlist(lapply(scales, "[[", "aesthetics"))
},
initialize = function(scales = NULL) {
initFields(scales = scales)
},
non_position_scales = function(.) {
Scales$new(scales[!find("x") & !find("y")])
},
get_scales = function(output) {
scale <- scales[find(output)]
if (length(scale) == 0) return()
scale[[1]]
}
))
# Train scale from a data frame
scales_train_df <- function(scales, df, drop = FALSE) {
if (empty(df) || length(scales$scales) == 0) return()
lapply(scales$scales, scale_train_df, df = df)
}
# Map values from a data.frame. Returns data.frame
scales_map_df <- function(scales, df) {
if (empty(df) || length(scales$scales) == 0) return(df)
mapped <- unlist(lapply(scales$scales, scale_map_df, df = df), recursive = FALSE)
quickdf(c(mapped, df[setdiff(names(df), names(mapped))]))
}
# Transform values to cardinal representation
scales_transform_df <- function(scales, df) {
if (empty(df) || length(scales$scales) == 0) return(df)
transformed <- unlist(lapply(scales$scales, scale_transform_df, df = df),
recursive = FALSE)
quickdf(c(transformed, df[setdiff(names(df), names(transformed))]))
}
# @param aesthetics A list of aesthetic-variable mappings. The name of each
# item is the aesthetic, and the value of each item is the variable in data.
scales_add_defaults <- function(scales, data, aesthetics, env) {
if (is.null(aesthetics)) return()
names(aesthetics) <- unlist(lapply(names(aesthetics), aes_to_scale))
new_aesthetics <- setdiff(names(aesthetics), scales$input())
# No new aesthetics, so no new scales to add
if (is.null(new_aesthetics)) return()
datacols <- tryapply(
aesthetics[new_aesthetics], eval,
envir = data, enclos = env
)
for(aes in names(datacols)) {
type <- scale_type(datacols[[aes]])
scale_name <- paste("scale", aes, type, sep="_")
# Skip aesthetics with no scales (e.g. group, order, etc)
scale_f <- find_global(scale_name, env, mode = "function")
if (is.null(scale_f)) next
scales$add(scale_f())
}
}
# Add missing but required scales.
# @param aesthetics A character vector of aesthetics. Typically c("x", "y").
scales_add_missing <- function(plot, aesthetics, env) {
# Keep only aesthetics that aren't already in plot$scales
aesthetics <- setdiff(aesthetics, plot$scales$input())
for (aes in aesthetics) {
scale_name <- paste("scale", aes, "continuous", sep="_")
scale_f <- find_global(scale_name, env, mode = "function")
plot$scales$add(scale_f())
}
}
# Look for object first in parent environment and if not found, then in
# ggplot2 namespace environment. This makes it possible to override default
# scales by setting them in the parent environment.
find_global <- function(name, env, mode = "any") {
if (exists(name, envir = env, mode = mode)) {
return(get(name, envir = env, mode = mode))
}
nsenv <- asNamespace("ggplot2")
if (exists(name, envir = nsenv, mode = mode)) {
return(get(name, envir = nsenv, mode = mode))
}
NULL
}
# Determine default type of a scale
scale_type <- function(x) UseMethod("scale_type")
#' @export
scale_type.default <- function(x) {
message("Don't know how to automatically pick scale for object of type ",
paste(class(x), collapse = "/"), ". Defaulting to continuous")
"continuous"
}
#' @export
scale_type.logical <- function(x) "discrete"
#' @export
scale_type.character <- function(x) "discrete"
#' @export
scale_type.factor <- function(x) "discrete"
#' @export
scale_type.POSIXt <- function(x) "datetime"
#' @export
scale_type.Date <- function(x) "date"
#' @export
scale_type.numeric <- function(x) "continuous"
|
