A simple side-by-side comparison of S4 with S3 in R

s4-vs-s3.md

S4

setClass('Seq', representation(data = 'character', id = 'character'),
         validity = function (object) is_dna(object@data))

print_fasta = function (object) {
    if (length(object@id) > 0) cat('>', object@id, '\n', sep = '')
    cat(strsplit(object@data, '(?<=.{60})', perl = TRUE)[[1]],
        sep = '\n')
}

setMethod('show', signature('Seq'), print_fasta)

## [1] "show"

setGeneric('revcomp',
          function (object) new('Seq', data = rc(object@data), id = object@id))

## [1] "revcomp"

Usage:

(gattaca_s4 = new('Seq', data = 'GATTACA', id = 'from the movie'))

## >from the movie
## GATTACA

revcomp(gattaca_s4)

## >from the movie
## TGTAATC

---

S3

seq = function (data, id) {
    stopifnot(is_dna(data))
    stopifnot(inherits(id, 'character'))
    structure(as.list(environment()), class = 'seq')
}

print.seq = function (x, ...) {
    if (length(x$id) > 0) cat('>', x$id, '\n', sep = '')
    cat(strsplit(x$data, '(?<=.{60})', perl = TRUE)[[1]], sep = '\n')
}

revcomp = function (seq) UseMethod('revcomp')

revcomp.default = rc

revcomp.seq = function (seq)
    seq(revcomp(seq$data), seq$id)

Usage:

(gattaca_s3 = seq('GATTACA', 'from the movie'))

## >from the movie
## GATTACA

revcomp(gattaca_s3)

## >from the movie
## TGTAATC

s4-vs-s3.rmd

```{r echo=FALSE}
# Helper functions that both implementations are going to use.

is_dna = function (seq)
    ! any(is.na(match(strsplit(seq, '')[[1]], c('A', 'C', 'G', 'T'))))

rc = function (seq)
    paste(rev(strsplit(chartr('ACGT', 'TGCA', seq), '')[[1]]), collapse = '')
```

## S4

```{r}
setClass('Seq', representation(data = 'character', id = 'character'),
         validity = function (object) is_dna(object@data))

print_fasta = function (object) {
    if (length(object@id) > 0) cat('>', object@id, '\n', sep = '')
    cat(strsplit(object@data, '(?<=.{60})', perl = TRUE)[[1]],
        sep = '\n')
}

setMethod('show', signature('Seq'), print_fasta)

setGeneric('revcomp',
          function (object) new('Seq', data = rc(object@data), id = object@id))
```

### Usage:

```{r}
(gattaca_s4 = new('Seq', data = 'GATTACA', id = 'from the movie'))
revcomp(gattaca_s4)
```

---

## S3

```{r}
seq = function (data, id) {
    stopifnot(is_dna(data))
    stopifnot(inherits(id, 'character'))
    structure(as.list(environment()), class = 'seq')
}

print.seq = function (x, ...) {
    if (length(x$id) > 0) cat('>', x$id, '\n', sep = '')
    cat(strsplit(x$data, '(?<=.{60})', perl = TRUE)[[1]], sep = '\n')
}

revcomp = function (seq) UseMethod('revcomp')

revcomp.default = rc

revcomp.seq = function (seq)
    seq(revcomp(seq$data), seq$id)
```

### Usage:

```{r}
(gattaca_s3 = seq('GATTACA', 'from the movie'))
revcomp(gattaca_s3)
```

Here’s a “better” pseudo-S4 that emphasises functions instead of data (as it should, in a functional language), and scaffolds S3 code behind the scenes, but with S4-like type checks in place:

class_(seq,
       list(data = is_dna, id = is.character),

       print = function (x, ...) {
           if (length(x$id) > 0) cat('>', x$id, '\n', sep = '')
           cat(strsplit(x$data, '(?<=.{60})', perl = TRUE)[[1]], sep = '\n')
       },

       revcomp = function (seq) seq(revcomp(seq$data), seq$id))

To show that this is reasonable, here’s a quick and dirty proof of concept implementation of class_. In reality, I’d probably call this function class and design it so that existing use of class (i.e. returning or assigning an object’s S3 class) would still work. This is messy but entirely possible. A real version would also need to allow for inheritance and potentially a cleaner interface.

class_ = function (name, definition, ...) {
    name = deparse(substitute(name))
    parent = parent.frame()
    cons_args = as.pairlist(setNames(replicate(length(definition),
                                               quote(expr =)),
                                     names(definition)))
    validation = mapply(function (n, v) bquote(stopifnot(.(v)(.(as.name(n))))),
                        names(definition), definition)
    cons_str = bquote(structure(as.list(environment()), class = .(name)))
    cons_body = as.call(c(quote(`{`), validation, cons_str))
    cons = eval(call('function', cons_args, cons_body), envir = parent)
    assign(name, cons, envir = parent)

    # Define functions

    interface = list(...)

    for (func in names(interface)) {
        if (! isS3method(paste(func, 'default', sep = '.'), envir = parent)) {
            fundef = call('function', formals(interface[[func]]),
                          bquote(UseMethod(.(func))))
            old = try(get(func, parent, mode = 'function'), silent = TRUE)
            if (inherits(old, 'try-error'))
                old = NULL
            assign(paste(func, 'default', sep = '.'), old, parent)
            assign(func, eval(fundef, parent), parent)
        }

        assign(paste(func, name, sep = '.'), interface[[func]], parent)
    }

    invisible()
}