imgplot: Image plot of spotted expression array data

In DAAGbio: Data Sets and Functions, for Demonstrations with Expression Arrays and Gene Sequences

Image plot of spotted expression array data

Description

Creates an image of graduated colors that represent the values of a statistic for each spot on a spotted microarray. By default, the only the 5 shown. The initial version was based on plot.spatial in the sma package.

Usage

imgplot(z = DAAGbio::coralRG$R[, 1], layout = DAAGbio::coralRG$printer, crit1 = 0.05,
crit2 = crit1, key.side=2,
lohi.colors = c("#9E0142", "#D53E4F", "#F46D43", "#FDAE61", "#ABDDA4",
"#66C2A5", "#3288BD", "#5E4FA2"), nacolor = "#FFFF00",
boxplot.side = 1, split = "quantiles")

Arguments

z	values to be plotted
layout	layout of spots, in the order (rows of grids, columns of grids, rows of spots in a grid, columns in a grid)
crit1	Choose the lower threshold to include this proportion at the high end
crit2	Choose the upper threshold to include this proportion of values at the low end
key.side	Side on which the color key should appear
lohi.colors	Graduated sequence of colors
nacolor	Use this color for NAs
boxplot.side	Show boxplot on this side of figure region
split	Specify "intervals" or "quantiles", as required

Value

A plot is created on the current graphics device

Author(s)

J. H. Maindonald

Examples

## The function is currently defined as
function (z=DAAGbio::coralRG$R[,1], layout=cDAAGbio::oralRG$printer, crit1 = 0.05,
            crit2 = crit1, key.side=2,
            lohi.colors=c("#9E0142","#D53E4F","#F46D43","#FDAE61",
              "#ABDDA4","#66C2A5","#3288BD","#5E4FA2"),
            nacolor="#FFFF00", boxplot.side=1, split="quantiles")
{
  "block2matrix" <-
    function(z, sr=3, sc=2, gr=2, gc=2){
      ## Assumes that values in the vector z are  in row major
      ## order within blocks of dimension sr x sc, with blocks
      ## in row major order within a gr x gc array of grids.
      ## Elements in the vector that is returned are in row
      ## major order wrt the sr*gr x sc*gc matrix of values on
      ## the slide. (It is given the dimensions of a matrix.)
      xy <- array(z, dim=c(sc, sr, gc, gr))
      xy <- aperm(xy, c(1,3,2,4))
      dim(xy) <- c(sc*gc, gr*sr)
      xy}
  quantile.na <- function (z, ...)
    {
      tmp <- !(is.na(z) | is.infinite(z))
      quantile(z[tmp], ...)
    }
  length.na <- function (z, ...)
    {
      tmp <- !(is.na(z) | is.infinite(z))
      length(z[tmp], ...)
    }
    if(is.matrix(z))warning("z is a matrix, You probably want a column vector")
  bplot <- function(z, boxplot.side=1){
    xrange <- range(z,na.rm=TRUE)
    iqr <- diff(quantile(xrange, c(.25,.75)))
    bwex <- diff(xrange)/(3*iqr)
    xhi <- max(z,na.rm=TRUE)
    xusr <- par()$usr[c(1:2)]
    xpos=pretty(z[!is.na(z)], n=5)
    z <- xusr[1]+(z-xrange[1])*diff(xusr)/diff(xrange)
    newpos <- xusr[1]+(xpos-xrange[1])*diff(xusr)/diff(xrange)
    par(xpd=TRUE)
    atvert <- switch(boxplot.side, par()$usr[3]-par()$cxy[2]*0.8,
                     "", par()$usr[4]+par()$cxy[2]*0.8, "")
    if(atvert!=""){
      boxplot(z, at=atvert, boxwex=bwex, add=TRUE, horizontal=TRUE, xaxt="n")
      axis(side=boxplot.side, line=1.5,
           at=newpos, labels=xpos, cex.axis=0.75, mgp=c(2, 0.5, 0))
    }
    par(xpd=FALSE)
  }
  if (crit1 >= 1)
    crit1 <- crit1/(length.na(z))
  if (crit2 >= 1)
    crit2 <- crit2/(length.na(z))
  tmpind <- (z > quantile.na(z, probs = 1 - crit2)) | (z <
                                  quantile.na(z, probs = crit1))
  n <- prod(unlist(layout))
  n.all <- length(z)
  n.na <- sum(is.na(z))
  nhalf <- length(lohi.colors)%/%2
  n2 <- 2*nhalf
  n.one <- length(lohi.colors)
  plo <- crit1*(0:nhalf)/nhalf
  phi <- 1-crit2*(nhalf:0)/nhalf
  quiles1 <- quantile.na(z, plo)
  quiles2 <- quantile.na(z, phi)
  if(split=="intervals"){
    quiles1[2:nhalf] <- quiles1[1]+(quiles1[nhalf+1]-quiles1[1])*
      (1:(nhalf-1))/nhalf
    quiles2[2:nhalf] <- quiles2[1]-(quiles2[nhalf+1]-quiles2[1])*
      ((nhalf-1):1)/nhalf
    plo[-1] <- sapply(quiles1[-1],
                      function(x, z)sum(z<=x, na.rm=TRUE)/length.na(z), z=z)
    phi[-1] <- sapply(quiles2[-1],
                      function(x, z)sum(z<=x, na.rm=TRUE)/length.na(z), z=z)
  }

  if(crit1+crit2<1){
    quiles <- c(quiles1,quiles2)
    frac <- c(plo, phi)
    colpal <- c(lohi.colors[1:nhalf],"#FFFFFF",
                lohi.colors[(n.one-nhalf+1):(n.one)])
    midbreak <- TRUE
  }
  else {colpal <- lohi.colors
        midbreak <- FALSE
        quiles <- quantile.na(z, (0:n.one)/n.one)
        frac <- c(plo, phi[-1])
      }
  dups <- duplicated(quiles)
  if(any(dups)){
    cats <- seq(along=quiles[-1])
    filledcats <- cats[!dups]
    cutcats <- as.integer(cut(z, quiles[!dups], include.lowest=TRUE))
    fullm <- filledcats[cutcats]}
  else fullm <- as.integer(cut(z, quiles, include.lowest=TRUE))
  n.one <- length(colpal)
  nrects <- length(quiles)
  if(any(is.na(z))){
    nacat <- TRUE
    fullm[is.na(fullm)] <- max(unique(fullm[!is.na(fullm)]))+1
    colpal <- c(colpal, nacolor)
  }
  else nacat <- FALSE
  if ((length(as.vector(z)) != n) & (!is.null(names(z)))) {
    y <- fullm[tmpind]
    fullm <- rep(NA, n)
    fullm[as.integer(names(y))] <- y
  }
  else fullm[!tmpind] <- NA
  if ((length(as.vector(z)) != n) & (is.null(names(z)))) {
    stop(paste("Error: Length of vector is different from total number\n",
               "of spots and vector has no row.name.\n"))
  }
#################################################################
  gc <- layout$ngrid.c
  gr <- layout$ngrid.r
  sc <- layout$nspot.c
  sr <- layout$nspot.r
  full <- block2matrix(fullm, sr, sc, gr, gc)
  image(1:ncol(full), 1:nrow(full), t(full), axes = FALSE,
        xlab = "", ylab = "", col=colpal)
  box()
  abline(v = ((gr - 1):1) * (sr) + 0.5)
  abline(h = (1:(gc - 1)) * (sc) + 0.5)
#################################################################
  if(boxplot.side%in%c(1,3))bplot(z, boxplot.side=boxplot.side)
  if(key.side%in%c(2,4)){
    chw <- par()$cxy[1]
    barwid <- 0.75*chw
    if(key.side==2){
      x0 <- par()$usr[1]-chw-barwid
      xcutpos <- x0 - 0.4*chw
      xquilepos <- x0+barwid+0.55*chw
      srt <- 90
    }
    else {
      x0 <- par()$usr[2]+chw
      xcutpos <- x0 + barwid + 0.4*chw
      xquilepos <- x0-0.4*chw
      srt <- -90
    }
    yvals2 <- seq(from=par()$usr[3], to=par()$usr[4],
                  length=n2+midbreak+2*nacat+1)[-(n2+midbreak+2*nacat+1)]
    eps2 <- diff(yvals2[1:2])

    if(nacat){
      nlast <- length(yvals2)
      nclast <- length(colpal)
      rect(x0, yvals2[nlast], x0+barwid, yvals2[nlast]+eps2,
           col=colpal[nclast], xpd=TRUE)
      text(x0+0.5*barwid, yvals2[nlast]+0.5*eps2, "NA",
           xpd=TRUE, srt=srt)
      yvals2 <- yvals2[-((nlast-1):nlast)]
      colpal <- colpal[-nclast]
    }
    if(!midbreak){
      rect(x0, yvals2, x0+barwid, yvals2+eps2,
           col=colpal, xpd=TRUE)
      text(xcutpos, c(yvals2[1],yvals2+eps2),
           paste(signif(quiles,3)), srt=srt, xpd=TRUE, cex=0.8)
      text(xquilepos, yvals2[1], "(0%)", srt=srt, xpd=TRUE, cex=0.65)
      fracs <- frac[-c(1, length(frac))]
      text(xquilepos, yvals2[-1],
           paste("(",round(fracs*100,2),")",sep=""),
           srt=srt, xpd=TRUE, cex=0.65)
      text(xquilepos, yvals2[length(yvals2)]+eps2, "(100%)", srt=srt,
           xpd=TRUE, cex=0.65)

    }
    else {rect(x0, yvals2[1:nhalf], x0+barwid, yvals2[1:nhalf]+eps2,
               col=colpal[1:nhalf], xpd=TRUE)
          rect(x0, yvals2[(nhalf+2):(2*nhalf+1)], x0+barwid,
               yvals2[(nhalf+2):(2*nhalf+1)]+eps2,
               col=colpal[(nhalf+2):(2*nhalf+1)], xpd=TRUE)
          text(xcutpos, yvals2[1:(nhalf+1)],
               paste(signif(quiles1,3)), srt=srt, xpd=TRUE, cex=0.8)
          text(xquilepos, yvals2[2:(nhalf+1)],
               paste("(",round(plo[-1]*100,2),")",sep=""), srt=srt,
               xpd=TRUE, cex=0.65)
          text(xquilepos, yvals2[1], "(0%)", srt=srt, xpd=TRUE, cex=0.65)
          text(xcutpos,
               c(yvals2[(nhalf+2):(2*nhalf+1)], yvals2[2*nhalf+1]+eps2),
               paste(signif(quiles2,3)), srt=srt, xpd=TRUE, cex=0.8)
          text(xquilepos, yvals2[(nhalf+2):(2*nhalf+1)],
               paste("(",round(phi[-length(phi)]*100,2),")",sep=""),
               srt=srt, xpd=TRUE, cex=0.65)
          text(xquilepos, yvals2[2*nhalf+1]+eps2, "(100%)", srt=srt,
               xpd=TRUE, cex=0.65)
        }
  }
  invisible()
  }

DAAGbio documentation built on Aug. 21, 2023, 1:08 a.m.