R/grayplot_na.R

Defines functions grayplot_na

Documented in grayplot_na

#  grayplot_na
#'
#' Scatterplot with missing values indicated
#'
#' Scatterplot with a gray background and with points with missing
#' values shown in separate panels near the margins.
#'
#' @param x Coordinates of points in the plot
#'
#' @param y Coordinates of points in the plot (optional)
#'
#' @param type Plot type (points, lines, etc.)
#'
#' @param bgcolor Background color
#'
#' @param v_over_h If `TRUE`, place vertical grid lines on top of
#' the horizontal ones.
#'
#' @param pch point type
#' @param bg Background color in points
#' @param col Color of outer circle in points
#'
#' @param force Indicates whether to force the NA box (on the x-axis,
#' y-axis, or both) even when there are no missing values.
#'
#' @param ... Optional graphics arguments
#'
#' @details
#' Calls `plot()` with `type="n", then
#' [graphics::rect()] to get the background, and then
#' [graphics::points()].
#'
#' There are a bunch of hidden graphical arguments you can include:
#' `na.width` controls the proportional width devoted to the NA boxes,
#' and `na.gap` the proportion for the gap between the NA boxes and
#' the main plot region. `mgp.x` and `mgp.y` (like `mgp`, for
#' controlling parameters of axis labels, but separate for x- and
#' y-axis). Also `hlines` to indicate locations of of horizontal
#' gridlines, and `hlines.col`, `hlines.lwd`, and `hlines.lty` to set
#' their color, width, and type. `hlines=NA` suppresses the grid
#' lines. Similarly `vlines`, `vlines.col`, `vlines.lwd`, and
#' `vlines.lty`. `xat` and `yat` are for specifying the locations of
#' x- and y-axis labels, respectively. `xat=NA` and `yat=NA` indicate
#' no labels.
#'
#'
#' @export
#' @importFrom graphics title rect axis abline points
#'
#' @return
#' None.
#'
#' @examples
#' \dontshow{set.seed(97536917)}
#' n <- 100
#' x <- rnorm(n)
#' y <- x+rnorm(n, 0, 0.7)
#' x[sample(n, 10)] <- NA
#'
#' grayplot_na(x, y)
#'
#' grayplot_na(x, y, force="y")
#'
#' y[sample(n, 10)] <- NA
#' grayplot_na(x, y)
#'
#' @seealso [grayplot()], [dotplot()]
#'
#' @keywords
#' graphics
grayplot_na <-
    function(x, y=NULL, type="p", bgcolor="gray90", v_over_h=FALSE,
             pch=21, bg="lightblue", col="black",
             force=c("none", "x", "y", "both"), ...)
{
    if(missing(x) || is.null(x)) stop("x unspecified")
    force <- match.arg(force)

    # this is to deal with varying inputs (did "..." include xaxt or not?)
    hidegrayplot_na <-
        function(x, y, ..., type="p",
                 hlines=NULL, hlines.col="white", hlines.lty=1, hlines.lwd=1,
                 vlines=NULL, vlines.col="white", vlines.lty=1, vlines.lwd=1,
                 xat=NULL, yat=NULL, bgcolor="gray90", xaxt="n", yaxt="n",
                 col.lab=par("col.lab"),
                 xlim=NULL, ylim=NULL,
                 xlab=NULL, ylab=NULL, xname, yname,
                 xaxs="i", yaxs="i",
                 pch=21, bg="lightblue", col="black",
                 las=1, mgp.x=c(2.6, 0.5, 0), mgp.y=c(2.6, 0.5, 0),
                 force=c("none", "x", "y", "both"),
                 v_over_h=FALSE, na.width=0.06, na.gap=0.01,
                 main="")
        {
            force <- match.arg(force)
            dots <- list(...)

            if(na.width >= 1 || na.width <= 0)
                stop("na.width must be between 0 and 1")
            if(na.gap >= na.width || na.gap <= 0)
                stop("na.gap must be between 0 and na.width")

            if("mgp" %in% names(dots) && missing(mgp.x))
                mgp.x <- dots$mgp
            if("mgp" %in% names(dots) && missing(mgp.y))
                mgp.y <- dots$mgp

            if(is.null(y)) {
                if(is.null(xlab)) xlab <- "Index"
                if(is.null(ylab)) ylab <- xname
                y <- x
                x <- seq(along=x)
            }
            else {
                if(is.null(xlab)) xlab <- xname
                if(is.null(ylab)) ylab <- yname
            }

            if(is.null(ylim)) {
                ylim <- range(y, na.rm=TRUE)
                # make sure ylim[1] < ylim[2]
                if(diff(ylim) < 2e-6) ylim <- ylim + c(-1,1)*1e-6
                ylim[1] <- ylim[1]-diff(ylim)*0.02
                ylim[2] <- ylim[2]+diff(ylim)*0.02
            }
            if(is.null(hlines)) {
                if(!is.null(yat))
                    hlines <- yat
                else
                    hlines <- pretty(ylim)
            }
            else if(length(hlines)==1 && is.na(hlines))
                hlines <- NULL

            if(is.null(xlim)) {
                xlim <- range(x, na.rm=TRUE)
                # make sure xlim[1] < xlim[2]
                if(diff(xlim) < 2e-6) xlim <- xlim + c(-1,1)*1e-6
                xlim[1] <- xlim[1]-diff(xlim)*0.02
                xlim[2] <- xlim[2]+diff(xlim)*0.02
            }
            if(is.null(vlines)) {
                if(!is.null(xat))
                    vlines <- xat
                else
                    vlines <- pretty(xlim)
            }
            else if(length(vlines)==1 && is.na(vlines))
                vlines <- NULL
            if(is.null(xat)) {
                xat <- pretty(xlim)
                xat <- xat[xat >= xlim[1] & xat <= xlim[2]]
            }
            if(is.null(yat)) {
                yat <- pretty(ylim)
                yat <- yat[yat >= ylim[1] & yat <= ylim[2]]
            }
            if(!is.null(vlines)) vlines <- vlines[vlines >= xlim[1] & vlines <= xlim[2]]
            if(!is.null(hlines)) hlines <- hlines[hlines >= ylim[1] & hlines <= ylim[2]]


            pin <- par("pin")
            xna.width <- pin[1]*na.width
            yna.width <- pin[2]*na.width
            width <- max(c(xna.width, yna.width))
            xna.width <- width/pin[1]
            yna.width <- width/pin[2]
            xna.gap <- pin[1]*na.gap
            yna.gap <- pin[2]*na.gap
            gap <- max(c(xna.gap, yna.gap))
            xna.gap <- gap/pin[1]
            yna.gap <- gap/pin[2]

            # whether to include the x and y NA boxes
            x_na <- y_na <- FALSE
            if(any(is.na(x)) || force %in% c("x", "both")) x_na <- TRUE
            if(any(is.na(y)) || force %in% c("y", "both")) y_na <- TRUE

            if(x_na) {
                xlim_expand <- c(xlim[2]-diff(xlim)/(1-xna.width), xlim[2])
                xlim_na <- c(xlim_expand[1], xlim_expand[1]+(xlim[1]-xlim_expand[1])*(1-xna.gap/xna.width))
                if(!is.null(vlines)) vlines <- c(vlines, mean(xlim_na))
            } else {
                xlim_expand <- xlim
            }
            if(y_na) {
                ylim_expand <- c(ylim[2]-diff(ylim)/(1-yna.width), ylim[2])
                ylim_na <- c(ylim_expand[1], ylim_expand[1]+(ylim[1]-ylim_expand[1])*(1-yna.gap/yna.width))
                if(!is.null(hlines)) hlines <- c(hlines, mean(ylim_na))
            } else {
                ylim_expand <- ylim
            }

            plot(x, y, type="n", xaxt="n", yaxt="n", xlab="", ylab="",
                 xlim=xlim_expand, ylim=ylim_expand, xaxs="i", yaxs="i", bty="n",
                 main=main)
            rect(xlim[1], ylim[1], xlim[2], ylim[2], col=bgcolor, border="black")
            if(x_na) rect(xlim_na[1], ylim[1], xlim_na[2], ylim[2],
                          col=bgcolor, border="black", xpd=TRUE)
            if(y_na) rect(xlim[1], ylim_na[1], xlim[2], ylim_na[2],
                          col=bgcolor, border="black", xpd=TRUE)
            if(x_na && y_na) rect(xlim_na[1], ylim_na[1], xlim_na[2], ylim_na[2],
                                  col=bgcolor, border="black", xpd=TRUE)

            # axis titles
            title(xlab=xlab, mgp=mgp.x, col.lab=col.lab)
            title(ylab=ylab, mgp=mgp.y, col.lab=col.lab)

            # x axis: if adding white lines, skip the tick marks and move the numbers closer
            if(!(length(xat)==1 && is.na(xat))) { # if a single NA, skip x-axis
                if(!is.null(vlines)) {
                    axis(side=1, at=xat, mgp=mgp.x, tick=FALSE, las=las)
                    if(x_na) axis(side=1, at=mean(xlim_na), "NA", mgp=mgp.x, tick=FALSE, las=las)
                } else {
                    axis(side=1, at=xat, las=las)
                    if(x_na) axis(side=1, at=mean(xlim_na), "NA", las=las)
                }
            }

            # y axis: like the x-axis
            if(!(length(yat)==1 && is.na(yat))) { # if a single NA, skip y-axis
                if(!is.null(hlines)) {
                    axis(side=2, at=yat, mgp=mgp.y, tick=FALSE, las=las)
                    if(y_na) axis(side=2, at=mean(ylim_na), "NA", mgp=mgp.y, tick=FALSE, las=las)
                } else {
                    axis(side=2, at=yat, las=las)
                    if(y_na) axis(side=2, at=mean(ylim_na), "NA", las=las)
                }
            }

            if(!is.null(vlines) && !v_over_h)
                abline(v=vlines, col=vlines.col, lty=vlines.lty, lwd=vlines.lwd)
            if(!is.null(hlines))
                abline(h=hlines, col=hlines.col, lty=hlines.lty, lwd=hlines.lwd)
            if(!is.null(vlines) && v_over_h)
                abline(v=vlines, col=vlines.col, lty=vlines.lty, lwd=vlines.lwd)

            points(x, y, pch=pch, bg=bg, col=col, type=type, ...)
            if(x_na) {
                n_na <- sum(is.na(x) & !is.na(y))
                if(n_na > 0) {
                    xnapos <- runif(n_na, xlim_na[1]+diff(xlim_na)*0.2, xlim_na[2]-diff(xlim_na)*0.2)
                    points(xnapos, y[is.na(x) & !is.na(y)],
                           pch=pch, bg=bg, col=col, ...)
                }
            }
            if(y_na) {
                n_na <- sum(is.na(y) & !is.na(x))
                if(n_na > 0) {
                    ynapos <- runif(n_na, ylim_na[1]+diff(ylim_na)*0.2, ylim_na[2]-diff(ylim_na)*0.2)
                    points(x[!is.na(x) & is.na(y)], ynapos,
                           pch=pch, bg=bg, col=col, ...)
                }
            }
            if(x_na & y_na) {
                n_na <- sum(is.na(y) & is.na(x))
                if(n_na > 0) {
                    xnapos <- runif(n_na, xlim_na[1]+diff(xlim_na)*0.2, xlim_na[2]-diff(xlim_na)*0.2)
                    ynapos <- runif(n_na, ylim_na[1]+diff(ylim_na)*0.2, ylim_na[2]-diff(ylim_na)*0.2)
                    points(xnapos, ynapos, pch=pch, bg=bg, col=col, ...)
                }

            }

            # add black borders
            rect(xlim[1], ylim[1], xlim[2], ylim[2], col=NULL, border="black")
            if(x_na) rect(xlim_na[1], ylim[1], xlim_na[2], ylim[2],
                          col=NULL, border="black", xpd=TRUE)
            if(y_na) rect(xlim[1], ylim_na[1], xlim[2], ylim_na[2],
                          col=NULL, border="black", xpd=TRUE)
            if(x_na && y_na) rect(xlim_na[1], ylim_na[1], xlim_na[2], ylim_na[2],
                                  col=NULL, border="black", xpd=TRUE)
        }

    hidegrayplot_na(x=x, y=y, type=type, bgcolor=bgcolor,
                    xname=substitute(x), yname=substitute(y),
                    pch=pch, bg=bg, col=col,
                    v_over_h=v_over_h, force=force, ...)
    invisible()
}

Try the broman package in your browser

Any scripts or data that you put into this service are public.

broman documentation built on July 8, 2022, 5:07 p.m.