'aclemen1/strictly' (modulr gear)

aclemen1-strictly.Rmd

# `aclemen1/strictly` (Modulr Gear) 
 
Assign and get variables with strict tests. 
 
This module allows to assign and get variables in an environment, and to 
perform strict tests on the value. 
 
## Provides 
 
* `$install_sugars(flag, globally)` 
* `$define(variable, test, envir)` 
* `$undefine(variable, envir)` 
* `$assign(variable, value, envir)` 
* `$get(variable, envir)` 
 
## Installation
```{r}
library(modulr)
```
```r
# Not run
"aclemen1/strictly" %imports%
  "https://gist.githubusercontent.com/aclemen1/b6a5885ada29db6690c5/raw/aclemen1-strictly.Rmd"

# "aclemen1/strictly" %digests%
#   "68d9f7f0fe0aca9ccc535902e20a54ad27a09e01" %imports%
#   "https://gist.githubusercontent.com/aclemen1/b6a5885ada29db6690c5/raw/aclemen1-strictly.Rmd"
```
## Definition

```{r definition}
"aclemen1/strictly" %provides%
  function() {

  #' # `aclemen1/strictly` (Modulr Gear)
  #'
  #' Assign and get variables with strict tests.
  #'
  #' This module allows to assign and get variables in an environment, and to
  #' perform strict tests on the value.
  #'
  #' ## Provides
  #'
  #' * `$install_sugars(flag, globally)`
  #' * `$define(variable, test, envir)`
  #' * `$undefine(variable, envir)`
  #' * `$assign(variable, value, envir)`
  #' * `$get(variable, envir)`
  #'

  # Initialization

  library(assertthat)

  register <- list()

  # Helper functions

  .envir_to_str <- function(envir) capture.output(print(envir))

  .stopifnot <- function(name, pass) {
    if(!isTRUE(pass))
      stop(sprintf("value not allowed for `%s`", name), call. = F)
  }

  # Install syntactic sugars

  install_sugars <- function(flag = T, globally = F) {
    assert_that(is.flag(flag), is.flag(globally))
    if(flag) {
      envir <- if(globally)
        globalenv() else parent.frame(2)
      if(!exists("%|<-|%", envir = envir) || !exists("|<-|", envir = envir)) {
        base::assign(
          "%|<-|%",
          function(lhs, rhs) assign(as.character(substitute(lhs)), rhs,
                                    envir = parent.frame()), envir = envir)
        base::assign(
          "|<-|",
          function(var) get(as.character(substitute(var)),
                            envir = parent.frame()), envir = envir)
      }
    }
  }

  # Define test function for a strictified variable

  define <- function(name, test = function(...) T,
                     drop = T, envir) {

    if(missing(envir)) envir <- parent.frame()

    assert_that(
      is.string(name),
      is.function(test),
      is.environment(env)
    )

    envir_str <- .envir_to_str(envir)

    if(!(envir_str %in% names(register)))
      register[[envir_str]] <<- list()

    if(drop && exists(name, envir = envir))
      rm(list = name, envir = envir)

    register[[c(envir_str, name)]] <<- list()
    register[[c(envir_str, name, "test")]] <<- test

  }

  # Undefine a strictified variable

  undefine <- function(name, drop = T, envir) {

    if(missing(envir)) envir <- parent.frame()

    assert_that(
      is.string(name),
      is.environment(envir)
    )

    envir_str <- .envir_to_str(envir)

    if(drop && exists(name, envir = envir))
      rm(list = name, envir = envir)

    if(envir_str %in% names(register))
      register[[c(envir_str, name)]] <<- NULL

  }

  # Assign value to a strictified variable

  assign <- function(name, value, envir) {

    if(missing(envir)) envir <- parent.frame()

    assert_that(
      is.string(name),
      is.environment(envir)
    )

    envir_str <- .envir_to_str(envir)

    if(envir_str %in% names(register) &&
         name %in% names(register[[envir_str]])) {
      .stopifnot(name, register[[c(envir_str, name, "test")]](value))
      base::assign(name, value, envir = envir)
      return(invisible(value))
    }

    stop(sprintf("variable `%s` not defined.", name), call. = F)

  }

  # Get value from a strictified variable

  get <- function(name, envir) {

    if(missing(envir)) envir <- parent.frame()

    assert_that(
      is.string(name),
      is.environment(envir)
    )

    envir_str <- .envir_to_str(envir)

    if(envir_str %in% names(register) && name %in% names(register[[envir_str]])
       && exists(name, envir = envir)) {
      value <- base::get(name, envir = envir)
      .stopifnot(name, register[[c(envir_str, name, "test")]](value))
      return(value)
    }

    stop(sprintf("variable `%s` not defined.", name), call. = F)
  }

  # Module contract

  list(
    install_sugars = install_sugars,
    define = define,
    undefine = undefine,
    assign = assign,
    get = get
  )

}

```
## Testing
### Mocks
```{r mocks}
"aclemen1/strictly/mock" %provides%
  get_provider("aclemen1/strictly")

```
### Tests
```{r tests}
"aclemen1/strictly/test" %requires%
  list(strictly = "aclemen1/strictly/mock") %provides%
  function() {

  # Initialization

  library(testthat)

  context("aclemen1/strictly/test")

  # Some (incomplete) regression tests
  # TODO: add more code coverage

  test_that("a variable passes all trivial tests", {

    strictly$define("foo", function(...) T)
    expect_equal(strictly$assign("foo", "bar"), "bar")

    strictly$define("foo", function(...) F)
    expect_error(strictly$assign("foo", "bar"))

  })

  test_that("a variable passes more complex tests", {

    strictly$define("foo", is.character)
    expect_equal(strictly$assign("foo", "bar"), "bar")
    expect_error(strictly$assign("foo", 0L))

    foo <- "Hello World"
    expect_equal(strictly$get("foo"), "Hello World")

    foo <- 0L
    expect_error(strictly$get("foo"))

  })

}

```
```r
# Not run
make_all(regexp = "aclemen1/strictly/test")
```
## Examples
```{r examples}
"aclemen1/strictly/example" %requires%
  list(strictly = "aclemen1/strictly") %provides%
  function() {

  # Helper function

  .prompt_and_do <- function(qexpr) {
    expr_str <- deparse(qexpr)
    message(sprintf("{%s} returns: ", expr_str), appendLF = F)
    value <- NULL
    try(value <- eval(qexpr, envir = parent.frame()))
    if(!is.null(value))
      message(sprintf("%s (%s)", value, typeof(value)))
  }

  # Install syntactic sugars (locally)

  strictly$install_sugars(T, globally = F)

  # Define a test function for variable "foo"

  strictly$define(
    "foo",
    function(x) is.character(x) || (is.numeric(x) && x <= 3)
  )

  # Run some examples

  .prompt_and_do(quote(foo %|<-|% "bar"))
  .prompt_and_do(quote(`|<-|`(foo)))
  .prompt_and_do(quote(foo))
  .prompt_and_do(quote(foo %|<-|% 1))
  .prompt_and_do(quote(foo %|<-|% 4))
  .prompt_and_do(quote(foo))
  .prompt_and_do(quote(foo %|<-|% function() NULL))
  .prompt_and_do(quote(foo <- 4))
  .prompt_and_do(quote(`|<-|`(foo)))

  # Module contract

  invisible(NULL)

}

```
```r
# Not run
make_all(regexp = "aclemen1/strictly/example")
```
---
_Gear prepared with the R package [_modulr_](https://github.com/aclemen1/modulr) (v0.1.7.9047) on 2015-10-24 02:18:26._