This is an automated email from the git hooks/post-receive script. tille pushed a commit to branch master in repository r-bioc-biocgenerics.
commit 09a6bb84d05d909a19bc5da4a936f63c54e33f07 Author: Andreas Tille <[email protected]> Date: Sun May 8 07:32:07 2016 +0200 Imported Upstream version 0.18.0 --- DESCRIPTION | 6 +- NAMESPACE | 7 +- R/order.R | 2 +- R/strand.R | 10 ++ R/test_BiocGenerics_package.R | 1 - R/updateObject.R | 105 +++++++++++++++++---- R/zzz.R | 2 +- inst/unitTests/test_updateObject.R | 28 ++++++ man/BiocGenerics-package.Rd | 4 +- man/is.unsorted.Rd | 7 +- man/lengths.Rd | 2 +- man/order.Rd | 4 +- man/rank.Rd | 2 +- man/strand.Rd | 37 ++++++-- man/updateObject.Rd | 29 ++++-- .../{BiocGenerics_unit_tests.R => run_unitTests.R} | 0 16 files changed, 198 insertions(+), 48 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index b32c706..9c2e4ac 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,7 +1,7 @@ Package: BiocGenerics Title: S4 generic functions for Bioconductor Description: S4 generic functions needed by many Bioconductor packages. -Version: 0.16.1 +Version: 0.18.0 Author: The Bioconductor Dev Team Maintainer: Bioconductor Package Maintainer <[email protected]> biocViews: Infrastructure @@ -21,6 +21,6 @@ Collate: S3-classes-as-S4-classes.R normarg-utils.R replaceSlots.R weights.R xtabs.R clusterApply.R annotation.R combine.R dbconn.R dge.R fileName.R normalize.R organism_species.R plotMA.R plotPCA.R score.R strand.R updateObject.R - testPackage.R test_BiocGenerics_package.R zzz.R + testPackage.R zzz.R NeedsCompilation: no -Packaged: 2015-11-06 03:02:04 UTC; biocbuild +Packaged: 2016-05-04 04:18:48 UTC; biocbuild diff --git a/NAMESPACE b/NAMESPACE index 4584ade..ce36595 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -204,7 +204,7 @@ export( score, "score<-", ## from R/strand.R: - strand, "strand<-", + strand, "strand<-", invertStrand, ## from R/updateObject.R: updateObject, @@ -229,7 +229,10 @@ exportMethods( estimateDispersions, plotDispEsts, plotMA, - plotPCA + plotPCA, + + ## from R/strand.R: + invertStrand ) diff --git a/R/order.R b/R/order.R index e2bf23b..6581b8f 100644 --- a/R/order.R +++ b/R/order.R @@ -3,7 +3,7 @@ ### ------------------------------------------------------------------------- ### ### Need to explicitly define this generic otherwise the implicit generic in -### package "base" would dispatch on ('na.last', 'decreasing'). +### package "base" would dispatch on ('na.last', 'decreasing', 'method'). ### ### Note that dispatching on '...' is supported starting with R 2.8.0 only. diff --git a/R/strand.R b/R/strand.R index 06517c9..99e4ef6 100644 --- a/R/strand.R +++ b/R/strand.R @@ -12,3 +12,13 @@ unstrand <- function(x) x } +setGeneric("invertStrand", function(x) standardGeneric("invertStrand")) + +setMethod("invertStrand", "ANY", + function(x) + { + strand(x) <- invertStrand(strand(x)) + x + } +) + diff --git a/R/test_BiocGenerics_package.R b/R/test_BiocGenerics_package.R deleted file mode 100644 index a71263d..0000000 --- a/R/test_BiocGenerics_package.R +++ /dev/null @@ -1 +0,0 @@ -.test <- function() testPackage("BiocGenerics") diff --git a/R/updateObject.R b/R/updateObject.R index 9e36f64..7356cfe 100644 --- a/R/updateObject.R +++ b/R/updateObject.R @@ -11,6 +11,15 @@ ### Utilities. ### +updateObjectFrom_errf <- function(..., verbose=FALSE) { + function(err) { + if (verbose) + message(..., ":\n ", conditionMessage(err), + "\n trying next method...") + NULL + } +} + getObjectSlots <- function(object) # object, rather than class defn, slots { if (!is.object(object) || isVirtualClass(class(object))) @@ -45,15 +54,6 @@ updateObjectFromSlots <- function(object, objclass=class(object), "returning original object") return(object) } - errf <- function(...) - { - function(err) { - if (verbose) - message(..., ":\n ", conditionMessage(err), - "\n trying next method...") - NULL - } - } if (verbose) message("updateObjectFromSlots(object = '", class(object), "' class = '", objclass, "')") @@ -68,9 +68,9 @@ updateObjectFromSlots <- function(object, objclass=class(object), updateObject, ..., verbose=verbose) toDrop <- which(!names(objectSlots) %in% classSlots) if (length(toDrop) > 0L) { - warning("dropping slot(s) ", - paste(names(objectSlots)[toDrop],collapse=", "), - " from object = '", class(object), "'") + warning("dropping slot(s) '", + paste(names(objectSlots)[toDrop], collapse="', '"), + "' from object = '", class(object), "'") objectSlots <- objectSlots[-toDrop] } ## ad-hoc methods for creating new instances @@ -80,8 +80,9 @@ updateObjectFromSlots <- function(object, objclass=class(object), message("heuristic updateObjectFromSlots, method 1") res <- tryCatch({ do.call(new, c(objclass, objectSlots[joint])) - }, error=errf("'new(\"", objclass, - "\", ...)' from slots failed")) + }, error=updateObjectFrom_errf( + "'new(\"", objclass, "\", ...)' from slots failed", + verbose=verbose)) } if (is.null(res)) { if (verbose) @@ -92,8 +93,9 @@ updateObjectFromSlots <- function(object, objclass=class(object), slot(obj, slt) <- updateObject(objectSlots[[slt]], ..., verbose=verbose) obj - }, error=errf("failed to add slots to 'new(\"", objclass, - "\", ...)'")) + }, error=updateObjectFrom_errf( + "failed to add slots to 'new(\"", objclass, "\", ...)'", + verbose=verbose)) } if (is.null(res)) stop("could not updateObject to class '", objclass, "'", @@ -102,6 +104,60 @@ updateObjectFromSlots <- function(object, objclass=class(object), res } +getObjectFields <- function(object) +{ + value <- object$.refClassDef@fieldClasses + for (field in names(value)) + value[[field]] <- object$field(field) + value +} + +updateObjectFromFields <- + function(object, objclass=class(object), ..., verbose=FALSE) +{ + if (verbose) + message("updateObjectFromFields(object = '", class(object), + "' objclass = '", objclass, "')") + + classFields <- names(getRefClass(objclass)$fields()) + if (is.null(classFields)) { + if (verbose) + message("definition of '", objclass, "' has no fields; ", + "regurning original object") + return(object) + } + + objectFields <- getObjectFields(object) + + toUpdate <- joint <- intersect(names(objectFields), classFields) + objectFields[toUpdate] <- + lapply(objectFields[toUpdate], updateObject, ..., verbose=verbose) + toDrop <- which(!names(objectFields) %in% classFields) + if (length(toDrop) > 0L) { + warning("dropping fields(s) '", + paste(names(objectFields)[toDrop], collapse="', '"), + "' from object = '", class(object), "'") + objectFields <- objectFields[-toDrop] + } + + ## ad-hoc methods for creating new instances + + if (verbose) + message("heuristic updateObjectFromFields, method 1") + res <- tryCatch({ + do.call(new, c(objclass, objectFields[joint])) + }, error = updateObjectFrom_errf( + "'new(\"", objclass, "\", ...' from slots failed", + verbose=verbose) + ) + + if (is.null(res)) + stop("could not updateObject to class '", objclass, "'", + "\nconsider defining an 'updateObject' method for class '", + class(object), "'") + res +} + ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### updateObject() @@ -180,3 +236,20 @@ setMethod("updateObject", "environment", } ) +setMethod("updateObject", "formula", + function(object, ..., verbose=FALSE) +{ + if (verbose) + ## [email protected] could be too general, e.g,. R_GlobalEnv + message("updateObject(object = 'formula'); ignoring .Environment") + object +}) + +setMethod("updateObject", "envRefClass", + function(object, ..., verbose=FALSE) +{ + msg <- sprintf("updateObject(object= '%s')", class(object)) + if (verbose) + message(msg) + updateObjectFromFields(object, ..., verbose=verbose) +}) diff --git a/R/zzz.R b/R/zzz.R index b40e1c1..0b8695b 100644 --- a/R/zzz.R +++ b/R/zzz.R @@ -1,2 +1,2 @@ -### +.test <- function() testPackage("BiocGenerics") diff --git a/inst/unitTests/test_updateObject.R b/inst/unitTests/test_updateObject.R index d70fdd6..365ca34 100644 --- a/inst/unitTests/test_updateObject.R +++ b/inst/unitTests/test_updateObject.R @@ -91,3 +91,31 @@ test_updateObject_setClass <- function() removeClass("A", where=.GlobalEnv) } +test_updateObject_refClass <- function() +{ + cls <- ".__test_updateObject_refClassA" + .A <- setRefClass(cls, fields=list(x="numeric", y="numeric"), + where=.GlobalEnv) + + a <- .A() + checkTrue(all.equal(a, updateObject(a))) + + a <- .A(x=1:5, y=5:1) + checkTrue(all.equal(a, updateObject(a))) + + .A <- setRefClass(cls, fields=list(x="numeric", y="numeric", z="numeric"), + where=.GlobalEnv) + checkTrue(all.equal(.A(x=1:5, y=5:1, z=numeric()), updateObject(a))) + + .A <- setRefClass(cls, fields=list(x="numeric")) + warn <- FALSE + value <- withCallingHandlers(updateObject(a), warning=function(w) { + txt <- "dropping fields(s) 'y' from object = '.__test_updateObject_refClassA'" + warn <<- identical(txt, conditionMessage(w)) + invokeRestart("muffleWarning") + }) + checkTrue(warn) + checkTrue(all.equal(.A(x=1:5), value)) + + removeClass(cls, where=.GlobalEnv) +} diff --git a/man/BiocGenerics-package.Rd b/man/BiocGenerics-package.Rd index 4e28266..2ce028f 100644 --- a/man/BiocGenerics-package.Rd +++ b/man/BiocGenerics-package.Rd @@ -172,13 +172,15 @@ \code{\link[BiocGenerics]{species<-}} \item \code{\link[BiocGenerics]{plotMA}} + \item \code{\link[BiocGenerics]{plotPCA}} \item \code{\link[BiocGenerics]{score}}, \code{\link[BiocGenerics]{score<-}} \item \code{\link[BiocGenerics]{strand}}, - \code{\link[BiocGenerics]{strand<-}} + \code{\link[BiocGenerics]{strand<-}}, + \code{\link[BiocGenerics]{invertStrand}} \item \code{\link[BiocGenerics]{updateObject}} } diff --git a/man/is.unsorted.Rd b/man/is.unsorted.Rd index b9b4dc4..0291a1e 100644 --- a/man/is.unsorted.Rd +++ b/man/is.unsorted.Rd @@ -63,9 +63,10 @@ is.unsorted(x, na.rm=FALSE, strictly=FALSE, ...) \item \code{\link[methods]{selectMethod}} for getting the definition of a specific method. - \item \link[S4Vectors]{is.unsorted,Rle-method} in the \pkg{S4Vectors} - package for an example of a specific \code{is.unsorted} method - (defined for \link[S4Vectors]{Rle} objects). + \item \link[GenomicRanges]{is.unsorted,GenomicRanges-method} in + the \pkg{GenomicRanges} package for an example of a specific + \code{is.unsorted} method (defined for + \link[GenomicRanges]{GenomicRanges} objects). \item \link{BiocGenerics} for a summary of all the generics defined in the \pkg{BiocGenerics} package. diff --git a/man/lengths.Rd b/man/lengths.Rd index 06c0a0b..3fe45a3 100644 --- a/man/lengths.Rd +++ b/man/lengths.Rd @@ -42,7 +42,7 @@ lengths(x, use.names=TRUE) IMPORTANT: The default method (\code{base::\link[base]{lengths}}) is equivalent to \code{sapply(x, length)}. However, because the \code{lengths} method for \link[S4Vectors]{Vector} objects is currently - defined as an alias for \code{S4Vectors::\link[S4Vectors]{elementLengths}}, + defined as an alias for \code{S4Vectors::\link[S4Vectors]{elementNROWS}}, it's equivalent to \code{sapply(x, NROW)}, not to \code{sapply(x, length)}. This makes a difference if \code{x} has array-like list elements. diff --git a/man/order.Rd b/man/order.Rd index fdfc50b..d931df4 100644 --- a/man/order.Rd +++ b/man/order.Rd @@ -18,14 +18,14 @@ } \usage{ -order(..., na.last=TRUE, decreasing=FALSE) +order(..., na.last=TRUE, decreasing=FALSE, method=c("shell", "radix")) } \arguments{ \item{...}{ One or more vector-like objects, all of the same length. } - \item{na.last, decreasing}{ + \item{na.last, decreasing, method}{ See \code{?base::\link[base]{order}} for a description of these arguments. } diff --git a/man/rank.Rd b/man/rank.Rd index b1bb4bd..e20574a 100644 --- a/man/rank.Rd +++ b/man/rank.Rd @@ -18,7 +18,7 @@ \usage{ rank(x, na.last=TRUE, - ties.method=c("average", "first", "random", "max", "min")) + ties.method=c("average", "first", "last", "random", "max", "min")) } \arguments{ diff --git a/man/strand.Rd b/man/strand.Rd index 937bf06..9429fbc 100644 --- a/man/strand.Rd +++ b/man/strand.Rd @@ -3,6 +3,8 @@ \alias{strand} \alias{strand<-} \alias{unstrand} +\alias{invertStrand} +\alias{invertStrand,ANY-method} \title{Accessing strand information} @@ -13,7 +15,11 @@ \usage{ strand(x, ...) strand(x, ...) <- value + unstrand(x) + +invertStrand(x) +\S4method{invertStrand}{ANY}(x) } \arguments{ @@ -35,17 +41,30 @@ unstrand(x) \code{*} is used when the exact strand of the location is unknown, or irrelevant, or when the "feature" at that location belongs to both strands. -} -\note{ - \code{unstrand} is not a generic function, just a convenience wrapper to - the generic strand setter (\code{strand<-}) that simply does: -\preformatted{ - strand(x) <- "*" + Note that \code{unstrand} is not a generic function, just a convenience + wrapper to the generic strand setter (\code{strand<-}) that does: +\preformatted{ strand(x) <- "*" + x +} + The default method for \code{invertStrand} does: +\preformatted{ strand(x) <- invertStrand(strand(x)) x } } +\value{ + If \code{x} is a vector-like object, \code{strand(x)} will typically + return a vector-like object \emph{parallel} to \code{x}, that is, an + object of the same length as \code{x} where the i-th element describes + the strand of the i-th element in \code{x}. + + \code{unstrand(x)} and \code{invertStrand(x)} return a copy of \code{x} + with the strand set to \code{"*"} for \code{unstrand} or inverted for + \code{invertStrand} (i.e. \code{"+"} and \code{"-"} switched, and + \code{"*"} untouched). +} + \seealso{ \itemize{ \item \code{\link[methods]{showMethods}} for displaying a summary of the @@ -71,6 +90,12 @@ showMethods("strand") `strand<-` showMethods("strand<-") +unstrand + +invertStrand +showMethods("invertStrand") +selectMethod("invertStrand", "ANY") # the default method + library(GenomicRanges) showMethods("strand") diff --git a/man/updateObject.Rd b/man/updateObject.Rd index 27c7e18..5a8b3bb 100644 --- a/man/updateObject.Rd +++ b/man/updateObject.Rd @@ -4,6 +4,8 @@ \alias{updateObject,ANY-method} \alias{updateObject,list-method} \alias{updateObject,environment-method} +\alias{updateObject,formula-method} +\alias{updateObject,envRefClass-method} \alias{updateObjectFromSlots} \alias{getObjectSlots} @@ -77,18 +79,25 @@ getObjectSlots(object) Visit each element in \code{environment}, applying \code{updateObject(environment[[elt]], \dots, verbose=verbose)} } + \item{\code{updateObject(formula, \dots, verbose=FALSE)}}{ + Do nothing; the environment of the formula may be too general + (e.g., \code{R_GlobalEnv}) to attempt an update. + } + \item{\code{updateObject(envRefClass, \dots, verbose=FALSE)}}{ + Attempt to update objects from fields using a strategy like + \code{updateObjectFromSlots} Method 1. + } } - \code{updateObjectFromSlots(object, objclass=class(object), - \dots, verbose=FALSE)} - is a utility function that identifies the intersection of slots defined - in the \code{object} instance and \code{objclass} definition. The - corresponding elements in \code{object} are then updated (with - \code{updateObject(elt, \dots, verbose=verbose)}) and used as arguments to - a call to \code{new(class, \dots)}, with \code{\dots} replaced by slots - from the original object. If this fails, \code{updateObjectFromSlots} - then tries \code{new(class)} and assigns slots of \code{object} to - the newly created instance. + \code{updateObjectFromSlots(object, objclass=class(object), \dots, + verbose=FALSE)} is a utility function that identifies the intersection + of slots defined in the \code{object} instance and \code{objclass} + definition. Under Method 1, the corresponding elements in + \code{object} are then updated (with \code{updateObject(elt, \dots, + verbose=verbose)}) and used as arguments to a call to \code{new(class, + \dots)}, with \code{\dots} replaced by slots from the original + object. If this fails, then Method 2 tries \code{new(class)} and + assigns slots of \code{object} to the newly created instance. \code{getObjectSlots(object)} extracts the slot names and contents from \code{object}. This is useful when \code{object} was created by a class diff --git a/tests/BiocGenerics_unit_tests.R b/tests/run_unitTests.R similarity index 100% rename from tests/BiocGenerics_unit_tests.R rename to tests/run_unitTests.R -- Alioth's /usr/local/bin/git-commit-notice on /srv/git.debian.org/git/debian-med/r-bioc-biocgenerics.git _______________________________________________ debian-med-commit mailing list [email protected] http://lists.alioth.debian.org/cgi-bin/mailman/listinfo/debian-med-commit
