S4 Class

The S4 class system is a set of facilities provided in R for OO programming

R also supports an older class system: the S3 class system

Implemented in the methods package

About OOP:

Objects : objects encapsulate state information and control behavior
Class : class describe general properties for groups of objects
Ihinheritance : inheritance new classes can be defined in terms of existing classes
Polymorphism : polymorphism a (generic) function has different behaviors, although similar outputs, depending on the class of one or more of its arguments.

SNP Locations

Set Class & Methods

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
)
)

SNPLocations <- function(genome, snpid, chrom, pos){
new("SNPLocations", genome=genome, snpid=snpid, chrom=chrom, pos=pos)}


setGeneric("info", function(x) standardGeneric("info"))
setMethod("info", "SNPLocations", function(x) {
          cat(" genome: ", x@genome ,"\n",
              "snpid: ", x@snpid, "\n",
              "chromosome: ", x@chrom, "\n",
              "position: ", x@pos)
})

## length is already a standardGeneric in R
setMethod("length", "SNPLocations", function(x) length(x@snpid))

setMethod("show", "SNPLocations",
function(object)
cat(class(object), "instance with", length(object),
"SNPs on genome", object@genome, "\n")
)

snplocs <- SNPLocations("hg19",
                        c("rs0001", "rs0002"),
                        c("chr1", "chrX"),
                        c(224033L, 1266886L))
info(snplocs)
# genome:  hg19 
# snpid:  rs0001 rs0002 
# chromosome:  chr1 chrX 
# position:  224033 1266886
snplocs
# SNPLocations instance with 2 SNPs on genome hg19

Validity

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

# snplocs@chrom <- c("chr9","chr8","chrY")
# validObject(snplocs)
## lengths of slots ’ snpid ’ , ’ chrom ’ and ’ pos ’ differ

setGeneric("chrom<-", function(x, value) standardGeneric("chrom<-"))
setReplaceMethod("chrom", "SNPLocations",
  function(x, value) {x@chrom <- value; validObject(x); x})
chrom(snplocs) <- LETTERS[1:2] 

info(snplocs)
# genome:  hg19 
# snpid:  rs0001 rs0002 
# chromosome:  A B 
# position:  224033 1266886

setAs("SNPLocations", "data.frame",
function(from)
data.frame(snpid=from@snpid, chrom=from@chrom, pos=from@pos)
)
as(snplocs, "data.frame")
#    snpid chrom     pos
# 1 rs0001     A  224033
# 2 rs0002     B 1266886

Inheritance

setClass("AnnotatedSNPs",
contains = "SNPLocations",
slots = c(
geneid ="character",
geneseq ="character"
 ),
validity = function(object) {
     if (!all(grepl("^[ACGTURYSWKMBDHVN]+$", toupper(object@geneseq)))) 
         return("The sequence must be a string in IUPAC codes")
     if  (length(object@geneid) != length(object) || 
          length(object@geneseq) != length(object))
       return(' "geneid" or "geneseq" slot must have the length of the object')
     TRUE
 })

AnnotatedSNPs <- function(genome, snpid, chrom, pos, geneid, geneseq){
new("AnnotatedSNPs",
SNPLocations(genome, snpid, chrom, pos),
geneid=geneid, geneseq=rep("AUGNNNTAATAGTGA",2))
}

setMethod("show", "AnnotatedSNPs",
function(object)
cat(class(object), "instance with", length(object),
"SNPs: ",object@snpid, "on gene", object@geneid, "\n")
)

snps <- AnnotatedSNPs("hg19",
c("rs0001", "rs0002"),
c("chr1", "chrX"),
c(224033L, 1266886L),
c("ID1", "ID2"))

as(snps, "SNPLocations")
# SNPLocations instance with 2 SNPs on genome hg19
snps
# AnnotatedSNPs instance with 2 SNPs:  rs0001 rs0002 on gene ID1 ID2

str(snplocs)
# Formal class 'SNPLocations' [package ".GlobalEnv"] with 4 slots
#   ..@ genome: chr "hg19"
#   ..@ snpid : chr [1:2] "rs0001" "rs0002"
#   ..@ chrom : chr [1:2] "A" "B"
#   ..@ pos   : int [1:2] 224033 1266886
str(snps)
# Formal class 'AnnotatedSNPs' [package ".GlobalEnv"] with 6 slots
#   ..@ geneid : chr [1:2] "ID1" "ID2"
#   ..@ geneseq: chr [1:2] "AUGNNNTAATAGTGA" "AUGNNNTAATAGTGA"
#   ..@ genome : chr "hg19"
#   ..@ snpid  : chr [1:2] "rs0001" "rs0002"
#   ..@ chrom  : chr [1:2] "chr1" "chrX"
#   ..@ pos    : int [1:2] 224033 1266886
class(snplocs)
# [1] "SNPLocations"
# attr(,"package")
# [1] ".GlobalEnv"

is(snps, "SNPLocations")
is(snps, "AnnotatedSNPs")
# TRUE

showClass("SNPLocations")
# Class "SNPLocations" [in ".GlobalEnv"]
# 
# Slots:
#                                               
# Name:     genome     snpid     chrom       pos
# Class: character character character   integer
# 
# Known Subclasses: "AnnotatedSNPs"
showClass("AnnotatedSNPs")
# Class "AnnotatedSNPs" [in ".GlobalEnv"]
# 
# Slots:
#                                                                   
# Name:     geneid   geneseq    genome     snpid     chrom       pos
# Class: character character character character character   integer
# 
# Extends: "SNPLocations"

RefClass

DNA <- setRefClass("DNA")
DNA$new()
# Reference class object of class "DNA"

DNA <- setRefClass("DNA", fields = list(seq = "character"))
a <- DNA$new(seq = "TATAWAW")
a$seq
# "TATAWAW"
a$seq <- "GGGTCAATCT"
a$seq
# "GGGTCAATCT"
b <- a
b$seq <- "GGCGGG"
a$seq
# "GGCGGG"

c <- a$copy()
a$seq <- "ATGCAAAT"
c$seq
# "GGCGGG"

DNA <- setRefClass("DNA", fields = list(seq = "character"), methods = list(reverseComplement = function() {
     .seq <- seq
     .seq <- rev(as.character(strsplit(.seq, "")[[1]]))
     .seq <- factor(.seq, levels = c("A", "C", "G", "T"))
     levels(.seq) <- c("T", "G", "C", "A")
     seq <<- paste(as.character(.seq), collapse = "")
 }))
a <- DNA$new(seq = "ATATTCAT")
a$reverseComplement()
a$seq
# "ATGAATAT"

NoNDNA <- setRefClass("NoNDDNA", contains = "DNA", methods = list(initialize = function(...) {
   .self$initFields(seq = ...)
   if (length(seq)!=0) {
       if (grepl("N", seq)) stop("contain N!")
   }
}))
b <- NoNDNA$new()
# b <- NoNDNA$new(seq = "NA")
# ## Error: contain N!