Zaawansowane programowanie w R

Spis treści

Typy bazowe

Podstawowe informacje o typach bazowych: od najprostszych do S4.

typeof(TRUE)
class(TRUE)

typeof( 2L)
class( 2L)

typeof( 2)
class( 2)

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

typeof( "ala ma kota")
class( "ala ma kota")

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

typeof( emptyenv())
class( emptyenv())

typeof( function(){ print( " hello")})
class( function(){ print( " hello")})

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

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

Podstawowe informacje o funkcjach

Od pustej do przyjmującej funkcje i ....

f1 <- function(){}

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

f3 <- function( x){
   x^2
 }

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

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

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

f6( seq( -pi, pi, length.out = 1000),
   function( x){ sin( x^2) * cos( x^2)},
   col = "red", fg = "yellow", lwd = 2, type = "l")

Środowiska

Konstrukcja

  • tablica przypisań (tablica hashująca)
  • wskaźnik na rodzica (środowisko)
Symbol Wartość
x 2
y 4
f closure

Podstawowe środowiska

Podstawowe środowiska

  • puste
  • bazowe
  • globalne

i odpowiadające im funkcje

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

Drzewo środowisk i widoczność symboli

Typowe funkcje

  • search()
  • searchpaths()
  • parent.env()
parent.env( emptyenv())
parent.env( baseenv())

search()
searchpaths()

parent.env( parent.env( globalenv()))

Zadanie Napisać funkcję przeszukującą środowiska zarówno w wersji standardowej i rekurencyjnej.

### Typowa implementacja
listEnvs1 <- function( e = list( globalenv())){
  while( !identical( e[[length( e)]], emptyenv())){
    e <- c( e, parent.env( e[[ length( e)]]))
  }
  e
}

listEnvs2 <- function( e = list( globalenv())){
  ## warunek stopu
  if( identical( emptyenv(), e[[length( e)]])){
    return( e)
  }
  ## rekurencja
  e <- c( e, parent.env( e[[length( e)]]))
  listEnvs2( e)
}

test <- listEnvs1()
test <- listEnvs2()

ls()
ls( all.names = TRUE)
ls( envir = baseenv(), all.names = TRUE)
x
plot()
qqq

plot <- function( x, f = identity, ...){
  base::plot( x, f( x), ...)
}

plot( seq( -pi, pi, length.out = 100), sin, col = "red", pch = 20)

x <- ts( cumsum( rnorm( 100)), start = c( 2000, 1), frequency = 12)
x
plot.ts( x)
y <- data.frame( x = sort( rnorm( 100))) %>% mutate( y = 1 + 2 * x + rnorm( 100))
y
class( y)
plot( y)
rm( plot)

graphics:::plot.data.frame( y)
listEnvs1( list( environment( graphics:::plot.data.frame)))

Szukanie symboli

Typowe funkcje

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

exists( x = "plot", envir = emptyenv())
exists( x = "f5", envir = parent.env( globalenv()))
exists( x = "plot", inherits = TRUE)
exists( x = "plot", inherits = FALSE)
exists( x = "plot", inherits = FALSE, envir = baseenv())

plot <- 123
rm( plot)
where( "plot", env = globalenv())

Zadanie Napisać funkcję szukającą danego symbolu uwzględniając jego typ i z możliwością znalezienia wszystkich symboli (również zasłanianych). Napisać w wersji standardowej i rekurencyjnej.

myWhere <- function( name, type, e = list( globalenv())){
  ret <- list()
  while( !identical( emptyenv(), e[[length( e)]])){
    if( exists( name, envir = e[[length( e)]], inherits = FALSE) ){
      if( identical( type, typeof( get( name, envir = e[[length( e)]])))){
	ret <- c( ret, e[[length( e)]])
    }
  }
    e <- c( e, parent.env( e[[length( e)]]))    
  }
  ret
}


myWhere( "plot", "double")
myWhere( "plot", "closure")

Praca ze środowiskami

  • Tworzenie new.env(), attr() dla atrybutu name
  • Usuwanie rm(), gc(), gcinfo()
  • Dodawanie elementów quote(), eval(), $, assign()
  • Listowanie elemntów i ich wykorzystanie ls, $, get(), [[
  • Kopiowanie i klonowanie środowiska as.environment(), as.list()
### Tworzenie nowego środowiska
e <- new.env()
e
parent.env( e)
attr( e, "name") <- "mojeNoweŚrodowisko"
e
e$x <- data.frame( id = 1:10^3, value = rnorm( 10^3))

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

search()

### Usuwanie środowiska
ls()
head( e$x)
object.size( e$x)
object.size( e)
typeof( e)
rm( e)
ls()

gc()
gcinfo( verbose = TRUE)

e2$x <- data.frame( id = 1:10^6, value = rnorm( 10^6))
rm( e2)
x <- 2

e0 <- new.env( parent = emptyenv())
e1 <- new.env( parent = e0)
e0test <- parent.env( e1)
identical( e0, e0test)
parent.env( parent.env( e1))

rm( e0, e0test, e1)

### Dodawanie elementów do środowiska
ls()
x
y <- 123
ls()

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

rm( x, y)
ls()

rm( x)
eval( quote( x <- 2), envir = e)
x
ls( envir = e)
e$x

rm( e)

e <- new.env( parent = emptyenv())
attr( e, "name") <- "test"
e
parent.env( e)
eval( quote( x <- 222), envir = e)

ast( x <- 2)
e$x <- 2
e$`<-` <- `<-`
eval( quote( x), envir = e)
ls( envir = e)
e$x

e[["x"]] <- 321
e$x
e$y
e[["y"]] <- 456
e$y

x <- list()
x[["ala"]] <- TRUE
x

assign( x = "z", value = 999, envir = e)
ls( envir = e)
e$z

e["z"]

get( x = "z", envir = e)
get( x = "<-", envir = e)
e$data.frame <- data.frame
get( x = "data.frame", envir = e)

rm( e)

### Czyszczenie
rm( list = ls())

### Tworzenie środowiska
e <- new.env()
attr( e, "name") <- "test"
e

### Dodawanie elementów
e$x <- 0
e$x

### Kopiowanie środowiska
eCopy <- e
e
eCopy

eCopy$x
eCopy$x <- 1
eCopy$x
e$x

### Klonowanie środowiska
eClone <- as.environment( as.list( e))
eClone$x
eClone$x <- 2
eClone$x
eCopy$x
e$x

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

Zadanie Napisać dwie funkcje, których zadaniem jest przyjmowanie wektora liczb i zwracanie jego permutacji. Jedna funkcja jako strukturę danych wykorzystuje wektor a druga środowisko. Wykonać pętlę implementującą \( n \)-krotne złożenie takich funkcji i zmierzyć czas wykonania dla obu implementacji.

### Sprzątanie
rm( list = ls())

### Funkcja standardowa
f1 <- function( x){
  y <- x
  y
}

time1Start <- Sys.time()
x <- 1:10^5
for( i in 1:10^6){
  x <- f1( x)
}
time1End <- Sys.time()
time1End - time1Start

### Funkcja wykorzystująca środowisko
f2 <- function( e){
  e$x <- e$x
}

time1Start <- Sys.time()
e <- new.env()
e$x <- 1:10^5
for( i in 1:10^6){
  f2( e)
}
time1End <- Sys.time()
time1End - time1Start

  • Proste manipulowanie ścieżką przeszukiwania attach(), detach()
### Sprzątanie
rm( list = ls())

### Przesuwanie środowisk
config <- list( os = "linux", "type" = "ubuntu")
config

search()
attach( config, name = "config")
search()
ls( envir = parent.env( globalenv()))
rm( list = ls())
ls()
os
type
detach( name = "config")
search()

Zadanie Napisać funkcję, która zamapiętuję ile razy została wywołana ale ma również możliwość zresetowania takiego licznika, przy czym przy resecie nie zostawia za sobą śmieci.

### Sprzątanie
rm( list = ls())

### Funkcja zapamiętująca ile razy jest wywołana
remember <- function( reset = FALSE){
  `%G%` <- paste0
  ## sprawdzanie czy istnieje środowisko z licznikiem
  if( !("remeberEnv" %in% search()) ){
    attach( what = list( rememberCounter = 0), name = "remeberEnv", pos = 2)
  }
  e <- as.environment( "remeberEnv")
  e$rememberCounter <- e$rememberCounter + 1
  print( "Number of calls = " %G% as.character( e$rememberCounter))
  if( reset){
    detach( name = "remeberEnv")
  }
}

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

Funkcje

Konstrukcja fukcji

  • typ bazowy
  • argumenty (ang. formals) formals()
  • ciało funkcji (ang. body) body()
  • domknięcie funkcji (ang. closure) environment()
### Czyszczenie
rm( list = ls())

### Prosta funkcja
f <- function( s = "default"){
  print( s)
}

typeof( f)
class( f)

formals( f)
body( f)
environment( f)

formals( f) <- alist( x = 1)
body( f) <- quote( x^2)
f
f( 2)

Środowiska związane z funkcją, static scoping. Zastosowania i problemy.

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

Przykład Sprawdzanie środowiska execution i jego rodzica. Sprawdzanie środowiska enclosing. Niezdefiniowane symbole w ramach funkcji i ich wyszukiwanie.

### Czyszczenie
rm(list = ls())

### Sprawdzanie środowiska execution
f <- function(){
  environment()
}

f()

### Środowisko execution jest zawsze tworzone na nowo
g <- function(){
  if( !exists( "x", inherits = FALSE)){
    x <- "nie istnieje"
  } else {
    x <- "istnieje"
  }
  x
}

g()

### Rodzic środowiska execution
f <- function(){
  e <- environment()
  list( "execution" = e, "parent of execution" = parent.env( e))
}

f()

### Środowisko enclosing
environment( f)

### Testowanie
rm(list = ls())
e <- new.env()
parent.env( e)

eval( quote( f <- function(){
  e <- environment()
  list( "execution" = e, "parent of execution" = parent.env( e))
}
), envir = e)
f
e$f
e$f()
e
a <- e$f()
a[[1]]
parent.env( a[[2]])

### Przykład
rm(list = ls())

f <- function(){
  x
}

f()
x <- "ala ma kota"
f()

g <- function(){
  f()
}

g()
environment( g)
x <- "ala nie ma kota"
g()

Przykład Definiowanie symboli z wewnątrz funkcji w środowisku enclosing przy pomocy $ i quote() / eval().

### Sprzątanie
rm(list = ls())

### Przykład
x <- 1

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

f()
x <- 2
f()

g <- function(){
  x <- 123
  print( x)
}

g()
x

h <- function(){
  e <- parent.env( environment())
  n <- 10
  e$x <- rnorm( n)
}

x
n <- 1
h()
x

h1 <- function(){
  e <- parent.env( environment())
  n <- 1
  eval( quote( x <- rnorm( n)), envir = e)
}

n <- 10
h1()
x

n <- 1
h()
x
h1()
x

Przykład Funkcja definiująca podany symbol w podanym środowisku.

### Czyszczenie
rm(list = ls())

### Środowisko
e <- new.env()

### Funkcja definiująca symbol w podanym środowisku
defSymbol <- function( sym, val, env){
  env$sym <- val
}

ls()
defSymbol( x, 1, globalenv())
ls()

defSymbol <- function( sym, val, env){
  env[[sym]] <- val
}

ls()
defSymbol( "x", 123, globalenv())
ls()
x

Przykład Funkcja zwracająca środowisko ze zdefiniowanymi zmiennymi (wstęp do modelu obiektowego R6).

### Czyszczenie
rm(list = ls())

### Funkcja
f <- function( n){
  e <- new.env( parent = emptyenv())
  e$x <- rnorm( 1)
  e
}

x <- f()
x$x

y <- f()
y$x

x
y

g <- function( n){
  zmiennaLokalna <- TRUE
  e <- new.env()
  e$x <- rnorm( 1)
  e
}

x <- g()
x$x
parent.env( x)$zmiennaLokalna
parent.env( x)$zmiennaLokalna <- FALSE
parent.env( parent.env( x))

Przykład Funkcje zwracające funkcje i retrospektywna redefinicja w środowisku execution.

### Czyszczenie
rm(list = ls())

### Function factory
f <- function( x){
  print( environment())
  function( y){ y + x + z}
}

h2 <- f( 2)
h2( 1)
z <- 100
h2( 1)

f <- function( x){
  z <- 10
  function( y){ y + x + z}
}

h3 <- f( 3)
rm( z)
h3( 1)
z <- 10000
ls( envir = environment( h3))

environment( h3)$z <- -100
h3( 0)
h3

x <- 999
h3( 0)
get( "x", envir = environment( h3))
environment( h3)$x <- -1000
h3( 0)

### Fukcja, która pamięta ile razy była wywołana
createRemeber <- function(){
  if( !( exists( "x", inherits = FALSE))){
    x <- 0
  }
  print( x)
  function(){
    e <- parent.env( environment())
    e$x <- e$x + 1
    print( paste0( "Liczba wywołań = ", as.character( e$x)))
  }
}

f <- createRemeber()
f()
environment( f)$x
x

Przykład Zmiana środowiska enclosing i wykrywanie środowiska calling parent.frame().

### Czyszczenie
rm(list = ls())

### Przykład
f <- function(){
  print( x)
}

x <- "ala"
f()
environment( f)
environment( f) <- baseenv()
f()

where( "print")

e <- new.env()
e$x <- "ala nie ma kota"
environment( f) <- globalenv()
f()
environment( f) <- e
f()

environment( plot)

plot

Przykład Co robi funkcja <<-? Funkcje zwracające środowiska execution, enclosing i calling.

### Czyszczenie
rm(list = ls())

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

f()
environment( f) <- baseenv()
f()

e <- new.env()

g <- function(){
  x <<- TRUE
  list( "exe" = e, "enc" = parent.env( e), "cal" = parent.frame())
}

g()
x
environment( g) <- e
g()
x
e$x

Przykład Problemy z gubieniem zmiennych i pseudo-dynamic scoping.

### Czyszczenie
rm(list = ls())

### Przykład
f <- function(){
  print( x)
}

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


g <- function(){
  x <- "ala ma psa"
  fDS()
}

g()
x
fDS()
x <- "kot siedzie na płocie"
fDS()

Przykład Implementacja rekusji w oparciu o środowisko.

Przykład Napisać prosty obiekt w pseudo R6 (pola + metody) na przykładzie grafu nieskierowanego.

### Czyszczenie
rm(list = ls())

### Konstruktor
graph <- function( v, e){
  env <- new.env( parent = globalenv())
  ## Tworzenie pól
  env$vertices <- v
  env$edges <- e
  ## Tworzenie metod
  env$getVertices <- function(){ vertices}
  environment( env$getVertices) <- env
  env$getEdges <- function(){ edges}
  environment( env$getEdges) <- env
  env$pos <- function( s, x){
    n <- length( s)
    (1:n)[s == x]
  }
  env$plot <- function( ...){
    n <- length( vertices)
    x <- rnorm( n)
    y <- rnorm( n)
    base::plot( x, y, ...)
    m <- dim( edges)[1]
    for( i in 1:m){
      x1 <- x[pos( vertices, edges[i,1])]
      y1 <- y[pos( vertices, edges[i,1])]
      x2 <- x[pos( vertices, edges[i,2])]
      y2 <- y[pos( vertices, edges[i,2])]
      lines( c( x1, x2), c( y1, y2))
    }
  }
  environment( env$plot) <- env
  env
}


### Wykorzystanie
v <- 1:20
e <- cbind( sample( v, 15), sample( v, 15))

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

g1$edges
g1$vertices

g1$getVertices()
g1$getEdges()
g1$plot(pch = 20, cex = 2, col = "blue")

Modele obiektowe

Wprowadzenie

  • S3
  • S4
  • R5 (RC)
  • R6

Model obiektowy S3

  • Nie ma formalnej definicji klasy
  • System oparty o funkcje generyczne (generics)
  • Generics dispatchują metody zgodnie z klasą obiektu.

Wykorzystywane typowe funkcje

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

Przykład wprowadzający: obiekty różnych klas w modelu S3.

rm(list = ls())

### Wektor
x <- cumsum( rnorm( 100))
x
typeof( x)
class( x)
plot( x)

### Szereg czasowy
y <- ts( cumsum( rnorm( 5 * 12)), frequency = 12, start = c( 2000, 1))
y
typeof( y)
class( y)
plot( y)

### Ramka danych
data( cars)
head( cars)
str( cars)
typeof( cars)
class( cars)
plot( cars)

### Model liniowy
z <- lm( dist ~ +1 +speed, data = cars)
summary( z)
typeof( z)
class( z)
par( mfrow = c( 2,2))
plot( z)

Weryfikacja czy dany obiekt jest obiektem w modelu S3.

rm(list = ls())

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

d
dd

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

ddd <- setClass( "test", slots = list( value = "numeric"))( value = 5)
is.object( ddd)
attributes( ddd)
attributes( dd)
typeof( ddd)

isS4( ddd)
isS4( d)

d4<- setRefClass( "test1")()

library( R6)

objectTest <- function( o){
  is.object( o) & !isS4( o) & !is.R6( o)
}

objectTest( d)
objectTest( dd)
objectTest( ddd)
objectTest( dddd)

library( pryr)

otype( d)
otype( dd)
otype( ddd)
otype( d4)

Definicja prostej klasy w modelu S3

rm(list = ls())

graph <- function( v, e){
  structure( list( vertices = v, edges = e), class = "graph")
}

g1 <- graph( 1, 1)
otype( g1)
is.object( g1)

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

d1 <- dataframeinfo( id = 1:5, value = rnorm( 5), info = "Dane z eksperymentu 1")
d1
print( d1)
print.default( d1)
print.data.frame( d1)
class( d1)
otype( d1)
is.object( d1)

Weryfikacja czy dana funkcja jest generic

rm(list = ls())

plot
data.frame

sum
list

ftype( plot)
ftype( data.frame)
ftype( sum)
ftype( list)
ftype( show)
body( show)

Metody w modelu S3. Podpinanie pod istniejący generic

plot.<nazwa klasy>

### Czyszczenie
rm(list = ls())

### Biblioteki
library( pryr)

### Definicja klasy
graph <- function( v, e){
  structure( list( vertices = v, edges = e), class = "graph")
}

### Wykorzystanie
v <- 1:10
e <- cbind( sample( v, 7), sample( v, 7))
g1 <- graph(v = v, e = e)
g1

print
ftype( print)

print.graph <- function( o){
  `%G%` <- paste0
  cat( "\n\nObject graph with " %G%
       as.character( length( o$vertices)) %G%
       " vertices. \nUse getter to get a list of nodes and edges.")
  cat( "\n\n")
}

g1
print.default( g1)
print( g1)

methods( print)
methods( plot)

### Przykład: metoda barplot dla ramek danych
body( barplot)
ftype( barplot)

methods( barplot)

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

barplot.data.frame <- function( o, colName, ...){
  graphics::barplot( o[[colName]], ...)
}
barplot( 
barplot( d, colName = "value",
	col = "red", density = 20, angle = 45, border = "red")

Tworzenie genericów i podpinanie metod

### Czyszczenie
rm(list = ls())

### Przykładowa klasa
graph <- function( v, e){
  structure( list( vertices = v, edges = e), class = "graph")
}

### Wykorzystanie
v <- 1:10
e <- cbind( sample( v, 7), sample( v, 7))
g1 <- graph(v = v, e = e)
g1

print.graph <- function( o){
  `%G%` <- paste0
  cat( "\nObject graph with " %G%
       as.character( length( o$vertices)) %G%
       " vertices. \nUse getter to get a list of nodes and edges.")
  cat( "\n\n")
}

g1

getVertices <- function( obj, ...){ UseMethod( "getVertices")}
ftype( getVertices)

getVertices.default <- function( obj, ...){
  cat( "\nMethod getVertices() is used with class graph\n\n")
}

getVertices.graph <- function( obj, ...){
  obj$vertices
}

getEdges <- function( obj, ...){ UseMethod( "getEdges")}
ftype( getEdges)

getEdges.default <- function( obj, ...){
  cat( "\nMethod getEdges() is used with class graph\n\n")
}

getEdges.graph <- function( obj, ...){
  obj$edges
}


getVertices( list( 3))
getVertices( g1)

getEdges( list( 3))
getEdges( g1)

Dziedziczenie

### Czyszczenie
rm(list = ls())

### Biblioteki
library( dplyr)

### Przykładowe dziedziczenie
m <- matrix( 1:4, 2, 2)
m
otype( m)
class( m)
plot( m)
methods( plot)

### Przykład
dataFrameInfo <- function( info, ...){
  ret <- data.frame( ...)
  structure( ret, class = c( "dataFrameInfo", "data.frame"), info = info)
}

d1 <- dataFrameInfo( info = "Przykładowe dane", id = 1:5, value = rnorm( 5))
otype( d1)
class( d1)

print.dataFrameInfo <- function( obj){
  `%G%` <- paste0
  cat( "\n" %G% " Data info: " %G% attributes( obj)$info %G% "\n\n")
  print( as_tibble( obj))
}

d1

plot( d1, pch = 2, cex = 2)

Przykładowa implementacja grafu nieskierowanego jako klasy w modelu S3

### Czyszczenie
rm(list = ls())

### Przykładowa klasa
graph <- function( v, e){
  structure( list( vertices = v, edges = e), class = "graph")
}

print.graph <- function( o){
  `%G%` <- paste0
  cat( "\nObject graph with " %G%
       as.character( length( o$vertices)) %G%
       " vertices. \nUse getter to get a list of nodes and edges.")
  cat( "\n\n")
}

getVertices <- function( obj, ...){ UseMethod( "getVertices")}
ftype( getVertices)

getVertices.default <- function( obj, ...){
  cat( "\nMethod getVertices() is used with class graph\n\n")
}

getVertices.graph <- function( obj, ...){
  obj$vertices
}

getEdges <- function( obj, ...){ UseMethod( "getEdges")}
ftype( getEdges)

getEdges.default <- function( obj, ...){
  cat( "\nMethod getEdges() is used with class graph\n\n")
}

getEdges.graph <- function( obj, ...){
  obj$edges
}

plot.graph <- function( o, ...){
  ## przypisanie punktów wierzchołkom
  vx <- rnorm( length( o$vertices))
  vy <- rnorm( length( o$vertices))

  ## tworzenie wykresu
  plot( vx, vy, ...)

  ## rysowanie krawędzi
  getX <- function( i, v, vx){
    vx[v == i]
  }
  getY <- function( i, v, vy){
    vy[v == i]
  }

  for( j in 1:dim( o$edges)[1]){
    lines(
      c( getX( o$edges[j,1], o$vertices, vx), getX( o$edges[j,2], o$vertices, vx)),
      c( getY( o$edges[j,1], o$vertices, vy), getY( o$edges[j,2], o$vertices, vy)))
  }

}

`[.graph` <- function( o, i){
  ## selekcja wierzchołków
  tempVerts <- o$vertices[i]
  ## selekcja krawędzi
  ind <- apply( X = o$edges, MARGIN = 1, FUN = function( r){ all( r %in% tempVerts)})
  tempEdges <- o$edges[ ind, ]
  ## tworzenie obiektu
  graph( v = tempVerts, e = tempEdges)
}


### Wykorzystanie
v <- 1:10
e <- cbind( sample( v, 7), sample( v, 7))
g1 <- graph(v = v, e = e)
g1

getVertices( list( 3))
getVertices( g1)

getEdges( list( 3))
getEdges( g1)

g2 <- g1[4:10]
getVertices( g2)
getEdges( g2)

plot( g1, pch = 20, cex =2)
plot( g1[4:10], pch = 20, cex =2)

### Przykład motywujący
g3 <- graph( v = c( "ala", "ma", "kota"), e = 1:10)
g3
getEdges( g3)

Implementacja dodawania stringów

### Biblioteki
library( pryr)
rm(list = ls())

### Niestety, metoda `+` jest primitive generic.
ftype( `+`)

### Dla primitive generic nie można definiować metod dla tzw. atomic
### types. Można jednak zdefiniować własną klasę, jak poniżej.
char <- function( s){
    structure( s, class = c( "char", "character"))
}

`+.char` <- function( e1, e2){
    paste0( e1, e2)
}

print.char <- function( s){
    class( s) <- "character"
    print( s)
}


s1 <- char( "ala")
s1
s2 <- char( "bela")
s2

s1 + s2

Model obiektowy S4

  • Historycznie jest to następca modelu S3
  • Formalna definicja klasy (tylko pola)
  • System oparty o funkcje generyczne (generics). System równoległy do systemu S3.
  • Obiekt w modelu S4 jest oparty o typ bazowy S4.

Definicja klasy, konstruktor

Typowe funkcje: setClass(), new(), getClass()

### Czyszczenie
rm(list = ls())

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

### Tworzenie obiektu
v <- 1:10
e <- cbind( sample( v), sample( v))
g1 <- graph( vertices = 1:10, edges = e)
g1

g2 <- new( Class = "graph", vertices = 1:10, edges = e)
g2

getClass( Class = "graph")

g1@vertices
g1@getNodes( g1)

Dostęp do pól, automatyczne gettery i settry, walidacja typu pól

Typowe funkcje: @, slot()

### Czyszczenie
rm(list = ls())

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

### Tworzenie obiektu
v <- 1:10
e <- cbind( sample( v), sample( v))
g1 <- graph( vertices = 1:10, edges = e)
g1

### Automatyczne gettery
g1@vertices
g1@edges

g1@"vertices"
g1@"edges"

slot( g1, "vertices")
slot( g1, "edges")

### Automatyczne settery i walidacja typu
g1@vertices <- 1:100
g1@vertices <- "ala ma kota"

g2 <- graph( vertices = v, edges = e)
g2 <- graph( vertices = "ala ma kota", edges = e)

### Przykładowe obejście testu na typ pola
attributes( g1)
attributes( g1)$vertices <- "ala ma kota"
g1@vertices
g1


Metody. Jak sprawdzić czy funkcja jest generyczna w modelu S4

Typowe funkcje: show(), ftype(), isGeneric(), hasMethod(), methods(), showMethods()

### Czyszczenie
rm(list = ls())

### Sprawdzenie czy funkcja jest generic w modelu S4
show
isGeneric( "show")
ftype( "show") # fail

### Sprawdzanie metod
showMethods( "show")
class( show)
typeof( show)
methods( generic.function = show)
methods( class = "standardGeneric")
methods( class = "standardGeneric")

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

isGeneric( "graph")
graph
class( graph)
methods( class = "classGeneratorFunction")
attributes( graph)

methods( class = "graph")

Jak przypiąć metodę do istniejącej funkcji generycznej

  • Typowe funkcje: setMethod()
  • Pierwszy argument zawsze musi nazywać się object
### Czyszczenie
rm(list = ls())

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

### Przykładowy obiekt
v <- 1:10
e1 <- cbind( sample( v, 5), sample( v, 5))
e2 <- cbind( sample( v, 10), sample( v, 10))
g1 <- graph( vertices = v, edges = e1)
g2 <- graph( vertices = v, edges = e2)

### Sprawdzania czy funkcja jest generyczna
body( show)

### Dodawanie metody show dla klasy graph
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 <- dim( object@edges)[1]
  if( ne > 0 & ne <=6 ){
    ## tutaj wyświetlam wszystko
    for( i in 1:ne){
      cat( as.character( object@edges[i,1]) %G% " -- " %G% as.character( object@edges[i,2]) %G% "\n")
    }
  } else {
    cat( "Use getEdges() to get all edges. \n")
  }
  cat( " \n\n")
}

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

g1
g2
show( g1)
show( g2)
methods( "show")
methods( class = "graph")

Jak tworzyć własne funkcje generyczne

Typowe funkcje: setGeneric(), standardGeneric()

### Czyszczenie
rm(list = ls())

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

### Przykładowy obiekt
v <- 1:10
e1 <- cbind( sample( v, 5), sample( v, 5))
e2 <- cbind( sample( v, 10), sample( v, 10))
g1 <- graph( vertices = v, edges = e1)
g2 <- graph( vertices = v, edges = e2)

### Sprawdzania czy funkcja jest generyczna
body( show)

### Dodawanie metody show dla klasy graph
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 <- dim( object@edges)[1]
  if( ne > 0 & ne <=6 ){
    ## tutaj wyświetlam wszystko
    for( i in 1:ne){
      cat( as.character( object@edges[i,1]) %G% " -- " %G% as.character( object@edges[i,2]) %G% "\n")
    }
  } else {
    cat( "Use getEdges() to get all edges. \n")
  }
  cat( " \n\n")
}

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

### Tworzenie generica
setGeneric( "getEdges", function( object, ...){ standardGeneric( "getEdges")})

isGeneric( "getEdges")
typeof( getEdges)
class( getEdges)
body( getEdges)

### Tworzenie metody dla generica getEdges
temp <- function( object){
  object@edges
}

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

methods( class = "graph")
g1
g2
getEdges( object = g2)

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

### Tworzenie metody dla generica getVertices
temp <- function( object){
  object@vertices
}

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


methods( class = "graph")
g1
g2
getEdges( object = g2)
getVertices( object = g2)

Dopisanie metody S4 do tzw. primitive generics

### Czyszczenie
rm(list = ls())

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

### Przykładowy obiekt
v <- 1:10
e1 <- cbind( sample( v, 5), sample( v, 5))
e2 <- cbind( sample( v, 10), sample( v, 10))
g1 <- graph( vertices = v, edges = e1)
g2 <- graph( vertices = v, edges = e2)

### Sprawdzania czy funkcja jest generyczna
body( show)

### Dodawanie metody show dla klasy graph
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 <- dim( object@edges)[1]
  if( ne > 0 & ne <=6 ){
    ## tutaj wyświetlam wszystko
    for( i in 1:ne){
      cat( as.character( object@edges[i,1]) %G% " -- " %G% as.character( object@edges[i,2]) %G% "\n")
    }
  } else {
    cat( "Use getEdges() to get all edges. \n")
  }
  cat( " \n\n")
}

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

### Tworzenie generica
setGeneric( "getEdges", function( object, ...){ standardGeneric( "getEdges")})

isGeneric( "getEdges")
typeof( getEdges)
class( getEdges)
body( getEdges)

### Tworzenie metody dla generica getEdges
temp <- function( object){
  object@edges
}

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

methods( class = "graph")
g1
g2
getEdges( object = g2)

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

### Tworzenie metody dla generica getVertices
temp <- function( object){
  object@vertices
}

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


methods( class = "graph")
g1
g2
getEdges( object = g2)
getVertices( object = g2)

### Tworzenie metody [ dla klasy graph
temp <- function( x, i, drop = "missing"){
  ## selekcja listy wierzchołków
  nv <- x@vertices[i]
  ## selekcja krawędzi
  checkEdges <- function( e, v){ all( e %in% v)}
  id <- apply( X = x@edges, MARGIN = 1, FUN = checkEdges, v = nv)
  ne <- x@edges[id,]
  ## tworzenie nowego obiektu
  graph( vertices = nv, edges = ne)
}

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

methods( class = "graph")

g1
g3 <- g1[1:6]
g3

g2
g4 <- g2[1:5]
g4

Walidacja poprawności tworzonego obiektu

Typowe funkcje: validObject(), setValidity()

### Czyszczenie
rm(list = ls())

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

### Przykładowy obiekt
v <- 1:10
e1 <- cbind( sample( v, 5), sample( v, 5))
e2 <- cbind( sample( v, 10), sample( v, 10))
g1 <- graph( vertices = v, edges = e1)
g2 <- graph( vertices = v, edges = e2)

### Sprawdzania czy funkcja jest generyczna
body( show)

### Dodawanie metody show dla klasy graph
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 <- dim( object@edges)[1]
  if( ne > 0 & ne <=6 ){
    ## tutaj wyświetlam wszystko
    for( i in 1:ne){
      cat( as.character( object@edges[i,1]) %G% " -- " %G% as.character( object@edges[i,2]) %G% "\n")
    }
  } else {
    cat( "Use getEdges() to get all edges. \n")
  }
  cat( " \n\n")
}

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

### Tworzenie generica
setGeneric( "getEdges", function( object, ...){ standardGeneric( "getEdges")})

isGeneric( "getEdges")
typeof( getEdges)
class( getEdges)
body( getEdges)

### Tworzenie metody dla generica getEdges
temp <- function( object){
  object@edges
}

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

methods( class = "graph")
g1
g2
getEdges( object = g2)

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

### Tworzenie metody dla generica getVertices
temp <- function( object){
  object@vertices
}

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


methods( class = "graph")
g1
g2
getEdges( object = g2)
getVertices( object = g2)

### Tworzenie metody [ dla klasy graph
temp <- function( x, i, drop = "missing"){
  ## selekcja listy wierzchołków
  nv <- x@vertices[i]
  ## selekcja krawędzi
  checkEdges <- function( e, v){ all( e %in% v)}
  id <- apply( X = x@edges, MARGIN = 1, FUN = checkEdges, v = nv)
  ne <- x@edges[id,]
  ## tworzenie nowego obiektu
  graph( vertices = nv, edges = ne)
}

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

methods( class = "graph")

g1
g3 <- g1[1:6]
g3

g2
g4 <- g2[1:5]
g4

### Dodatkowe sprawdzanie spójności klasy graph
v <- 1:10
e3 <- cbind(
  sample( 1:100, 5),
  sample( 1:100, 5)
)
e3

g5 <- graph( vertices = v, edges = e3)
g5

temp <- function( object){
  ## wartości domyślne
  val <- TRUE
  warn <- NULL
  ## sprawdzanie czy są zdefiniowane krawędzie
  if( !(nrow( getEdges( object)) > 0) ){
    val = FALSE
    warn <- "No defined edges"
  }
  ## sprawdanie czy krawędzie zdefiniowane o istniejące wierzchołki
  if( !all( as.vector( getEdges( object)) %in% getVertices( object)) ){
    val = FALSE
    warn <- "Edges defined with non defined vertices"
  }

  ## zwrotka
  if( val){
    TRUE
  } else {
    warn
  }

}

### Przypinanie do metody validObject
setValidity( Class = "graph", temp)

### Testowanie walidacji klasy
v <- 1:10
e3 <- cbind(
  sample( v, 5),
  sample( v, 5)
)
e3

g5 <- graph( vertices = v, edges = e3)
g5

validObject( g5)

e3 <- cbind(
  sample( 1:100, 5),
  sample( 1:100, 5)
)

attributes( g5)$edges <- e3

g5

validObject( g5)

Mutacje

Konstrukcja funkcji postaci foo<-()

### Czyszczenie
rm(list = ls())

### Biblioteki
library(pryr)

### Przykłady wprowadzające
x <- 1:5
x
x[1]
`[`( x, 1)

x[1] <- 9
x

address( x)
x[1] <- 123
address( x)


x <- `[<-`( x, 1, 555)
x

### Przykład implementacji mutacji
### Czyszczenie
rm(list = ls())

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

### Dodawanie metody show dla klasy graph
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 <- dim( object@edges)[1]
    if( ne > 0 & ne <=6 ){
	## tutaj wyświetlam wszystko
	for( i in 1:ne){
	    cat( as.character( object@edges[i,1]) %G% " -- " %G% as.character( object@edges[i,2]) %G% "\n")
	}
    } else {
	cat( "Use getEdges() to get all edges. \n")
    }
    cat( " \n\n")
}

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

### Tworzenie generica
setGeneric( "getEdges", function( object, ...){ standardGeneric( "getEdges")})

### Tworzenie metody dla generica getEdges
temp <- function( object){
    object@edges
}

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

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

### Tworzenie metody dla generica getVertices
temp <- function( object){
    object@vertices
}

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


### Tworzenie metody [ dla klasy graph
temp <- function( x, i, drop = "missing"){
    ## selekcja listy wierzchołków
    nv <- x@vertices[i]
    ## selekcja krawędzi
    checkEdges <- function( e, v){ all( e %in% v)}
    id <- apply( X = x@edges, MARGIN = 1, FUN = checkEdges, v = nv)
    ne <- x@edges[id,]
    ## tworzenie nowego obiektu
    graph( vertices = nv, edges = ne)
}

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

temp <- function( object){
    ## wartości domyślne
    val <- TRUE
    warn <- NULL
    ## sprawdzanie czy są zdefiniowane krawędzie
    if( !(nrow( getEdges( object)) > 0) ){
	val = FALSE
	warn <- "No defined edges"
    }
    ## sprawdanie czy krawędzie zdefiniowane o istniejące wierzchołki
    if( !all( as.vector( getEdges( object)) %in% getVertices( object)) ){
	val = FALSE
	warn <- "Edges defined with non defined vertices"
    }

    ## zwrotka
    if( val){
	TRUE
    } else {
	warn
    }

}

### Przypinanie do metody validObject
setValidity( Class = "graph", temp)

### Przykładowy graf
v <- 1:30
e <- cbind(sample(v, 50, replace = TRUE), sample(v, 50, replace = TRUE))
g <- graph( vertices = v, edges = e)
g
getVertices(g)

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

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

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

getVertices(g)
getVertices(g) <- 30:1
getVertices(g)

getVertices(g) <- 1:10
getVertices(g)

Dziedziczenie

  • Dziedziczenie z modelu S4, contains
  • Dziedziczenie z modelu S3 przez podniesienie do modelu S4, setOldClass()
### Czyszczenie
rm(list = ls())

### Dziedziczenie standardowe
dataStructure <- setClass(Class = "dataStructure",
			  slots = list( data = "data.frame"))

### Metoda show
temp <- function(object) {
    cat("dataStructure: ", class(object), "\n")
    cat("NUmber of variables: ", dim(object@data)[2], "\n")
    cat("Number of observations: ", dim(object@data)[1], "\n")
}

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

### Przykładowy obiekt
a <- dataStructure(data = data.frame(id = 1:5, value = rnorm(5)))
a

### Dziedziczenie
dataStructureInfo <- setClass(Class = "dataStructureInfo",
			      slots = list( info = "character"),
			      contains = "dataStructure")

b <- dataStructureInfo(
    data = data.frame(id = 1:5, value = rnorm(5)),
    info = "Przykładowe dane")

b

### Dziedziczenie z S3
rm(list = ls())

### Tworzenie prostej klasy S3
dataFrame <- function(data, name){
    ret <- list( data = data, name = name)
    structure(ret, "class" = "dataFrame")
}

a <- dataFrame(
    data= data.frame(id = 1:5, value = rnorm(5)),
    name = "Przykładowe dane")

a

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

plot(a)

### Rejestrowanie w modelu S4
setOldClass("dataFrame")

### Tworzenie klasy w modelu S4
dataFrameS4 <- setClass(Class = "dataFrameS4",
			slots = list( conditions = "character"),
			contains = "dataFrame")

b <- dataFrameS4(a, conditions = "Dane z lab 1")
b

S3Part(b)
attributes( b)

### Metoda S4
temp <- function(object) {
    cat("Part S4: ")
    cat(object@conditions)
    cat("\n")
    cat("Part S3:\n")
    print(S3Part(object)$data)
}

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

class( b)

### Metoda S3 dla klasy w modelu S4
plot.dataFrameS4 <- function(object, ...) {
    cat("\nConditions for a data in the plot\n\n", object@conditions)
    plot(S3Part(object), ...)
}

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

Model obiektowy R5 (RC)

  • Elementy są przechowywane w środowisku
  • Model oparty o typ bazowy S4
  • Formalna definicja klasy zawierająca pola i metody (nie jest oparty o system funkcji generycznych)
  • Wszystkie klasy dziedziczą z klasy envRefClass

Definiowanie klasy

### Czyszczenie
rm(list = ls())

### Biblioteki
library(pryr)

### Tworzenie bardzo prostej klasy
generator <- setRefClass(
    Class = "student")

generator
otype(generator)
typeof(generator)
ftype(generator)
str(generator)

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

student

s1 <- student(name = "Mike", id = 123245)
s1
otype(s1)
typeof(s1)
attributes(s1)
e <- attributes(s1)$.xData
ls(envir = e)
e$name
e$id
e$id <- 55555
e$id
e$show
s1$show()
parent.env(e)
e$id <- 123
e$id <- "ala ma kota"

Automatyczne gettery i settery

### Czyszczenie
rm(list = ls())

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

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

### Automatyczne gettery
s1$name
s1$id

### Autoamtyczne settery
s1$name <- "John"
s1$name

s1$id <- 321
s1$id

s1$name <- 123
s1$id <- "ala"

Mutowalność kopie (klonowanie)

### Czyszczenie
rm(list = ls())

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

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

### Naiwne kopiowanie
s2 <- s1

s1$name
s2$name

s1$id
s2$id

identical(s1, s2)
address(s1)
address(s2)

s2$name <- "Ella"
s2$name
s1$name

attributes(s1)
attributes(s2)

rm(s2)
s2 <- s1$copy()

attributes(s1)
attributes(s2)

s1$name
s2$name <- "Mike"
s1$name
s2$name

### Dziwna klasa

strange <- setRefClass(
    Class = "strange",
    fields = list(name = "character", deep = "environment"))

a <- strange(name = "Przykład", deep = new.env())
a

parent.env(a$deep)
a$name <- "test 1"
a$deep$y <- TRUE
a$deep$y

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

a$name <- "Zmiana"
a$deep$x <- 555

aDeep$name
aDeep$deep$x
aDeep$deep$y

aShallow$name
aShallow$deep$x
aShallow$deep$y

### Przykład z obiektem w modelu R5
bc <- setRefClass(
    Class = "bc",
    fields = list(info = "character"))


vs <- setRefClass(
    Class = "vs",
    fields = list(name = "character", deep = "bc"))

a0 <- bc(info = "Testowy obiekt")
a <- vs(name = "test", deep = a0)
a

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

a$name <- "nowa wartość"
a$deep$info <- "nowa wartość na bc"

aDeep$name
aDeep$deep$info

aShallow$name
aShallow$deep$info

NEXT Metody (internal / external)

Dziedziczenie

  • Dziedziczenie z modelu S4 i R5
  • Dziedziczenie z modelu S3 przez podniesienie do modelu S4
  • Argument contains

Weryfikacja poprawności obiektu

Mieszanie modeli obiektowych

Model obiektowy R6

Autor: Michał Ramsza

Created: 2021-04-12 Mon 16:42

Validate