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

