scoreplot {hddplot} | R Documentation

## Plot discriminant function scores, with various identification

### Description

There is provision for the plottting of two sets of scores on the same graph, possibly with different classifying factors. The function is designed for use with output from `cvscores()` or from `simulateScores()`. This is an alpha version! Suggestions for code changes and/or enhancements that will improve the graphs will be welcomed.

### Usage

    scoreplot(scorelist = miniG.scores, plot.disc = 1:2, xlab = NULL, ylab = NULL, params = NULL, circle = NULL, cl.circle = NULL, circle.pos = c(1, 1), adj.circle = 1, adj.title = 0.5, join.legends = TRUE, prefix.title = "", cex.title = 1, ratio = 1, plot.folds = FALSE)

### Arguments

`scorelist` | list, with elements `scores` (a matrix of scores) `cl` (a classifying factor), `other` (optional, a further sets of scores), `cl.other` (a a classifying factor for `other`, optional) and `nfeatures` (optional, used to label the graph)
`plot.disc` | choice of columns of `scorelist` to plot
`xlab` | label for x-axis
`ylab` | label for y-axis
`params` | List, with optional elements (lists) `points`, `other`, `circle` and `legend`. Allowed list elements for `points` and `other` are `cex`, `lwd`, `pch` and `col`. For `circle` they are `cex`, `lwd` and `col`. For `legend`, they are `cex` and `cex.other`
`circle` | identifies points that are to be circled
`cl.circle` | different colors may be used for different points, according to levels of `cl.circle`
`circle.pos` | This is a vector of length 2, that specifies where to place the legend information for the circling of points. Possibilities are `c(0,0)` (left, below), `c(1,1)` (right, above), etc.
`adj.circle` | controls positioning of circle legend
`adj.title` | controls positioning of title
`join.legends` | logical; should legends for `points` and `other` be combined?
`prefix.title` | prefix, to place before title
`cex.title` | `cex` for title
`ratio` | `y`-scale to `x`-scale ratio for graph
`plot.folds` | Plot individual fold information, comparing projected training scores with their projections onto the global space. This is not at present implemented

### Details

### Value

A graph is plotted.

### Note

### Author(s)

John Maindonald

### References

### See Also

See also `cvdisc`, `cvscores`

### Examples

    ## Use first 500 rows (expression values) of Golub, for demonstration.
    data(Golub)
    data(golubInfo)
    attach(golubInfo)
    miniG.BM <- Golub[1:500, BM.PB=="BM"]  # 1st 500 rows only
    cancer.BM <- cancer[BM.PB=="BM"]
    miniG.cv <- cvdisc(miniG.BM, cl=cancer.BM, nfeatures=1:10,
                        nfold=c(3,1))
    miniG.scores <- cvscores(cvlist=miniG.cv, nfeatures=4,
                             cl.other=NULL)
    subsetB <- (cancer=="allB") & (tissue.mf %in% c("BM:f","BM:m","PB:m"))
    tissue.mfB <- tissue.mf[subsetB, drop=TRUE]
    scoreplot(scorelist=miniG.scores, cl.circle=tissue.mfB,
           circle=tissue.mfB%in%c("BM:f","BM:m"),
           params=list(circle=list(col=c("cyan","gray"))),
           prefix="BM samples -")
    detach(golubInfo)

    ## The function is currently defined as
      function(scorelist=BMonly.scores, plot.disc=1:2,
               xlab=NULL, ylab=NULL, params=NULL,
               circle=NULL, cl.circle=NULL, circle.pos=c(1,1),
               adj.circle=1,
               adj.title=0.5, join.legends=T, prefix.title="Golub data - ",
               cex.title=1.0, ratio=1, plot.folds=FALSE ){
        library(MASS)
        combine.params <-
          function(params=list(circle=list(col=c("cyan","gray")))){
            default.params=list(points=list(cex=1, lwd=1.25, pch=1:8, col=1:8),
              other=list(cex=0.65, lwd=1.25, pch=13:9, col=c(6:8,5:1)),
              circle=list(cex=2, lwd=1, pch=1.75, col="gray40"),
              legend=list(cex=1, cex.other=1))
            nam <- names(params)
            if(!is.null(nam))
              for(a in nam){
                nam2 <- names(params[[a]])
                for(b in nam2)default.params[[a]][[b]] <- params[[a]][[b]]
              }
            default.params
          }
        params <- combine.params(params=params)
        cl <- scorelist$cl
        cl.other <- scorelist$cl.other
        if(!is.null(cl.other)) cl.other <- factor(cl.other)
        nfeatures <- scorelist$nfeatures
        if(length(plot.disc)==2){
          n1 <- plot.disc[1]
          n2 <- plot.disc[2]
          if(is.null(xlab))xlab <- paste("Discriminant function", n1)
          if(is.null(ylab))ylab <- paste("Discriminant function", n2)
        } else stop("plot.disc must be a vector of length 2")
        if(!is.factor(cl))cl <- factor(cl)
        levnames <- levels(cl)
        fitscores <- scorelist$scores
        other.scores <- scorelist$other
        ngp <- length(levnames)
        n1lim <- range(fitscores[,n1])
        n2lim <- range(fitscores[,n2])
        if(!is.null(cl.other)){
          n1lim <- range(c(n1lim, other.scores[,n1]))
          n2lim <- range(c(n2lim, other.scores[,n2]))
          levnum <- unclass(cl.other)
          levnames.other <- levels(cl.other)
          intlev.other <- unclass(cl.other)
          ngp.other <- length(levels(cl.other))
        }
        n1 <- plot.disc[1]; n2 <- plot.disc[2]
        intlev <- unclass(cl)
        oldpar <- par(lwd=1)
        on.exit(par(oldpar))
        eqscplot(n1lim, n2lim, type="n",
                 xlab=xlab, ylab=ylab, ratio=ratio)
        with(params$points,
             points(fitscores[,n1], fitscores[,n2], col=col[intlev],
                    pch=pch[intlev], cex=cex, lwd=lwd))
        if(!is.null(cl.other))
          with(params$other,
               points(other.scores[,n1], other.scores[,n2],
                      pch=pch[intlev.other],
                      col=col[intlev.other],
                      cex=cex, lwd=lwd))
        if(!is.null(cl.circle)){
          cl.circle <- factor(cl.circle[circle])
          lev.circle <- levels(cl.circle)
          with(params$circle,
               points(fitscores[circle, n1], fitscores[circle,n2], pch=pch,
                      cex=cex, col=col[unclass(cl.circle)], lwd=lwd))
        }
        par(xpd=TRUE)
        chw <- par()$cxy[1]
        chh <- par()$cxy[2]
        par(lwd=1.5)
        ypos <- par()$usr[4]
        xmid <- mean(par()$usr[1:2])
        top.pos <- 0
        mtext(side=3, line=(top.pos+1), paste(prefix.title,
                nfeatures, "features"), cex=cex.title, adj=adj.title)
        ypos.legend <- ypos+(top.pos-0.45)*chh*0.8

        if(join.legends&!is.null(cl.other)){
          leg.info <- legend(xmid, ypos.legend, xjust=0.5, yjust=0, plot=FALSE,
                             x.intersp=0.5, ncol=ngp, legend=levnames,
                             pt.lwd=params$points$lwd,
                             pt.cex=params$points$cex,
                             cex=params$legend$cex,
                             pch=params$points$pch)
          legother.info <- legend(xmid, ypos.legend, xjust=0.5, yjust=0,
                                  plot=FALSE, x.intersp=0.5,
                                  ncol=ngp.other, legend=levnames.other,
                                  pt.lwd=params$other$lwd,
                                  pt.cex=params$other$cex,
                                  cex=params$legend$cex.other,
                                  pch=params$other$pch)
          leftoff <- 0.5*legother.info$rect$w-0.5*chw
          rightoff <- 0.5*leg.info$rect$w+0.5*chw
          ypos.other <- ypos.legend
        }
        else {
          leftoff <- 0
          rightoff <- 0
          ypos.other <- ypos+(top.pos-1.5)*chh*0.8
        }
        legend(xmid-leftoff, ypos.legend, xjust=0.5, yjust=0,
               bty="n", pch=params$points$pch,
               x.intersp=0.5, col=params$points$col, ncol=ngp,
               legend=levnames,
               pt.lwd=params$points$lwd,
               pt.cex=params$points$cex,
               cex=params$legend$cex)
        par(lwd=1)
        if(!is.null(cl.other))
          lego.info <- legend(xmid+rightoff, ypos.other, xjust=0.5, yjust=0,
                              pch=params$other$pch, x.intersp=0.5,
                              col=params$other$col, ncol=ngp.other,
                              pt.lwd=params$other$lwd,
                              pt.cex=params$other$cex,
                              legend=levnames.other,
                              cex=params$legend$cex.other,
                              bty="n")
        if(!is.null(cl.other)&join.legends)
          text(lego.info$rect$left+c(0.4*chw,lego.info$rect$w-0.25*chw),
               rep(ypos.other,2)+0.8*chh, labels=c("(",")"),
               cex=params$legend$cex,
               lwd=params$legend$lwd, bty="n")
        par(lwd=params$circle$lwd)
        if(!is.null(cl.circle))if(lev.circle[1]!=""){
          pch.circle <- params$circle$pch
          xy <- par()$usr[circle.pos+c(1,3)]
          legend(xy[1], xy[2],
                 xjust=adj.circle[1], yjust=circle.pos[2], bty="n", x.intersp=0.5,
                 pch=rep(pch.circle,length(lev.circle)), col=params$circle$col,
                 ncol=1, legend=lev.circle, cex=0.85, pt.cex=1.5)
        }
        par(lwd=1, xpd=FALSE)
        if(plot.folds){
          mtext(side=1, line=1.25, "Discriminant function 1", outer=T)
          mtext(side=2, line=1.25, "Discriminant function 2", outer=T)
        }
      }

[Package hddplot version 0.51 Index]