R/debug.R

In thomasp85/grid: The Grid Graphics Package

#  File src/library/grid/R/debug.R
#  Part of the R package, https://www.R-project.org
#
#  Copyright (C) 1995-2016 The R Core Team
#
#  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.
#
#  A copy of the GNU General Public License is available at
#  https://www.R-project.org/Licenses/

### Label grobs in a scene


labelGrob <- function(grob, recurse, curdepth, depth, labelfun, ...) {
    UseMethod("labelGrob")
}

# The default grob label needs to do some calculations
# on sizes so need a drawDetails method to get the
# calculations right
drawDetails.groblabel <- function(x, ...) {
    gw <- convertWidth(grobWidth(x$grob), "inches", valueOnly=TRUE)
    gh <- convertHeight(grobHeight(x$grob), "inches", valueOnly=TRUE)
    grid.rect(grobX(x$grob, "west"), grobY(x$grob, "south"),
              unit(gw, "inches"), unit(gh, "inches"),
              just=c("left", "bottom"), gp=x$gp)
    tw <- convertWidth(stringWidth(x$grob$name), "inches", valueOnly=TRUE)
    th <- convertHeight(stringHeight(x$grob$name), "inches", valueOnly=TRUE)
    eps <- .01
    # If grob is REALLY short, draw horiz at normal cex
    if (gh < eps) {
        rot <- 0
        cex <- 1
    # If grob is REALLY thin, draw vertical at normal cex
    } else if (gw < eps) {
        rot <- 90
        cex <- 1
    } else {
        gratio <- gh/gw
        if (gratio > 1 && tw > gw) {
            rot <- 90
            wratio <- th/gw
            hratio <- tw/gh
        } else {
            rot <- 0
            wratio <- tw/gw
            hratio <- th/gh
        }
        if (wratio > 1 || hratio > 1) {
            cex <- 1/max(wratio, hratio)
        } else {
            cex <- 1
        }
    }
    if (is.null(x$gp)) {
        x$gp <- gpar(cex=cex)
    } else {
        if (is.null(x$gp$cex))
            x$gp$cex <- cex
    }
    if (is.null(x$otherArgs$rot))
        x$otherArgs$rot <- rot
    do.call("grid.text", c(list(label=x$grob$name,
                                x=grobX(x$grob, "north"),
                                y=grobY(x$grob, "west"),
                                gp=x$gp),
                           x$otherArgs))
}

grobLabel <- function(grob,
                      gp=gpar(col=rgb(1, 0, 0, .5),
                        fill=rgb(1, 0, 0, .2)),
                      ...) {
    grob(grob=grob, gp=gp, otherArgs=list(...),
         cl="groblabel")
}

labelGrob.grob <- function(grob, recurse, curdepth, depth, labelfun, ...) {
    if (is.null(depth) || curdepth %in% depth) {
        gTree(children=gList(grob,
                labelfun(grob, ...)),
              # Name new gTree same as old grob so that
              # setGrob() approach works below
              # (when 'gPath' is specified)
              name=grob$name)
    } else {
        grob
    }
}

labelGrob.gTree <- function(grob, recurse, curdepth, depth, labelfun, ...) {
    if (recurse) {
        newChildren <- do.call("gList",
                               lapply(grob$children,
                                      labelGrob,
                                      recurse, curdepth + 1, depth,
                                      labelfun, ...))
        grob <- setChildren(grob, newChildren)
    }
    if (is.null(depth) || curdepth %in% depth) {
        gTree(children=gList(grob,
                labelfun(grob, ...)),
              name=grob$name)
    } else {
        grob
    }
}

showGrob <- function(x=NULL,
                     gPath=NULL, strict=FALSE, grep=FALSE,
                     recurse=TRUE, depth=NULL,
                     labelfun=grobLabel, ...) {
    if (is.null(x)) {
        # Label all or part of current scene
        # The grid display list is NOT affected
        # To remove labels use grid.redraw()
        if (is.null(gPath)) {
            # Show the current scene
            dl <- grid.Call(C_getDisplayList)[1L : grid.Call(C_getDLindex)]
            grid.newpage(recording=FALSE)
            # -1 because first element on DL is ROOT viewport
            lapply(dl[-1],
                   function(y) {
                       # Modify the grob to add a label
                       if (is.grob(y))
                           y <- labelGrob(y, recurse, 1, depth, labelfun, ...)
                       # Draw either the original object or the modified grob
                       grid.draw(y, recording=FALSE)
                   })
        } else {
            # Only label the bit of the current scene specified by gPath
            grobToLabel <- grid.get(gPath, strict=strict, grep=grep)
            # NOTE: have to 'wrap' because otherwise the grobs in the
            # captured scene have been altered
            scene <- grid.grab(wrap=TRUE)
            modScene <- setGrob(scene, gPath,
                                labelGrob(grobToLabel, recurse, 1, depth,
                                          labelfun, ...),
                                strict=strict, grep=grep)
            grid.newpage(recording=FALSE)
            grid.draw(modScene, recording=FALSE)
        }
    } else {
        # Assume grob is not current scene so start a new page
        grid.newpage()
        grid.draw(x)
        showGrob(NULL, gPath, strict, grep, recurse, depth, labelfun, ...)
    }
    invisible()
}

#############
# Labelling viewports in a scene
#############

# FIXME:  some of this code for vpLists and vpStacks and vpTrees
# assumes that the components of a vpList or vpStack or the
# vpTree parent can ONLY be a viewport (when in fact they can
# also be a vpList, vpStack, or vpTree!)

# Label a viewport
# Get physical aspect ratio of vp to determine whether to rotate
# Shrink text to fit in vp
# (Assumes that we are currently occupying 'vp'
#  so that conversions are correct)
labelVP <- function(vp, col) {
    vw <- convertWidth(unit(1, "npc"), "inches", valueOnly=TRUE)
    vh <- convertHeight(unit(1, "npc"), "inches", valueOnly=TRUE)
    tw <- convertWidth(stringWidth(vp$name), "inches", valueOnly=TRUE)
    th <- convertHeight(stringHeight(vp$name), "inches", valueOnly=TRUE)
    eps <- .01
    # If viewport is REALLY short, draw horiz at normal cex
    if (vh < eps) {
        rot <- 0
        cex <- 1
    # If viewport is REALLY thin, draw vertical at normal cex
    } else if (vw < eps) {
        rot <- 90
        cex <- 1
    } else {
        vratio <- vh/vw
        if (vratio > 1 && tw > vw) {
            rot <- 90
            wratio <- th/vw
            hratio <- tw/vh
        } else {
            rot <- 0
            wratio <- tw/vw
            hratio <- th/vh
        }
        if (wratio > 1 || hratio > 1) {
            cex <- 1/max(wratio, hratio)
        } else {
            cex <- 1
        }
    }
    # Violate any clipping that is in effect
    pushViewport(viewport(clip="off"))
    grid.text(vp$name, rot=rot, gp=gpar(col=col, cex=cex))
    upViewport()
}

# Draw a "viewport"
drawVP <- function(vp, curDepth, depth, col, fill, label) {
    UseMethod("drawVP")
}

drawVP.viewport <- function(vp, curDepth, depth, col, fill, label) {
    if (vp$name != "ROOT" &&
        (is.null(depth) || curDepth %in% depth)) {
        pushViewport(vp)
        colIndex <- (curDepth - 1) %% length(col) + 1
        fillIndex <- (curDepth - 1) %% length(fill) + 1
        grid.rect(gp=gpar(col=col[colIndex], fill=fill[fillIndex]))
        if (label)
            labelVP(vp, col[colIndex])
        upViewport()
    }
}

drawVP.vpPath <- function(vp, curDepth, depth, col, fill, label) {
    if (is.null(depth) || curDepth %in% depth) {
        downViewport(vp)
        colIndex <- (curDepth - 1) %% length(col) + 1
        fillIndex <- (curDepth - 1) %% length(fill) + 1
        grid.rect(gp=gpar(col=col[colIndex], fill=fill[fillIndex]))
        if (label)
            labelVP(vp, col[colIndex])
        upViewport(depth(vp))
    }
}

drawVP.vpList <- function(vp, curDepth, depth, col, fill, label) {
    lapply(vp, drawVP, curDepth, depth, col, fill, label)
}

drawVP.vpStack <- function(vp, curDepth, depth, col, fill, label) {
    d <- depth(vp)
    for (i in 1:length(vp)) {
        this <- vp[[i]]
        drawVP(this, curDepth, depth, col, fill, label)
        curDepth <- curDepth + depth(this)
        pushViewport(this)
    }
    upViewport(d)
}

drawVP.vpTree <- function(vp, curDepth, depth, col, fill, label) {
    if (vp$parent$name == "ROOT") {
        lapply(vp$children, drawVP, curDepth, depth, col, fill, label)
    } else {
        pushViewport(vp$parent)
        if (is.null(depth) || curDepth %in% depth) {
            colIndex <- (curDepth - 1) %% length(col) + 1
            fillIndex <- (curDepth - 1) %% length(fill) + 1
            grid.rect(gp=gpar(col=col[colIndex], fill=fill[fillIndex]))
            if (label) {
                drawLabel <- is.null(vp$children) ||
                             (!is.null(depth) &&
                              curDepth == max(depth))
                if (drawLabel)
                    labelVP(vp$parent, col[colIndex])
            }
        }
        lapply(vp$children, drawVP, curDepth + 1, depth, col, fill, label)
        upViewport()
    }
}

# Draw all viewports in same viewport
showVP <- function(vp, newpage, cvpt, depth, col, fill,
                   label) {
    # If we've started a new page, we'll need the old
    # viewport tree to navigate within
    if (newpage) {
        pushViewport(cvpt)
        # "-1" for "ROOT"
        upViewport(depth(cvpt) - 1)
    }
    # Work off a vpTree, so convert vp if it's a vpPath
    showingPath <- inherits(vp, "vpPath")
    if (showingPath) {
        path <- vp
        downViewport(path)
        vp <- current.vpTree(all=FALSE)
        upViewport(1)
    }
    drawVP(vp, 1, depth, col, fill, label)
    if (showingPath)
        # "-1" because we went down the path then back up 1 originally
        upViewport(depth(path) - 1)
    invisible()
}

# Convert a "viewport" to a set of vpPaths
leafPaths <- function(vp) {
    UseMethod("leafPaths")
}

leafPaths.viewport <- function(vp) {
    if (vp$name == "ROOT")
        NULL
    else
        vp$name
}

leafPaths.vpList <- function(vp) {
    unlist(lapply(vp, leafPaths))
}

leafPaths.vpStack <- function(vp) {
    pathList <- lapply(vp, leafPaths)
    for (i in 1:length(pathList)) {
        if (i > 1) {
            pathList[[i]] <- paste(pathList[[i - 1]],
                                   pathList[[i]],
                                   sep=.grid.pathSep)
        }
    }
    unlist(pathList)
}

leafPaths.vpTree <- function(vp) {
    if (is.null(vp$children)) {
        if (vp$parent$name == "ROOT")
            NULL
        else
            vp$parent$name
    } else {
        pathList <- lapply(vp$children, leafPaths)
        if (vp$parent$name == "ROOT") {
            unlist(pathList)
        } else {
            paste(vp$parent$name,
                  unlist(pathList),
                  sep=.grid.pathSep)
        }
    }
}

leafPaths.vpPath <- function(vp) {
    as.character(vp)
}

# Draw a vpPath
drawPath <- function(path, depth, col, fill, label) {
    n <- depth(path)
    for (i in 1:n) {
        downViewport(path[i])
        if (is.null(depth) || i %in% depth) {
            colIndex <- (i - 1) %% length(col) + 1
            fillIndex <- (i - 1) %% length(fill) + 1
            grid.rect(gp=gpar(col=col[colIndex], fill=fill[fillIndex]))
            if (label) {
                if (is.null(depth))
                    drawLabel <- i == n
                else
                    drawLabel <- i == min(n, max(depth))
                if (drawLabel)
                    labelVP(current.viewport(), col[colIndex])
            }
        }
    }
    upViewport(n)
}

# Draw each leaf in separate viewports
# FIXME: allow control over number of rows and cols
# NOTE: this does NOT leave its viewports hanging around after
showVPmatrix <- function(vp, cvpt, depth, col, fill,
                         label, # Only the leaf viewports are labelled
                         nrow, ncol) {
    # Work off a vpPath, so convert vp if it's a "viewport"
    if (is.viewport(vp)) {
        paths <- leafPaths(vp)
    } else {
        # Should not happen
        stop("how did we get here?")
    }
    firstPath <- 0
    while (length(paths) - firstPath > 0) {
        if (firstPath > 0)
            grid.newpage()
        pushViewport(viewport(layout=grid.layout(nrow, ncol)))
        for (i in 1:nrow) {
            for (j in 1:ncol) {
                theLeaf <- firstPath + (i - 1)*nrow + j
                if (theLeaf <= length(paths)) {
                    thePath <- vpPath(paths[theLeaf])
                    pushViewport(viewport(layout.pos.row=i,
                                          layout.pos.col=j))
                    grid.rect(gp=gpar(col="grey80"))
                    # We may need the old vpTree to navigate within
                    # if 'vp' is a vpStack, or something similar, that
                    # contains a vpPath
                    if (!is.null(cvpt$children)) {
                        pushViewport(cvpt$children)
                        upViewport(depth(cvpt) - 1)
                    }
                    # Now push the viewport we are showing
                    pushViewport(vp)
                    upViewport(depth(vp))
                    # Now go to the particular viewport we
                    # are going to show
                    drawPath(thePath, depth, col, fill, label)
                    # Pop our placement within the layout
                    popViewport()
                }
            }
        }
        popViewport()
        firstPath <- firstPath + nrow*ncol
    }
}

showViewport <- function(vp=NULL, recurse=TRUE, depth=NULL,
                         newpage=FALSE, leaves=FALSE,
                         col=rgb(0, 0, 1, .2), fill=rgb(0, 0, 1, .1),
                         label=TRUE, nrow=3, ncol=nrow) {
    cvpt <- current.vpTree()
    if (is.null(vp))
        vp <- cvpt
    if (newpage == FALSE && leaves == TRUE)
        stop("must start new page if showing leaves separately")
    if (newpage) {
        grid.newpage()
    }
    if (!recurse)
        depth <- 1
    if (leaves) {
        # Special case of showing vpPath (i.e., only one viewport)
        # Ignores nrow & ncol
        if (inherits(vp, "vpPath"))
            showVP(vp, TRUE, cvpt, depth, col, fill, label)
        else
            showVPmatrix(vp, cvpt, depth, col, fill, label, nrow, ncol)
    } else {
        showVP(vp, newpage, cvpt, depth, col, fill, label)
    }
    invisible()
}