S4QuickOverview.R
In S4Vectors: Foundation of vector-like and list-like containers in Bioconductor

### R code from vignette source 'S4QuickOverview.Rnw'

###################################################
### code chunk number 1: setup
###################################################
options(width=60)
library(Matrix)
library(IRanges)
library(ShortRead)
library(graph)


###################################################
### code chunk number 2: S4_object_in_dataset
###################################################
library(graph)
data(apopGraph)
apopGraph


###################################################
### code chunk number 3: S4_object_from_constructor
###################################################
library(IRanges)
IRanges(start=c(101, 25), end=c(110, 80))


###################################################
### code chunk number 4: S4_object_from_ceorcion
###################################################
library(Matrix)
m <- matrix(3:-4, nrow=2)
as(m, "Matrix")


###################################################
### code chunk number 5: S4_object_from_high_level_IO_function
###################################################
library(ShortRead)
path_to_my_data <- system.file(
    package="ShortRead",
    "extdata", "Data", "C1-36Firecrest", "Bustard", "GERALD")
lane1 <- readFastq(path_to_my_data, pattern="s_1_sequence.txt")
lane1


###################################################
### code chunk number 6: S4_object_inside_another_object
###################################################
sread(lane1)


###################################################
### code chunk number 7: getters_and_setters
###################################################
ir <- IRanges(start=c(101, 25), end=c(110, 80))
width(ir)
width(ir) <- width(ir) - 5
ir


###################################################
### code chunk number 8: specialized_methods
###################################################
qa1 <- qa(lane1, lane="lane1")
class(qa1)


###################################################
### code chunk number 9: showMethods
###################################################
showMethods("qa")


###################################################
### code chunk number 10: showClass
###################################################
class(lane1)
showClass("ShortReadQ")


###################################################
### code chunk number 11: setClass
###################################################
setClass("SNPLocations",
    slots=c(
      genome="character",  # a single string
      snpid="character",   # a character vector of length N
      chrom="character",   # a character vector of length N
      pos="integer"        # an integer vector of length N
    )
)


###################################################
### code chunk number 12: SNPLocations
###################################################
SNPLocations <- function(genome, snpid, chrom, pos)
    new("SNPLocations", genome=genome, snpid=snpid, chrom=chrom, pos=pos)


###################################################
### code chunk number 13: test_SNPLocations
###################################################
snplocs <- SNPLocations("hg19",
             c("rs0001", "rs0002"),
             c("chr1", "chrX"),
             c(224033L, 1266886L))


###################################################
### code chunk number 14: length
###################################################
setMethod("length", "SNPLocations", function(x) length(x@snpid))


###################################################
### code chunk number 15: test_length
###################################################
length(snplocs)  # just testing


###################################################
### code chunk number 16: genome
###################################################
setGeneric("genome", function(x) standardGeneric("genome"))
setMethod("genome", "SNPLocations", function(x) x@genome)


###################################################
### code chunk number 17: snpid
###################################################
setGeneric("snpid", function(x) standardGeneric("snpid"))
setMethod("snpid", "SNPLocations", function(x) x@snpid)


###################################################
### code chunk number 18: chrom
###################################################
setGeneric("chrom", function(x) standardGeneric("chrom"))
setMethod("chrom", "SNPLocations", function(x) x@chrom)


###################################################
### code chunk number 19: pos
###################################################
setGeneric("pos", function(x) standardGeneric("pos"))
setMethod("pos", "SNPLocations", function(x) x@pos)


###################################################
### code chunk number 20: test_slot_getters
###################################################
genome(snplocs)  # just testing
snpid(snplocs)   # just testing


###################################################
### code chunk number 21: show
###################################################
setMethod("show", "SNPLocations",
    function(object)
        cat(class(object), "instance with", length(object),
            "SNPs on genome", genome(object), "\n")
)


###################################################
### code chunk number 22: S4QuickOverview.Rnw:383-384
###################################################
snplocs  # just testing


###################################################
### code chunk number 23: validity
###################################################
setValidity("SNPLocations",
    function(object) {
        if (!is.character(genome(object)) ||
            length(genome(object)) != 1 || is.na(genome(object)))
            return("'genome' slot must be a single string")
        slot_lengths <- c(length(snpid(object)),
                          length(chrom(object)),
                          length(pos(object)))
        if (length(unique(slot_lengths)) != 1)
            return("lengths of slots 'snpid', 'chrom' and 'pos' differ")
        TRUE
    }
)


###################################################
### code chunk number 24: set_chrom
###################################################
setGeneric("chrom<-", function(x, value) standardGeneric("chrom<-"))
setReplaceMethod("chrom", "SNPLocations",
    function(x, value) {x@chrom <- value; validObject(x); x})


###################################################
### code chunk number 25: test_slot_setters
###################################################
chrom(snplocs) <- LETTERS[1:2]  # repair currently broken object


###################################################
### code chunk number 26: setAs
###################################################
setAs("SNPLocations", "data.frame",
    function(from)
        data.frame(snpid=snpid(from), chrom=chrom(from), pos=pos(from))
)


###################################################
### code chunk number 27: test_coercion
###################################################
as(snplocs, "data.frame")  # testing


###################################################
### code chunk number 28: AnnotatedSNPs
###################################################
setClass("AnnotatedSNPs",
    contains="SNPLocations",
    slots=c(
        geneid="character"  # a character vector of length N
    )
)


###################################################
### code chunk number 29: slot_inheritance
###################################################
showClass("AnnotatedSNPs")


###################################################
### code chunk number 30: AnnotatedSNPs
###################################################
AnnotatedSNPs <- function(genome, snpid, chrom, pos, geneid)
{
    new("AnnotatedSNPs",
        SNPLocations(genome, snpid, chrom, pos),
        geneid=geneid)
}


###################################################
### code chunk number 31: method_inheritance
###################################################
snps <- AnnotatedSNPs("hg19",
             c("rs0001", "rs0002"),
             c("chr1", "chrX"),
             c(224033L, 1266886L),
             c("AAU1", "SXW-23"))


###################################################
### code chunk number 32: method_inheritance
###################################################
snps


###################################################
### code chunk number 33: as_data_frame_is_not_right
###################################################
as(snps, "data.frame")  # the 'geneid' slot is ignored


###################################################
### code chunk number 34: S4QuickOverview.Rnw:536-539
###################################################
is(snps, "AnnotatedSNPs")     # 'snps' is an AnnotatedSNPs object
is(snps, "SNPLocations")      # and is also a SNPLocations object
class(snps)                   # but is *not* a SNPLocations *instance*


###################################################
### code chunk number 35: automatic_coercion_method
###################################################
as(snps, "SNPLocations")


###################################################
### code chunk number 36: incremental_validity_method
###################################################
setValidity("AnnotatedSNPs",
    function(object) {
        if (length(object@geneid) != length(object))
            return("'geneid' slot must have the length of the object")
        TRUE
    }
)