[Gtdb-commits] r57 - in pkg/gt.db: R man
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Thu Jul 1 02:20:14 CEST 2010
Author: dahinds
Date: 2010-07-01 02:20:13 +0200 (Thu, 01 Jul 2010)
New Revision: 57
Modified:
pkg/gt.db/R/cluster.R
pkg/gt.db/R/genotype.R
pkg/gt.db/R/gplot.R
pkg/gt.db/R/ld.R
pkg/gt.db/man/manhattan.plot.Rd
Log:
- fixed bug in summary.gt.data() for X markers
- enhanced manhattan.plot() for single chromosome region
- removed some cruft from .panel.cluster
- changed strategy for drawing rotated LD plots
Modified: pkg/gt.db/R/cluster.R
===================================================================
--- pkg/gt.db/R/cluster.R 2010-06-22 17:53:42 UTC (rev 56)
+++ pkg/gt.db/R/cluster.R 2010-07-01 00:20:13 UTC (rev 57)
@@ -19,19 +19,10 @@
#
panel.cluster <-
-function(x, y, group.number=1, mark, pch, alpha,
- subscripts, bounds=c(), min.points=4, ...)
+function(x, y, group.number=1, bounds=c(), min.points=4, ...)
{
require(cluster)
- if (any(mark)) {
- m <- mark[subscripts]
- panel.xyplot(x[!m], y[!m], subscripts=subscripts[!m],
- pch=pch, alpha=alpha, ...)
- panel.xyplot(x[m], y[m], subscripts=subscripts[m],
- pch=8, alpha=1, ...)
- } else
- panel.xyplot(x, y, subscripts=subscripts,
- pch=pch, alpha=alpha, ...)
+ panel.xyplot(x, y, ...)
if (!length(bounds))
return()
grp <- function(x,n) lapply(x, function(y) y[(n-1)%%length(y)+1])
@@ -61,11 +52,10 @@
gt.cluster.plot <-
function(data, by=assay.name, rescale=TRUE, bounds=c(0.5,0.95),
- mark=FALSE, min.points=4, between=list(x=0.5,y=0.5),
+ min.points=4, between=list(x=0.5,y=0.5),
scales=list(alternating=0), xlab=NULL, ylab=NULL,
par.settings=.gt.settings, ...)
{
- mark <- eval(substitute(mark), data, parent.frame())
if ('signal.a' %in% names(data)) {
x <- data$signal.a
y <- data$signal.b
@@ -128,7 +118,7 @@
gt[is.na(gt)] <- nn
}
p <- xyplot(y~x|n, groups=gt, bounds=bounds, min.points=min.points,
- scales=scales, prepanel=prepanel, aspect=1, mark=mark,
+ scales=scales, prepanel=prepanel, aspect=1,
panel=panel.superpose, panel.groups=panel.cluster,
xlab=xlab, ylab=ylab, between=between,
par.settings=par.settings, ...)
Modified: pkg/gt.db/R/genotype.R
===================================================================
--- pkg/gt.db/R/genotype.R 2010-06-22 17:53:42 UTC (rev 56)
+++ pkg/gt.db/R/genotype.R 2010-07-01 00:20:13 UTC (rev 57)
@@ -326,7 +326,7 @@
dg <- ifelse(s=='A', g, x)
hg <- ifelse(s=='M', g, x)
if (any(s=='X'))
- dg[s=='X'] <- mask.str(dg[s=='X'], gm['F'])
+ dg[s=='X'] <- mask.str(g[s=='X'], gm['F'])
if (any(s %in% c('X','Y'))) {
if (any(!(un.mask(gm['M']) | un.mask(gm['F']))))
warning('some samples have unknown gender')
Modified: pkg/gt.db/R/gplot.R
===================================================================
--- pkg/gt.db/R/gplot.R 2010-06-22 17:53:42 UTC (rev 56)
+++ pkg/gt.db/R/gplot.R 2010-07-01 00:20:13 UTC (rev 57)
@@ -70,10 +70,17 @@
grp[abs(pos - hit) < around] <- 2
}
}
- w <- match(paste('chr',xticks,sep=''), names(len))
- xlim <- range(pos,na.rm=TRUE) + 50e6*c(-1,1)
+ xlim <- range(pos,na.rm=TRUE)
+ xlim <- xlim + (xlim[2]-xlim[1]) * c(-0.02,0.02)
panel.fn <- function(...) { xyplot(...) ; panel.refline(h=threshold) }
- xyplot(val~pos, ..., cex=cex, groups=grp, par.settings=set,
- scales=list(x=list(at=mid[w],tck=0,labels=xticks)),
- panel=panel.fn, xlab=xlab, ylab=ylab, xlim=xlim)
+ if (length(len) == 1) {
+ set <- list(superpose.symbol=list(col=col[-2]))
+ xyplot(val~pos, ..., cex=cex, groups=grp, par.settings=set,
+ panel=panel.fn, xlab=xlab, ylab=ylab, xlim=xlim)
+ } else {
+ w <- match(paste('chr',xticks,sep=''), names(len))
+ xyplot(val~pos, ..., cex=cex, groups=grp, par.settings=set,
+ scales=list(x=list(at=mid[w],tck=0,labels=xticks)),
+ panel=panel.fn, xlab=xlab, ylab=ylab, xlim=xlim)
+ }
}
Modified: pkg/gt.db/R/ld.R
===================================================================
--- pkg/gt.db/R/ld.R 2010-06-22 17:53:42 UTC (rev 56)
+++ pkg/gt.db/R/ld.R 2010-07-01 00:20:13 UTC (rev 57)
@@ -205,6 +205,8 @@
}
if (length(s) > 1)
stop('inconsistent ploidy information')
+ if (measure == 'none')
+ return(rep(NA,max(nrow(g1),nrow(g2))))
if (s == 'A') {
m <- ch.table(g1$genotype, g2$genotype, c('a','h','b'))
} else if (s == 'X') {
@@ -259,6 +261,40 @@
r
}
+.panel.ldplot <-
+ function(x, y, z, at=pretty(z), rug=FALSE, ...,
+ col.regions=regions$col, alpha.regions=regions$alpha)
+{
+ regions <- trellis.par.get("regions")
+ x <- as.numeric(x)
+ y <- as.numeric(y)
+ zcol <- level.colors(z, at, col.regions, colors = TRUE)
+
+ ux <- sort(unique(x[!is.na(x)]))
+ bx <- if (length(ux) > 1)
+ c(3 * ux[1] - ux[2], ux[-length(ux)] + ux[-1], 3 *
+ ux[length(ux)] - ux[length(ux) - 1])/2
+ else ux + c(-1,1)
+ lx <- 0.5 * diff(bx)
+ cx <- (bx[-1] + bx[-length(bx)])/2
+
+ if (is.list(rug))
+ do.call('panel.rug', c(list(x=ux),rug))
+ else if (rug)
+ panel.rug(ux)
+
+ idx <- match(x, ux)
+ idy <- match(y, ux)
+ x0 <- (cx[idx]+cx[idy])/2 - (lx[idx]+lx[idy])/2
+ xm <- rbind(x0, x0+lx[idy], x0+lx[idx]+lx[idy], x0+lx[idx])
+ y0 <- (max(cy) - (cx[idx]-cx[idy]) + (lx[idx]-lx[idy]))/2
+ ym <- rbind(y0, y0+lx[idy], y0+lx[idy]-lx[idx], y0-lx[idx])*2
+ gp <- gpar(fill=zcol, lwd=1e-5, col='transparent', alpha=alpha.regions)
+ grid.polygon(x=as.vector(xm), y=as.vector(ym),
+ id.lengths=rep(4,length(x0)),
+ default.units = "native", gp = gp)
+}
+
ld.plot <-
function(gt.data, col=gray(seq(1,0,-0.01)), measure='rsqr',
rotate=FALSE, equal=TRUE, colorkey=list(height=0.5),
@@ -272,27 +308,30 @@
}
if (missing(scales)) {
scales <- if (equal) list(alternating=0) else list()
- if (rotate) scales <- list(draw=FALSE)
+ if (rotate) scales <- list(y=list(draw=FALSE))
}
+ if (rotate) {
+ panel.fn <- .panel.ldplot
+ aspect <- 0.5
+ } else {
+ panel.fn <- panel.levelplot
+ aspect <- 1.0
+ }
if (equal) {
- p <- levelplot(ld, aspect=1, col.regions=col, colorkey=colorkey,
- xlab=NULL, ylab=NULL, scales=scales, ...)
+ levelplot(ld, aspect=aspect,
+ col.regions=col, colorkey=colorkey,
+ xlab=NULL, ylab=NULL, scales=scales,
+ panel=panel.fn, ...)
} else {
- p <- as.character(gt.data$position)
- dimnames(ld) <- list(p,p)
- xd <- as.data.frame.table(ld)
- xd[,1] <- as.numeric(as.character(xd[,1]))
- xd[,2] <- as.numeric(as.character(xd[,2]))
- p <- levelplot(Freq~Var1*Var2, xd, aspect=1,
- col.regions=col, colorkey=colorkey,
- xlab=NULL, ylab=NULL, scales=scales, ...)
+ dimnames(ld) <- list(gt.data$position)[c(1,1)]
+ xd <- as.data.frame.table(ld, stringsAsFactors=FALSE)
+ xd[,1] <- as.numeric(xd[,1])
+ xd[,2] <- as.numeric(xd[,2])
+ levelplot(Freq~Var1*Var2, xd, aspect=aspect,
+ col.regions=col, colorkey=colorkey,
+ xlab=NULL, ylab=NULL, scales=scales,
+ panel.fn=panel.fn, ...)
}
- if (rotate) {
- grid.newpage()
- pushViewport(viewport(h=0.707,w=0.707,angle=-45))
- suppressWarnings(print(p,newpage=FALSE))
- popViewport()
- } else { p }
}
ld.prune <-
Modified: pkg/gt.db/man/manhattan.plot.Rd
===================================================================
--- pkg/gt.db/man/manhattan.plot.Rd 2010-06-22 17:53:42 UTC (rev 56)
+++ pkg/gt.db/man/manhattan.plot.Rd 2010-07-01 00:20:13 UTC (rev 57)
@@ -44,7 +44,10 @@
\code{\link[lattice:xyplot]{xyplot}}.}
}
\details{
- Typically, the scores are expected to be \code{-log10(pvalue)}.
+ Typically, the scores are expected to be \code{-log10(pvalue)}. If
+ the source data spans multiple chromosomes, then chromosome names are
+ shown along the X axis. If the data is all on a single chromosome,
+ then chromosomal positions are shown.
}
\value{
A plot object of class \code{"trellis"}.
More information about the Gtdb-commits
mailing list