[R] Rewriting the Biplot Function

[Scott Robinson]

Dear R-Help,

I have been trying to rewrite the base biplot.prcomp function but am coming across some errors I don't understand. It seems like R is still 'expecting' the same values despite me rewriting and renaming the methods. My aim is simply to have an additional biplot function which could use a vector of colours, where each position of the vector gives the colour for a variable name and its arrow.

Another issue I have with the default function is that when I save a very large image (to get good seperation and readability when looking at hundreds of variables) the names are very displaced from the arrows, but I haven't even started looking into that yet...

I ran the code on my actual data and got the error:
> colouredBiplot(prc, yCol=rep("#FFFF00", 962))
Error in if (yCol == NULL) { : argument is of length zero
> traceback()
2: colouredBiplot.internal(t(t(scores[, choices])/lam), t(t(x$rotation[,
       choices]) * lam), yCol, ...) at colouredBiplot.R#103
1: colouredBiplot(prc, yCol = rep("#FFFF00", 962))

However when I tried creating a small example I got a different error:

> options(stringsAsFactors=F)
> source("C:/Work/InGenious/InGen/colouredBiplot.R")
>
> random <- matrix(rexp(200, rate=.1), ncol=20)
> prc <- prcomp(random, center=T, scale=T)
> colouredBiplot(random, rep("#FFFF00", 20))
Error in colouredBiplot(random, rep("#FFFF00", 20)) :
  length of choices must be 2
> sessionInfo()
R version 3.0.2 (2013-09-25)
Platform: x86_64-w64-mingw32/x64 (64-bit)

locale:
[1] LC_COLLATE=English_United Kingdom.1252
[2] LC_CTYPE=English_United Kingdom.1252
[3] LC_MONETARY=English_United Kingdom.1252
[4] LC_NUMERIC=C
[5] LC_TIME=English_United Kingdom.1252

attached base packages:
[1] stats     graphics  grDevices utils     datasets  methods   base




and then immediately after the above I thought to try a traceback() and got another different error again, which I don't even understand how is possible:

> colouredBiplot(random, yCol=rep("#FFFF00", 20))
Error in x$x : $ operator is invalid for atomic vectors
> traceback()
1: colouredBiplot(random, yCol = rep("#FFFF00", 20))




The only things I have changed are to pass in a vector "yCol" and use it inside the else blocks of some conditionals testing 'if(yCol==NULL)':

colouredBiplot.internal <- function (x, y, var.axes = TRUE, col, cex = rep(par("cex"), 2),
    xlabs = NULL, ylabs = NULL, expand = 1, xlim = NULL, ylim = NULL,
    arrow.len = 0.1, main = NULL, sub = NULL, xlab = NULL, ylab = NULL, yCol=NULL,
    ...)
{
    n <- nrow(x)
    p <- nrow(y)
    if (missing(xlabs)) {
        xlabs <- dimnames(x)[[1L]]
        if (is.null(xlabs))
            xlabs <- 1L:n
    }
    xlabs <- as.character(xlabs)
    dimnames(x) <- list(xlabs, dimnames(x)[[2L]])
    if (missing(ylabs)) {
        ylabs <- dimnames(y)[[1L]]
        if (is.null(ylabs))
            ylabs <- paste("Var", 1L:p)
    }
    ylabs <- as.character(ylabs)
    dimnames(y) <- list(ylabs, dimnames(y)[[2L]])
    if (length(cex) == 1L)
        cex <- c(cex, cex)
    if (missing(col)) {
        col <- par("col")
        if (!is.numeric(col))
            col <- match(col, palette(), nomatch = 1L)
        col <- c(col, col + 1L)
    }
    else if (length(col) == 1L)
        col <- c(col, col)
    unsigned.range <- function(x) c(-abs(min(x, na.rm = TRUE)),
        abs(max(x, na.rm = TRUE)))
    rangx1 <- unsigned.range(x[, 1L])
    rangx2 <- unsigned.range(x[, 2L])
    rangy1 <- unsigned.range(y[, 1L])
    rangy2 <- unsigned.range(y[, 2L])
    if (missing(xlim) && missing(ylim))
        xlim <- ylim <- rangx1 <- rangx2 <- range(rangx1, rangx2)
    else if (missing(xlim))
        xlim <- rangx1
    else if (missing(ylim))
        ylim <- rangx2
    ratio <- max(rangy1/rangx1, rangy2/rangx2)/expand
    on.exit(par(op))
    op <- par(pty = "s")
    if (!is.null(main))
        op <- c(op, par(mar = par("mar") + c(0, 0, 1, 0)))
    plot(x, type = "n", xlim = xlim, ylim = ylim, col = col[1L],
        xlab = xlab, ylab = ylab, sub = sub, main = main, ...)
    text(x, xlabs, cex = cex[1L], col = col[1L], ...)
    par(new = TRUE)
    dev.hold()
    on.exit(dev.flush(), add = TRUE)
    if(yCol==NULL){
    plot(y, axes = FALSE, type = "n", xlim = xlim * ratio, ylim = ylim *
        ratio, xlab = "", ylab = "", col = col[1L], ...)
        }
        else{
        plot(y, axes = FALSE, type = "n", xlim = xlim * ratio, ylim = ylim *
        ratio, xlab = "", ylab = "", col = yCol, ...)
        }
    axis(3, col = col[2L], ...)
    axis(4, col = col[2L], ...)
    box(col = col[1L])
    if(yCol==NULL){
    text(y, labels = ylabs, cex = cex[2L], col = col[2L], ...)
    } else{
    text(y, labels = ylabs, cex = cex[2L], col = yCol, ...)
    }
    if (var.axes){
    if(yCol==NULL){
        arrows(0, 0, y[, 1L] * 0.8, y[, 2L] * 0.8, col = col[2L],
            length = arrow.len)
            }else{
        arrows(0, 0, y[, 1L] * 0.8, y[, 2L] * 0.8, col = yCol,
            length = arrow.len)            }
            }
    invisible()
}


colouredBiplot <- function (x, choices = 1L:2L, scale = 1, pc.biplot = FALSE, yCol=NULL, ...)
{
    if (length(choices) != 2L)
        stop("length of choices must be 2")
    if (!length(scores <- x$x))
        stop(gettextf("object '%s' has no scores", deparse(substitute(x))),
            domain = NA)
    if (is.complex(scores))
        stop("biplots are not defined for complex PCA")
    lam <- x$sdev[choices]
    n <- NROW(scores)
    lam <- lam * sqrt(n)
    if (scale < 0 || scale > 1)
        warning("'scale' is outside [0, 1]")
    if (scale != 0)
        lam <- lam^scale
    else lam <- 1
    if (pc.biplot)
        lam <- lam/sqrt(n)
    colouredBiplot.internal(t(t(scores[, choices])/lam), t(t(x$rotation[,
        choices]) * lam), yCol, ...)
    invisible()
}


I have looked into a few alternatives but most either don't allow that type of different colouring, or else aren't compatable with my various versions of R.

Help me R-Help, you're my only hope,

Scott




	[[alternative HTML version deleted]]