R/zenplot.R

In zenplots: Zigzag Expanded Navigation Plots

##' @title Unfold the hypercube and produce all necessary plotting information
##' @param nVars The number of variables (>= 1)
##' @param turns A vector of turns (in "u", "d", "l", "r"); contructed if NULL
##' @param n2dcol The number of columns of 2d plots (>= 1); ignored if turns is not NULL
##' @param method The method according to which the path is built; ignored if
##'        turns is not NULL
##' @param last1d A logical indicating whether the last 1d plot should be omitted
##'        from the path
##' @param width1d The width of 1d plots
##' @param width2d The width of 2d plots
##' @return A list containing the path (turns, positions, occupancy matrix)
##'         and the layout (...)
##' @author Marius Hofert and Wayne Oldford
unfold <- function(nVars, turns=NULL, n2dcol=5,
                   method=c("tidy", "double.zigzag", "single.zigzag"),
                   last1d=TRUE, width1d=1, width2d=10)
{
    ## Checking
    stopifnot(nVars >= 1, is.logical(last1d), length(width1d) == 1,
              length(width2d) == 1, width1d >= 0, width2d >= 0)
    if(nVars == 1 && !last1d)
        stop("'last1d' can only be FALSE if ncol(x) > 1")
    if(is.null(turns)) { # turns not provided => use n2dcol and method
        stopifnot(length(n2dcol)==1, n2dcol >= 1)
        if(nVars >= 3 && n2dcol < 2)
            stop("If ncol(x) >= 3, n2dcol must be >= 2.")
        method <- match.arg(method)
    } else { # turns provided
        if(length(turns) != 2*nVars-1)
            stop("Number of turns has to be 2*ncol(x)-1.")
        if(!is.character(turns) || !all(turns %in% c("d", "u", "r", "l")))
            stop("'turns' not all in 'd', 'u', 'r' or 'l'")
    }

    ## Construct the path (= turns, positions in the occupancy matrix
    ## and the occupancy matrix)
    path <- get_path(nVars, turns=turns, n2dcol=n2dcol, method=method, last1d=last1d)

    ## If turns is not provided, extract it here (for checking and computing
    ## the layout via get_layout())
    if(is.null(turns)) turns <- path$turns

    ## Check turns here (more fail-safe)
    if(last1d) {
        if(length(turns) != 2*nVars-1)
            stop("If last1d, the number of turns has to be 2*nVars-1.")
    } else {
        if(length(turns) != 2*nVars-2)
            stop("If !last1d, the number of turns has to be 2*nVars-2.")
    }
    if(!is.character(turns) || !all(turns %in% c("d", "u", "r", "l")))
        stop("'turns' not all in 'd', 'u', 'r' or 'l'")

    ## Determine the layout
    layout <- get_layout(turns, nVars=nVars, last1d=last1d,
                         width1d=width1d, width2d=width2d)

    ## Return
    list(path=path, layout=layout)
}

##' @title Zenplot function to create a zen plot (possibly a grob), the path and the layout
##' @param x An (n,d)-matrix containing the data points
##' @param scale A character string or function used to scale the data to [0,1]^2
##' @param turns A vector of turns (in "u", "d", "l", "r"); constructed if NULL
##' @param n2dcol The number of columns of 2d plots (>= 1); ignored if turns is not NULL
##' @param method The method according to which the path is built; ignored if
##'        turns is not NULL
##' @param pkg The R package used for plotting
##' @param plot1d The function used to create the 1d (edge) plots
##' @param plot2d The function used to create the 2d (face) plots
##' @param last1d A logical indicating whether the last 1d plot should be omitted
##'        from the path
##' @param width1d The width of 1d plots
##' @param width2d The width of 2d plots
##' @param par.list If pkg="graphics", this provides the list of plotting
##'        parameters (arguments of par()). By default, we reduce 'mar' (bottom,
##'        left, top, right space) as this would otherwise lead to the error
##'        "Error in plot.new() : figure margins too large"
##' @param vp1d If pkg="grid", the viewport passed to plot1d()
##' @param vp2d If pkg="grid", the viewport passed to plot2d()
##' @param vp If pkg="grid", the viewport passed to the frame grob
##' @param draw If pkg="grid", a logical indicating whether plotting should be done.
##' @param ... Additional arguments passed to both plot1d and plot2d
##' @return invisible() unless pkg="grid" and value is assigned to a variable
##'         in which case a list containing the path, layout and grobs is returned
##' @author Marius Hofert and Wayne Oldford
zenplot <- function(x, scale=c("columnwise", "rowwise", "all", "pobs", "none"),
                    turns=NULL, n2dcol=5,
                    method=c("tidy", "double.zigzag", "single.zigzag"),
                    pkg=c("graphics", "grid"),
                    plot1d=c("rug", "points", "jitter", "density", "boxplot", "hist",
                             "label", "arrow", "rect", "lines"),
                    plot2d=c("points", "density", "axes", "label", "arrow", "rect"),
                    last1d=TRUE, width1d=NULL, width2d=NULL,
                    par.list=list(mar=rep(0, 4), oma=rep(0.6, 4)),
                    vp1d=NULL, vp2d=NULL, vp=viewport(width=unit(0.96, "npc"),
                                                      height=unit(0.96, "npc")), draw=TRUE, ...)
{
    ## Check and define basic variables
    ## Check x
    if(is.data.frame(x)) x <- data.matrix(x)
    if(is.vector(x) && is.numeric(x)) x <- cbind(x)
    stopifnot(is.matrix(x))
    ## data needs to be scaled within (0,1)
    datarange <- range(x)
    if(min(datarange)< 0 | max(datarange) >1) {
      x <- scale01(x)
    }
    nVars <- ncol(x)
    if(nVars < 1) stop("'x' should have at least one column.")
    ## Check scaling
    if(is.function(scale)) {
        x <- do.call(scale, args=x)
        if(!all(0 <= x, x <= 1))
            stop("The provided function 'scale' did not produce values in [0,1]")
    } else {
        scale <- match.arg(scale)
        if(scale=="none") {
            ## If x is in [0,1], fine. If not, and plot1d and plot2d are functions
            ## then this is also fine (we assume the user-provided plot1d() and plot2d()
            ## scale x to [0,1] in this case. But if x is not in [0,1] and not both
            ## plot1d and plot2d are functions, then stop()
            if(!all(0 <= x, x <= 1) && (!is.function(plot1d) || !is.function(plot2d)))
                stop("If scale=\"none\", 'plot1d' and 'plot2d' have to be functions (which scale 'x' to [0,1])")
        } else { # one of the scaling methods provided by scale01()
            x <- scale01(x, method=scale)
            stopifnot(0 <= x, x <= 1) # defensive programming
        }
    }
    ## Check logicals and turns
    stopifnot(is.logical(last1d), is.logical(draw))
    if(nVars == 1 && !last1d)
        stop("'last1d' can only be FALSE if ncol(x) > 1")
    if(is.null(turns)) { # turns not provided => use n2dcol and method
        stopifnot(length(n2dcol)==1, n2dcol >= 1)
        if(nVars >= 3 && n2dcol < 2)
            stop("If ncol(x) >= 3, n2dcol must be >= 2.")
        method <- match.arg(method)
    } else { # turns provided
        if(length(turns) != 2*nVars-1)
            stop("Number of turns is ",length(turns)," but it needs to be 2*ncol(x)-1 = ",2*ncol(x)-1,".")
        if(!is.character(turns) || !all(turns %in% c("d", "u", "r", "l")))
            stop("'turns' not all in 'd', 'u', 'r' or 'l'")
    }
    ## Check width1d, width2d
    ## Note: Use the same defaults in the respective *_1d/2d_graphics/grid functions
    if(!is.null(width1d)) {
        stopifnot(length(width1d) == 1, width1d >= 0)
    } else {
        width1d <- if(is.null(plot1d)) 0.5 else 1
    }
    if(!is.null(width2d)) {
        stopifnot(length(width2d) == 1, width2d >= 0)
    } else {
        width2d <- 10
    }
    ## Check pkg (if you provide your own function, you have to choose 'pkg' accordingly)
    pkg <- match.arg(pkg)
    ## Check plot1d(), plot2d()
    if(!is.null(plot1d)) {
        if(!is.function(plot1d)) {
            ## ## Stop if there are unimplemented methods
            ## if (pkg == "graphics") {
            ##     if (match.arg(plot1d) == "hist") {
            ##         stop(paste("plot1d =", match.arg(plot1d),
            ##                    "is not yet implemented for pkg =", pkg))
            ##     }
            ## }
            plot1d <- paste(match.arg(plot1d), "1d", pkg, sep="_") # full name of underlying 1d
        }
        if(!exists(as.character(substitute(plot1d))))
            stop("Function provided as argument 'plot1d' does not exist.")
        ## Note: x, turn, horizontal and plotID will be pased to plot1d;
        ##       be careful if your plot1d has one of these arguments but
        ##       assumes a different meaning (this cannot be checked)
    } else { # plot1d is NULL
        if(pkg=="graphics") # define empty plot (to advance in layout)
            plot1d <- function(...) plot(0, type="n", ann=FALSE, axes=FALSE)
    }
    if(!is.null(plot2d)) {
        if(!is.function(plot2d))
            plot2d <- paste(match.arg(plot2d), "2d", pkg, sep="_") # full name of underlying 2d plot
        if(!exists(as.character(substitute(plot2d))))
            stop("Function provided as argument 'plot2d' does not exist.")
        ## Note: x, turn and plotID will be pased to plot2d;
        ##       be careful if your plot2d has one of these arguments but
        ##       assumes a different meaning (this cannot be checked)
    } else { # plot1d is NULL
        if(pkg=="graphics") # define empty plot (to advance in layout)
            plot2d <- function(...) plot(0, type="n", ann=FALSE, axes=FALSE)
    }

    ## Get '...' arguments
    .args <- list(...)

    ## Get varnames for plotID
    varnames <- colnames(x)
    if(is.null(varnames)) varnames <- rep(NA, nVars)
    ## Note: If NULL, we can't take 1:nVars here because if x has no column
    ##       names and the user reorders the data and plots them again, he
    ##       will see the same pair labels (if label_2d_grid() is used), which
    ##       would be wrong.


    ## Call unfold() to compute the path and corresponding layout
    pathLayout <- unfold(nVars, turns=turns, n2dcol=n2dcol, method=method,
                         last1d=last1d, width1d=width1d, width2d=width2d) # call unfold()
    path <- pathLayout$path
    Layout <- pathLayout$layout
    bbs <- Layout$boundingBoxes
    vars <- Layout$vars
    ndims <- Layout$dimensions
    orientation <- Layout$orientations
    LayoutWidth <- Layout$LayoutWidth
    LayoutHeight <- Layout$LayoutHeight
    turns <- path$turns
    nPlots <- nrow(bbs)

    ## Compute layout information
    fg.rows <- unique(bbs[,c("bottom", "top"), drop=FALSE])
    fg.rows <- fg.rows[order(fg.rows[,1], decreasing=TRUE),, drop=FALSE]
    fg.cols <- unique(bbs[,c("left", "right"), drop=FALSE])
    fg.cols <- fg.cols[order(fg.cols[,1], decreasing=FALSE),, drop=FALSE]
    fg.nrow <- nrow(fg.rows)
    fg.ncol <- nrow(fg.cols)
    heights <- (fg.rows[,  "top"] - fg.rows[,"bottom"]) / LayoutHeight
    widths  <- (fg.cols[,"right"] - fg.cols[,  "left"]) / LayoutWidth

    ## Set up layout and plot
    switch(pkg,
           "graphics" = {

               ## Set plot parameters
               opar <- par(no.readonly=TRUE) # get plotting parameter list
               do.call(par, par.list) # change plotting parameters
               on.exit(par(opar)) # on exit, set back the old plotting parameters

               ## Layout
               lay <- matrix(0, nrow=fg.nrow, ncol=fg.ncol, byrow=TRUE)
               positions <- path$positions
               for(i in seq_len(fg.nrow)) {
                   for(j in seq_len(fg.ncol)) {
                       for(k in 1:nrow(positions)) {
                           if(all(positions[k,]==c(i,j))) {
                               lay[i,j] <- k
                               break # break inner-most for-loop since (i,j) can only appear once in 'positions'
                           }
                       }
                   }
               }
               layout(lay, widths=widths, heights=heights) # layout
               ## => use, e.g., layout.show(nrow(positions)) to display the layout

               ## Loop over the 1d and 2d plots
               for(i in seq_len(nPlots))
               {
                   xyvars <- vars[i,]
                   if(ndims[i] == 1){ # 1d plot
                       if(!is.null(plot1d)) {
                           horizontal <- orientation[i]=="h"
                           formal.args <- list(x=x[,xyvars[1], drop=FALSE], # univariate data
                                               horizontal=horizontal, # plot direction
                                               plotAsp=width1d/width2d, # smaller/larger side (in [0,1])
                                               plotID=list(name=varnames[xyvars[1]], # variable name
                                                           idx=xyvars[1], # column index
                                                           plotNo=(i+1)/2), # plot number (among all 1d)
                                               turn=turns[i]) # turn out of the current plot
                           do.call(plot1d, args=c(formal.args, .args))
                       }
                   } else { # 2d plot
                       if(!is.null(plot2d)) {
                           formal.args <- list(x=x[,xyvars, drop=FALSE], # bivariate data
                                               plotID=list(name=varnames[xyvars], # variable names
                                                           idx=xyvars, # column indices
                                                           plotNo=i/2), # plot number (among all 2d)
                                               turn=turns[i]) # turn out of the current plot
                           do.call(plot2d, args=c(formal.args, .args))
                       }
                   }
               }

           },
           "grid" = {

               layout <- grid.layout(nrow=fg.nrow, ncol=fg.ncol,
                                     widths=unit(widths, "npc"),
                                     heights=unit(heights, "npc"),
                                     just="centre")
               fg <- frameGrob(layout=layout, vp=vp) # major result (a frame grob)

               ## Compute the 1d and 2d grobs and place them in the frame grob
               for(i in seq_len(nPlots))
               {
                   xyvars <- vars[i,]
                   newGrob <-
                       if(ndims[i] == 1){ # 1d plot
                           if(is.null(plot1d)) nullGrob() else {
                               horizontal <- orientation[i]=="h"
                               formal.args <- list(x=x[,xyvars[1]], # univariate data
                                                   horizontal=horizontal, # plot direction
                                                   plotAsp=width1d/width2d, # smaller/larger side (in [0,1])
                                                   plotID=list(name=varnames[xyvars[1]], # variable name
                                                               idx=xyvars[1], # column index
                                                               plotNo=(i+1)/2), # plot number (among all 1d)
                                                   turn=turns[i], # turn out of the current plot
                                                   vp=vp1d) # viewport
                               do.call(plot1d, args=c(formal.args, .args, draw=FALSE))
                           }
                       } else { # 2d plot
                           if(is.null(plot2d)) nullGrob() else {
                               formal.args <- list(x=x[,xyvars], # bivariate data
                                                   plotID=list(name=varnames[xyvars], # variable names
                                                               idx=xyvars, # column indices
                                                               plotNo=i/2), # plot number (among all 2d)
                                                   turn=turns[i], # turn out of the current plot
                                                   vp=vp2d) # viewport
                               do.call(plot2d, args=c(formal.args, .args, draw=FALSE))
                           }
                       }
                   ## Placing of grobs in the frame grob
                   rowNo <- (1:fg.nrow)[fg.rows[,"bottom"] == bbs[i,"bottom"]]
                   colNo <- (1:fg.ncol)[fg.cols[,  "left"] == bbs[i,"left"]]
                   fg <- placeGrob(fg, grob=newGrob, col=colNo, row=rowNo)
               }
               if(draw) { # plot
                   grid.newpage()
                   grid.draw(fg)
               }

               ## Return
               invisible(list(path=path, layout=Layout, grob=fg))

           },
           stop("Wrong 'pkg'"))
}