Advanced R programming

Table of Contents

Base types

Basic information on base types: from simple to S4.

typeof( TRUE)
class( TRUE)

typeof( 2L)
class( 2L)

typeof( 2)
class( 2)

typeof( 2 + 2i)
class( 2 + 2i)

typeof( "fox")
class( "fox")

typeof( list( a = 123, b = "fox"))
class( list( a = 123, b = "fox"))

typeof( data.frame( id = 1:5, value = rnorm( 5)))
class( data.frame( id = 1:5, value = rnorm( 5)))

typeof( globalenv())
class( globalenv())

typeof( function(){})
class( function(){})

typeof( quote( x <- 3))
class( quote( x <- 3))

typeof( setClass( "test", slots = list( value = "numeric"))( value = 5))
class( setClass( "test", slots = list( value = "numeric"))( value = 5))

Basic information on functions

From an empty function to ... argument.

f1 <- function(){}
f1()

f2 <- function(){
  print( " Hello world!")
}

x <- f2()
x

f3 <- function( x){
  print( x)
 }

x <- f3( "This fox is brown")
x

f4 <- function( x, y){
  x^y
}

f4( 2, 4)

f5 <- function( x, y = 1){
  x^y
}

f5( 2, 4)
f5( 2)

f6 <- function( x, f, ...){
  plot( x, f( x), ...)
}

f6( seq( -pi, pi, length.out = 100), sin)

f6( seq( -pi, pi, length.out = 100),
   function( x){ sin(x^2) + cos( x^2)},
   type = "o", pch = 20, col = "red", fg = "magenta", main = "This is one crazy plot")

Environments

Construction

  • hashing table
  • pointer to a parent environment
symbol value
x 2
y function

Basic environments

Basic environments

  • empty
  • base
  • global

and respective functions

  • emptyenv()
  • baseenv()
  • globalenv()
  • environment()
emptyenv()
baseenv()
globalenv()
environment()

Environment tree and symbol visibility

Typical functions

  • search()
  • searchpaths()
  • parent.env()
search()
searchpaths()
library( dplyr)

x <- seq( 0, 1, length.out = 100)

base::plot( x, exp( x), type = "o", col = "blue", pch = 20)
plot( x, exp( x), type = "o", col = "blue", pch = 20)


parent.env( baseenv())

plot <- function( ...){
  print( "It's a different function")
}

rm( plot)

x <- ts( cumsum( rnorm( 5 * 24)), start = c( 2000, 1), frequency = 12)
x
plot( x)
stats::plot.ts( x, col = "blue", lwd = 2)
y <- tibble( x = rnorm( 100), y = 1 + 2 * x + rnorm( 100))
y
typeof( y)
plot( y)
graphics:::plot.data.frame( y, pch = 4)
listEnvs( list( environment( graphics:::plot.data.frame)))

Task Write a function searching through a search path (standard and recursive versions).

### Standard version
listEnvs <- function( ret = list( globalenv())){
  while( !identical( emptyenv(), ret[[length( ret)]])){
    ret <- c( ret, parent.env( ret[[ length( ret)]]))
  }
  ret
}

test <- listEnvs()
test

listEnvs( list( baseenv()))


### Recursive version
listEnvs2 <- function( ret = list( globalenv())){
  ## stop condition
  if( identical( emptyenv(), last( ret))){
  return( ret)
  }
  ret <- c( ret, parent.env( last( ret)))
  listEnvs2( ret)
}

listEnvs2()

Searching for symbols

Typical functions

  • where()
  • exists()
library( pryr)

exists( "plot", inherits = FALSE)
exists( "plot", inherits = FALSE, envir = baseenv())
ls( envir = baseenv())
ls( envir = baseenv(), all.names = TRUE)
ls()
ls( all.names = TRUE)

.x <- 321
ls( all.names = TRUE)
.x + 2
.x

e <- where( "plot.ts")
where( "plot.ts", env = e)

Task Write a function searching for a symbol. The function should check for a base type of a symbol and return all occurrences of a symbol (also the overshadowed ones). Write the standard and recursive version.

### Standard versrion
findSymbol <- function( s, e = list( globalenv()), bt){
  ret <- list()
  while( !identical( emptyenv(), last( e))){
    if( exists( s, inherits = FALSE, envir = last( e))){
      if( identical( typeof( get( s, envir = last( e))), bt)){
        ret <- c( ret, last( e))
      }
    }
    e <- c( e, parent.env( last( e)))
  }
  ret
}

findSymbol( "plot", bt = "integer")
findSymbol( "plot", bt = "closure")

Working with environments

  • Creating new.env(), attr() for the attribute name
  • Removing rm(), gc(), gcinfo()
  • Adding elements quote(), eval(), $, assign()
  • Listing and getting elements ls, $, get()
  • Copying and cloning environments as.environment(), as.list()
### Cleaning
rm(list = ls())

### Creating envs
e <- new.env()
e
typeof( e)
parent.env( e)

### Removing envs
ls()
rm( e)
ls()
gc()
gcinfo(verbose = TRUE)
for( j in 1:20){
  x <- rnorm( 10^5)
}
gcinfo(verbose = FALSE)

### Creating trees
e0 <- new.env( parent = emptyenv())
parent.env( e0)
e1 <- new.env( parent = e0)
parent.env( e1)
e0
parent.env( parent.env( e1))
parent.env( baseenv())

e0
attr( e0, "name") <- "myNewEnv"
e0
attr( e1, "name") <- "mySecondEnv"
e0
e1

### Cleaning
rm(list = ls())

### Creating env
e <- new.env()
attr(e, "name") <- "myEnv"
e
parent.env( e)

### Adding elements
a <- list()
a
a <- c(a, list(value =10))
a
a$value
a$id <- 1
a

e$x <- TRUE
e$x
x

assign(x = "y", value = FALSE, envir = e)
e$y
y

eval(quote( x <- FALSE), envir = e)
e$x

ee <- new.env(parent = emptyenv())
attr(ee, "name") <- "evilEnv"
ee

ee$x <- "ok"
ee$x
assign(x = "y", value = "not ok", envir = ee)
ee$y
eval(quote( x <- "awesome"), envir = ee)

x <- 2
x
`<-`(x, 9)
x
`<-`

### Cleaning
rm(list = ls())

### Listing
ls(envir = globalenv())
ls(envir = globalenv(), all.names = TRUE)
ls(envir = baseenv())
ls(envir = baseenv(), all.names = TRUE)

### Getting from envs
base::plot()
graphics:::plot.data.frame()

e <- new.env()
attr( e, "name") <- "myEnv"
e

e$x <- TRUE
e$x
get(x = "x", envir = e)
e[["x"]]
e["x"]
e[[1]]
e[["y"]] <- FALSE
e$y

### Cleaning
rm(list = ls())

### Copying envs
e <- new.env()
e$x <- 123

ee <- e
ee$x
ee$x <- 321
ee$x
e$x

n <- 10^4
e$x <- data.frame( id = 1:n, value = rnorm( n))
x
head( e$x)
object.size( e$x)
object.size( e)
e$x <- 123

eee <- as.environment( as.list( e))
eee
e$x
eee$x
eee$x <- 456
eee$x
e$x

parent.env( eee)
parent.env( eee) <- globalenv()
parent.env( eee)

as.environment( search()[4])

Task Write two functions. The goal of each function is to take a vector of numbers, generate a random number, append it to the vector and return a vector. The first function should accept a vector as an argument, the second should accept an environment as an argument. Evaluate a for loop implementing \( n \)-fold of the function for each function. Check evaluation times and explain the difference.

### Cleaning
rm(list = ls())

### Creating env
e <- new.env(parent = emptyenv())
e$x <- 123

### Function
f <- function( e){
  e$x <- rnorm(1)
}

e$x
f( e)
e$x

  • Simple search path manipulation attach(), detach()
### Cleaning
rm(list = ls())

search()
attach( list( os = "linux"), name = "os")
search() 
detach(name = "os")
search() 

Task Write a function that remembers how many times it's been called. The function should provide means of resetting the counter and should not leave any junk behind.

### Cleaning
rm(list = ls())

f <- function(){
  if(!exists( "x")){
    x <- 0
  }
  x <- x + 1
  x
}

f()

remember <- function( reset = FALSE){
  if( !("remember" %in% search()) ){
    attach( list( rememberCounter = 0), name = "remember", pos = 2)
  }
  e <- as.environment( "remember")
  e$rememberCounter <- e$rememberCounter + 1
  print( e$rememberCounter)
  if( reset){
    detach( name = "remember")
  }
}


remember()
remember( reset = TRUE)
search()

Functions

Construction

  • base type
  • formals (arguments) formals()
  • body body()
  • closure environment()
f <- function(){}
class( f)
typeof( f)
f()

formals( f) <- alist( x = 0) 
f

typeof( body( f))
body( f) <-  quote( print( x^2))
f
f( 2)

environment( f)

Environments realted to a function, static scoping. Applications and typical problems.

  • execution environment
  • enclosing environment environment()
  • binding environment
  • calling environment parent.frame()

Example Checking for execution environment and its parent. Checking for enclosing environment. What is static scoping and how does it work?

rm(list = ls())

f <- function(){
  e <- environment()
  list( exe = e, parent = parent.env( e))
}

f()

e <- new.env()
eval( quote( f <- function(){
  e <- environment()
  list( exe = e, parent = parent.env( e))
}
), envir = e)

f()
e$f()
e

e$x <- "brown fox"
g <- function(){
  print( x)
}
x
g()
environment( g)
environment( g) <- e
environment( g)
e
g()

Example Defining symbols from within a function in an enclosing environment with $ and quote() / eval() combo.

rm(list = ls())

f <- function(){
  e <- parent.env( environment())
  e$x <- "from a function with love"
}

x
f()
x

g <- function(){
  e <- parent.env( environment())
  eval( quote( x <- "another stuff"), envir = e)
}

x
g()
x

e <- new.env( parent = emptyenv())

environment( g) <- e
g()

### More subtle example
rm(list = ls())

f1 <- function(){
  e <- parent.env( environment())
  x <- 10
  e$x <- x^2
}

x
f1()
x

f2 <- function(){
  e <- parent.env( environment())
  x <- 10
  eval( quote( x <- x^2), envir = e)
}

x
f2()
x

Example Functions defining symbols in a given environments with given values.

rm(list = ls())

define <- function( sym, val, env = globalenv()){
  env[[sym]] <- val
}

define <- function( sym, val, env = globalenv()){
  assign( x = sym, value = val, envir = env)
}


ls()
define( "x", FALSE)
x

define( "x", rnorm(4))
x

e <- new.env()
define( "x", rnorm(1), env = e)
x
e$x

Example Functions taking and returning environments (introduction to R6 object model), environment as a data structure.

rm(list = ls())

graph <- function( vertices, edges){
  e <- new.env( parent = globalenv())
  e$vertices <- vertices
  e$edges <- edges
  e$getVertices <- function(){ vertices}
  environment( e$getVertices) <- e
  e
}

v <- 1:10
e <- cbind( sample( v, 5), sample( v, 5))
e

g1 <- graph( vertices = v, edges = e)
g1
g1$vertices
g1$edges
g1$getVertices()

g1$vertices <- 1:5
g1$getVertices()

Example Function factories and retrospective redefinitions in execution environment.

rm(list = ls())

f <- function(){
  if ( !exists( "x", inherits = FALSE)){
    x <- 0
  }
  x <- x + 1
  x
}

f()

makeFun <- function( x){
  function( y){ x + y}
}

g2 <- makeFun( 2)
formals( g2)
body( g2)
g2( 2)
environment( g2)$x <- 100
g2( 2)

### use enclosing as the holder for private vars.
createFun <- function(){
  counter <- 0
  function(){
    e <- parent.env( environment())
    print( counter)
    e$counter <- counter + 1
  }
}

f <- createFun()
f()
ls()
search()

Example Changing enclosing environment and checking for calling environment with parent.frame().

rm(list = ls())

f <- function(){
  list(
    enclosing = parent.env( environment()),
    calling = parent.frame()
  )
}

f()

g <- function(){
  f()
}

g()

e <- new.env()
attr( e, "name") <- "myEnv"
e

environment( f) <- e

f()

g()

Example What is <<- function? A function returning execution, enclosing and calling environments.

rm(list = ls())

ls()

f <- function(){
  x <<- 123
}

f()
ls()
x

environment( f)

e <- new.env()
attr( e, "name") <- "myEnv"

e

environment( f) <- e

rm( x)
x

f()
x

g <- function(){
  list(
    exe = environment(),
    encl = parent.env( environment()),
    calling = parent.frame()
  )
}

g()
environment( g) <- e
g()

Example Data bleeding and pseudo-dynamic scoping.

rm(list = ls())

f <- function(){
  print( x)
}

f()
x <- "global env"
f()

g <- function(){
  x <- "local env"
  f()
}

g()

fds <- function(){
  e <- parent.frame()
  x <- get( "x", envir = e)
  print( x)
}

g <- function(){
  x <- "local env"
  fds()
}

x
g()

g <- function(){
  ## x <- "local env"
  fds()
}

g()

Example Recursion with environements.

rm(list = ls())

f <- function( n){
  if( n == 0) return( 1)
  n * f( n - 1)
}

f( 0)
f( 1)
f( 2)
f( 3)

Object models

Introduction

  • S3
  • S4
  • R5 (RC)
  • R6

S3 object model

  • No class definition
  • Based on a system of generics
  • Generics dispatch methods based on first argument class

Typical functions

  • is.object(), isS4(), is.R6(), otype()
  • ftype() + code
  • methods()
  • attributes(), attr(), structure()
  • UseMethod()

Intruduction: various S3 classes

rm(list = ls())

x <- cumsum( rnorm( 10))
x

typeof( x)
mode( x)
class( x)

y <- ts( cumsum( rnorm( 5 *12)), frequency = 12, start = c( 2001, 1))
y
typeof( y)
mode( y)
class( y)

data( cars)
head( cars)
str( cars)
typeof( cars)
mode( cars)
class( cars)

z <- lm( dist ~ +1 +speed, data = cars)
z
typeof( z)
mode( z)
class( z)

Testing for S3 class

rm(list = ls())

d <- data.frame( id = 1:5, value = rnorm( 5))
d

dd <- as.list( d)
dd

attributes( d)
is.object( d)
is.object( dd)

ddd <- setClass( Class = "test",
              slots = list( value = "numeric"))( value = 5)

d
isS4( d)
isS4( dd)
isS4( ddd)

library( pryr)
library( dplyr)
otype( d)
otype( dd)
otype( ddd)

Defining a simple S3 class

rm(list = ls())

### Libraries
library( pryr)

d <- data.frame( id = 1:5, value = rnorm( 5))
d

attributes( d)
attr( d, "class") <- NULL
attr( d, "row.names") <- NULL
d

attr( d, "class") <- "data.frame"
attr( d, "row.names") <- 1:5
class( d)

plot( d)
print.data.frame( d)
print.default( d)
print( d)
d

dataframeInfo <- function( info, ...){
  ret <- data.frame( ...)
  structure( ret, "class" = "dataframeInfo", "info" = info)
}

o1 <- dataframeInfo( info = "Data from experiment 1", id = 1:5, value = rnorm( 5))
class( o1)
otype( o1)
o1
print.default( o1)

Testing for S3 generic

### Cleaning
rm(list = ls())

### Libraries
library( pryr)

### Check the body of a function
plot
body( plot)
body( data.frame)

list
sum

### Use ftype
ftype( plot)
ftype( data.frame)

ftype( list)
ftype( sum)
ftype( `[`)
ftype( show)

Methods in S3 object model. Binding with existing generics

### Cleaning
rm(list = ls())

### Libraries
library( pryr)

### Define a graph class
graph <- function( vertices, edges){
  ret <- list( vertices = vertices,  edges = edges)
  structure( ret, class = "graph")
}

### Example
v <- 1:10
e <- cbind( sample( v, 7), sample( v, 7))

g1 <- graph( vertices = v, edges = e)
g1

### print method
ftype( print)

print.graph <- function( object){
  `%G%` <- paste0
  cat( "\nGraph with " %G% as.character( length( object$vertices)) %G% " vertices. \n\n")
  n <- nrow( object$edges)
  if( n > 0 & n < 10){
    print( object$edges)
  } else {
    cat( "Use getEdges() getter to get all egdes. \n\n")
  }
}

g1
print( g1)
print.default( g1)

### plot method for class graph
ftype( plot)

plot.graph <- function( object, ...){
  n <- length( object$vertices)
  x <- rnorm( n)
  y <- rnorm( n)
  plot( x, y, ...)
  checkCoordinate <- function( j, coords){ coords[j]}
  for( i in 1:nrow( object$edges)){
    lines(
      c( checkCoordinate( object$edges[i,1], x), checkCoordinate( object$edges[i,2], x)),
      c( checkCoordinate( object$edges[i,1], y), checkCoordinate( object$edges[i,2], y)),
      ...
    )
  }
}

plot( g1, pch = 20, cex = 3, col = "blue", lwd = 3)


### Example
v <- 1:30
e <- cbind( sample( v, 50, replace = TRUE), sample( v, 50, replace = TRUE))

g2 <- graph( vertices = v, edges = e)
g2

plot( g2, pch = 20, col = "red")

### How do I check for existing methods
methods( "plot")
methods( class = "graph")

### method getEdges for class graph
ftype( getEdges)

Methods in S3 object model. Creating new generics and binding methods

### Cleaning
rm(list = ls())

### Libraries
library( pryr)

### Define a graph class
graph <- function( vertices, edges){
  ret <- list( vertices = vertices,  edges = edges)
  structure( ret, class = "graph")
}

### print method
print.graph <- function( object){
  `%G%` <- paste0
  cat( "\nGraph with " %G% as.character( length( object$vertices)) %G% " vertices. \n\n")
  n <- nrow( object$edges)
  if( n > 0 & n < 10){
    print( object$edges)
  } else {
    cat( "Use getEdges() getter to get all egdes. \n\n")
  }
}

### plot method for class graph
plot.graph <- function( object, ...){
  n <- length( object$vertices)
  x <- rnorm( n)
  y <- rnorm( n)
  plot( x, y, ...)
  checkCoordinate <- function( j, coords){ coords[j]}
  for( i in 1:nrow( object$edges)){
    lines(
      c( checkCoordinate( object$edges[i,1], x), checkCoordinate( object$edges[i,2], x)),
      c( checkCoordinate( object$edges[i,1], y), checkCoordinate( object$edges[i,2], y)),
      ...
    )
  }
}

### method getEdges for class graph
getEdges <- function( obj, ...){ UseMethod( "getEdges")}
ftype( getEdges)

getEdges.default <- function( obj, ...){
  print( "getEdges() is a method of class graph. ")
}

getEdges.graph <- function( obj, ...){
  `%G%` <- paste0
  cat( "\n\nEdges of a graph with " %G% as.character( length( obj$vertices)) %G% " vertices.\n\n")
  obj$edges
}

### Example
v <- 1:30
e <- cbind( sample( v, 50, replace = TRUE), sample( v, 50, replace = TRUE))

g2 <- graph( vertices = v, edges = e)
g2
class( g2)
getEdges( g2)

Inheritance

### Cleaning
rm(list = ls())

### Define a class dataframeInfo
dataframeInfo <- function( info = "", ...){
  ret <- data.frame( ...)
  structure( ret, info = info, class = c( "dataframeInfo", "data.frame"))
}

d1 <- dataframeInfo( info = "Some data", id = 1:5, value = rnorm( 5))

print( d1)
plot( d1, main = "Some data")

### Method info for class dataframeInfo
info <- function( obj, ...){ UseMethod( "info")}

info.default <- function( object, ...){
  print( "Method info for class dataframeInfo." )
}

info.dataframeInfo <- function( object, ...){
  attributes( object)$info
}

info( d1)

### Method plot for class dataframeInfo
plot.dataframeInfo <- function( object, ...){
  temp <- structure( object, class = "data.frame")
  plot( temp, main = info( object), ...)
}

plot( d1)

d2 <- dataframeInfo( info = "Some new data", id = 1:5, value = rnorm( 5))
plot( d2)

S4 object model

  • Historically, it is successor of the S3 object model
  • It provides a formal definition of a class.
  • The S4 object model relies on a system of generic functions dispatching methods. This is a parallel system to the S3 system.
  • The base type for an S4 object is always S4.

Defining a class, constructors

  • Useful functions: setClass(), new(), getClass()
### Cleaning
rm(list = ls())

### Simple class
graph <- setClass( Class = "graph",
                  slots = list( vertices = "numeric", edges = "matrix"))

graph
typeof( graph)
class( graph)
attributes( graph)

### Defining a simple object
v <- 1:10
e <- cbind( sample( v, 5), sample( v, 5))
g1 <- graph( vertices = v, edges = e)

g1
class( g1)
typeof( g1)

attributes( g1)$vertices
attributes( g1)$edges

attributes( g1)$vertices <- "brown fox"
attributes( g1)$edges <- "jumps over me"

g1

Automatic getters and setters

  • Useful functions: @, slot()
### Cleaning
rm(list = ls())

### Simple class
graph <- setClass(Class = "graph",
                  slots = list( vertices = "numeric", edges = "matrix"))

### Defining a simple object
v <- 1:10
e <- cbind(sample( v, 5), sample( v, 5))
g1 <- graph(vertices = v, edges = e)

### Getters
g1@vertices
g1@edges

slot(g1, "vertices")


### Setters
g1@vertices <- 10:1
g1@vertices
g1@vertices <- "brown fox"

slot(g1, "vertices") <- 1:20
slot(g1, "vertices")
g1@vertices

### Trick
g1
attributes(g1)
attributes(g1)$vertices
attributes(g1)$vertices <- 1:5
g1@vertices
attributes(g1)$vertices <- "brown fox"
g1@vertices
names(attributes(g1))

Methods. How to check if a function is a generic in S4 object model

  • Useful functions: show(), ftype(), isGeneric(), hasMethod(), methods(), showMethods()

    ### Cleaning
    rm(list = ls())
    
    ### Libraries
    library(pryr)
    
    ### Check if a function is generic in S4
    show
    body(show)
    isGeneric("show")
    ftype(show)
    ftype(print)
    
    ### How to check methods
    showMethods("show")
    methods(generic.function = "show")
    class(show)
    methods(class = "standardGeneric")
    
    ### Example
    graph <- setClass(Class = "graph",
                      slots = list( vertices = "numeric", edges = "matrix"))
    
    isGeneric("graph")
    body(graph)
    graph
    class(graph)
    methods(class = "graph")
    
    

Binding a method to an existing generic function

  • Useful functions: setMethod()
  • The name of the first argument is always object
### Cleaning
rm(list = ls())

### Example
graph <- setClass(Class = "graph",
                  slots = list( vertices = "numeric", edges = "matrix"))

v <- 1:10
e <- cbind(sample(size = 20, x = v, replace = TRUE),
           sample(size = 20, x = v, replace = TRUE))

g1 <- new(Class = "graph", vertices = v, edges = e)
g1
str(g1)

v <- 1:10
e <- cbind(sample(size = 5, x = v, replace = TRUE),
           sample(size = 5, x = v, replace = TRUE))

g2 <- new(Class = "graph", vertices = v, edges = e)
g2


### Adding the show method
ftype(show)

temp <- function(object) {
    `%G%` <- paste0
    cat("\nObject of class" %G% class(object) %G% "\n\n")
    cat("Graph with " %G% as.character(length(object@vertices)) %G% " vertices\n\n")
    ne <- nrow(object@edges)
    if(ne > 0 & ne <= 6) {
        e <- object@edges
        for(i in 1:nrow(e)){
            cat(as.character(e[i, 1]) %G% " -> " %G% as.character(e[i,2]))
            cat("\n")
        }
    } else {
        cat("Use getEdges() to get a list of all edges. \n")
    }
    cat("\n\n")
    }

g1

setMethod(f = "show",
          signature = "graph",
          definition = temp)

g1
g2

methods(class = "graph")

Creating S4 generic functions

  • Useful functions: setGeneric(), standardGeneric()
### Cleaning
rm(list = ls())

### Class definition
graph <- setClass(Class = "graph",
                  slots = list( vertices = "numeric", edges = "matrix"))


### Method show
temp <- function(object) {
    `%G%` <- paste0
    cat("\nObject of class" %G% class(object) %G% "\n\n")
    cat("Graph with " %G% as.character(length(object@vertices)) %G% " vertices\n\n")
    ne <- nrow(object@edges)
    if(ne > 0 & ne <= 6) {
        e <- object@edges
        for(i in 1:nrow(e)){
            cat(as.character(e[i, 1]) %G% " -> " %G% as.character(e[i,2]))
            cat("\n")
        }
    } else {
        cat("Use getEdges() to get a list of all edges. \n")
    }
    cat("\n\n")
    }

setMethod(f = "show",
          signature = "graph",
          definition = temp)


### Getters
setGeneric("getEdges", function( object, ...){ standardGeneric( "getEdges")})
isGeneric("getEdges")

temp <- function(object) {
    object@edges
}

setMethod(f = "getEdges",
          signature = "graph",
          definition = temp)

setGeneric("getVertices", function( object, ...){ standardGeneric( "getVertices")})

temp <- function(object) {
    object@vertices
}

setMethod(f = "getVertices",
          signature = "graph",
          definition = temp)


### Example
v <- 1:10
e <- cbind(sample(size = 20, x = v, replace = TRUE),
           sample(size = 20, x = v, replace = TRUE))

g1 <- new(Class = "graph", vertices = v, edges = e)
g1

getEdges(g1)
getVertices(g1)

methods(class = "graph")

Primitive generics and S4 methods

### Cleaning
rm(list = ls())

### Class definition
graph <- setClass(Class = "graph",
                  slots = list( vertices = "numeric", edges = "matrix"))


### Method show
temp <- function(object) {
    `%G%` <- paste0
    cat("\nObject of class" %G% class(object) %G% "\n\n")
    cat("Graph with " %G% as.character(length(object@vertices)) %G% " vertices\n\n")
    ne <- nrow(object@edges)
    if(ne > 0 & ne <= 6) {
        e <- object@edges
        for(i in 1:nrow(e)){
            cat(as.character(e[i, 1]) %G% " -> " %G% as.character(e[i,2]))
            cat("\n")
        }
    } else {
        cat("Use getEdges() to get a list of all edges. \n")
    }
    cat("\n\n")
    }

setMethod(f = "show",
          signature = "graph",
          definition = temp)


### Getters
setGeneric("getEdges", function( object, ...){ standardGeneric( "getEdges")})
isGeneric("getEdges")

temp <- function(object) {
    object@edges
}

setMethod(f = "getEdges",
          signature = "graph",
          definition = temp)

setGeneric("getVertices", function( object, ...){ standardGeneric( "getVertices")})

temp <- function(object) {
    object@vertices
}

setMethod(f = "getVertices",
          signature = "graph",
          definition = temp)


### Example
v <- 1:10
e <- cbind(sample(size = 20, x = v, replace = TRUE),
           sample(size = 20, x = v, replace = TRUE))

g1 <- new(Class = "graph", vertices = v, edges = e)
g1

getEdges(g1)
getVertices(g1)

methods(class = "graph")

### Primitive generics, e.g., `[`
temp <- function(x, i, drop = "missing") {
    ## picking vertices
    nv <- x@vertices[i]
    ## picking edges
    checkEdges <- function(e, v){ all(e %in% v)}
    id <- apply(X = x@edges, MARGIN = 1, FUN = checkEdges, v = nv)
    ne <- x@edges[id, ]
    ## create a new object
    graph(vertices = nv, edges = ne)
}

setMethod(f = "[",
          signature = "graph",
          definition = temp)

g2 <- g1[1:5]
getVertices(g1)
getVertices(g2)

getEdges(g1)
getEdges(g2)

Validating an object

  • Useful functions: Typowe funkcje: validObject(), setValidity()
### Cleaning
rm(list = ls())

### Class definition
graph <- setClass(Class = "graph",
                  slots = list( vertices = "numeric", edges = "matrix"))

### Method show
temp <- function(object) {
    `%G%` <- paste0
    cat("\nObject of class" %G% class(object) %G% "\n\n")
    cat("Graph with " %G% as.character(length(object@vertices)) %G% " vertices\n\n")
    ne <- nrow(object@edges)
    if(ne > 0 & ne <= 6) {
        e <- object@edges
        for(i in 1:nrow(e)){
            cat(as.character(e[i, 1]) %G% " -> " %G% as.character(e[i,2]))
            cat("\n")
        }
    } else {
        cat("Use getEdges() to get a list of all edges. \n")
    }
    cat("\n\n")
}

setMethod(f = "show",
          signature = "graph",
          definition = temp)


### Getters
setGeneric("getEdges", function( object, ...){ standardGeneric( "getEdges")})
isGeneric("getEdges")

temp <- function(object) {
    object@edges
}

setMethod(f = "getEdges",
          signature = "graph",
          definition = temp)

setGeneric("getVertices", function( object, ...){ standardGeneric( "getVertices")})

temp <- function(object) {
    object@vertices
}

setMethod(f = "getVertices",
          signature = "graph",
          definition = temp)


### Creating validity checks
temp <- function(object) {
    val <- TRUE
    warn <- NULL
    ## check if there are any edges
    if(!(nrow(getEdges(object)) > 0)) {
        val <- FALSE
        warn <- "No defined edges"
    }
    ## check if edges are consistent with vertices
    if(!all(as.vector(getEdges(object)) %in% getVertices(object))) {
        val <- FALSE
        warn <- "Edges defined for not defined vertices. "
    }
    ## return
    if(val) {
        TRUE
    } else {
        warn
    }
}

setValidity(Class = "graph", temp)

### Example
v <- 1:10
e <- cbind(sample(size = 20, x = v, replace = TRUE),
           sample(size = 20, x = v, replace = TRUE))

g1 <- graph(vertices = v, edges = e)
g1

getEdges(g1)
getVertices(g1)
validObject(g1)

v <- 1:10
e <- cbind(sample(size = 20, x = 1:20, replace = TRUE),
           sample(size = 20, x = 1:20, replace = TRUE))

g2 <- graph(vertices = v, edges = e)

Mutating objects

  • Functions of the form foo<-()
### Cleaning
rm(list = ls())

### Class definition
graph <- setClass(Class = "graph",
                  slots = list( vertices = "numeric", edges = "matrix"))

### Method show
temp <- function(object) {
    `%G%` <- paste0
    cat("\nObject of class" %G% class(object) %G% "\n\n")
    cat("Graph with " %G% as.character(length(object@vertices)) %G% " vertices\n\n")
    ne <- nrow(object@edges)
    if(ne > 0 & ne <= 6) {
        e <- object@edges
        for(i in 1:nrow(e)){
            cat(as.character(e[i, 1]) %G% " -> " %G% as.character(e[i,2]))
            cat("\n")
        }
    } else {
        cat("Use getEdges() to get a list of all edges. \n")
    }
    cat("\n\n")
}

setMethod(f = "show",
          signature = "graph",
          definition = temp)


### Getters
setGeneric("getEdges", function( object, ...){ standardGeneric( "getEdges")})
isGeneric("getEdges")

temp <- function(object) {
    object@edges
}

setMethod(f = "getEdges",
          signature = "graph",
          definition = temp)

setGeneric("getVertices", function( object, ...){ standardGeneric( "getVertices")})

temp <- function(object) {
    object@vertices
}

setMethod(f = "getVertices",
          signature = "graph",
          definition = temp)


### Creating validity checks
temp <- function(object) {
    val <- TRUE
    warn <- NULL
    ## check if there are any edges
    if(!(nrow(getEdges(object)) > 0)) {
        val <- FALSE
        warn <- "No defined edges"
    }
    ## check if edges are consistent with vertices
    if(!all(as.vector(getEdges(object)) %in% getVertices(object))) {
        val <- FALSE
        warn <- "Edges defined for not defined vertices. "
    }
    ## return
    if(val) {
        TRUE
    } else {
        warn
    }
}

setValidity(Class = "graph", temp)

### Example
v <- 1:10
e <- cbind(sample(size = 20, x = v, replace = TRUE),
           sample(size = 20, x = v, replace = TRUE))

g1 <- graph(vertices = v, edges = e)
g1

### Setters
setGeneric("getVertices<-", function( object, ...){ standardGeneric( "getVertices<-")})

temp <- function(object, value) {
    object@vertices <- value
    if(validObject(object)) {
        return(object)
    }
}

setMethod(f = "getVertices<-",
          signature = "graph",
          definition = temp)

getVertices(g1)
getVertices(g1) <- 10:1
getVertices(g1)
getVertices(g1) <- 1:5
getVertices(g1)

Inheritance

  • Inheritance in S4 object model, contains
  • Inheriting from S3 object model, setOldClass()
### Cleaning
rm(list = ls())

### Libraries
library(pryr)

### Simple class
dataBlob <- setClass(Class = "dataBlob",
                     slots = list(data = "data.frame"))

### Method "show"
temp <- function(object) {
    `%G%` <- paste
    print("Object of class" %G% class(object))
    print("Number of variables =", dim(object@data)[2])
    print("Number of records =", dim(object@data)[1])
}

setMethod(f = "show",
          signature = "dataBlob",
          definition = temp)

### Example
a <- dataBlob(data = data.frame(id = 1:5, value = rnorm(5)))
a

### Child class
dataBlobInfo <- setClass(Class = "dataBlobInfo",
                         slots = list( info = "character"),
                         contains = "dataBlob")

### Example
b <- dataBlobInfo(data = data.frame(id = 1:5, value = rnorm(5)), info = "Some data")
b

### Inheritance from S3
dataFrame <- function(data, name) {
    structure(list(data = data, name = name), class = "dataFrame")
}

plot.dataFrame <- function(object, ...) {
    plot(object$data, main = object$name, ...)
}

x <- dataFrame(
    data = data.frame(x = seq(-pi, pi, length.out = 100), y = cumsum(rnorm(100))),
    name = "Some random data")

x
plot(x)
plot(x, col = "blue", pch = 4)


setOldClass("dataFrame")

dataFrameS4 <- setClass(Class = "dataFrameS4",
                        slots = list( dataSource = "character"),
                        contains = "dataFrame")

y <- dataFrameS4(x, dataSource = "Data come from somwhere")
y

plot(y, pch = 20, col = "red")

S3Part(y)
attributes(y)

plot.dataFrameS4 <- function(object, ...) {
    plot(S3Part(object), ...)
}

plot(y)

Example

### Cleaning
rm(list = ls())

### Example 1
`+.data.frame` <- function(object1, object2) {
    ## check dimensions
    if(dim(object1)[1] == dim(object2)[1]) {
        return(cbind(object1, object2))
    } else {
        stop("Not compatible dimensions")
    }
}

a <- data.frame(id = 1:5, value = rnorm(5))
a

b <- data.frame(class = sample(letters[1:2], 5, replace = TRUE))
b

a + b

R5 object model (RC)

  • Elements are kept in an environment
  • Model based on the S4 base type
  • Formal definion contains both fields and methods (no generic functions)
  • All classes are children of envRefClass class (certain methods are always available)

Class definition

### Cleaning
rm(list = ls())

### Libraries
library(pryr)

### Example
student <- setRefClass(
    Class = "student",
    fields = list(name = "character",
                  id = "numeric"))

typeof(student)
class(student)
student

s1 <- student(name = "Mike", id = 123)
s1

Automatic getters and setters

### Cleaning
rm(list = ls())

### Libraries
library(pryr)

### Example
student <- setRefClass(
    Class = "student",
    fields = list(name = "character",
                  id = "numeric"))

s1 <- student(name = "Mike", id = 123)
s1

s1$name
s1$id


s1$name <- "John"
s1$name

s1$id <- 321
s1$id

s1$name <- 123

Mutating (clones)

### Cleaning
rm(list = ls())

### Libraries
library(pryr)

### Example
student <- setRefClass(
    Class = "student",
    fields = list(name = "character",
                  id = "numeric"))

s1 <- student(name = "Mike", id = 123)

s1$name
s1$id

s2 <- s1

s2$name
s2$id

s2$name <- "John"
s2$id <- 321

s2$name
s2$id

s1$name
s1$id

e <- attributes(s1)$.xData
ls(envir = e)

attributes(s1)$.xData
attributes(s2)$.xData

### Solution
s3 <- s1$copy()

s3$name
s3$id

s1$name
s1$id

s3$name <- "Mary"
s3$id <- 555

s3$name
s3$id

s1$name
s1$id

### Example
dataStore <- setRefClass(
    Class = "dataStore",
    fields = list(data = "numeric"))

dataStoreInfo <- setRefClass(
    Class = "dataStoreInfo",
    fields = list(data = "dataStore",
                  info = "character"))

a <- dataStoreInfo(
    data = dataStore(data = 0),
    info = "Some data")

a
a$data$data
a$info

aDeep <- a$copy(shallow = FALSE)
aShallow <- a$copy(shallow = TRUE)

aDeep$data$data
aDeep$data$data <- 1
aDeep$data$data
a$data$data

aShallow$data$data
aShallow$data$data <- 1
aShallow$data$data
a$data$data

### Example
strangeClass <- setRefClass(
    Class = "strangeClass",
    fields = list(value = "numeric",
                  store = "environment"))

a <- strangeClass(value = 1, store = new.env())
a

a$value
a$store
a$store$x <- 0
a$store$x

aDeep <- a$copy(shallow = FALSE)
aShallow <- a$copy(shallow = TRUE)

aDeep$value
aDeep$store$x

aShallow$value
aShallow$store$x

aShallow$value <- 5
aShallow$store$x <- 5

aShallow$value
aShallow$store$x

a$value
a$store$x

aDeep$value <- 7
aDeep$store$x <- 7

aDeep$value
aDeep$store$x

a$value
a$store$x

Methods (internal / external)

  • Defined through argument methods or through a method methods
  • By default, defined methods are internal methods
  • We can choose to define external methods with the first argument .self
### Cleaning
rm(list = ls())

### Libraries
library(pryr)

### Example
student <- setRefClass(
    Class = "student",
    fields = list(name = "character",
                  id = "numeric"),
    methods = list(info = function() {
        print(paste("Student", name, "Id", id))
    }))

s1 <- student(name = "Mike", id = 123)
s1$info()

### Example
student <- setRefClass(
    Class = "student",
    fields = list(name = "character",
                  id = "numeric",
                  score = "numeric"))

student$methods(
            info = function() {
            print(paste("Student", name, "Id", id))
        }
        )

student$methods(
            scoreInc = function() { score <<- score + 1},
            scoreDec = function() { score <<- score - 1}
        )

s1 <- student(name = "Mike", id = 123, score = 0)
s1
s1$info()
s1$scoreInc()
s1$scoreInc()
s1$score
s1$scoreDec()
s1$score

### Example
simpleClass <- setRefClass(
    Class = "simpleClass",
    fields = list(value = "numeric"))

simpleClass$methods(
                checkEnc = function() {
                ret <- list(environment())
                last <- function(l) { l[[length(l)]]}
                while(!identical(emptyenv(), last(ret))) {
                    ret <- c(ret, parent.env(last(ret)))
                }
                ret
            }
            )

a <- simpleClass(value = 0)
p <- a$checkEnc()
p[1:3]

attributes(a)$.xData
p[[2]]

### Example
simpleClass <- setRefClass(
    Class = "simpleClass",
    fields = list(value = "numeric"))

simpleClass$methods(
                checkEnc = function() {
                ret <- list(environment())
                last <- function(l) { l[[length(l)]]}
                while(!identical(emptyenv(), last(ret))) {
                    ret <- c(ret, parent.env(last(ret)))
                }
                ret
            }
            )

simpleClass$methods(
                checkEncExt = function(.self) {
                ret <- list(environment())
                last <- function(l) { l[[length(l)]]}
                while(!identical(emptyenv(), last(ret))) {
                    ret <- c(ret, parent.env(last(ret)))
                }
                ret
            }
            )

simpleClass$methods(
                info = function(.self) {
                print(.self$value)
                invisible(.self)
            },
            changeValue = function(v) {
                .self$value <- v
                invisible(.self)
            }
            )

a <- simpleClass(value = 0)
a$info()$changeValue(5)$info()
(a$checkEncExt())[1:3]

e <- attributes(a)$.xData
ls(envir = e)
ls(envir = e, all.names = TRUE)

Inheritance

  • Argument contains
  • Inheritance from R5
  • Inheritance from S3 and S4
### Cleaning
rm(list = ls())

### Exaple
dataStruct <- setRefClass(
    Class = "dataStruct",
    fields = list(data = "data.frame"))

temp <- function() {
    dims <- dim(data)
    print(paste("Object of class", class(.self)))
    print(paste("Number of observations", dims[1]))
    print(paste("Number of variables", dims[2]))
}

dataStruct$methods(info = temp)

a <- dataStruct(data = data.frame(id = 1:5, value = rnorm(5)))
a
a$info()

dataStructInfo <- setRefClass(
    Class = "dataStructInfo",
    fields = list(desc = "character"),
    contains = "dataStruct")

temp <- function() {
    callSuper()
    print(desc)
}

dataStructInfo$methods(info = temp)

b <- dataStructInfo(
    data = data.frame(id = 1:5, value = rnorm(5)),
    desc = "Some data")

b$info()

Validity of an object

  • Method initialize()
  • Own logic through validObject()
### Cleaning
rm(list = ls())

### Example
shortText <- setRefClass(
    Class = "shortText",
    fields = list(text = "character",
                  id = "character"))

temp <- function() {
    print(paste("Text with id", id))
    print(paste("This object says:", text))
}

shortText$methods(printText = temp)

a <- shortText(text = "Short text", id = "text1/45")
a
a$printText()


b <- shortText(
    text = "Short text that is not that short but it'r rather long. ",
    id = "text1/45")
b$printText()

### Initialize method
temp <- function(text = "") {
    id <<- sub("/", "", tempfile(pattern = "", tmpdir = ""))
    n <- nchar(text)
    if(n > 20) {
        warning("Provided text is too long", call. = FALSE)
        text <<- substring(text = text, first = 1L, last = 20L)
    } else {
        text <<- text
    }
}

shortText$methods(initialize = temp)

a <- shortText(text = "Short text")
a$printText()

b <- shortText(text = "Short text that is not that short at all!")
b$printText()

b$text
b$text <- "Short text that is not that short at all!"
b$printText()

### validObject() approach
temp <- function() {
    nchar(text) <= 20L
}

shortText$methods(validObject = temp)

temp <- function(text = "") {
    oldText <- .self$text
    text <<- text
    if(!validObject()) {
        warning("The text provided is too long", call. = FALSE)
        text <<- oldText
    }
    invisible(.self)
}

shortText$methods(setText = temp)

a <- shortText(text = "Short text")
a$printText()
a$setText(text = "Another short text")
a$printText()
a$setText(text = "Another short text that is not that short at all!")
a$printText()

Mixing various object models

### Cleaning
rm(list = ls())

### Libraries
library(dplyr)

### Example
dataWithInfo <- setRefClass(
    Class = "dataWithInfo",
    fields = list(data = "data.frame",
                  info = "character"))

temp <- function() {
    print(paste("Data info:", info))
    print(as_tibble(data))
}

dataWithInfo$methods(showInfo = temp)

temp <- function(...) {
    base::plot(data, ...)
}

dataWithInfo$methods(plot = temp)

plot.dataWithInfo <- function(object, ...) {
    plot(object$data, ...) # object$plot(...)
}

a <- dataWithInfo(
    data = data.frame(
        x = sort(rnorm(100)),
        y = cumsum(rnorm(100))),
    info = "Some data")

a$showInfo()
a$plot()
a$plot(pch = 20, col = "red")
plot(a, pch = 4, col = "blue", cex = 3)

  • Things that should not be used in production code!
### Cleaning
rm(list = ls())

### Create some data
write.table(
    file = "./data.txt",
    x = rnorm(10),
    row.names = FALSE)

### Create S4 from S3
setOldClass(c("file", "connection"))

### Create in R5
.Stream <- setRefClass(
    Class = "Stream",
    fields = list(.con = "file",
                  fileName = "character",
                  chunk = "integer"))

temp <- function() {
    .con <<- file(fileName, "r")
    invisible(.self)
}

.Stream$methods(open = temp)

temp <- function() {
    base::close(.con)
}

.Stream$methods(close = temp)

.ReadLinesStream <- setRefClass(
    Class = "ReadLinesStream",
    contains = "Stream")

temp <- function() {
    readLines(.con, chunk)
}

.ReadLinesStream$methods(stream = temp)

s <- .ReadLinesStream(fileName = "./data.txt", chunk = 3L)
s
s$open()
s$stream()
s$close()
attributes(s)

s$open()
while(length(ret <- s$stream())) {
    print(length(ret))
}
s$close()

ReadLinesStream <- function(fileName, chunk = 1L) {
    .ReadLinesStream(fileName = fileName, chunk = chunk)    
}

setGeneric("open")
setMethod(f = "open",
          signature = "Stream",
          definition = function(con, ...) { con$open()})

setGeneric("close")
setMethod(f = "close",
          signature = "Stream",
          definition = function(con, ...) { con$close()})

setGeneric("stream", function(object, ...){ standardGeneric( "stream")})
setMethod(f = "stream",
          signature = "ReadLinesStream",
          definition = function(object) {object$stream()})

s <- ReadLinesStream(fileName = "./data.txt", chunk = 2L)
s
open(s)
s
stream(s)
close(s)

R6 object model

Creating a basic class

### Cleaning
rm(list = ls())

### Libraries
library(R6)

### Defnition of a simple class
person <- R6Class(classname = "person",
                 public = list(
                     name = NA,
                     hair = NA,
                     initialize = function(name, hair) {
                     self$name <- name
                     self$hair <- hair
                     self$greet()
                 },
                 greet = function() {
                     print(paste("Hi, my name is", self$name, "."))
                 },
                 setHair = function(value) {
                     self$hair <- value
                 }
                 ))

### Tworzenie obiektu
john <- person$new(name = "John", hair = "red")

john$name
john$hair
john$greet()

john$name <- "Jan"
john$name
john$greet()
john$hair <- "blue"
john$hair

john$name <- 123
john$name
john$greet()
john$hair
john$setHair("green")
john$hair

Public elements

### Cleaning
rm(list = ls())

### Libraries
library(R6)

### Simple FIFO queue
fifo <- R6Class(classname = "fifo",
                public = list(
                    ## -----------------------------------------------------------------
                    quu = list(),
                    ## -----------------------------------------------------------------
                    initialize = function(...) {
                    for (e in list(...)) {
                        self$add(e)
                    }
                },
                add = function(e) {
                    self$quu <- c(self$quu, list(e))
                    invisible(self)
                },
                remove = function() {
                    if (length(self$quu) == 0L) {
                        return(NULL)
                    }
                    head <- self$quu[[1]]
                    self$quu <- self$quu[-1]
                    head
                },
                show = function() {
                    for (i in seq_along(self$quu)) {
                        print(paste("Position", i))
                        print(self$quu[[i]])
                    }
                }
                ))

### Example
k <- fifo$new(
              1:4,
              list(pole = TRUE),
              FALSE
          )

k$show()
k$add(data.frame(id = 1:5, value =  rnorm(5)))
k$show()
k$add(TRUE)$add(FALSE)$add(5:1)
k$show()
pop <- k$remove()
pop
k$show()

k$quu <- sin
k$show()

Private elements

### Cleaning
rm(list = ls())

### Simple FIFO queue
fifo <- R6Class(classname = "fifo",
                public = list(

                initialize = function(...) {
                    for (e in list(...)) {
                        self$add(e)
                    }
                },
                add = function(e) {
                    private$quu <- c(private$quu, list(e))
                    invisible(self)
                },
                remove = function() {
                    if (private$length() == 0L) {
                        return(NULL)
                    }
                    head <- private$quu[[1]]
                    private$quu <- private$quu[-1]
                    head
                },
                show = function() {
                    for (i in seq_along(private$quu)) {
                        print(paste("Position", i))
                        print(private$quu[[i]])
                    }
                }
                ),
                private = list(
                quu = list(),
                length = function() {
                    base::length(private$quu)
                }
                )
                )

### Example
k <- fifo$new(
              1:4,
              list(pole = TRUE),
              FALSE
          )

k$show()
k$add(sin)
k$show()
pop <- k$remove()
pop
k$show()

k$length() # fail
k$quu

k$show

Active elements

### Cleaning
rm(list = ls())

### Active bindings
x
makeActiveBinding(sym = "x", fun = function() { rnorm(1) }, env = globalenv())
x

makeActiveBinding(
    sym = "magicPlot",
    env = globalenv(),
    fun = function() {
    x <- sort(rnorm(100))
    y <- cumsum(rnorm(100))
    cs <- runif(n = 3, min = 0, max = 1)
    plot(x, y, pch = 20, col = rgb(cs[1], cs[2], cs[3]))
})

magicPlot

### A class with active elements
crazyString <- R6Class(classname = "crazyString",
                       private = list(
                           s = "CrazyString"
                       ),
                       active = list(
                       x = function(value) {
                           if (missing(value)) {
                               return(private$s)
                           } else {
                               private$s <- value
                           }
                       }
                       ))

### Example
a <- crazyString$new()
a$x
a$x <- "New string"
a$x

a
attributes(a)

print.crazyString <- function(object) {
    print(paste("R6 object of class", class(object)))
    print(object$x)
}

a

R6 object's internal structure

### Cleaning
rm(list = ls())

### Libraries
library(pryr)
library(dplyr)
library(R6)

### Simple class
sc <- R6Class(classname = "sc",
              public = list(

              publicM = function() {
                  e <- list(environment()) # execution env.
                  while(!(identical(last(e), emptyenv()))) {
                      e <- c(e, list(parent.env(last(e))))
                  }
                  e
              },
              callPrivateM = function() {
                  private$privateM()
              }
              ),
              private = list(
                  privateM = function() {
                  e <- list(environment()) # execution env.
                  while(!(identical(last(e), emptyenv()))) {
                      e <- c(e, list(parent.env(last(e))))
                  }
                  e
              }
              ),
              active = list(
                  activeM = function() {
                  e <- list(environment()) # execution env.
                  while(!(identical(last(e), emptyenv()))) {
                      e <- c(e, list(parent.env(last(e))))
                  }
                  e
              }
              ))

a <- sc$new()

### What is an R6 object and what's inside?
typeof(a)
ls(envir = a, all.names = TRUE)
a$.__enclos_env__ # interesting environment
ls(envir = a$.__enclos_env__)
typeof(a$.__enclos_env__$self)
typeof(a$.__enclos_env__$private)

### What is inside the self and private environments
identical(a$.__enclos_env__$self, a) # self --- pointer to the object itself
ls(envir = a$.__enclos_env__$private) # private --- point to the private environment

### Where are all those environments?
parent.env(a$.__enclos_env__$self)
parent.env(a$.__enclos_env__$private)
parent.env(a$.__enclos_env__)

### How do methods find the self and private pointers?
publicPath <- a$publicM()
privatePath <- a$callPrivateM()
activePath <- a$activeM

publicPath[1:3]
privatePath[1:3]
activePath[1:3]
a$.__enclos_env__

Inheritance

  • In the R6 object model, a class may inherit only from an R6 class; no more model mixing!
  • We can always write S3 methods for R6 classes.
### Cleaning
rm(list = ls())

## Simple FIFO queue
qu <-  R6Class( classname = "qu",
               public = list(
                   initialize = function(...) {
                       for(i in list(...)) {
                           self$add(i)
                       }
                   },
                   show = function() {
                       private$quu
                   },
                   add = function(x) {
                       private$quu <- c(private$quu, list(x))
                       invisible(self)
                   },
                   remove = function() {
                       if(private$length() == 0) {
                           return(NULL)
                       }
                       head <- private$quu[[1]]
                       private$quu <- private$quu[-1]
                       head
                   }
                ),
               private = list(
                   quu = list(),
                   length = function() {
                       base::length(private$quu)
                   }
               )
               )

### A FIFO queue with memory
hqu <-  R6Class(classname = "hqu",
                inherit = qu,
                public = list(
                    show = function() {
                        cat("Next item at index: ", private$headIdx + 1, "\n")
                        for(i in seq_along(private$quu)) {
                            cat(i, ": ", private$quu[[i]], "\n")
                        }
                    },
                    remove = function() {
                        if(private$length() - private$headIdx == 0) {
                            return(NULL)
                        }
                        private$headIdx <- private$headIdx + 1
                        private$quu[[private$headIdx]]
                    }
                ),
                private = list(
                    headIdx = 0
                )
                )

a <- hqu$new(1, 3, TRUE, "ala")
a$show()
a$remove()
a$show()

### The FIFO queue with a counter (how to use the super pointer)
cqu <-  R6Class(classname = "cqu",
                inherit = qu,                
                public = list(
                    add = function(x) {
                        private$total <- private$total + 1
                        super$add(x)
                    },
                    getTotal =  function() {
                        private$total
                    }
                ),
                private = list(
                    total = 0
                )
                )

a <- cqu$new(1, 4, TRUE, "ala")
a$show()
a$getTotal()
a$add(5)
a$getTotal()
a$remove()
a$show()
a$getTotal()

ls(envir = a$.__enclos_env__)
ls(envir = a$.__enclos_env__$super)

Elements containing reference type objects

  • Each element in the R6 object may contain a reference type object, e.g., environment, another R6 object.
  • These elements can be shared between instances depending on the initialization type.
### Cleaning
rm(list = ls())

### A simple class to be used as an element of a more complex class.
slotClass <-  R6Class(classname = "slotClass",
                      public = list(
                          x = NULL
                      )
                      )

### The class with shared reference type elements / Initialization is
### outside of initialize() method.
envClass <- R6Class(
    classname = "envClass",
    public = list(
        e = slotClass$new()
    )
)

### Example of sharing
s1 <- envClass$new()
s1$e
s1$e$x <- 123
s1$e$x

s2 <- envClass$new()
s2$e$x
s2$e$x <- 321
s2$e$x
s1$e$x

### The class with reference type elements not being shared /
### Initialization is done with the initialize() method.
envClass2 <- R6Class(
    classname = "envClass2",
    public = list(
        e = NULL,
        initialize = function() {
            self$e <- slotClass$new()
        }
    )
)

### Example / no sharing
s3 <- envClass2$new()
s3$e$x <- 123
s3$e$x

s4 <- envClass2$new()
s4$e$x
s4$e$x <- 3421
s4$e$x
s3$e$x

  • Sharing can be used to store data common to all instances. Also, it is way to implement communitacion between instances.
  • Below is an example of shared data between instances.
### Simple class with shared data
dataModels <- R6Class(classname = "dataModels",
                      public = list(

                      getData = function() {
                          self$data$data
                      },

                      addData = function(data) {
                          self$data$data <- data
                      },

                      addModel = function(model, modelName) {
                          m <- substitute(model)
                          if(modelName %in% names(private$models)) {
                              stop("Model name is alread on the list. Aborting.")
                          } else {
                              private$models[modelName] <- list(m)
                          }
                      },

                      listModels = function() {
                          for(m in seq_along(private$models)) {
                              r <- paste(names(private$models)[m], ":", deparse(private$models[[m]]))
                              print(r)
                          }
                      },

                      evalModel = function(modelName) {
                          if(!(modelName %in% names(private$models))) {
                              stop("Model is not on the list. Aborting.")
                          }
                          eval(private$models[[modelName]], self$data$data)
                      },

                      data = new.env(parent = emptyenv())

                      ),
                      ### -----------------------------------------------------------------
                      private = list(
                          models = list() 
                      )
                      )

### Example
data(cars)

a <- dataModels$new()
a$addData(data = cars)
head(a$getData())
a$addModel(model = lm(dist ~ +1 +speed), modelName = "Linear regression 1")
a$addModel(model = lm(dist ~ -1 +speed), modelName = "Linear regression 2")
a$listModels()
summary(a$evalModel("Linear regression 1"))
summary(a$evalModel("Linear regression 2"))

b <- dataModels$new()
head(b$getData())
b$addModel(model = lm(dist ~ +1 +speed + I(speed^2)), modelName = "Quadratic polynomial")
b$listModels()
summary(b$evalModel("Quadratic polynomial"))

Portable and nonportable classes

  • Nonportable classes allow to rapidly move code from R5 do R6.
  • Don't use it if you don't have to.
### Cleaning
rm(list = ls())

### A typical R5 class with internal methods
r5Class <- setRefClass(
    "r5Class",
    fields = list(
        x = 'ANY'
    ),
    methods = list(
        getX = function() { x},
        setX = function(value){ x <<- value}
    )
)

r5 <- r5Class$new()
r5$setX(123)
r5$getX()

### Reimplementation of the above class in nonportable R6R class
r6ClassNP <- R6Class(
    classname = "r6ClassNP",
    portable = FALSE,
    public = list(
        x = NA,
        getX = function(){ x},
        setX = function(value){ x <<- value}
    )
)

r6 <- r6ClassNP$new()
r6$setX(123)
r6$getX()

  • What is the internal structure of nonportable R6 class?
### Cleaning
rm(list = ls())

### Libraries
library(dplyr)

### Simple nonportable class
r6ClassNP <- R6Class(
    classname = "r6ClassNP",
    portable = FALSE,
    public = list(

    showPublicPath = function() {
        e <- list( environment())
        while(!(identical(last(e), emptyenv()))) {
            e <- c(e, list(parent.env(last(e))))
        }
        e
    },

    showPrivatePath = function() {
        private$privatePath()
    }

    ),
    ## -----------------------------------------------------------------
    private = list(
        privatePath = function() {
        e <- list( environment())
        while(!(identical(last(e), emptyenv()))) {
            e <- c(e, list(parent.env(last(e))))
        }
        e
    }
    )
)

s1 <- r6ClassNP$new()
p1 <- s1$showPublicPath()
p2 <- s1$showPrivatePath()

p1[1:4]
p2[1:4]
ls(envir = s1)
s1$private

Modifying existing classes

  • Similar to R5 class, it is possible to modify the R6 class with the set() method.
### Cleaning
rm(list = ls())

### A simple unlocked class
klasa <- R6Class(
    classname = "klasa",
    public = list(
        x = 1,
        getX = function() { self$x }
    )
)

### Append a method
klasa
klasa$set( "public", "setX", function( value){ self$x <- value})
klasa

### Overwrite a method
klasa$set("public", "getX", function() { cat("x is ", self$x, "\n")})
klasa$set("public", "getX", function() { cat("x is ", self$x, "\n")}, overwrite = TRUE)

### A simple locked class
klasa <- R6Class(
    classname = "klasa",
    lock_class = TRUE,
    public = list(
        x = 1,
        getX = function(){ self$x}
    )
)

### Modifying 
klasa$set("public", "setX", function(value) { self$x <- value})
klasa$unlock()
klasa$set("public", "setX", function(value) { self$x <- value})
klasa$lock()
klasa

NEXT Cloning objects

  • An object in the R6 model is an environment so it must be cloned to have a separate copy.
  • One way of doing it is to use the clone() method (deep of shallow). This method works only for R6 models.
  • To clone arbitrary reference type elements a deep_clone() method must be defined. This is left to the programmer.

An example for the R6 model.

### Cleaning
rm(list = ls())

### A simple class to be used with the more complex class. 
pole <- R6Class(
    classname = "pole",
    public = list(
        x = 1
    )
)

### A more complex class with elements being R6 objects
klon <- R6Class(
    classname = "klon",
    public = list(
        a = NULL,
        b = NULL,
        initialize = function(){
        self$a <- pole$new()
        self$b <- 10L
    }
    )
)

### Example
k <- klon$new()
k$a
k$b

### Shallow clone
kShallow <- k$clone()
kShallow
kShallow$a
kShallow$b

kShallow$b <- 321L
kShallow$b
k$b

kShallow$a$x <- 321L
kShallow$a$x
k$a$x


### Deep clone
kDeep <- k$clone(deep = TRUE)
kDeep$a$x
kDeep$b

kDeep$b <- 555L
kDeep$b
k$b

kDeep$a$x <- 555L
kDeep$a$x
k$a$x

To clone arbitrary reference type objects a deep_clone() method needs to be defined. Following example shows how to do it.

### Cleaning
rm(list = ls())

### The following class has a specialized deep_clone method that
### clones one element but not the other. Creating such clones is
### another way to share elements between instances.
tk <- R6Class(
    classname = "tk",
    public = list(
        a = NULL,
        b = NULL,
        v = 1,
    initialize = function() {
        self$a <- new.env(parent = emptyenv())
        self$b <- new.env(parent = emptyenv())
        self$a$x <- 1
        self$b$x <- 1
    }
    ),
    private = list(
        deep_clone = function(name, value){
        if(name == "a") {
            list2env(as.list.environment(value, all.names = TRUE))
        } else {
            value
        }
    }
    )
)

### Example
s0 <- tk$new()

s0$a
s0$a$x
s0$b
s0$b$x

### Deep clone
s1 <- s0$clone( deep = TRUE)

ls( envir = s1$a)
s1$a$x
s1$b$x
s1$v

### Introducing changes
s1$a$x <- 123
s1$b$x <- 123
s1$v <- 123

### Checking changes in the original instance
s0$a$x
s0$b$x
s0$v

Some additional topics concerning functions

Elements of functions

  • Any object of class function has three elements
    • body body()
    • formals formals()
    • enclosing environment environment()
### Cleaning
rm(list = ls())

### Libraries
library(pryr)

### Simple function
f <- function(x = "", k) {
    for(i in 1:k) {
        print(x)
    }
}

typeof(f)
class(f)

### Elements of a function
body(f)
typeof(body(f))

formals(f)
typeof(formals(f))

environment(f)
typeof(environment(f))

### Modifying a function
formals(f) <- alist(x = "No argument given", k = 1)
formals(f)
f()

body(f) <- quote({for(s in 1:k) { print(paste(s, x))}})
f()
f(k = 5)

  • Knowing functions' elements we can do interesting analysis. The following example concerns package base.
### Cleaning
rm(list = ls())

### A list of all function from package base
o <- mget(ls("package:base"), inherits = TRUE)
fs <- Filter(f = is.function, x = o)
fs[1:2]
length(fs)

### A list of all primitive functions from package base
fsPrimitive <- Filter(f = function(x){ is.function(x) & is.primitive(x)}, x = o)
length(fsPrimitive)

### A list of all interpreted functions from package base
fsNotPrimitive <- Filter(
    f = function(x){ is.function(x) & !is.primitive(x)},
    x = o)
length(fsNotPrimitive)

### Analyzing arguments numbers
w <- unlist(
    lapply(
        X = fsNotPrimitive,
        FUN = function(x) { length(formals(x))}
    ))
names(w) <- NULL

wCounts <- table(w)
wCounts

barplot(height = wCounts,
        names.arg = names(wCounts),
        horiz = T,
        las = 1,
        xlim = c(0, 400))

grid()

### What is the function with the largest number of arguments
ind <- unlist(
    lapply(
        X = o,
        FUN = function(x){
        is.function(x) & !is.primitive(x)}
    )
)
names(ind) <- NULL
ls("package:base")[ind][which.max(w)]

Calling functions and creating calls

  • Typical functions do.call(), call(), eval()
### Cleaning
rm(list = ls())

### A standard example
y <- rnorm(10)
mean(y)

### Evaluate a call with a given list of arguments
do.call(mean, list(x = y)) 

### Create a call instance without dispatching
r <- call(name = "mean", y) 
typeof(r)
class(r)
eval(r)

### Create a call instance with dispatching
t <- as.call(list(mean, x = y)) 
typeof(t)
class(t)

### Example: a function taking many functions with styles creating a graph
multiPlot <- function(domain, fs, styles, len = 50){
    ## x values
    x <- seq(min(domain), max(domain), length.out = len)
    ## y values
    y <- list()
    for(k in 1:length(fs)){
        y <- c(y, list(fs[[k]](x)))
    }
    ## creating a graph
    plot(0, 0, col = "white",
         ylim = range(y), xlab = "", ylab = "")
    for(k in 1:length(fs)){
        arg <- c(
            list(x = x),
            list(y = y[[k]]),
            styles[[k]],
            list(xlab = "", ylab = "")
        )
        par(new = TRUE)
        do.call(plot, arg)
    }
}


multiPlot(c(0, 2 * pi),
          fs = list(sin, cos, tan),
          styles = list(
              list(col = "red", type = "h", lwd = 4),
              list(col = "blue", type = "l", lwd = 2),
              list(col = "green", type = "o", pch = 5, lty = "dashed")
          )
          )

Lazy evaluation

  • Lazy evaluation is a method to postpone evaluation till the value is required, in particular copying. The mechanism increases efficiency.
### Cleaning
rm(list = ls())

### Function using all arguments
f1 <- function(a, b){
    print(a)
    print(nchar(b))
}

f1("ala", "john")
f1("ala", print("john"))

### Function not using all arguments
f2 <- function(a, b){
    print(a)
}

f2("ala", "john")
f2("ala", print("john"))

### Forcing evaluation
f3 <- function(x = stop("Evaluated")){
    123
}

f3()

f4 <- function(x = stop("Evaluated")){
    force(x)
    123
}

f4()

### Default values
f0 <- function(x = 0){
    print(x)
}

f0()
f0(18)

f1 <- function(a = 1, b = 2 * a){
    c(a, b)
}

f1()

f2 <- function(a = 1, b = 2 * x){
    x <- 2 * a
    c(a, x, b)
}

x <- 1000
f2() # all evaluated in the execution env. 

f3 <- function(a = 1, b = 2 * x){
    print(b)
    x <- 2 * a
    c(a, x, b)
}

rm(x)
ls()
x
f3()
x <- 100
f3() # bleeding

### where are the default values evaluated
rm(list = ls())
z <- 1
f <- function(x = ls()){
    a <- 123
    x
}
f()
f(ls())

Some additional tricks

Missing arguments

### Cleaning
rm(list = ls())

### Libraries
library(R6)
library(dplyr)

### Typical example
f <- function(a, b) {
    c(missing(a), missing(b))
}

f(1, 2)
f(a = 1)
f(b = 10)
f()

### Typical use for active elements in the R6 class
dataFrame <- R6Class(classname = "dataFrame",
                     public = list(
                         initialize = function(data) {
                         private$dataValue <- data
                     }
                     ),
                     private = list(
                         dataValue = NA
                     ),
                     active = list(
                         data = function(data) {
                         if(missing(data)) {
                             return(private$dataValue)
                         } else {
                             private$dataValue <- data
                         }
                     }
                     ))

### Example
data(cars)
a <- dataFrame$new(cars)
a$data
a$data <- a$data %>% filter(speed < quantile(speed, .5))
a$data

Replacement functions

  • Functions with a specific name foo<-

    ### Cleaning
    rm(list = ls())
    
    ### A typical
    last <- function(x) {
        x[length(x)]
    }
    
    `last<-` <- function(x, value) {
        x[length(x)] <- value
        x
    }
    
    x <- sample(1:5)
    x
    last(x)
    last(x) <- 555
    x
    

Invisible returns

  • Typical function invisible()
### Cleaning
rm(list = ls())

### Libraries
library(R6)

### A simple function
f <- function(x) {
    print(x^2)
    invisible(list(value = x, result = x^2))
}

f(4)
x <- f(4)
x

### Typical application 
newList <- R6Class(classname = "newList",
                   public = list(

                   initialize = function(...) {
                       for(e in list(...)) {
                           self$elementAdd(e)
                       }
                   },

                   elementAdd = function(e) {
                       private$data <- c(private$data, list(e))
                       invisible(self)
                   },

                   elementShow = function() {
                       private$data
                   }
                   ),
                   private = list(
                       data = list()
                   ))

a <- newList$new(1, TRUE, sin, list(T, F))
a$elementShow()
a$elementAdd(666)$elementAdd(TRUE)$elementAdd(FALSE)
a$elementShow()

Cleaning on exit

  • Function on.exit()
### Cleaning
rm(list = ls())

### Function cleans before exiting
listDir <- function(directory) {
    wd <- setwd(directory)
    on.exit(setwd(wd))
    list.files()
}

### Example
getwd()
listDir("/home/michael")
getwd()

Non-standard evaluation

Capturing arguments

  • Typical functions: substitute(), quote(), deparse(), parse(), expression()
  • Base types: language, expression

    ### Cleaning
    rm(list = ls())
    
    ### Libraries
    library(pryr)
    
    ### -----------------------------------------------------------------
    
    ### Basic behavior of substitute() / quote()
    quote(x + y)
    typeof(quote(x + y))
    
    substitute(x + y)
    typeof(substitute(x + y))
    
    ### substitute() returns different types depending on the argument
    whatRet <- function(x) {
        ret <- c(typeof(x), mode(x), class(x))
        names(ret) <- c("base", "mode", "class")
        ret
    }
    
    whatRet(substitute(2)) # atom
    whatRet(substitute(x)) # symbol / name
    whatRet(substitute(f(x))) # call
    
    ### Using substitute() to substitute
    substitute(x + y)
    substitute(x + y, env = list(x = 1))
    whatRet(substitute(x + y, env = list(x = 1)))
    
    substitute(x + y, env = list(x = 1 + 5)) # substituted objects are evaluated, sometimes
    substitute(x + y, env = list(x = 1, y = 1:10)) # here not
    substitute(x + y, env = list(x = "ala ma kota", y = 1)) # substitutions are lexical
    
    ### A more complicated substitution
    ne <- new.env(parent = emptyenv())
    ne$y <- 1
    delayedAssign("x", cos(1:10), assign.env = ne)
    substitute(x + y, env = ne)
    
    ### -----------------------------------------------------------------
    
    ### Typical use of deparse() and parse()
    deparse(quote(x + y))
    sub("y", "1", deparse(quote(x + y))) # substitution through a string
    
    parse(text = "x + y")
    whatRet(parse(text = "x + y"))
    e <- parse(text = "x + y")
    length(e)
    e[[1]]
    whatRet(e[[1]])
    
    e <- parse(text = "x <- rnorm(1) \n y <- x + sin(rnorm(1))")
    length(e)
    e[[1]]
    e[[2]]
    eval(e[[1]])
    x
    eval(e[[2]])
    y
    
    

Capuring and evaluating

  • Typical function: eval()
  • Control what and where is evaluated.
### Cleaning
rm(list = ls())

### -----------------------------------------------------------------
### Basics

### Eval in a context of a list
eval(quote(x), envir = list(x = 10))
typeof(eval(quote(x), envir = list(x = 10)))

### Eval in the context of a data.frame / tibble
data(cars)
eval(quote(mean(dist)), cars)
eval(quote(mean(dist)), as_tibble(cars))

### Eval in the context of an environment
e <- new.env(parent = emptyenv())
e$x <- 10
eval(quote(x), envir = e)

### More examples
e$x <- rnorm(20)
eval(quote(mean(x)), envir = e) # fail
eval(quote(base::mean(x)), envir = e) # fail
e$mean <- base::mean
eval(quote(mean(x)), envir = e)

### Same expression but different contexts
e <- quote(f(x, pch = pchTemp))
e

eval(e, envir = list(
            x = cumsum(rnorm(100)),
            pchTemp = 20,
            f = plot
        ))

eval(e, envir = list(
            x = rnorm(10),
            pchTemp = 1,
            f = barplot
        ))

### -----------------------------------------------------------------
### Combining substitute() and eval() for non-standard argument evaluation

### Sample data frame
d <- tibble(id = 1:10, value = rnorm(10), class = sample(LETTERS[1:2], replace = TRUE, size = 10))
d

simpleFilter <- function(data, cond) {
    condUnEval <- substitute(cond)
    print(condUnEval)
    print(ls())
    ind <- eval(condUnEval, data)
    print(ind)
    data[ind, ]
}

simpleFilter(d, class == "A")
simpleFilter(d, class == "A" & value < 0)

### Some problems
y <- 4L
data <- 4L
cond <- 4L
condUnEval <- 4L

simpleFilter(d, id == 4)
simpleFilter(d, id == y) 
simpleFilter(d, id == data) 
simpleFilter(d, id == cond) 
simpleFilter(d, id == condUnEval) 

### A better version
simpleFilter <- function(data, cond) {
    condUnEval <- substitute(cond)
    print(condUnEval)
    print(ls())
    ind <- eval(condUnEval, data, enclos = parent.frame())
    print(ind)
    data[ind, ]
}

simpleFilter(d, id == 4)
simpleFilter(d, id == y) 
simpleFilter(d, id == data) 
simpleFilter(d, id == cond) 
simpleFilter(d, id == condUnEval)

### -----------------------------------------------------------------
### Example

### A simple function running commands on a data
execute <- function(data, command) {
    comSub <- substitute(command)
    eval(comSub, list(. = data))
}

### Sample data frame
d <- data.frame(
    id = 1:10,
    value = rnorm(10),
    class = sample(LETTERS[1:2], size = 10, replace = TRUE))
d

### Examples
execute(d, .[.$class == "A", ])
execute(d, mean(.[.$class == "A", "value"]))

NSE and non-interactive calls

  • The basic limitation with NSE is with the non-interactive use (calls from another functions).
### Cleaning
rm(list = ls())

### Libraries
library(pryr)
library(dplyr)

### Simple filtering function
simpleFilter <- function(data, cond) {
    condUnEval <- substitute(cond)
    ind <- eval(condUnEval, data, enclos = parent.frame())
    data[ind, ]
}

### A failed attempt at the plot / filter function
plotFilter <- function(data, cond) {
    plot(simpleFilter(data, cond))
}

### Sample data frame
d <- tibble(x = sort(rnorm(100)), y = cumsum(rnorm(100)))
d

### Technical error / first level computations
plotFilter(d, x > 0)
traceback()

### Logical error / data bleeding
x <- 1
par(mfrow = c(2, 1))
plotFilter(d, x > 0)
plot(d)

### Can we capture the condition on the first level?
plotFilter <- function(data, cond) {
    condSub <- substitute(cond)
    plot(simpleFilter(data, condSub))
}

### Example
plotFilter(d, x > 0)
traceback()

### The above problem is with the nested substitute!
r <- substitute(substitute(2 + 3))
eval(r)
eval(eval(r))

### -----------------------------------------------------------------
### Solution 1. Create separate functions for different uses.

simpleFilter <- function(data, cond) {
    condUnEval <- substitute(cond)
    ind <- eval(condUnEval, data, enclos = parent.frame())
    data[ind, ]
}

simpleFilterQ <- function(data, cond) {
    ind <- eval(cond, data, enclos = parent.frame())
    data[ind, ]
}

plotFilter <- function(data, cond) {
    condSub <- substitute(cond)
    plot(simpleFilterQ(data, condSub))
}

d <- tibble(x = sort(rnorm(100)), y = cumsum(rnorm(100)))
simpleFilter(d, x > 0)
simpleFilter(d, x < 0)
plotFilter(d, x > 0)
plotFilter(d, x < 0)

### -----------------------------------------------------------------
### Solution 2. Create a function with a separate argument toggling between different uses.

simpleFilter <- function(data, cond, interactive = TRUE) {
    if(interactive) {
        cond <- substitute(cond)
    }
    ind <- eval(cond, data, enclos = parent.frame())
    data[ind, ]
}

plotFilter <- function(data, cond) {
    condSub <- substitute(cond)
    plot(simpleFilter(data, condSub, interactive = FALSE))
}

d <- tibble(x = sort(rnorm(100)), y = cumsum(rnorm(100)))
simpleFilter(d, x > 0)
simpleFilter(d, x < 0)
plotFilter(d, x > 0)
plotFilter(d, x < 0)

### -----------------------------------------------------------------
### Solution 3. Let the functions checks the call.

simpleFilter <- function(data, cond) {
    if(identical(globalenv(), parent.frame())) {
        cond <- substitute(cond)
    }
    ind <- eval(cond, data, enclos = parent.frame())
    data[ind, ]
}

plotFilter <- function(data, cond) {
    condSub <- substitute(cond)
    plot(simpleFilter(data, condSub))
}

d <- tibble(x = sort(rnorm(100)), y = cumsum(rnorm(100)))
simpleFilter(d, x > 0)
simpleFilter(d, x < 0)
plotFilter(d, x > 0)
plotFilter(d, x < 0)

Expressions and computations on the language

Structure of an expression

  • Each expression may contain
    • atoms (constants),
    • symbols (aka names)
    • calls
    • pairlists
### Cleaning
rm(list = ls())

### Libraries
library(pryr)

### Standard AST
ast(y <- 3 * x)
ast(g(a, b, c, d, e))
ast(`<-`(x, 3))
ast(x[4] <- 5)
ast(a <- b <- c <- d)

### -----------------------------------------------------------------
### Atoms / constants
ast(123)
ast(TRUE)
ast("mike")

### -----------------------------------------------------------------
### Symbols / names
ast(x)
ast(setOldClass)
ast(`<-`)

### Testing for symbols and creating symbols
is.symbol(quote(x))
is.name(quote(x))
is.symbol(quote(x^2))

as.symbol("x")
is.symbol(as.symbol("x"))

as.symbol("some name")
is.symbol(as.symbol("some name"))

### -----------------------------------------------------------------
### Calls
ast(f())
ast(a + b)
ast((a + b))
ast(a[[5]])
ast(r[4])

### The base type of a call is language
a <- quote(x <- 2)
typeof(a)
mode(a)
class(a)

###Testing for calls
is.call(quote(x <- 2))
is.call(quote(3 + 5))
is.call(quote(4))
is.call(quote(function(x) { x^2 }))

### -----------------------------------------------------------------
### Pairlists
ast(function(x = 1, y) { x^2 + y})
ast(function(x = 1, y = 2 * x) { x^2 + y})

### Structure of a pairlist
f <- function(x = 10, y) {
    x * y
}

typeof(formals(f))
formals(f)
formals(f) <- alist(x = , y = 20)
f

### -----------------------------------------------------------------
### Example
get("plot")

newGet <- function(name) {
    eval(as.symbol(name))
}

newGet("plot")

Structure of calls and modifications

  • Typical functions $<-, [[<-, [<-
### Cleaning
rm(list = ls())

### Libraries
library(pryr)

### -----------------------------------------------------------------
### Structure of a call

### Typical structore of a call
ast(f(x = 1, y = 2))
w1 <- quote(f(x = 1, y = 2))
w1
typeof(w1)
mode(w1)
w2 <- quote(g(4, 20))
mode(w2)
w3 <- quote(g(4, y = 20))
mode(w3)


### Simple analysis of a call
length(w1)
names(w1)

length(w2)
names(w2)

length(w3)
names(w3)

w1[[1]]
w2[[1]]
w3[[1]]

is.symbol(w1[[1]])
is.symbol(w2[[1]])
is.symbol(w3[[1]])

w1[[2]]
w1[[3]]

w1$x
w1$y

### Non-standard call with the first element being another call
f <- function(x) {
    print(x)
    invisible(
        function(y) {
        print(y)
    }
    )
}

f(1)(2)
ast(f(1)(2))
w <- quote(f(1)(2))
w
length(w)
w[[1]]
mode(w[[1]])
is.call(w[[1]])
w[[2]]
length(w[[1]])
w[[1]][[1]]
w[[1]][[2]]

ast(print(sin(pi)))
w <- quote(print(sin(pi)))
w
length(w)
w[[1]]
w[[2]]
length(w[[2]])
w[[2]][[1]]
w[[2]][[2]]

### Example: simple call analysis
callStructure <- function(cc, level = 1) {
    if(!is.call(cc)) {
        stop("Not a call. Aborting.")
    } else {
        ell <- length(cc)
        for(i in 1:ell) {
            if(is.call(cc[[i]])) {
                callStructure(cc[[i]], level + 1)
            } else {
                print(paste("(", level, ") Not a call:", deparse(cc[[i]])))
            }
        }
    }
}

w <- quote(print(sin(pi)))
callStructure(cc = w)

w <- quote(f(1)(2))
callStructure(cc = w)

### -----------------------------------------------------------------
### Modifying calls

### Two functions to switch between
numericFun <- function(x) {
    x^2
}

stringFun <- function(x) {
    nchar(x)
}

### Modifying calls
w <- quote(foo(x = "This is a test"))
w <- quote(foo(x = 12))

switch(mode(w$x),
       "numeric" = {w[[1]] <- quote(numericFun)},
       "character" = {w[[1]] <- quote(stringFun)}
       )

w
eval(w)

### Example: another way to use call modificatons
listFiles <- function(p = getwd(), ext){
    `%T%` <- paste0
    patt <- "[.]" %T% ext %T% "+"
    w <- quote(list.files(pattern = pattToChange, path = pathToChange))
    ## modificaitons
    w$pattern <- patt
    w$path <- p
    ## evaluating a call
    fs <- eval(w)
    fs <- file.info(fs)[, c("size", "isdir")]
    names(fs) <- c("size", "directory")
    fs
}

listFiles(ext = "html")
listFiles(ext = "tx")

### Removing parts of a call
w <- quote(f(a = 4, 6, x = 12))
length(w)
w[1]
w[2]
w[3]
w[4]

w[-2]
w[-3]
w[-4]

missingFunc <- function(x, y, z){
    state <- any(c(missing(x), missing(y), missing(z)))
    if(state){
        stop("Something's missing!")
    } else {
        print("All OK. ")
    }
}

missingFunc(x = 1, y = 2, z = 3)
missingFunc(x = 1, y = 2)

w <- quote(missingFunc(x = 1, y = 2, z = 3))
w
eval(w)
eval(w[-2])
eval(w[c(-3, -4)])
eval(w[-1]) # removing the top call / fail

### Weird stuff :)
f1 <- function(f, a, b){
    print(paste("(f1) ", a, b))
}

f2 <- function(x, y){
    print(paste("(f2) ", x, y))
}

f1(1, 56, 2)
f2(3, 4)

w <- quote(f1(f2, 8, 9))
w

eval(w)
eval(w[-1]) # removing the top call / works!

Creating calls

  • Typical functions: do.call(), call(), as.call()
### Creates a call and evaluates
do.call(mean, list(x = y)) 

### Creates a call (base type language) with no dispatching
r <- call(name = "mean", y) 
typeof(r)
class(r)
eval(r)

### Creates a call (base type language) with dispatching
t <- as.call(list(mean, x = y)) 
typeof(t)
class(t)

### Creating and evaluating calls
eval(call("+", 2, 3))
call("+", 2, x) # fail
call("+", 2, quote(x))
eval(call("+", 2, quote(x)), list(x = 10))
eval(call("print", call("nchar", "The fox is brown")))
eval(as.call(list(quote(sample), quote(1:10))))

### A simple version of do.call()
doCall <- function(fun, args){
    f <- substitute(fun)
    cl <- as.call(c(list(f), args))
    print(cl)
    eval(cl, envir = parent.frame())
}

doCall(sin, list(1:10))
doCall(plot, list(x = 1:100, y = cumsum(rnorm(100)), xlab = "", ylab = ""))

Capturing calls

  • Typical functions: sys.call(), match.call()
### Cleaning
rm(list = ls())

### Libraries
library(pryr)

### Different ways to capture calls
f <- function(a = 1, b = 1, envir = parent.frame()) {
    list(
        system = sys.call(),
        match = match.call()
    )
}

f()
f(1)
f(b = 2, a = 4)
f(b = 2, a = 4, envir = globalenv())

### Different ways to capture ...
f <- function(...) {
    list(
        match = match.call(expand.dots = TRUE),
        match = match.call(expand.dots = FALSE)
    )
}

f()
f(a = 4, b = 5)

### A more detailed look at call caputer / filling in arguments names
match.call(plot, quote(plot(data.frame(x = rnorm(10), y = rnorm(10)))))
match.call(setOldClass, quote(setOldClass(file)))
match.call(match.call, quote(match.call(sin, quote(sin(pi)))))
match.call(match.call, quote(match.call(data.frame, quote(data.frame(x = 1:5)))))
eval(match.call(match.call, quote(match.call(data.frame, quote(data.frame(x = 1:5))))))
eval(eval(match.call(match.call, quote(match.call(data.frame, quote(data.frame(x = 1:5)))))))

### The same application  based on a single call
w <- quote(setOldClass(file))
w[[1]]
eval(w[[1]])
match.call(eval(w[[1]]), w)

w <- quote(plot(sort(rnorm(20)), cumsum(rnorm(20)), pch = 20, col = "red"))
w[[1]]
eval(w[[1]])
match.call(eval(w[[1]]), w)

### Example / a function to modify calls
changeCall <- function(cl, args, envir = parent.frame()) {
    ## test if the arguments are correct
    if(!is.call(cl) | !is.list(args)) {
        stop("Wrong call or wrong list of arguments. Aborting." )
    }
    ## test if a list of arguments is named
    argsNames <- names(args)
    if(is.null(argsNames)) {
        argsNames <- rep("", length(args))
    }
    if(any(argsNames == "")) {
        stop("Only namded lists are accaptable. Aborting.")
    }
    ## filling in arguments' names
    w <- eval(cl[[1]], envir = envir)
    w <- match.call(w, cl)
    ## modifying call
    for(n in argsNames) {
        w[[n]] <- args[[n]]
    }
    ## returning
    w
}

g <- function(...){}
changeCall(quote(g(a = 3, b = 5)), list(b = quote(1:10)))
changeCall(quote(g(a = 3, b = 5)), list(a = 123, b = quote(1:10)))
changeCall(quote(g(a = 3, b = 5)), list(a = 123, b = quote(1:10), ala = 888))

Call stack

  • All calls are put on a call stack.
  • Function sys.nframe() returns a call's index on a stack
  • Function sys.frame() returns a pointer to an environment related to a given call based on the stack index. Using this with sys.nframe() let you traverse the whole stack.
### Cleaning
rm(list = ls())

### Stack indices 
sys.nframe() # global env. 

g <- function() {
    print(sys.nframe())
}

g()

f <-  function() {
    print(sys.nframe())
    g()
}

f()

### Connecting with sys.frame()
sys.frame(which = 0) # default / global env.
g <- function() {
    `%T%` <- paste
    n <- sys.nframe()
    for(k in n:0) {
        cat("(" %T% as.character(k) %T% "): ")
        print(sys.frame(which = k))
    }
}

g()

f <-  function() {
    g()
}

f()

### Pay attention that call stack has nothing to do with the envs tree. Both functions have the global env. as the enclosing env. 

environment(f)
environment(g)

### Example: a function traversing the stack and returning calls
callList <- function() {
    n <- sys.nframe()
    print(paste("Number of call on stack:", n))
    for(k in n:1) {
        cat(paste("(", k, "):"))
        print(sys.call(which = k))
    }
}

g <- function() {
    callList()
}

g()

f <- function(k) {
    if(k < 0) {
        return()
    }
    print("-------------------")
    callList()
    f(k - 1)
}

f(5)

Pairlist

  • Creating pairlist in advance as a part of call creation is a useful tool. The following example show how to treat formulas as mathematical formulas.
### Cleaning
rm(list = ls())

### Example: function for creating functions
makeFunction <- function(args, body, envir = parent.frame()) {
    args <- as.pairlist(args)
    eval(call("function", args, body), envir = envir)
}

### Example of use
f1 <- makeFunction(
    alist(x = ),
    quote({ mean(x)})
)

f1(1:10)

f2 <- makeFunction(
    alist(x = 0),
    quote({ mean(x)})
)

f2()
f2(rnorm(10))

f3 <- makeFunction(
    args = alist(... = ),
    quote({ list(...)})
)

f3(2, TRUE, data.frame(id = 1:5, value = rnorm(5)))

### Simple NSE with pairlist
mathPlot <- function(ff, var = "x",
                     xlim = c(0, 1), n = 100,
                     envir = parent.frame(), ...){
    `%T%` <- paste0
    ## Tworzenie listy arguemntow
    args <- parse(text = "alist(" %T% var %T% " = )" )
    ## Tworzenie funkcji do narysowania
    f <- makeFunction(eval(args), substitute(ff), envir)
    x <- seq(min(xlim), max(xlim), length.out = n)
    y <- f(x)
    plot(x, y, ...)
}

mathPlot(sin(x), xlim = c(-pi, pi), type = "l")
mathPlot(log(s) * sin(4 * s), var = "s", xlim = c(1, exp(1)), type = "l")

Parsing i deparsing

  • Parsing and deparsing transfers expressions to strings and back
  • Base type: expression
### Clean
rm(list = ls())

### -----------------------------------------------------------------
### Basic behavior

### deparse()
a <- quote(cumsum(rnorm(100)))
a
b <- deparse(a)
b

### parse()
parse(text = b)
sub(pattern = "cumsum", replacement = "mean", x = b)
parse(text = sub(pattern = "cumsum", replacement = "mean", x = b))
eval(parse(text = sub(pattern = "cumsum", replacement = "mean", x = b)))

### parse() with many elements
a <- parse(text = "x <- sort(rnorm(100)); y <- x^2 + rnorm(100); plot(x, y, pch = 20)")
a
a[[1]]
typeof(a[[1]])

for(e in a){
    eval(e)
}

x
y

### -----------------------------------------------------------------
### Examples

### A simple version of source()
simpleSource <- function(file, envir = new.env(parent = globalenv())){
    ## technical checks
    stopifnot(file.exists(file))
    stopifnot(is.environment(envir))
    ## reading in a script
    lines <- readLines(file, warn = FALSE)
    expres <- parse(text = lines)
    ## check if there are any expressions
    n <- length(expres)
    if(n == 0L){
        return(invisible())
    }
    ## evaluating
    for(i in 1:(n-1)){
        eval(expres[[i]], envir = envir)
    }
    ## returning the value of last evaluation
    invisible(eval(expres[[n]], envir = envir))
}

simpleSource(file = "./test.R")

### Simple version of source() with simple checking
simpleSourceControl <- function(file, envir = new.env(parent = globalenv())){
    ## technical checks
    stopifnot(file.exists(file))
    stopifnot(is.environment(envir))
    ## reading in script
    lines <- readLines(file, warn = FALSE)
    expres <- parse(text = lines)
    ## check if there are any expressions
    n <- length(expres)
    if(n == 0L){
        return(invisible())
    }
    ## checks on the existence of symbol definitions
    condExists <- TRUE
    for(i in 1:n){
        if(exists(deparse(expres[[i]][[1]]))){
            cat("    OK |")
        } else {
            cat("NOT OK |")
            cat(deparse(expres[[i]][[1]]))
            condExists <- FALSE
        }
        cat(" \n")
    }
    ## evaluating
    if(condExists){
        for(i in 1:(n-1)){
            eval(expres[[i]], envir = envir)
        }
        ## return the value of last evaluation
        invisible(eval(expres[[n]], envir = envir))
    } else {
        return(NULL)
    }
}

simpleSourceControl(file = "./test.R")
simpleSourceControl(file = "./test_bad.R")

AST analysis

  • The best way to think and do the AST analysis is the recursion.
  • Start with language objects. For expression objects just use loops.
### Cleaning
rm(list = ls())

### Traversing AST / searching for a given symbol
checkForSymbol <- function(lan, sym) {
    ## if atom => stop
    if(is.atomic(lan)) {
        return(FALSE)
    }
    ## if symbol => check if the required => stop
    if(is.symbol(lan)) {
        return(identical(lan, as.symbol(sym)))
    }
    ## if call or pairlist => loop + recursion
    if(is.call(lan) || is.pairlist(x)) {
        for(i in seq_along(lan)) {
            if(checkForSymbol(lan[[i]], sym)) {
                return(TRUE)
            }
        }
        return(FALSE)
    }
    ## if something else => abort
    stop("Unknow type. Aborting.")
}

checkForSymbol(
    quote(mean(rnorm(1:10))),
    "TRUE"
)

checkForSymbol(
    quote(mean(rnorm(1:10))),
    "mean"
)

parse(text = readLines(con = "./test.R"))
w <- parse(text = readLines(con = "./test.R"))

for(e in w) {
    if(checkForSymbol(lan = e, sym = "plot")) {
        print(e)
    }
}

for(e in w) {
    if(checkForSymbol(lan = e, sym = "rgb")) {
        print(e)
    }
}

Author: Michał Ramsza

Created: 2021-05-13 Thu 20:59

Validate