[Gtdb-commits] r58 - in pkg/gt.db: . R demo inst/doc inst/schema man src
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Fri Sep 10 22:56:58 CEST 2010
Author: dahinds
Date: 2010-09-10 22:56:58 +0200 (Fri, 10 Sep 2010)
New Revision: 58
Added:
pkg/gt.db/R/power.R
pkg/gt.db/R/tracks.R
pkg/gt.db/man/adjust.ld.Rd
pkg/gt.db/man/cc.model.Rd
pkg/gt.db/man/cc.power.Rd
pkg/gt.db/man/draw.tracks.Rd
pkg/gt.db/man/qtl.cc.power.Rd
pkg/gt.db/man/qtl.model.Rd
pkg/gt.db/man/qtl.power.Rd
pkg/gt.db/man/qtl.to.cc.Rd
pkg/gt.db/man/setup.tracks.Rd
Modified:
pkg/gt.db/DESCRIPTION
pkg/gt.db/INDEX
pkg/gt.db/R/admin.R
pkg/gt.db/R/affy.R
pkg/gt.db/R/align.R
pkg/gt.db/R/assay.R
pkg/gt.db/R/attr.R
pkg/gt.db/R/cluster.R
pkg/gt.db/R/firstlib.R
pkg/gt.db/R/flag.R
pkg/gt.db/R/genotype.R
pkg/gt.db/R/gplot.R
pkg/gt.db/R/hapmap.R
pkg/gt.db/R/hwe.R
pkg/gt.db/R/jt.R
pkg/gt.db/R/keep.R
pkg/gt.db/R/ld.R
pkg/gt.db/R/misc.R
pkg/gt.db/R/options.R
pkg/gt.db/R/prcomp.R
pkg/gt.db/R/progress.R
pkg/gt.db/R/qq.R
pkg/gt.db/R/rawdata.R
pkg/gt.db/R/relate.R
pkg/gt.db/R/sample.R
pkg/gt.db/R/score.R
pkg/gt.db/R/sql.R
pkg/gt.db/R/str.R
pkg/gt.db/R/subject.R
pkg/gt.db/R/test.R
pkg/gt.db/demo/00Index
pkg/gt.db/demo/setup.gt.demo.R
pkg/gt.db/demo/setup.hapmap.R
pkg/gt.db/inst/doc/gt.db.pdf
pkg/gt.db/inst/schema/mk_mysql.sql
pkg/gt.db/inst/schema/mk_oracle.sql
pkg/gt.db/inst/schema/mk_sqlite.sql
pkg/gt.db/man/adjust.gt.calls.Rd
pkg/gt.db/man/apply.gt.dataset.Rd
pkg/gt.db/man/apply.loadings.Rd
pkg/gt.db/man/as.mask.Rd
pkg/gt.db/man/big.loadings.Rd
pkg/gt.db/man/ch.table.Rd
pkg/gt.db/man/demo_01.Rd
pkg/gt.db/man/demo_02.Rd
pkg/gt.db/man/fetch.gt.data.Rd
pkg/gt.db/man/fetch.prcomp.Rd
pkg/gt.db/man/fetch.pt.data.Rd
pkg/gt.db/man/fetch.sample.data.Rd
pkg/gt.db/man/fetch.subject.data.Rd
pkg/gt.db/man/fetch.test.scores.Rd
pkg/gt.db/man/gplot.Rd
pkg/gt.db/man/gplot.prcomp.Rd
pkg/gt.db/man/gt.cluster.plot.Rd
pkg/gt.db/man/gt.demo.check.Rd
pkg/gt.db/man/gt.split.Rd
pkg/gt.db/man/hapmap.Rd
pkg/gt.db/man/hwe.test.Rd
pkg/gt.db/man/ibd.dataset.Rd
pkg/gt.db/man/ibd.gt.data.Rd
pkg/gt.db/man/ibd.plot.Rd
pkg/gt.db/man/ibd.summary.Rd
pkg/gt.db/man/ibs.gt.data.Rd
pkg/gt.db/man/if.na.Rd
pkg/gt.db/man/init.gt.db.Rd
pkg/gt.db/man/jt.test.Rd
pkg/gt.db/man/keep.attr.Rd
pkg/gt.db/man/ld.gt.data.Rd
pkg/gt.db/man/ld.plot.Rd
pkg/gt.db/man/ld.prune.Rd
pkg/gt.db/man/load.affy.chp.data.Rd
pkg/gt.db/man/load.hapmap.data.Rd
pkg/gt.db/man/ls.assay.Rd
pkg/gt.db/man/ls.assay.position.Rd
pkg/gt.db/man/ls.dataset.Rd
pkg/gt.db/man/ls.mapping.Rd
pkg/gt.db/man/ls.platform.Rd
pkg/gt.db/man/ls.prcomp.Rd
pkg/gt.db/man/ls.project.Rd
pkg/gt.db/man/ls.sample.Rd
pkg/gt.db/man/ls.subject.Rd
pkg/gt.db/man/ls.test.Rd
pkg/gt.db/man/manhattan.plot.Rd
pkg/gt.db/man/mask.gt.data.Rd
pkg/gt.db/man/mask.str.Rd
pkg/gt.db/man/match.gt.data.Rd
pkg/gt.db/man/mk.assay.Rd
pkg/gt.db/man/mk.assay.data.Rd
pkg/gt.db/man/mk.assay.position.Rd
pkg/gt.db/man/mk.attr.Rd
pkg/gt.db/man/mk.dataset.Rd
pkg/gt.db/man/mk.mapping.Rd
pkg/gt.db/man/mk.platform.Rd
pkg/gt.db/man/mk.project.Rd
pkg/gt.db/man/mk.sample.Rd
pkg/gt.db/man/mk.sample.attr.Rd
pkg/gt.db/man/mk.subject.Rd
pkg/gt.db/man/mk.subject.attr.Rd
pkg/gt.db/man/na.if.Rd
pkg/gt.db/man/nsubstr.Rd
pkg/gt.db/man/orient.gt.data.Rd
pkg/gt.db/man/pack.raw.data.Rd
pkg/gt.db/man/panel.cluster.Rd
pkg/gt.db/man/panel.qqpval.Rd
pkg/gt.db/man/panel.qqthin.Rd
pkg/gt.db/man/prcomp.gt.data.Rd
pkg/gt.db/man/progress.bar.Rd
pkg/gt.db/man/qqmath.prcomp.Rd
pkg/gt.db/man/qqpval.Rd
pkg/gt.db/man/qqthin.Rd
pkg/gt.db/man/rawToHex.Rd
pkg/gt.db/man/read.affy.anno.Rd
pkg/gt.db/man/reshape.gt.data.Rd
pkg/gt.db/man/revcomp.Rd
pkg/gt.db/man/score.and.store.Rd
pkg/gt.db/man/score.chisq.2x2.Rd
pkg/gt.db/man/score.chisq.Rd
pkg/gt.db/man/score.fisher.Rd
pkg/gt.db/man/score.glm.Rd
pkg/gt.db/man/score.glm.general.Rd
pkg/gt.db/man/score.glm.groups.Rd
pkg/gt.db/man/score.gt.data.Rd
pkg/gt.db/man/score.jt.Rd
pkg/gt.db/man/score.kruskal.Rd
pkg/gt.db/man/score.lm.Rd
pkg/gt.db/man/score.lm.general.Rd
pkg/gt.db/man/score.lm.groups.Rd
pkg/gt.db/man/score.prcomp.Rd
pkg/gt.db/man/score.trend.Rd
pkg/gt.db/man/set.hidden.Rd
pkg/gt.db/man/snp.loadings.Rd
pkg/gt.db/man/sql.query.Rd
pkg/gt.db/man/store.prcomp.Rd
pkg/gt.db/man/store.sample.data.Rd
pkg/gt.db/man/store.subject.data.Rd
pkg/gt.db/man/store.test.scores.Rd
pkg/gt.db/man/summary.gt.data.Rd
pkg/gt.db/man/unpack.gt.matrix.Rd
pkg/gt.db/man/use.gt.db.Rd
pkg/gt.db/src/raw.c
pkg/gt.db/src/str.c
Log:
- added support for representing allele dosages
- nicer Manhattan plot scaling
- implementation of track-organized plots (draw.tracks)
- cleaned up management of gender, samples in gt.data objects
- added diff.gt.data for comparing gt.data objects
- added stuff for power calculations (cc.power etc)
Modified: pkg/gt.db/DESCRIPTION
===================================================================
--- pkg/gt.db/DESCRIPTION 2010-07-01 00:20:13 UTC (rev 57)
+++ pkg/gt.db/DESCRIPTION 2010-09-10 20:56:58 UTC (rev 58)
@@ -1,11 +1,12 @@
-Package: gt.db
-Version: 0.6-1
-Date: 2010-02-21
-Title: GT.DB: Genotype Data Management and Analysis
-Author: David Hinds
-Maintainer: David Hinds <dhinds at sonic.net>
-Description: Framework for storing and manipulating genotype data,
- phenotype data, and association study results
-License: GPL
-Depends: R (>= 2.7.0), lattice, grid, methods, DBI
-Suggests: nlme, cluster, mda, RMySQL, RSQLite
+Package: gt.db
+Version: 0.7-1
+Date: 2010-08-12
+Title: GT.DB: Genotype Data Management and Analysis
+Author: David Hinds
+Maintainer: David Hinds <dhinds at sonic.net>
+Description: Framework for storing and manipulating genotype data,
+ phenotype data, and association study results
+License: GPL
+Depends: R (>= 2.7.0), lattice, grid, methods, DBI
+Suggests: nlme, cluster, mda, RMySQL, RSQLite
+Packaged: 2010-08-12 20:47:05 UTC; dhinds
Modified: pkg/gt.db/INDEX
===================================================================
--- pkg/gt.db/INDEX 2010-07-01 00:20:13 UTC (rev 57)
+++ pkg/gt.db/INDEX 2010-09-10 20:56:58 UTC (rev 58)
@@ -1,4 +1,6 @@
adjust.gt.calls Manually Assign Genotype Calls
+adjust.ld Adjust Model to Account for Incomplete Linkage
+ Disequilibrium
apply.gt.dataset Apply a Function to a Genotype Dataset
apply.loadings Apply PCA SNP Loadings to a New Genotype Set
as.mask Convert To/From Character Masks
@@ -8,7 +10,11 @@
Samples
big.loadings Identify Large Sample or SNP Loadings from a
PCA Analysis
+cc.model Case-Control Disease Model Parameters
+cc.power Power Calculation for Case-Control Association
+ Studies
ch.table Character Based Contingency Table
+draw.tracks Draw Tracks in Genomic Coordinates
fetch.gt.data Load Genotype Data for a Genotyping Dataset
fetch.prcomp Load Principal Components Results for a
Genotyping Dataset
@@ -48,7 +54,7 @@
ld.plot Pairwise Linkage Disequilibrium Plot
ld.prune Prune SNP List to Limit Linkage Disequilibrium
load.affy.chp.data Import Affymetrix CHP Genotype Data
-load.hapmap.data Import Unphased HapMap Genotype Data
+load.hapmap.data Import HapMap Genotype Data
ls.assay List Assay Definitions
ls.assay.position List Assay Positions
ls.dataset List Genotype Datasets
@@ -59,6 +65,7 @@
ls.sample List Samples in a Genotype Dataset
ls.subject List Subjects in a Genotyping Project
ls.test List Association Test Result Sets
+manhattan.plot Genome-Wide Manhattan Plot
mask.gt.data Mask Sample Genotypes
mask.str Mask Character Strings
match.gt.data Identify Equivalent Genotyping Assays
@@ -94,6 +101,13 @@
qqprcomp Quantile-Quantile Plots of PCA Loadings
qqpval Quantile-Quantile Plots for P Values
qqthin Sparse Normal Quantile-Quantile Plots
+qtl.cc.power Power Calculation for QTL Case-Control
+ Association Studies
+qtl.model Quantitative Trait Model Parameters
+qtl.power Power Calculation for Quantitative Trait
+ Association Studies
+qtl.to.cc Create Case-Control Model from Quantitative
+ Trait Tails
read.affy.anno Import Affymetrix NetAffx Annotation Data
reshape.gt.data Reshape Genotype Data
revcomp Reverse Complement DNA Sequences
@@ -121,6 +135,7 @@
Components
score.trend Cochran-Armitage Trend Test for Association
set.hidden Update Hidden Status
+setup.tracks Initialize Track Plot of a Genomic Interval
snp.loadings SNP Loadings from Principal Components Analyses
sql.query Simplified SQL Statement Execution
store.prcomp Store or Remove Principal Components Results
Modified: pkg/gt.db/R/admin.R
===================================================================
--- pkg/gt.db/R/admin.R 2010-07-01 00:20:13 UTC (rev 57)
+++ pkg/gt.db/R/admin.R 2010-09-10 20:56:58 UTC (rev 58)
@@ -1,133 +1,133 @@
-#
-# Copyright (C) 2009, Perlegen Sciences, Inc.
-# Copyright (C) 2010, 23andMe, Inc.
-#
-# Written by David A. Hinds <dhinds at sonic.net>
-#
-# This is free software; you can redistribute it and/or modify it
-# under the terms of the GNU General Public License as published by
-# the Free Software Foundation; either version 3 of the license, or
-# (at your option) any later version.
-#
-# This program is distributed in the hope that it will be useful,
-# but WITHOUT ANY WARRANTY; without even the implied warranty of
-# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-# GNU General Public License for more details.
-#
-# You should have received a copy of the GNU General Public License
-# along with this program. If not, see <http://www.gnu.org/licenses/>
-#
-
-#---------------------------------------------------------------------
-
-# Administrative functions for viewing and modifying the contents
-# of the project, platform, and dataset tables
-
-#---------------------------------------------------------------------
-
-ls.project <-
-function(project.name='%', show.all=FALSE, show.ids=FALSE)
-{
- sql <-
- "select project_id, name project_name, description,
- (select count(*) from dataset d
- where d.project_id=p.project_id
- and is_hidden <= :1) datasets,
- is_hidden, created_by, created_dt
- from project p
- where name like :2
- and is_hidden <= :3"
- r <- sql.query(gt.db::.gt.db, sql, show.all, project.name, show.all)
- .filter.ids(r, show.ids)
-}
-
-mk.project <- function(project.name, description, is.hidden=FALSE)
-{
- .check.name(project.name)
- sql <-
- "insert into project
- values (null, :1, :2, :3, :user:, :sysdate:)"
- sql.exec(gt.db::.gt.db, sql, project.name, description, is.hidden)
-}
-
-rm.project <- function(project.name)
-{
- sql <- 'delete from project where project_id=:1'
- sql.exec(gt.db::.gt.db, sql, lookup.id('project', project.name))
-}
-
-#---------------------------------------------------------------------
-
-ls.platform <- function(platform.name='%', show.ids=FALSE)
-{
- sql <-
- "select platform_id, name platform_name, description,
- (select count(*) from dataset d
- where p.platform_id=d.platform_id) datasets,
- created_by, created_dt
- from platform p
- where name like :1"
- r <- sql.query(gt.db::.gt.db, sql, platform.name)
- .filter.ids(r, show.ids)
-}
-
-mk.platform <- function(platform.name, description)
-{
- .check.name(platform.name)
- sql <-
- "insert into platform
- values (null, :1, :2, :user:, :sysdate:)"
- sql.exec(gt.db::.gt.db, sql, platform.name, description)
-}
-
-rm.platform <- function(platform.name)
-{
- sql <- 'delete from platform where platform_id=:1'
- sql.exec(gt.db::.gt.db, sql, lookup.id('platform', platform.name))
-}
-
-#---------------------------------------------------------------------
-
-ls.dataset <-
-function(project.name='%', dataset.name='%',
- show.all=FALSE, show.ids=FALSE)
-{
- sql <-
- "select dataset_id, d.name dataset_name,
- d.project_id, p.name project_name,
- d.platform_id, m.name platform_name,
- d.description, d.raw_layout, d.is_hidden,
- d.created_by, d.created_dt
- from dataset d, project p, platform m
- where d.project_id=p.project_id
- and d.platform_id=m.platform_id
- and p.name like :1
- and d.name like :2
- and p.is_hidden <= :3
- and d.is_hidden <= :4"
- r <- sql.query(gt.db::.gt.db, sql, project.name, dataset.name,
- show.all, show.all)
- .filter.ids(r, show.ids)
-}
-
-mk.dataset <-
-function(dataset.name, project.name, platform.name,
- description, raw.layout=c(NA,'signal','seqread','chpdata'),
- is.hidden=FALSE)
-{
- raw.layout <- match.arg(raw.layout)
- .check.name(dataset.name)
- proj.id <- lookup.id('project', project.name)
- plat.id <- lookup.id('platform', platform.name)
- sql <-
- "insert into dataset
- values (null, :1, :2, :3, :4, :5, :6, :user:, :sysdate:)"
- sql.exec(gt.db::.gt.db, sql, proj.id, plat.id, dataset.name,
- description, raw.layout, is.hidden)
-}
-
-rm.dataset <- function(dataset.name)
-{
- sql <- 'delete from dataset where dataset_id=:1'
- sql.exec(gt.db::.gt.db, sql, lookup.id('dataset', dataset.name))
-}
+#
+# Copyright (C) 2009, Perlegen Sciences, Inc.
+# Copyright (C) 2010, 23andMe, Inc.
+#
+# Written by David A. Hinds <dhinds at sonic.net>
+#
+# This is free software; you can redistribute it and/or modify it
+# under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 3 of the license, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, see <http://www.gnu.org/licenses/>
+#
+
+#---------------------------------------------------------------------
+
+# Administrative functions for viewing and modifying the contents
+# of the project, platform, and dataset tables
+
+#---------------------------------------------------------------------
+
+ls.project <-
+function(project.name='%', show.all=FALSE, show.ids=FALSE)
+{
+ sql <-
+ "select project_id, name project_name, description,
+ (select count(*) from dataset d
+ where d.project_id=p.project_id
+ and is_hidden <= :1) datasets,
+ is_hidden, created_by, created_dt
+ from project p
+ where name like :2
+ and is_hidden <= :3"
+ r <- sql.query(gt.db::.gt.db, sql, show.all, project.name, show.all)
+ .filter.ids(r, show.ids)
+}
+
+mk.project <- function(project.name, description, is.hidden=FALSE)
+{
+ .check.name(project.name)
+ sql <-
+ "insert into project
+ values (null, :1, :2, :3, :user:, :sysdate:)"
+ sql.exec(gt.db::.gt.db, sql, project.name, description, is.hidden)
+}
+
+rm.project <- function(project.name)
+{
+ sql <- 'delete from project where project_id=:1'
+ sql.exec(gt.db::.gt.db, sql, lookup.id('project', project.name))
+}
+
+#---------------------------------------------------------------------
+
+ls.platform <- function(platform.name='%', show.ids=FALSE)
+{
+ sql <-
+ "select platform_id, name platform_name, description,
+ (select count(*) from dataset d
+ where p.platform_id=d.platform_id) datasets,
+ created_by, created_dt
+ from platform p
+ where name like :1"
+ r <- sql.query(gt.db::.gt.db, sql, platform.name)
+ .filter.ids(r, show.ids)
+}
+
+mk.platform <- function(platform.name, description)
+{
+ .check.name(platform.name)
+ sql <-
+ "insert into platform
+ values (null, :1, :2, :user:, :sysdate:)"
+ sql.exec(gt.db::.gt.db, sql, platform.name, description)
+}
+
+rm.platform <- function(platform.name)
+{
+ sql <- 'delete from platform where platform_id=:1'
+ sql.exec(gt.db::.gt.db, sql, lookup.id('platform', platform.name))
+}
+
+#---------------------------------------------------------------------
+
+ls.dataset <-
+function(project.name='%', dataset.name='%',
+ show.all=FALSE, show.ids=FALSE)
+{
+ sql <-
+ "select dataset_id, d.name dataset_name,
+ d.project_id, p.name project_name,
+ d.platform_id, m.name platform_name,
+ d.description, d.raw_layout, d.is_hidden,
+ d.created_by, d.created_dt
+ from dataset d, project p, platform m
+ where d.project_id=p.project_id
+ and d.platform_id=m.platform_id
+ and p.name like :1
+ and d.name like :2
+ and p.is_hidden <= :3
+ and d.is_hidden <= :4"
+ r <- sql.query(gt.db::.gt.db, sql, project.name, dataset.name,
+ show.all, show.all)
+ .filter.ids(r, show.ids)
+}
+
+mk.dataset <-
+function(dataset.name, project.name, platform.name,
+ description, raw.layout=c(NA,'signal','seqread','chpdata'),
+ is.hidden=FALSE)
+{
+ raw.layout <- match.arg(raw.layout)
+ .check.name(dataset.name)
+ proj.id <- lookup.id('project', project.name)
+ plat.id <- lookup.id('platform', platform.name)
+ sql <-
+ "insert into dataset
+ values (null, :1, :2, :3, :4, :5, :6, :user:, :sysdate:)"
+ sql.exec(gt.db::.gt.db, sql, proj.id, plat.id, dataset.name,
+ description, raw.layout, is.hidden)
+}
+
+rm.dataset <- function(dataset.name)
+{
+ sql <- 'delete from dataset where dataset_id=:1'
+ sql.exec(gt.db::.gt.db, sql, lookup.id('dataset', dataset.name))
+}
Modified: pkg/gt.db/R/affy.R
===================================================================
--- pkg/gt.db/R/affy.R 2010-07-01 00:20:13 UTC (rev 57)
+++ pkg/gt.db/R/affy.R 2010-09-10 20:56:58 UTC (rev 58)
@@ -138,7 +138,7 @@
d$forced.call <- recode.gt(d$forced.call)
qscore <- round(-10*log10(d$confidence))
qscore <- ifelse(is.finite(qscore), qscore, 0)
- raw.data <- rawToHex(matrix(.pack.chpdata(d), ncol=nrow(d)))
+ raw.data <- ramToHex(matrix(.pack.chpdata(d), ncol=nrow(d)))
data.frame(genotype=recode.gt(d$call),
qscore=as.integer(qscore),
raw.data=raw.data,
Modified: pkg/gt.db/R/align.R
===================================================================
--- pkg/gt.db/R/align.R 2010-07-01 00:20:13 UTC (rev 57)
+++ pkg/gt.db/R/align.R 2010-09-10 20:56:58 UTC (rev 58)
@@ -1,82 +1,82 @@
-#
-# Copyright (C) 2009, Perlegen Sciences, Inc.
-#
-# Written by David A. Hinds <dhinds at sonic.net>
-#
-# This is free software; you can redistribute it and/or modify it
-# under the terms of the GNU General Public License as published by
-# the Free Software Foundation; either version 3 of the license, or
-# (at your option) any later version.
-#
-# This program is distributed in the hope that it will be useful,
-# but WITHOUT ANY WARRANTY; without even the implied warranty of
-# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-# GNU General Public License for more details.
-#
-# You should have received a copy of the GNU General Public License
-# along with this program. If not, see <http://www.gnu.org/licenses/>
-#
-
-nw.align <- function(gt1, gt2, gap=-1, pm=1, mm=0, ends=FALSE)
-{
- gt1 <- gsub('[^ACGT]','N',toupper(gt1))
- gt2 <- gsub('[^ACGT]','n',toupper(gt2))
- if (length(ends)==1) ends <- rep(ends,4)
- x <- .Call('do_nw_align', gt1, gt2, c(gap,pm,mm),
- ends, PACKAGE='gt.db')
- p <- nsubstr(x[[3]][2],'|') / nchar(c(gt1,gt2))
- list(score=x[[1]], pct.matched=100*p,
- ends=x[[2]], alignment=x[[3]])
-}
-
-nw.score <- function(gt1, gt2, gap=-1, pm=1, mm=0, ends=FALSE)
-{
- gt1 <- gsub('[^ACGT]','N',toupper(gt1))
- gt2 <- gsub('[^ACGT]','n',toupper(gt2))
- if (length(ends)==1) ends <- rep(ends,4)
- param <- c(gap, pm, mm)
- mapply(.Call, name='do_nw_score', gt1=gt1, gt2=gt2,
- MoreArgs=list(param=param, ends=ends, PACKAGE='gt.db'),
- USE.NAMES=FALSE)
-}
-
-nw.orient.assay <- function(gt1, gt2, delta=1)
-{
- l1 <- sub('(.*)_.*', '\\1', gt1)
- r1 <- sub('.*_(.*)', '\\1', gt1)
- l2 <- sub('(.*)_.*', '\\1', gt2)
- r2 <- sub('.*_(.*)', '\\1', gt2)
- rhs <- c(FALSE,TRUE,FALSE,TRUE)
- fwd <- (nw.score(l1,l2,ends=!rhs) + nw.score(r1,r2,ends=rhs))
- rev <- (nw.score(l1,revcomp(r2),ends=!rhs) +
- nw.score(r1,revcomp(l2),ends=rhs))
- f <- ifelse(fwd>rev+delta, '+', ifelse(rev>fwd+delta, '-', NA))
- factor(f, levels=c('+','-'))
-}
-
-print.align <- function(x, ..., width=50, pad=10)
-{
- do.pad <- function(s)
- {
- n <- seq(1, nchar(s), pad)
- paste(mapply(substr, s, n, n+pad-1), collapse=' ')
- }
- wrap <- function(s)
- {
- n <- seq(1, nchar(s), width)
- mapply(substr, s, n, n+width-1)
- }
- a <- lapply(x$alignment, wrap)
- n1 <- cumsum(c(x$ends[1],nchar(a[[1]])-nsubstr(a[[1]], '-')))
- n2 <- cumsum(c(x$ends[3],nchar(a[[3]])-nsubstr(a[[3]], '-')))
- s1 <- sprintf("%05d ", n1)
- s2 <- sprintf("%05d ", n2)
- e1 <- sprintf(" %05d\n", n1[-1]-1)
- e2 <- sprintf(" %05d\n", n2[-1]-1)
- for (i in 1:length(a[[1]])) {
- cat(s1[i], do.pad(a[[1]][i]), e1[i], sep='')
- cat(' ', do.pad(a[[2]][i]), '\n', sep='')
- cat(s2[i], do.pad(a[[3]][i]), e2[i], sep='')
- if (i < length(a[[1]])) cat('\n')
- }
-}
+#
+# Copyright (C) 2009, Perlegen Sciences, Inc.
+#
+# Written by David A. Hinds <dhinds at sonic.net>
+#
+# This is free software; you can redistribute it and/or modify it
+# under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 3 of the license, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, see <http://www.gnu.org/licenses/>
+#
+
+nw.align <- function(gt1, gt2, gap=-1, pm=1, mm=0, ends=FALSE)
+{
+ gt1 <- gsub('[^ACGT]','N',toupper(gt1))
+ gt2 <- gsub('[^ACGT]','n',toupper(gt2))
+ if (length(ends)==1) ends <- rep(ends,4)
+ x <- .Call('do_nw_align', gt1, gt2, c(gap,pm,mm),
+ ends, PACKAGE='gt.db')
+ p <- nsubstr(x[[3]][2],'|') / nchar(c(gt1,gt2))
+ list(score=x[[1]], pct.matched=100*p,
+ ends=x[[2]], alignment=x[[3]])
+}
+
+nw.score <- function(gt1, gt2, gap=-1, pm=1, mm=0, ends=FALSE)
+{
+ gt1 <- gsub('[^ACGT]','N',toupper(gt1))
+ gt2 <- gsub('[^ACGT]','n',toupper(gt2))
+ if (length(ends)==1) ends <- rep(ends,4)
+ param <- c(gap, pm, mm)
+ mapply(.Call, name='do_nw_score', gt1=gt1, gt2=gt2,
+ MoreArgs=list(param=param, ends=ends, PACKAGE='gt.db'),
+ USE.NAMES=FALSE)
+}
+
+nw.orient.assay <- function(gt1, gt2, delta=1)
+{
+ l1 <- sub('(.*)_.*', '\\1', gt1)
+ r1 <- sub('.*_(.*)', '\\1', gt1)
+ l2 <- sub('(.*)_.*', '\\1', gt2)
+ r2 <- sub('.*_(.*)', '\\1', gt2)
+ rhs <- c(FALSE,TRUE,FALSE,TRUE)
+ fwd <- (nw.score(l1,l2,ends=!rhs) + nw.score(r1,r2,ends=rhs))
+ rev <- (nw.score(l1,revcomp(r2,TRUE),ends=!rhs) +
+ nw.score(r1,revcomp(l2,TRUE),ends=rhs))
+ f <- ifelse(fwd>rev+delta, '+', ifelse(rev>fwd+delta, '-', NA))
+ factor(f, levels=c('+','-'))
+}
+
+print.align <- function(x, ..., width=50, pad=10)
+{
+ do.pad <- function(s)
+ {
+ n <- seq(1, nchar(s), pad)
+ paste(mapply(substr, s, n, n+pad-1), collapse=' ')
+ }
+ wrap <- function(s)
+ {
+ n <- seq(1, nchar(s), width)
+ mapply(substr, s, n, n+width-1)
+ }
+ a <- lapply(x$alignment, wrap)
+ n1 <- cumsum(c(x$ends[1],nchar(a[[1]])-nsubstr(a[[1]], '-')))
+ n2 <- cumsum(c(x$ends[3],nchar(a[[3]])-nsubstr(a[[3]], '-')))
+ s1 <- sprintf("%05d ", n1)
+ s2 <- sprintf("%05d ", n2)
+ e1 <- sprintf(" %05d\n", n1[-1]-1)
+ e2 <- sprintf(" %05d\n", n2[-1]-1)
+ for (i in 1:length(a[[1]])) {
+ cat(s1[i], do.pad(a[[1]][i]), e1[i], sep='')
+ cat(' ', do.pad(a[[2]][i]), '\n', sep='')
+ cat(s2[i], do.pad(a[[3]][i]), e2[i], sep='')
+ if (i < length(a[[1]])) cat('\n')
+ }
+}
Modified: pkg/gt.db/R/assay.R
===================================================================
--- pkg/gt.db/R/assay.R 2010-07-01 00:20:13 UTC (rev 57)
+++ pkg/gt.db/R/assay.R 2010-09-10 20:56:58 UTC (rev 58)
@@ -1,185 +1,185 @@
-#
-# Copyright (C) 2009, Perlegen Sciences, Inc.
-# Copyright (C) 2010, 23andMe, Inc.
-#
-# Written by David A. Hinds <dhinds at sonic.net>
-#
-# This is free software; you can redistribute it and/or modify it
-# under the terms of the GNU General Public License as published by
-# the Free Software Foundation; either version 3 of the license, or
-# (at your option) any later version.
-#
-# This program is distributed in the hope that it will be useful,
-# but WITHOUT ANY WARRANTY; without even the implied warranty of
-# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-# GNU General Public License for more details.
-#
-# You should have received a copy of the GNU General Public License
-# along with this program. If not, see <http://www.gnu.org/licenses/>
-#
-
-#---------------------------------------------------------------------
-
-ls.mapping <-
-function(platform.name, mapping.name='%',
- show.all=FALSE, show.ids=FALSE)
-{
- sql <-
- 'select mapping_id, name mapping_name, description,
- assembly, is_hidden, created_by, created_dt
- from mapping
- where platform_id=:1
- and name like :2
- and is_hidden<=:3'
- r <- sql.query(gt.db::.gt.db, sql, lookup.id('platform', platform.name),
- mapping.name, show.all)
- .filter.ids(r, show.ids)
-}
-
-mk.mapping <-
-function(platform.name, mapping.name, description,
- assembly, is.hidden=FALSE)
-{
- .check.name(mapping.name)
- plat.id <- lookup.id('platform', platform.name)
- sql <-
- "insert into mapping
- values (null, :1, :2, :3, :4, :5, :user:, :sysdate:)"
- sql.exec(gt.db::.gt.db, sql, plat.id, mapping.name,
- description, assembly, is.hidden)
-}
-
-rm.mapping <- function(platform.name, mapping.name)
-{
- grp.id <- lookup.id('mapping', mapping.name,
- platform.id=lookup.id('platform', platform.name))
- sql <- 'delete from mapping where mapping_id=:1'
- sql.exec(gt.db::.gt.db, sql, grp.id)
-}
-
-lookup.mapping.id <- function(platform.name, mapping.name)
-{
- if (missing(mapping.name)) {
- m <- ls.mapping(platform.name, show.ids=TRUE)
- if (nrow(m) != 1)
- stop('could not choose default mapping', call.=FALSE)
- structure(m$mapping.id, names=m$mapping.name)
- } else {
- plat.id <- lookup.id('platform', platform.name)
- lookup.id('mapping', mapping.name, platform.id=plat.id)
- }
-}
-
-#---------------------------------------------------------------------
-
-ls.assay <- function(platform.name, show.ids=FALSE)
-{
- sql <-
- 'select assay_id, name assay_name, alleles, probe_seq
- from assay where platform_id=:1'
- r <- sql.query(gt.db::.gt.db, sql, lookup.id('platform', platform.name))
- .filter.ids(data.frame(r, row.names=r$assay.name), show.ids)
-}
-
-mk.assay <- function(platform.name, data, progress=FALSE)
-{
- plat.id <- lookup.id('platform', platform.name)
- .check.name(data$assay.name)
- r <- (regexpr('^[a-zA-Z]*_[a-zA-Z]*$', data$probe.seq) < 0)
- if (any(r,na.rm=TRUE))
- stop("invalid probe sequence(s)", call.=FALSE)
- if (is.null(data$flags)) data$flags <- 0
- if (is.null(data$probe.seq)) data$probe.seq <- NA
- if (is.null(data$alt.name)) data$alt.name <- NA
- sql <- 'insert into assay values (null,:1,:2,:3,:4,:5,:6)'
- sql.exec(gt.db::.gt.db, sql, plat.id,
- data[c('assay.name','flags','alleles','probe.seq','alt.name')],
- progress=progress)
-}
-
-#---------------------------------------------------------------------
-
-.fixup.ploidy <- function(ploidy)
-{
- if (!all(ploidy %in% c('A','M','X','Y',NA)))
- stop('Invalid ploidy data')
- factor(ploidy, levels=c('A','M','X','Y'))
-}
-
-ls.assay.position <-
-function(platform.name, mapping.name, show.ids=FALSE)
-{
- map.id <- lookup.mapping.id(platform.name, mapping.name)
- sql <-
- 'select a.assay_id, a.name assay_name, scaffold, position,
- strand, ploidy, dbsnp_rsid, dbsnp_orient
- from assay a, assay_position p
- where mapping_id=:1
- and a.assay_id=p.assay_id'
- r <- sql.query(gt.db::.gt.db, sql, map.id)
- r$ploidy <- .fixup.ploidy(r$ploidy)
- .filter.ids(data.frame(r,row.names=r$assay.name), show.ids)
-}
-
-mk.assay.position <-
-function(platform.name, mapping.name, data, progress=FALSE)
-{
- map.id <- lookup.mapping.id(platform.name, mapping.name)
- if (is.null(data$assay.id)) {
- plat.id <- lookup.id('platform', platform.name)
- data$assay.id <- lookup.id('assay', data$assay.name,
- platform.id=plat.id)
- }
- sql <-
- 'insert into assay_position values (:1,:2,:3,:4,:5,:6,:7,:8)'
- if (is.null(data$ploidy)) {
- warning("ploidy information is missing")
- data$ploidy <- NA
- }
- data$ploidy <- .fixup.ploidy(data$ploidy)
- if (is.null(data$dbsnp.rsid)) data$dbsnp.rsid <- NA
- if (is.null(data$dbsnp.orient)) data$dbsnp.orient <- NA
- sql.exec(gt.db::.gt.db, sql, map.id,
- data[c('assay.id', 'scaffold', 'position', 'strand',
- 'ploidy', 'dbsnp.rsid', 'dbsnp.orient')],
- progress=progress)
-}
-
-#---------------------------------------------------------------------
-
-mk.assay.data <- function(dataset.name, data, progress=FALSE)
-{
- dset.id <- lookup.id('dataset', dataset.name)
- if (is.null(data$flags)) data$flags <- 0
- if (is.null(data$qscore)) data$qscore <- NA
- if (is.null(data$raw.data)) data$raw.data <- NA
- if (is.null(data$assay.id)) {
- plat.id <- ls.dataset(dataset.name=dataset.name,
- show.ids=TRUE)$platform.id
- data$assay.id <- lookup.id('assay', data$assay.name,
- platform.id=plat.id)
- }
-
- db.mode <- .gt.db.options('db.mode')
- tx.mode <- .gt.db.options('tx.mode')
- if ((db.mode == tx.mode) || (db.mode == 'raw') &&
- all(is.na(data$qscore) && is.na(data$raw.data))) {
- txt.fn <- ''
- raw.fn <- ''
- } else if (db.mode == 'raw' && tx.mode == 'hex') {
- txt.fn <- ''
- raw.fn <- ':unhex:'
- } else if (db.mode == 'zip' && tx.mode == 'hex') {
- txt.fn <- ':zip:'
- raw.fn <- ':zip.unhex:'
- } else {
- stop('unknown conversion!')
- }
-
- sql <-
- 'insert into assay_data
- values (null,:1,:2,:3,%1$s(:4),%2$s(:5),%2$s(:6))'
- sql <- sprintf(sql, txt.fn, raw.fn)
- cols <- c('assay.id','flags','genotype','qscore','raw.data')
- sql.exec(gt.db::.gt.db, sql, dset.id, data[cols], progress=progress)
-}
+#
+# Copyright (C) 2009, Perlegen Sciences, Inc.
+# Copyright (C) 2010, 23andMe, Inc.
+#
+# Written by David A. Hinds <dhinds at sonic.net>
+#
+# This is free software; you can redistribute it and/or modify it
+# under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 3 of the license, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, see <http://www.gnu.org/licenses/>
+#
+
+#---------------------------------------------------------------------
+
+ls.mapping <-
+function(platform.name, mapping.name='%',
+ show.all=FALSE, show.ids=FALSE)
+{
+ sql <-
+ 'select mapping_id, name mapping_name, description,
+ assembly, is_hidden, created_by, created_dt
+ from mapping
+ where platform_id=:1
+ and name like :2
+ and is_hidden<=:3'
+ r <- sql.query(gt.db::.gt.db, sql, lookup.id('platform', platform.name),
+ mapping.name, show.all)
+ .filter.ids(r, show.ids)
+}
+
+mk.mapping <-
+function(platform.name, mapping.name, description,
+ assembly, is.hidden=FALSE)
+{
+ .check.name(mapping.name)
+ plat.id <- lookup.id('platform', platform.name)
+ sql <-
+ "insert into mapping
+ values (null, :1, :2, :3, :4, :5, :user:, :sysdate:)"
+ sql.exec(gt.db::.gt.db, sql, plat.id, mapping.name,
+ description, assembly, is.hidden)
+}
+
+rm.mapping <- function(platform.name, mapping.name)
+{
+ grp.id <- lookup.id('mapping', mapping.name,
+ platform.id=lookup.id('platform', platform.name))
+ sql <- 'delete from mapping where mapping_id=:1'
+ sql.exec(gt.db::.gt.db, sql, grp.id)
+}
+
+lookup.mapping.id <- function(platform.name, mapping.name)
+{
+ if (missing(mapping.name)) {
+ m <- ls.mapping(platform.name, show.ids=TRUE)
+ if (nrow(m) != 1)
+ stop('could not choose default mapping', call.=FALSE)
+ structure(m$mapping.id, names=m$mapping.name)
+ } else {
+ plat.id <- lookup.id('platform', platform.name)
+ lookup.id('mapping', mapping.name, platform.id=plat.id)
+ }
+}
+
+#---------------------------------------------------------------------
+
+ls.assay <- function(platform.name, show.ids=FALSE)
+{
+ sql <-
+ 'select assay_id, name assay_name, alleles, probe_seq
+ from assay where platform_id=:1'
+ r <- sql.query(gt.db::.gt.db, sql, lookup.id('platform', platform.name))
+ .filter.ids(data.frame(r, row.names=r$assay.name), show.ids)
+}
+
+mk.assay <- function(platform.name, data, progress=FALSE)
+{
+ plat.id <- lookup.id('platform', platform.name)
+ .check.name(data$assay.name)
+ r <- (regexpr('^[a-zA-Z]*_[a-zA-Z]*$', data$probe.seq) < 0)
+ if (any(r,na.rm=TRUE))
+ stop("invalid probe sequence(s)", call.=FALSE)
+ if (is.null(data$flags)) data$flags <- 0
+ if (is.null(data$probe.seq)) data$probe.seq <- NA
+ if (is.null(data$alt.name)) data$alt.name <- NA
+ sql <- 'insert into assay values (null,:1,:2,:3,:4,:5,:6)'
+ sql.exec(gt.db::.gt.db, sql, plat.id,
+ data[c('assay.name','flags','alleles','probe.seq','alt.name')],
+ progress=progress)
+}
+
+#---------------------------------------------------------------------
+
+.fixup.ploidy <- function(ploidy)
+{
+ if (!all(ploidy %in% c('A','M','X','Y',NA)))
+ stop('Invalid ploidy data')
+ factor(ploidy, levels=c('A','M','X','Y'))
+}
+
+ls.assay.position <-
+function(platform.name, mapping.name, show.ids=FALSE)
+{
+ map.id <- lookup.mapping.id(platform.name, mapping.name)
+ sql <-
+ 'select a.assay_id, a.name assay_name, scaffold, position,
+ strand, ploidy, dbsnp_rsid, dbsnp_orient
+ from assay a, assay_position p
+ where mapping_id=:1
+ and a.assay_id=p.assay_id'
+ r <- sql.query(gt.db::.gt.db, sql, map.id)
+ r$ploidy <- .fixup.ploidy(r$ploidy)
+ .filter.ids(data.frame(r,row.names=r$assay.name), show.ids)
+}
+
+mk.assay.position <-
+function(platform.name, mapping.name, data, progress=FALSE)
+{
+ map.id <- lookup.mapping.id(platform.name, mapping.name)
+ if (is.null(data$assay.id)) {
+ plat.id <- lookup.id('platform', platform.name)
+ data$assay.id <- lookup.id('assay', data$assay.name,
+ platform.id=plat.id)
+ }
+ sql <-
+ 'insert into assay_position values (:1,:2,:3,:4,:5,:6,:7,:8)'
+ if (is.null(data$ploidy)) {
+ warning("ploidy information is missing")
+ data$ploidy <- NA
+ }
+ data$ploidy <- .fixup.ploidy(data$ploidy)
+ if (is.null(data$dbsnp.rsid)) data$dbsnp.rsid <- NA
+ if (is.null(data$dbsnp.orient)) data$dbsnp.orient <- NA
+ sql.exec(gt.db::.gt.db, sql, map.id,
+ data[c('assay.id', 'scaffold', 'position', 'strand',
+ 'ploidy', 'dbsnp.rsid', 'dbsnp.orient')],
+ progress=progress)
+}
+
+#---------------------------------------------------------------------
+
+mk.assay.data <- function(dataset.name, data, progress=FALSE)
+{
+ dset.id <- lookup.id('dataset', dataset.name)
+ if (is.null(data$flags)) data$flags <- 0
+ if (is.null(data$qscore)) data$qscore <- NA
+ if (is.null(data$raw.data)) data$raw.data <- NA
+ if (is.null(data$assay.id)) {
+ plat.id <- ls.dataset(dataset.name=dataset.name,
+ show.ids=TRUE)$platform.id
+ data$assay.id <- lookup.id('assay', data$assay.name,
+ platform.id=plat.id)
+ }
+
+ db.mode <- .gt.db.options('db.mode')
+ tx.mode <- .gt.db.options('tx.mode')
+ if ((db.mode == tx.mode) || (db.mode == 'raw') &&
+ all(is.na(data$qscore) && is.na(data$raw.data))) {
+ txt.fn <- ''
+ raw.fn <- ''
+ } else if (db.mode == 'raw' && tx.mode == 'hex') {
+ txt.fn <- ''
+ raw.fn <- ':unhex:'
+ } else if (db.mode == 'zip' && tx.mode == 'hex') {
+ txt.fn <- ':zip:'
+ raw.fn <- ':zip.unhex:'
+ } else {
+ stop('unknown conversion!')
[TRUNCATED]
To get the complete diff run:
svnlook diff /svnroot/gtdb -r 58
More information about the Gtdb-commits
mailing list