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
|
#' Calculate contours of 3d data.
#'
#' @section Aesthetics:
#' \Sexpr[results=rd,stage=build]{ggplot2:::rd_aesthetics("stat", "contour")}
#'
#' @inheritParams stat_identity
#' @param na.rm If \code{FALSE} (the default), removes missing values with
#' a warning. If \code{TRUE} silently removes missing values.
#' @return A data frame with additional column:
#' \item{level}{height of contour}
#' @export
#' @examples
#' \donttest{
#' # Generate data
#' library(reshape2) # for melt
#' volcano3d <- melt(volcano)
#' names(volcano3d) <- c("x", "y", "z")
#'
#' # Basic plot
#' v <- ggplot(volcano3d, aes(x, y, z = z))
#' v + stat_contour()
#'
#' # Setting bins creates evenly spaced contours in the range of the data
#' v + stat_contour(bins = 2)
#' v + stat_contour(bins = 10)
#'
#' # Setting binwidth does the same thing, parameterised by the distance
#' # between contours
#' v + stat_contour(binwidth = 2)
#' v + stat_contour(binwidth = 5)
#' v + stat_contour(binwidth = 10)
#' v + stat_contour(binwidth = 2, size = 0.5, colour = "grey50") +
#' stat_contour(binwidth = 10, size = 1)
#'
#' # Add aesthetic mappings
#' v + stat_contour(aes(size = ..level..))
#' v + stat_contour(aes(colour = ..level..))
#'
#' # Change scale
#' v + stat_contour(aes(colour = ..level..), size = 2) +
#' scale_colour_gradient(low = "brown", high = "white")
#'
#' # Set aesthetics to fixed value
#' v + stat_contour(colour = "red")
#' v + stat_contour(size = 2, linetype = 4)
#'
#' # Try different geoms
#' v + stat_contour(geom="polygon", aes(fill=..level..))
#' v + geom_tile(aes(fill = z)) + stat_contour()
#'
#' # Use qplot instead
#' qplot(x, y, z = z, data = volcano3d, geom = "contour")
#' qplot(x, y, z = z, data = volcano3d, stat = "contour", geom = "path")
#' }
stat_contour <- function (mapping = NULL, data = NULL, geom = "path", position = "identity",
na.rm = FALSE, ...) {
StatContour$new(mapping = mapping, data = data, geom = geom,
position = position, na.rm = na.rm, ...)
}
StatContour <- proto(Stat, {
objname <- "contour"
calculate <- function(., data, scales, bins=NULL, binwidth=NULL, breaks = NULL, complete = FALSE, na.rm = FALSE, ...) {
data <- remove_missing(data, na.rm, name = "stat_contour", finite = TRUE)
# If no parameters set, use pretty bins
if (is.null(bins) && is.null(binwidth) && is.null(breaks)) {
breaks <- pretty(range(data$z), 10)
}
# If provided, use bins to calculate binwidth
if (!is.null(bins)) {
binwidth <- diff(range(data$z)) / bins
}
# If necessary, compute breaks from binwidth
if (is.null(breaks)) {
breaks <- fullseq(range(data$z), binwidth)
}
contour_lines(data, breaks, complete = complete)
}
default_geom <- function(.) GeomPath
default_aes <- function(.) aes(order = ..level..)
required_aes <- c("x", "y", "z")
})
# v3d <- reshape2::melt(volcano)
# names(v3d) <- c("x", "y", "z")
#
# breaks <- seq(95, 195, length = 10)
# contours <- contour_lines(v3d, breaks)
# qplot(x, y, data = contours, geom = "path") + facet_wrap(~ piece)
contour_lines <- function(data, breaks, complete = FALSE) {
z <- tapply(data$z, data[c("x", "y")], identity)
cl <- contourLines(
x = sort(unique(data$x)), y = sort(unique(data$y)), z = z,
levels = breaks)
if (length(cl) == 0) {
warning("Not possible to generate contour data", call. = FALSE)
return(data.frame())
}
# Convert list of lists into single data frame
lengths <- vapply(cl, function(x) length(x$x), integer(1))
levels <- vapply(cl, "[[", "level", FUN.VALUE = double(1))
xs <- unlist(lapply(cl, "[[", "x"), use.names = FALSE)
ys <- unlist(lapply(cl, "[[", "y"), use.names = FALSE)
pieces <- rep(seq_along(cl), lengths)
# Add leading zeros so that groups can be properly sorted later
groups <- paste(data$group[1], sprintf("%03d", pieces), sep = "-")
data.frame(
level = rep(levels, lengths),
x = xs,
y = ys,
piece = pieces,
group = groups
)
}
# 1 = clockwise, -1 = counterclockwise, 0 = 0 area
# From http://stackoverflow.com/questions/1165647
# x <- c(5, 6, 4, 1, 1)
# y <- c(0, 4, 5, 5, 0)
# poly_dir(x, y)
poly_dir <- function(x, y) {
xdiff <- c(x[-1], x[1]) - x
ysum <- c(y[-1], y[1]) + y
sign(sum(xdiff * ysum))
}
# To fix breaks and complete the polygons, we need to add 0-4 corner points.
#
# contours <- ddply(contours, "piece", mutate, dir = poly_dir(x, y))
# qplot(x, y, data = contours, geom = "path", group = piece,
# colour = factor(dir))
# last_plot() + facet_wrap(~ level)
|
