-
Notifications
You must be signed in to change notification settings - Fork 1
/
panel.3d.contour.R
112 lines (112 loc) · 4.35 KB
/
panel.3d.contour.R
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
#' @name panel.3d.contour
#' @export
#' @importFrom lattice ltransform3dto3d panel.lines panel.3dwire
#' @author Walmes Zeviani, \email{walmes@@ufpr.br}, based on the
#' messages to the R-help mailing list.
#' @title Lattice Panel for Draw Contour Lines In Wireframe Plots
#' @description Used to superpose contour lines at the bottom, top or on
#' the surface of a wireframe.
#' @param type a string vector. The values allowed are \code{top},
#' \code{bottom} and/or \code{on}. Can be use more than one.
#' @param levels the same argument defined in
#' \code{\link[lattice]{wireframe}()}.
#' @param nlevels the same argument defined in
#' \code{\link[lattice]{wireframe}()}.
#' @param col.contour color of the contour lines.
#' @param x,y,z,rot.mat,distance,zlim.scaled,zlim,... arguments passed
#' to panel.3dwire, the core function of wireframe.
#' @seealso \code{\link[lattice]{wireframe}()}.
#' @examples
#'
#' library(lattice)
#' library(latticeExtra)
#' library(RColorBrewer)
#'
#' #--------------------------------------------
#' # Example 1.
#'
#' # display.brewer.all()
#' colr <- brewer.pal(11, "RdYlGn")
#' colr <- colorRampPalette(colr, space = "rgb")
#'
#' grid <- expand.grid(x = seq(0, 1, by = 0.05),
#' y = seq(0, 1, by = 0.05))
#' grid$z <- with(grid, x + y)
#'
#' wireframe(z ~ x + y, data = grid,
#' scales = list(arrows = FALSE),
#' panel.3d.wireframe = panel.3d.contour,
#' levels = seq(0.5, 1.5, by = 0.1), type = "on",
#' col.regions = colr(101), drape = TRUE)
#'
#' #--------------------------------------------
#' # Example 2.
#'
#' colr <- brewer.pal(11, "Spectral")
#' colr <- colorRampPalette(colr, space = "rgb")
#'
#' grid <- expand.grid(x = seq(-1, 1, by = 0.1),
#' y = seq(-1, 1, by = 0.1))
#' grid$z <- with(grid, 1 + 0.01 * x + 0.05 * y -
#' 0.5 * x * y - 0.5 * x^2 - 0.2 * y^2)
#'
#' wireframe(z ~ x + y, data = grid,
#' scales = list(arrows = FALSE),
#' zlim = extendrange(grid$z, f = 0.5),
#' panel.3d.wireframe = panel.3d.contour,
#' nlevels = 18, col = "gray30",
#' type = c("on", "top", "bottom"),
#' col.regions = colr(101), drape = TRUE)
#'
panel.3d.contour <- function(x, y, z, rot.mat, distance,
type = c("on", "top", "bottom"),
nlevels = 20, levels = NULL, zlim.scaled,
zlim, col.contour = 1, ...) {
# Test for the values at the argument `type=`.
if (!any(type %in% c("on", "top", "bottom"))) {
stop("`type=` must be \"on\", \"top\" and/or \"bottom\".")
}
if (is.null(levels)) {
levels.scaled <- pretty(range(z, na.rm = TRUE), nlevels)
} else {
nlevels <- length(levels)
levels.scaled <- (levels - zlim[1])/diff(range(zlim)) - 0.5
}
# Estimate the contour lines.
clines <- grDevices::contourLines(x, y,
matrix(z,
nrow = length(x),
byrow = TRUE),
nlevels = nlevels,
levels = levels.scaled)
# Draw contour lines on the floor (bottom).
if (any(type %in% c("bottom"))) {
for (ll in clines) {
n <- ltransform3dto3d(rbind(ll$x, ll$y, zlim.scaled[1]),
rot.mat, distance)
panel.lines(n[1, ], n[2, ], col = col.contour,
lty = 1, lwd = 1)
}
}
# Draw the wireframe surface.
panel.3dwire(x, y, z, rot.mat, distance,
zlim.scaled = zlim.scaled, ...)
# Draw contour lines on the surface (on).
if (any(type %in% c("on"))) {
for (ll in clines) {
n <- ltransform3dto3d(rbind(ll$x, ll$y, ll$level),
rot.mat, distance)
panel.lines(n[1, ], n[2, ], col = col.contour,
lty = 1, lwd = 1)
}
}
# Draw contour lines on the top of cube (top).
if (any(type %in% c("top"))) {
for (ll in clines) {
n <- ltransform3dto3d(rbind(ll$x, ll$y, zlim.scaled[2]),
rot.mat, distance)
panel.lines(n[1, ], n[2, ], col = col.contour,
lty = 1, lwd = 1)
}
}
}