From f5adfed2d3a6889e7136f87519b2f5a1123b01a6 Mon Sep 17 00:00:00 2001
From: Winston Chang <winston@stdout.org>
Date: Tue, 29 Jul 2014 09:44:10 -0500
Subject: [PATCH] Remove R8 code

---
 NAMESPACE                     |   4 -
 R/r8_class.R                  | 197 ------------------
 src/r8.c                      |  42 ----
 tests/testthat/test-r8class.R | 379 ----------------------------------
 4 files changed, 622 deletions(-)
 delete mode 100644 R/r8_class.R
 delete mode 100644 src/r8.c
 delete mode 100644 tests/testthat/test-r8class.R

diff --git a/NAMESPACE b/NAMESPACE
index c199137..cb2665a 100644
--- a/NAMESPACE
+++ b/NAMESPACE
@@ -1,9 +1,5 @@
 # Generated by roxygen2 (4.0.1): do not edit by hand
 
-S3method("$",R8_shared)
-S3method("[[",R8_shared)
 S3method(print,R6)
 S3method(print,R6ClassGenerator)
 export(R6Class)
-export(R8Class)
-useDynLib(R6,subset_R8)
diff --git a/R/r8_class.R b/R/r8_class.R
deleted file mode 100644
index 7961fc9..0000000
--- a/R/r8_class.R
+++ /dev/null
@@ -1,197 +0,0 @@
-#' @export
-R8Class <- function(classname = NULL, public = list(), private = NULL,
-                    active = NULL, inherit = NULL, lock = TRUE, shared = TRUE,
-                    class = TRUE, parent_env = parent.frame()) {
-
-  if (!all_named(public) || !all_named(private) || !all_named(active)) {
-    stop("All elements of public, private, and active must be named.")
-  }
-  if (any(duplicated(c(names(public), names(private), names(active))))) {
-    stop("All items in public, private, and active must have unique names.")
-  }
-  if (any(c("self", "private", "super") %in%
-      c(names(public), names(private), names(active)))) {
-    stop("Items cannot use reserved names 'self', 'private', and 'super'.")
-  }
-  if ("initialize" %in% c(names(private), names(active))) {
-    stop("'initialize' is not allowed in private or active.")
-  }
-
-  if (length(get_nonfunctions(active)) != 0) {
-    stop("All items in active must be functions.")
-  }
-
-  if (!is.null(inherit)) {
-    if (!inherits(inherit, "R8ClassGenerator")) {
-      stop("`inherit` must be a R8ClassGenerator.")
-    }
-
-    # Merge the new items over the inherited ones
-    public  <- merge_vectors(inherit$public,  public)
-    private <- merge_vectors(inherit$private, private)
-    active  <- merge_vectors(inherit$active,  active)
-  }
-
-  # If methods are shared, extract the methods and put them in an environment
-  if (shared) {
-    # Separate methods from fields
-    public_fields <- get_nonfunctions(public)
-    public_methods <- list2env2(get_functions(public))
-
-    private_fields <- get_nonfunctions(private)
-    private_methods <- list2env2(get_functions(private))
-  }
-
-  if (class) {
-    if (shared)
-      classes <- c("R8_shared", "R8")
-    else
-      classes <- "R8"
-
-    classes <- c(classname, get_superclassnames(inherit), classes)
-
-  } else {
-    if (!shared)
-      stop("R8 classes with shared methods must have class=TRUE")
-
-    classes <- NULL
-  }
-
-  newfun <- R8Class_newfun(classes,
-                           public_fields, public_methods,
-                           private_fields, private_methods,
-                           active, inherit, lock, parent_env)
-
-
-  structure(
-    list(
-      new = newfun,
-      classname = classname,
-      public = public,
-      private = private,
-      public_fields = public_fields,
-      public_methods = public_methods,
-      private_fields = private_fields,
-      private_methods = private_methods,
-      active = active,
-      inherit = inherit,
-      parent_env = parent_env,
-      lock = lock
-    ),
-    class = "R8ClassGenerator"
-  )
-}
-
-
-# Create the $new function for a R8ClassGenerator
-R8Class_newfun <- function(classes, public_fields, public_methods,
-                           private_fields, private_methods, active,
-                           inherit, lock, parent_env) {
-
-  function(...) {
-    # Create the evaluation environment
-    eval_env <- new.env(parent = parent_env, hash = FALSE)
-
-    # Copy public fields to public binding environment
-    public_bind_env <- list2env2(public_fields, empty_to_null = FALSE)
-
-    # Add self pointer
-    eval_env$self <- public_bind_env
-
-    # Do same for private_fields
-    if (!is.null(private_fields) || !is.null(private_methods)) {
-      private_bind_env <- list2env2(private_fields, empty_to_null = FALSE)
-      eval_env$private <- private_bind_env
-      class(private_bind_env) <- "R8_shared"
-    }
-
-    # Set up active bindings
-    if (!is.null(active)) {
-      active <- assign_func_envs(active, eval_env)
-
-      for (name in names(active)) {
-        makeActiveBinding(name, active[[name]], public_bind_env)
-      }
-    }
-
-    # Create super environment if needed
-    if (!is.null(inherit)) {
-      eval_env$super <- create_r8_super_env(inherit, public_bind_env,
-                                            private_bind_env)
-    }
-
-    if (lock) {
-      lockEnvironment(public_bind_env)
-      if (!is.null(private_fields))
-        lockEnvironment(private_bind_env)
-    }
-
-    # Always lock the eval_env
-    lockEnvironment(eval_env)
-
-    class(public_bind_env) <- classes
-    attr(public_bind_env, "eval_env") <- eval_env
-    attr(public_bind_env, "methods") <- public_methods
-    if (!is.null(private_methods)) {
-      attr(private_bind_env, "eval_env") <- eval_env
-      attr(private_bind_env, "methods") <- private_methods
-    }
-
-    if (is.function(public_methods$initialize)) {
-      public_bind_env$initialize(...)
-    } else if (length(list(...)) != 0 ) {
-      stop("Called new() with arguments, but there is no initialize method.")
-    }
-    public_bind_env
-  }
-}
-
-# Create a super env
-create_r8_super_env <- function(inherit, public_bind_env, private_bind_env) {
-  # Unclass inherit for faster access with $ (avoid S3 overhead)
-  inherit <- unclass(inherit)
-
-  eval_env <- new.env(parent = inherit$parent_env, hash = FALSE)
-
-  eval_env$self <- public_bind_env
-  if (!is.null(private_bind_env))
-    eval_env$private <- private_bind_env
-
-  # Set up active bindings
-  # The only thing that goes in the binding env are the active bindings.
-  active <- inherit$active
-  bind_env <- new.env(parent = emptyenv(), hash = length(active) > 100)
-  if (!is.null(active)) {
-    active <- assign_func_envs(active, eval_env)
-    for (name in names(active)) {
-      makeActiveBinding(name, active[[name]], bind_env)
-    }
-  }
-
-  # Recurse if there are more superclasses
-  if (!is.null(inherit$inherit)) {
-    eval_env$super <- create_r8_super_env(inherit$inherit, public_bind_env,
-                                          inherit$parent_env)
-  }
-
-  # Always lock the eval_env
-  lockEnvironment(eval_env)
-
-  # Add the methods
-  attr(bind_env, "methods") <- inherit$public_methods
-  attr(bind_env, "methods2") <- inherit$private_methods
-
-  attr(bind_env, "eval_env") <- eval_env
-  class(bind_env) <- "R8_shared"
-  bind_env
-}
-
-
-#' @export
-#' @useDynLib R6 subset_R8
-`$.R8_shared` <- function(x, name) {
-  .Call(subset_R8, x, name)
-}
-
-#' @export
-`[[.R8_shared` <- `$.R8_shared`
diff --git a/src/r8.c b/src/r8.c
deleted file mode 100644
index 5625ebf..0000000
--- a/src/r8.c
+++ /dev/null
@@ -1,42 +0,0 @@
-#include <R.h>
-#include <Rdefines.h>
-
-SEXP get_function_from_env_attrib(SEXP x, SEXP attribSym, SEXP nameSym) {
-  SEXP methods_env = Rf_getAttrib(x, attribSym);
-  if (isEnvironment(methods_env)) {
-    return Rf_findVarInFrame(methods_env, nameSym);
-  }
-  return R_NilValue;
-}
-
-SEXP subset_R8(SEXP x, SEXP name) {
-  // Look in x (an environment) for the object
-  SEXP nameSym = Rf_install(CHAR(STRING_ELT(name, 0)));
-  SEXP foundVar = Rf_findVarInFrame(x, nameSym);
-  if (foundVar != R_UnboundValue) {
-    return foundVar;
-  }
-
-  // if not found in x, look in methods
-  SEXP fun = get_function_from_env_attrib(x, Rf_install("methods"), nameSym);
-
-  // If not found in methods, search in methods2. This is present only for
-  // storing private methods in a superclass.
-  if (!isFunction(fun)) {
-    fun = get_function_from_env_attrib(x, Rf_install("methods2"), nameSym);
-  }
-  if (!isFunction(fun)) {
-    return R_NilValue;
-  }
-
-  // Make a copy of the function, with a new environment
-  SEXP fun2 = PROTECT(duplicate(fun));
-  SEXP eval_env = Rf_getAttrib(x, Rf_install("eval_env"));
-  if (!isEnvironment(eval_env)) {
-    UNPROTECT(1);
-    return R_NilValue;
-  }
-  SET_CLOENV(fun2, eval_env);
-  UNPROTECT(1);
-  return fun2;
-}
diff --git a/tests/testthat/test-r8class.R b/tests/testthat/test-r8class.R
deleted file mode 100644
index 57a13fa..0000000
--- a/tests/testthat/test-r8class.R
+++ /dev/null
@@ -1,379 +0,0 @@
-context("R8")
-
-test_that("initialization", {
-  AC <- R8Class("AC",
-    public = list(
-      x = 1,
-      initialize = function(x, y) {
-        self$x <- self$getx() + x    # Assign to self; also access a method
-        private$y <- y          # Assign to private
-      },
-      getx = function() self$x,
-      gety = function() private$y
-    ),
-    private = list(
-      y = 2
-    )
-  )
-  A <- AC$new(2, 3)
-  expect_identical(A$x, 3)
-  expect_identical(A$gety(), 3)
-
-  # No initialize method: throw error if arguments are passed in
-  AC <- R8Class("AC", public = list(x = 1))
-  expect_error(AC$new(3))
-})
-
-test_that("empty members and methods are allowed", {
-  # No initialize method: throw error if arguments are passed in
-  AC <- R8Class("AC")
-  expect_that(AC$new(), not(throws_error()))
-})
-
-
-test_that("Private members are private, and self/private environments", {
-  AC <- R8Class("AC",
-    public = list(
-      x = 1,
-      gety = function() private$y,
-      getx = function() self$x,
-      getx2 = function() private$getx_priv(),
-      getself = function() self,
-      getprivate = function() private
-    ),
-    private = list(
-      y = 2,
-      getx_priv = function() self$x
-    )
-  )
-  A <- AC$new()
-
-  # Environment structure
-  expect_identical(A$getself(), A)
-  expect_identical(parent.env(A), emptyenv())
-
-  # The private binding environment contains private fields
-  private_bind_env <- A$getprivate()
-  expect_identical(ls(private_bind_env), "y")
-  expect_identical(parent.env(private_bind_env), emptyenv())
-
-  # Eval environment
-  eval_env <- attr(A, "eval_env")
-  expect_identical(parent.env(eval_env), environment())
-  expect_identical(eval_env$self, A)
-  expect_identical(eval_env$private, A$getprivate())
-
-  # The public methods environment
-  public_methods_env <- attr(A, "methods")
-  expect_identical(
-    sort(ls(public_methods_env)),
-    c("getprivate", "getself", "getx", "getx2", "gety")
-  )
-  expect_identical(parent.env(public_methods_env), emptyenv())
-
-  # Environment of public methods should be same as eval_env - but only when
-  # fetched with A$getx.
-  expect_identical(environment(A$getx), eval_env)
-  # When fetched directly from the public_methods_env, it should have this
-  # environment.
-  expect_identical(environment(public_methods_env$getx), environment())
-
-  # The private methods environment
-  private_methods_env <- attr(A$getprivate(), "methods")
-  expect_identical(ls(private_methods_env), "getx_priv")
-  expect_identical(parent.env(private_methods_env), emptyenv())
-
-  # Environment of private methods should be same as eval_env - but only when
-  # fetched with private$getx_priv.
-  expect_identical(environment(A$getprivate()$getx_priv), eval_env)
-  # When fetched directly from the public_methods_env, it should have this
-  # environment.
-  expect_identical(environment(private_methods_env$getx), environment())
-
-
-  # Behavioral tests
-  expect_identical(A$x, 1)
-  expect_null(A$y)
-  expect_null(A$getx_foo)
-  expect_identical(A$gety(), 2)  # Explicit access: private$y
-  expect_identical(A$getx(), 1)  # Explicit access: self$x
-  expect_identical(A$getx2(), 1) # Indirect access: private$getx_priv()
-})
-
-
-
-test_that("Private methods exist even when no private fields", {
-  AC <- R8Class("AC",
-    public = list(
-      x = 1,
-      getx = function() self$x,
-      getx2 = function() private$getx_priv(),
-      getself = function() self,
-      getprivate = function() private
-    ),
-    private = list(
-      getx_priv = function() self$x
-    )
-  )
-  A <- AC$new()
-
-  # The private binding environment contains private fields
-  private_bind_env <- A$getprivate()
-  expect_identical(length(private_bind_env), 0L)
-  expect_identical(parent.env(private_bind_env), emptyenv())
-
-  # The private methods environment
-  private_methods_env <- attr(A$getprivate(), "methods")
-  expect_identical(ls(private_methods_env), "getx_priv")
-  expect_identical(parent.env(private_methods_env), emptyenv())
-
-  # Environment of private methods should be same as eval_env - but only when
-  # fetched with private$getx_priv.
-  expect_identical(environment(A$getprivate()$getx_priv), attr(A, "eval_env"))
-  # When fetched directly from the public_methods_env, it should have this
-  # environment.
-  expect_identical(environment(private_methods_env$getx), environment())
-})
-
-
-test_that("Active bindings work", {
-  AC <- R8Class("AC",
-    public = list(
-      x = 5
-    ),
-    active = list(
-      x2 = function(value) {
-        if (missing(value)) return(self$x * 2)
-        else self$x <- value/2
-      }
-    )
-  )
-  A <- AC$new()
-
-  expect_identical(A$x2, 10)
-  A$x <- 20
-  expect_identical(A$x2, 40)
-  A$x2 <- 60
-  expect_identical(A$x2, 60)
-  expect_identical(A$x, 30)
-})
-
-
-test_that("Locking works", {
-  AC <- R8Class("AC",
-    public = list(x = 1),
-    private = list(y = 2),
-    lock = TRUE
-  )
-  A <- AC$new()
-
-  expect_that(A$x <- 5, not(throws_error()))
-  expect_identical(A$x, 5)
-  expect_error(A$z <- 1)
-
-  # Not locked
-  AC <- R8Class("AC",
-    public = list(x = 1),
-    private = list(y = 2),
-    lock = FALSE
-  )
-  A <- AC$new()
-
-  expect_that(A$x <- 5, not(throws_error()))
-  expect_identical(A$x, 5)
-  expect_that(A$z <- 1, not(throws_error()))
-})
-
-
-test_that("Validity checks on creation", {
-  fun <- function() 1  # Dummy function for tests
-
-  # All arguments must be named
-  expect_error(R8Class("AC", public = list(1)))
-  expect_error(R8Class("AC", private = list(1)))
-  expect_error(R8Class("AC", active = list(fun)))
-
-  # Names can't be duplicated
-  expect_error(R8Class("AC", public = list(a=1, a=2)))
-  expect_error(R8Class("AC", public = list(a=1), private = list(a=1)))
-  expect_error(R8Class("AC", private = list(a=1), active = list(a=fun)))
-
-  # Reserved names
-  expect_error(R8Class("AC", public = list(self = 1)))
-  expect_error(R8Class("AC", private = list(private = 1)))
-  expect_error(R8Class("AC", active = list(super = 1)))
-
-  # `initialize` only allowed in public
-  expect_error(R8Class("AC", private = list(initialize = fun)))
-  expect_error(R8Class("AC", active = list(initialize = fun)))
-})
-
-
-test_that("Inheritance", {
-  AC <- R8Class("AC",
-    public = list(
-      x = 0,
-      z = 0,
-      initialize = function(x) self$x <- x,
-      getx = function() self$x,
-      getx2 = function() self$x*2,
-      getprivateA = function() private
-    ),
-    private = list(
-      getz = function() self$z,
-      getz2 = function() self$z*2
-    ),
-    active = list(
-      x2 = function(value) {
-        if (missing(value)) return(self$x * 2)
-        else self$x <- value/2
-      },
-      x3 = function(value) {
-        if (missing(value)) return(self$x * 3)
-        else self$x <- value/3
-      }
-    )
-  )
-  BC <- R8Class("BC",
-    inherit = AC,
-    public = list(
-      y = 0,
-      z = 3,
-      initialize = function(x, y) {
-        super$initialize(x)
-        self$y <- y
-      },
-      getx = function() self$x + 10,
-      getprivateB = function() private
-    ),
-    private = list(
-      getz = function() self$z + 10
-    ),
-    active = list(
-      x2 = function(value) {
-        if (missing(value)) return(self$x + 2)
-        else self$x <- value-2
-      }
-    )
-  )
-  B <- BC$new(1, 2)
-
-  # Environment checks
-  eval_env <- attr(B, "eval_env")
-  super_bind_env <- eval_env$super
-  super_eval_env <- attr(super_bind_env, "eval_env")
-
-  expect_identical(parent.env(super_bind_env), emptyenv())
-  expect_identical(parent.env(super_eval_env), environment())
-  expect_identical(super_eval_env$self, B)
-  expect_identical(super_eval_env$private, B$getprivateA())
-  expect_identical(B$getprivateA(), B$getprivateB())
-
-  expect_identical(eval_env, environment(B$getx))                # Overridden public method
-  expect_identical(eval_env, environment(B$getx2))               # Inherited public method
-  expect_identical(eval_env, environment(B$getprivateA()$getz))  # Overridden private method
-  expect_identical(eval_env, environment(B$getprivateA()$getz2)) # Inherited private method
-
-  # Behavioral tests
-  # Overriding literals
-  expect_identical(B$x, 1)
-  expect_identical(B$y, 2)
-  expect_identical(B$z, 3) # Subclass value overrides superclass value
-  # Methods
-  expect_identical(B$getx(), 11)                # Overridden public method
-  expect_identical(B$getx2(), 2)                # Inherited public method
-  expect_identical(B$getprivateA()$getz(), 13)  # Overriden private method
-  expect_identical(B$getprivateA()$getz2(), 6)  # Inherited private method
-
-  # Active bindings
-  expect_identical(B$x2, 3) # Overridden
-  expect_identical(B$x3, 3) # Inherited
-
-  # Classes
-  expect_identical(class(B), c("BC", "AC", "R8_shared", "R8"))
-})
-
-
-test_that("Inheritance: superclass methods", {
-  AC <- R8Class("AC",
-    public = list(
-      x = 0,
-      initialize = function() {
-        self$inc_x()
-        private$inc_y()
-        self$incz
-      },
-      inc_x = function() self$x <- self$x + 1,
-      inc = function(val) val + 1,
-      pinc = function(val) private$priv_inc(val), # Call private inc method
-      gety = function() private$y,
-      z = 0
-    ),
-    private = list(
-      y = 0,
-      inc_y = function() private$y <- private$y + 1,
-      priv_inc = function(val) val + 1
-    ),
-    active = list(
-      incz = function(value) {
-        self$z <- z + 1
-      }
-    )
-  )
-  BC <- R8Class("BC",
-    inherit = AC,
-    public = list(
-      inc_x = function() self$x <- self$x + 2,
-      inc = function(val) super$inc(val) + 20
-    ),
-    private = list(
-      inc_y = function() private$y <- private$y + 2,
-      priv_inc = function(val) super$priv_inc(val) + 20
-    ),
-    active = list(
-      incz = function(value) {
-        self$z <- self$z + 2
-      }
-    )
-  )
-  B <- BC$new()
-
-  # Testing overrides
-  expect_identical(B$x, 2)       # Public
-  expect_identical(B$gety(), 2)  # Private
-  expect_identical(B$z, 2)       # Active
-  # Calling superclass methods
-  expect_identical(B$inc(0), 21)
-  expect_identical(B$pinc(0), 21)
-
-
-  # Multi-level inheritance
-  CC <- R8Class("CC",
-    inherit = BC,
-    public = list(
-      inc_x = function() self$x <- self$x + 3,
-      inc = function(val) super$inc(val) + 300
-    ),
-    private = list(
-      inc_y = function() private$y <- private$y + 3,
-      priv_inc = function(val) super$priv_inc(val) + 300
-    ),
-    active = list(
-      incz = function(value) {
-        self$z <- self$z + 3
-      }
-    )
-  )
-  C <- CC$new()
-
-  # Testing overrides
-  expect_identical(C$x, 3)       # Public
-  expect_identical(C$gety(), 3)  # Private
-  expect_identical(C$z, 3)       # Active
-  # Calling superclass methods (two levels)
-  expect_identical(C$inc(0), 321)
-  expect_identical(C$pinc(0), 321)
-
-  # Classes
-  expect_identical(class(C), c("CC", "BC", "AC", "R8_shared", "R8"))
-})