R/panel.3d.contour.R

In walmes/wzRfun: Walmes Zeviani's collection of functions

#' @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)
        }
    }
}