## ---- echo=FALSE, results="hide"---------------------------------------------- knitr::opts_chunk$set(error=FALSE, warning=FALSE, message=FALSE) ## ---- echo=FALSE-------------------------------------------------------------- library(SummarizedExperiment) library(testthat) ## ----------------------------------------------------------------------------- #' @export #' @import methods #' @importClassesFrom SummarizedExperiment SummarizedExperiment .CountSE <- setClass("CountSE", contains="SummarizedExperiment") ## ----------------------------------------------------------------------------- #' @export #' @importFrom SummarizedExperiment SummarizedExperiment CountSE <- function(counts, ...) { se <- SummarizedExperiment(list(counts=counts), ...) .CountSE(se) } ## ----------------------------------------------------------------------------- setValidity2("CountSE", function(object) { msg <- NULL if (assayNames(object)[1] != "counts") { msg <- c(msg, "'counts' must be first assay") } if (min(assay(object)) < 0) { msg <- c(msg, "negative values in 'counts'") } if (is.null(msg)) { TRUE } else msg }) ## ----------------------------------------------------------------------------- CountSE(matrix(rpois(100, lambda=1), ncol=5)) ## ---- error=TRUE-------------------------------------------------------------- CountSE(matrix(rnorm(100), ncol=5)) ## ----------------------------------------------------------------------------- #' @export setGeneric("negcounts", function(x, ...) standardGeneric("negcounts")) ## ----------------------------------------------------------------------------- #' @export #' @importFrom SummarizedExperiment assay setMethod("negcounts", "CountSE", function(x, withDimnames=TRUE) { -assay(x, withDimnames=withDimnames) }) ## ----------------------------------------------------------------------------- #' @export #' @import methods #' @importClassesFrom SummarizedExperiment SummarizedExperiment .ExampleClass <- setClass("ExampleClass", slots= representation( rowVec="integer", colVec="integer", rowToRowMat="matrix", colToColMat="matrix", rowToColMat="matrix", colToRowMat="matrix" ), contains="SummarizedExperiment" ) ## ----------------------------------------------------------------------------- #' @export #' @importFrom SummarizedExperiment SummarizedExperiment ExampleClass <- function( rowVec=integer(0), colVec=integer(0), rowToRowMat=matrix(0,0,0), colToColMat=matrix(0,0,0), rowToColMat=matrix(0,0,0), colToRowMat=matrix(0,0,0), ...) { se <- SummarizedExperiment(...) .ExampleClass(se, rowVec=rowVec, colVec=colVec, rowToRowMat=rowToRowMat, colToColMat=colToColMat, rowToColMat=rowToColMat, colToRowMat=colToRowMat) } ## ----------------------------------------------------------------------------- #' @export setGeneric("rowVec", function(x, ...) standardGeneric("rowVec")) #' @export setGeneric("colVec", function(x, ...) standardGeneric("colVec")) ## ----------------------------------------------------------------------------- #' @export setMethod("rowVec", "ExampleClass", function(x, withDimnames=TRUE) { out <- x@rowVec if (withDimnames) names(out) <- rownames(x) out }) #' @export setMethod("colVec", "ExampleClass", function(x, withDimnames=TRUE) { out <- x@colVec if (withDimnames) names(out) <- colnames(x) out }) ## ----------------------------------------------------------------------------- #' @export setGeneric("rowToRowMat", function(x, ...) standardGeneric("rowToRowMat")) #' @export setGeneric("colToColMat", function(x, ...) standardGeneric("colToColMat")) #' @export setGeneric("rowToColMat", function(x, ...) standardGeneric("rowToColMat")) #' @export setGeneric("colToRowMat", function(x, ...) standardGeneric("colToRowMat")) ## ----------------------------------------------------------------------------- #' @export setMethod("rowToRowMat", "ExampleClass", function(x, withDimnames=TRUE) { out <- x@rowToRowMat if (withDimnames) rownames(out) <- rownames(x) out }) #' @export setMethod("colToColMat", "ExampleClass", function(x, withDimnames=TRUE) { out <- x@colToColMat if (withDimnames) colnames(out) <- colnames(x) out }) #' @export setMethod("rowToColMat", "ExampleClass", function(x, withDimnames=TRUE) { out <- x@rowToColMat if (withDimnames) rownames(out) <- colnames(x) out }) #' @export setMethod("colToRowMat", "ExampleClass", function(x, withDimnames=TRUE) { out <- x@colToRowMat if (withDimnames) colnames(out) <- rownames(x) out }) ## ----------------------------------------------------------------------------- #' @export #' @importMethodsFrom SummarizedExperiment rowData setMethod("rowData", "ExampleClass", function(x, ...) { out <- callNextMethod() # Do something extra here. out$extra <- runif(nrow(out)) # Returning the rowData object. out }) ## ----------------------------------------------------------------------------- #' @importFrom BiocGenerics NCOL NROW setValidity2("ExampleClass", function(object) { NR <- NROW(object) NC <- NCOL(object) msg <- NULL # 1D if (length(rowVec(object, withDimnames=FALSE)) != NR) { msg <- c(msg, "'rowVec' should have length equal to the number of rows") } if (length(colVec(object, withDimnames=FALSE)) != NC) { msg <- c( msg, "'colVec' should have length equal to the number of columns" ) } # 2D if (NROW(rowToRowMat(object, withDimnames=FALSE)) != NR) { msg <- c( msg, "'nrow(rowToRowMat)' should be equal to the number of rows" ) } if (NCOL(colToColMat(object, withDimnames=FALSE)) != NC) { msg <- c( msg, "'ncol(colToColMat)' should be equal to the number of columns" ) } if (NROW(rowToColMat(object, withDimnames=FALSE)) != NC) { msg <- c( msg, "'nrow(rowToColMat)' should be equal to the number of columns" ) } if (NCOL(colToRowMat(object, withDimnames=FALSE)) != NR) { msg <- c( msg, "'ncol(colToRowMat)' should be equal to the number of rows" ) } if (length(msg)) { msg } else TRUE }) ## ----------------------------------------------------------------------------- #' @export #' @importMethodsFrom SummarizedExperiment show setMethod("show", "ExampleClass", function(object) { callNextMethod() cat( "rowToRowMat has ", ncol(rowToRowMat(object)), " columns\n", "colToColMat has ", nrow(colToColMat(object)), " rows\n", "rowToColMat has ", ncol(rowToRowMat(object)), " columns\n", "colToRowMat has ", ncol(rowToRowMat(object)), " rows\n", sep="" ) }) ## ----------------------------------------------------------------------------- #' @export setGeneric("rowVec<-", function(x, ..., value) standardGeneric("rowVec<-")) #' @export setGeneric("colVec<-", function(x, ..., value) standardGeneric("colVec<-")) ## ----------------------------------------------------------------------------- #' @export setReplaceMethod("rowVec", "ExampleClass", function(x, value) { x@rowVec <- value validObject(x) x }) #' @export setReplaceMethod("colVec", "ExampleClass", function(x, value) { x@colVec <- value validObject(x) x }) ## ----------------------------------------------------------------------------- #' @export setGeneric("rowToRowMat<-", function(x, ..., value) standardGeneric("rowToRowMat<-") ) #' @export setGeneric("colToColMat<-", function(x, ..., value) standardGeneric("colToColMat<-") ) #' @export setGeneric("rowToColMat<-", function(x, ..., value) standardGeneric("rowToColMat<-") ) #' @export setGeneric("colToRowMat<-", function(x, ..., value) standardGeneric("colToRowMat<-") ) ## ----------------------------------------------------------------------------- #' @export setReplaceMethod("rowToRowMat", "ExampleClass", function(x, value) { x@rowToRowMat <- value validObject(x) x }) #' @export setReplaceMethod("colToColMat", "ExampleClass", function(x, value) { x@colToColMat <- value validObject(x) x }) #' @export setReplaceMethod("rowToColMat", "ExampleClass", function(x, value) { x@rowToColMat <- value validObject(x) x }) #' @export setReplaceMethod("colToRowMat", "ExampleClass", function(x, value) { x@colToRowMat <- value validObject(x) x }) ## ----------------------------------------------------------------------------- #' @export #' @importMethodsFrom SummarizedExperiment "rowData<-" setReplaceMethod("rowData", "ExampleClass", function(x, ..., value) { y <- callNextMethod() # returns a modified ExampleClass # Do something extra here. message("hi!\n") y }) ## ----------------------------------------------------------------------------- #' @export #' @importFrom BiocGenerics normalize setMethod("normalize", "ExampleClass", function(object) { # do something exciting, i.e., flip the signs new.row <- -rowVec(object, withDimnames=FALSE) new.col <- -colVec(object, withDimnames=FALSE) BiocGenerics:::replaceSlots(object, rowVec=new.row, colVec=new.col, check=FALSE) }) ## ----------------------------------------------------------------------------- #' @export setMethod("[", "ExampleClass", function(x, i, j, drop=TRUE) { rv <- rowVec(x, withDimnames=FALSE) cv <- colVec(x, withDimnames=FALSE) rrm <- rowToRowMat(x, withDimnames=FALSE) ccm <- colToColMat(x, withDimnames=FALSE) rcm <- rowToColMat(x, withDimnames=FALSE) crm <- colToRowMat(x, withDimnames=FALSE) if (!missing(i)) { if (is.character(i)) { fmt <- paste0("<", class(x), ">[i,] index out of bounds: %s") i <- SummarizedExperiment:::.SummarizedExperiment.charbound( i, rownames(x), fmt ) } i <- as.vector(i) rv <- rv[i] rrm <- rrm[i,,drop=FALSE] crm <- crm[,i,drop=FALSE] } if (!missing(j)) { if (is.character(j)) { fmt <- paste0("<", class(x), ">[,j] index out of bounds: %s") j <- SummarizedExperiment:::.SummarizedExperiment.charbound( j, colnames(x), fmt ) } j <- as.vector(j) cv <- cv[j] ccm <- ccm[,j,drop=FALSE] rcm <- rcm[j,,drop=FALSE] } out <- callNextMethod() BiocGenerics:::replaceSlots(out, rowVec=rv, colVec=cv, rowToRowMat=rrm, colToColMat=ccm, rowToColMat=rcm, colToRowMat=crm, check=FALSE) }) ## ----------------------------------------------------------------------------- #' @export setReplaceMethod("[", c("ExampleClass", "ANY", "ANY", "ExampleClass"), function(x, i, j, ..., value) { rv <- rowVec(x, withDimnames=FALSE) cv <- colVec(x, withDimnames=FALSE) rrm <- rowToRowMat(x, withDimnames=FALSE) ccm <- colToColMat(x, withDimnames=FALSE) rcm <- rowToColMat(x, withDimnames=FALSE) crm <- colToRowMat(x, withDimnames=FALSE) if (!missing(i)) { if (is.character(i)) { fmt <- paste0("<", class(x), ">[i,] index out of bounds: %s") i <- SummarizedExperiment:::.SummarizedExperiment.charbound( i, rownames(x), fmt ) } i <- as.vector(i) rv[i] <- rowVec(value, withDimnames=FALSE) rrm[i,] <- rowToRowMat(value, withDimnames=FALSE) crm[,i] <- colToRowMat(value, withDimnames=FALSE) } if (!missing(j)) { if (is.character(j)) { fmt <- paste0("<", class(x), ">[,j] index out of bounds: %s") j <- SummarizedExperiment:::.SummarizedExperiment.charbound( j, colnames(x), fmt ) } j <- as.vector(j) cv[j] <- colVec(value, withDimnames=FALSE) ccm[,j] <- colToColMat(value, withDimnames=FALSE) rcm[j,] <- rowToColMat(value, withDimnames=FALSE) } out <- callNextMethod() BiocGenerics:::replaceSlots(out, rowVec=rv, colVec=cv, rowToRowMat=rrm, colToColMat=ccm, rowToColMat=rcm, colToRowMat=crm, check=FALSE) }) ## ----------------------------------------------------------------------------- #' @export setMethod("rbind", "ExampleClass", function(..., deparse.level=1) { args <- list(...) all.rv <- lapply(args, rowVec, withDimnames=FALSE) all.rrm <- lapply(args, rowToRowMat, withDimnames=FALSE) all.crm <- lapply(args, colToRowMat, withDimnames=FALSE) all.rv <- do.call(c, all.rv) all.rrm <- do.call(rbind, all.rrm) all.crm <- do.call(cbind, all.crm) # Checks for identical column state. ref <- args[[1]] ref.cv <- colVec(ref, withDimnames=FALSE) ref.ccm <- colToColMat(ref, withDimnames=FALSE) ref.rcm <- rowToColMat(ref, withDimnames=FALSE) for (x in args[-1]) { if (!identical(ref.cv, colVec(x, withDimnames=FALSE)) || !identical(ref.ccm, colToColMat(x, withDimnames=FALSE)) || !identical(ref.rcm, rowToColMat(x, withDimnames=FALSE))) { stop("per-column values are not compatible") } } old.validity <- S4Vectors:::disableValidity() S4Vectors:::disableValidity(TRUE) on.exit(S4Vectors:::disableValidity(old.validity)) out <- callNextMethod() BiocGenerics:::replaceSlots(out, rowVec=all.rv, rowToRowMat=all.rrm, colToRowMat=all.crm, check=FALSE) }) ## ----------------------------------------------------------------------------- #' @export setMethod("cbind", "ExampleClass", function(..., deparse.level=1) { args <- list(...) all.cv <- lapply(args, colVec, withDimnames=FALSE) all.ccm <- lapply(args, colToColMat, withDimnames=FALSE) all.rcm <- lapply(args, rowToColMat, withDimnames=FALSE) all.cv <- do.call(c, all.cv) all.ccm <- do.call(cbind, all.ccm) all.rcm <- do.call(rbind, all.rcm) # Checks for identical column state. ref <- args[[1]] ref.rv <- rowVec(ref, withDimnames=FALSE) ref.rrm <- rowToRowMat(ref, withDimnames=FALSE) ref.crm <- colToRowMat(ref, withDimnames=FALSE) for (x in args[-1]) { if (!identical(ref.rv, rowVec(x, withDimnames=FALSE)) || !identical(ref.rrm, rowToRowMat(x, withDimnames=FALSE)) || !identical(ref.crm, colToRowMat(x, withDimnames=FALSE))) { stop("per-row values are not compatible") } } old.validity <- S4Vectors:::disableValidity() S4Vectors:::disableValidity(TRUE) on.exit(S4Vectors:::disableValidity(old.validity)) out <- callNextMethod() BiocGenerics:::replaceSlots(out, colVec=all.cv, colToColMat=all.ccm, rowToColMat=all.rcm, check=FALSE) }) ## ----------------------------------------------------------------------------- #' @exportMethods coerce setAs("SummarizedExperiment", "ExampleClass", function(from) { new("ExampleClass", from, rowVec=integer(nrow(from)), colVec=integer(ncol(from)), rowToRowMat=matrix(0,nrow(from),0), colToColMat=matrix(0,0,ncol(from)), rowToColMat=matrix(0,ncol(from),0), colToRowMat=matrix(0,0,nrow(from))) }) ## ----------------------------------------------------------------------------- se <- SummarizedExperiment(matrix(rpois(100, lambda=1), ncol=5)) as(se, "CountSE") ## ----------------------------------------------------------------------------- RV <- 1:10 CV <- sample(50, 7) RRM <- matrix(runif(30), nrow=10) CCM <- matrix(rnorm(14), ncol=7) RCM <- matrix(runif(21), nrow=7) CRM <- matrix(rnorm(20), ncol=10) thing <- ExampleClass(rowVec=RV, colVec=CV, rowToRowMat=RRM, colToColMat=CCM, rowToColMat=RCM, colToRowMat=CRM, assays=list(counts=matrix(rnorm(70), nrow=10)), colData=DataFrame(whee=LETTERS[1:7]), rowData=DataFrame(yay=letters[1:10]) ) ## ----------------------------------------------------------------------------- rownames(thing) <- paste0("FEATURE_", seq_len(nrow(thing))) colnames(thing) <- paste0("SAMPLE_", seq_len(ncol(thing))) thing ## ----------------------------------------------------------------------------- expect_true(validObject(thing)) ## ----------------------------------------------------------------------------- expect_true(validObject(.ExampleClass())) # internal expect_true(validObject(ExampleClass())) # exported ## ----------------------------------------------------------------------------- expect_error(ExampleClass(rowVec=1), "rowVec") expect_error(ExampleClass(colVec=1), "colVec") expect_error(ExampleClass(rowToRowMat=rbind(1)), "rowToRowMat") expect_error(ExampleClass(colToColMat=rbind(1)), "colToColMat") expect_error(ExampleClass(rowToColMat=rbind(1)), "rowToColMat") expect_error(ExampleClass(colToRowMat=rbind(1)), "colToRowMat") ## ----------------------------------------------------------------------------- se <- as(thing, "SummarizedExperiment") conv <- as(se, "ExampleClass") expect_true(validObject(conv)) ## ----------------------------------------------------------------------------- expect_identical(names(rowVec(thing)), rownames(thing)) expect_identical(rowVec(thing, withDimnames=FALSE), RV) expect_identical(names(colVec(thing)), colnames(thing)) expect_identical(colVec(thing, withDimnames=FALSE), CV) ## ----------------------------------------------------------------------------- expect_identical(rowToRowMat(thing, withDimnames=FALSE), RRM) expect_identical(rownames(rowToRowMat(thing)), rownames(thing)) expect_identical(colToColMat(thing, withDimnames=FALSE), CCM) expect_identical(colnames(colToColMat(thing)), colnames(thing)) expect_identical(rowToColMat(thing, withDimnames=FALSE), RCM) expect_identical(rownames(rowToColMat(thing)), colnames(thing)) expect_identical(colToRowMat(thing, withDimnames=FALSE), CRM) expect_identical(colnames(colToRowMat(thing)), rownames(thing)) ## ----------------------------------------------------------------------------- expect_true("extra" %in% colnames(rowData(thing))) ## ----------------------------------------------------------------------------- rowVec(thing) <- 0:9 expect_equivalent(rowVec(thing), 0:9) colVec(thing) <- 7:1 expect_equivalent(colVec(thing), 7:1) ## ----------------------------------------------------------------------------- old <- rowToRowMat(thing) rowToRowMat(thing) <- -old expect_equivalent(rowToRowMat(thing), -old) old <- colToColMat(thing) colToColMat(thing) <- 2 * old expect_equivalent(colToColMat(thing), 2 * old) old <- rowToColMat(thing) rowToColMat(thing) <- old + 1 expect_equivalent(rowToColMat(thing), old + 1) old <- colToRowMat(thing) colToRowMat(thing) <- old / 10 expect_equivalent(colToRowMat(thing), old / 10) ## ----------------------------------------------------------------------------- expect_message(rowData(thing) <- 1, "hi") ## ----------------------------------------------------------------------------- expect_error(rowVec(thing) <- 0, "rowVec") expect_error(colVec(thing) <- 0, "colVec") expect_error(rowToRowMat(thing) <- rbind(0), "rowToRowMat") expect_error(colToColMat(thing) <- rbind(0), "colToColMat") expect_error(rowToColMat(thing) <- rbind(0), "rowToColMat") expect_error(colToRowMat(thing) <- rbind(0), "colToRowMat") ## ----------------------------------------------------------------------------- modified <- normalize(thing) expect_equal(rowVec(modified), -rowVec(thing)) expect_equal(colVec(modified), -colVec(thing)) ## ----------------------------------------------------------------------------- subbyrow <- thing[1:5,] expect_identical(rowVec(subbyrow), rowVec(thing)[1:5]) expect_identical(rowToRowMat(subbyrow), rowToRowMat(thing)[1:5,]) expect_identical(colToRowMat(subbyrow), colToRowMat(thing)[,1:5]) # columns unaffected... expect_identical(colVec(subbyrow), colVec(thing)) expect_identical(colToColMat(subbyrow), colToColMat(thing)) expect_identical(rowToColMat(subbyrow), rowToColMat(thing)) ## ----------------------------------------------------------------------------- subbycol <- thing[,1:2] expect_identical(colVec(subbycol), colVec(thing)[1:2]) expect_identical(colToColMat(subbycol), colToColMat(thing)[,1:2]) expect_identical(rowToColMat(subbycol), rowToColMat(thing)[1:2,]) # rows unaffected... expect_identical(rowVec(subbycol), rowVec(thing)) expect_identical(rowToRowMat(subbycol), rowToRowMat(thing)) expect_identical(colToRowMat(subbycol), colToRowMat(thing)) ## ----------------------------------------------------------------------------- norow <- thing[0,] expect_true(validObject(norow)) expect_identical(nrow(norow), 0L) nocol <- thing[,0] expect_true(validObject(nocol)) expect_identical(ncol(nocol), 0L) ## ----------------------------------------------------------------------------- modified <- thing modified[1:5,1:2] <- thing[5:1,2:1] rperm <- c(5:1, 6:nrow(thing)) expect_identical(rowVec(modified), rowVec(thing)[rperm]) expect_identical(rowToRowMat(modified), rowToRowMat(thing)[rperm,]) expect_identical(colToRowMat(modified), colToRowMat(thing)[,rperm]) cperm <- c(2:1, 3:ncol(thing)) expect_identical(colVec(modified), colVec(thing)[cperm]) expect_identical(colToColMat(modified), colToColMat(thing)[,cperm]) expect_identical(rowToColMat(modified), rowToColMat(thing)[cperm,]) ## ----------------------------------------------------------------------------- modified <- thing modified[0,] <- thing[0,] expect_equal(modified, thing) modified[1,] <- thing[1,] expect_equal(modified, thing) modified[,0] <- thing[,0] expect_equal(modified, thing) modified[,1] <- thing[,1] expect_equal(modified, thing) ## ----------------------------------------------------------------------------- expect_error(modified[1,1] <- thing[0,0], "replacement has length zero") ## ----------------------------------------------------------------------------- combined <- rbind(thing, thing) rtwice <- rep(seq_len(nrow(thing)), 2) expect_identical(rowVec(combined), rowVec(thing)[rtwice]) expect_identical(rowToRowMat(combined), rowToRowMat(thing)[rtwice,]) expect_identical(colToRowMat(combined), colToRowMat(thing)[,rtwice]) # Columns are unaffected: expect_identical(colVec(combined), colVec(thing)) expect_identical(colToColMat(combined), colToColMat(thing)) expect_identical(rowToColMat(combined), rowToColMat(thing)) ## ----------------------------------------------------------------------------- combined <- cbind(thing, thing) ctwice <- rep(seq_len(ncol(thing)), 2) expect_equivalent(colVec(combined), colVec(thing)[ctwice]) expect_equivalent(colToColMat(combined), colToColMat(thing)[,ctwice]) expect_equivalent(rowToColMat(combined), rowToColMat(thing)[ctwice,]) # Rows are unaffected: expect_equivalent(rowVec(combined), rowVec(thing)) expect_equivalent(rowToRowMat(combined), rowToRowMat(thing)) expect_equivalent(colToRowMat(combined), colToRowMat(thing)) ## ----------------------------------------------------------------------------- expect_equal(thing, rbind(thing)) expect_equal(thing, rbind(thing, thing[0,])) expect_equal(thing, cbind(thing)) expect_equal(thing, cbind(thing, thing[,0])) ## ----------------------------------------------------------------------------- expect_error(rbind(thing, thing[,ncol(thing):1]), "not compatible") expect_error(cbind(thing, thing[nrow(thing):1,]), "not compatible") ## ----------------------------------------------------------------------------- sessionInfo()