scoreplot              package:hddplot              R Documentation

_P_l_o_t _d_i_s_c_r_i_m_i_n_a_n_t _f_u_n_c_t_i_o_n _s_c_o_r_e_s, _w_i_t_h _v_a_r_i_o_u_s _i_d_e_n_t_i_f_i_c_a_t_i_o_n

_D_e_s_c_r_i_p_t_i_o_n:

     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.

_U_s_a_g_e:

     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)

_A_r_g_u_m_e_n_t_s:

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

_D_e_t_a_i_l_s:

_V_a_l_u_e:

     A graph is plotted.

_N_o_t_e:

_A_u_t_h_o_r(_s):

     John Maindonald

_R_e_f_e_r_e_n_c_e_s:

_S_e_e _A_l_s_o:

     See also 'cvdisc', 'cvscores'

_E_x_a_m_p_l_e_s:

     ## 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)
         }
       }

