R/plot.surface.R

In fields: Tools for Spatial Data

#
# fields  is a package for analysis of spatial data written for
# the R software environment.
# Copyright (C) 2024 Colorado School of Mines
# 1500 Illinois St., Golden, CO 80401
# Contact: Douglas Nychka,  douglasnychka@gmail.com,
#
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with the R software environment if not, write to the Free Software
# Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301  USA
# or see http://www.r-project.org/Licenses/GPL-2
##END HEADER
"plot.surface" <- function(x, main = NULL, type = "C", 
    zlab = NULL, xlab = NULL, ylab = NULL, levels = NULL, zlim = NULL, 
    graphics.reset = NULL, labcex = 0.6, add.legend = TRUE, ...) {
    obj <- x
    old.par <- par(no.readonly = TRUE)
    if (is.na(match(type, c("b", "c", "C", "I", "p")))) {
        stop("plot type does not match b, C, I, or p.")
    }
    if (is.null(zlim)) {
        zlim = range(obj$z, na.rm = TRUE)
    }
    if (is.null(graphics.reset) & (type == "b")) {
        graphics.reset <- TRUE
    }
    else {
        graphics.reset <- FALSE
    }
    if (graphics.reset) {
        on.exit(par(old.par))
    }
    if (is.null(xlab)) {
        if (is.null(obj$xlab)) 
            xlab <- "X"
        else xlab <- obj$xlab
    }
    if (is.null(ylab)) {
        if (is.null(obj$ylab)) 
            ylab <- "Y"
        else ylab <- obj$ylab
    }
    if (is.null(zlab)) {
        if (is.null(obj$zlab)) 
            zlab <- "Z"
        else zlab <- obj$zlab
    }
    if (is.null(main)) 
        if (!is.null(obj$main)) 
            main <- obj$main
    if (type == "b") 
        set.panel(1, 2, TRUE)
    if (type == "p" | type == "b") {
        if (type == "b") {
            add.legend <- FALSE
            old.mar <- par()$mar
            par(mar = c(0, 5, 0, 0))
        }
        drape.plot(obj, xlab = xlab, ylab = ylab, zlab = zlab, 
            zlim = zlim, add.legend = add.legend, ...)
        if (!is.null(main)) 
            title(main)
    }
    if (type == "I") {
        image.plot(obj$x, obj$y, obj$z, xlab = xlab, ylab = ylab, 
            zlim = zlim, ...)
        if ((!is.null(main)) & type != "b") 
            title(main)
    }
    if (type == "c") {
        if (is.null(levels)) 
            levels <- pretty(obj$z[!is.na(obj$z)], 5)
        contour(obj$x, obj$y, obj$z, levels = levels, labcex = labcex, 
            lwd = 2, ...)
        if ((!is.null(main)) & type != "b") 
            title(main)
    }
    if (type == "b" | type == "C") {
        if (type == "b") {
            par(mar = old.mar)
        }
        image.plot(obj$x, obj$y, obj$z, xlab = xlab, ylab = ylab, 
            graphics.reset = graphics.reset, zlim = zlim, ...)
        if (is.null(levels)) 
            levels <- pretty(obj$z[!is.na(obj$z)], 5)
        contour(obj$x, obj$y, obj$z, add = TRUE, levels = levels, 
            labcex = labcex, col = "black", lwd = 2)
        if ((!is.null(main)) & type != "b") 
            title(main)
    }
    invisible()
}