version 1.3

cran · Nov 1, 2010 · d4dd9fc · d4dd9fc
1 parent ac4b3b2
commit d4dd9fc
Show file tree

Hide file tree

Showing 72 changed files with 2,644 additions and 1,043 deletions.
diff --git a/ChangeLog b/ChangeLog
@@ -1,3 +1,25 @@
+12-22-2010 : 1.3
+	* improvements to memory handler, which previously slowed down rphast
+	  by 33%.  Now there is no significant increase in run-time, at least
+	  for the code in rphast/tests.  It also no longer causes occasional
+	  segfaults when code is interrupted, since protection now occurs
+	  during the on.exit function instead of only when the function
+	  finishes cleanly.  We also protect all external pointer objects,
+	  rather than only the ones the user might see, which also cleans up
+	  potential segfaults and makes writing new RPHAST functions more 
+	  foolproof.
+	* fixed bug in phyloFit when optimizing codon models with the
+	  selection parameter; now rate matrix is scaled before applying
+	  selection parameter.
+	* fixed bug in plot.msa where alignment plot was placed wrongly when
+	  ploted with several tracks.
+	* changed phyloP to always return 1-based coordinates
+	* added function mod.backgd.tm which modifies background frequency of
+	  tree model while maintaining reversibility
+	* added function translate.msa
+	* added function col.expected.subs.msa
+	* use %g notation (instead of %f) to print branch lengths of trees;
+	  this avoids some loss of precision when passing trees to/from R/C.
 11-10-2010: 1.2 released 
 	* added memory handler so that memory allocated in C is no longer
 	  lost due to function interrupt (or failure to explicitly free it)

diff --git a/DESCRIPTION b/DESCRIPTION
@@ -1,5 +1,5 @@
 Package: rphast
-Version: 1.2
+Version: 1.3
 Date: 2010-11-01
 Title: R interface to PHAST software for comparative genomics
 Author: Melissa Hubisz, Katherine Pollard, and Adam Siepel
@@ -23,6 +23,6 @@ Suggests: ape, seqLogo
 Collate: 'checkArgs.R' 'feat.R' 'hmm.R' 'listOfLists.R' 'msa.R'
         'phastCons.R' 'phyloFit.R' 'phyloP.R' 'plot.R' 'rphast.R'
         'treeModel.R' 'trees.R'
-Packaged: 2010-11-10 16:54:07 UTC; melissa
+Packaged: 2010-12-22 17:02:24 UTC; melissa
 Repository: CRAN
-Date/Publication: 2010-11-11 12:40:48
+Date/Publication: 2010-12-23 10:28:59
diff --git a/MD5 b/MD5
diff --git a/NAMESPACE b/NAMESPACE
@@ -51,6 +51,7 @@ useDynLib(rphast)
 export(msa)
 export(ncol.msa)
 S3method(ncol, msa)
+export(coord.range.msa)
 S3method(dim, msa)
 export(dim.msa)
 export(ninf.msa)
@@ -81,6 +82,7 @@ export("[.msa")
 export(postprob.msa)
 export(expected.subs.msa)
 export(total.expected.subs.msa)
+export(col.expected.subs.msa)
 export(likelihood.msa)
 export(simulate.msa)
 importFrom(stats, simulate)
@@ -97,6 +99,7 @@ export(state.freq.msa)
 export(base.freq.msa)
 export(gc.content.msa)
 export(pairwise.diff.msa)
+export(translate.msa)
 export(plot.msa)
 export(phastCons)
 export(phyloFit)
@@ -122,6 +125,7 @@ S3method(print, tm)
 export(is.subst.mod.tm)
 export(subst.mods)
 export(tm)
+export(mod.backgd.tm)
 export(bgc.sel.factor)
 export(apply.bgc.sel)
 export(unapply.bgc.sel)

diff --git a/R/feat.R b/R/feat.R
@@ -21,8 +21,7 @@
 copy.feat <- function(x) {
   if (is.null(x$externalPtr)) return(x)
   result <- .makeObj.feat()
-  on.exit(freeall.rphast())
-  result$externalPtr <- .Call("rph_gff_copy", x$externalPtr)
+  result$externalPtr <- .Call.rphast("rph_gff_copy", x$externalPtr)
   result
 }
 
@@ -58,8 +57,7 @@ copy.feat <- function(x) {
 ##' @export
 read.feat <- function(filename, pointer.only=FALSE) {
   feat <- .makeObj.feat()
-  on.exit(freeall.rphast())
-  feat$externalPtr <- .Call("rph_gff_read", filename)
+  feat$externalPtr <- .Call.rphast("rph_gff_read", filename)
   if (!pointer.only) {
     feat <- as.data.frame.feat(feat)
   }
@@ -140,11 +138,10 @@ feat <- function(seqname="default", src=".", feature=".",
     if (!is.null(strand)) strand <- as.character(strand)
     if (!is.null(frame)) frame <- as.integer(frame)
     if (!is.null(attribute)) attribute <- as.character(attribute)
-    on.exit(freeall.rphast())
-    ptr <- .Call("rph_gff_new", as.character(seqname),
-                 as.character(src), as.character(feature),
-                 as.integer(start), as.integer(end),
-                 score, strand, frame, attribute)
+    ptr <- .Call.rphast("rph_gff_new", as.character(seqname),
+                        as.character(src), as.character(feature),
+                        as.integer(start), as.integer(end),
+                        score, strand, frame, attribute)
     x <- .makeObj.feat()
     x$externalPtr <- ptr
   } else {
@@ -204,8 +201,7 @@ write.feat <- function(x, file) {
   check.arg(file, "file", "character", null.OK=TRUE)
   if (is.null(x$externalPtr))
     x <- as.pointer.feat(x)
-  on.exit(freeall.rphast())
-  invisible(.Call("rph_gff_print", file, x$externalPtr))
+  invisible(.Call.rphast("rph_gff_print", file, x$externalPtr))
 }
 
 
@@ -220,8 +216,7 @@ write.feat <- function(x, file) {
 nrow.feat <- function(x) {
   if (is.null(x$externalPtr))
     return(dim(x)[1])
-  on.exit(freeall.rphast())
-  .Call("rph_gff_numrow", x$externalPtr)
+  .Call.rphast("rph_gff_numrow", x$externalPtr)
 }
 
 
@@ -279,8 +274,7 @@ summary.feat <- function(object, ...) {
 as.data.frame.feat <- function(x, row.names=NULL, optional=FALSE, ...) {
   if (is.data.frame(x)) return(x)
   if (!is.null(x$externalPtr)) {
-    on.exit(freeall.rphast())
-    x <- .Call("rph_gff_dataframe", x$externalPtr)
+    x <- .Call.rphast("rph_gff_dataframe", x$externalPtr)
   }
   attr(x, "class") <- "list"
   as.data.frame(x, row.names, optional, ...)
@@ -320,9 +314,8 @@ range.feat <- function(..., na.rm=FALSE) {
     if (is.data.frame(x)) {
       r <- range(c(x$start, x$end), na.rm=na.rm)
     } else {
-      on.exit(freeall.rphast())
-      r <- c(.Call("rph_gff_minCoord", x$externalPtr),
-             .Call("rph_gff_maxCoord", x$externalPtr))
+      r <- c(.Call.rphast("rph_gff_minCoord", x$externalPtr),
+             .Call.rphast("rph_gff_maxCoord", x$externalPtr))
     }
     mins[i] <- r[1]
     maxs[i] <- r[2]
@@ -558,15 +551,13 @@ plot.gene <- function(x, y=0, height=1,
 density.feat <- function(x, type="length", ...) {
   if (type == "length") {
     if (!is.null(x$externalPtr)) {
-      on.exit(freeall.rphast())
-      vals <- .Call("rphast_gff_lengths", x$externalPtr)
+      vals <- .Call.rphast("rphast_gff_lengths", x$externalPtr)
     } else {
       vals <- x$end - x$start
     }
   } else if (type == "score") {
     if (!is.null(x$externalPtr)) {
-      on.exit(freeall.rphast())
-      vals <- .Call("rphast_gff_getScores", x$externalPtr)
+      vals <- .Call.rphast("rphast_gff_getScores", x$externalPtr)
     } else {
       vals <- x$score
     }
@@ -586,17 +577,15 @@ density.feat <- function(x, type="length", ...) {
 hist.feat <- function(x, type="length", ...) {
   if (type == "length") {
     if (!is.null(x$externalPtr)) {
-      on.exit(freeall.rphast())
-      starts <- .Call("rph_gff_starts", x$externalPtr)
-      ends <- .Call("rph_gff_ends", x$externalPtr)
+      starts <- .Call.rphast("rph_gff_starts", x$externalPtr)
+      ends <- .Call.rphast("rph_gff_ends", x$externalPtr)
       vals <- ends - starts + 1
     } else {
       vals <- x$end - x$start + 1
     }
   } else if (type == "score") {
     if (!is.null(x$externalPtr)) {
-      on.exit(freeall.rphast())
-      vals <- .Call("rph_gff_scores", x$externalPtr)
+      vals <- .Call.rphast("rph_gff_scores", x$externalPtr)
     } else {
       vals <- x$score
     }
@@ -647,9 +636,10 @@ overlap.feat <- function(x, filter, numbase=1, min.percent=NULL,
     filter <- as.pointer.feat(filter)
 
   rv <- .makeObj.feat()
-  on.exit(freeall.rphast())
-  rv$externalPtr <- .Call("rph_gff_overlapSelect", x$externalPtr, filter$externalPtr,
-                          numbase, min.percent, !overlapping, get.fragments)
+  rv$externalPtr <- .Call.rphast("rph_gff_overlapSelect",
+                                 x$externalPtr, filter$externalPtr,
+                                 numbase, min.percent, !overlapping,
+                                 get.fragments)
   if (!is.null(rv) && !pointer.only) {
     rv <- as.data.frame.feat(rv)
   }
@@ -677,10 +667,9 @@ inverse.feat <- function(x, region.bounds, pointer.only=FALSE) {
   if (is.null(region.bounds$externalPtr))
     region.bounds <- as.pointer.feat(region.bounds)
   rv <- .makeObj.feat()
-  on.exit(freeall.rphast())
-  rv$externalPtr <- .Call("rph_gff_inverse",
-                          x$externalPtr,
-                          region.bounds$externalPtr)
+  rv$externalPtr <- .Call.rphast("rph_gff_inverse",
+                                 x$externalPtr,
+                                 region.bounds$externalPtr)
   if (!pointer.only)
     rv <- as.data.frame.feat(rv)
   rv
@@ -732,14 +721,14 @@ coverage.feat <- function(..., or=FALSE, not=NULL, get.feats=FALSE,
       x <- as.pointer.feat(x)
     featlist[[i]] <- x$externalPtr
   }
-  on.exit(freeall.rphast())
   if (get.feats) {
     rv <- .makeObj.feat()
-    rv$externalPtr <- .Call("rph_gff_featureBits", featlist, or, get.feats)
+    rv$externalPtr <- .Call.rphast("rph_gff_featureBits", featlist,
+                                   or, get.feats)
     if (pointer.only) return(rv)
     return(as.data.frame.feat(rv))
   }
-  .Call("rph_gff_featureBits", featlist, or, get.feats)
+  .Call.rphast("rph_gff_featureBits", featlist, or, get.feats)
 }
 
 
@@ -759,8 +748,7 @@ add.UTRs.feat <- function(x) {
     getDataFrame <- TRUE
   } else getDataFrame <- FALSE
   rv <- .makeObj.feat()
-  on.exit(freeall.rphast())
-  rv$externalPtr <- .Call("rph_gff_add_UTRs", x$externalPtr)
+  rv$externalPtr <- .Call.rphast("rph_gff_add_UTRs", x$externalPtr)
   if (getDataFrame) return(as.data.frame.feat(rv))
   rv
 }
@@ -781,8 +769,7 @@ add.introns.feat <- function(x) {
     getDataFrame <- TRUE
   } else getDataFrame <- FALSE
   rv <- .makeObj.feat()
-  on.exit(freeall.rphast())
-  rv$externalPtr <- .Call("rph_gff_add_introns", x$externalPtr)
+  rv$externalPtr <- .Call.rphast("rph_gff_add_introns", x$externalPtr)
   if (getDataFrame) return(as.data.frame.feat(rv))
   rv
 }
@@ -806,8 +793,7 @@ add.signals.feat <- function(x) {
     getDataFrame <- TRUE
   } else getDataFrame <- FALSE
   rv <- .makeObj.feat()
-  on.exit(freeall.rphast())
-  rv$externalPtr <- .Call("rph_gff_add_signals", x$externalPtr)
+  rv$externalPtr <- .Call.rphast("rph_gff_add_signals", x$externalPtr)
   if (getDataFrame) return(as.data.frame.feat(rv))
   rv
 }
@@ -834,8 +820,7 @@ fix.start.stop.feat <- function(x) {
     getDataFrame <- TRUE
   } else getDataFrame <- FALSE
   rv <- .makeObj.feat()
-  on.exit(freeall.rphast())
-  rv$externalPtr <- .Call("rph_gff_fix_start_stop", x$externalPtr)
+  rv$externalPtr <- .Call.rphast("rph_gff_fix_start_stop", x$externalPtr)
   if (getDataFrame) return(as.data.frame.feat(rv))
   rv
 }
@@ -862,8 +847,7 @@ rbind.feat <- function(...) {
     }
   }
   if (idx == 1) return(NULL)
-  on.exit(freeall.rphast())
-  feat$externalPtr <- .Call("rph_gff_append", featlist)
+  feat$externalPtr <- .Call.rphast("rph_gff_append", featlist)
   as.data.frame.feat(feat)
 }
 
@@ -903,10 +887,9 @@ split.feat <- function(x, f, drop=FALSE, start.from="left",
   if (is.null(x$externalPtr))
     x <- as.pointer.feat(x)
   splitFeat <- .makeObj.feat()
-  on.exit(freeall.rphast())
-  splitFeat$externalPtr <- .Call("rph_gff_split", x$externalPtr,
-                                max.length, drop, 
-                                 ifelse(start.from=="left", 0, 1))
+  splitFeat$externalPtr <- .Call.rphast("rph_gff_split", x$externalPtr,
+                                        max.length, drop, 
+                                        ifelse(start.from=="left", 0, 1))
   if (!pointer.only)
     splitFeat <- as.data.frame.feat(splitFeat)
   splitFeat
@@ -930,8 +913,7 @@ sort.feat <- function(x, decreasing = FALSE, ...) {
   if (is.null(x$externalPtr))
     x <- as.pointer.feat(x)
   rv <- .makeObj.feat()
-  on.exit(freeall.rphast())
-  rv$externalPtr <- .Call("rph_gff_sort", x$externalPtr)
+  rv$externalPtr <- .Call.rphast("rph_gff_sort", x$externalPtr)
   rv <- as.data.frame.feat(rv)
   if (decreasing) 
     rv <- rv[dim(rv)[1]:1,]
@@ -1033,8 +1015,7 @@ unique.feat <- function(x, incomparables=FALSE, ...) {
     getDataFrame <- TRUE
   } else getDataFrame <- FALSE
   rv <- .makeObj.feat()
-  on.exit(freeall.rphast())
-  rv$externalPtr <- .Call("rph_gff_nonOverlapping_genes", x$externalPtr)
+  rv$externalPtr <- .Call.rphast("rph_gff_nonOverlapping_genes", x$externalPtr)
   if (getDataFrame)
     rv <- as.data.frame.feat(rv)
   rv
@@ -1063,8 +1044,8 @@ tagval.feat <- function(x, tag) {
     if (is.null(x$attribute)) return (rep(NA, nrow(x)))
     x <- as.pointer.feat(x)
   }
-  on.exit(freeall.rphast())
-  rv <- rphast.simplify.list(.Call("rph_gff_one_attribute", x$externalPtr, tag))
+  rv <- rphast.simplify.list(.Call.rphast("rph_gff_one_attribute",
+                                          x$externalPtr, tag))
   maxlen <- max(sapply(rv, length))
   if (maxlen == 1L) rv <- as.character(rv)
     f <- rv==""