Thread: [R-gregmisc-users] SF.net SVN: r-gregmisc:[1318] trunk/gplots
Brought to you by:
warnes
Menu
▾
▴
r-gregmisc-users
|
From: <wa...@us...> - 2009-05-08 21:57:03
|
Revision: 1318
http://r-gregmisc.svn.sourceforge.net/r-gregmisc/?rev=1318&view=rev
Author: warnes
Date: 2009-05-08 21:56:38 +0000 (Fri, 08 May 2009)
Log Message:
-----------
plotCI now properly handles 'NULL' and 'NA' values for ui, li, uiw, and liw.
Modified Paths:
--------------
trunk/gplots/R/plotCI.R
trunk/gplots/man/plotCI.Rd
Modified: trunk/gplots/R/plotCI.R
===================================================================
--- trunk/gplots/R/plotCI.R 2009-05-08 21:55:05 UTC (rev 1317)
+++ trunk/gplots/R/plotCI.R 2009-05-08 21:56:38 UTC (rev 1318)
@@ -67,6 +67,12 @@
else
z <- x
+ if(invalid(uiw))
+ uiw <- NA
+ if(invalid(liw))
+ liw <- NA
+
+
if(invalid(ui))
ui <- z + uiw
if(invalid(li))
Modified: trunk/gplots/man/plotCI.Rd
===================================================================
--- trunk/gplots/man/plotCI.Rd 2009-05-08 21:55:05 UTC (rev 1317)
+++ trunk/gplots/man/plotCI.Rd 2009-05-08 21:56:38 UTC (rev 1318)
@@ -41,18 +41,18 @@
defaults to \code{1:n}.}
\item{uiw}{ width of the upper or right error bar. Set to \code{NULL}
- omit upper bars.}
+ or \code{NA} to omit upper bars.}
\item{liw}{ width of the lower or left error bar. Defaults to same value as
- \code{uiw}. Set to \code{NULL} to omit lower bars. }
+ \code{uiw}. Set to \code{NULL} or \code{NA} to omit lower bars. }
\item{ui}{ upper end of error bars. Defaults to \code{y + uiw} or
- \code{x + uiw} depeding on \code{err}. Set to \code{NULL} omit
- upper bars. }
+ \code{x + uiw} depeding on \code{err}. Set to \code{NULL} or
+ \code{NA} to omit upper bars. }
\item{li}{ lower end of error bars. Defaults to \code{y - liw} or
- \code{x - liw} depedning on \code{err}. Set to \code{NULL} to omit
- lower bars.}
+ \code{x - liw} depedning on \code{err}. Set to \code{NULL} or
+ \code{NA} to omit lower bars.}
\item{err}{ direction for error bars. Set to "y" for vertical bars.
Set to "x" for horizontal bars. Defaults to "y".}
@@ -147,6 +147,22 @@
# better yet, just use plotmeans ... #
plotmeans( state.area ~ state.region )
+/dontshow{
+## Just for testing
+ plotCI(x=means, uiw=NA)
+ plotCI(x=means, uiw=NULL)
+ plotCI(x=means, uiw=ciw)
+ plotCI(x=means, uiw=ciw, liw=NULL)
+ plotCI(x=means, uiw=ciw, liw=NA)
+ plotCI(x=means, liw=ciw, ciw=NULL)
+ plotCI(x=means, liw=ciw, ciw=NA)
+ ciw.na <- ciw
+ ciw.na[3] <- NA
+ plotCI(x=means, uiw=ciw.na, liw=ciw)
+ plotCI(x=means, liw=ciw.na, uiw=ciw)
}
+
+}
+
\keyword{ hplot }
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <wa...@us...> - 2009-05-08 21:55:20
|
Revision: 1317
http://r-gregmisc.svn.sourceforge.net/r-gregmisc/?rev=1317&view=rev
Author: warnes
Date: 2009-05-08 21:55:05 +0000 (Fri, 08 May 2009)
Log Message:
-----------
heatmap.2: Add option to create breakpoints symmetric around 0, provide additional information in the return value
Modified Paths:
--------------
trunk/gplots/R/heatmap.2.R
trunk/gplots/man/heatmap.2.Rd
trunk/gplots/tests/heatmap2Test.Rout.save
Modified: trunk/gplots/R/heatmap.2.R
===================================================================
--- trunk/gplots/R/heatmap.2.R 2009-05-08 21:27:55 UTC (rev 1316)
+++ trunk/gplots/R/heatmap.2.R 2009-05-08 21:55:05 UTC (rev 1317)
@@ -1,164 +1,177 @@
-# $Id$
+## $Id$
heatmap.2 <- function (x,
- # dendrogram control
- Rowv = TRUE,
- Colv=if(symm)"Rowv" else TRUE,
- distfun = dist,
- hclustfun = hclust,
- dendrogram = c("both","row","column","none"),
- symm = FALSE,
+ ## dendrogram control
+ Rowv = TRUE,
+ Colv=if(symm)"Rowv" else TRUE,
+ distfun = dist,
+ hclustfun = hclust,
+ dendrogram = c("both","row","column","none"),
+ symm = FALSE,
- # data scaling
- scale = c("none","row", "column"),
- na.rm=TRUE,
+ ## data scaling
+ scale = c("none","row", "column"),
+ na.rm=TRUE,
- # image plot
- revC = identical(Colv, "Rowv"),
- add.expr,
- breaks,
- col="heat.colors",
+ ## image plot
+ revC = identical(Colv, "Rowv"),
+ add.expr,
- # block sepration
- colsep,
- rowsep,
- sepcolor="white",
- sepwidth=c(0.05,0.05),
+ ## mapping data to colors
+ breaks,
+ symbreaks=min(x < 0, na.rm=TRUE) || scale!="none",
- # cell labeling
- cellnote,
- notecex=1.0,
- notecol="cyan",
- na.color=par("bg"),
+ ## colors
+ col="heat.colors",
- # level trace
- trace=c("column","row","both","none"),
- tracecol="cyan",
- hline=median(breaks),
- vline=median(breaks),
- linecol=tracecol,
+ ## block sepration
+ colsep,
+ rowsep,
+ sepcolor="white",
+ sepwidth=c(0.05,0.05),
- # Row/Column Labeling
- margins = c(5, 5),
- ColSideColors,
- RowSideColors,
- cexRow = 0.2 + 1/log10(nr),
- cexCol = 0.2 + 1/log10(nc),
- labRow = NULL,
- labCol = NULL,
+ ## cell labeling
+ cellnote,
+ notecex=1.0,
+ notecol="cyan",
+ na.color=par("bg"),
- # color key + density info
- key = TRUE,
- keysize = 1.5,
- density.info=c("histogram","density","none"),
- denscol=tracecol,
- #symkey = TRUE, # should be something like
- symkey = min(x < 0, na.rm=TRUE),
- densadj = 0.25,
+ ## level trace
+ trace=c("column","row","both","none"),
+ tracecol="cyan",
+ hline=median(breaks),
+ vline=median(breaks),
+ linecol=tracecol,
- # plot labels
- main = NULL,
- xlab = NULL,
- ylab = NULL,
+ ## Row/Column Labeling
+ margins = c(5, 5),
+ ColSideColors,
+ RowSideColors,
+ cexRow = 0.2 + 1/log10(nr),
+ cexCol = 0.2 + 1/log10(nc),
+ labRow = NULL,
+ labCol = NULL,
- # plot layout
- lmat = NULL,
- lhei = NULL,
- lwid = NULL,
+ ## color key + density info
+ key = TRUE,
+ keysize = 1.5,
+ density.info=c("histogram","density","none"),
+ denscol=tracecol,
+ symkey = min(x < 0, na.rm=TRUE) || symbreaks,
+ densadj = 0.25,
- # extras
- ...
- )
+ ## plot labels
+ main = NULL,
+ xlab = NULL,
+ ylab = NULL,
+
+ ## plot layout
+ lmat = NULL,
+ lhei = NULL,
+ lwid = NULL,
+
+ ## extras
+ ...
+ )
{
scale01 <- function(x, low=min(x), high=max(x) )
{
x <- (x-low)/(high - low)
x
}
+
+ retval <- list()
+
+ scale <- if(symm && missing(scale)) "none" else match.arg(scale)
+ dendrogram <- match.arg(dendrogram)
+ trace <- match.arg(trace)
+ density.info <- match.arg(density.info)
- scale <- if(symm && missing(scale)) "none" else match.arg(scale)
- dendrogram <- match.arg(dendrogram)
- trace <- match.arg(trace)
- density.info <- match.arg(density.info)
+ if(length(col)==1 && is.character(col) )
+ col <- get(col, mode="function")
- if(!missing(breaks) && (scale!="none"))
- warning("Using scale=\"row\" or scale=\"column\" when breaks are",
- "specified can produce unpredictable results.",
- "Please consider using only one or the other.")
+ if(!missing(breaks) && (scale!="none"))
+ warning("Using scale=\"row\" or scale=\"column\" when breaks are",
+ "specified can produce unpredictable results.",
+ "Please consider using only one or the other.")
- # key & density don't make sense when data is not all on the same scale
-# if(scale!="none" && key==TRUE)
-# {
-# warning("Key cannot be plotted when scale!=\"none\".")
-# key=FALSE
-# }
+ ## key & density don't make sense when data is not all on the same scale
+ ## if(scale!="none" && key==TRUE)
+ ## {
+ ## warning("Key cannot be plotted when scale!=\"none\".")
+ ## key=FALSE
+ ## }
-
-
- if ( (Colv=="Rowv") && (!isTRUE(Rowv) || is.null(Rowv) ) )
+ if ( is.null(Rowv) )
+ Rowv <- FALSE
+ if ( is.null(Colv) )
Colv <- FALSE
+ else if( Colv=="Rowv" && !isTRUE(Rowv) )
+ Colv <- FALSE
- if(length(di <- dim(x)) != 2 || !is.numeric(x))
- stop("`x' must be a numeric matrix")
+
+ if(length(di <- dim(x)) != 2 || !is.numeric(x))
+ stop("`x' must be a numeric matrix")
- nr <- di[1]
- nc <- di[2]
+ nr <- di[1]
+ nc <- di[2]
- if(nr <= 1 || nc <= 1)
- stop("`x' must have at least 2 rows and 2 columns")
+ if(nr <= 1 || nc <= 1)
+ stop("`x' must have at least 2 rows and 2 columns")
- if(!is.numeric(margins) || length(margins) != 2)
- stop("`margins' must be a numeric vector of length 2")
+ if(!is.numeric(margins) || length(margins) != 2)
+ stop("`margins' must be a numeric vector of length 2")
- if(missing(cellnote))
- cellnote <- matrix("", ncol=ncol(x), nrow=nrow(x))
+ if(missing(cellnote))
+ cellnote <- matrix("", ncol=ncol(x), nrow=nrow(x))
- if(!inherits(Rowv, "dendrogram")) {
- ## Check if Rowv and dendrogram arguments are consistent
- if ( ( (!isTRUE(Rowv)) || (is.null(Rowv))) && (dendrogram %in% c("both","row") ) )
- {
- if (is.logical(Colv) && (Colv))
- dendrogram <- "column"
- else
- dedrogram <- "none"
-
- warning("Discrepancy: Rowv is FALSE, while dendrogram is `",
- dendrogram, "'. Omitting row dendogram.")
-
+ if(!inherits(Rowv, "dendrogram")) {
+ ## Check if Rowv and dendrogram arguments are consistent
+ if ( ( (!isTRUE(Rowv)) || (is.null(Rowv))) &&
+ (dendrogram %in% c("both","row") ) )
+ {
+ if (is.logical(Colv) && (Colv))
+ dendrogram <- "column"
+ else
+ dedrogram <- "none"
+
+ warning("Discrepancy: Rowv is FALSE, while dendrogram is `",
+ dendrogram, "'. Omitting row dendogram.")
+
+ }
}
-}
- if(!inherits(Colv, "dendrogram")) {
- ## Check if Colv and dendrogram arguments are consistent
- if ( ( (!isTRUE(Colv)) || (is.null(Colv)))
- && (dendrogram %in% c("both","column")) )
- {
- if (is.logical(Rowv) && (Rowv))
- dendrogram <- "row"
- else
- dendrogram <- "none"
-
- warning("Discrepancy: Colv is FALSE, while dendrogram is `",
- dendrogram, "'. Omitting column dendogram.")
- }
-}
+ if(!inherits(Colv, "dendrogram")) {
+ ## Check if Colv and dendrogram arguments are consistent
+ if ( ( (!isTRUE(Colv)) || (is.null(Colv)))
+ && (dendrogram %in% c("both","column")) )
+ {
+ if (is.logical(Rowv) && (Rowv))
+ dendrogram <- "row"
+ else
+ dendrogram <- "none"
+
+ warning("Discrepancy: Colv is FALSE, while dendrogram is `",
+ dendrogram, "'. Omitting column dendogram.")
+ }
+ }
## by default order by row/col mean
## if(is.null(Rowv)) Rowv <- rowMeans(x, na.rm = na.rm)
## if(is.null(Colv)) Colv <- colMeans(x, na.rm = na.rm)
- ## get the dendrograms and reordering indices
+ ## get the dendrograms and reordering indices
- ## if( dendrogram %in% c("both","row") )
- ## { ## dendrogram option is used *only* for display purposes
+ ## if( dendrogram %in% c("both","row") )
+ ## { ## dendrogram option is used *only* for display purposes
if(inherits(Rowv, "dendrogram"))
{
ddr <- Rowv ## use Rowv 'as-is', when it is dendrogram
rowInd <- order.dendrogram(ddr)
}
-else if (is.integer(Rowv))
+ else if (is.integer(Rowv))
{ ## Compute dendrogram and do reordering based on given vector
hcr <- hclustfun(distfun(x))
ddr <- as.dendrogram(hcr)
@@ -208,308 +221,342 @@
if(nc != length(colInd))
stop("column dendrogram ordering gave index of wrong length")
}
-else if (isTRUE(Colv))
- {## If TRUE, compute dendrogram and do reordering based on rowMeans
- Colv <- colMeans(x, na.rm = na.rm)
- hcc <- hclustfun(distfun(if(symm)x else t(x)))
- ddc <- as.dendrogram(hcc)
- ddc <- reorder(ddc, Colv)
+ else if (isTRUE(Colv))
+ {## If TRUE, compute dendrogram and do reordering based on rowMeans
+ Colv <- colMeans(x, na.rm = na.rm)
+ hcc <- hclustfun(distfun(if(symm)x else t(x)))
+ ddc <- as.dendrogram(hcc)
+ ddc <- reorder(ddc, Colv)
- colInd <- order.dendrogram(ddc)
- if(nc != length(colInd))
- stop("column dendrogram ordering gave index of wrong length")
- }
-else
- {
- colInd <- 1:nc
- }
+ colInd <- order.dendrogram(ddc)
+ if(nc != length(colInd))
+ stop("column dendrogram ordering gave index of wrong length")
+ }
+ else
+ {
+ colInd <- 1:nc
+ }
+
+ retval$rowInd <- rowInd
+ retval$colInd <- colInd
+ retval$call <- match.call()
+
- ## reorder x & cellnote
- x <- x[rowInd, colInd]
- x.unscaled <- x
- cellnote <- cellnote[rowInd, colInd]
+ ## reorder x & cellnote
+ x <- x[rowInd, colInd]
+ x.unscaled <- x
+ cellnote <- cellnote[rowInd, colInd]
- if(is.null(labRow))
- labRow <- if(is.null(rownames(x))) (1:nr)[rowInd] else rownames(x)
- else
- labRow <- labRow[rowInd]
+ if(is.null(labRow))
+ labRow <- if(is.null(rownames(x))) (1:nr)[rowInd] else rownames(x)
+ else
+ labRow <- labRow[rowInd]
- if(is.null(labCol))
- labCol <- if(is.null(colnames(x))) (1:nc)[colInd] else colnames(x)
- else
- labCol <- labCol[colInd]
+ if(is.null(labCol))
+ labCol <- if(is.null(colnames(x))) (1:nc)[colInd] else colnames(x)
+ else
+ labCol <- labCol[colInd]
- if(scale == "row") {
- x <- sweep(x, 1, rowMeans(x, na.rm = na.rm))
- sx <- apply(x, 1, sd, na.rm = na.rm)
- x <- sweep(x, 1, sx, "/")
- }
- else if(scale == "column") {
- x <- sweep(x, 2, colMeans(x, na.rm = na.rm))
- sx <- apply(x, 2, sd, na.rm = na.rm)
- x <- sweep(x, 2, sx, "/")
- }
+ if(scale == "row") {
+ retval$rowMeans <- rm <- rowMeans(x, na.rm = na.rm)
+ x <- sweep(x, 1, rm)
+ retval$rowSDs <- sx <- apply(x, 1, sd, na.rm = na.rm)
+ x <- sweep(x, 1, sx, "/")
+ }
+ else if(scale == "column") {
+ retval$colMeans <- rm <- colMeans(x, na.rm = na.rm)
+ x <- sweep(x, 2, rm)
+ retval$colSDs <- sx <- apply(x, 2, sd, na.rm = na.rm)
+ x <- sweep(x, 2, sx, "/")
+ }
- ## Set up breaks and force values outside the range into the endmost bins
- if(missing(breaks) || is.null(breaks) || length(breaks)<1 )
- if(missing(col))
+ ## Set up breaks and force values outside the range into the endmost bins
+ if(missing(breaks) || is.null(breaks) || length(breaks)<1 )
+ {
+ if( missing(col) || is.function(col) )
breaks <- 16
- else
+ else
breaks <- length(col)+1
- if(length(breaks)==1)
- {
+ }
+
+ if(length(breaks)==1)
+ {
+ if(!symbreaks)
breaks <- seq( min(x, na.rm=na.rm), max(x,na.rm=na.rm), length=breaks)
- }
+ else
+ {
+ extreme <- max(abs(x), na.rm=TRUE)
+ breaks <- seq( -extreme, extreme, length=breaks )
+ }
+ }
- nbr <- length(breaks)
- ncol <- length(breaks)-1
+ nbr <- length(breaks)
+ ncol <- length(breaks)-1
- if(class(col)=="function")
- col <- col(ncol)
- else if(is.character(col) && length(col)==1)
- col <- do.call(col,list(ncol))
+ if(class(col)=="function")
+ col <- col(ncol)
- min.breaks <- min(breaks)
- max.breaks <- max(breaks)
+ min.breaks <- min(breaks)
+ max.breaks <- max(breaks)
- x[] <- ifelse(x<min.breaks, min.breaks, x)
- x[] <- ifelse(x>max.breaks, max.breaks, x)
+ x[x<min.breaks] <- min.breaks
+ x[x>max.breaks] <- max.breaks
-
-
+ ## Calculate the plot layout
+ if( missing(lhei) || is.null(lhei) )
+ lhei <- c(keysize, 4)
-
- ## Calculate the plot layout
- if( missing(lhei) || is.null(lhei) )
- lhei <- c(keysize, 4)
+ if( missing(lwid) || is.null(lwid) )
+ lwid <- c(keysize, 4)
- if( missing(lwid) || is.null(lwid) )
- lwid <- c(keysize, 4)
+ if( missing(lmat) || is.null(lmat) )
+ {
+ lmat <- rbind(4:3, 2:1)
+
+ if(!missing(ColSideColors)) { ## add middle row to layout
+ if(!is.character(ColSideColors) || length(ColSideColors) != nc)
+ stop("'ColSideColors' must be a character vector of length ncol(x)")
+ lmat <- rbind(lmat[1,]+1, c(NA,1), lmat[2,]+1)
+ lhei <- c(lhei[1], 0.2, lhei[2])
+ }
- if( missing(lmat) || is.null(lmat) )
- {
- lmat <- rbind(4:3, 2:1)
-
- if(!missing(ColSideColors)) { ## add middle row to layout
- if(!is.character(ColSideColors) || length(ColSideColors) != nc)
- stop("'ColSideColors' must be a character vector of length ncol(x)")
- lmat <- rbind(lmat[1,]+1, c(NA,1), lmat[2,]+1)
- lhei <- c(lhei[1], 0.2, lhei[2])
- }
+ if(!missing(RowSideColors)) { ## add middle column to layout
+ if(!is.character(RowSideColors) || length(RowSideColors) != nr)
+ stop("'RowSideColors' must be a character vector of length nrow(x)")
+ lmat <- cbind(lmat[,1]+1, c(rep(NA, nrow(lmat)-1), 1), lmat[,2]+1)
+ lwid <- c(lwid[1], 0.2, lwid[2])
+ }
- if(!missing(RowSideColors)) { ## add middle column to layout
- if(!is.character(RowSideColors) || length(RowSideColors) != nr)
- stop("'RowSideColors' must be a character vector of length nrow(x)")
- lmat <- cbind(lmat[,1]+1, c(rep(NA, nrow(lmat)-1), 1), lmat[,2]+1)
- lwid <- c(lwid[1], 0.2, lwid[2])
- }
+ lmat[is.na(lmat)] <- 0
+ }
+
+ if(length(lhei) != nrow(lmat))
+ stop("lhei must have length = nrow(lmat) = ", nrow(lmat))
- lmat[is.na(lmat)] <- 0
- }
-
- if(length(lhei) != nrow(lmat))
- stop("lhei must have length = nrow(lmat) = ", nrow(lmat))
+ if(length(lwid) != ncol(lmat))
+ stop("lwid must have length = ncol(lmat) =", ncol(lmat))
- if(length(lwid) != ncol(lmat))
- stop("lwid must have length = ncol(lmat) =", ncol(lmat))
+ ## Graphics `output' -----------------------
- ## Graphics `output' -----------------------
+ op <- par(no.readonly = TRUE)
+ on.exit(par(op))
+ layout(lmat, widths = lwid, heights = lhei, respect = FALSE)
- op <- par(no.readonly = TRUE)
- on.exit(par(op))
- layout(lmat, widths = lwid, heights = lhei, respect = FALSE)
-
- ## draw the side bars
- if(!missing(RowSideColors)) {
- par(mar = c(margins[1],0, 0,0.5))
- image(rbind(1:nr), col = RowSideColors[rowInd], axes = FALSE)
+ ## draw the side bars
+ if(!missing(RowSideColors)) {
+ par(mar = c(margins[1],0, 0,0.5))
+ image(rbind(1:nr), col = RowSideColors[rowInd], axes = FALSE)
+ }
+ if(!missing(ColSideColors)) {
+ par(mar = c(0.5,0, 0,margins[2]))
+ image(cbind(1:nc), col = ColSideColors[colInd], axes = FALSE)
+ }
+ ## draw the main carpet
+ par(mar = c(margins[1], 0, 0, margins[2]))
+ if(!symm || scale != "none")
+ {
+ x <- t(x)
+ cellnote <- t(cellnote)
}
- if(!missing(ColSideColors)) {
- par(mar = c(0.5,0, 0,margins[2]))
- image(cbind(1:nc), col = ColSideColors[colInd], axes = FALSE)
+ if(revC)
+ { ## x columns reversed
+ iy <- nr:1
+ if(exists("ddr"))
+ ddr <- rev(ddr)
+ x <- x[,iy]
+ cellnote <- cellnote[,iy]
}
- ## draw the main carpet
- par(mar = c(margins[1], 0, 0, margins[2]))
- if(!symm || scale != "none")
- {
- x <- t(x)
- cellnote <- t(cellnote)
- }
- if(revC)
- { # x columns reversed
- iy <- nr:1
- ddr <- rev(ddr)
- x <- x[,iy]
- cellnote <- cellnote[,iy]
- }
- else iy <- 1:nr
+ else iy <- 1:nr
- image(1:nc, 1:nr, x, xlim = 0.5+ c(0, nc), ylim = 0.5+ c(0, nr),
- axes = FALSE, xlab = "", ylab = "", col=col, breaks=breaks,
- ...)
+ ## display the main carpet
+ image(1:nc, 1:nr, x, xlim = 0.5+ c(0, nc), ylim = 0.5+ c(0, nr),
+ axes = FALSE, xlab = "", ylab = "", col=col, breaks=breaks,
+ ...)
+ retval$carpet <- x
+ if(exists("ddr"))
+ retval$rowDendrogram <- ddr
+ if(exists("ddc"))
+ retval$colDendrogram <- ddc
+ retval$breaks <- breaks
+ retval$col <- col
+
+ ## fill 'na' positions with na.color
+ if(!invalid(na.color) & any(is.na(x)))
+ {
+ mmat <- ifelse(is.na(x), 1, NA)
+ image(1:nc, 1:nr, mmat, axes = FALSE, xlab = "", ylab = "",
+ col=na.color, add=TRUE)
+ }
- if(!invalid(na.color) & any(is.na(x)))
- {
- mmat <- ifelse(is.na(x), 1, NA)
- image(1:nc, 1:nr, mmat, axes = FALSE, xlab = "", ylab = "",
- col=na.color, add=TRUE)
- }
+ ## add labels
+ axis(1, 1:nc, labels= labCol, las= 2, line= -0.5, tick= 0, cex.axis= cexCol)
+ if(!is.null(xlab)) mtext(xlab, side = 1, line = margins[1] - 1.25)
+ axis(4, iy, labels= labRow, las= 2, line= -0.5, tick= 0, cex.axis= cexRow)
+ if(!is.null(ylab)) mtext(ylab, side = 4, line = margins[2] - 1.25)
+ ## perform user-specified function
+ if (!missing(add.expr))
+ eval(substitute(add.expr))
- axis(1, 1:nc, labels= labCol, las= 2, line= -0.5, tick= 0, cex.axis= cexCol)
- if(!is.null(xlab)) mtext(xlab, side = 1, line = margins[1] - 1.25)
- axis(4, iy, labels= labRow, las= 2, line= -0.5, tick= 0, cex.axis= cexRow)
- if(!is.null(ylab)) mtext(ylab, side = 4, line = margins[2] - 1.25)
+ ## add 'background' colored spaces to visually separate sections
+ if(!missing(colsep))
+ for(csep in colsep)
+ rect(xleft =csep+0.5, ybottom=rep(0,length(csep)),
+ xright=csep+0.5+sepwidth[1], ytop=rep(ncol(x)+1,csep),
+ lty=1, lwd=1, col=sepcolor, border=sepcolor)
- if (!missing(add.expr))
- eval(substitute(add.expr))
+ if(!missing(rowsep))
+ for(rsep in rowsep)
+ rect(xleft =0, ybottom= (ncol(x)+1-rsep)-0.5,
+ xright=nrow(x)+1, ytop = (ncol(x)+1-rsep)-0.5 - sepwidth[2],
+ lty=1, lwd=1, col=sepcolor, border=sepcolor)
- ## add 'background' colored spaces to visually separate sections
- if(!missing(colsep))
- for(csep in colsep)
- rect(xleft =csep+0.5, ybottom=rep(0,length(csep)),
- xright=csep+0.5+sepwidth[1], ytop=rep(ncol(x)+1,csep),
- lty=1, lwd=1, col=sepcolor, border=sepcolor)
+
+ ## show traces
+ min.scale <- min(breaks)
+ max.scale <- max(breaks)
+ x.scaled <- scale01(t(x), min.scale, max.scale)
- if(!missing(rowsep))
- for(rsep in rowsep)
- rect(xleft =0, ybottom= (ncol(x)+1-rsep)-0.5,
- xright=nrow(x)+1, ytop = (ncol(x)+1-rsep)-0.5 - sepwidth[2],
- lty=1, lwd=1, col=sepcolor, border=sepcolor)
+ if(trace %in% c("both","column") )
+ {
+ retval$vline <- vline
+ vline.vals <- scale01(vline, min.scale, max.scale)
+ for( i in colInd )
+ {
+ if(!is.null(vline))
+ {
+ abline(v=i-0.5 + vline.vals, col=linecol, lty=2)
+ }
+ xv <- rep(i, nrow(x.scaled)) + x.scaled[,i] - 0.5
+ xv <- c(xv[1], xv)
+ yv <- 1:length(xv)-0.5
+ lines(x=xv, y=yv, lwd=1, col=tracecol, type="s")
+ }
+ }
- # show traces
- min.scale <- min(breaks)
- max.scale <- max(breaks)
- x.scaled <- scale01(t(x), min.scale, max.scale)
+ if(trace %in% c("both","row") )
+ {
+ retval$hline <- hline
+ hline.vals <- scale01(hline, min.scale, max.scale)
+ for( i in rowInd )
+ {
+ if(!is.null(hline))
+ {
+ abline(h=i + hline, col=linecol, lty=2)
+ }
+ yv <- rep(i, ncol(x.scaled)) + x.scaled[i,] - 0.5
+ yv <- rev(c(yv[1], yv))
+ xv <- length(yv):1-0.5
+ lines(x=xv, y=yv, lwd=1, col=tracecol, type="s")
+ }
+ }
- if(trace %in% c("both","column") )
- {
- for( i in colInd )
- {
- if(!is.null(vline))
- {
- vline.vals <- scale01(vline, min.scale, max.scale)
- abline(v=i-0.5 + vline.vals, col=linecol, lty=2)
- }
- xv <- rep(i, nrow(x.scaled)) + x.scaled[,i] - 0.5
- xv <- c(xv[1], xv)
- yv <- 1:length(xv)-0.5
- lines(x=xv, y=yv, lwd=1, col=tracecol, type="s")
- }
- }
-
- if(trace %in% c("both","row") )
- {
- for( i in rowInd )
- {
- if(!is.null(hline))
- {
- hline.vals <- scale01(hline, min.scale, max.scale)
- abline(h=i + hline, col=linecol, lty=2)
- }
- yv <- rep(i, ncol(x.scaled)) + x.scaled[i,] - 0.5
- yv <- rev(c(yv[1], yv))
- xv <- length(yv):1-0.5
- lines(x=xv, y=yv, lwd=1, col=tracecol, type="s")
- }
- }
+ if(!missing(cellnote))
+ text(x=c(row(cellnote)),
+ y=c(col(cellnote)),
+ labels=c(cellnote),
+ col=notecol,
+ cex=notecex)
+ ## the two dendrograms :
+ par(mar = c(margins[1], 0, 0, 0))
+ if( dendrogram %in% c("both","row") )
+ {
+ plot(ddr, horiz = TRUE, axes = FALSE, yaxs = "i", leaflab = "none")
+ }
+ else
+ plot.new()
- if(!missing(cellnote))
- text(x=c(row(cellnote)),
- y=c(col(cellnote)),
- labels=c(cellnote),
- col=notecol,
- cex=notecex)
+ par(mar = c(0, 0, if(!is.null(main)) 5 else 0, margins[2]))
- ## the two dendrograms :
- par(mar = c(margins[1], 0, 0, 0))
- if( dendrogram %in% c("both","row") )
- {
- plot(ddr, horiz = TRUE, axes = FALSE, yaxs = "i", leaflab = "none")
- }
- else
- plot.new()
+ if( dendrogram %in% c("both","column") )
+ {
+ plot(ddc, axes = FALSE, xaxs = "i", leaflab = "none")
+ }
+ else
+ plot.new()
- par(mar = c(0, 0, if(!is.null(main)) 5 else 0, margins[2]))
+ ## title
+ if(!is.null(main)) title(main, cex.main = 1.5*op[["cex.main"]])
- if( dendrogram %in% c("both","column") )
- {
- plot(ddc, axes = FALSE, xaxs = "i", leaflab = "none")
- }
- else
- plot.new()
+ ## Add the color-key
+ if(key)
+ {
+ par(mar = c(5, 4, 2, 1), cex=0.75)
+ tmpbreaks <- breaks
- ## title
- if(!is.null(main)) title(main, cex.main = 1.5*op[["cex.main"]])
+ if(symkey)
+ {
+ max.raw <- max(abs(c(x,breaks)),na.rm=TRUE)
+ min.raw <- -max.raw
+ tmpbreaks[1] <- -max(abs(x))
+ tmpbreaks[length(tmpbreaks)] <- max(abs(x))
+ }
+ else
+ {
+ min.raw <- min(x, na.rm=TRUE) ## Again, modified to use scaled
+ max.raw <- max(x, na.rm=TRUE) ## or unscaled (SD 12/2/03)
+ }
- ## Add the color-key
- if(key)
- {
- par(mar = c(5, 4, 2, 1), cex=0.75)
+ z <- seq(min.raw, max.raw, length=length(col))
+ image(z=matrix(z, ncol=1),
+ col=col, breaks=tmpbreaks,
+ xaxt="n", yaxt="n")
- if(symkey)
- {
- max.raw <- max(abs(x),na.rm=TRUE)
- min.raw <- -max.raw
- }
- else
- {
- min.raw <- min(x, na.rm=TRUE) # Again, modified to use scaled
- max.raw <- max(x, na.rm=TRUE) # or unscaled (SD 12/2/03)
- }
+ par(usr=c(0,1,0,1))
+ lv <- pretty(breaks)
+ xv <- scale01(as.numeric(lv), min.raw, max.raw)
+ axis(1, at=xv, labels=lv)
+ if(scale=="row")
+ mtext(side=1,"Row Z-Score", line=2)
+ else if(scale=="column")
+ mtext(side=1,"Column Z-Score", line=2)
+ else
+ mtext(side=1,"Value", line=2)
- z <- seq(min.raw,max.raw,length=length(col))
- image(z=matrix(z, ncol=1),
- col=col, breaks=breaks,
- xaxt="n", yaxt="n" )
+ if(density.info=="density")
+ {
+ ## Experimental : also plot density of data
+ dens <- density(x, adjust=densadj, na.rm=TRUE)
+ omit <- dens$x < min(breaks) | dens$x > max(breaks)
+ dens$x <- dens$x[-omit]
+ dens$y <- dens$y[-omit]
+ dens$x <- scale01(dens$x,min.raw,max.raw)
+ lines(dens$x, dens$y / max(dens$y) * 0.95, col=denscol, lwd=1)
+ axis(2, at=pretty(dens$y)/max(dens$y) * 0.95, pretty(dens$y) )
+ title("Color Key\nand Density Plot")
+ par(cex=0.5)
+ mtext(side=2,"Density", line=2)
+ }
+ else if(density.info=="histogram")
+ {
+ h <- hist(x, plot=FALSE, breaks=breaks)
+ hx <- scale01(breaks,min.raw,max.raw)
+ hy <- c(h$counts, h$counts[length(h$counts)])
+ lines(hx, hy/max(hy)*0.95, lwd=1, type="s", col=denscol)
+ axis(2, at=pretty(hy)/max(hy) * 0.95, pretty(hy) )
+ title("Color Key\nand Histogram")
+ par(cex=0.5)
+ mtext(side=2,"Count", line=2)
+ }
+ else
+ title("Color Key")
- par(usr=c(0,1,0,1))
- lv <- pretty(breaks)
- xv <- scale01(as.numeric(lv), min.raw, max.raw)
- axis(1, at=xv, labels=lv)
- if(scale=="row")
- mtext(side=1,"Row Z-Score", line=2)
- else if(scale=="column")
- mtext(side=1,"Column Z-Score", line=2)
- else
- mtext(side=1,"Value", line=2)
+ }
+ else
+ plot.new()
- if(density.info=="density")
- {
- # Experimental : also plot density of data
- dens <- density(x, adjust=densadj, na.rm=TRUE)
- omit <- dens$x < min(breaks) | dens$x > max(breaks)
- dens$x <- dens$x[-omit]
- dens$y <- dens$y[-omit]
- dens$x <- scale01(dens$x,min.raw,max.raw)
- lines(dens$x, dens$y / max(dens$y) * 0.95, col=denscol, lwd=1)
- axis(2, at=pretty(dens$y)/max(dens$y) * 0.95, pretty(dens$y) )
- title("Color Key\nand Density Plot")
- par(cex=0.5)
- mtext(side=2,"Density", line=2)
- }
- else if(density.info=="histogram")
- {
- h <- hist(x, plot=FALSE, breaks=breaks)
- hx <- scale01(breaks,min.raw,max.raw)
- hy <- c(h$counts, h$counts[length(h$counts)])
- lines(hx, hy/max(hy)*0.95, lwd=1, type="s", col=denscol)
- axis(2, at=pretty(hy)/max(hy) * 0.95, pretty(hy) )
- title("Color Key\nand Histogram")
- par(cex=0.5)
- mtext(side=2,"Count", line=2)
- }
- else
- title("Color Key")
+ ## Create a table showing how colors match to (transformed) data ranges
+ retval$colorTable <- data.frame(
+ low=retval$breaks[-length(retval$breaks)],
+ high=retval$breaks[-1],
+ color=retval$col
+ )
- }
- else
- plot.new()
-
- invisible(list(rowInd = rowInd, colInd = colInd))
+
+ invisible( retval )
}
M...
[truncated message content] |
|
From: <wa...@us...> - 2009-10-10 16:39:30
|
Revision: 1359
http://r-gregmisc.svn.sourceforge.net/r-gregmisc/?rev=1359&view=rev
Author: warnes
Date: 2009-10-10 16:39:22 +0000 (Sat, 10 Oct 2009)
Log Message:
-----------
Update DESCRIPTION and NEWS file for 2.7.1
Modified Paths:
--------------
trunk/gplots/DESCRIPTION
trunk/gplots/inst/NEWS
Modified: trunk/gplots/DESCRIPTION
===================================================================
--- trunk/gplots/DESCRIPTION 2009-10-10 16:35:34 UTC (rev 1358)
+++ trunk/gplots/DESCRIPTION 2009-10-10 16:39:22 UTC (rev 1359)
@@ -4,7 +4,7 @@
Depends: R (>= 1.9.0), gtools, gdata, stats, caTools, grid
Recommends: datasets, grid
Suggests: gtools
-Version: 2.7.0
+Version: 2.7.1
Author: Gregory R. Warnes. Includes R source code and/or documentation
contributed by (in alphabetical order):
Ben Bolker, Lodewijk Bonebakker, Robert Gentleman, Wolfgang
Modified: trunk/gplots/inst/NEWS
===================================================================
--- trunk/gplots/inst/NEWS 2009-10-10 16:35:34 UTC (rev 1358)
+++ trunk/gplots/inst/NEWS 2009-10-10 16:39:22 UTC (rev 1359)
@@ -1,6 +1,15 @@
Release 2.7.0 - 2009-05-08
--------------------------
+Bug Fixes:
+
+- Correct bug reported by Ken Lo: cox2hex() had blue and green
+ components swapped.
+
+
+Release 2.7.0 - 2009-05-08
+--------------------------
+
New Features:
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <wa...@us...> - 2009-10-10 17:32:33
|
Revision: 1360
http://r-gregmisc.svn.sourceforge.net/r-gregmisc/?rev=1360&view=rev
Author: warnes
Date: 2009-10-10 17:32:26 +0000 (Sat, 10 Oct 2009)
Log Message:
-----------
Various minor changes to remove new R CMD CHECK warnings.
Modified Paths:
--------------
trunk/gplots/R/col2hex.R
trunk/gplots/man/colorpanel.Rd
trunk/gplots/man/lowess.Rd
trunk/gplots/man/ooplot.Rd
trunk/gplots/man/overplot.Rd
trunk/gplots/man/smartlegend.Rd
trunk/gplots/man/space.Rd
trunk/gplots/tests/heatmap2Test.Rout.save
Modified: trunk/gplots/R/col2hex.R
===================================================================
--- trunk/gplots/R/col2hex.R 2009-10-10 16:39:22 UTC (rev 1359)
+++ trunk/gplots/R/col2hex.R 2009-10-10 17:32:26 UTC (rev 1360)
@@ -3,7 +3,7 @@
colMat <- col2rgb(cname)
rgb(
red=colMat[1,]/255,
- green=colMat[2,]/255
- blue=colMat[3,]/255,
+ green=colMat[2,]/255,
+ blue=colMat[3,]/255
)
}
Modified: trunk/gplots/man/colorpanel.Rd
===================================================================
--- trunk/gplots/man/colorpanel.Rd 2009-10-10 16:39:22 UTC (rev 1359)
+++ trunk/gplots/man/colorpanel.Rd 2009-10-10 17:32:26 UTC (rev 1360)
@@ -43,7 +43,7 @@
Vector of HTML-style RGB colors.
}
\author{ Gregory R. Warnes \email{gr...@ra...} }
-\seealso{ \code{\link[base]{colors} } }
+\seealso{ \code{\link{colors} } }
\examples{
showpanel <- function(col)
Modified: trunk/gplots/man/lowess.Rd
===================================================================
--- trunk/gplots/man/lowess.Rd 2009-10-10 16:39:22 UTC (rev 1359)
+++ trunk/gplots/man/lowess.Rd 2009-10-10 17:32:26 UTC (rev 1360)
@@ -70,7 +70,7 @@
LOWESS: A program for smoothing scatterplots by robust locally weighted
regression. \emph{The American Statistician}, \bold{35}, 54.
}
-\seealso{\code{\link[modreg]{loess}} (in package \code{modreg}), a newer
+\seealso{\code{\link{loess}} (in package \code{modreg}), a newer
formula based version of \code{lowess} (with different defaults!).
}
\examples{
Modified: trunk/gplots/man/ooplot.Rd
===================================================================
--- trunk/gplots/man/ooplot.Rd 2009-10-10 16:39:22 UTC (rev 1359)
+++ trunk/gplots/man/ooplot.Rd 2009-10-10 17:32:26 UTC (rev 1360)
@@ -160,7 +160,7 @@
by Gregory R. Warnes \email{gr...@ra...}.
Based on barplot2().
}
-\seealso{ \code{\link[plot]{plot}}, \code{\link[plot]{boxplot}} }
+\seealso{ \code{\link{plot}}, \code{\link{boxplot}} }
\examples{
data(VADeaths, package = "datasets")
Modified: trunk/gplots/man/overplot.Rd
===================================================================
--- trunk/gplots/man/overplot.Rd 2009-10-10 16:39:22 UTC (rev 1359)
+++ trunk/gplots/man/overplot.Rd 2009-10-10 17:32:26 UTC (rev 1360)
@@ -20,7 +20,7 @@
\item{same.scale}{ Logical value indicating whether the plot region
should have the same range for all plots. Defaults to \code{FALSE}.}
\item{xlab, ylab, xlim, ylim, main}{ Standard plotting parameters. See
- \code{\link[base]{plot}} for details}
+ \code{\link{plot}} for details}
\item{min.y, max.y}{Scalar or vector values used to specify the y
plotting limits for individual plots. If a single scalar value is
provided, it will be used for all plots. These parameters can be
@@ -57,8 +57,8 @@
}
\author{ Gregory R. Warnes \email{gr...@ra...} }
\seealso{
- \code{\link[base]{interaction.plot}},
- \code{\link[base]{coplot}} for alternative visualizations of 3-way data.}
+ \code{\link{interaction.plot}},
+ \code{\link{coplot}} for alternative visualizations of 3-way data.}
\examples{
# Example teratogenicity rtPCR data
Modified: trunk/gplots/man/smartlegend.Rd
===================================================================
--- trunk/gplots/man/smartlegend.Rd 2009-10-10 16:39:22 UTC (rev 1359)
+++ trunk/gplots/man/smartlegend.Rd 2009-10-10 17:32:26 UTC (rev 1360)
@@ -24,7 +24,7 @@
Same as \code{legend}
}
\author{Gregory R. Warnes \email{gr...@ra...} }
-\seealso{ \code{\link[base]{legend}} }
+\seealso{ \code{\link{legend}} }
\examples{
x <- rnorm(100)
Modified: trunk/gplots/man/space.Rd
===================================================================
--- trunk/gplots/man/space.Rd 2009-10-10 16:39:22 UTC (rev 1359)
+++ trunk/gplots/man/space.Rd 2009-10-10 17:32:26 UTC (rev 1360)
@@ -64,7 +64,7 @@
\item{y}{y location of each input point}
}
\author{ Gregory R. Warnes \email{gr...@ra...} }
-\seealso{ \code{\link{jitter}}, \code{\link[base]{sunflowerplot}} }
+\seealso{ \code{\link{jitter}}, \code{\link{sunflowerplot}} }
\examples{
x <- rep(1:5, 10)
Modified: trunk/gplots/tests/heatmap2Test.Rout.save
===================================================================
--- trunk/gplots/tests/heatmap2Test.Rout.save 2009-10-10 16:39:22 UTC (rev 1359)
+++ trunk/gplots/tests/heatmap2Test.Rout.save 2009-10-10 17:32:26 UTC (rev 1360)
@@ -1,5 +1,5 @@
-R version 2.9.0 (2009-04-17)
+R version 2.10.0 alpha (2009-10-08 r49995)
Copyright (C) 2009 The R Foundation for Statistical Computing
ISBN 3-900051-07-0
@@ -18,6 +18,14 @@
> library(gplots)
Loading required package: gtools
Loading required package: gdata
+
+Attaching package: 'gdata'
+
+
+ The following object(s) are masked from package:utils :
+
+ object.size
+
Loading required package: caTools
Loading required package: bitops
Loading required package: grid
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <wa...@us...> - 2009-10-12 13:26:42
|
Revision: 1361
http://r-gregmisc.svn.sourceforge.net/r-gregmisc/?rev=1361&view=rev
Author: warnes
Date: 2009-10-12 13:26:35 +0000 (Mon, 12 Oct 2009)
Log Message:
-----------
Update version number to 2.7.2, 2.7.1 was already up but apparently DESCRIPTION wasn't commited with change.
Modified Paths:
--------------
trunk/gplots/DESCRIPTION
trunk/gplots/inst/NEWS
Modified: trunk/gplots/DESCRIPTION
===================================================================
--- trunk/gplots/DESCRIPTION 2009-10-10 17:32:26 UTC (rev 1360)
+++ trunk/gplots/DESCRIPTION 2009-10-12 13:26:35 UTC (rev 1361)
@@ -4,7 +4,7 @@
Depends: R (>= 1.9.0), gtools, gdata, stats, caTools, grid
Recommends: datasets, grid
Suggests: gtools
-Version: 2.7.1
+Version: 2.7.2
Author: Gregory R. Warnes. Includes R source code and/or documentation
contributed by (in alphabetical order):
Ben Bolker, Lodewijk Bonebakker, Robert Gentleman, Wolfgang
Modified: trunk/gplots/inst/NEWS
===================================================================
--- trunk/gplots/inst/NEWS 2009-10-10 17:32:26 UTC (rev 1360)
+++ trunk/gplots/inst/NEWS 2009-10-12 13:26:35 UTC (rev 1361)
@@ -1,4 +1,4 @@
-Release 2.7.0 - 2009-05-08
+Release 2.7.2 - 2009-05-08
--------------------------
Bug Fixes:
@@ -7,7 +7,7 @@
components swapped.
-Release 2.7.0 - 2009-05-08
+Release 2.7.1 - 2009-05-08
--------------------------
New Features:
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <wa...@us...> - 2009-10-22 20:38:13
|
Revision: 1363
http://r-gregmisc.svn.sourceforge.net/r-gregmisc/?rev=1363&view=rev
Author: warnes
Date: 2009-10-22 20:37:49 +0000 (Thu, 22 Oct 2009)
Log Message:
-----------
Update NEWS and DESCRIPTION for gplots 2.7.3
Modified Paths:
--------------
trunk/gplots/DESCRIPTION
trunk/gplots/inst/NEWS
Modified: trunk/gplots/DESCRIPTION
===================================================================
--- trunk/gplots/DESCRIPTION 2009-10-22 20:31:50 UTC (rev 1362)
+++ trunk/gplots/DESCRIPTION 2009-10-22 20:37:49 UTC (rev 1363)
@@ -1,10 +1,10 @@
Package: gplots
Title: Various R programming tools for plotting data
Description: Various R programming tools for plotting data
-Depends: R (>= 1.9.0), gtools, gdata, stats, caTools, grid
+Depends: gtools, gdata, stats, caTools, grid
Recommends: datasets, grid
Suggests: gtools
-Version: 2.7.2
+Version: 2.7.3
Author: Gregory R. Warnes. Includes R source code and/or documentation
contributed by (in alphabetical order):
Ben Bolker, Lodewijk Bonebakker, Robert Gentleman, Wolfgang
Modified: trunk/gplots/inst/NEWS
===================================================================
--- trunk/gplots/inst/NEWS 2009-10-22 20:31:50 UTC (rev 1362)
+++ trunk/gplots/inst/NEWS 2009-10-22 20:37:49 UTC (rev 1363)
@@ -1,3 +1,12 @@
+Release 2.7.3 - 2009-10-22
+--------------------------
+
+Bug Fixes:
+
+- Correct bug reported by Rudolf Talens: heatmap.2() incorrectly
+ transposed the displayed matrix when the option symm=TRUE.
+
+
Release 2.7.2 - 2009-05-08
--------------------------
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <wa...@us...> - 2009-11-12 15:39:01
|
Revision: 1365
http://r-gregmisc.svn.sourceforge.net/r-gregmisc/?rev=1365&view=rev
Author: warnes
Date: 2009-11-12 15:38:53 +0000 (Thu, 12 Nov 2009)
Log Message:
-----------
Correct bug reported by Alan Yong: plotmeans() crashed when 'bars=FALSE'.
Modified Paths:
--------------
trunk/gplots/DESCRIPTION
trunk/gplots/R/plotmeans.R
trunk/gplots/inst/NEWS
Added Paths:
-----------
trunk/gplots/tests/plotmeans_nobars.R
Modified: trunk/gplots/DESCRIPTION
===================================================================
--- trunk/gplots/DESCRIPTION 2009-10-22 20:53:11 UTC (rev 1364)
+++ trunk/gplots/DESCRIPTION 2009-11-12 15:38:53 UTC (rev 1365)
@@ -4,7 +4,7 @@
Depends: gtools, gdata, stats, caTools, grid
Recommends: datasets, grid
Suggests: gtools
-Version: 2.7.3
+Version: 2.7.4
Author: Gregory R. Warnes. Includes R source code and/or documentation
contributed by (in alphabetical order):
Ben Bolker, Lodewijk Bonebakker, Robert Gentleman, Wolfgang
Modified: trunk/gplots/R/plotmeans.R
===================================================================
--- trunk/gplots/R/plotmeans.R 2009-10-22 20:53:11 UTC (rev 1364)
+++ trunk/gplots/R/plotmeans.R 2009-11-12 15:38:53 UTC (rev 1365)
@@ -59,8 +59,12 @@
mf[,i] <- factor(mf[,i])
means <- sapply(split(mf[[response]], mf[[-response]]), mean, na.rm=TRUE)
+ ns <- sapply(sapply(split(mf[[response]], mf[[-response]]), na.omit,
+ simplify=FALSE), length )
xlim <- c(0.5, length(means)+0.5)
+
+
if(!bars)
{
plot( means, ..., col=col, xlim=xlim)
@@ -69,12 +73,9 @@
{
myvar <- function(x) var(x[!is.na(x)])
-
vars <- sapply(split(mf[[response]], mf[[-response]]), myvar)
- ns <- sapply( sapply(split(mf[[response]], mf[[-response]]), na.omit,
- simplify=FALSE), length )
- # apply minimum variance specified by minsd^2
+ ## apply minimum variance specified by minsd^2
vars <- ifelse( vars < (minsd^2), (minsd^2), vars)
if(use.t)
Modified: trunk/gplots/inst/NEWS
===================================================================
--- trunk/gplots/inst/NEWS 2009-10-22 20:53:11 UTC (rev 1364)
+++ trunk/gplots/inst/NEWS 2009-11-12 15:38:53 UTC (rev 1365)
@@ -1,3 +1,10 @@
+Release 2.7.4 - 2009-11-12
+--------------------------
+
+Bug Fixes:
+
+- Correct bug reported by Alan Yong: plotmeans() failed when bars=FALSE.
+
Release 2.7.3 - 2009-10-22
--------------------------
Added: trunk/gplots/tests/plotmeans_nobars.R
===================================================================
--- trunk/gplots/tests/plotmeans_nobars.R (rev 0)
+++ trunk/gplots/tests/plotmeans_nobars.R 2009-11-12 15:38:53 UTC (rev 1365)
@@ -0,0 +1,7 @@
+## Test that plotmeans works properly when bars=F
+## Bug repoted by Alan Yong, Research Geophysicist,
+## US DEPARTMENT OF THE INTERIOR
+
+library(gplots)
+data(state)
+plotmeans(state.area ~ state.region, bars=FALSE)
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <ar...@us...> - 2010-01-22 13:56:10
|
Revision: 1372
http://r-gregmisc.svn.sourceforge.net/r-gregmisc/?rev=1372&view=rev
Author: arnima
Date: 2010-01-22 13:55:22 +0000 (Fri, 22 Jan 2010)
Log Message:
-----------
Renamed files rich.color.* to rich.colors.* and renamed rich.colors args
Added Paths:
-----------
trunk/gplots/R/rich.colors.R
trunk/gplots/man/rich.colors.Rd
Removed Paths:
-------------
trunk/gplots/R/rich.color.R
trunk/gplots/man/rich.color.Rd
Deleted: trunk/gplots/R/rich.color.R
===================================================================
--- trunk/gplots/R/rich.color.R 2010-01-22 13:06:33 UTC (rev 1371)
+++ trunk/gplots/R/rich.color.R 2010-01-22 13:55:22 UTC (rev 1372)
@@ -1,50 +0,0 @@
-rich.colors <- function(n, palette="temperature", rgb.matrix=FALSE,
- plot.colors=FALSE)
-{
- if(n <= 0)
- return(character(0))
-
- palette <- match.arg(palette, c("temperature","blues"))
- x <- seq(0, 1, length=n)
-
- if(palette == "temperature")
- {
- r <- 1 / (1+exp(20-35*x))
- g <- pmin(pmax(0,-0.8+6*x-5*x^2), 1)
- b <- dnorm(x,0.25,0.15) / max(dnorm(x,0.25,0.15))
- }
- else
- {
- r <- 0.6*x + 0.4*x^2
- g <- 1.5*x - 0.5*x^2
- b <- 0.36 + 2.4*x - 2.0*x^2
- b[x>0.4] <- 1
- }
-
- rgb.m <- matrix(c(r,g,b), ncol=3,
- dimnames=list(as.character(seq(length=n)),
- c("red","green","blue")))
- rich.vector <- apply(rgb.m, 1, function(v) rgb(v[1],v[2],v[3]))
-
- if(rgb.matrix)
- attr(rich.vector, "rgb.matrix") <- rgb.m
-
- if(plot.colors)
- {
- opar <- par("fig", "plt")
- par(fig=c(0,1,0,0.7), plt=c(0.15,0.9,0.2,0.95))
- plot(NA, xlim=c(-0.01,1.01), ylim=c(-0.01,1.01), xlab="Spectrum", ylab="",
- xaxs="i", yaxs="i", axes=FALSE)
- title(ylab="Value", mgp=c(3.5,0,0))
- matlines(x, rgb.m, col=colnames(rgb.m), lty=1, lwd=3)
- matpoints(x, rgb.m, col=colnames(rgb.m), pch=16)
- axis(1, at=0:1)
- axis(2, at=0:1, las=1)
- par(fig=c(0,1,0.75,0.9), plt=c(0.08,0.97,0,1), new=TRUE)
- midpoints <- barplot(rep(1,n), col=rich.vector, border=FALSE, space=FALSE,
- axes=FALSE)
- axis(1, at=midpoints, labels=1:n, lty=0, cex.axis=0.6)
- par(opar)
- }
- return(rich.vector)
-}
Copied: trunk/gplots/R/rich.colors.R (from rev 1371, trunk/gplots/R/rich.color.R)
===================================================================
--- trunk/gplots/R/rich.colors.R (rev 0)
+++ trunk/gplots/R/rich.colors.R 2010-01-22 13:55:22 UTC (rev 1372)
@@ -0,0 +1,49 @@
+rich.colors <- function(n, palette="temperature", rgb=FALSE, plot=FALSE)
+{
+ if(n <= 0)
+ return(character(0))
+
+ palette <- match.arg(palette, c("temperature","blues"))
+ x <- seq(0, 1, length=n)
+
+ if(palette == "temperature")
+ {
+ r <- 1 / (1+exp(20-35*x))
+ g <- pmin(pmax(0,-0.8+6*x-5*x^2), 1)
+ b <- dnorm(x,0.25,0.15) / max(dnorm(x,0.25,0.15))
+ }
+ else
+ {
+ r <- 0.6*x + 0.4*x^2
+ g <- 1.5*x - 0.5*x^2
+ b <- 0.36 + 2.4*x - 2.0*x^2
+ b[x>0.4] <- 1
+ }
+
+ rgb.m <- matrix(c(r,g,b), ncol=3,
+ dimnames=list(as.character(seq(length=n)),
+ c("red","green","blue")))
+ rich.vector <- apply(rgb.m, 1, function(v) rgb(v[1],v[2],v[3]))
+
+ if(rgb)
+ attr(rich.vector, "rgb") <- rgb.m
+
+ if(plot)
+ {
+ opar <- par("fig", "plt")
+ par(fig=c(0,1,0,0.7), plt=c(0.15,0.9,0.2,0.95))
+ plot(NA, xlim=c(-0.01,1.01), ylim=c(-0.01,1.01), xlab="Spectrum", ylab="",
+ xaxs="i", yaxs="i", axes=FALSE)
+ title(ylab="Value", mgp=c(3.5,0,0))
+ matlines(x, rgb.m, col=colnames(rgb.m), lty=1, lwd=3)
+ matpoints(x, rgb.m, col=colnames(rgb.m), pch=16)
+ axis(1, at=0:1)
+ axis(2, at=0:1, las=1)
+ par(fig=c(0,1,0.75,0.9), plt=c(0.08,0.97,0,1), new=TRUE)
+ midpoints <- barplot(rep(1,n), col=rich.vector, border=FALSE, space=FALSE,
+ axes=FALSE)
+ axis(1, at=midpoints, labels=1:n, lty=0, cex.axis=0.6)
+ par(opar)
+ }
+ return(rich.vector)
+}
Deleted: trunk/gplots/man/rich.color.Rd
===================================================================
--- trunk/gplots/man/rich.color.Rd 2010-01-22 13:06:33 UTC (rev 1371)
+++ trunk/gplots/man/rich.color.Rd 2010-01-22 13:55:22 UTC (rev 1372)
@@ -1,53 +0,0 @@
-\name{rich.colors}
-\alias{rich.colors}
-\title{
- Rich color palettes
-}
-\description{
- Create a vector of \code{n} colors that are perceptually equidistant
- and in an order that is easy to interpret.
-}
-\usage{
-rich.colors(n, palette="temperature", rgb.matrix=FALSE,
- plot.colors=FALSE)
-}
-\arguments{
- \item{n}{number of colors to generate.}
- \item{palette}{palette to use: \code{"temperature"} contains
- blue-green-yellow-red, and \code{"blues"} contains
- black-blue-white.}
- \item{rgb.matrix}{if \code{TRUE} then a matrix of RGB values is
- included as an attribute.}
- \item{plot.colors}{if \code{TRUE} then a descriptive color diagram is
- plotted on the current device.}
-}
-\value{
- A character vector of color codes.
-}
-\author{Arni Magnusson \email{arnima@u.washington.edu}}
-\seealso{
- \code{\link{rgb}},
- \code{\link{rainbow}},
- \code{\link{heat.colors}}.
-}
-\examples{
-m <- matrix(1:120+rnorm(120), nrow=15, ncol=8)
-opar <- par(bg="gray", mfrow=c(1,2))
-matplot(m, type="l", lty=1, lwd=3, col=rich.colors(8))
-matplot(m, type="l", lty=1, lwd=3, col=rich.colors(8,"blues"))
-par(opar)
-
-barplot(rep(1,100), col=rich.colors(100), space=0, border=0, axes=FALSE)
-barplot(rep(1,20), col=rich.colors(40)[11:30]) # choose subset
-
-rich.colors(100, plot=TRUE, rgb=TRUE) # describe rgb recipe
-
-par(mfrow=c(2,2))
-barplot(m, col=heat.colors(15), main="\nheat.colors")
-barplot(m, col=1:15, main="\ndefault palette")
-barplot(m, col=rich.colors(15), main="\nrich.colors")
-barplot(m, col=rainbow(15), main="\nrainbow")
-par(opar)
-}
-% Graphics
-\keyword{color}
Copied: trunk/gplots/man/rich.colors.Rd (from rev 1371, trunk/gplots/man/rich.color.Rd)
===================================================================
--- trunk/gplots/man/rich.colors.Rd (rev 0)
+++ trunk/gplots/man/rich.colors.Rd 2010-01-22 13:55:22 UTC (rev 1372)
@@ -0,0 +1,46 @@
+\name{rich.colors}
+\alias{rich.colors}
+\title{Rich Color Palettes}
+\description{
+ Create a vector of \code{n} colors that are perceptually equidistant
+ and in an order that is easy to interpret.
+}
+\usage{
+rich.colors(n, palette="temperature", rgb=FALSE, plot=FALSE)
+}
+\arguments{
+ \item{n}{number of colors to generate.}
+ \item{palette}{palette to use: \code{"temperature"} contains
+ blue-green-yellow-red, and \code{"blues"} contains
+ black-blue-white.}
+ \item{rgb}{if \code{TRUE} then a matrix of RGB values is included as
+ an attribute.}
+ \item{plot}{if \code{TRUE} then a descriptive color diagram is plotted
+ on the current device.}
+}
+\value{A character vector of color codes.}
+\author{Arni Magnusson}
+\seealso{
+ \code{\link{rgb}}, \code{\link{rainbow}}, \code{\link{heat.colors}}.
+}
+\examples{
+m <- matrix(1:120+rnorm(120), nrow=15, ncol=8)
+opar <- par(bg="gray", mfrow=c(1,2))
+matplot(m, type="l", lty=1, lwd=3, col=rich.colors(8))
+matplot(m, type="l", lty=1, lwd=3, col=rich.colors(8,"blues"))
+par(opar)
+
+barplot(rep(1,100), col=rich.colors(100), space=0, border=0, axes=FALSE)
+barplot(rep(1,20), col=rich.colors(40)[11:30]) # choose subset
+
+rich.colors(100, plot=TRUE, rgb=TRUE) # describe rgb recipe
+
+par(mfrow=c(2,2))
+barplot(m, col=heat.colors(15), main="\nheat.colors")
+barplot(m, col=1:15, main="\ndefault palette")
+barplot(m, col=rich.colors(15), main="\nrich.colors")
+barplot(m, col=rainbow(15), main="\nrainbow")
+par(opar)
+}
+% Graphics
+\keyword{color}
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <wa...@us...> - 2010-02-17 14:53:26
|
Revision: 1420
http://r-gregmisc.svn.sourceforge.net/r-gregmisc/?rev=1420&view=rev
Author: warnes
Date: 2010-02-17 14:53:16 +0000 (Wed, 17 Feb 2010)
Log Message:
-----------
Improve performance of hist2d thanks to suggestion by Joerg van den Hoff.
Modified Paths:
--------------
trunk/gplots/DESCRIPTION
trunk/gplots/R/hist2d.R
trunk/gplots/inst/NEWS
Modified: trunk/gplots/DESCRIPTION
===================================================================
--- trunk/gplots/DESCRIPTION 2010-01-28 19:58:26 UTC (rev 1419)
+++ trunk/gplots/DESCRIPTION 2010-02-17 14:53:16 UTC (rev 1420)
@@ -4,7 +4,7 @@
Depends: gtools, gdata, stats, caTools, grid
Recommends: datasets, grid
Suggests: gtools
-Version: 2.7.4
+Version: 2.7.5
Author: Gregory R. Warnes. Includes R source code and/or documentation
contributed by (in alphabetical order):
Ben Bolker, Lodewijk Bonebakker, Robert Gentleman, Wolfgang
Modified: trunk/gplots/R/hist2d.R
===================================================================
--- trunk/gplots/R/hist2d.R 2010-01-28 19:58:26 UTC (rev 1419)
+++ trunk/gplots/R/hist2d.R 2010-02-17 14:53:16 UTC (rev 1420)
@@ -25,13 +25,13 @@
if(same.scale)
{
- x.cuts <- seq( from=min(x,y), to=max(x,y), length=nbins[1]+1)
- y.cuts <- seq( from=min(x,y), to=max(x,y), length=nbins[2]+1)
+ x.cuts <- seq( from=min(x,y), to=max(x,y), length=nbins[1]+1, labels=FALSE)
+ y.cuts <- seq( from=min(x,y), to=max(x,y), length=nbins[2]+1, labels=FALSE)
}
else
{
- x.cuts <- seq( from=min(x), to=max(x), length=nbins[1]+1)
- y.cuts <- seq( from=min(y), to=max(y), length=nbins[2]+1)
+ x.cuts <- seq( from=min(x), to=max(x), length=nbins[1]+1, labels=FALSE)
+ y.cuts <- seq( from=min(y), to=max(y), length=nbins[2]+1, labels=FALSE)
}
Modified: trunk/gplots/inst/NEWS
===================================================================
--- trunk/gplots/inst/NEWS 2010-01-28 19:58:26 UTC (rev 1419)
+++ trunk/gplots/inst/NEWS 2010-02-17 14:53:16 UTC (rev 1420)
@@ -1,3 +1,11 @@
+Release 2.7.5 - ??
+--------------------------
+
+Improvements:
+
+- Performance of 'hist2d' improved thanks to a suggestion from i
+ Joerg van den Hoff.
+
Release 2.7.4 - 2009-11-12
--------------------------
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <wa...@us...> - 2010-06-11 03:11:22
|
Revision: 1440
http://r-gregmisc.svn.sourceforge.net/r-gregmisc/?rev=1440&view=rev
Author: warnes
Date: 2010-06-11 03:11:16 +0000 (Fri, 11 Jun 2010)
Log Message:
-----------
- venn() now returns an object of class venn() and a plot method for
this class is provided.
- Manual page for venn has been improved, based on contributions by
Steffen Moeller
Modified Paths:
--------------
trunk/gplots/R/venn.R
trunk/gplots/man/venn.Rd
Added Paths:
-----------
trunk/gplots/R/plot.venn.R
Copied: trunk/gplots/R/plot.venn.R (from rev 1431, trunk/gplots/R/venn.R)
===================================================================
--- trunk/gplots/R/plot.venn.R (rev 0)
+++ trunk/gplots/R/plot.venn.R 2010-06-11 03:11:16 UTC (rev 1440)
@@ -0,0 +1,284 @@
+
+plot.venn <- function(x, y, ...,
+ small=0.7,
+ showSetLogicLabel=FALSE,
+ simplify=FALSE
+ )
+ {
+ drawVennDiagram(
+ data=x,
+ small=small,
+ showSetLogicLabel=showSetLogicLabel,
+ simplify=simplify
+ )
+ }
+
+## data should be a matrix.
+## - The first column of the matrix is the
+## count of the number of objects with the specified pattern.
+## - The second and subsequent columns contain 0-1 indicators
+## giving the pattern of group membership
+
+
+drawVennDiagram <-function(data,small=0.7,
+ showSetLogicLabel=FALSE,simplify=FALSE) {
+ numCircles<-NA
+ data.colnames<-NULL
+ data.rownames<-NULL
+ if(is.matrix(data)) {
+ numCircles<-ncol(data)-1
+ data.colnames<-colnames(data)[2:(ncol(data))]
+ # Order is reverted since later indexing starts with
+ # the "lowest bit" and that is expected at the left
+ data.rownames<-rownames(data)
+ }
+ else {
+ cat("Testing only, presuming first argument to specify",
+ "the number of circles to draw.\n")
+ numCircles<-data
+ }
+
+ m<-(0:(-1+2^numCircles))
+
+ if (! is.matrix(data)) {
+ ##cat("prepare randomised data\n")
+ data<-t(sapply(X=m,FUN=function(v){
+ l<-baseOf(v,2,numCircles)
+ #print(l)
+ return(l)
+ }))
+
+ #print(data)
+
+ #data.names<-apply(data,1,function(X){
+ # return(paste(X),collapse="")
+ #})
+ for(i in m) {
+ n<-paste(data[i+1,],collapse="")
+ if (is.null(data.rownames)) {
+ data.rownames<-n
+ }
+ else {
+ data.rownames<-c(data.rownames,n)
+ }
+ }
+ #print(data.rownames)
+ data<-cbind(sample(1:100,size=2^numCircles,replace=TRUE),data)
+ #print(data)
+ rownames(data)<-data.rownames
+ data.colnames<-LETTERS[1:numCircles]
+ colnames(data)<-c("num",data.colnames)
+ }
+
+ if ((2 <= numCircles && numCircles <= 3) || (4 == numCircles && simplify)) {
+ ##cat("drawing circles\n")
+ # draw circles with radius 1.7 equally distributed
+ # with centers on a circle of radius 1
+
+ degrees<-2*pi/numCircles*(1:numCircles)
+
+ # scaling factor
+ s<-1/8
+
+ x<-sapply(degrees,FUN=sin)*s + 0.5
+ y<-sapply(degrees,FUN=cos)*s + 0.5
+
+
+ if(!require(grid)) {
+ stop("Need access to 'grid' library.")
+ }
+ grid.newpage()
+ grid.circle(x,y,3/12,name="some name")
+
+ ##cat("filling data\n")
+
+ distFromZero<-rep(NA,2^numCircles)
+ degrees<-rep(NA,2^numCircles)
+
+ degrees[(2^numCircles)]<-0
+ distFromZero[(2^numCircles)]<-0
+
+ for (i in 0:(numCircles-1)) {
+ distFromZero[2^i+1] <- 4/12
+ degrees[2^i+1] <- 2*pi/numCircles*i
+ d<-degrees[2^i+1]
+
+ #print(data.colnames)
+
+ grid.text(
+ # starting from the lowest bit, hence reading
+ # lables from the right
+ label=data.colnames[numCircles - i],
+ x=sin(d)*5/12+0.5,
+ y=cos(d)*5/12+0.5,
+ rot=0
+ )
+
+ }
+
+ if (4==numCircles) {
+ for (i in 0:(numCircles-1)) {
+ # Current set bit plus the bit left of it and the bit right of it
+ distFromZero[2^i
+ +2^((i+numCircles-1)%%numCircles)
+ +2^((i+1)%%numCircles)+1] <- 2/12
+ degrees[2^i
+ +2^((i+numCircles-1)%%numCircles)
+ +2^((i+1)%%numCircles)+1] <- degrees[2^i+1]
+ }
+ }
+
+ #degrees[2^i+1] + degrees[2^((i+1)%%numCircles)+1])/2
+
+ if (3 <=numCircles) {
+ for (i in 0:(numCircles-1)) {
+ distFromZero[(2^i+2^((i+1)%%numCircles))+1]<- 3/12
+ if (i == (numCircles-1)) {
+ degrees[(2^i+2^((i+1)%%numCircles))+1] <- (
+ degrees[2^i+1] + 2*pi+ degrees[1+1])/2
+ }
+ else {
+ degrees[(2^i+2^((i+1)%%numCircles))+1] <- (
+ degrees[2^i+1] + degrees[2^((i+1)%%numCircles)+1])/2
+ }
+
+ }
+ }
+
+ for(i in 1:2^numCircles) {
+ n<-paste(baseOf((i-1),2,numCircles),collapse="")
+ v<-data[n,1]
+ d<-degrees[i]
+ if (1 == length(d) && is.na(d)) {
+ if (v>0) warning("Not shown: ",n,"is",v,"\n")
+ }
+ else {
+ l<-distFromZero[i]
+ x<-sin(d)*l+0.5
+ y<-cos(d)*l+0.5
+ #cat("i=",i," x=",x," y=",y," label=",n,"\n")
+ l<-v
+ if (showSetLogicLabel) l<-paste(n,"\n",v,sep="")
+ grid.text(label=l,x=x,y=y,rot=0)
+ }
+ }
+ }
+ else if (4 <= numCircles && numCircles <= 5 && !simplify) {
+
+ grid.newpage()
+ # Function to turn and move ellipses
+ relocate_elp <- function(e, alpha, x, y){
+ phi=(alpha/180)*pi;
+ xr=e[,1]*cos(phi)+e[,2]*sin(phi)
+ yr=-e[,1]*sin(phi)+e[,2]*cos(phi)
+ xr=x+xr;
+ yr=y+yr;
+ return(cbind(xr, yr))
+ }
+
+ lab<-function (identifier, data, showLabel=showSetLogicLabel) {
+ r<-data[identifier,1]
+ if (showLabel) {
+ return(paste(identifier,r,sep="\n"))
+ }
+ else {
+ return(r)
+ }
+ }
+
+ plot(c(0, 400), c(0, 400), type="n", axes=F, ylab="", xlab="")
+ if (4 == numCircles) {
+ elps=cbind(162*cos(seq(0,2*pi,len=1000)), 108*sin(seq(0,2*pi,len=1000)));
+
+ plot(c(0, 400), c(0, 400), type="n", axes=F, ylab="", xlab="");
+ polygon(relocate_elp(elps, 45,130, 170));
+ polygon(relocate_elp(elps, 45,200, 200));
+ polygon(relocate_elp(elps, 135,200, 200));
+ polygon(relocate_elp(elps, 135,270, 170));
+
+ text( 35, 315, data.colnames[1],cex=1.5)
+ text(138, 347, data.colnames[2],cex=1.5)
+ text(262, 347, data.colnames[3],cex=1.5)
+ text(365, 315, data.colnames[4],cex=1.5)
+
+ elps <- cbind(130*cos(seq(0,2*pi,len=1000)),
+ 80*sin(seq(0,2*pi,len=1000)))
+
+ text( 35, 250, lab("1000",data));
+ text(140, 315, lab("0100",data));
+ text(260, 315, lab("0010",data));
+ text(365, 250, lab("0001",data));
+
+ text( 90, 280, lab("1100",data), cex=small)
+ text( 95, 110, lab("1010",data) )
+ text(200, 50, lab("1001",data), cex=small)
+ text(200, 290, lab("0110",data))
+ text(300, 110, lab("0101",data))
+ text(310, 280, lab("0011",data), cex=small)
+
+ text(130, 230, lab("1110",data))
+ text(245, 75, lab("1101",data),cex=small)
+ text(155, 75, lab("1011",data),cex=small)
+ text(270, 230, lab("0111",data))
+
+ text(200,150,lab("1111",data))
+ }
+ else if (5 == numCircles) {
+
+ elps <- cbind(150*cos(seq(0,2*pi,len=1000)),
+ 60*sin(seq(0,2*pi,len=1000)))
+
+ polygon(relocate_elp(elps, 90,200, 250))
+ polygon(relocate_elp(elps, 162,250, 220))
+ polygon(relocate_elp(elps, 234,250, 150))
+ polygon(relocate_elp(elps, 306,180, 125))
+ polygon(relocate_elp(elps, 378,145, 200))
+
+ text( 50, 280, data.colnames[1],cex=1.5)
+ text(150, 400, data.colnames[2],cex=1.5)
+ text(350, 300, data.colnames[3],cex=1.5)
+ text(350, 20, data.colnames[4],cex=1.5)
+ text( 50, 10, data.colnames[5],cex=1.5)
+
+ text( 61, 228, lab("10000",data));
+ text(194, 329, lab("01000",data));
+ text(321, 245, lab("00100",data));
+ text(290, 81, lab("00010",data));
+ text(132, 69, lab("00001",data));
+
+ text(146, 250, lab("11000",data), cex=small)
+ text(123, 188, lab("10100",data), cex=small)
+ text(275, 152, lab("10010",data), cex=small)
+ text(137, 146, lab("10001",data), cex=small)
+ text(243, 268, lab("01100",data), cex=small)
+ text(175, 267, lab("01010",data), cex=small)
+ text(187, 117, lab("01001",data), cex=small)
+ text(286, 188, lab("00110",data), cex=small)
+ text(267, 235, lab("00101",data), cex=small)
+ text(228, 105, lab("00011",data), cex=small)
+
+ text(148, 210, lab("11100",data),cex=small)
+ text(159, 253, lab("11010",data),cex=small)
+ text(171, 141, lab("11001",data),cex=small)
+ text(281, 175, lab("10110",data),cex=small)
+ text(143, 163, lab("10101",data),cex=small)
+ text(252, 145, lab("10011",data),cex=small)
+ text(205, 255, lab("01110",data),cex=small)
+ text(254, 243, lab("01101",data),cex=small)
+ text(211, 118, lab("01011",data),cex=small)
+ text(267, 211, lab("00111",data),cex=small)
+
+ text(170, 231,lab("11110",data),cex=small)
+ text(158, 169,lab("11101",data),cex=small)
+ text(212, 139,lab("11011",data),cex=small)
+ text(263, 180,lab("10111",data),cex=small)
+ text(239, 232,lab("01111",data),cex=small)
+
+ text(204,190,lab("11111",data))
+ }
+ }
+ else {
+ stop(paste("The printing of ",numCircles," circles is not yet supported."))
+ }
+
+}
Modified: trunk/gplots/R/venn.R
===================================================================
--- trunk/gplots/R/venn.R 2010-05-03 16:26:14 UTC (rev 1439)
+++ trunk/gplots/R/venn.R 2010-06-11 03:11:16 UTC (rev 1440)
@@ -9,30 +9,6 @@
# The sum of values placed is the number of entries of
# each set.
-# transform base
-# v = value of base 10 to be transformed
-# b = new base
-# l = minimal length of returned array (default is 1)
-# return value: array of factors, highest exponent first
-baseOf<-function(v,b,l=1) {
- remainder<-v
- i<-l
- ret<-NULL
- while(remainder>0 || i>0) {
- #print(paste("i=",i," remainder=",remainder))
- m<-remainder%%b
- if (is.null(ret)) {
- ret<-m
- }
- else {
- ret<-c(m,ret)
- }
- remainder <- remainder %/% b
- i<-i-1
- }
- return(ret)
-}
-
# Function to determine values of a venn diagram
# It works for an arbitrary large set of input sets.
#
@@ -82,7 +58,7 @@
else {
sel<-NULL
}
- }
+ }
}
# something should be in sel now, otherwise
@@ -139,284 +115,13 @@
else{
colnames(result.table)<-c("num",names(l))
}
+ class(result.table) <- "venn"
return(result.table)
}
#print(getVennCounts(list(A,B,C,D)))
#print(getVennCounts(list(a=A,b=B,c=C,d=D)))
-
-## data should be a matrix.
-## - The first column of the matrix is the
-## count of the number of objects with the specified pattern.
-## - The second and subsequent columns contain 0-1 indicators
-## giving the pattern of group membership
-
-
-drawVennDiagram <-function(data,small=0.7,
- showSetLogicLabel=FALSE,simplify=FALSE) {
- numCircles<-NA
- data.colnames<-NULL
- data.rownames<-NULL
- if(is.matrix(data)) {
- numCircles<-ncol(data)-1
- data.colnames<-colnames(data)[2:(ncol(data))]
- # Order is reverted since later indexing starts with
- # the "lowest bit" and that is expected at the left
- data.rownames<-rownames(data)
- }
- else {
- cat("Testing only, presuming first argument to specify",
- "the number of circles to draw.\n")
- numCircles<-data
- }
-
- m<-(0:(-1+2^numCircles))
-
- if (! is.matrix(data)) {
- ##cat("prepare randomised data\n")
- data<-t(sapply(X=m,FUN=function(v){
- l<-baseOf(v,2,numCircles)
- #print(l)
- return(l)
- }))
-
- #print(data)
-
- #data.names<-apply(data,1,function(X){
- # return(paste(X),collapse="")
- #})
- for(i in m) {
- n<-paste(data[i+1,],collapse="")
- if (is.null(data.rownames)) {
- data.rownames<-n
- }
- else {
- data.rownames<-c(data.rownames,n)
- }
- }
- #print(data.rownames)
- data<-cbind(sample(1:100,size=2^numCircles,replace=TRUE),data)
- #print(data)
- rownames(data)<-data.rownames
- data.colnames<-LETTERS[1:numCircles]
- colnames(data)<-c("num",data.colnames)
- }
-
- if ((2 <= numCircles && numCircles <= 3) || (4 == numCircles && simplify)) {
- ##cat("drawing circles\n")
- # draw circles with radius 1.7 equally distributed
- # with centers on a circle of radius 1
-
- degrees<-2*pi/numCircles*(1:numCircles)
-
- # scaling factor
- s<-1/8
-
- x<-sapply(degrees,FUN=sin)*s + 0.5
- y<-sapply(degrees,FUN=cos)*s + 0.5
-
-
- if(!require(grid)) {
- stop("Need access to 'grid' library.")
- }
- grid.newpage()
- grid.circle(x,y,3/12,name="some name")
-
- ##cat("filling data\n")
-
- distFromZero<-rep(NA,2^numCircles)
- degrees<-rep(NA,2^numCircles)
-
- degrees[(2^numCircles)]<-0
- distFromZero[(2^numCircles)]<-0
-
- for (i in 0:(numCircles-1)) {
- distFromZero[2^i+1] <- 4/12
- degrees[2^i+1] <- 2*pi/numCircles*i
- d<-degrees[2^i+1]
-
- #print(data.colnames)
-
- grid.text(
- # starting from the lowest bit, hence reading
- # lables from the right
- label=data.colnames[numCircles - i],
- x=sin(d)*5/12+0.5,
- y=cos(d)*5/12+0.5,
- rot=0
- )
-
- }
-
- if (4==numCircles) {
- for (i in 0:(numCircles-1)) {
- # Current set bit plus the bit left of it and the bit right of it
- distFromZero[2^i
- +2^((i+numCircles-1)%%numCircles)
- +2^((i+1)%%numCircles)+1] <- 2/12
- degrees[2^i
- +2^((i+numCircles-1)%%numCircles)
- +2^((i+1)%%numCircles)+1] <- degrees[2^i+1]
- }
- }
-
- #degrees[2^i+1] + degrees[2^((i+1)%%numCircles)+1])/2
-
- if (3 <=numCircles) {
- for (i in 0:(numCircles-1)) {
- distFromZero[(2^i+2^((i+1)%%numCircles))+1]<- 3/12
- if (i == (numCircles-1)) {
- degrees[(2^i+2^((i+1)%%numCircles))+1] <- (
- degrees[2^i+1] + 2*pi+ degrees[1+1])/2
- }
- else {
- degrees[(2^i+2^((i+1)%%numCircles))+1] <- (
- degrees[2^i+1] + degrees[2^((i+1)%%numCircles)+1])/2
- }
-
- }
- }
-
- for(i in 1:2^numCircles) {
- n<-paste(baseOf((i-1),2,numCircles),collapse="")
- v<-data[n,1]
- d<-degrees[i]
- if (1 == length(d) && is.na(d)) {
- if (v>0) warning("Not shown: ",n,"is",v,"\n")
- }
- else {
- l<-distFromZero[i]
- x<-sin(d)*l+0.5
- y<-cos(d)*l+0.5
- #cat("i=",i," x=",x," y=",y," label=",n,"\n")
- l<-v
- if (showSetLogicLabel) l<-paste(n,"\n",v,sep="")
- grid.text(label=l,x=x,y=y,rot=0)
- }
- }
- }
- else if (4 <= numCircles && numCircles <= 5 && !simplify) {
-
- grid.newpage()
- # Function to turn and move ellipses
- relocate_elp <- function(e, alpha, x, y){
- phi=(alpha/180)*pi;
- xr=e[,1]*cos(phi)+e[,2]*sin(phi)
- yr=-e[,1]*sin(phi)+e[,2]*cos(phi)
- xr=x+xr;
- yr=y+yr;
- return(cbind(xr, yr))
- }
-
- lab<-function (identifier, data, showLabel=showSetLogicLabel) {
- r<-data[identifier,1]
- if (showLabel) {
- return(paste(identifier,r,sep="\n"))
- }
- else {
- return(r)
- }
- }
-
- plot(c(0, 400), c(0, 400), type="n", axes=F, ylab="", xlab="")
- if (4 == numCircles) {
- elps=cbind(162*cos(seq(0,2*pi,len=1000)), 108*sin(seq(0,2*pi,len=1000)));
-
- plot(c(0, 400), c(0, 400), type="n", axes=F, ylab="", xlab="");
- polygon(relocate_elp(elps, 45,130, 170));
- polygon(relocate_elp(elps, 45,200, 200));
- polygon(relocate_elp(elps, 135,200, 200));
- polygon(relocate_elp(elps, 135,270, 170));
-
- text( 35, 315, data.colnames[1],cex=1.5)
- text(138, 347, data.colnames[2],cex=1.5)
- text(262, 347, data.colnames[3],cex=1.5)
- text(365, 315, data.colnames[4],cex=1.5)
-
- elps <- cbind(130*cos(seq(0,2*pi,len=1000)),
- 80*sin(seq(0,2*pi,len=1000)))
-
- text( 35, 250, lab("1000",data));
- text(140, 315, lab("0100",data));
- text(260, 315, lab("0010",data));
- text(365, 250, lab("0001",data));
-
- text( 90, 280, lab("1100",data), cex=small)
- text( 95, 110,lab("1010",data) )
- text(200, 50, lab("1001",data), cex=small)
- text(200, 290, lab("0110",data))
- text(300, 110, lab("0101",data))
- text(310, 280, lab("0011",data), cex=small)
-
- text(130, 230, lab("1110",data))
- text(245, 75, lab("1101",data),cex=small)
- text(155, 75, lab("1011",data),cex=small)
- text(270, 230, lab("0111",data))
-
- text(200,150,lab("1111",data))
- }
- else if (5 == numCircles) {
-
- elps <- cbind(150*cos(seq(0,2*pi,len=1000)),
- 60*sin(seq(0,2*pi,len=1000)))
-
- polygon(relocate_elp(elps, 90,200, 250))
- polygon(relocate_elp(elps, 162,250, 220))
- polygon(relocate_elp(elps, 234,250, 150))
- polygon(relocate_elp(elps, 306,180, 125))
- polygon(relocate_elp(elps, 378,145, 200))
-
- text( 50, 280, data.colnames[1],cex=1.5)
- text(150, 400, data.colnames[2],cex=1.5)
- text(350, 300, data.colnames[3],cex=1.5)
- text(350, 20, data.colnames[4],cex=1.5)
- text( 50, 10, data.colnames[5],cex=1.5)
-
- text( 61, 228, lab("10000",data));
- text(194, 329, lab("01000",data));
- text(321, 245, lab("00100",data));
- text(290, 81, lab("00010",data));
- text(132, 69, lab("00001",data));
-
- text(146, 250, lab("11000",data), cex=small)
- text(123, 188, lab("10100",data), cex=small)
- text(275, 152, lab("10010",data), cex=small)
- text(137, 146, lab("10001",data), cex=small)
- text(243, 268, lab("01100",data), cex=small)
- text(175, 267, lab("01010",data), cex=small)
- text(187, 117, lab("01001",data), cex=small)
- text(286, 188, lab("00110",data), cex=small)
- text(267, 235, lab("00101",data), cex=small)
- text(228, 105, lab("00011",data), cex=small)
-
- text(148, 210, lab("11100",data),cex=small)
- text(159, 253, lab("11010",data),cex=small)
- text(171, 141, lab("11001",data),cex=small)
- text(281, 175, lab("10110",data),cex=small)
- text(143, 163, lab("10101",data),cex=small)
- text(252, 145, lab("10011",data),cex=small)
- text(205, 255, lab("01110",data),cex=small)
- text(254, 243, lab("01101",data),cex=small)
- text(211, 118, lab("01011",data),cex=small)
- text(267, 211, lab("00111",data),cex=small)
-
- text(170, 231,lab("11110",data),cex=small)
- text(158, 169,lab("11101",data),cex=small)
- text(212, 139,lab("11011",data),cex=small)
- text(263, 180,lab("10111",data),cex=small)
- text(239, 232,lab("01111",data),cex=small)
-
- text(204,190,lab("11111",data))
- }
- }
- else {
- stop(paste("The printing of ",numCircles," circles is not yet supported."))
- }
-
-}
-
-
venn <- function(data,
universe=NA,
small=0.7,
@@ -424,8 +129,8 @@
simplify=FALSE,
show.plot=TRUE)
{
- counts <- getVennCounts(data)
-
+ counts <- getVennCounts(data, universe=universe)
+
if(show.plot)
drawVennDiagram(data=counts,
small=small,
@@ -433,5 +138,7 @@
simplify=simplify
)
+
invisible(counts)
}
+
Modified: trunk/gplots/man/venn.Rd
===================================================================
--- trunk/gplots/man/venn.Rd 2010-05-03 16:26:14 UTC (rev 1439)
+++ trunk/gplots/man/venn.Rd 2010-06-11 03:11:16 UTC (rev 1440)
@@ -2,74 +2,133 @@
\alias{venn}
\title{Plot a Venn diagram}
\description{
-Plot Venn diagrams for up to 5 sets
+ Plot a Venn diagrams for up to 5 sets
}
\usage{
venn(data, universe=NA, small=0.7, showSetLogicLabel=FALSE,
simplify=FALSE, show.plot=TRUE)
+\method{plot}{venn}(x, y, ..., small=0.7, showSetLogicLabel=FALSE,
+ simplify=FALSE)
}
\arguments{
- \item{data}{data to be plotted (see below)}
- \item{universe}{??}
- \item{small}{Character size of group labels}
+ \item{data}{Either a list list containing vectors of names or indices
+ of group members, or a data frame containing boolean indicators of
+ group membership (see below)}
+ \item{universe}{Subset of valid name/index elements. Values ignore values
+ in code{data} not in this list will be ignored. Use \code{NA} to
+ use all elements of \code{data} (the default).}
+ \item{small}{Character scaling of the smallest group counts}
\item{showSetLogicLabel}{Logical flag indicating whether the internal
group label should be displayed}
- \item{simplify}{Logical flag indicating whether unobserved group
+ \item{simplify}{Logical flag indicating whether unobserved groups
should be omitted.}
\item{show.plot}{Logical flag indicating whether the plot should be
displayed. If false, simply returns the group count matrix.}
}
\details{
\code{data} should be either a named list of vectors containing
- indexes of group members (1, 2, 3,..) , or a data frame containing indicator
- variables (TRUE, FALSE, TRUE, ..) for group membership. Group names
- will be taken from the component vector or column names.
+ character string names ("GeneAABBB", "GeneBBBCY", .., "GeneXXZZ") or
+ indexes of group members (1, 2, .., N), or a data frame containing
+ indicator variables (TRUE, FALSE, TRUE, ..) for group membership.
+ Group names will be taken from the component list element or column
+ names.
}
\value{
- A matrix of all possible sets of groups, and the observed numer of
- items beloinging to each set of groups is returned invisibly.
- The fist column contains observed counts, subsequent columns contain
- 0-1 indicators of group membership.
+ Invisibly returns an object of class "venn", containing a matrix of
+ all possible sets of groups, and the observed count of items belonging
+ to each The fist column contains observed counts, subsequent columns
+ contain 0-1 indicators of group membership.
}
-\author{Steffen Moeller \email{steffen\_mo...@gm...},
+\author{
+ Steffen Moeller \email{steffen\_mo...@gm...},
with cleanup and packaging by Gregory R. Warnes
- \email{gr...@ra...}.}
+ \email{gr...@wa...}.}
\examples{
##
-## Example using a list of item indexes belonging to the
+## Example using a list of item names belonging to the
## specified group.
##
-A<- 1:20
-B<- 1:20
-C<- 2:20
-D<- 3:21
-input<-list(A,B,C,D)
+
+## construct some fake gene names..
+oneName <- function() paste(sample(LETTERS,5,replace=T),collapse="")
+geneNames <- replicate(1000, oneName())
+
+##
+GroupA <- sample(geneNames, 400, replace=FALSE)
+GroupB <- sample(geneNames, 750, replace=FALSE)
+GroupC <- sample(geneNames, 250, replace=FALSE)
+GroupD <- sample(geneNames, 300, replace=FALSE)
+input <-list(GroupA,GroupB,GroupC,GroupD)
input
venn(input)
+
##
-## Example using a data frame of indicator columns
+## Example using a list of item indexes belonging to the
+## specified group.
##
-A<- as.logical(rbinom(100, 1, 0.2))
-B<- as.logical(rbinom(100, 1, 0.7))
-C<- as.logical(rbinom(100, 1, 0.2))
-D<- as.logical(rbinom(100, 1, 0.1))
-input<-data.frame(A,B,C,D)
-venn(input)
+GroupA.i <- which(geneNames %in% GroupA)
+GroupB.i <- which(geneNames %in% GroupB)
+GroupC.i <- which(geneNames %in% GroupC)
+GroupD.i <- which(geneNames %in% GroupD)
+input.i <-list(A=GroupA.i,B=GroupB.i,C=GroupC.i,D=GroupD.i)
+input.i
+venn(input.i)
-## Omit un-observed groupings
-tmp <- venn(input, simplify=TRUE)
+##
+## Example using a data frame of indicator ('f'lag) columns
+##
+GroupA.f <- geneNames %in% GroupA
+GroupB.f <- geneNames %in% GroupB
+GroupC.f <- geneNames %in% GroupC
+GroupD.f <- geneNames %in% GroupD
+input.df <- data.frame(A=GroupA.f,B=GroupB.f,C=GroupC.f,D=GroupD.f)
+head(input.df)
+venn(input.df)
-## show details
+## smaller set to create empty groupings
+small <- input[1:20,]
+
+venn(small, simplify=FALSE) # with empty groupings
+venn(small, simplify=TRUE) # without empty groupings
+
+## Capture group counts, but don't plot
+tmp <- venn(input, show.plot=FALSE)
tmp
## Show internal binary group labels
venn(input, showSetLogicLabel=TRUE)
-## Specify universe
-venn(input, universe=NULL, showSetLogicLabel=TRUE)
+## Limit universe
+tmp <- venn(input, universe=geneNames[1:100])
+tmp
+
+##
+## Example to determine which elements are in A and B but not in
+## C and D: first determine the universe, then form indicator columns
+## and perform intersections on these. R allows using the set operations
+## directly, but some might find this approach more intuitive.
+##
+
+universe <- unique(c(GroupA,GroupB,GroupC,GroupD))
+GroupA.l <-universe %in% GroupA
+GroupB.l <-universe %in% GroupB
+GroupC.l <-universe %in% GroupC
+GroupD.l <-universe %in% GroupD
+
+## Genes that are in GroupA and in GroupB but not in GroupD (unification
+## of sets III0 and II00 in the venn diagram:
+universe[GroupA.l & GroupB.l & !GroupD.l]
+
+##
+## Alternatively: construct a function to test for the pattern you want.
+##
+test <- function(x) (x %in% GroupA) & (x %in% GroupB) & !(x %in% GroupC)
+universe[ test(universe) ]
+
+
}
\keyword{hplot}
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <wa...@us...> - 2010-06-11 03:15:25
|
Revision: 1443
http://r-gregmisc.svn.sourceforge.net/r-gregmisc/?rev=1443&view=rev
Author: warnes
Date: 2010-06-11 03:15:19 +0000 (Fri, 11 Jun 2010)
Log Message:
-----------
Update for gplots 2.8.0
Modified Paths:
--------------
trunk/gplots/DESCRIPTION
trunk/gplots/NAMESPACE
trunk/gplots/inst/NEWS
Modified: trunk/gplots/DESCRIPTION
===================================================================
--- trunk/gplots/DESCRIPTION 2010-06-11 03:14:38 UTC (rev 1442)
+++ trunk/gplots/DESCRIPTION 2010-06-11 03:15:19 UTC (rev 1443)
@@ -4,11 +4,12 @@
Depends: gtools, gdata, stats, caTools, grid
Recommends: datasets, grid
Suggests: gtools
-Version: 2.7.5
+Version: 2.8.0
+Date: 2010-06-10
Author: Gregory R. Warnes. Includes R source code and/or documentation
contributed by (in alphabetical order):
Ben Bolker, Lodewijk Bonebakker, Robert Gentleman, Wolfgang
Huber Andy Liaw, Thomas Lumley, Martin Maechler, Arni
Magnusson, Steffen Moeller, Marc Schwartz, Bill Venables
-Maintainer: Gregory R. Warnes <gr...@ra...>
+Maintainer: Gregory R. Warnes <gr...@wa...>
License: GPL-2
Modified: trunk/gplots/NAMESPACE
===================================================================
--- trunk/gplots/NAMESPACE 2010-06-11 03:14:38 UTC (rev 1442)
+++ trunk/gplots/NAMESPACE 2010-06-11 03:15:19 UTC (rev 1443)
@@ -14,6 +14,7 @@
overplot,
panel.overplot,
plot.lm2,
+ plot.venn,
plotCI,
plotmeans,
qqnorm.aov,
Modified: trunk/gplots/inst/NEWS
===================================================================
--- trunk/gplots/inst/NEWS 2010-06-11 03:14:38 UTC (rev 1442)
+++ trunk/gplots/inst/NEWS 2010-06-11 03:15:19 UTC (rev 1443)
@@ -1,3 +1,15 @@
+Release 2.8.0 - 2010-06-10
+--------------------------
+
+Improvements:
+
+- venn() now returns an object of class venn() and a plot method for
+ this class is provided.
+
+- Manual page for venn has been improved, based on contributions by
+ Steffen Moeller
+
+
Release 2.7.5 - ??
--------------------------
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <ar...@us...> - 2011-05-02 14:02:40
|
Revision: 1470
http://r-gregmisc.svn.sourceforge.net/r-gregmisc/?rev=1470&view=rev
Author: arnima
Date: 2011-05-02 14:02:34 +0000 (Mon, 02 May 2011)
Log Message:
-----------
Added argument 'alpha' and removed argument 'rgb' in rich.colors()
Modified Paths:
--------------
trunk/gplots/R/rich.colors.R
trunk/gplots/man/rich.colors.Rd
Modified: trunk/gplots/R/rich.colors.R
===================================================================
--- trunk/gplots/R/rich.colors.R 2011-04-16 17:04:06 UTC (rev 1469)
+++ trunk/gplots/R/rich.colors.R 2011-05-02 14:02:34 UTC (rev 1470)
@@ -1,4 +1,4 @@
-rich.colors <- function(n, palette="temperature", rgb=FALSE, plot=FALSE)
+rich.colors <- function(n, palette="temperature", alpha=1, plot=FALSE)
{
if(n <= 0)
return(character(0))
@@ -20,14 +20,9 @@
b[x>0.4] <- 1
}
- rgb.m <- matrix(c(r,g,b), ncol=3,
- dimnames=list(as.character(seq(length=n)),
- c("red","green","blue")))
- rich.vector <- apply(rgb.m, 1, function(v) rgb(v[1],v[2],v[3]))
+ rgb.m <- matrix(c(r,g,b), ncol=3, dimnames=list(NULL,c("red","green","blue")))
+ col <- mapply(rgb, r, g, b, alpha)
- if(rgb)
- attr(rich.vector, "rgb") <- rgb.m
-
if(plot)
{
opar <- par("fig", "plt")
@@ -40,10 +35,11 @@
axis(1, at=0:1)
axis(2, at=0:1, las=1)
par(fig=c(0,1,0.75,0.9), plt=c(0.08,0.97,0,1), new=TRUE)
- midpoints <- barplot(rep(1,n), col=rich.vector, border=FALSE, space=FALSE,
+ midpoints <- barplot(rep(1,n), col=col, border=FALSE, space=FALSE,
axes=FALSE)
axis(1, at=midpoints, labels=1:n, lty=0, cex.axis=0.6)
par(opar)
}
- return(rich.vector)
+
+ return(col)
}
Modified: trunk/gplots/man/rich.colors.Rd
===================================================================
--- trunk/gplots/man/rich.colors.Rd 2011-04-16 17:04:06 UTC (rev 1469)
+++ trunk/gplots/man/rich.colors.Rd 2011-05-02 14:02:34 UTC (rev 1470)
@@ -13,18 +13,16 @@
\item{palette}{palette to use: \code{"temperature"} contains
blue-green-yellow-red, and \code{"blues"} contains
black-blue-white.}
- \item{rgb}{if \code{TRUE} then a matrix of RGB values is included as
- an attribute.}
- \item{plot}{if \code{TRUE} then a descriptive color diagram is plotted
- on the current device.}
+ \item{alpha}{alpha transparency, from 0 to 1.}
+ \item{plot}{whether to plot a descriptive color diagram.}
}
\value{A character vector of color codes.}
-\author{Arni Magnusson}
+\author{Arni Magnusson.}
\seealso{
\code{\link{rgb}}, \code{\link{rainbow}}, \code{\link{heat.colors}}.
}
\examples{
-m <- matrix(1:120+rnorm(120), nrow=15, ncol=8)
+m <- abs(matrix(1:120+rnorm(120), nrow=15, ncol=8))
opar <- par(bg="gray", mfrow=c(1,2))
matplot(m, type="l", lty=1, lwd=3, col=rich.colors(8))
matplot(m, type="l", lty=1, lwd=3, col=rich.colors(8,"blues"))
@@ -33,8 +31,11 @@
barplot(rep(1,100), col=rich.colors(100), space=0, border=0, axes=FALSE)
barplot(rep(1,20), col=rich.colors(40)[11:30]) # choose subset
-rich.colors(100, plot=TRUE, rgb=TRUE) # describe rgb recipe
+plot(m, rev(m), ylim=c(120,0), pch=16, cex=2,
+ col=rich.colors(200,"blues",alpha=0.6)[1:120]) # semitransparent
+rich.colors(100, plot=TRUE) # describe rgb recipe
+
par(mfrow=c(2,2))
barplot(m, col=heat.colors(15), main="\nheat.colors")
barplot(m, col=1:15, main="\ndefault palette")
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <wa...@us...> - 2011-08-16 01:03:38
|
Revision: 1471
http://r-gregmisc.svn.sourceforge.net/r-gregmisc/?rev=1471&view=rev
Author: warnes
Date: 2011-08-16 01:03:31 +0000 (Tue, 16 Aug 2011)
Log Message:
-----------
Accellerate hist2d by replacing for() loop with tapply(), and allow user to specify summary function applied, per suggestion by Peter Hagedorn (PHA -at- santaris -dot- com).
Modified Paths:
--------------
trunk/gplots/R/hist2d.R
trunk/gplots/man/hist2d.Rd
Modified: trunk/gplots/R/hist2d.R
===================================================================
--- trunk/gplots/R/hist2d.R 2011-05-02 14:02:34 UTC (rev 1470)
+++ trunk/gplots/R/hist2d.R 2011-08-16 01:03:31 UTC (rev 1471)
@@ -1,7 +1,16 @@
# $Id$
if(is.R())
-hist2d <- function( x,y=NULL, nbins=200, same.scale=FALSE, na.rm=TRUE, show=TRUE, col=c("black", heat.colors(12)), ... )
+
+ hist2d <- function(x,
+ y=NULL,
+ nbins=200,
+ same.scale=FALSE,
+ na.rm=TRUE,
+ show=TRUE,
+ col=c("black", heat.colors(12)),
+ FUN=base::length,
+ ... )
{
if(is.null(y))
{
@@ -34,18 +43,17 @@
y.cuts <- seq( from=min(y), to=max(y), length=nbins[2]+1, labels=FALSE)
}
-
-
index.x <- cut( x, x.cuts, include.lowest=TRUE)
index.y <- cut( y, y.cuts, include.lowest=TRUE)
- m <- matrix( 0, nrow=nbins[1], ncol=nbins[2],
- dimnames=list( levels(index.x),
- levels(index.y) ) )
+ ## tapply is faster than old for() loop, and allows
+ ## use of any user-specified summary function
+ m <- tapply(x,list(index.x,index.y),FUN)
- for( i in 1:length(index.x) )
- m[ index.x[i], index.y[i] ] <- m[ index.x[i], index.y[i] ] + 1
-
+ ## If we're using length, set empty cells to 0 instead of NA
+ if(identical(FUN,base::length))
+ m[is.na(m)] <- 0
+
xvals <- x.cuts[1:nbins[1]]
yvals <- y.cuts[1:nbins[2]]
@@ -54,9 +62,3 @@
invisible(list(counts=m,x=xvals,y=yvals))
}
-
-
-
-
-
-
Modified: trunk/gplots/man/hist2d.Rd
===================================================================
--- trunk/gplots/man/hist2d.Rd 2011-05-02 14:02:34 UTC (rev 1470)
+++ trunk/gplots/man/hist2d.Rd 2011-08-16 01:03:31 UTC (rev 1471)
@@ -27,9 +27,8 @@
}
\usage{
hist2d(x,y=NULL, nbins=200, same.scale=FALSE, na.rm=TRUE, show=TRUE,
- col=c("black", heat.colors(12)), ... )
+ col=c("black", heat.colors(12)), FUN=base::length, ... )
}
-%- maybe also `usage' for other objects documented here.
\arguments{
\item{x}{either a vector containing the x coordinates
or a matrix with 2 columns. }
@@ -45,6 +44,10 @@
been computed. Defaults to TRUE.}
\item{col}{ Colors for the histogram. Defaults to "black" for
bins containing no elements, a set of 16 heat colors for other bins.}
+ \item{FUN}{Function used to summarize bin contents. Defaults to
+ \code{base::length}. Use, e.g., \code{mean} to calculate means for each bin
+ instead of counts.
+ }
\item{\dots}{ Parameters passed to the image function. }
}
\details{
@@ -61,10 +64,8 @@
bin}
\item{x}{lower x limit of each bin}
\item{y}{lower y limit of each bin}
-}
-%\references{ ~put references to the literature/web site here ~ }
+ }
\author{ Gregory R. Warnes \email{gr...@wa...}}
-%\note{ ~~further notes~~ }
\seealso{ \code{\link{image}}, \code{\link{persp}}, \code{\link{hist}} }
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <wa...@us...> - 2011-08-16 01:16:06
|
Revision: 1472
http://r-gregmisc.svn.sourceforge.net/r-gregmisc/?rev=1472&view=rev
Author: warnes
Date: 2011-08-16 01:16:00 +0000 (Tue, 16 Aug 2011)
Log Message:
-----------
Add 'alpha' argument to rich.colors() to control transparency.
Modified Paths:
--------------
trunk/gplots/R/rich.colors.R
trunk/gplots/man/rich.colors.Rd
Modified: trunk/gplots/R/rich.colors.R
===================================================================
--- trunk/gplots/R/rich.colors.R 2011-08-16 01:03:31 UTC (rev 1471)
+++ trunk/gplots/R/rich.colors.R 2011-08-16 01:16:00 UTC (rev 1472)
@@ -1,4 +1,8 @@
-rich.colors <- function(n, palette="temperature", alpha=1, plot=FALSE)
+rich.colors <- function(n,
+ palette="temperature",
+ alpha=1,
+ rgb=FALSE,
+ plot=FALSE)
{
if(n <= 0)
return(character(0))
@@ -20,9 +24,13 @@
b[x>0.4] <- 1
}
- rgb.m <- matrix(c(r,g,b), ncol=3, dimnames=list(NULL,c("red","green","blue")))
+ rgb.m <- matrix(c(r,g,b), ncol=3,
+ dimnames=list(NULL,c("red","green","blue")))
col <- mapply(rgb, r, g, b, alpha)
+ if(rgb)
+ attr(col, "rgb") <- cbind(rgb.m, alpha)
+
if(plot)
{
opar <- par("fig", "plt")
Modified: trunk/gplots/man/rich.colors.Rd
===================================================================
--- trunk/gplots/man/rich.colors.Rd 2011-08-16 01:03:31 UTC (rev 1471)
+++ trunk/gplots/man/rich.colors.Rd 2011-08-16 01:16:00 UTC (rev 1472)
@@ -6,14 +6,17 @@
and in an order that is easy to interpret.
}
\usage{
-rich.colors(n, palette="temperature", rgb=FALSE, plot=FALSE)
+rich.colors(n, palette="temperature", alpha=1.0, rgb=FALSE, plot=FALSE)
}
\arguments{
\item{n}{number of colors to generate.}
\item{palette}{palette to use: \code{"temperature"} contains
blue-green-yellow-red, and \code{"blues"} contains
black-blue-white.}
- \item{alpha}{alpha transparency, from 0 to 1.}
+ \item{alpha}{alpha transparency, from 0 (fully transparent) to 1
+ (opaque).}
+ \item{rgb}{if ‘TRUE’ then a matrix of RGBA values is included as an
+ attribute.}
\item{plot}{whether to plot a descriptive color diagram.}
}
\value{A character vector of color codes.}
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <wa...@us...> - 2011-08-25 03:10:11
|
Revision: 1474
http://r-gregmisc.svn.sourceforge.net/r-gregmisc/?rev=1474&view=rev
Author: warnes
Date: 2011-08-25 03:10:05 +0000 (Thu, 25 Aug 2011)
Log Message:
-----------
- Add 'ci2d()' to compute 2-dimensional emipirical confidence interval.
- Fix parse error in help page for 'rich.colors()'.
Modified Paths:
--------------
trunk/gplots/DESCRIPTION
trunk/gplots/NAMESPACE
trunk/gplots/man/rich.colors.Rd
Added Paths:
-----------
trunk/gplots/R/ci2d.R
trunk/gplots/man/ci2d.Rd
Modified: trunk/gplots/DESCRIPTION
===================================================================
--- trunk/gplots/DESCRIPTION 2011-08-16 01:17:20 UTC (rev 1473)
+++ trunk/gplots/DESCRIPTION 2011-08-25 03:10:05 UTC (rev 1474)
@@ -4,7 +4,7 @@
Depends: gtools, gdata, stats, caTools, grid
Recommends: datasets, grid, MASS
Suggests: gtools
-Version: 2.8.1
+Version: 2.9.0
Date: 2011-08-15
Author: Gregory R. Warnes. Includes R source code and/or documentation
contributed by (in alphabetical order):
Modified: trunk/gplots/NAMESPACE
===================================================================
--- trunk/gplots/NAMESPACE 2011-08-16 01:17:20 UTC (rev 1473)
+++ trunk/gplots/NAMESPACE 2011-08-25 03:10:05 UTC (rev 1474)
@@ -4,6 +4,7 @@
barplot2,
bluered,
boxplot.n,
+ ci2d,
col2hex,
colorpanel,
greenred,
Added: trunk/gplots/R/ci2d.R
===================================================================
--- trunk/gplots/R/ci2d.R (rev 0)
+++ trunk/gplots/R/ci2d.R 2011-08-25 03:10:05 UTC (rev 1474)
@@ -0,0 +1,64 @@
+## first(...) selects the first element of which(...)
+first <- function(x,...)
+ {
+ w <- which(x,...)
+ if(length(x)>1)
+ w[1]
+ else
+ w
+}
+
+## first(...) selects the first element of which(...)
+last <- function(x,...)
+ {
+ w <- which(x,...)
+ if(length(x)>1)
+ rev(w)[1]
+ else
+ w
+}
+
+## non-parametric 2 dimensional approximate confidence interval
+## based on 2 dimensional histogram
+ci2d <- function(x,
+ y = NULL,
+ nbins=25,
+ ci.levels=c(0.50,0.75,0.90,0.95,0.975),
+ show=c("filled.contour","contour","image","none"),
+ xlab=deparse(substitute(x)),
+ ylab=deparse(substitute(y)),
+ col=topo.colors(length(breaks)-1),
+ ...)
+ {
+
+ show=match.arg(show)
+ breaks <- unique(c(0, ci.levels, 1.0))
+
+ h2d <- hist2d(x,y, show=FALSE, nbins=nbins, ...)
+ h2d$density <- h2d$counts / sum(h2d$counts, na.rm=TRUE)
+
+ uniqueVals <- rev(unique(sort(h2d$density)))
+ cumProbs <- sapply( uniqueVals, function(val) sum( h2d$density[h2d$density>=val] ) )
+ names(cumProbs) <- uniqueVals
+ h2d$cumDensity <- matrix(nrow=nrow(h2d$density), ncol=ncol(h2d$density))
+ h2d$cumDensity[] <- cumProbs[as.character(h2d$density)]
+
+ if(show=="image")
+ {
+ image( h2d$x, h2d$y, h2d$cumDensity, xlab=xlab, ylab=ylab, breaks=breaks, col=col)
+ }
+ else if(show=="filled.contour")
+ {
+ filled.contour(h2d$x, h2d$y, h2d$cumDensity,
+ levels=breaks,
+ col=col,
+ key.axes={axis(4, at=breaks); title("\nCI Level")}
+ )
+ }
+ else if(show=="contour")
+ contour(h2d$x, h2d$y, h2d$cumDensity, levels=breaks, nlevels=length(breaks))
+
+ h2d$contours <- contourLines(h2d$x, h2d$y, h2d$cumDensity, levels=breaks, nlevels=length(breaks))
+ names
+ invisible(h2d)
+ }
Added: trunk/gplots/man/ci2d.Rd
===================================================================
--- trunk/gplots/man/ci2d.Rd (rev 0)
+++ trunk/gplots/man/ci2d.Rd 2011-08-25 03:10:05 UTC (rev 1474)
@@ -0,0 +1,76 @@
+\name{ci2d}
+\alias{ci2d}
+\title{
+ Create 2-dimensional empirical confidence regions
+}
+\description{
+ Create 2-dimensional empirical confidence regions based on a
+ 2-dimensoinal histogram.
+}
+\usage{
+ci2d(x, y=NULL,
+ nbins=25,
+ ci.levels=c(0.5, 0.75, 0.9, 0.95, 0.975),
+ show=c("filled.contour", "contour", "image", "none"),
+ xlab=deparse(substitute(x)),
+ ylab=deparse(substitute(y)),
+ col=topo.colors(length(breaks) - 1),
+ ...)
+}
+\arguments{
+ \item{x}{either a vector containing the x coordinates
+ or a matrix with 2 columns. }
+ \item{y}{a vector contianing the y coordinates, not required if `x'
+ is matrix}
+ \item{nbins}{number of bins in each dimension. May be a scalar or a
+ 2 element vector. Defaults to 25.}
+ \item{ci.levels}{Confidence level(s) to use for plotting
+ data. Defaults to \code{c(0.5, 0.75, 0.9, 0.95, 0.975)} }
+ \item{show}{Plot type to be displaed. One of "filled.contour",
+ "contour", "image", or "none". Defaults to "filled.contour".}
+ \item{xlab, ylab}{Axis labels}
+ \item{col}{Colors to use for plots.}
+ \item{\dots}{Additional arguments passed to \code{hist2d}. }
+}
+\details{
+ This function utilizes \code{hist2d} to create a 2-dimensional
+ histogram of the data passed as an argument. This data is then
+ converted into densities and used to create and display confidence
+ regions.
+}
+\value{
+ A list containing 3 elements:
+ \item{counts}{Matrix containing the number of points falling into each
+ bin}
+ \item{x}{lower x limit of each bin}
+ \item{y}{lower y limit of each bin}
+ \item{density}{Matrix containing the probability density of each bin (count in bin/total
+ count)}
+ \item{cumDensity}{Matrix where each element contains the cumulative probability density
+ of all elements with the same density (used to create the confidence
+ region plots) }
+ \item{contours}{Contours of each confidence region}
+}
+%\references{
+%}
+\author{ Gregory R. Warnes \email{gr...@wa...}}
+\seealso{
+ \code{\link{hist2d}}
+}
+\examples{
+ # example data, bivariate normal, no correlation
+ x <- rnorm(2000, sd=4)
+ y <- rnorm(2000, sd=1)
+
+ # 2-d confidence intervals based on 2d histogram
+ ci2d(x,y)
+
+ # same scale for each axis, this looks oval
+ ci2d(x,y, same.scale=TRUE)
+
+}
+% Add one or more standard keywords, see file 'KEYWORDS' in the
+% R documentation directory.
+\keyword{dplot}
+\keyword{hplot}
+\keyword{nonparametric}
Modified: trunk/gplots/man/rich.colors.Rd
===================================================================
--- trunk/gplots/man/rich.colors.Rd 2011-08-16 01:17:20 UTC (rev 1473)
+++ trunk/gplots/man/rich.colors.Rd 2011-08-25 03:10:05 UTC (rev 1474)
@@ -15,7 +15,7 @@
black-blue-white.}
\item{alpha}{alpha transparency, from 0 (fully transparent) to 1
(opaque).}
- \item{rgb}{if ‘TRUE’ then a matrix of RGBA values is included as an
+ \item{rgb}{if \code{TRUE} then a matrix of RGBA values is included as an
attribute.}
\item{plot}{whether to plot a descriptive color diagram.}
}
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <wa...@us...> - 2011-09-01 19:37:45
|
Revision: 1486
http://r-gregmisc.svn.sourceforge.net/r-gregmisc/?rev=1486&view=rev
Author: warnes
Date: 2011-09-01 19:37:38 +0000 (Thu, 01 Sep 2011)
Log Message:
-----------
Improvements to ci2d():
- Add option to utilize KernDensity::bkde2D to estimate the 2-d
density (now the default).
- Add option to display points for original data on generated plots
- Name elements of returned contour list according to the significance
level to make it easier to select desired contours.
- Improve handling of x and y labels
Modified Paths:
--------------
trunk/gplots/R/ci2d.R
trunk/gplots/man/ci2d.Rd
Modified: trunk/gplots/R/ci2d.R
===================================================================
--- trunk/gplots/R/ci2d.R 2011-09-01 19:26:23 UTC (rev 1485)
+++ trunk/gplots/R/ci2d.R 2011-09-01 19:37:38 UTC (rev 1486)
@@ -1,3 +1,5 @@
+## $Id$
+
## first(...) selects the first element of which(...)
first <- function(x,...)
{
@@ -19,24 +21,78 @@
}
## non-parametric 2 dimensional approximate confidence interval
-## based on 2 dimensional histogram
ci2d <- function(x,
y = NULL,
- nbins=25,
+ nbins=51,
+ method=c("bkde2D","hist2d"),
+ bandwidth,
+ factor=1.0,
+
ci.levels=c(0.50,0.75,0.90,0.95,0.975),
+
show=c("filled.contour","contour","image","none"),
- xlab=deparse(substitute(x)),
- ylab=deparse(substitute(y)),
col=topo.colors(length(breaks)-1),
+ show.points=FALSE,
+ pch=par("pch"),
+ points.col="red",
+ xlab, ylab,
...)
{
- show=match.arg(show)
+ show <- match.arg(show)
+ method <- match.arg(method)
breaks <- unique(c(0, ci.levels, 1.0))
-
- h2d <- hist2d(x,y, show=FALSE, nbins=nbins, ...)
- h2d$density <- h2d$counts / sum(h2d$counts, na.rm=TRUE)
+ # get labels for x and y
+ if (missing(xlab))
+ xlab <- if (missing(x))
+ ""
+ else deparse(substitute(x))
+ if (missing(ylab))
+ ylab <- if (missing(y))
+ ""
+ else deparse(substitute(y))
+
+ if(!is.null(y))
+ x <- cbind(x,y)
+
+ if(method=="hist2d")
+ {
+ h2d <- hist2d(x,
+ show=FALSE,
+ nbins=nbins,
+ ...)
+ ## normalize
+ h2d$density <- h2d$counts / sum(h2d$counts, na.rm=TRUE)
+ }
+ else if (method=="bkde2D")
+ {
+ if(length(nbins)==1)
+ nbins <- c(nbins, nbins)
+
+ if(missing(bandwidth))
+ {
+ h.x = dpik(x[,1])
+ h.y = dpik(x[,2])
+ bandwidth <- c(h.x, h.y)
+ }
+
+ est <- bkde2D(x,
+ bandwidth=bandwidth*factor,
+ gridsize=nbins,
+ ...
+ )
+
+ h2d <- list()
+ h2d$x <- est$x1
+ h2d$y <- est$x2
+ h2d$counts <- est$fhat
+ h2d$density <- est$fhat / sum(est$fhat) # normalize
+
+ }
+ else
+ stop("Unknown method: '", method, "'")
+
uniqueVals <- rev(unique(sort(h2d$density)))
cumProbs <- sapply(uniqueVals,
function(val) sum( h2d$density[h2d$density>=val] ) )
@@ -49,14 +105,26 @@
image(h2d$x, h2d$y, h2d$cumDensity,
xlab=xlab, ylab=ylab,
breaks=breaks, col=col)
+ if(show.points)
+ points(x[,1], x[,2], pch=pch, col=points.col);
}
else if(show=="filled.contour")
{
+ if(show.points)
+ plot.title <- function() {
+ points(x[,1], x[,2], pch=pch, col=points.col);
+ }
+ else
+ plot.title <- function() {}
+
+
filled.contour(h2d$x, h2d$y, h2d$cumDensity,
levels=breaks,
col=col,
- key.axes={ axis(4, at=breaks);
- title("\nCI Level") }
+ xlab=xlab,
+ ylab=ylab,
+ plot.title=plot.title(),
+ key.title=title("\nCI Level")
)
}
else if(show=="contour")
@@ -65,14 +133,26 @@
contour(h2d$x, h2d$y, h2d$cumDensity,
levels=tmpBreaks,
labels=tmpBreaks,
+ xlab=xlab,
+ ylab=ylab,
nlevels=length(tmpBreaks),
col=col
)
+ if(show.points)
+ points(x[,1], x[,2], pch=pch, col=points.col);
}
-
h2d$contours <- contourLines(h2d$x, h2d$y, h2d$cumDensity,
levels=breaks, nlevels=length(breaks))
- names
+
+ # use the confidence level value as the name in the contour list
+ names(h2d$contours) <- sapply(h2d$contours, function(x) x$level)
+
+ # convert each contour into a (x,y) dataframe
+ h2d$contours <- lapply( h2d$contours,
+ function(J) data.frame(x=J$x, y=J$y) )
+
+ h2d$call <- match.call()
+
invisible(h2d)
}
Modified: trunk/gplots/man/ci2d.Rd
===================================================================
--- trunk/gplots/man/ci2d.Rd 2011-09-01 19:26:23 UTC (rev 1485)
+++ trunk/gplots/man/ci2d.Rd 2011-09-01 19:37:38 UTC (rev 1486)
@@ -1,3 +1,4 @@
+% $Id$
\name{ci2d}
\alias{ci2d}
\title{
@@ -4,18 +5,23 @@
Create 2-dimensional empirical confidence regions
}
\description{
- Create 2-dimensional empirical confidence regions based on a
- 2-dimensoinal histogram.
+ Create 2-dimensional empirical confidence regions from provided data.
}
\usage{
-ci2d(x, y=NULL,
- nbins=25,
- ci.levels=c(0.5, 0.75, 0.9, 0.95, 0.975),
- show=c("filled.contour", "contour", "image", "none"),
- xlab=deparse(substitute(x)),
- ylab=deparse(substitute(y)),
- col=topo.colors(length(breaks) - 1),
- ...)
+ci2d <- function(x,
+ y = NULL,
+ nbins=51,
+ method=c("bkde2D","hist2d"),
+ bandwidth,
+ factor=1.0,
+ ci.levels=c(0.50,0.75,0.90,0.95,0.975),
+ show=c("filled.contour","contour","image","none"),
+ col=topo.colors(length(breaks)-1),
+ show.points=FALSE,
+ pch=par("pch"),
+ points.col="red",
+ xlab, ylab,
+ ...)
}
\arguments{
\item{x}{either a vector containing the x coordinates
@@ -23,51 +29,232 @@
\item{y}{a vector contianing the y coordinates, not required if `x'
is matrix}
\item{nbins}{number of bins in each dimension. May be a scalar or a
- 2 element vector. Defaults to 25.}
+ 2 element vector. Defaults to 51.}
+ \item{method}{One of "bkde2D" (for KernSmooth::bdke2d) or "hist2d"
+ (for gplots::hist2d) specifyting the name of the method to create
+ the 2-d density summarizing the data. Defaults to "bkde2D".}
+ \item{bandwidth}{Bandwidth to use for \code{KernSmooth::bkde2D}.
+ See below for default value. }
\item{ci.levels}{Confidence level(s) to use for plotting
data. Defaults to \code{c(0.5, 0.75, 0.9, 0.95, 0.975)} }
\item{show}{Plot type to be displaed. One of "filled.contour",
"contour", "image", or "none". Defaults to "filled.contour".}
+ \item{show.points}{Boolean indicating whether original data values
+ should be plotted. Defaults to \code{TRUE}.}
+ \item{pch}{Point type for plots. See \code{points} for details.}
+ \item{points.col}{Point color for plotting original data. Defaiults to
+ "red".}
+ \item{col}{Colors to use for plots.}
\item{xlab, ylab}{Axis labels}
- \item{col}{Colors to use for plots.}
- \item{\dots}{Additional arguments passed to \code{hist2d}. }
+ \item{\dots}{Additional arguments passed to \code{KernSmooth::bkde2D}
+ or \code{gplots::hist2d}. }
}
\details{
- This function utilizes \code{hist2d} to create a 2-dimensional
- histogram of the data passed as an argument. This data is then
- converted into densities and used to create and display confidence
- regions.
+ This function utilizes either \code{KernSmooth::bkde2D} or
+ \code{gplots::hist2d} to estmate a 2-dimensional density of the data
+ passed as an argument. This density is then used to create and
+ (optionally) display confidence regions.
+
+ When \code{bandwidth} is ommited and \code{method="bkde2d"},
+ \code{KernSmooth::dpik} is appled in x and y dimensions to select the
+ bandwidth.
+
}
+\note{
+ Confidence intervals generated by ci2d are \emph{approximate}, and
+ are subject to biases and/or artifacts induced by the binning or
+ kernel smoothing method, bin locations, bin sizes, and kernel bandwidth.
+ }
\value{
- A list containing 3 elements:
- \item{counts}{Matrix containing the number of points falling into each
- bin}
- \item{x}{lower x limit of each bin}
- \item{y}{lower y limit of each bin}
- \item{density}{Matrix containing the probability density of each bin (count in bin/total
- count)}
- \item{cumDensity}{Matrix where each element contains the cumulative probability density
- of all elements with the same density (used to create the confidence
- region plots) }
- \item{contours}{Contours of each confidence region}
+ A list containing (at least) the following elements:
+ \item{x}{x position of each density estimate bin}
+ \item{y}{y position of each density estimate bin}
+ \item{density}{Matrix containing the probability density of each bin
+ (count in bin/total count)}
+ \item{cumDensity}{Matrix where each element contains the cumulative
+ probability density of all elements with the same density (used to
+ create the confidence region plots) }
+ \item{contours}{Contours of each confidence region}.
+ \item{call}{Call used to create this object}
}
%\references{
%}
\author{ Gregory R. Warnes \email{gr...@wa...}}
\seealso{
+ \code{\link[KernSmooth]{bkde2D}}, \code{\link[KernSmooth]{dpik}},
\code{\link{hist2d}}
}
\examples{
- # example data, bivariate normal, no correlation
+ ####
+ ## Basic usage
+ ####
+ data(geyser, package="MASS")
+
+ x <- geyser$duration
+ y <- geyser$waiting
+
+ # 2-d confidence intervals based on binned kernel density estimate
+ ci2d(x,y) # filled contour plot
+ ci2d(x,y, show.points=TRUE) # show original data
+
+
+ # image plot
+ ci2d(x,y, show="image")
+ ci2d(x,y, show="image", show.points=TRUE)
+
+ # contour plot
+ ci2d(x,y, show="contour", col="black")
+ ci2d(x,y, show="contour", col="black", show.points=TRUE)
+
+ ####
+ ## Control Axis scales
+ ####
x <- rnorm(2000, sd=4)
y <- rnorm(2000, sd=1)
+ # 2-d confidence intervals based on binned kernel density estimate
+ ci2d(x,y)
+
# 2-d confidence intervals based on 2d histogram
+ ci2d(x,y, method="hist2d", nbins=25)
+
+ # Require same scale for each axis, this looks oval
+ ci2d(x,y, range.x=list(c(-20,20), c(-20,20)))
+ ci2d(x,y, method="hist2d", same.scale=TRUE, nbins=25) # hist2d
+
+ ####
+ ## Control smoothing and binning
+ ####
+ x <- rnorm(2000, sd=4)
+ y <- rnorm(2000, mean=x, sd=2)
+
+ # Default 2-d confidence intervals based on binned kernel density estimate
ci2d(x,y)
- # same scale for each axis, this looks oval
- ci2d(x,y, same.scale=TRUE)
+ # change the smoother bandwidth
+ ci2d(x,y,
+ bandwidth=c(sd(x)/8, sd(y)/8)
+ )
+ # change the smoother number of bins
+ ci2d(x,y, nbins=10)
+ ci2d(x,y)
+ ci2d(x,y, nbins=100)
+
+ # Default 2-d confidence intervals based on 2d histogram
+ ci2d(x,y, method="hist2d", show.points=TRUE)
+
+ # change the number of histogram bins
+ ci2d(x,y, nbin=10, method="hist2d", show.points=TRUE )
+ ci2d(x,y, nbin=25, method="hist2d", show.points=TRUE )
+
+ ####
+ ## Perform plotting manually
+ ####
+ data(geyser, package="MASS")
+
+ # let ci2d handle plotting contours...
+ ci2d(geyser$duration, geyser$waiting, show="contour", col="black")
+
+ # call contour() directly, show the 90 percent CI, and the mean point
+ est <- ci2d(geyser$duration, geyser$waiting, show="none")
+ contour(est$x, est$y, est$cumDensity,
+ xlab="duration", ylab="waiting",
+ levels=0.90, lwd=4, lty=2)
+ points(mean(geyser$duration), mean(geyser$waiting),
+ col="red", pch="X")
+
+
+ ####
+ ## Extract confidence region values
+ ###
+ data(geyser, package="MASS")
+
+ ## Empirical 90 percent confidence limits
+ quantile( geyser$duration, c(0.05, 0.95) )
+ quantile( geyser$waiting, c(0.05, 0.95) )
+
+ ## Bivariate 90 percent confidence region
+ est <- ci2d(geyser$duration, geyser$waiting, show="none")
+ names(est$contours) ## show available contours
+
+ ci.90 <- est$contours[names(est$contours)=="0.9"] # get region(s)
+ ci.90 <- rbind(ci.90[[1]],NA, ci.90[[2]], NA, ci.90[[3]]) # join them
+
+ print(ci.90) # show full contour
+ range(ci.90$x, na.rm=TRUE) # range for duration
+ range(ci.90$y, na.rm=TRUE) # range for waiting
+
+ ####
+ ## Visually compare confidence regions
+ ####
+ data(geyser, package="MASS")
+
+ ## Bivariate smoothed 90 percent confidence region
+ est <- ci2d(geyser$duration, geyser$waiting, show="none")
+ names(est$contours) ## show available contours
+
+ ci.90 <- est$contours[names(est$contours)=="0.9"] # get region(s)
+ ci.90 <- rbind(ci.90[[1]],NA, ci.90[[2]], NA, ci.90[[3]]) # join them
+
+ plot( waiting ~ duration, data=geyser,
+ main="Comparison of 90 percent confidence regions" )
+ polygon( ci.90, col="green", border="green", density=10)
+
+ ## Univariate Normal-Theory 90 percent confidence region
+ mean.x <- mean(geyser$duration)
+ mean.y <- mean(geyser$waiting)
+ sd.x <- sd(geyser$duration)
+ sd.y <- sd(geyser$waiting)
+
+ t.value <- qt(c(0.05,0.95), df=nobs(geyser$duration), lower=TRUE)
+ ci.x <- mean.x + t.value* sd.x
+ ci.y <- mean.y + t.value* sd.y
+
+ plotCI(mean.x, mean.y,
+ li=ci.x[1],
+ ui=ci.x[2],
+ barcol="blue", col="blue",
+ err="x",
+ pch="X",
+ add=TRUE )
+
+ plotCI(mean.x, mean.y,
+ li=ci.y[1],
+ ui=ci.y[2],
+ barcol="blue", col="blue",
+ err="y",
+ pch=NA,
+ add=TRUE )
+
+# rect(ci.x[1], ci.y[1], ci.x[2], ci.y[2], border="blue",
+# density=5,
+# angle=45,
+# col="blue" )
+
+
+ ## Empirical univariate 90 percent confidence region
+ box <- cbind( x=quantile( geyser$duration, c(0.05, 0.95 )),
+ y=quantile( geyser$waiting, c(0.05, 0.95 )) )
+
+ rect(box[1,1], box[1,2], box[2,1], box[2,2], border="red",
+ density=5,
+ angle=-45,
+ col="red" )
+
+ ## now a nice legend
+ legend( "topright", legend=c(" Region type",
+ "Univariate Normal Theory",
+ "Univarite Empirical",
+ "Smoothed Bivariate"),
+ lwd=c(NA,1,1,1),
+ col=c("black","blue","red","green"),
+ lty=c(NA,1,1,1)
+ )
+
+
+
+
}
% Add one or more standard keywords, see file 'KEYWORDS' in the
% R documentation directory.
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <wa...@us...> - 2011-09-01 19:47:09
|
Revision: 1489
http://r-gregmisc.svn.sourceforge.net/r-gregmisc/?rev=1489&view=rev
Author: warnes
Date: 2011-09-01 19:47:03 +0000 (Thu, 01 Sep 2011)
Log Message:
-----------
- Update NEWS file and correct version number
Modified Paths:
--------------
trunk/gplots/DESCRIPTION
trunk/gplots/inst/NEWS
Modified: trunk/gplots/DESCRIPTION
===================================================================
--- trunk/gplots/DESCRIPTION 2011-09-01 19:41:02 UTC (rev 1488)
+++ trunk/gplots/DESCRIPTION 2011-09-01 19:47:03 UTC (rev 1489)
@@ -5,7 +5,7 @@
Recommends: datasets, grid, MASS, KernSmooth
Requires: R (>= 2.10)
Suggests: gtools
-Version: 2.9.5
+Version: 2.10.0
Date: 2011-09-01
Author: Gregory R. Warnes. Includes R source code and/or documentation
contributed by (in alphabetical order):
Modified: trunk/gplots/inst/NEWS
===================================================================
--- trunk/gplots/inst/NEWS 2011-09-01 19:41:02 UTC (rev 1488)
+++ trunk/gplots/inst/NEWS 2011-09-01 19:47:03 UTC (rev 1489)
@@ -4,7 +4,8 @@
New Features:
- New ci2d() function to create 2-dimensional empirical confidence
- intervals utilizing hist2d(). See ?ci2d for details.
+ intervals utilizing KernSmooth:bkde2D and gplots::hist2d().
+ See ?ci2d for details.
- Add 'alpha' argument to rich.colors() to control transparency.
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <wa...@us...> - 2011-09-01 20:10:50
|
Revision: 1490
http://r-gregmisc.svn.sourceforge.net/r-gregmisc/?rev=1490&view=rev
Author: warnes
Date: 2011-09-01 20:10:44 +0000 (Thu, 01 Sep 2011)
Log Message:
-----------
- Comment out import from KernSmooth in NAMESPACES, since KernSmooth
doesn't provide a namespace.
- Update a test output.
Modified Paths:
--------------
trunk/gplots/DESCRIPTION
trunk/gplots/NAMESPACE
trunk/gplots/tests/heatmap2Test.Rout.save
Modified: trunk/gplots/DESCRIPTION
===================================================================
--- trunk/gplots/DESCRIPTION 2011-09-01 19:47:03 UTC (rev 1489)
+++ trunk/gplots/DESCRIPTION 2011-09-01 20:10:44 UTC (rev 1490)
@@ -1,8 +1,8 @@
Package: gplots
Title: Various R programming tools for plotting data
Description: Various R programming tools for plotting data
-Depends: gtools, gdata, stats, caTools, grid
-Recommends: datasets, grid, MASS, KernSmooth
+Depends: gtools, gdata, stats, caTools, grid, KernSmooth
+Recommends: datasets, grid, MASS
Requires: R (>= 2.10)
Suggests: gtools
Version: 2.10.0
Modified: trunk/gplots/NAMESPACE
===================================================================
--- trunk/gplots/NAMESPACE 2011-09-01 19:47:03 UTC (rev 1489)
+++ trunk/gplots/NAMESPACE 2011-09-01 20:10:44 UTC (rev 1490)
@@ -43,8 +43,9 @@
#importFrom(caTools, runsd)
#importFrom(caTools, runmean)
-importFrom(KernSmooth, bkdeD2)
-importFrom(KernSmooth, dpik)
+# No Namespace
+#importFrom(KernSmooth, bkdeD2)
+#importFrom(KernSmooth, dpik)
Modified: trunk/gplots/tests/heatmap2Test.Rout.save
===================================================================
--- trunk/gplots/tests/heatmap2Test.Rout.save 2011-09-01 19:47:03 UTC (rev 1489)
+++ trunk/gplots/tests/heatmap2Test.Rout.save 2011-09-01 20:10:44 UTC (rev 1490)
@@ -1,7 +1,8 @@
-R version 2.10.0 alpha (2009-10-08 r49995)
-Copyright (C) 2009 The R Foundation for Statistical Computing
+R version 2.12.1 (2010-12-16)
+Copyright (C) 2010 The R Foundation for Statistical Computing
ISBN 3-900051-07-0
+Platform: i686-pc-linux-gnu (32-bit)
R is free software and comes with ABSOLUTELY NO WARRANTY.
You are welcome to redistribute it under certain conditions.
@@ -18,25 +19,29 @@
> library(gplots)
Loading required package: gtools
Loading required package: gdata
+gdata: read.xls support for 'XLS' (Excel 97-2004) files ENABLED.
+gdata: read.xls support for 'XLSX' (Excel 2007+) files ENABLED.
+
Attaching package: 'gdata'
+The following object(s) are masked from 'package:utils':
- The following object(s) are masked from package:utils :
+ object.size
- object.size
-
Loading required package: caTools
Loading required package: bitops
Loading required package: grid
+Loading required package: KernSmooth
+KernSmooth 2.23 loaded
+Copyright M. P. Wand 1997-2009
Attaching package: 'gplots'
+The following object(s) are masked from 'package:stats':
- The following object(s) are masked from package:stats :
+ lowess
- lowess
-
>
> data(mtcars)
> x <- as.matrix(mtcars)
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <wa...@us...> - 2011-09-01 21:41:16
|
Revision: 1491
http://r-gregmisc.svn.sourceforge.net/r-gregmisc/?rev=1491&view=rev
Author: warnes
Date: 2011-09-01 21:41:10 +0000 (Thu, 01 Sep 2011)
Log Message:
-----------
- Correct issues in ci2d() man page.
Modified Paths:
--------------
trunk/gplots/NAMESPACE
trunk/gplots/man/ci2d.Rd
Modified: trunk/gplots/NAMESPACE
===================================================================
--- trunk/gplots/NAMESPACE 2011-09-01 20:10:44 UTC (rev 1490)
+++ trunk/gplots/NAMESPACE 2011-09-01 21:41:10 UTC (rev 1491)
@@ -47,8 +47,6 @@
#importFrom(KernSmooth, bkdeD2)
#importFrom(KernSmooth, dpik)
-
-
S3method(balloonplot,default)
S3method(balloonplot,table)
Modified: trunk/gplots/man/ci2d.Rd
===================================================================
--- trunk/gplots/man/ci2d.Rd 2011-09-01 20:10:44 UTC (rev 1490)
+++ trunk/gplots/man/ci2d.Rd 2011-09-01 21:41:10 UTC (rev 1491)
@@ -8,20 +8,17 @@
Create 2-dimensional empirical confidence regions from provided data.
}
\usage{
-ci2d <- function(x,
- y = NULL,
- nbins=51,
- method=c("bkde2D","hist2d"),
- bandwidth,
- factor=1.0,
- ci.levels=c(0.50,0.75,0.90,0.95,0.975),
- show=c("filled.contour","contour","image","none"),
- col=topo.colors(length(breaks)-1),
- show.points=FALSE,
- pch=par("pch"),
- points.col="red",
- xlab, ylab,
- ...)
+ci2d(x, y = NULL,
+ nbins=51, method=c("bkde2D","hist2d"),
+ bandwidth, factor=1.0,
+ ci.levels=c(0.50,0.75,0.90,0.95,0.975),
+ show=c("filled.contour","contour","image","none"),
+ col=topo.colors(length(breaks)-1),
+ show.points=FALSE,
+ pch=par("pch"),
+ points.col="red",
+ xlab, ylab,
+ ...)
}
\arguments{
\item{x}{either a vector containing the x coordinates
@@ -35,6 +32,8 @@
the 2-d density summarizing the data. Defaults to "bkde2D".}
\item{bandwidth}{Bandwidth to use for \code{KernSmooth::bkde2D}.
See below for default value. }
+ \item{factor}{Numeric scaling factor for bandwidth. Useful for
+ exploring effect of changing the bandwidth. Defaults to 1.0.}
\item{ci.levels}{Confidence level(s) to use for plotting
data. Defaults to \code{c(0.5, 0.75, 0.9, 0.95, 0.975)} }
\item{show}{Plot type to be displaed. One of "filled.contour",
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <wa...@us...> - 2011-09-02 18:14:45
|
Revision: 1501
http://r-gregmisc.svn.sourceforge.net/r-gregmisc/?rev=1501&view=rev
Author: warnes
Date: 2011-09-02 18:14:37 +0000 (Fri, 02 Sep 2011)
Log Message:
-----------
Provide print() methods for 'hist2d' and 'ci2d' objects.
Modified Paths:
--------------
trunk/gplots/NAMESPACE
trunk/gplots/R/ci2d.R
trunk/gplots/R/hist2d.R
trunk/gplots/man/ci2d.Rd
trunk/gplots/man/hist2d.Rd
Added Paths:
-----------
trunk/gplots/R/print.ci2d.R
trunk/gplots/R/print.hist2d
Modified: trunk/gplots/NAMESPACE
===================================================================
--- trunk/gplots/NAMESPACE 2011-09-02 17:25:11 UTC (rev 1500)
+++ trunk/gplots/NAMESPACE 2011-09-02 18:14:37 UTC (rev 1501)
@@ -62,3 +62,5 @@
S3method(textplot,default)
S3method(textplot,matrix)
+S3method(print,ci2d)
+S3method(print,hist2d)
Modified: trunk/gplots/R/ci2d.R
===================================================================
--- trunk/gplots/R/ci2d.R 2011-09-02 17:25:11 UTC (rev 1500)
+++ trunk/gplots/R/ci2d.R 2011-09-02 18:14:37 UTC (rev 1501)
@@ -1,4 +1,4 @@
-## $Id$
+# $Id: hist2d.R 1471 2011-08-16 01:03:31Z warnes $
## first(...) selects the first element of which(...)
first <- function(x,...)
@@ -87,8 +87,8 @@
h2d$x <- est$x1
h2d$y <- est$x2
h2d$counts <- est$fhat
+ h2d$nobs <- nrow(x)
h2d$density <- est$fhat / sum(est$fhat) # normalize
-
}
else
stop("Unknown method: '", method, "'")
@@ -124,7 +124,8 @@
xlab=xlab,
ylab=ylab,
plot.title=plot.title(),
- key.title=title("\nCI Level")
+ key.title=title("\nCI Level"),
+ key.axes=axis(4, at=breaks)
)
}
else if(show=="contour")
@@ -153,6 +154,8 @@
function(J) data.frame(x=J$x, y=J$y) )
h2d$call <- match.call()
+ class(h2d) <- "ci2d"
invisible(h2d)
}
+
Modified: trunk/gplots/R/hist2d.R
===================================================================
--- trunk/gplots/R/hist2d.R 2011-09-02 17:25:11 UTC (rev 1500)
+++ trunk/gplots/R/hist2d.R 2011-09-02 18:14:37 UTC (rev 1501)
@@ -1,16 +1,14 @@
# $Id$
-if(is.R())
-
- hist2d <- function(x,
- y=NULL,
- nbins=200,
- same.scale=FALSE,
- na.rm=TRUE,
- show=TRUE,
- col=c("black", heat.colors(12)),
- FUN=base::length,
- ... )
+hist2d <- function(x,
+ y=NULL,
+ nbins=200,
+ same.scale=FALSE,
+ na.rm=TRUE,
+ show=TRUE,
+ col=c("black", heat.colors(12)),
+ FUN=base::length,
+ ... )
{
if(is.null(y))
{
@@ -53,12 +51,19 @@
## If we're using length, set empty cells to 0 instead of NA
if(identical(FUN,base::length))
m[is.na(m)] <- 0
-
+
xvals <- x.cuts[1:nbins[1]]
yvals <- y.cuts[1:nbins[2]]
if(show)
image( xvals,yvals, m, col=col,...)
- invisible(list(counts=m,x=xvals,y=yvals))
+ retval <- list()
+ retval$counts <- m
+ retval$x=xvals
+ retval$y=yvals
+ retval$nobs=length(x)
+ retval$call <- match.call()
+ class(retval) <- "hist2d"
+ retval
}
Added: trunk/gplots/R/print.ci2d.R
===================================================================
--- trunk/gplots/R/print.ci2d.R (rev 0)
+++ trunk/gplots/R/print.ci2d.R 2011-09-02 18:14:37 UTC (rev 1501)
@@ -0,0 +1,34 @@
+## $Id$
+
+print.ci2d <- function(x, ...)
+ {
+ cat("\n")
+ cat("----------------------------\n")
+ cat("2-D Confidence Region Object\n")
+ cat("----------------------------\n")
+ cat("\n")
+ cat("Call: ")
+ print(x$call)
+ cat("\n")
+ cat("Number of data points: ", x$nobs, "\n")
+ cat("Number of grid points: ", length(x$x), "x", length(x$y), "\n")
+ cat("Number of confidence regions:", length(x$contours), "\n")
+ cat("\n")
+
+ tab <- data.frame(
+ "Region"=1:length(x$contours),
+ "CI Level"=as.numeric(names(x$contours)),
+ "X Min"=sapply(x$contours, function(XX) min(XX$x)),
+ "X Max"=sapply(x$contours, function(XX) max(XX$x)),
+ "Y Min"=sapply(x$contours, function(XX) min(XX$y)),
+ "Y Max"=sapply(x$contours, function(XX) max(XX$y))
+ )
+
+ print(tab, row.names=FALSE, ...)
+
+ x$summary <- tab
+
+ class(x) <- c("ci2d.summary", "ci2d")
+
+ return(x)
+ }
Added: trunk/gplots/R/print.hist2d
===================================================================
--- trunk/gplots/R/print.hist2d (rev 0)
+++ trunk/gplots/R/print.hist2d 2011-09-02 18:14:37 UTC (rev 1501)
@@ -0,0 +1,19 @@
+# $Id: hist2d.R 1471 2011-08-16 01:03:31Z warnes $
+
+print.hist2d <- function(x, ...)
+ {
+ cat("\n")
+ cat("----------------------------\n")
+ cat("2-D Histogram Object\n")
+ cat("----------------------------\n")
+ cat("\n")
+ cat("Call: ")
+ print(x$call)
+ cat("\n")
+ cat("Number of data points: ", x$nobs, "\n")
+ cat("Number of grid points: ", length(x$x), "x", length(x$y), "\n")
+ cat("X range: (", min(x$x), ",", max(x$x), ")\n")
+ cat("Y range: (", min(x$y), ",", max(x$y), ")\n")
+ cat("\n")
+
+ }
Modified: trunk/gplots/man/ci2d.Rd
===================================================================
--- trunk/gplots/man/ci2d.Rd 2011-09-02 17:25:11 UTC (rev 1500)
+++ trunk/gplots/man/ci2d.Rd 2011-09-02 18:14:37 UTC (rev 1501)
@@ -19,6 +19,7 @@
points.col="red",
xlab, ylab,
...)
+\method{print}{ci2d}(x, ...)
}
\arguments{
\item{x}{either a vector containing the x coordinates
@@ -65,7 +66,9 @@
kernel smoothing method, bin locations, bin sizes, and kernel bandwidth.
}
\value{
- A list containing (at least) the following elements:
+ A \code{ci2d} object consisting of a list containing (at least) the
+ following elements:
+ \item{nobs}{number of original data points}
\item{x}{x position of each density estimate bin}
\item{y}{y position of each density estimate bin}
\item{density}{Matrix containing the probability density of each bin
@@ -73,11 +76,9 @@
\item{cumDensity}{Matrix where each element contains the cumulative
probability density of all elements with the same density (used to
create the confidence region plots) }
- \item{contours}{Contours of each confidence region}.
+ \item{contours}{List of contours of each confidence region.}
\item{call}{Call used to create this object}
}
-%\references{
-%}
\author{ Gregory R. Warnes \email{gr...@wa...}}
\seealso{
\code{\link[KernSmooth]{bkde2D}}, \code{\link[KernSmooth]{dpik}},
@@ -251,12 +252,18 @@
lty=c(NA,1,1,1)
)
-
+ ####
+ ## Test with a large number of points
+ ####
+ x <- rnorm(60000, sd=1)
+ y <- c( rnorm(40000, mean=x, sd=1),
+ rnorm(20000, mean=x+4, sd=1) )
+ hist2d(x,y)
+ ci <- ci2d(x,y)
+ ci
}
-% Add one or more standard keywords, see file 'KEYWORDS' in the
-% R documentation directory.
\keyword{dplot}
\keyword{hplot}
\keyword{nonparametric}
Modified: trunk/gplots/man/hist2d.Rd
===================================================================
--- trunk/gplots/man/hist2d.Rd 2011-09-02 17:25:11 UTC (rev 1500)
+++ trunk/gplots/man/hist2d.Rd 2011-09-02 18:14:37 UTC (rev 1501)
@@ -8,6 +8,7 @@
\usage{
hist2d(x,y=NULL, nbins=200, same.scale=FALSE, na.rm=TRUE, show=TRUE,
col=c("black", heat.colors(12)), FUN=base::length, ... )
+\method{print}{hist2d}(x, ...)
}
\arguments{
\item{x}{either a vector containing the x coordinates
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <wa...@us...> - 2011-12-09 09:22:35
|
Revision: 1519
http://r-gregmisc.svn.sourceforge.net/r-gregmisc/?rev=1519&view=rev
Author: warnes
Date: 2011-12-09 09:22:25 +0000 (Fri, 09 Dec 2011)
Log Message:
-----------
Add 'lwd' (linewidth) to arguments handled by plotmeans.
Modified Paths:
--------------
trunk/gplots/R/plotmeans.R
trunk/gplots/man/plotmeans.Rd
Modified: trunk/gplots/R/plotmeans.R
===================================================================
--- trunk/gplots/R/plotmeans.R 2011-10-05 17:05:54 UTC (rev 1518)
+++ trunk/gplots/R/plotmeans.R 2011-12-09 09:22:25 UTC (rev 1519)
@@ -13,6 +13,7 @@
legends=names(means),
xaxt,
use.t = TRUE,
+ lwd,
...)
{
is.R <- get("is.R")
@@ -47,7 +48,7 @@
m$col <- m$barwidth <- NULL
m$digits <- m$mean.labels <- m$ci.label <- m$n.label <- NULL
m$connect <- m$ccol <- m$legends <- m$labels<- NULL
- m$xaxt <- m$use.t <- NULL
+ m$xaxt <- m$use.t <- m$lwd <- NULL
m[[1]] <- as.name("model.frame")
mf <- eval(m, parent.frame())
response <- attr(attr(mf, "terms"), "response")
@@ -141,7 +142,7 @@
lines(x=connect[[which]],y=means[connect[[which]]],col=ccol[which])
}
else
- lines(means, ..., col=ccol)
+ lines(means, ..., lwd=lwd, col=ccol)
}
Modified: trunk/gplots/man/plotmeans.Rd
===================================================================
--- trunk/gplots/man/plotmeans.Rd 2011-10-05 17:05:54 UTC (rev 1518)
+++ trunk/gplots/man/plotmeans.Rd 2011-12-09 09:22:25 UTC (rev 1519)
@@ -11,7 +11,8 @@
xlab=names(mf)[2], ylab=names(mf)[1], mean.labels=FALSE,
ci.label=FALSE, n.label=TRUE, digits=getOption("digits"),
col="black", barwidth=1, barcol="blue",
- connect=TRUE, ccol=col, legends=names(means), xaxt, use.t=TRUE, ...)
+ connect=TRUE, ccol=col, legends=names(means), xaxt,
+ use.t=TRUE, lwd, ...)
}
%
%\usage{
@@ -91,7 +92,9 @@
default, a t distribution will the correct number of degrees of
freedom for each group be used. If \code{FALSE}, the a normal
distribution will be used.}
-
+
+ \item{lwd}{Width of connecting lines }
+
\item{\dots}{ optional plotting parameters. }
}
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <wa...@us...> - 2012-06-07 15:03:35
|
Revision: 1553
http://r-gregmisc.svn.sourceforge.net/r-gregmisc/?rev=1553&view=rev
Author: warnes
Date: 2012-06-07 15:03:24 +0000 (Thu, 07 Jun 2012)
Log Message:
-----------
Add default value for lwd argument to plotmeans()
Modified Paths:
--------------
trunk/gplots/R/plotmeans.R
trunk/gplots/man/plotmeans.Rd
Modified: trunk/gplots/R/plotmeans.R
===================================================================
--- trunk/gplots/R/plotmeans.R 2012-06-06 22:10:39 UTC (rev 1552)
+++ trunk/gplots/R/plotmeans.R 2012-06-07 15:03:24 UTC (rev 1553)
@@ -13,7 +13,7 @@
legends=names(means),
xaxt,
use.t = TRUE,
- lwd,
+ lwd=par("lwd"),
...)
{
is.R <- get("is.R")
Modified: trunk/gplots/man/plotmeans.Rd
===================================================================
--- trunk/gplots/man/plotmeans.Rd 2012-06-06 22:10:39 UTC (rev 1552)
+++ trunk/gplots/man/plotmeans.Rd 2012-06-07 15:03:24 UTC (rev 1553)
@@ -12,7 +12,7 @@
ci.label=FALSE, n.label=TRUE, digits=getOption("digits"),
col="black", barwidth=1, barcol="blue",
connect=TRUE, ccol=col, legends=names(means), xaxt,
- use.t=TRUE, lwd, ...)
+ use.t=TRUE, lwd=par("lwd"), ...)
}
%
%\usage{
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <wa...@us...> - 2012-06-07 16:08:29
|
Revision: 1555
http://r-gregmisc.svn.sourceforge.net/r-gregmisc/?rev=1555&view=rev
Author: warnes
Date: 2012-06-07 16:08:18 +0000 (Thu, 07 Jun 2012)
Log Message:
-----------
Object returned by hist2d() has been changed:
- $x and $y now contain the n midpoints of the bins in each direction
- $x.breaks, $y.breaks now contain the n+1 limits of the bins in each direction
The function print.hist2d() has been updated appropriately.
Modified Paths:
--------------
trunk/gplots/R/ci2d.R
trunk/gplots/R/hist2d.R
trunk/gplots/R/print.hist2d.R
trunk/gplots/man/hist2d.Rd
Modified: trunk/gplots/R/ci2d.R
===================================================================
--- trunk/gplots/R/ci2d.R 2012-06-07 15:19:02 UTC (rev 1554)
+++ trunk/gplots/R/ci2d.R 2012-06-07 16:08:18 UTC (rev 1555)
@@ -1,4 +1,4 @@
-# $Id: hist2d.R 1471 2011-08-16 01:03:31Z warnes $
+# $Id: ci2d.R 1471 2011-08-16 01:03:31Z warnes $
## first(...) selects the first element of which(...)
first <- function(x,...)
Modified: trunk/gplots/R/hist2d.R
===================================================================
--- trunk/gplots/R/hist2d.R 2012-06-07 15:19:02 UTC (rev 1554)
+++ trunk/gplots/R/hist2d.R 2012-06-07 16:08:18 UTC (rev 1555)
@@ -8,6 +8,8 @@
show=TRUE,
col=c("black", heat.colors(12)),
FUN=base::length,
+ xlab,
+ ylab,
... )
{
if(is.null(y))
@@ -32,13 +34,13 @@
if(same.scale)
{
- x.cuts <- seq( from=min(x,y), to=max(x,y), length=nbins[1])
- y.cuts <- seq( from=min(x,y), to=max(x,y), length=nbins[2])
+ x.cuts <- seq( from=min(x,y), to=max(x,y), length=nbins[1]+1)
+ y.cuts <- seq( from=min(x,y), to=max(x,y), length=nbins[2]+1)
}
else
{
- x.cuts <- seq( from=min(x), to=max(x), length=nbins[1])
- y.cuts <- seq( from=min(y), to=max(y), length=nbins[2])
+ x.cuts <- seq( from=min(x), to=max(x), length=nbins[1]+1)
+ y.cuts <- seq( from=min(y), to=max(y), length=nbins[2]+1)
}
index.x <- cut( x, x.cuts, include.lowest=TRUE)
@@ -51,15 +53,22 @@
## If we're using length, set empty cells to 0 instead of NA
if(identical(FUN,base::length))
m[is.na(m)] <- 0
+
+ if(missing(xlab)) xlab <- deparse(substitute(xlab))
+ if(missing(ylab)) ylab <- deparse(substitute(ylab))
if(show)
- image( x.cuts, y.cuts, m, col=col, ...)
+ image( x.cuts, y.cuts, m, col=col, xlab=xlab, ylab=ylab, ...)
+ midpoints <- function(x) (x[-1]+x[-length(x)])/2
+
retval <- list()
retval$counts <- m
- retval$x=x.cuts
- retval$y=y.cuts
- retval$nobs=length(x)
+ retval$x.breaks = x.cuts
+ retval$y.breaks = y.cuts
+ retval$x = midpoints(x.cuts)
+ retval$y = midpoints(y.cuts)
+ retval$nobs = length(x)
retval$call <- match.call()
class(retval) <- "hist2d"
retval
Modified: trunk/gplots/R/print.hist2d.R
===================================================================
--- trunk/gplots/R/print.hist2d.R 2012-06-07 15:19:02 UTC (rev 1554)
+++ trunk/gplots/R/print.hist2d.R 2012-06-07 16:08:18 UTC (rev 1555)
@@ -2,7 +2,7 @@
print.hist2d <- function(x, ...)
{
- cat("\n")
+ cat("\n")
cat("----------------------------\n")
cat("2-D Histogram Object\n")
cat("----------------------------\n")
@@ -11,9 +11,8 @@
print(x$call)
cat("\n")
cat("Number of data points: ", x$nobs, "\n")
- cat("Number of grid points: ", length(x$x), "x", length(x$y), "\n")
- cat("X range: (", min(x$x), ",", max(x$x), ")\n")
- cat("Y range: (", min(x$y), ",", max(x$y), ")\n")
+ cat("Number of grid bins: ", length(x$x), "x", length(x$y), "\n")
+ cat("X range: (", min(x$x.breaks), ",", max(x$x.breaks), ")\n")
+ cat("Y range: (", min(x$y.breaks), ",", max(x$y.breaks), ")\n")
cat("\n")
-
}
Modified: trunk/gplots/man/hist2d.Rd
===================================================================
--- trunk/gplots/man/hist2d.Rd 2012-06-07 15:19:02 UTC (rev 1554)
+++ trunk/gplots/man/hist2d.Rd 2012-06-07 16:08:18 UTC (rev 1555)
@@ -8,7 +8,8 @@
}
\usage{
hist2d(x,y=NULL, nbins=200, same.scale=FALSE, na.rm=TRUE, show=TRUE,
- col=c("black", heat.colors(12)), FUN=base::length, ... )
+ col=c("black", heat.colors(12)), FUN=base::length, xlab, ylab,
+ ... )
\method{print}{hist2d}(x, ...)
}
\arguments{
@@ -18,7 +19,7 @@
is matrix}
\item{nbins}{number of bins in each dimension. May be a scalar or a
2 element vector. Defaults to 200.}
- \item{same.scale}{use a single range for x and y. Defaults to FALSE.}
+ \item{same.scale}{use the same range for x and y. Defaults to FALSE.}
\item{na.rm}{ Indicates whether missing values should be
removed. Defaults to TRUE.}
\item{show}{ Indicates whether the histogram be displayed using
@@ -29,6 +30,7 @@
\item{FUN}{Function used to summarize bin contents. Defaults to
\code{base::length}. Use, e.g., \code{mean} to calculate means for each bin
instead of counts.
+ \item{xlab,ylab}{(Optional) x and y axis labels}
}
\item{\dots}{ Parameters passed to the image function. }
}
@@ -41,42 +43,53 @@
}
\value{
- A list containing 3 elements:
+ A list containing 5 elements:
\item{counts}{Matrix containing the number of points falling into each
bin}
- \item{x}{lower x limit of each bin}
- \item{y}{lower y limit of each bin}
+ \item{x.breaks, y.breaks}{Lower and upper limits of each bin}
+ \item{x,y}{midpoints of each bin}
}
\author{ Gregory R. Warnes \email{gr...@wa...}}
\seealso{ \code{\link{image}}, \code{\link{persp}}, \code{\link{hist}} }
\examples{
- # example data, bivariate normal, no correlation
+ ## example data, bivariate normal, no correlation
x <- rnorm(2000, sd=4)
y <- rnorm(2000, sd=1)
- # separate scales for each axis, this looks circular
+ ## separate scales for each axis, this looks circular
hist2d(x,y)
- # same scale for each axis, this looks oval
+ ## same scale for each axis, this looks oval
hist2d(x,y, same.scale=TRUE)
- # use different # bins in each dimension
+ ## use different ## bins in each dimension
hist2d(x,y, same.scale=TRUE, nbins=c(100,200) )
- # use the hist2d function to create inputs for a perspective plot ...
+ ## use the hist2d function to create an h2d object
h2d <- hist2d(x,y,show=FALSE, same.scale=TRUE, nbins=c(20,30))
+
+ ## show object summary
+ h2d
+
+ ## object contents
+ str(h2d)
+
+ ## perspective plot
persp( h2d$x, h2d$y, h2d$counts,
ticktype="detailed", theta=30, phi=30,
expand=0.5, shade=0.5, col="cyan", ltheta=-30)
- # for contour (line) plot ...
+ ## for contour (line) plot ...
contour( h2d$x, h2d$y, h2d$counts, nlevels=4 )
- # for a filled contour plot ...
+ ## for a filled contour plot ...
filled.contour( h2d$x, h2d$y, h2d$counts, nlevels=4,
col=gray((4:0)/4) )
+
+
+
}
\keyword{dplot}
\keyword{hplot}
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <wa...@us...> - 2012-06-08 17:56:44
|
Revision: 1557
http://r-gregmisc.svn.sourceforge.net/r-gregmisc/?rev=1557&view=rev
Author: warnes
Date: 2012-06-08 17:56:37 +0000 (Fri, 08 Jun 2012)
Log Message:
-----------
Fix R CMD check warnings.
Modified Paths:
--------------
trunk/gplots/DESCRIPTION
trunk/gplots/R/barplot2.R
trunk/gplots/R/ooplot.R
trunk/gplots/R/plotCI.R
trunk/gplots/R/sinkplot.R
trunk/gplots/man/qqnorm.aov.Rd
trunk/gplots/tests/heatmap2Test.Rout.save
Modified: trunk/gplots/DESCRIPTION
===================================================================
--- trunk/gplots/DESCRIPTION 2012-06-08 17:49:30 UTC (rev 1556)
+++ trunk/gplots/DESCRIPTION 2012-06-08 17:56:37 UTC (rev 1557)
@@ -1,11 +1,11 @@
Package: gplots
Title: Various R programming tools for plotting data
Description: Various R programming tools for plotting data
-Depends: R (>= 2.10), gtools, gdata, stats, caTools, grid, KernSmooth
-Recommends: datasets, grid, MASS
+Depends: R (>= 2.10), gtools, gdata, stats, caTools, grid, KernSmooth, MASS, datasets
+Recommends: grid
Suggests: gtools
-Version: 2.10.1
-Date: 2011-09-01
+Version: 2.11.0
+Date: 2012-06-08
Author: Gregory R. Warnes. Includes R source code and/or documentation
contributed by (in alphabetical order):
Ben Bolker, Lodewijk Bonebakker, Robert Gentleman, Wolfgang
Modified: trunk/gplots/R/barplot2.R
===================================================================
--- trunk/gplots/R/barplot2.R 2012-06-08 17:49:30 UTC (rev 1556)
+++ trunk/gplots/R/barplot2.R 2012-06-08 17:56:37 UTC (rev 1557)
@@ -233,7 +233,7 @@
}
if (beside)
- w.m <- matrix(w.m, nc = NC)
+ w.m <- matrix(w.m, ncol = NC)
if(plot) ##-------- Plotting :
{
Modified: trunk/gplots/R/ooplot.R
===================================================================
--- trunk/gplots/R/ooplot.R 2012-06-08 17:49:30 UTC (rev 1556)
+++ trunk/gplots/R/ooplot.R 2012-06-08 17:56:37 UTC (rev 1557)
@@ -313,7 +313,7 @@
}
if (beside)
- w.m <- matrix(w.m, nc=NC)
+ w.m <- matrix(w.m, ncol=NC)
## check height/ci.l if using log scale to prevent log(<=0) error
## adjust appropriate ranges and bar base values
Modified: trunk/gplots/R/plotCI.R
===================================================================
--- trunk/gplots/R/plotCI.R 2012-06-08 17:49:30 UTC (rev 1556)
+++ trunk/gplots/R/plotCI.R 2012-06-08 17:56:37 UTC (rev 1557)
@@ -111,18 +111,6 @@
text(x, y, label=labels, col=col, ... )
}
}
- if(is.R())
- myarrows <- function(...) arrows(...)
- else
- myarrows <- function(x1,y1,x2,y2,angle,code,length,...)
- {
- segments(x1,y1,x2,y2,open=TRUE,...)
- if(code==1)
- segments(x1-length/2,y1,x1+length/2,y1,...)
- else
- segments(x2-length/2,y2,x2+length/2,y2,...)
- }
-
if(err=="y")
{
if(gap!=FALSE)
@@ -132,11 +120,11 @@
# draw upper bar
if(!is.null(li))
- myarrows(x , li, x, pmax(y-gap,li), col=barcol, lwd=lwd,
+ arrows(x , li, x, pmax(y-gap,li), col=barcol, lwd=lwd,
lty=lty, angle=90, length=smidge, code=1)
# draw lower bar
if(!is.null(ui))
- myarrows(x , ui, x, pmin(y+gap,ui), col=barcol,
+ arrows(x , ui, x, pmin(y+gap,ui), col=barcol,
lwd=lwd, lty=lty, angle=90, length=smidge, code=1)
}
else
@@ -147,10 +135,10 @@
# draw left bar
if(!is.null(li))
- myarrows(li, y, pmax(x-gap,li), y, col=barcol, lwd=lwd,
+ arrows(li, y, pmax(x-gap,li), y, col=barcol, lwd=lwd,
lty=lty, angle=90, length=smidge, code=1)
if(!is.null(ui))
- myarrows(ui, y, pmin(x+gap,ui), y, col=barcol, lwd=lwd,
+ arrows(ui, y, pmin(x+gap,ui), y, col=barcol, lwd=lwd,
lty=lty, angle=90, length=smidge, code=1)
}
Modified: trunk/gplots/R/sinkplot.R
===================================================================
--- trunk/gplots/R/sinkplot.R 2012-06-08 17:49:30 UTC (rev 1556)
+++ trunk/gplots/R/sinkplot.R 2012-06-08 17:56:37 UTC (rev 1557)
@@ -6,8 +6,8 @@
if( operation=="start" )
{
- if (exists(".sinkplot.conn", env=globalenv()) &&
- get(".sinkplot.conn", env=globalenv()) )
+ if (exists(".sinkplot.conn", envir=globalenv()) &&
+ get(".sinkplot.conn", envir=globalenv()) )
stop("sinkplot already in force")
@@ -20,22 +20,22 @@
}
else
{
- if (!exists(".sinkplot.conn", env=globalenv()) || !.sinkplot.conn )
+ if (!exists(".sinkplot.conn", envir=globalenv()) || !.sinkplot.conn )
stop("No sinkplot currently in force")
sink()
- data <- get(".sinkplot.data", env=globalenv())
+ data <- get(".sinkplot.data", envir=globalenv())
if( operation=="plot" )
textplot( paste( data, collapse="\n"), ... )
- close(get(".sinkplot.conn", env=globalenv()))
+ close(get(".sinkplot.conn", envir=globalenv()))
- if(exists(".sinkplot.data", env=globalenv()))
+ if(exists(".sinkplot.data", envir=globalenv()))
rm(".sinkplot.data", pos=globalenv())
- if(exists(".sinkplot.conn", env=globalenv()))
+ if(exists(".sinkplot.conn", envir=globalenv()))
rm(".sinkplot.conn", pos=globalenv())
invisible(data)
Modified: trunk/gplots/man/qqnorm.aov.Rd
===================================================================
--- trunk/gplots/man/qqnorm.aov.Rd 2012-06-08 17:49:30 UTC (rev 1556)
+++ trunk/gplots/man/qqnorm.aov.Rd 2012-06-08 17:56:37 UTC (rev 1557)
@@ -56,6 +56,8 @@
data(npk)
npk.aov <- aov(yield ~ block + N*P*K, npk)
qqnorm(npk.aov)
+
+## interactive labeling of points. Click mouse on points to show label.
if (dev.interactive()) qqnorm(npk.aov, omit=2:6, label=TRUE)
}
\keyword{ hplot }%
Modified: trunk/gplots/tests/heatmap2Test.Rout.save
===================================================================
--- trunk/gplots/tests/heatmap2Test.Rout.save 2012-06-08 17:49:30 UTC (rev 1556)
+++ trunk/gplots/tests/heatmap2Test.Rout.save 2012-06-08 17:56:37 UTC (rev 1557)
@@ -1,8 +1,8 @@
-R version 2.12.1 (2010-12-16)
-Copyright (C) 2010 The R Foundation for Statistical Computing
+R version 2.15.0 (2012-03-30)
+Copyright (C) 2012 The R Foundation for Statistical Computing
ISBN 3-900051-07-0
-Platform: i686-pc-linux-gnu (32-bit)
+Platform: x86_64-apple-darwin9.8.0/x86_64 (64-bit)
R is free software and comes with ABSOLUTELY NO WARRANTY.
You are welcome to redistribute it under certain conditions.
@@ -25,6 +25,10 @@
Attaching package: 'gdata'
+The following object(s) are masked from 'package:stats':
+
+ nobs
+
The following object(s) are masked from 'package:utils':
object.size
@@ -131,7 +135,7 @@
List of 12
$ rowInd : int [1:32] 31 17 16 15 5 25 29 24 7 6 ...
$ colInd : int [1:11] 2 9 8 11 6 5 10 7 1 4 ...
- $ call : language heatmap.2(x = x, scale = "column", col = cm.colors(256), tracecol = "green", margins = c(5, 10), ColSideColors = cc, RowSideColors = rc, ...
+ $ call : language heatmap.2(x = x, scale = "column", col = cm.colors(256), tracecol = "green", margins = c(5, 10), ColSideColors = cc, RowSideColors = rc, density.info = "density", ...
$ colMeans : Named num [1:11] 6.188 0.406 0.438 2.812 3.217 ...
..- attr(*, "names")= chr [1:11] "cyl" "am" "vs" "carb" ...
$ colSDs : Named num [1:11] 1.786 0.499 0.504 1.615 0.978 ...
@@ -147,7 +151,7 @@
.. | |--[dendrogram w/ 2 branches and 3 members at h = 40.8, midpoint = 0.75, value = 198]
.. | | |--leaf "Chrysler Imperial" ( value.Chrysler Imperial = 66 )
.. | | `--[dendrogram w/ 2 branches and 2 members at h = 15.6, midpoint = 0.5, value = 132]
- .. | | |--leaf "Lincoln Continental" ( value.Lincoln Continental = 66 )
+ .. | | |--leaf "Lincoln Continental" ( value.Lincoln Continental = 66.1 )
.. | | `--leaf "Cadillac Fleetwood" ( value.Cadillac Fleetwood = 66.2 )
.. | `--[dendrogram w/ 2 branches and 5 members at h = 102, midpoint = 1.62, value = 290]
.. | |--[dendrogram w/ 2 branches and 2 members at h = 40, midpoint = 0.5, value = 111]
@@ -161,26 +165,26 @@
.. `--[dendrogram w/ 2 branches and 23 members at h = 262, midpoint = 6.33, value = 716]
.. |--[dendrogram w/ 2 branches and 7 members at h = 103, midpoint = 2.06, value = 306]
.. | |--[dendrogram w/ 2 branches and 2 members at h = 33.6, midpoint = 0.5, value = 73.8]
- .. | | |--leaf "Valiant" ( value.Valiant = 35.0 )
+ .. | | |--leaf "Valiant" ( value.Valiant = 35 )
.. | | `--leaf "Hornet 4 Drive" ( value.Hornet 4 Drive = 38.7 )
.. | `--[dendrogram w/ 2 branches and 5 members at h = 51.8, midpoint = 1.62, value = 233]
- .. | |--[dendrogram w/ 2 branches and 2 members at h = 14.0, midpoint = 0.5, value = 93.2]
+ .. | |--[dendrogram w/ 2 branches and 2 members at h = 14, midpoint = 0.5, value = 93.2]
.. | | |--leaf "AMC Javelin" ( value.AMC Javelin = 46 )
.. | | `--leaf "Dodge Challenger" ( value.Dodge Challenger = 47.2 )
.. | `--[dendrogram w/ 2 branches and 3 members at h = 2.14, midpoint = 0.75, value = 139]
.. | |--leaf "Merc 450SLC" ( value.Merc 450SLC = 46.4 )
- .. | `--[dendrogram w/ 2 branches and 2 members at h = 0.983, midpoint = 0.5, value = 93]
+ .. | `--[dendrogram w/ 2 branches and 2 members at h = 0.983, midpoint = 0.5, value = 92.9]
.. | |--leaf "Merc 450SE" ( value.Merc 450SE = 46.4 )
.. | `--leaf "Merc 450SL" ( value.Merc 450SL = 46.5 )
.. `--[dendrogram w/ 2 branches and 16 members at h = 142, midpoint = 3.59, value = 409]
- .. |--[dendrogram w/ 2 branches and 4 members at h = 14.8, midpoint = 0.875, value = 75]
+ .. |--[dendrogram w/ 2 branches and 4 members at h = 14.8, midpoint = 0.875, value = 74.9]
.. | |--leaf "Honda Civic" ( value.Honda Civic = 17.7 )
.. | `--[dendrogram w/ 2 branches and 3 members at h = 10.4, midpoint = 0.75, value = 57.2]
.. | |--leaf "Toyota Corolla" ( value.Toyota Corolla = 18.8 )
.. | `--[dendrogram w/ 2 branches and 2 members at h = 5.15, midpoint = 0.5, value = 38.4]
.. | |--leaf "Fiat X1-9" ( value.Fiat X1-9 = 18.9 )
.. | `--leaf "Fiat 128" ( value.Fiat 128 = 19.4 )
- .. `--[dendrogram w/ 2 branches and 12 members at h = 113, midpoint = 2.30, value = 334]
+ .. `--[dendrogram w/ 2 branches and 12 members at h = 113, midpoint = 2.3, value = 334]
.. |--leaf "Ferrari Dino" ( value.Ferrari Dino = 34.5 )
.. `--[dendrogram w/ 2 branches and 11 members at h = 74.4, midpoint = 3.61, value = 300]
.. |--[dendrogram w/ 2 branches and 5 members at h = 64.9, midpoint = 1.25, value = 148]
@@ -233,3 +237,6 @@
..$ color: Factor w/ 254 levels "#80FFFFFF","#81FFFFFF",..: 1 1 2 3 4 5 6 7 8 9 ...
>
>
+> proc.time()
+ user system elapsed
+ 1.427 0.067 1.487
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <wa...@us...> - 2013-03-24 05:19:07
|
Revision: 1646
http://sourceforge.net/p/r-gregmisc/code/1646
Author: warnes
Date: 2013-03-24 05:19:04 +0000 (Sun, 24 Mar 2013)
Log Message:
-----------
Add ci.width argument to barplot2() to allow varying the length of the 't' at the end of confidence interval bars.
Modified Paths:
--------------
trunk/gplots/R/barplot2.R
trunk/gplots/man/barplot2.Rd
Modified: trunk/gplots/R/barplot2.R
===================================================================
--- trunk/gplots/R/barplot2.R 2013-03-24 04:50:22 UTC (rev 1645)
+++ trunk/gplots/R/barplot2.R 2013-03-24 05:19:04 UTC (rev 1646)
@@ -12,30 +12,60 @@
barplot2 <- function(height, ...) UseMethod("barplot2")
barplot2.default <-
- function(
- height,
- width = 1,
- space = NULL,
- names.arg = NULL,
- legend.text = NULL,
- beside = FALSE,
- horiz = FALSE,
- density = NULL,
- angle = 45,
- col = NULL,
- prcol = NULL,
- border = par("fg"),
- main = NULL,
- sub = NULL, xlab = NULL, ylab = NULL,
- xlim = NULL, ylim = NULL, xpd = TRUE, log = "",
- axes = TRUE, axisnames = TRUE,
- cex.axis = par("cex.axis"), cex.names = par("cex.axis"),
- inside = TRUE, plot = TRUE, axis.lty = 0, offset = 0,
- plot.ci = FALSE, ci.l = NULL, ci.u = NULL,
- ci.color = "black", ci.lty = "solid", ci.lwd = 1,
- plot.grid = FALSE, grid.inc = NULL,
- grid.lty = "dotted", grid.lwd = 1, grid.col = "black",
- add = FALSE, panel.first = NULL, panel.last = NULL, ...)
+ function(
+ height,
+ width = 1,
+ space = NULL,
+ names.arg = NULL,
+ legend.text = NULL,
+ beside = FALSE,
+ horiz = FALSE,
+ density = NULL,
+ angle = 45,
+ col = NULL,
+ prcol = NULL,
+ border = par("fg"),
+ main = NULL,
+ sub = NULL,
+ xlab = NULL,
+ ylab = NULL,
+
+ xlim = NULL,
+ ylim = NULL,
+ xpd = TRUE,
+ log = "",
+
+ axes = TRUE,
+ axisnames = TRUE,
+
+ cex.axis = par("cex.axis"),
+ cex.names = par("cex.axis"),
+
+ inside = TRUE,
+ plot = TRUE,
+ axis.lty = 0,
+ offset = 0,
+
+ plot.ci = FALSE,
+ ci.l = NULL,
+ ci.u = NULL,
+
+ ci.color = "black",
+ ci.lty = "solid",
+ ci.lwd = 1,
+ ci.width = 0.5,
+
+ plot.grid = FALSE,
+ grid.inc = NULL,
+
+ grid.lty = "dotted",
+ grid.lwd = 1,
+ grid.col = "black",
+
+ add = FALSE,
+ panel.first = NULL,
+ panel.last = NULL,
+ ...)
{
if (!missing(inside)) .NotYetUsed("inside", error = FALSE)# -> help(.)
@@ -137,10 +167,10 @@
# Check for NA values and issue warning if required
height.na <- sum(is.na(height))
if (height.na > 0)
- {
+ {
warning(sprintf("%.0f values == NA in 'height' omitted from logarithmic plot",
height.na), domain = NA)
- }
+ }
# Check for 0 values and issue warning if required
# _FOR NOW_ change 0's to NA's so that other calculations are not
@@ -148,15 +178,15 @@
# except for stacked bars, so don't change those.
height.lte0 <- sum(height <= 0, na.rm = TRUE)
if (height.lte0 > 0)
- {
+ {
warning(sprintf("%0.f values <=0 in 'height' omitted from logarithmic plot",
height.lte0), domain = NA)
-
+
# If NOT stacked bars, modify 'height'
if (beside)
height[height <= 0] <- NA
- }
-
+ }
+
if (plot.ci && (min(ci.l) <= 0))
stop("log scale error: at least one lower c.i. value <= 0")
@@ -172,12 +202,12 @@
{
rectbase <- c(height[is.finite(height)], ci.l)
rectbase <- min(0.9 * rectbase[rectbase > 0])
- }
+ }
else
{
rectbase <- height[is.finite(height)]
rectbase <- min(0.9 * rectbase[rectbase > 0])
- }
+ }
# if axis limit is set to < above, adjust bar base value
# to draw a full bar
@@ -253,7 +283,7 @@
# Execute the panel.first expression. This will work here
# even if 'add = TRUE'
panel.first
-
+
# Set plot region coordinates
usr <- par("usr")
@@ -335,23 +365,23 @@
# Execute the panel.last expression here
panel.last
-
+
if (plot.ci)
{
# CI plot width = barwidth / 2
- ci.width = width / 4
+ half.ci.width = width * ci.width / 2
if (horiz)
{
segments(ci.l, w.m, ci.u, w.m, col = ci.color, lty = ci.lty, lwd = ci.lwd)
- segments(ci.l, w.m - ci.width, ci.l, w.m + ci.width, col = ci.color, lty = ci.lty, lwd = ci.lwd)
- segments(ci.u, w.m - ci.width, ci.u, w.m + ci.width, col = ci.color, lty = ci.lty, lwd = ci.lwd)
+ segments(ci.l, w.m - half.ci.width, ci.l, w.m + half.ci.width, col = ci.color, lty = ci.lty, lwd = ci.lwd)
+ segments(ci.u, w.m - half.ci.width, ci.u, w.m + half.ci.width, col = ci.color, lty = ci.lty, lwd = ci.lwd)
}
else
{
segments(w.m, ci.l, w.m, ci.u, col = ci.color, lty = ci.lty, lwd = ci.lwd)
- segments(w.m - ci.width, ci.l, w.m + ci.width, ci.l, col = ci.color, lty = ci.lty, lwd = ci.lwd)
- segments(w.m - ci.width, ci.u, w.m + ci.width, ci.u, col = ci.color, lty = ci.lty, lwd = ci.lwd)
+ segments(w.m - half.ci.width, ci.l, w.m + half.ci.width, ci.l, col = ci.color, lty = ci.lty, lwd = ci.lwd)
+ segments(w.m - half.ci.width, ci.u, w.m + half.ci.width, ci.u, col = ci.color, lty = ci.lty, lwd = ci.lwd)
}
}
Modified: trunk/gplots/man/barplot2.Rd
===================================================================
--- trunk/gplots/man/barplot2.Rd 2013-03-24 04:50:22 UTC (rev 1645)
+++ trunk/gplots/man/barplot2.Rd 2013-03-24 05:19:04 UTC (rev 1646)
@@ -84,8 +84,8 @@
axes = TRUE, axisnames = TRUE,
cex.axis = par("cex.axis"), cex.names = par("cex.axis"),
inside = TRUE, plot = TRUE, axis.lty = 0, offset = 0,
- plot.ci = FALSE, ci.l = NULL,
- ci.u = NULL, ci.color = "black", ci.lty = "solid", ci.lwd = 1,
+ plot.ci = FALSE, ci.l = NULL, ci.u = NULL,
+ ci.color = "black", ci.lty = "solid", ci.lwd = 1, ci.width = 0.5,
plot.grid = FALSE, grid.inc = NULL,
grid.lty = "dotted", grid.lwd = 1, grid.col = "black",
add = FALSE, panel.first = NULL, panel.last = NULL, \dots)
@@ -176,7 +176,10 @@
the same dim structure as \code{height}.}
\item{ci.color}{the color for the confidence interval line segments}
\item{ci.lty}{the line type for the confidence interval line segments}
- \item{ci.lwd}{the line width for the confidence interval line segments}
+ \item{ci.lwd}{the line width for the confidence interval line
+ segments}
+ \item{ci.width}{length of lines used for the "t" at the end of confidence
+ interval line segments, as a multple of \code{width}. Defaults to 0.5.}
\item{plot.grid}{if \code{TRUE} a lined grid will be plotted behind the bars}
\item{grid.inc}{the number of grid increments to be plotted}
\item{grid.lty}{the line type for the grid}
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
×
Want the latest updates on software, tech news, and AI?
Get latest updates about software, tech news, and AI from SourceForge directly in your inbox once a month.
Thanks for helping keep SourceForge clean.
X