[med-svn] [r-cran-lambda.r] 08/10: New upstream version 1.1.9
Andreas Tille
tille at debian.org
Thu Sep 28 21:11:49 UTC 2017
This is an automated email from the git hooks/post-receive script.
tille pushed a commit to branch master
in repository r-cran-lambda.r.
commit 01da1d6efd37076a8cc47965d11f60474bbde6f4
Author: Andreas Tille <tille at debian.org>
Date: Thu Sep 28 23:10:10 2017 +0200
New upstream version 1.1.9
---
DESCRIPTION | 16 +
MD5 | 40 +
NAMESPACE | 19 +
R/duck.R | 28 +
R/framework.R | 1092 ++++++++++++++++++++
R/introspection.R | 106 ++
R/objects.R | 1 +
debian/README.test | 10 -
debian/changelog | 30 -
debian/compat | 1 -
debian/control | 24 -
debian/copyright | 18 -
debian/docs | 3 -
.../no_test_report_in_usr_lib_R_site-library.patch | 27 -
debian/patches/series | 1 -
debian/rules | 4 -
debian/source/format | 1 -
debian/tests/control | 3 -
debian/tests/run-unit-test | 11 -
debian/watch | 2 -
inst/unitTests/runit.auto_replace.1.R | 46 +
inst/unitTests/runit.auto_replace.2.R | 72 ++
inst/unitTests/runit.auto_replace.3.R | 15 +
inst/unitTests/runit.dispatching.1.R | 102 ++
inst/unitTests/runit.ellipsis_arguments.1.R | 41 +
inst/unitTests/runit.ellipsis_arguments.2.R | 15 +
inst/unitTests/runit.examples.R | 13 +
inst/unitTests/runit.factorial.1.R | 11 +
inst/unitTests/runit.factorial.2.R | 18 +
inst/unitTests/runit.fill_args.R | 47 +
inst/unitTests/runit.function_args.1.R | 27 +
inst/unitTests/runit.function_type.1.R | 15 +
inst/unitTests/runit.heaviside_step.1.R | 10 +
inst/unitTests/runit.heaviside_step.2.R | 13 +
inst/unitTests/runit.optional_arguments.1.R | 87 ++
inst/unitTests/runit.optional_arguments.2.R | 43 +
inst/unitTests/runit.parse_transforms.1.R | 22 +
inst/unitTests/runit.parse_transforms.2.R | 22 +
inst/unitTests/runit.parse_transforms.3.R | 27 +
inst/unitTests/runit.pattern_matching.R | 29 +
inst/unitTests/runit.taylor_series.1.R | 41 +
inst/unitTests/runit.type_any_type.R | 38 +
inst/unitTests/runit.type_ellipsis.R | 48 +
inst/unitTests/runit.type_functions.R | 61 ++
inst/unitTests/runit.type_inheritance.R | 114 ++
inst/unitTests/runit.type_integer_inheritance.R | 51 +
inst/unitTests/runit.type_variable.1.R | 79 ++
inst/unitTests/runit.types.1.R | 66 ++
man/UseFunction.Rd | 57 +
man/duck.Rd | 50 +
man/framework.Rd | 109 ++
man/introspection.Rd | 73 ++
man/lambda.r-package.Rd | 395 +++++++
tests/doRUnit.R | 60 ++
54 files changed, 3219 insertions(+), 135 deletions(-)
diff --git a/DESCRIPTION b/DESCRIPTION
new file mode 100644
index 0000000..ebbfeaf
--- /dev/null
+++ b/DESCRIPTION
@@ -0,0 +1,16 @@
+Package: lambda.r
+Type: Package
+Title: Modeling Data with Functional Programming
+Version: 1.1.9
+Date: 2016-07-10
+Depends: R (>= 3.0.0)
+Suggests: RUnit
+Author: Brian Lee Yung Rowe
+Maintainer: Brian Lee Yung Rowe <r at zatonovo.com>
+Description: A language extension to efficiently write functional programs in R. Syntax extensions include multi-part function definitions, pattern matching, guard statements, built-in (optional) type safety.
+License: LGPL-3
+LazyLoad: yes
+NeedsCompilation: no
+Packaged: 2016-07-10 13:33:55 UTC; brian
+Repository: CRAN
+Date/Publication: 2016-07-10 16:30:57
diff --git a/MD5 b/MD5
new file mode 100644
index 0000000..8204aba
--- /dev/null
+++ b/MD5
@@ -0,0 +1,40 @@
+522b07ad4e394663c2d9c15fd2f40add *DESCRIPTION
+ab82d9729386261d282f5fc0d8b3d5f4 *NAMESPACE
+1f1c9a9a097262fe0f7e3517eacefbee *R/duck.R
+7c016c2b35276b2364a9b78613a04ed2 *R/framework.R
+adac14153bc41e3607ed9dec5da7830a *R/introspection.R
+c5d9ed228976ea81509c224506d65f2f *R/objects.R
+97ceabf07d26fc1d390ed1bff9cceb55 *inst/unitTests/runit.auto_replace.1.R
+225c406a39eb8f4318e19ac356ee5bd6 *inst/unitTests/runit.auto_replace.2.R
+0e382f059b346b22f83b9dad307d3569 *inst/unitTests/runit.auto_replace.3.R
+774e7bcaa994519ae86405c8d68387f3 *inst/unitTests/runit.dispatching.1.R
+66fc3ac59a85c97a7719fd76fdede470 *inst/unitTests/runit.ellipsis_arguments.1.R
+783580a79a572f49b0c28b5f74515abf *inst/unitTests/runit.ellipsis_arguments.2.R
+cb96ac32893792bd0fc5522e1d7deff6 *inst/unitTests/runit.examples.R
+f51390873d9ace14ff2c3c55a0867d35 *inst/unitTests/runit.factorial.1.R
+080c9faea036e772a4bd4dd02dac65fa *inst/unitTests/runit.factorial.2.R
+253426aaff845e9ffe8525e9c974f9c9 *inst/unitTests/runit.fill_args.R
+9ee9fe941b00e243dff4d603fde446d7 *inst/unitTests/runit.function_args.1.R
+d00182c9d7417129db68fc46d62fe471 *inst/unitTests/runit.function_type.1.R
+65d13a07127f9509f88b624c6d16bb46 *inst/unitTests/runit.heaviside_step.1.R
+979dce6f4f885fee49c796de79ec1ec8 *inst/unitTests/runit.heaviside_step.2.R
+9a61eb814b14d27344b3754263c153a0 *inst/unitTests/runit.optional_arguments.1.R
+c72938f7a98c6447fcbd768df14a717e *inst/unitTests/runit.optional_arguments.2.R
+cf791378a6213f7e874142eef8740170 *inst/unitTests/runit.parse_transforms.1.R
+a0f5aa44def62f0c236233fec1212661 *inst/unitTests/runit.parse_transforms.2.R
+37f2bd279ecd0795fb230d1080f8ddba *inst/unitTests/runit.parse_transforms.3.R
+e8be891b03015204266313dd585da349 *inst/unitTests/runit.pattern_matching.R
+a1dfd153edb537cad1b9dc8c7942843d *inst/unitTests/runit.taylor_series.1.R
+d77fa33d1812e5be0b38431731594f41 *inst/unitTests/runit.type_any_type.R
+5c30ae25c9229e753301695d28af2234 *inst/unitTests/runit.type_ellipsis.R
+ae772e8e2067de9da0b2b65d49d6afe8 *inst/unitTests/runit.type_functions.R
+31dc52fd5a66f12a6c643e2b83c0fe53 *inst/unitTests/runit.type_inheritance.R
+1188d14fa191eef5536250d967631a19 *inst/unitTests/runit.type_integer_inheritance.R
+2440de145b19f5b20d7a9881d0ad0366 *inst/unitTests/runit.type_variable.1.R
+c6c8fe9189580c87fe3e35b0de73365b *inst/unitTests/runit.types.1.R
+a2c77e08d37644ae9f2ad53a00a487de *man/UseFunction.Rd
+7954e4e489368550f3b029ae69756bc3 *man/duck.Rd
+7ed5820d3134d7d8e93ca02257b8af1b *man/framework.Rd
+ad73256313b25f4a7ab5079204872ebd *man/introspection.Rd
+852aa917958ed85a17251526222fae9f *man/lambda.r-package.Rd
+8e4fcf20f64e5f762f1e52d089e32ee9 *tests/doRUnit.R
diff --git a/NAMESPACE b/NAMESPACE
new file mode 100644
index 0000000..719e5bb
--- /dev/null
+++ b/NAMESPACE
@@ -0,0 +1,19 @@
+importFrom("utils", "capture.output", "getParseData", "str", "tail")
+export("%as%")
+export("%::%")
+export("UseFunction")
+export("NewObject")
+export("describe")
+export("EMPTY")
+S3method(print, lambdar.fun)
+S3method(print, lambdar.type)
+export("debug.lr")
+export("undebug.lr")
+export("undebug.all")
+export("is.debug")
+export("which.debug")
+export("seal")
+export("%isa%")
+export("%hasa%")
+export("%hasall%")
+
diff --git a/R/duck.R b/R/duck.R
new file mode 100644
index 0000000..58583ac
--- /dev/null
+++ b/R/duck.R
@@ -0,0 +1,28 @@
+'%isa%' <- function(argument, type)
+{
+ type <- gsub('[\'"]','',deparse(substitute(type)))
+ type %in% class(argument)
+}
+
+# Note this will produce a vector of results
+'%hasa%' <- function(argument, property)
+{
+ property <- gsub('[\'"]','',deparse(substitute(property)))
+ property <- gsub(' ','', property, fixed=TRUE)
+ property <- sub('c(','', property, fixed=TRUE)
+ property <- sub(')','', property, fixed=TRUE)
+ props <- strsplit(property, ',', fixed=TRUE)[[1]]
+ props %in% names(argument)
+}
+
+'%hasall%' <- function(argument, property)
+{
+ property <- gsub('[\'"]','',deparse(substitute(property)))
+ property <- gsub(' ','', property, fixed=TRUE)
+ property <- sub('c(','', property, fixed=TRUE)
+ property <- sub(')','', property, fixed=TRUE)
+ props <- strsplit(property, ',', fixed=TRUE)[[1]]
+ all(props %in% names(argument))
+}
+
+
diff --git a/R/framework.R b/R/framework.R
new file mode 100644
index 0000000..88a0810
--- /dev/null
+++ b/R/framework.R
@@ -0,0 +1,1092 @@
+EMPTY <- 'EMPTY'
+
+#' Check if name is bound to a non-lambda.r object
+is.bound <- function(name) {
+ if (! exists(name, inherits=TRUE)) return(FALSE)
+
+ o <- get(name, inherits=TRUE)
+ ! any(c('lambdar.fun','lambdar.type') %in% class(o))
+}
+
+# f(a,b) %::% A : B : C
+'%::%' <- function(signature, types) {
+ os <- options(keep.source=TRUE)
+ s.expr <- paste(deparse(substitute(signature)), collapse="\n")
+ t.expr <- paste(deparse(substitute(types)), collapse="\n")
+ text <- paste(s.expr,t.expr, sep=" %::% ")
+ raw <- getParseData(parse(text=text))
+ # SPECIAL tokens now appear with a leading white space
+ raw$text <- sub("^ ","", raw$text)
+
+ it <- iterator(raw)
+ tree <- list(args=NULL)
+ args_expr <- parse_fun(it)
+ name <- args_expr$token[1]
+ if (is.bound(name))
+ stop("Function name is already bound to non lambda.r object")
+
+ if (nrow(args_expr) > 1)
+ tree$args <- args_expr[2:nrow(args_expr),]
+ tree$types <- parse_types(it, tree$args, text)
+ tree$signature <- paste(s.expr,"%::%",t.expr, sep=' ')
+
+ add_type(name, tree)
+ options(keep.source=os$keep.source)
+ invisible()
+}
+
+
+# f(a,0) %when% { a < 5; a > 0 } %as% { z <- a + 2; z * 2 }
+# f(a,b) %when% { a < 0 } %as% { abs(a) + b }
+# f(a,b) %as% { a + b }
+'%as%' <- function(signature, body) {
+ os <- options(keep.source=TRUE)
+ s.expr <- paste(deparse(substitute(signature)), collapse="\n")
+ b.expr <- paste(deparse(substitute(body)), collapse="\n")
+ text <- paste(s.expr,b.expr, sep=" %as% ")
+ raw <- getParseData(parse(text=text))
+ # SPECIAL tokens now appear with a leading white space
+ raw$text <- sub("^ ","", raw$text)
+ it <- iterator(raw)
+
+ tree <- list(args=NULL)
+ args_expr <- parse_fun(it)
+ name <- args_expr$token[1]
+ if (is.bound(name))
+ stop("Function name is already bound to non lambda.r object")
+
+ where <- get_function_env()
+ #cat(sprintf("Function env for %s is\n", name))
+ #print(where)
+ #cat("\n")
+
+ if (nrow(args_expr) > 1)
+ tree$args <- args_expr[2:nrow(args_expr),]
+ guard_expr <- parse_guard(it)
+ guard_expr <- transform_attrs(guard_expr)
+ if (!is.null(tree$args))
+ tree$guard <- guard_fn(tree$args, guard_expr, where)
+
+ body_expr <- parse_body(it)
+ body_expr <- transform_attrs(body_expr)
+ tree$def <- body_fn(tree$args, body_expr, where)
+ tree$signature <- s.expr
+ tree$body <- b.expr
+ tree$ellipsis <- idx_ellipsis(tree)
+ tree$fill.tokens <- clean_tokens(tree)
+ tree$fill.defaults <- clean_defaults(tree)
+
+ add_variant(name, tree, where)
+ options(keep.source=os$keep.source)
+ invisible()
+}
+
+################################## RUN TIME ###################################
+.ERR_NO_MATCH <- "No match for function"
+.ERR_USE_FUNCTION <- "No valid function for"
+.ERR_ENSURE_FAILED <- "Assertion '%s' failed for args = %s and result = %s"
+#NewObject <- function(type.name, ...)
+NewObject <- function(type.fn,type.name, ...)
+{
+ result <- UseFunction(type.fn,type.name, ...)
+
+ type <- gsub('"','', type.name)
+ if (!type %in% class(result))
+ class(result) <- c(type, class(result))
+ result
+}
+
+# Some timings
+# Baseline:
+# g <- function(x) x
+# system.time(for (i in 1:10000) g(i) )
+# user system elapsed
+# 0.004 0.000 0.003
+#
+# S3:
+# h <- function(x, ...) UseMethod("h")
+# h.default <- function(x, ...) x
+# system.time(for (i in 1:10000) h(i) )
+# user system elapsed
+# 0.035 0.001 0.035
+#
+# Lambda.r:
+# f(x) %as% x
+# system.time(for (i in 1:10000) { fn <- get('f', inherits=TRUE) })
+# user system elapsed
+# 0.017 0.000 0.018
+#
+# system.time(for (i in 1:10000) f(i) )
+# user system elapsed
+# 1.580 0.005 1.590
+# 0.622 0.005 0.628
+# 0.443 0.003 0.447
+# 0.407 0.000 0.408
+# 0.391 0.001 0.392
+# 0.384 0.001 0.386
+# 0.372 0.003 0.376
+# 0.347 0.001 0.347
+# 0.305 0.000 0.305
+# 0.238 0.000 0.238
+UseFunction <- function(fn,fn.name, ...)
+{
+ result <- NULL
+ # u:0.007 s:0.002
+ raw.args <- list(...)
+ # u:0.305 s:0.010
+ # u:0.096 s:0.002
+ # u:0.088 s:0.004
+ # u:0.082 s:0.000
+ vs <- get_variant(fn,length(raw.args))
+ if (is.null(vs) || length(vs) < 1)
+ stop(use_error(.ERR_NO_MATCH,fn.name,raw.args))
+
+ matched.fn <- NULL
+ for (v in vs)
+ {
+ # u:1.007 s:0.006
+ # u:0.106 s:0.001
+ # u:0.068 s:0.001
+ full.args <- fill_args(raw.args, v$fill.tokens, v$fill.defaults, v$ellipsis)
+ if (is.null(full.args)) next
+ # u:0.019 s:0.003
+ full.type <- get_type(fn,v$type.index)
+ if (!check_types(full.type, full.args)) next
+ if (is.null(v$guard)) { matched.fn <- v$def; break }
+ gout <- do.call(v$guard, full.args)
+ if (!is.na(gout) && length(gout) > 0 && gout) { matched.fn <- v$def; break }
+ }
+ if (is.null(matched.fn))
+ stop(use_error(.ERR_USE_FUNCTION,fn.name,raw.args))
+
+ result <- do.call(matched.fn, full.args)
+
+ if (!is.null(full.type))
+ {
+ result.class <- class(result)
+ return.type <- return_type(full.type, full.args, result.class)[1]
+ if ('integer' %in% result.class) result.class <- c(result.class, 'numeric')
+
+ if (return.type == '.') {
+ NULL
+ } else if (return.type == '.lambda.r_UNIQUE') {
+ act <- paste(result.class, collapse=', ')
+ first <- result.class[1]
+ if (first %in% sapply(raw.args, class)) {
+ msg <- sprintf("Expected unique return type but found '%s' for",first)
+ stop(use_error(msg,fn.name,raw.args))
+ }
+ } else if (!return.type %in% result.class) {
+ exp <- return.type
+ act <- paste(result.class, collapse=', ')
+ msg <- sprintf("Expected '%s' as return type but found '%s' for",exp,act)
+ stop(use_error(msg,fn.name,raw.args))
+ }
+ }
+
+ result
+}
+
+
+idx_ellipsis <- function(tree) {
+ which(tree$args$token == '...')
+}
+
+clean_tokens <- function(tree) {
+ if (length(tree$ellipsis) == 0)
+ tree$args$token
+ else
+ tree$args$token[-tree$ellipsis]
+}
+
+clean_defaults <- function(tree) {
+ if (length(tree$ellipsis) == 0)
+ tree$args$default
+ else
+ tree$args$default[-tree$ellipsis]
+}
+
+# rm(list=ls()); detach('package:lambda.r', unload=TRUE); library(lambda.r)
+fill_args <- function(params, tokens, defaults, idx.ellipsis)
+{
+ args <- list()
+ if (is.null(params) && all(is.na(defaults))) return(args)
+
+ # Skip parameters that don't coincide with the expected tokens
+ param.names <- names(params)
+ if (!is.null(param.names) &&
+ !all(param.names[nchar(param.names) > 0] %in% tokens) &&
+ length(idx.ellipsis) == 0) return(NULL)
+
+ # Initialize arguments with NA
+ arg.length <- max(length(tokens), length(defaults)) + length(idx.ellipsis)
+ if (arg.length == 0) return(args)
+
+ idx.concrete <- idx.args <- 1:arg.length
+ if (length(idx.ellipsis) > 0)
+ idx.concrete <- idx.args[-idx.ellipsis]
+ names(idx.concrete) <- tokens
+ args[idx.args] <- NA
+ names(args)[idx.concrete] <- tokens
+
+ # Populate named arguments
+ named.params <- param.names[param.names %in% tokens]
+ args[named.params] <- params[named.params]
+
+ # Catalog named and unnamed arguments
+ if (length(params) > 0) {
+ idx.params <- 1:length(params)
+ names(idx.params) <- names(params)
+ if (is.null(named.params) || length(named.params) < 1) {
+ idx.p.named <- integer()
+ idx.p.unnamed <- idx.params
+ idx.a.named <- integer()
+ idx.a.unnamed <- idx.concrete
+ } else {
+ idx.p.named <- idx.params[named.params]
+ idx.p.unnamed <- idx.params[-idx.p.named]
+ idx.a.named <- idx.concrete[named.params]
+ idx.a.unnamed <- idx.concrete[-idx.a.named]
+ }
+
+ if (length(idx.ellipsis) > 0) {
+ # Choose only required arguments
+ idx.required <- idx.concrete[is.na(defaults)]
+ idx.required <- idx.required[!idx.required %in% idx.a.named]
+
+ # Set arguments before ellipsis
+ idx.left <- idx.required[idx.required < idx.ellipsis]
+ args[idx.left] <- params[idx.p.unnamed[1:length(idx.left)]]
+
+ idx.right <- idx.required[idx.required > idx.ellipsis]
+ args[idx.right] <- params[tail(idx.p.unnamed, length(idx.right))]
+
+ # Fill the ellipsis with the remainder
+ orphans <- c(idx.p.named, idx.left, idx.right)
+ if (length(orphans) == 0) {
+ args[[idx.ellipsis]] <- params
+ } else {
+ args[[idx.ellipsis]] <- params[-orphans]
+ }
+ } else if (length(idx.p.unnamed) > 0) {
+ args[idx.a.unnamed[1:length(idx.p.unnamed)]] <- params[idx.p.unnamed]
+ }
+ }
+
+ # Apply default values to unset optional arguments
+ if (!is.null(defaults)) {
+ idx.optional <- idx.concrete[is.na(args[idx.concrete]) & !is.na(defaults)]
+ if (length(idx.ellipsis) > 0) {
+ idx.defaults <- ifelse(idx.optional >= idx.ellipsis,
+ idx.optional - 1,
+ idx.optional)
+ } else {
+ idx.defaults <- idx.optional
+ }
+ args[idx.optional] <- lapply(idx.defaults,
+ function(idx) eval(parse(text=defaults[idx]), list2env(args)))
+ }
+
+ if (length(idx.ellipsis) > 0) {
+ names(args)[idx.ellipsis] <- ''
+ #args <- c(args[-idx.ellipsis],unlist(args[idx.ellipsis], recursive=FALSE))
+ args <- c(args[idx.args < idx.ellipsis],
+ unlist(args[idx.ellipsis], recursive = FALSE),
+ args[idx.args > idx.ellipsis])
+ }
+ args
+}
+
+
+# Return the index of the ellipsis argument or an empty vector otherwise
+has_ellipsis <- function(declared.types) {
+ idx <- 1:length(declared.types)
+ val <- sapply(declared.types,
+ function(x) any(grep('...', x, fixed=TRUE) > 0))
+ idx[val]
+}
+
+update_type_map <- function(type.map, the.type, arg.type) {
+ if (is.null(type.map[[the.type]])) {
+ if (any(arg.type %in% type.map))
+ # This forces a failure in the type check later on
+ type.map[[the.type]] <- paste("!",arg.type,sep='')
+ else
+ # Add the new type if it doesn't exist
+ type.map[[the.type]] <- arg.type
+ }
+ type.map
+}
+
+strip_ellipsis <- function(the.type) {
+ sub('...','',the.type, fixed=TRUE)
+}
+
+# Used internally to determine the declared type based on its
+# value and corresponding argument type.
+dereference_type <- function(declared.types, arg.types) {
+ type.map <- list()
+ len.delta <- length(arg.types) - length(declared.types) + 1
+
+ # Check for type variables (can only be a-z)
+ fn <- function(x) {
+ the.type <- declared.types[[x]]
+ if (the.type == '.')
+ return(arg.types[[x]])
+ else if (the.type == '...')
+ return(arg.types[x + 0:len.delta])
+ else if (the.type %in% letters) {
+ type.map <<- update_type_map(type.map, the.type, arg.types[[x]])
+ return(type.map[[the.type]])
+ }
+ else if (any(grep('[a-z]\\.\\.\\.', the.type) > 0)) {
+ the.type <- strip_ellipsis(the.type)
+ type.map <<- update_type_map(type.map, the.type, arg.types[[x]])
+ return(rep(type.map[[the.type]], len.delta + 1))
+ }
+ else if (any(grep('[a-zA-Z0-9._]+\\.\\.\\.', the.type) > 0)) {
+ the.type <- strip_ellipsis(the.type)
+ return(rep(the.type, len.delta + 1))
+ }
+ # Default
+ the.type
+ }
+}
+
+
+# Validate arguments against types
+check_types <- function(raw.types, raw.args)
+{
+ if (is.null(raw.types)) return(TRUE)
+ declared.types <- raw.types$types$text
+ idx.ellipsis <- has_ellipsis(declared.types)
+ if (length(idx.ellipsis) == 0 &&
+ nrow(raw.types$types) - 1 != length(raw.args)) return(FALSE)
+
+ arg.fn <- function(x) {
+ cl <- class(x)
+ if ('integer' %in% cl) cl <- c(cl, 'numeric')
+ cl
+ }
+ arg.types <- lapply(raw.args, arg.fn)
+
+ fn <- dereference_type(declared.types, arg.types)
+ declared.types <- lapply(1:(length(declared.types)-1), fn)
+ if (length(idx.ellipsis) > 0) {
+ idx.declared <- 1:length(declared.types)
+ declared.types <- c(
+ declared.types[idx.declared[idx.declared < idx.ellipsis]],
+ unlist(declared.types[idx.ellipsis], recursive=FALSE),
+ declared.types[idx.declared[idx.declared > idx.ellipsis]]
+ )
+ }
+
+ idx <- 1:length(raw.args)
+ all(sapply(idx, function(x) any(declared.types[[x]] %in% arg.types[[x]])))
+}
+
+
+
+# Get the return type of a function declaration. This is aware of type
+# variables.
+# TODO: Make this more efficient using information computed
+# by check_types.
+return_type <- function(raw.types, raw.args, result.class)
+{
+ declared.types <- raw.types$types$text
+ if (! has_ellipsis(declared.types) &&
+ nrow(raw.types$types) - 1 != length(raw.args)) return(MissingReturnType)
+
+ arg.types <- lapply(raw.args, function(x) class(x))
+
+ # Check for type variables (can only be a-z)
+ ret.type <- declared.types[length(declared.types)]
+ if (ret.type %in% letters) {
+ fn <- dereference_type(declared.types, c(arg.types,result.class))
+ sapply(1:(length(declared.types)-1), fn)
+ ret.type <- fn(length(declared.types))
+ if (is.null(ret.type)) ret.type <- ".lambda.r_UNIQUE"
+ }
+ # Use Function as a proxy for function
+ gsub('\\bFunction\\b','function',ret.type, perl=TRUE)
+}
+
+.SIMPLE_TYPES <- c('numeric','character','POSIXt','POSIXct','Date')
+.is.simple <- function(x) any(class(x) %in% .SIMPLE_TYPES)
+as_simple <- function(x)
+{
+ if (! .is.simple(x)) return(class(x)[1])
+ if (length(x) == 1) return(x)
+ if (length(x) < 5) sprintf("c(%s)", paste(x, collapse=','))
+ else sprintf("c(%s, ...)", paste(x[1:4], collapse=','))
+}
+
+use_error <- function(msg, fn.name, raw.args)
+{
+ args <- paste(sapply(raw.args, as_simple), collapse=',')
+ signature <- sprintf("'%s(%s)'", fn.name, args)
+ sprintf("%s %s", msg, signature)
+}
+
+################################# PARSE TIME #################################
+iterator <- function(tree)
+{
+ if (!is.null(tree)) tree <- tree[! (tree$token=='expr' & tree$text==''),]
+ cap <- nrow(tree) + 1
+ idx <- 0
+ function(rewind=FALSE)
+ {
+ if (rewind) idx <<- idx - 1
+ else idx <<- idx + 1
+ if (idx < cap) tree[idx,]
+ else NA
+ }
+}
+
+get_name <- function(it)
+{
+ line <- it()
+ if (line$token != 'SYMBOL_FUNCTION_CALL')
+ stop("Function must start with a symbol (instead of ",line$token,")")
+ line$text
+}
+
+# parse_fun(raw=parser(text="fib(0,y=some.fun(1)) %as% 1"))
+# parse_fun(raw=parser(text="fib(x,y=some.fun(1), 'bgfs') %as% 1"))
+parse_fun <- function(it, raw=NULL)
+{
+ if (!is.null(raw)) { it <- iterator(raw) }
+ name <- get_name(it)
+ paren.level <- 0
+ node <- 'function.name'
+ out <- data.frame(paren.level=paren.level, node=node, token=name,
+ pattern=NA, default=NA, stringsAsFactors=FALSE)
+
+ arg.idx <- 1
+ node <- 'argument'
+ token <- pattern <- default <- NULL
+ in.default <- FALSE
+ while (!is.na(line <- it()) && line$token != "SPECIAL")
+ {
+ line.token <- line$token
+ if (line.token == 'expr') next
+ if (line.token == "'('")
+ {
+ paren.level <- paren.level + 1
+ if (paren.level == 1) next # Opening function parenthesis
+ }
+ if (line.token == "')'")
+ {
+ paren.level <- paren.level - 1
+ if (paren.level < 1) # Closing function parenthesis
+ {
+ # Check for 0 argument function
+ if (is.null(token) && is.null(pattern)) break
+ # Otherwise...
+ if (!is.null(token) && token == EMPTY) {
+ token <- NULL
+ pattern <- EMPTY
+ }
+ if (is.null(token)) token <- paste('.lambda',arg.idx,sep='_')
+ if (is.null(pattern)) pattern <- NA
+ #else pattern <- strip_quotes(paste(pattern, collapse=' '))
+ else pattern <- paste(pattern, collapse=' ')
+ if (is.null(default)) default <- NA
+ #else default <- strip_quotes(paste(default, collapse=' '))
+ else default <- paste(default, collapse=' ')
+ out <- rbind(out, c(1,node,token,pattern,default))
+ break
+ }
+ }
+
+ #cat("paren.level:",paren.level,"\n")
+ if (paren.level == 1)
+ {
+ if (!in.default && line.token %in% c('SYMBOL','SYMBOL_SUB','SYMBOL_FUNCTION_CALL'))
+ {
+ token <- line$text
+ next
+ }
+ if (line.token == 'EQ_SUB')
+ {
+ in.default <- TRUE
+ next
+ }
+ # Close current node
+ if (line.token == "','")
+ {
+ if (!is.null(token) && token == EMPTY) {
+ token <- NULL
+ pattern <- EMPTY
+ }
+ if (is.null(token)) token <- paste('.lambda',arg.idx,sep='_')
+ if (is.null(pattern)) pattern <- NA
+ #else pattern <- strip_quotes(paste(pattern, collapse=' '))
+ else pattern <- paste(pattern, collapse=' ')
+ if (is.null(default)) default <- NA
+ #else default <- strip_quotes(paste(default, collapse=' '))
+ else default <- paste(default, collapse=' ')
+
+ out <- rbind(out, c(paren.level,node,token,pattern,default))
+ token <- pattern <- default <- NULL
+ node <- 'argument'
+ arg.idx <- arg.idx + 1
+ in.default <- FALSE
+ next
+ }
+
+ # TODO: Current structure will fail if a default uses a function call
+ # with multiple arguments (due to the comma)
+ if (in.default) {
+ default <- c(default, line$text)
+ #cat("Adding to default value:",line$text,"\n")
+ } else
+ pattern <- c(pattern, line$text)
+ }
+ else
+ {
+ default <- c(default, line$text)
+ #cat("Default is now",default,"\n")
+ }
+ }
+ out
+}
+
+strip_quotes <- function(x) sub('^[\'"]([^\'"]+)[\'"]$', '\\1', x)
+
+
+parse_guard <- function(it)
+{
+ guards <- NULL
+ while (!is.na(line <- it()) && line$token != "SPECIAL") next
+ if (line$text == '%when%')
+ {
+ line <- it()
+ if (line$token != "'{'")
+ stop("Guard missing opening block")
+ while (!is.na(line <- it()) && line$token != "'}'")
+ {
+ if (line$token %in% c("'{'"))
+ stop("Invalid symbol '",line$text,"'in function definition")
+ #if (line$token %in% c('expr',"','")) next
+ if (line$token %in% c('expr')) next
+ guards <- rbind(guards, line)
+ }
+ #while (!is.na(line <- it()) && line$token != "SPECIAL") next
+ }
+ else
+ it(rewind=TRUE)
+ guards[,c('line1','token','text')]
+}
+
+guard_fn <- function(raw.args, tree, where)
+{
+ lines <- NULL
+ # Add any pattern matches
+ if (any(!is.na(raw.args$pattern)))
+ {
+ patterns <- raw.args[!is.na(raw.args$pattern),]
+ f <- function(x) {
+ if (patterns$pattern[x] == 'NULL')
+ paste("is.null(", patterns$token[x],")", sep='')
+ else if (patterns$pattern[x] == 'NA')
+ paste("is.na(", patterns$token[x],")", sep='')
+ else if (patterns$pattern[x] == 'EMPTY')
+ paste("length(", patterns$token[x],") == 0 || ",
+ "(!is.null(dim(",patterns$token[x],")) && ",
+ "nrow(",patterns$token[x],") == 0)" , sep='')
+ else
+ paste(patterns$token[x],'==',patterns$pattern[x], sep=' ')
+ }
+ lines <- sapply(1:nrow(patterns), f)
+ }
+
+ # Add explicit guards
+ if (!is.null(tree))
+ {
+ f <- function(x) paste(tree[tree$line1 %in% x,]$text, collapse=' ')
+ index <- array(unique(tree$line1))
+ lines <- c(lines,apply(index,1,f))
+ }
+
+ if (length(lines) < 1) return(NULL)
+
+ body <- paste(lines, collapse=' & ')
+ arg.string <- paste(raw.args$token, collapse=',')
+ fn.string <- sprintf("function(%s) { %s }", arg.string, body)
+ eval(parse(text=fn.string), where)
+}
+
+# A parse transform to change object at attribute to attr(object,'attribute')
+# f(x) %when% { x at name == "bob" } %as% x
+transform_attrs <- function(tree)
+{
+ start <- grep("'@'", tree$token, value=FALSE) - 1
+ #stop <- grep("SLOT", tree$token, value=FALSE)
+ stop <- start + 2
+ if (length(start) < 1) return(tree)
+
+ template <- data.frame(line1=0,
+ token=c('SYMBOL_FUNCTION_CALL',"'('",'SYMBOL',"','",'STR_CONST',"')'"),
+ text=c('attr','(', 'object', ',', '"key"',')'),
+ stringsAsFactors=FALSE)
+ rep.fn <- function(idx,o,k)
+ {
+ template$line1 <- idx
+ template$text[3] <- o
+ template$text[5] <- paste('"',k,'"', sep='')
+ template
+ }
+
+ positions <- data.frame(cbind(start,stop), stringsAsFactors=FALSE)
+ cut.fn <- function(idx)
+ {
+ ls <- NULL
+ # Grab lines preceding transform
+ if (idx == 1) inf <- 1
+ else inf <- positions$stop[idx - 1] + 1
+ sup <- positions$start[idx] - 1
+ if (inf < positions$start[idx] && sup >= inf)
+ ls <- rbind(ls, tree[inf:sup,])
+
+ i <- tree[positions$start[idx],]$line1
+ o <- tree[positions$start[idx],]$text
+ k <- tree[positions$stop[idx],]$text
+ ls <- rbind(ls, rep.fn(i,o,k))
+
+ if (idx == nrow(positions)) {
+ ls <- rbind(ls, tree[(positions$stop[idx] + 1) : nrow(tree),] )
+ }
+ ls
+ }
+ lines <- lapply(1:nrow(positions), cut.fn)
+ do.call(rbind, lines)
+}
+
+is.type <- function(fn.string)
+{
+ length(grep('^[A-Z]', fn.string)) > 0
+}
+
+
+parse_body <- function(it)
+{
+ body <- NULL
+ # Skip until we get to the
+ while (!is.na(line <- it()) && line$token != "SPECIAL") next
+ if (line$text == '%as%')
+ {
+ needs.wrapping <- FALSE
+ while (!is.na(line <- it()) && TRUE)
+ {
+ if (line$token %in% c('expr')) next
+ body <- rbind(body, line)
+ }
+ }
+ else
+ it(rewind=TRUE)
+ body[,c('line1','token','text')]
+}
+
+
+body_fn <- function(raw.args, tree, where)
+{
+ if (tree$token[1] == "'{'") tree <- tree[2:(nrow(tree)-1), ]
+ lines <- NULL
+
+ if (!is.null(tree))
+ {
+ f <- function(x) paste(tree[tree$line1 %in% x,]$text, collapse=' ')
+ index <- unique(tree$line1)
+ lines <- lapply(index,f)
+ }
+
+ if (length(lines) < 1) return(NULL)
+
+ body <- paste(lines, collapse='\n')
+ if (is.null(raw.args))
+ arg.string <- ''
+ else
+ arg.string <- paste(raw.args$token, collapse=',')
+ fn.string <- sprintf("function(%s) { %s }", arg.string, body)
+ eval(parse(text=fn.string), where)
+}
+
+parse_types <- function(it, args, sig)
+{
+ types <- NULL
+ while (!is.na(line <- it()) && line$token != "SPECIAL") next
+ if (line$text == '%::%')
+ {
+ while (!is.na(line <- it()) && TRUE)
+ {
+ if (line$token %in% c("'{'", "'}'", "'('", "')'"))
+ stop("Invalid symbol '",line$text,"'in definition of ",sig)
+ if (line$token != "SYMBOL") next
+ types <- rbind(types, line)
+ }
+ }
+ if (is.null(args)) {
+ if (nrow(types) != 1)
+ stop("Incorrect number of parameters in type declaration for ",sig)
+ } else {
+ if (nrow(args) != nrow(types) - 1)
+ stop("Incorrect number of parameters in type declaration for ",sig)
+ }
+
+ types[,c('line1','token','text')]
+}
+
+from_root_env <- function(frames)
+{
+ length(frames) < 3
+}
+
+add_variant <- function(fn.name, tree, where)
+{
+ #cat("NOTE: Environment for",fn.name,"is\n", sep=' ')
+ #print(sprintf("NOTE: Environment for %s is",fn.name))
+ #print(where)
+ env <- capture.output(str(as.environment(where), give.attr=FALSE))
+ if (! is.null(tree$def)) {
+ attr(tree$def,'topenv') <- env
+ attr(tree$def,'name') <- fn.name
+ } else {
+ cat("NOTE: Empty body definition encountered for",tree$signature,"\n")
+ }
+
+ setup_parent(fn.name, where)
+ fn <- get(fn.name, where)
+ #cat(sprintf("The parent.env(%s) is\n", fn.name))
+ #print(parent.env(environment(fn)))
+ #cat("\n")
+
+ variants <- attr(fn,'variants')
+ active.type <- attr(fn,'active.type')
+ args <- NULL
+
+ if (is.null(tree$args))
+ tree$accepts <- c(0,0)
+ else {
+ args <- tree$args
+ required.args <- length(args$default[is.na(args$default)])
+ if ('...' %in% tree$args$token)
+ tree$accepts <- c(required.args-1, Inf)
+ #tree$accepts <- c(required.args : nrow(args) - 1, Inf)
+ else
+ tree$accepts <- c(required.args, nrow(args))
+ type.index <- get_type_index(fn, nrow(args), active.type)
+ if (!is.null(type.index) && length(type.index) > 0)
+ tree$type.index <- type.index
+ }
+
+ # Replace existing function clauses if there is a signature match
+ idx <- has_variant(variants, args, tree$guard, active.type)
+ if (length(idx) > 0) variants[[idx]] <- tree
+ else variants[[length(variants) + 1]] <- tree
+ attr(fn,'variants') <- variants
+
+ assign(fn.name, fn, where)
+ #if (! from_root_env(frames)) attach(where, name='lambda.r_temp_env')
+ .sync_debug(fn.name)
+ invisible()
+}
+
+get_variant <- function(fn, arg.length)
+{
+ # u:0.007 s:0.000
+ raw <- attr(fn,'variants')
+ len <- length(raw)
+ matches <- vector(length=len)
+ for (j in 1:len) {
+ accepts <- raw[[j]]$accepts
+ matches[j] <- arg.length >= accepts[1] && arg.length <= accepts[2]
+ }
+ raw[matches]
+}
+
+# Check whether this function already has the given variant
+has_variant <- function(variants, args, guard=NULL, active.type=NULL)
+{
+ if (length(variants) == 0) return(variants)
+
+ keys <- colnames(args)[! colnames(args) %in% 'default']
+ fn <- function(x) {
+ v <- variants[[x]]
+ if (!is.null(v$type.index) && !is.null(active.type) && v$type.index != active.type) return(NA)
+ var.len <- ifelse(is.null(v$args), 0, nrow(v$args))
+ arg.len <- ifelse(is.null(args), 0, nrow(args))
+ if (var.len != arg.len) return(NA)
+ if (var.len == 0) return (x)
+
+ if (!is.null(v$guard) || !is.null(guard)) {
+ if (!is.null(v$guard) && is.null(guard)) return(NA)
+ if (is.null(v$guard) && !is.null(guard)) return(NA)
+ dv <- deparse(v$guard)
+ dg <- deparse(guard)
+ if (length(dv) != length(dg)) return(NA)
+ if (!all(deparse(v$guard) == deparse(guard))) return(NA)
+ }
+
+ args$pattern[is.na(args$pattern)] <- ".lambdar_NA"
+ v$args$pattern[is.na(v$args$pattern)] <- ".lambdar_NA"
+ ifelse(all(v$args[,keys] == args[,keys]),x, NA)
+ }
+ out <- sapply(1:length(variants), fn)
+ out[!is.na(out)]
+}
+
+# Adds type constraint to function
+# If an existing type constraint is encountered, then the active.type index
+# will be set to this type constraint. This has the same effect as adding a
+# new constraint.
+add_type <- function(fn.name, tree)
+{
+ frames <- sys.frames()
+ if (length(frames) < 3)
+ where <- topenv(parent.frame(2))
+ else
+ where <- target_env(sys.calls()[[length(frames)-2]], length(frames))
+
+ setup_parent(fn.name, where)
+ fn <- get(fn.name, where)
+ types <- attr(fn,'types')
+
+ if (is.null(tree$args))
+ tree$accepts <- c(0,0)
+ else {
+ args <- tree$args
+ tree$accepts <- c(length(args$default[is.na(args$default)]), nrow(args))
+ }
+ f <- function(x) {
+ ifelse(types[[x]]$signature == tree$signature, x, NA)
+ }
+ if (length(types) > 0)
+ {
+ out <- sapply(1:length(types), f)
+ }
+ else
+ out <- NA
+ out <- out[!is.na(out)]
+ idx <- ifelse(length(out) == 0, length(types) + 1, out[1])
+ types[[idx]] <- tree
+ attr(fn,'types') <- types
+ attr(fn,'active.type') <- idx
+
+ assign(fn.name, fn, where)
+ invisible()
+}
+
+# Type declarations are scoped based on when they are created. They continue
+# until a new type declaration is added.
+get_type <- function(fn, idx)
+{
+ if (is.null(idx)) return(NULL)
+ raw <- attr(fn,'types')
+ if (length(raw) < 1) return(NULL)
+ match <- raw[[idx]]
+ # Use Function as a proxy for function
+ char.type <- match$types$text
+ match$types$text <- gsub('\\bFunction\\b','function',char.type, perl=TRUE)
+ match
+}
+
+# Get the index for the most recent type declaration for the given arg.length
+get_type_index <- function(fn, arg.length, active.type)
+{
+ raw <- attr(fn,'types')
+ if (length(raw) < 1) return(NULL)
+ if (!is.null(active.type) &&
+ !is.null(raw[[active.type]]$args) &&
+ nrow(raw[[active.type]]$args) == arg.length) return(active.type)
+
+ match.fn <- function(x)
+ any(arg.length >= raw[[x]]$accepts & arg.length <= raw[[x]]$accepts)
+ matches <- data.frame(idx=(1:length(raw)), v=sapply(1:length(raw), match.fn))
+ if (!all(matches$v)) return(NULL)
+ max(matches$idx[matches$v==TRUE])
+}
+
+setup_parent <- function(parent, where)
+{
+ # Overwrite a final definition (as opposed to appending)
+ if (exists(parent, where))
+ {
+ parent.def <- get(parent, where)
+ is.final <- attr(parent.def, 'sealed')
+ if ((!is.null(is.final) && is.final == TRUE) ||
+ (! any(c('lambdar.fun','lambdar.type') %in% class(parent.def))) )
+ {
+ parent.def <- init_function(parent, where)
+ assign(parent, parent.def, where)
+ }
+ }
+ else
+ {
+ parent.def <- init_function(parent, where)
+ assign(parent, parent.def, where)
+ }
+}
+
+init_function <- function(name, where)
+{
+ if (is.type(name))
+ pattern <- 'function(...) NewObject(%s,"%s",...)'
+ else
+ pattern <- 'function(...) UseFunction(%s,"%s",...)'
+ fn <- eval(parse(text=sprintf(pattern,name,name)), where)
+ if (is.type(name))
+ attr(fn, 'class') <- c('lambdar.type', 'function')
+ else
+ attr(fn, 'class') <- c('lambdar.fun', 'function')
+ attr(fn, 'variants') <- list()
+ attr(fn, 'types') <- list()
+ #print(sprintf("Parent.env(%s) is", name))
+ #print(parent.env(environment(fn)))
+ fn
+}
+
+
+# Check if the same signature already exists in the function. If so return the
+# index of the existing definition
+# Types do not require default values specified in the signature, so we don't
+# check for that
+# With guards, there could be multiple matches, so each match will get a type
+# added
+# For adding types, we want to match all applicable
+# INCOMPLETE - Requires examining guards as well
+signature_idx <- function(tree, variants)
+{
+ if (length(variants) < 1) return(NULL)
+ args <- tree$args
+ fn <- function(idx)
+ {
+ vargs <- variants[[idx]]$args
+ if (nrow(args) != nrow(vargs)) return(NULL)
+ if (length(args$pattern[is.na(args$pattern)]) !=
+ length(vargs$pattern[is.na(vargs$pattern)]) ) return(NULL)
+ if (!all(args$token == vargs$token))
+ stop("Mismatched argument names found")
+ idx
+ }
+ temp <- sapply(array(1:length(variants)), fn)
+ do.call(c, temp)
+}
+
+seal <- function(fn)
+{
+ fn.name <- deparse(substitute(fn))
+ attr(fn,'sealed') <- TRUE
+ assign(fn.name, fn, inherits=TRUE)
+ invisible()
+}
+
+# This is a fall back for special cases. It is clearly not efficient but is
+# necessary for unit testing frameworks that manipulate the normal environment
+# structures
+# Returns the index of the most recent frame that contains the variable
+# UNUSED
+really_get <- function(x)
+{
+ frames <- sys.frames()
+ match.idx <- sapply(frames, function(y) x %in% ls(y))
+ frame.idx <- (1:length(frames))[match.idx]
+ if (length(frame.idx) < 1) stop("Still couldn't find ",x,"\n")
+ get(x, frames[frame.idx[length(frame.idx)]])
+}
+
+get_function_env <- function() {
+ frames <- sys.frames()
+
+ if (from_root_env(frames)) {
+ #print("Assuming in root environment")
+ where <- topenv(parent.frame(2))
+ } else {
+ #print("Getting target environment from call stack")
+ #if ('lambda.r_temp_env' %in% search())
+ # detach('lambda.r_temp_env', character.only=TRUE)
+ my.call <- sys.calls()[[length(frames)-2]]
+ where <- target_env(my.call, length(frames))
+ }
+ where
+}
+
+
+# Get the target env for the function definition. Normally this would be
+# just traversing the frame stack, but we need to add special logic to
+# handle eval() calls with an explicit environment.
+target_env <- function(head.call, frame.length)
+{
+ parsed.call <- getParseData(parse(text=deparse(head.call)))
+ it <- iterator(parsed.call)
+ args <- parse_eval(it)
+
+ # 3 is a magic number based on the lambda.r call stack to this function
+ stack.depth <- 3
+ top.env <- topenv(parent.frame(stack.depth))
+ if (args$token[1] != 'eval') return(top.env)
+
+ eval.frame <- sys.frame(frame.length-stack.depth)
+ lambda.r_temp_env <- tryCatch(get('envir', envir=eval.frame),
+ error=function(e) stop("Unable to extract envir in eval frame\n"))
+
+ #cat("NOTE: Using lambda.r_temp_env for",parsed.call[1,'token'],"\n", sep=' ')
+ lambda.r_temp_env
+}
+
+parse_eval <- function(it, raw=NULL)
+{
+ if (!is.null(raw))
+ {
+ if (!is.null(attr(raw,'data'))) raw <- attr(raw,'data')
+ it <- iterator(raw)
+ }
+ name <- get_name(it)
+ paren.level <- 0
+ node <- 'function.name'
+ out <- data.frame(paren.level=paren.level, node=node, token=name,
+ pattern=NA, default=NA, stringsAsFactors=FALSE)
+
+ arg.idx <- 1
+ node <- 'argument'
+ token <- NULL
+ while (!is.na(line <- it()) && TRUE)
+ {
+ line.token <- line$token
+ if (line.token == 'expr') next
+ if (line.token == "'('")
+ {
+ paren.level <- paren.level + 1
+ if (paren.level == 1) next # Opening function parenthesis
+ }
+ if (line.token == "')'")
+ {
+ paren.level <- paren.level - 1
+ if (paren.level < 1) # Closing function parenthesis
+ {
+ out <- rbind(out, c(1,node,paste(token,collapse=' '),NA,NA))
+ break
+ }
+ }
+
+ if (paren.level == 1 && line.token == "','")
+ {
+ out <- rbind(out, c(paren.level,node,paste(token,collapse=' '),NA,NA))
+ token <- NULL
+ arg.idx <- arg.idx + 1
+ next
+ }
+ token <- c(token, line$text)
+ }
+ out
+}
+
+.sync_debug <- function(fn.name) {
+ os <- getOption('lambdar.debug')
+ if (is.null(os)) return(invisible())
+
+ os[[fn.name]] <- NULL
+ options(lambdar.debug=os)
+ invisible()
+}
+
diff --git a/R/introspection.R b/R/introspection.R
new file mode 100644
index 0000000..f1ae3ce
--- /dev/null
+++ b/R/introspection.R
@@ -0,0 +1,106 @@
+describe(fn, idx, raw=FALSE) %when% { raw } %as% {
+ class(fn) <- NULL
+ print(fn)
+}
+describe(fn, idx) %when% {
+ idx > 0
+} %as% {
+ variants <- attr(fn,'variants')
+ types <- attr(fn,'types')
+ if (length(variants) < 1) stop("Nothing to describe")
+ if (idx > length(variants)) stop("Invalid index specified")
+ variants[[idx]]$def
+}
+seal(describe)
+
+
+debug.lr <- function(x)
+{
+ name <- deparse(substitute(x))
+ os <- getOption('lambdar.debug')
+ if (is.null(os)) os <- list()
+
+ os[[name]] <- TRUE
+ options(lambdar.debug=os)
+
+ if (! any(c('lambdar.fun','lambdar.type') %in% class(x)))
+ return(debug(x))
+
+ variants <- attr(x,'variants')
+ sapply(variants, function(v) debug(v$def))
+ invisible()
+}
+
+undebug.lr <- function(x)
+{
+ if (is.function(x)) {
+ name <- deparse(substitute(x))
+ } else {
+ name <- x
+ x <- get(x, parent.frame(), inherits=TRUE)
+ }
+ os <- getOption('lambdar.debug')
+ if (is.null(os)) return(invisible())
+
+ os[[name]] <- NULL
+ options(lambdar.debug=os)
+
+ if (! any(c('lambdar.fun','lambdar.type') %in% class(x)))
+ return(undebug(x))
+
+ variants <- attr(x,'variants')
+ sapply(variants, function(v) undebug(v$def))
+ invisible()
+}
+
+#' Undebug all registered functions
+undebug.all <- function() {
+ sapply(which.debug(), undebug.lr)
+ invisible()
+}
+
+is.debug <- function(fn.name) {
+ os <- getOption('lambdar.debug')
+ fn.name %in% names(os)
+}
+
+which.debug <- function() {
+ names(getOption('lambdar.debug'))
+}
+
+print.lambdar.fun <- function(x, ...)
+{
+ variants <- attr(x,'variants')
+ types <- attr(x,'types')
+ if (is.null(variants)) stop("Oops: lambda.r function incorrectly defined")
+ if (length(variants) < 1) stop("Function has no clauses")
+ cat("<function>\n")
+ fn <- function(idx)
+ {
+ f <- variants[[idx]]
+ cat("[[",idx,"]]\n",sep='')
+ if (!is.null(f$type.index))
+ cat(types[[f$type.index]]$signature,"\n")
+ cat(f$signature,"%as% ...\n")
+ }
+ sapply(1:length(variants),fn)
+ invisible()
+}
+
+print.lambdar.type <- function(x, ...)
+{
+ variants <- attr(x,'variants')
+ types <- attr(x,'types')
+ if (is.null(variants)) stop("Oops: lambda.R type constructor incorrectly defined")
+ cat("<type constructor>\n")
+ fn <- function(idx)
+ {
+ f <- variants[[idx]]
+ cat("[[",idx,"]]\n",sep='')
+ if (!is.null(f$type.index))
+ cat(types[[f$type.index]]$signature,"\n")
+ cat(f$signature,"%as% ...\n")
+ }
+ sapply(1:length(variants),fn)
+ invisible()
+}
diff --git a/R/objects.R b/R/objects.R
new file mode 100644
index 0000000..e40aed0
--- /dev/null
+++ b/R/objects.R
@@ -0,0 +1 @@
+MissingReturnType <- "MissingReturnType"
diff --git a/debian/README.test b/debian/README.test
deleted file mode 100644
index 0fe5d4e..0000000
--- a/debian/README.test
+++ /dev/null
@@ -1,10 +0,0 @@
-Notes on how this package can be tested.
-────────────────────────────────────────
-
-To run the unit tests provided by the package you can do
-
- sh run-unit-test
-
-in this directory.
-
- -- Andreas Tille <tille at debian.org> Fri, 20 Jun 2014 15:25:06 +0200
diff --git a/debian/changelog b/debian/changelog
deleted file mode 100644
index 289e059..0000000
--- a/debian/changelog
+++ /dev/null
@@ -1,30 +0,0 @@
-r-cran-lambda.r (1.1.9-1) unstable; urgency=medium
-
- * New upstream version
- * Convert to dh-r
- * Canonical homepage for CRAN
- * d/watch: version=4
-
- -- Andreas Tille <tille at debian.org> Wed, 16 Nov 2016 15:17:58 +0100
-
-r-cran-lambda.r (1.1.7-3) unstable; urgency=medium
-
- * Fix autopkgtest
- * cme fix dpkg-control
-
- -- Andreas Tille <tille at debian.org> Thu, 28 Apr 2016 11:40:24 +0200
-
-r-cran-lambda.r (1.1.7-2) unstable; urgency=medium
-
- * Package is arch all not any
- * debian/copyright:
- - fix cut-n-pasto
- - add location where the license is mentioned at ftpmaster request
-
- -- Andreas Tille <tille at debian.org> Thu, 28 May 2015 16:27:42 +0200
-
-r-cran-lambda.r (1.1.7-1) unstable; urgency=medium
-
- * Initial upload (Closes: #784887)
-
- -- Andreas Tille <tille at debian.org> Sat, 09 May 2015 08:52:18 +0200
diff --git a/debian/compat b/debian/compat
deleted file mode 100644
index f599e28..0000000
--- a/debian/compat
+++ /dev/null
@@ -1 +0,0 @@
-10
diff --git a/debian/control b/debian/control
deleted file mode 100644
index e03a510..0000000
--- a/debian/control
+++ /dev/null
@@ -1,24 +0,0 @@
-Source: r-cran-lambda.r
-Maintainer: Debian Med Packaging Team <debian-med-packaging at lists.alioth.debian.org>
-Uploaders: Andreas Tille <tille at debian.org>
-Section: gnu-r
-Priority: optional
-Build-Depends: debhelper (>= 10),
- r-base-dev,
- dh-r
-Standards-Version: 3.9.8
-Vcs-Browser: https://anonscm.debian.org/viewvc/debian-med/trunk/packages/R/r-cran-lambda.r/
-Vcs-Svn: svn://anonscm.debian.org/debian-med/trunk/packages/R/r-cran-lambda.r/
-Homepage: https://cran.r-project.org/package=lambda.r
-
-Package: r-cran-lambda.r
-Architecture: all
-Depends: ${misc:Depends},
- ${R:Depends}
-Recommends: ${R:Recommends}
-Suggests: ${R:Suggests}
-Description: GNU R modeling data with functional programming
- This GNU R package provides a language extension to efficiently write
- functional programs in R. Syntax extensions include multi-part function
- definitions, pattern matching, guard statements, built-in (optional)
- type safety.
diff --git a/debian/copyright b/debian/copyright
deleted file mode 100644
index 320cc00..0000000
--- a/debian/copyright
+++ /dev/null
@@ -1,18 +0,0 @@
-Format: https://www.debian.org/doc/packaging-manuals/copyright-format/1.0/
-Upstream-Contact: Brian Lee Yung Rowe <r at zatonovo.com>
-Upstream-Name: lambda.r
-Source: https://cran.r-project.org/package=lambda.r
-
-Files: *
-Copyright: 2010-2016 Brian Lee Yung Rowe <r at zatonovo.com>
-License: LGPL-3
-Comment: License is mentioned in the metadata of the file DESCRIPTION
- and at the download page mentioned above.
-
-Files: debian/*
-Copyright: 2015-2016 Andreas Tille <tille at debian.org>
-License: LGPL-3
-
-License: LGPL-3
- On Debian systems, the complete text of the GNU Lesser General Public
- License version 3 can be found in ‘/usr/share/common-licenses/LGPL-3’.
diff --git a/debian/docs b/debian/docs
deleted file mode 100644
index 960011c..0000000
--- a/debian/docs
+++ /dev/null
@@ -1,3 +0,0 @@
-tests
-debian/README.test
-debian/tests/run-unit-test
diff --git a/debian/patches/no_test_report_in_usr_lib_R_site-library.patch b/debian/patches/no_test_report_in_usr_lib_R_site-library.patch
deleted file mode 100644
index a95df07..0000000
--- a/debian/patches/no_test_report_in_usr_lib_R_site-library.patch
+++ /dev/null
@@ -1,27 +0,0 @@
-Author: Andreas Tille <tille at debian.org>
-Last-Update: Sat, 09 May 2015 08:52:18 +0200
-Description: The test suite tries to write an logfile in addition to the standard
- output to /usr/lib/R/site-library/lambda.r/unitTests/reportSummary.txt which
- is for sure permitted
-
---- a/tests/doRUnit.R
-+++ b/tests/doRUnit.R
-@@ -39,13 +39,13 @@ if(require("RUnit", quietly=TRUE)) {
- ## Report to stdout and text files
- cat("------------------- UNIT TEST SUMMARY ---------------------\n\n")
- printTextProtocol(tests, showDetails=FALSE)
-- printTextProtocol(tests, showDetails=FALSE,
-- fileName=paste(pathReport, "Summary.txt", sep=""))
-- printTextProtocol(tests, showDetails=TRUE,
-- fileName=paste(pathReport, ".txt", sep=""))
-+# printTextProtocol(tests, showDetails=FALSE,
-+# fileName=paste(pathReport, "Summary.txt", sep=""))
-+# printTextProtocol(tests, showDetails=TRUE,
-+# fileName=paste(pathReport, ".txt", sep=""))
-
- ## Report to HTML file
-- printHTMLProtocol(tests, fileName=paste(pathReport, ".html", sep=""))
-+## printHTMLProtocol(tests, fileName=paste(pathReport, ".html", sep=""))
-
- ## Return stop() to cause R CMD check stop in case of
- ## - failures i.e. FALSE to unit tests or
diff --git a/debian/patches/series b/debian/patches/series
deleted file mode 100644
index f389607..0000000
--- a/debian/patches/series
+++ /dev/null
@@ -1 +0,0 @@
-no_test_report_in_usr_lib_R_site-library.patch
diff --git a/debian/rules b/debian/rules
deleted file mode 100755
index 68d9a36..0000000
--- a/debian/rules
+++ /dev/null
@@ -1,4 +0,0 @@
-#!/usr/bin/make -f
-
-%:
- dh $@ --buildsystem R
diff --git a/debian/source/format b/debian/source/format
deleted file mode 100644
index 163aaf8..0000000
--- a/debian/source/format
+++ /dev/null
@@ -1 +0,0 @@
-3.0 (quilt)
diff --git a/debian/tests/control b/debian/tests/control
deleted file mode 100644
index a0a0edc..0000000
--- a/debian/tests/control
+++ /dev/null
@@ -1,3 +0,0 @@
-Tests: run-unit-test
-Depends: @, r-cran-survival
-Restrictions: allow-stderr
diff --git a/debian/tests/run-unit-test b/debian/tests/run-unit-test
deleted file mode 100644
index acf9dce..0000000
--- a/debian/tests/run-unit-test
+++ /dev/null
@@ -1,11 +0,0 @@
-#!/bin/sh -e
-
-pkg=r-cran-lambda.r
-if [ "$ADTTMP" = "" ] ; then
- ADTTMP=`mktemp -d /tmp/${pkg}-test.XXXXXX`
-fi
-cd $ADTTMP
-cp -a /usr/share/doc/${pkg}/tests/* $ADTTMP
-find . -name "*.gz" -exec gunzip \{\} \;
-LC_ALL=C R --no-save < doRUnit.R
-rm -fr $ADTTMP/*
diff --git a/debian/watch b/debian/watch
deleted file mode 100644
index 0aff824..0000000
--- a/debian/watch
+++ /dev/null
@@ -1,2 +0,0 @@
-version=4
-http://cran.r-project.org/src/contrib/lambda.r_([\d.-]*)\.tar.gz
diff --git a/inst/unitTests/runit.auto_replace.1.R b/inst/unitTests/runit.auto_replace.1.R
new file mode 100644
index 0000000..49f88be
--- /dev/null
+++ b/inst/unitTests/runit.auto_replace.1.R
@@ -0,0 +1,46 @@
+test.auto_replace.no_types_1a <- function() {
+ fib(0) %as% 2
+ fib(0) %as% 1
+ fib(1) %as% 1
+ fib(n) %as% { fib(n-1) + fib(n-2) }
+ seal(fib)
+
+ act <- fib(3)
+ checkEquals(act, 3)
+}
+
+test.auto_replace.no_types_1b <- function() {
+ fib(0) %as% 2
+ fib(0) %as% 1
+ fib(1) %as% 1
+ fib(n) %as% { fib(n-1) - fib(n-2) }
+ fib(n) %as% { fib(n-1) + fib(n-2) }
+ seal(fib)
+
+ act <- fib(3)
+ checkEquals(act, 3)
+}
+
+# Zero argument functions
+test.auto_replace.no_types_1c <- function() {
+ foo() %as% 2
+ foo() %as% 1
+ seal(foo)
+
+ act <- foo()
+ checkEquals(act, 1)
+}
+
+# Zero argument functions as part of a multipart definition
+test.auto_replace.no_types_1c <- function() {
+ foo(n) %as% n
+ foo() %as% 2
+ foo() %as% 1
+ seal(foo)
+
+ act <- foo()
+ checkEquals(act, 1)
+ act <- foo(5)
+ checkEquals(act, 5)
+}
+
diff --git a/inst/unitTests/runit.auto_replace.2.R b/inst/unitTests/runit.auto_replace.2.R
new file mode 100644
index 0000000..58da27e
--- /dev/null
+++ b/inst/unitTests/runit.auto_replace.2.R
@@ -0,0 +1,72 @@
+test.auto_replace.types_2a <- function() {
+ fib(n) %::% numeric : numeric
+ fib(0) %as% 1
+ fib(1) %as% 2
+ fib(n) %as% { fib(n-1) - fib(n-2) }
+ fib(n) %as% { fib(n-1) + fib(n-2) }
+
+ fib(n) %::% character : numeric
+ fib(n) %as% { fib(as.numeric(n)) }
+
+ fib(n) %::% numeric : numeric
+ fib(1) %as% 1
+ seal(fib)
+
+ act <- fib(3)
+ checkEquals(act, 3)
+ act <- fib("3")
+ checkEquals(act, 3)
+}
+
+test.auto_replace.types_2b <- function() {
+ fib() %::% numeric
+ fib() %as% 3
+
+ fib(n) %::% numeric : numeric
+ fib(0) %as% 1
+ fib(1) %as% 2
+ fib(n) %as% { fib(n-1) - fib(n-2) }
+ fib(n) %as% { fib(n-1) + fib(n-2) }
+ fib(n) %::% character : numeric
+ fib(n) %as% { fib(as.numeric(n)) }
+
+ fib(n) %::% numeric : numeric
+ fib(1) %as% 1
+
+ fib() %as% 5
+ seal(fib)
+
+ act <- fib(3)
+ checkEquals(act, 3)
+ act <- fib("3")
+ checkEquals(act, 3)
+ act <- fib()
+ checkEquals(act, 5)
+}
+
+test.auto_replace.types_2c <- function() {
+ fib() %::% numeric
+ fib() %as% 3
+ fib() %as% 5
+ seal(fib)
+
+ act <- fib()
+ checkEquals(act, 5)
+}
+
+test.auto_replace.types_2d <- function() {
+ fib() %::% numeric
+ fib() %as% 3
+
+ fib(n) %::% numeric : numeric
+ fib(n) %as% n
+
+ fib() %as% 5
+ seal(fib)
+
+ act <- fib()
+ checkEquals(act, 5)
+ act <- fib(4)
+ checkEquals(act, 4)
+}
+
diff --git a/inst/unitTests/runit.auto_replace.3.R b/inst/unitTests/runit.auto_replace.3.R
new file mode 100644
index 0000000..74967d4
--- /dev/null
+++ b/inst/unitTests/runit.auto_replace.3.R
@@ -0,0 +1,15 @@
+test.auto_replace_3 <- function() {
+ fib(0) %as% 2
+ fib(0) %as% 1
+ fib(1) %as% 1
+ fib(n=5) %as% { fib(n-1) - fib(n-2) }
+ fib(n=2) %as% { fib(n-1) + fib(n-2) }
+ seal(fib)
+
+ # These are failing
+ act <- fib(3)
+ checkEquals(act, 3)
+ act <- fib(2)
+ checkEquals(act, 2)
+}
+
diff --git a/inst/unitTests/runit.dispatching.1.R b/inst/unitTests/runit.dispatching.1.R
new file mode 100644
index 0000000..7dcd66f
--- /dev/null
+++ b/inst/unitTests/runit.dispatching.1.R
@@ -0,0 +1,102 @@
+test.dispatching_1a <- function() {
+ fib(0) %as% 1
+ fib(1) %as% 1
+ fib(n) %when% {
+ abs(n - round(n)) < .Machine$double.eps^0.5
+ } %as% {
+ fib(n-1) + fib(n-2)
+ }
+ seal(fib)
+
+ checkEquals(fib(5), 8)
+}
+
+test.dispatching_1b <- function() {
+ fib(n) %::% numeric : numeric
+ fib(0) %as% 1
+ fib(1) %as% 1
+ fib(n) %as% { fib(n-1) + fib(n-2) }
+ seal(fib)
+
+ act.1 <- fib(5)
+ checkEquals(act.1, 8)
+
+ act.2 <- tryCatch(fib("a"), error=function(x) 'error')
+ checkEquals(act.2, 'error')
+}
+
+test.dispatching_1c <- function() {
+ Integer(x) %as% x
+
+ fib(n) %::% Integer : Integer
+ fib(0) %as% Integer(1)
+ fib(1) %as% Integer(1)
+ fib(n) %as% { Integer(fib(n-1) + fib(n-2)) }
+ seal(Integer)
+ seal(fib)
+
+ checkEquals(fib(Integer(5)), Integer(8))
+
+ act <- tryCatch(fib(5), error=function(x) 'error')
+ checkEquals(act, 'error')
+}
+
+test.dispatching_1d <- function() {
+ abs_max(a,b) %::% numeric : numeric : numeric
+ abs_max(a,b) %when% {
+ a != b
+ } %as% {
+ pmax(abs(a), abs(b))
+ }
+
+ abs_max(a,b) %::% character : character : numeric
+ abs_max(a,b) %as%
+ {
+ abs_max(as.numeric(a), as.numeric(b))
+ }
+
+ abs_max(a) %as% { max(abs(a)) }
+ seal(abs_max)
+
+ checkEquals(abs_max(2,-3), 3)
+ checkEquals(abs_max("3","-4"), 4)
+
+ a <- c(1,2,5,6,3,2,1,3)
+ checkEquals(abs_max(a), 6)
+}
+
+
+test.different_names <- function() {
+ A(a) %as% { list(a=a) }
+ A(b) %as% { list(b=b) }
+ seal(A)
+
+ checkEquals(A(5)$a, 5)
+ checkEquals(A(a=5)$a, 5)
+ checkEquals(A(b=5)$b, 5)
+}
+
+test.empty_function <- function() {
+ a() %as% { }
+ seal(a)
+
+ b(a) %as% { }
+ seal(b)
+
+ # Empty functions will fail
+ checkException(a(), NULL)
+ checkException(b(1), NULL)
+}
+
+test.empty_type_constructor <- function() {
+ A() %as% { }
+ seal(A)
+
+ B(a) %as% { }
+ seal(B)
+
+ # Empty functions will fail
+ checkException(A(), NULL)
+ checkException(B(1), NULL)
+}
+
diff --git a/inst/unitTests/runit.ellipsis_arguments.1.R b/inst/unitTests/runit.ellipsis_arguments.1.R
new file mode 100644
index 0000000..d0c5227
--- /dev/null
+++ b/inst/unitTests/runit.ellipsis_arguments.1.R
@@ -0,0 +1,41 @@
+Prices(series, asset.class, periodicity) %as%
+{
+ series at asset.class <- asset.class
+ series at periodicity <- periodicity
+ series at visualize <- TRUE
+ series
+}
+
+visualize(x, ...) %when% {
+ x at visualize == TRUE
+} %as% {
+ plot(x, ...)
+}
+seal(Prices)
+seal(visualize)
+
+dummy(x, ...) %as% { list(...) }
+seal(dummy)
+
+
+test.ellipsis_arguments_1 <- function() {
+ ps <- Prices(rnorm(50), 'equity', 'daily')
+ visualize(ps, main='Prices', xlab='time')
+
+ scatter <- matrix(rnorm(200), ncol=2)
+ act <- tryCatch(visualize(scatter), error=function(x) 'error')
+ checkEquals(act, 'error')
+
+ attr(scatter,'visualize') <- TRUE
+ visualize(scatter)
+
+ visualize(scatter, main='random')
+}
+
+test.ellipsis_unnamed_arguments <- function() {
+ act <- dummy(1,2)
+ checkEquals(act, list(2))
+
+ act <- dummy(1,2,3,4)
+ checkEquals(act, list(2,3,4))
+}
diff --git a/inst/unitTests/runit.ellipsis_arguments.2.R b/inst/unitTests/runit.ellipsis_arguments.2.R
new file mode 100644
index 0000000..97da07e
--- /dev/null
+++ b/inst/unitTests/runit.ellipsis_arguments.2.R
@@ -0,0 +1,15 @@
+# :vim set filetype=R
+regress(formula, ..., na.action=na.fail) %as% {
+ lm(formula, ..., na.action=na.action)
+}
+seal(regress)
+
+test.ellipsis_arguments_2 <- function() {
+ ctl <- c(4.17,5.58,5.18,6.11,4.50,4.61,5.17,4.53,5.33,5.14)
+ trt <- c(4.81,4.17,4.41,3.59,5.87,3.83,6.03,4.89,4.32,4.69)
+ data <- data.frame(group=gl(2,10,20,labels=c("Ctl","Trt")), weight=c(ctl, trt))
+ lm.1 <- regress(weight ~ group, data=data)
+ lm.2 <- regress(data=data, formula=weight ~ group)
+ checkTrue(all(lm.2$coefficients == lm.1$coefficients))
+ checkTrue(all(lm.2$residuals == lm.1$residuals))
+}
diff --git a/inst/unitTests/runit.examples.R b/inst/unitTests/runit.examples.R
new file mode 100644
index 0000000..eb2b448
--- /dev/null
+++ b/inst/unitTests/runit.examples.R
@@ -0,0 +1,13 @@
+test.example_1 <- function()
+{
+ reciprocal(x) %::% numeric : numeric
+ reciprocal(x) %when% { x != 0 } %as% { 1 / x }
+ reciprocal(x) %::% character : numeric
+ reciprocal(x) %as% { reciprocal(as.numeric(x)) }
+
+ act <- reciprocal(4)
+ checkEquals(act, 0.25)
+
+ act <- reciprocal("4")
+ checkEquals(act, 0.25)
+}
diff --git a/inst/unitTests/runit.factorial.1.R b/inst/unitTests/runit.factorial.1.R
new file mode 100644
index 0000000..5d4fbf5
--- /dev/null
+++ b/inst/unitTests/runit.factorial.1.R
@@ -0,0 +1,11 @@
+test.factorial_1 <- function() {
+ fac(0) %as% 1
+ fac(n) %when% { n > 0 } %as% { n * fac(n - 1) }
+ seal(fac)
+
+ checkEquals(fac(1), 1)
+ checkEquals(fac(5), 120)
+
+ act <- tryCatch(fac(-1), error=function(x) 'error')
+ checkEquals(act, 'error')
+}
diff --git a/inst/unitTests/runit.factorial.2.R b/inst/unitTests/runit.factorial.2.R
new file mode 100644
index 0000000..0a986de
--- /dev/null
+++ b/inst/unitTests/runit.factorial.2.R
@@ -0,0 +1,18 @@
+test.factorial_2 <- function() {
+ WholeNumber(x) %when% { x > 0 } %as% x
+
+ fac(n) %::% WholeNumber : WholeNumber
+ fac(0) %as% WholeNumber(1)
+ fac(n) %when% { n > 0 } %as% { n * fac(n - 1) }
+
+ fac(n) %::% numeric : WholeNumber
+ fac(n) %as% fac(WholeNumber(n))
+
+ checkEquals(fac(WholeNumber(1)), WholeNumber(1))
+ checkEquals(fac(WholeNumber(5)), WholeNumber(120))
+ checkEquals(fac(1), WholeNumber(1))
+ checkEquals(fac(5), WholeNumber(120))
+
+ act <- tryCatch(fac(-1), error=function(x) 'error')
+ checkEquals(act, 'error')
+}
diff --git a/inst/unitTests/runit.fill_args.R b/inst/unitTests/runit.fill_args.R
new file mode 100644
index 0000000..6cee926
--- /dev/null
+++ b/inst/unitTests/runit.fill_args.R
@@ -0,0 +1,47 @@
+#act <- tryCatch(fib(3), error=function(x) 'error')
+#checkEquals(act, 'error')
+
+test.type_fill_args_1 <- function() {
+ mysum(x, y, ...) %as% { (x - y) * sum(...) }
+ seal(mysum)
+
+ act <- mysum(2, 3, 1, 2, 3)
+ checkEquals(act, -6)
+
+ act <- mysum(x=2, 3, 1, 2, 3)
+ checkEquals(act, -6)
+
+ act <- mysum(2, y=3, 1, 2, 3)
+ checkEquals(act, -6)
+
+ act <- mysum(y=3, x=2, 1, 2, 3)
+ checkEquals(act, -6)
+
+ act <- mysum(y=3, 1, 2, 3, x=2)
+ checkEquals(act, -6)
+
+ act <- mysum(2, 1, 2, 3, y=3)
+ checkEquals(act, -6)
+}
+
+test.type_fill_args_2 <- function() {
+ mysum(x, y=3, ...) %as% { (x - y) * sum(...) }
+ seal(mysum)
+
+ act <- mysum(2, 1, 1, 2, 3)
+ checkEquals(act, -7)
+
+ act <- mysum(1, y=2, 1, 1, 2, 3)
+ checkEquals(act, -7)
+
+ act <- mysum(y=2, x=1, 1, 1, 2, 3)
+ checkEquals(act, -7)
+
+ act <- mysum(1, 1, 2, 3, x=2)
+ checkEquals(act, -7)
+
+ act <- mysum(1, 1, 1, 2, 3, y=2)
+ checkEquals(act, -7)
+}
+
+
diff --git a/inst/unitTests/runit.function_args.1.R b/inst/unitTests/runit.function_args.1.R
new file mode 100644
index 0000000..2c960a6
--- /dev/null
+++ b/inst/unitTests/runit.function_args.1.R
@@ -0,0 +1,27 @@
+test.function_args_1 <- function() {
+ f() %as% 1
+ seal(f)
+ act <- f()
+ checkEquals(act,1)
+}
+
+test.function_args_2 <- function() {
+ f() %::% numeric
+ f() %as% 1
+ seal(f)
+ act <- f()
+ checkEquals(act,1)
+}
+
+test.function_args_3 <- function() {
+ f() %::% numeric
+ f() %as% 1
+ f(a) %::% numeric : numeric
+ f(a) %as% a
+ seal(f)
+
+ act <- f()
+ checkEquals(act,1)
+ act <- f(3)
+ checkEquals(act,3)
+}
diff --git a/inst/unitTests/runit.function_type.1.R b/inst/unitTests/runit.function_type.1.R
new file mode 100644
index 0000000..1488b8b
--- /dev/null
+++ b/inst/unitTests/runit.function_type.1.R
@@ -0,0 +1,15 @@
+test.function_type_1 <- function() {
+ seq.gen(start) %::% a : Function
+ seq.gen(start) %as%
+ {
+ value <- start - 1
+ function() {
+ value <<- value + 1
+ return(value)
+ }
+ }
+ seal(seq.gen)
+
+ act <- seq.gen(1)
+ checkTrue('function' %in% class(act))
+}
diff --git a/inst/unitTests/runit.heaviside_step.1.R b/inst/unitTests/runit.heaviside_step.1.R
new file mode 100644
index 0000000..29612a4
--- /dev/null
+++ b/inst/unitTests/runit.heaviside_step.1.R
@@ -0,0 +1,10 @@
+test.heaviside_1 <- function() {
+ h.step(n) %when% { n < 0 } %as% { 0 }
+ h.step(0) %as% 0.5
+ h.step(n) %as% 1
+ seal(h.step)
+
+ checkTrue(h.step(-1) == 0)
+ checkTrue(h.step(0) == 0.5)
+ checkTrue(h.step(1) == 1)
+}
diff --git a/inst/unitTests/runit.heaviside_step.2.R b/inst/unitTests/runit.heaviside_step.2.R
new file mode 100644
index 0000000..30f31b8
--- /dev/null
+++ b/inst/unitTests/runit.heaviside_step.2.R
@@ -0,0 +1,13 @@
+test.heaviside_2 <- function() {
+ h.step(n) %::% numeric : numeric
+ h.step(n) %when% { n < 0 } %as% { 0 }
+ h.step(0) %as% 0.5
+ h.step(n) %as% 1
+ seal(h.step)
+
+ checkEquals(h.step(-1), 0)
+ checkEquals(h.step(0), 0.5)
+ checkEquals(h.step(1), 1)
+ # TODO: This throws an error in the shell but not via RUnit
+ #checkException(h.step("a"))
+}
diff --git a/inst/unitTests/runit.optional_arguments.1.R b/inst/unitTests/runit.optional_arguments.1.R
new file mode 100644
index 0000000..2f2267d
--- /dev/null
+++ b/inst/unitTests/runit.optional_arguments.1.R
@@ -0,0 +1,87 @@
+# vim: set filetype=R
+
+test.optional_arguments_1a <- function() {
+ Prices(series, asset.class='equity', periodicity='daily') %as% {
+ series at asset.class <- asset.class
+ series at periodicity <- periodicity
+ series
+ }
+
+ returns(x) %when% {
+ x at asset.class == "equity"
+ x at periodicity == "daily"
+ } %as% {
+ x[2:length(x)] / x[1:(length(x) - 1)] - 1
+ }
+ seal(Prices)
+ seal(returns)
+
+ ps <- Prices(abs(rnorm(50)))
+ checkEquals(attr(ps,'asset.class'), 'equity')
+ checkEquals(attr(ps,'periodicity'), 'daily')
+
+ ps <- Prices(abs(rnorm(50)), 'fx')
+ checkEquals(attr(ps,'asset.class'), 'fx')
+ checkEquals(attr(ps,'periodicity'), 'daily')
+
+ ps <- Prices(abs(rnorm(50)), periodicity='monthly')
+ checkEquals(attr(ps,'asset.class'), 'equity')
+ checkEquals(attr(ps,'periodicity'), 'monthly')
+
+ ps <- Prices(periodicity='monthly', series=abs(rnorm(50)))
+ checkEquals(attr(ps,'asset.class'), 'equity')
+ checkEquals(attr(ps,'periodicity'), 'monthly')
+
+ err <- tryCatch(returns(ps), error=function(x) 'error')
+ checkEquals(err, 'error')
+
+ ps <- Prices(abs(rnorm(50)))
+ checkEquals(length(returns(ps)), length(ps) - 1)
+
+}
+
+
+test.optional_arguments_1b <- function() {
+ Temperature(x, system='metric', units='celsius') %as% {
+ x at system <- system
+ x at units <- units
+ x
+ }
+
+ freezing(x) %::% Temperature : logical
+ freezing(x) %when% {
+ x at system == 'metric'
+ x at units == 'celsius'
+ } %as% {
+ if (x < 0) { TRUE }
+ else { FALSE }
+ }
+
+ freezing(x) %when% {
+ x at system == 'metric'
+ x at units == 'kelvin'
+ } %as% {
+ if (x < 273) { TRUE }
+ else { FALSE }
+ }
+ seal(Temperature)
+ seal(freezing)
+
+ ctemp <- Temperature(20)
+ checkTrue(! freezing(ctemp))
+
+ ktemp <- Temperature(20, units='kelvin')
+ checkTrue(freezing(ktemp))
+}
+
+
+test.optional_arguments_1c <- function() {
+ avg(x, fun=mean) %as% { fun(x) }
+
+ a <- 1:4
+ a.mean <- avg(a)
+ checkEquals(a.mean, 2.5)
+
+ a.med <- avg(a, median)
+ checkEquals(a.med, 2.5)
+}
diff --git a/inst/unitTests/runit.optional_arguments.2.R b/inst/unitTests/runit.optional_arguments.2.R
new file mode 100644
index 0000000..99cd0bb
--- /dev/null
+++ b/inst/unitTests/runit.optional_arguments.2.R
@@ -0,0 +1,43 @@
+# vim: set filetype=R
+
+test.optional_arguments_no_args <- function()
+{
+ f(name='ROOT') %as% 1
+ seal(f)
+ checkEquals(f(), 1)
+ checkEquals(f('a'), 1)
+}
+
+test.optional_arguments_no_args_type_constraint <- function()
+{
+ f(name) %::% character : numeric
+ f(name='ROOT') %as% 1
+ seal(f)
+ checkEquals(f(), 1)
+ checkEquals(f('a'), 1)
+}
+
+test.optional_arguments_function <- function()
+{
+ f(x, y=runif(5)) %as% { x + y }
+ seal(f)
+ act <- f(1)
+ checkTrue(length(act) == 5)
+}
+
+test.optional_arguments_function_named <- function()
+{
+ f(y=runif(5), x) %as% { x + y }
+ seal(f)
+ act <- f(x=1)
+ checkTrue(length(act) == 5)
+}
+
+test.optional_arguments_reference_var <- function()
+{
+ f(y=min(x), x) %as% { x + y }
+ seal(f)
+ act <- f(x=1:5)
+ checkTrue(length(act) == 5)
+ checkEquals(act, 2:6)
+}
diff --git a/inst/unitTests/runit.parse_transforms.1.R b/inst/unitTests/runit.parse_transforms.1.R
new file mode 100644
index 0000000..63ca248
--- /dev/null
+++ b/inst/unitTests/runit.parse_transforms.1.R
@@ -0,0 +1,22 @@
+test.parse_transforms_1 <- function() {
+ Prices(series) %as%
+ {
+ series at asset.class <- 'equity'
+ series at periodicity <- 'daily'
+ series
+ }
+
+ returns(x) %when% {
+ x at asset.class == "equity"
+ x at periodicity == "daily"
+ } %as% {
+ x[2:length(x)] / x[1:(length(x) - 1)] - 1
+ }
+
+ ps <- Prices(rnorm(50))
+ checkEquals(attr(ps,'asset.class'), 'equity')
+ checkEquals(attr(ps,'periodicity'), 'daily')
+
+ rs <- returns(ps)
+ checkEquals(length(rs), length(ps) - 1)
+}
diff --git a/inst/unitTests/runit.parse_transforms.2.R b/inst/unitTests/runit.parse_transforms.2.R
new file mode 100644
index 0000000..bc07d2d
--- /dev/null
+++ b/inst/unitTests/runit.parse_transforms.2.R
@@ -0,0 +1,22 @@
+Temperature(x, system, units) %as%
+{
+ x at system <- system
+ x at units <- units
+ x
+}
+
+freezing(x) %when% {
+ x at system == 'metric'
+ x at units == 'celsius'
+} %as% {
+ if (x < 0) { TRUE }
+ else { FALSE }
+}
+
+test.parse_transforms_2 <- function() {
+ temp <- Temperature(20, 'metric', 'celsius')
+ checkEquals(attr(temp,'system'), 'metric')
+ checkEquals(attr(temp,'units'), 'celsius')
+
+ checkTrue(! freezing(temp))
+}
diff --git a/inst/unitTests/runit.parse_transforms.3.R b/inst/unitTests/runit.parse_transforms.3.R
new file mode 100644
index 0000000..3ecc923
--- /dev/null
+++ b/inst/unitTests/runit.parse_transforms.3.R
@@ -0,0 +1,27 @@
+WishartModel(n,m,Q,sd) %as% {
+ x <- list()
+ x at n <- n
+ x at m <- m
+ x at Q <- Q
+ x at sd <- sd
+ x
+}
+
+WishartMatrix(x, model) %as% {
+ x at n <- model at n
+ x at m <- model at m
+ x at Q <- model at Q
+ x at sd <- model at sd
+ x
+}
+
+
+test.parse_transforms_3 <- function() {
+ model <- WishartModel(10,20,2,1)
+ mat <- WishartMatrix(rnorm(10), model)
+
+ checkEquals(attr(mat,'n'), 10)
+ checkEquals(attr(mat,'m'), 20)
+ checkEquals(attr(mat,'Q'), 2)
+ checkEquals(attr(mat,'sd'),1)
+}
diff --git a/inst/unitTests/runit.pattern_matching.R b/inst/unitTests/runit.pattern_matching.R
new file mode 100644
index 0000000..9ae6812
--- /dev/null
+++ b/inst/unitTests/runit.pattern_matching.R
@@ -0,0 +1,29 @@
+# :vim set filetype=R
+
+test.pattern_null <- function()
+{
+ fold(f, x, acc) %as% acc
+ fold(f, NULL, acc) %as% acc
+
+ act <- fold(function(x,y) x + y, NULL, 5)
+ checkEquals(5, act)
+}
+
+test.pattern_na <- function()
+{
+ fold(f, x, acc) %as% acc
+ fold(f, NA, acc) %as% acc
+
+ act <- fold(function(x,y) x + y, NA, 5)
+ checkEquals(5, act)
+}
+
+test.pattern_empty <- function()
+{
+ fold(f, EMPTY, acc) %as% acc
+ fold(f,x,acc) %as% { fold(f,x[-1], f(x[1],acc)) }
+ plus <- function(x,y) x + y
+
+ act <- fold(plus, 1:5, 0)
+ checkEquals(15, act)
+}
diff --git a/inst/unitTests/runit.taylor_series.1.R b/inst/unitTests/runit.taylor_series.1.R
new file mode 100644
index 0000000..7e99e4e
--- /dev/null
+++ b/inst/unitTests/runit.taylor_series.1.R
@@ -0,0 +1,41 @@
+compare <- function(a,b, xs) {
+ plot(xs, a(xs), type='l')
+ lines(xs, b(xs), type='l', col='blue')
+ invisible()
+}
+
+# f <- taylor(sin, pi)
+# xs <- seq(2,4.5,0.02)
+# compare(sin,f, xs)
+#
+# p <- function(x) x^4 + 3 * (x-2)^3 - 2 * x^2 + 1
+# p1 <- function(x) 4*x^3 + 9*(x-2)^2 - 4*x
+# p2 <- function(x) 12*x^2 + 18*(x-2) - 4
+# p3 <- function(x) 24*x + 18
+#
+# f <- taylor(p, 1)
+# xs <- seq(-5,5,0.02)
+# compare(p,f, xs)
+#
+# f(x) ~ f(a) + f'(a) * (x - a) + f''(a) / 2! * (x - a)^2 + ...
+test.taylor_series_1 <- function() {
+ seal(fac)
+ fac(1) %as% 1
+ fac(n) %when% { n > 0 } %as% { n * fac(n - 1) }
+
+ # TODO: Implement this properly for k > 2
+ d(f, 1, h=10^-9) %as% function(x) { (f(x + h) - f(x - h)) / (2*h) }
+ d(f, 2, h=10^-9) %as% function(x) { (f(x + h) - 2*f(x) + f(x - h)) / h^2 }
+
+ taylor(f, a, step=2) %as% taylor(f, a, step, 1, function(x) f(a))
+ taylor(f, a, 0, k, g) %as% g
+ taylor(f, a, step, k, g) %as% {
+ df <- d(f,k)
+ g1 <- function(x) { g(x) + df(a) * (x - a)^k / fac(k) }
+ taylor(f, a, step-1, k+1, g1)
+ }
+
+ f <- taylor(sin, pi)
+ v <- f(3.1)
+ checkEquals(v, sin(3.1), tolerance=0.01)
+}
diff --git a/inst/unitTests/runit.type_any_type.R b/inst/unitTests/runit.type_any_type.R
new file mode 100644
index 0000000..684df90
--- /dev/null
+++ b/inst/unitTests/runit.type_any_type.R
@@ -0,0 +1,38 @@
+test.type_any_type_1 <- function() {
+ fib(n) %::% . : a
+ fib(0) %as% 1
+ fib(1) %as% 1
+ fib(n) %as% { fib(n-1) + fib(n-2) }
+ seal(fib)
+
+ act <- fib(4)
+ checkEquals(act, 5)
+}
+
+test.type_any_type_2 <- function() {
+ hypotenuse(a,b) %::% . : . : numeric
+ hypotenuse(a,b) %as% { (a^2 + b^2)^.5 }
+ seal(hypotenuse)
+
+ act <- hypotenuse(3,4)
+ checkEquals(act,5)
+}
+
+test.type_any_type_3 <- function() {
+ hypotenuse(a,b) %::% numeric : numeric: .
+ hypotenuse(a,b) %as% { (a^2 + b^2)^.5 }
+ seal(hypotenuse)
+
+ act <- hypotenuse(3,4)
+ checkEquals(act,5)
+}
+
+test.type_any_type_4 <- function() {
+ hypotenuse(a,b) %::% a : a: .
+ hypotenuse(a,b) %as% { (a^2 + b^2)^.5 }
+ seal(hypotenuse)
+
+ act <- hypotenuse(3,4)
+ checkEquals(act,5)
+}
+
diff --git a/inst/unitTests/runit.type_ellipsis.R b/inst/unitTests/runit.type_ellipsis.R
new file mode 100644
index 0000000..b376ec6
--- /dev/null
+++ b/inst/unitTests/runit.type_ellipsis.R
@@ -0,0 +1,48 @@
+#act <- tryCatch(fib(3), error=function(x) 'error')
+#checkEquals(act, 'error')
+
+test.type_ellipsis_1 <- function() {
+ ioc(f, ...) %::% Function : ... : .
+ ioc(f, ...) %as% f(...)
+ seal(ioc)
+
+ act <- ioc(sum, 1, 2, 3)
+ checkEquals(act, 6)
+}
+
+test.type_ellipsis_2 <- function() {
+ ioc(f, ...) %::% Function : ... : numeric
+ ioc(f, ...) %as% f(...)
+ seal(ioc)
+
+ act <- ioc(sum, 1, 2, 3)
+ checkEquals(act, 6)
+}
+
+test.type_ellipsis_3 <- function() {
+ mysum(x, ...) %::% a : ... : numeric
+ mysum(x, ...) %as% sum(...)
+ seal(mysum)
+
+ act <- mysum('foo', 1, 2, 3)
+ checkEquals(act, 6)
+}
+
+test.type_ellipsis_4 <- function() {
+ mysum(..., x) %::% ... : logical : numeric
+ mysum(..., x) %as% sum(..., na.rm=x)
+ seal(mysum)
+
+ act <- mysum(1, 2, 3, x=TRUE)
+ checkEquals(act, 6)
+}
+
+test.type_ellipsis_var_1 <- function() {
+ mysum(..., x) %::% numeric... : logical : numeric
+ mysum(..., x) %as% sum(..., na.rm=x)
+ seal(mysum)
+
+ act <- mysum(1, 2, 3, x=FALSE)
+ checkEquals(act, 6)
+}
+
diff --git a/inst/unitTests/runit.type_functions.R b/inst/unitTests/runit.type_functions.R
new file mode 100644
index 0000000..7eda97b
--- /dev/null
+++ b/inst/unitTests/runit.type_functions.R
@@ -0,0 +1,61 @@
+test.zero <- function() {
+ zero() %::% Function
+ zero() %as% { function() 1 }
+
+ act <- zero()
+ checkEquals(act(), 1)
+}
+
+test.one_application <- function() {
+ fn.0 <- function() 0
+
+ one_application(x) %::% Function : numeric
+ one_application(x) %as% { x() }
+
+ act <- one_application(fn.0)
+ checkEquals(act, 0)
+}
+
+test.one_identity <- function() {
+ fn.0 <- function() 0
+
+ one_identity(x) %::% Function : Function
+ one_identity(x) %as% { x }
+
+ act <- one_identity(fn.0)
+ checkEquals(act, fn.0)
+}
+
+test.two_application <- function() {
+ fn.1 <- function(x) x
+
+ two_application(x,y) %::% Function : numeric : numeric
+ two_application(x,y) %as% { x(y) }
+
+ two_application(y,x) %::% numeric : Function : numeric
+ two_application(y,x) %as% { x(y) }
+
+ act <- two_application(fn.1,2)
+ checkEquals(act, 2)
+
+ act <- two_application(4,fn.1)
+ checkEquals(act, 4)
+}
+
+test.two_identity <- function() {
+ fn.0 <- function() 0
+ fn.1 <- function(x) x
+
+ two_identity(x,y) %::% Function : numeric : Function
+ two_identity(x,y) %as% { x }
+
+ two_identity(y,x) %::% numeric : Function : Function
+ two_identity(y,x) %as% { x }
+
+ act <- two_identity(fn.0, 1)
+ checkEquals(act, fn.0)
+
+ act <- two_identity(2, fn.1)
+ checkEquals(act, fn.1)
+}
+
diff --git a/inst/unitTests/runit.type_inheritance.R b/inst/unitTests/runit.type_inheritance.R
new file mode 100644
index 0000000..042a143
--- /dev/null
+++ b/inst/unitTests/runit.type_inheritance.R
@@ -0,0 +1,114 @@
+
+
+test.inheritance_one_arg <- function() {
+ Base(x) %as% x
+ A(x) %as% { Base(x) }
+ B(x) %as% { A(x) }
+ E(x) %as% { Base(x) }
+
+ one.arg(x) %::% A : character
+ one.arg(x) %as% { "a" }
+
+ one.arg(x) %::% Base : character
+ one.arg(x) %as% { "base" }
+
+ seal(Base)
+ seal(A)
+ seal(B)
+ seal(E)
+ seal(one.arg)
+
+ a <- A(1)
+ b <- B(2)
+ c <- E(3)
+ act.a <- one.arg(a)
+ checkEquals(act.a, "a")
+ act.b <- one.arg(b)
+ checkEquals(act.b, "a")
+ act.c <- one.arg(c)
+ checkEquals(act.c, "base")
+}
+
+test.inheritance_two_arg <- function() {
+ Base(x) %as% x
+ A(x) %as% { Base(x) }
+ B(x) %as% { A(x) }
+ E(x) %as% { Base(x) }
+
+ two.arg(x,y) %::% A : B : character
+ two.arg(x,y) %as% { "a" }
+
+ two.arg(x,y) %::% Base : Base : character
+ two.arg(x,y) %as% { "base" }
+
+ seal(Base)
+ seal(A)
+ seal(B)
+ seal(E)
+ seal(two.arg)
+
+ a <- A(1)
+ b <- B(2)
+ c <- E(3)
+ act.a <- two.arg(a,b)
+ checkEquals(act.a, "a")
+ act.b <- two.arg(b,b)
+ checkEquals(act.b, "a")
+ act.c <- two.arg(c,b)
+ checkEquals(act.c, "base")
+}
+
+
+test.inheritance_with_type_variable <- function() {
+ Base(x) %as% x
+ A(x) %as% { Base(x) }
+ B(x) %as% { A(x) }
+ E(x) %as% { Base(x) }
+
+ two.arg(x,y) %::% a : B : character
+ two.arg(x,y) %as% { "a" }
+
+ two.arg(x,y) %::% Base : Base : character
+ two.arg(x,y) %as% { "base" }
+
+ seal(Base)
+ seal(A)
+ seal(B)
+ seal(E)
+ seal(two.arg)
+
+ a <- A(1)
+ b <- B(2)
+ c <- E(3)
+ act.a <- two.arg(a,b)
+ checkEquals(act.a, "a")
+ act.b <- two.arg(b,b)
+ checkEquals(act.b, "a")
+ act.c <- two.arg(c,b)
+ checkEquals(act.c, "a")
+}
+
+
+test.inheritance_with_ellipsis_1 <- function() {
+ Base(x, ...) %as% list(x=x, ...)
+ A(x, z) %as% { Base(x, z=z) }
+
+ seal(Base)
+ seal(A)
+
+ a <- A(1, 2)
+ checkEquals(a$x, 1)
+ checkEquals(a$z, 2)
+}
+
+test.inheritance_with_ellipsis_2 <- function() {
+ Base(x=1, ...) %as% list(x=x, ...)
+ A(z) %as% { Base(z=z) }
+
+ seal(Base)
+ seal(A)
+
+ a <- A(2)
+ checkEquals(a$x, 1)
+ checkEquals(a$z, 2)
+}
diff --git a/inst/unitTests/runit.type_integer_inheritance.R b/inst/unitTests/runit.type_integer_inheritance.R
new file mode 100644
index 0000000..d354048
--- /dev/null
+++ b/inst/unitTests/runit.type_integer_inheritance.R
@@ -0,0 +1,51 @@
+test.type_integer_1 <- function() {
+ fib(n) %::% numeric : numeric
+ fib(0) %as% 1
+ fib(1) %as% 1
+ fib(n) %as% { fib(n-1) + fib(n-2) }
+ seal(fib)
+
+ act <- fib(3)
+ checkEquals(act, 3)
+}
+
+test.type_integer_2 <- function() {
+ fib(n) %::% numeric : numeric
+ fib(0) %as% 1
+ fib(1) %as% 1
+ fib(n) %as% { fib(n-1) + fib(n-2) }
+ seal(fib)
+
+ act <- fib(as.integer(3))
+ checkEquals(act, 3)
+}
+
+test.type_integer_5 <- function() {
+ fib(n) %::% numeric : numeric
+ fib(0) %as% as.integer(1)
+ fib(1) %as% as.integer(1)
+ fib(n) %as% { as.integer(fib(n-1) + fib(n-2)) }
+ seal(fib)
+
+ act <- fib(as.integer(3))
+ checkEquals(act, 3)
+}
+
+test.type_integer_3 <- function() {
+ hypotenuse(a,b) %::% numeric : numeric : numeric
+ hypotenuse(a,b) %as% { (a^2 + b^2)^.5 }
+ seal(hypotenuse)
+
+ act <- hypotenuse(as.integer(3),4)
+ checkEquals(act,5)
+}
+
+test.type_integer_4 <- function() {
+ hypotenuse(a,b) %::% numeric : numeric : numeric
+ hypotenuse(a,b) %as% { (a^2 + b^2)^.5 }
+ seal(hypotenuse)
+
+ act <- hypotenuse(as.integer(3), as.integer(4))
+ checkEquals(act,5)
+}
+
diff --git a/inst/unitTests/runit.type_variable.1.R b/inst/unitTests/runit.type_variable.1.R
new file mode 100644
index 0000000..593bd58
--- /dev/null
+++ b/inst/unitTests/runit.type_variable.1.R
@@ -0,0 +1,79 @@
+test.type_variable_1 <- function() {
+ fib(n) %::% a : a
+ fib(0) %as% 1
+ fib(1) %as% 1
+ fib(n) %as% { fib(n-1) + fib(n-2) }
+ seal(fib)
+
+ #act <- tryCatch(f(2,3), error=function(x) 'error')
+ #checkEquals(act, 'error')
+ act <- fib(3)
+ checkEquals(act, 3)
+}
+
+# This is not working from the shell but works interactively
+ignore.type_variable_2 <- function() {
+ fib(n) %::% b : a
+ fib(0) %as% 1
+ fib(1) %as% 1
+ fib(n) %as% { fib(n-1) + fib(n-2) }
+ seal(fib)
+
+ act <- tryCatch(f(2), error=function(x) 'error')
+ cat("\ntest.type_variable_2: act =",act,"\n")
+ checkEquals('error', act)
+}
+
+# This is not working from the shell but works interactively
+ignore.type_variable_3 <- function() {
+ fib(n) %::% a : b
+ fib(0) %as% 1
+ fib(1) %as% 1
+ fib(n) %as% { fib(n-1) + fib(n-2) }
+ seal(fib)
+
+ act <- tryCatch(f(2), error=function(x) 'error')
+ checkEquals('error', act)
+}
+
+test.type_variable_4 <- function() {
+ hypotenuse(a,b) %::% a : a : a
+ hypotenuse(a,b) %as% { (a^2 + b^2)^.5 }
+ seal(hypotenuse)
+
+ #act <- tryCatch(f(2), error=function(x) 'error')
+ #checkEquals(act, 'error')
+ act <- hypotenuse(3,4)
+ checkEquals(act,5)
+}
+
+test.type_variable_5 <- function() {
+ hypotenuse(a,b) %::% a : b : a
+ hypotenuse(a,b) %as% { (a^2 + b^2)^.5 }
+ seal(hypotenuse)
+
+ act <- tryCatch(hypotenuse(5,12), error=function(x) 'error')
+ checkEquals(act, 'error')
+}
+
+test.type_variable_6 <- function() {
+ hypotenuse(a,b) %::% a : a : b
+ hypotenuse(a,b) %as% { (a^2 + b^2)^.5 }
+ seal(hypotenuse)
+
+ act <- tryCatch(hypotenuse(5,12), error=function(x) 'error')
+ checkEquals(act, 'error')
+}
+
+test.mixed_type_variable_1 <- function() {
+ Point(x,y) %as% list(x=x,y=y)
+ distance(a,b) %::% Point : Point : z
+ distance(a,b) %as% { ((a$x - b$x)^2 + (a$y - b$y)^2)^.5 }
+ seal(distance)
+
+ point.1 <- Point(2, 2)
+ point.2 <- Point(1, 1)
+
+ act <- distance(point.1, point.2)
+ checkEquals(act, sqrt(2))
+}
diff --git a/inst/unitTests/runit.types.1.R b/inst/unitTests/runit.types.1.R
new file mode 100644
index 0000000..57760f4
--- /dev/null
+++ b/inst/unitTests/runit.types.1.R
@@ -0,0 +1,66 @@
+# vim: set filetype=R
+
+test.types_1 <- function() {
+ A(x) %as% x
+ B(x) %as% x
+
+ f(a,b) %::% A : B : numeric
+ f(a,0) %when% { a < 5; a > 0 } %as% { z <- a + 2; unclass(z * 2) }
+ f(a,b) %when% { a < 0 } %as% { unclass(abs(a) + b) }
+ f(a,b) %as% { unclass(a + b) }
+
+ seal(A)
+ seal(B)
+ seal(f)
+
+ act.1 <- tryCatch(f(2,3), error=function(x) 'error')
+ cat("[test.types_1] act.1 =",act.1,"\n")
+ checkEquals(act.1, 'error')
+ a <- A(2)
+ b <- B(3)
+ act.2 <- f(a,b)
+ checkEquals(act.2, 5)
+}
+
+
+test.types_2.1 <- function() {
+ Point(x,y) %as% list(x=x,y=y)
+ Polar(r,theta) %as% list(r=r,theta=theta)
+
+ distance(a,b) %::% Point : Point : numeric
+ distance(a,b) %as% { ((a$x - b$x)^2 + (a$y - b$y)^2)^.5 }
+
+ distance(a,b) %::% Polar : Polar : numeric
+ distance(a,b) %as%
+ {
+ (a$r^2 + b$r^2 - 2 * a$r * b$r * cos(a$theta - b$theta))^.5
+ }
+ seal(Point)
+ seal(Polar)
+ seal(distance)
+
+ point.1 <- Point(2,3)
+ point.2 <- Point(5,7)
+ checkEquals(distance(point.1,point.2), 5)
+}
+
+test.types_2.2 <- function() {
+ Point(x,y) %as% list(x=x,y=y)
+ Polar(r,theta) %as% list(r=r,theta=theta)
+
+ distance(a,b) %::% Point : Point : numeric
+ distance(a,b) %as% { ((a$x - b$x)^2 + (a$y - b$y)^2)^.5 }
+
+ distance(a,b) %::% Polar : Polar : numeric
+ distance(a,b) %as%
+ {
+ (a$r^2 + b$r^2 - 2 * a$r * b$r * cos(a$theta - b$theta))^.5
+ }
+ seal(Point)
+ seal(Polar)
+ seal(distance)
+
+ point.3 <- Polar(3,pi/2)
+ point.4 <- Polar(4,pi)
+ checkEquals(distance(point.3,point.4), 5)
+}
diff --git a/man/UseFunction.Rd b/man/UseFunction.Rd
new file mode 100644
index 0000000..3a95326
--- /dev/null
+++ b/man/UseFunction.Rd
@@ -0,0 +1,57 @@
+\name{UseFunction}
+\alias{UseFunction}
+\alias{NewObject}
+\title{Primary dispatcher for functional programming }
+\description{UseFunction manages the dispatching for multipart functions in
+lambda.r. This is used internally by lambda.r.}
+\usage{
+UseFunction(fn, fn.name, ...)
+NewObject(type.fn, type.name, ...)
+}
+\arguments{
+ \item{fn}{The function reference that is being applied}
+ \item{fn.name}{The name of a function that uses functional dispatching. This
+ is just the name of the function being defined}
+ \item{type.fn}{The function representing the type constructor}
+ \item{type.name}{The name of the type}
+ \item{\dots}{The arguments that are passed to dispatched functions }
+}
+\details{
+ This function is used internally and generally does not need to be called
+ by an end user.
+}
+\value{
+ Returns the value of the dispatched function
+}
+\author{ Brian Lee Yung Rowe }
+
+\seealso{
+\code{\link{\%as\%}}
+}
+\examples{
+# Note that these are trivial examples for pedagogical purposes. Due to their
+# trivial nature, most of these examples can be implemented more concisely
+# using built-in R features.
+
+
+reciprocal(x) \%::\% numeric : numeric
+reciprocal(x) \%when\% {
+ x != 0
+} \%as\% {
+ 1 / x
+}
+
+reciprocal(x) \%::\% character : numeric
+reciprocal(x) \%as\% {
+ reciprocal(as.numeric(x))
+}
+
+seal(reciprocal)
+
+print(reciprocal)
+reciprocal(4)
+reciprocal("4")
+
+}
+\keyword{ methods }
+\keyword{ programming }
diff --git a/man/duck.Rd b/man/duck.Rd
new file mode 100644
index 0000000..905ff6f
--- /dev/null
+++ b/man/duck.Rd
@@ -0,0 +1,50 @@
+\name{duck-typing}
+\alias{\%isa\%}
+\alias{\%hasa\%}
+\alias{\%hasall\%}
+\title{Functions for duck typing}
+\description{Duck typing is a way to emulate type checking by virtue of an
+object's characteristics as opposed to strong typing.}
+\usage{
+argument \%isa\% type
+argument \%hasa\% property
+argument \%hasall\% property
+
+}
+\arguments{
+ \item{argument}{An object to inspect}
+ \item{type}{A type name}
+ \item{property}{A property of an object}
+}
+\details{
+ These operators provide a convenient method for testing for specific
+ properties of an object.
+
+ \code{\%isa\%} checks if an object is of the given type.
+
+ \code{\%hasa\%} checks if an object has a given property. This can
+ be any named element of a list or data.frame.
+}
+\value{
+ Boolean value indicating whether the specific test is true or not.
+}
+\author{ Brian Lee Yung Rowe }
+
+\seealso{
+\code{\link{\%as\%}}
+}
+\examples{
+5 \%isa\% numeric
+
+Point(r,theta, 'polar') \%as\% {
+ o <- list(r=r,theta=theta)
+ o at system <- 'polar'
+ o
+}
+
+p <- Point(5, pi/2, 'polar')
+p %hasa% theta
+
+}
+\keyword{ methods }
+\keyword{ programming }
diff --git a/man/framework.Rd b/man/framework.Rd
new file mode 100644
index 0000000..481f5fa
--- /dev/null
+++ b/man/framework.Rd
@@ -0,0 +1,109 @@
+\name{\%as\%}
+\alias{\%as\%}
+\alias{\%::\%}
+\alias{EMPTY}
+\alias{seal}
+\title{Define functions and type constructors in lambda.r}
+\description{The \%as\% function is used in place of the
+assignment operator for defining functions and type constructors
+with lambda.r. The \%as\% operator is the gateway to a
+full suite of advanced functional programming features.}
+\usage{
+signature \%::\% types
+signature \%as\% body
+seal(fn)
+}
+\arguments{
+ \item{signature}{The function signature for the function to be defined}
+ \item{types}{The type constraints for the function}
+ \item{body}{The body of the function}
+ \item{fn}{The function to seal}
+}
+\details{
+ The \%as\% and \%::\% operators are the primary touch points with lambda.r.
+
+ Functions are defined using \%as\% notation. Any block of code can be in the
+ function definition. For simple criteria, pattern matching of literals can
+ be used directly in lambda.r. Executing different function clauses within a
+ multipart function sometimes requires more detail than simple pattern
+ matching. For these scenarios a guard statement is used to define the
+ condition for execution. Guards are simply an additional clause in the
+ function definition defined by the \%when\% operator.
+
+ \code{ fib(n) \%when\% { n >= 0 } \%as\% { fib(n-1) + fib(n-2) } }
+
+ A function variant only executes if the guard statements all evaluate to true.
+ As many guard statements as desired can be added in the block. Just separate
+ them with either a new line or a semi-colon.
+
+ Type constructors are no different from regular functions with one exception:
+ the function name must start with a capital letter. In lambda.r, types are
+ defined in PascalCase and functions are lower case. Violating this rule will
+ result in undefined behavior. The return value of the type constructor is the
+ object that represents the type. It will have the type attached to the object.
+
+ \code{ Number(x, set='real') \%as\% {
+ x at set <- set
+ x
+ }}
+
+ Attributes can be accessed using lambda.r's at-notation, which borrows from
+ S4's member notation. These attributes are standard R attributes and should
+ not be confused with object properties. Hence with lambda.r it is possible to
+ use both the $ to access named elements of lists and data.frames while using
+ the @ symbol to access the object's attributes.
+
+ Type constraints specify the type of each input argument in addition to the
+ return type. Using this approach ensures that the arguments can only have
+ compatible types when the function is called. The final type in the
+ constraint is the return type, which is checked after a function is called.
+ If the result does not have the correct return type, then the call will fail.
+ Each type is separated by a colon and their order is defined by the order of
+ the function clause signature.
+
+ Each function clause can have its own type constraint. Once a constraint is
+ defined, it will continue to be valid until another type constraint is
+ defined.
+
+ 'seal' finalizes a function definition. Any new statements found will reset
+ the definition, effectively deleting it. This is useful to prevent other
+ people from accidentally modifying your function definition.
+}
+\value{
+ The defined functions are invisibly returned.
+}
+\author{ Brian Lee Yung Rowe }
+
+\examples{
+# Type constraints are optional and include the return type as the
+# final type
+reciprocal(x) \%::\% numeric : numeric
+reciprocal(0) \%as\% stop("Division by 0 not allowed")
+
+# The type constraint is still valid for this function clause
+reciprocal(x) \%when\% {
+ # Guard statements can be added in succession
+ x != 0
+ # Attributes can be accessed using '@' notation
+ is.null(x at dummy.attribute)
+} \%as\% {
+ # This is the body of the function clause
+ 1 / x
+}
+
+# This new type constraint applies from this point on
+reciprocal(x) \%::\% character : numeric
+reciprocal(x) \%as\% {
+ reciprocal(as.numeric(x))
+}
+
+# Seal the function so no new definitions are allowed
+seal(reciprocal)
+
+print(reciprocal)
+reciprocal(4)
+reciprocal("4")
+
+}
+\keyword{ methods }
+\keyword{ programming }
diff --git a/man/introspection.Rd b/man/introspection.Rd
new file mode 100644
index 0000000..a7d9528
--- /dev/null
+++ b/man/introspection.Rd
@@ -0,0 +1,73 @@
+\name{introspection}
+\alias{describe}
+\alias{debug.lr}
+\alias{undebug.lr}
+\alias{undebug.all}
+\alias{is.debug}
+\alias{which.debug}
+\alias{print.lambdar.fun}
+\alias{print.lambdar.type}
+\title{Introspection for lambda.r}
+\description{These tools are used for debugging and provide a means of examining
+the evaluation order of the function definitions as well as provide a lambda.r
+compatible debugger.}
+\usage{
+debug.lr(x)
+
+undebug.lr(x)
+
+is.debug(fn.name)
+
+which.debug()
+
+undebug.all()
+
+describe(\dots)
+\method{print}{lambdar.fun}(x, \dots)
+\method{print}{lambdar.type}(x, \dots)
+}
+\arguments{
+ \item{x}{The function}
+ \item{fn.name}{The name of the function}
+ \item{\dots}{Additional arguments}
+}
+\details{
+ For a basic description of the function it is easiest to just type the
+ function name in the shell. This will call the print methods and print a
+ clean output of the function definition. The definition is organized based
+ on each function clause. If a type constraint exists, this precedes the
+ clause signature including guards. To reduce clutter, the actual body of the
+ function clause is not printed. To view a clause body, each clause is
+ prefixed with an index number, which can be used in the \code{describe}
+ function to get a full listing of the function.
+
+ \code{describe(fn, idx)}
+
+ The 'debug.lr' and 'undebug.lr' functions are replacements for the built-in
+ debug and undebug functions. They provide a mechanism to debug a complete
+ function, which is compatible with the dispatching in lambda.r. The semantics
+ are identical to the built-ins. Note that these functions will properly
+ handle non-lambda.r functions so only one set of commands need to be
+ issued.
+
+ Lambda.r keeps track of all functions that are being debugged. To see
+ if a function is currently set for debugging, use the \code{is.debug}
+ function. To see all functions that are being debugged, use
+ \code{which.debug}. It is possible to undebug all debugged functions
+ by calling \code{undebug.all}.
+}
+\value{
+ The defined functions are invisibly returned.
+}
+\author{ Brian Lee Yung Rowe }
+
+\examples{
+\dontrun{
+f(x) %as% x
+debug.lr(f)
+which.debug()
+undebug.lr(f)
+}
+}
+\keyword{ methods }
+\keyword{ programming }
diff --git a/man/lambda.r-package.Rd b/man/lambda.r-package.Rd
new file mode 100644
index 0000000..fc73ac3
--- /dev/null
+++ b/man/lambda.r-package.Rd
@@ -0,0 +1,395 @@
+\name{lambda.r-package}
+\alias{lambda.r-package}
+\alias{lambda.r}
+\docType{package}
+\title{
+Modeling Data with Functional Programming
+}
+\description{
+Lambda.r is a language extension that supports a functional programming
+style in R. As an alternative to the object-oriented systems,
+lambda.r offers a functional syntax for defining types and functions.
+Functions can be defined with multiple distinct function clauses
+similar to how multipart mathematical functions are defined.
+There is also support for pattern matching and guard expressions to
+finely control function dispatching, all the while still
+supporting standard features of R. Lambda.r also introduces its own
+type system with intuitive type constructors are and
+type constraints that can optionally be added to function definitions.
+Attributes are also given the attention they deserve with a clean
+and convenient syntax that reduces type clutter.
+}
+\details{
+\tabular{ll}{
+Package: \tab lambda.r\cr
+Type: \tab Package\cr
+Version: \tab 1.1.9\cr
+Date: \tab 2016-07-10\cr
+License: \tab LGPL-3\cr
+LazyLoad: \tab yes\cr
+}
+Data analysis relies so much on mathematical operations, transformations,
+and computations that a functional approach is better suited for these
+types of applications. The reason is that object models rarely make sense in
+data analysis since so many transformations are applied to data sets. Trying to
+define classes and attach methods to them results in a futile enterprise rife
+with arbitrary choices and hierarchies. Functional programming avoids this
+unnecessary quandry by making objects and functions first class and preserving
+them as two distinct entities.
+
+R provides many functional programming concepts mostly inherited from
+Scheme. Concepts like first class functions and lazy evaluation are
+key components to a functional language, yet R lacks some of the more
+advanced features of modern functional programming languages.
+Lambda.r introduces a syntax for writing applications using a
+declarative notation that facilitates reasoning about your program
+in addition to making programs modular and easier to maintain.
+
+
+\subsection{Function Definition}{
+Functions are defined using the \code{\%as\%} symbol in place of \code{<-}.
+Simple functions can be defined as simply as
+\preformatted{f(x) \%as\% x }
+and can be called like any other function.
+\preformatted{f(1) }
+
+Functions that have a more complicated body require braces.
+\preformatted{f(x) \%as\% { 2 * x }
+
+g(x, y) \%as\% {
+ z <- x + y
+ sqrt(z)
+}
+}
+
+\subsection{Multipart functions and guards}{
+Many functions are defined in multiple parts. For example absolute value
+is typically defined in two parts: one covering negative numbers and one
+covering everything else. Using guard expressions and the \code{\%when\%}
+keyword, these parts can be easily captured.
+\preformatted{abs(x) \%when\% { x < 0 } \%as\% -x
+abs(x) \%as\% x
+}
+
+Any number of guard expressions can be in a guard block, such that all
+guard expressions must evaluate to true.
+\preformatted{abs(x) \%when\% {
+ is.numeric(x)
+ length(x) == 1
+ x < 0
+} \%as\% -x
+
+abs(x) \%when\% {
+ is.numeric(x)
+ length(x) == 1
+} \%as\% x
+}
+
+If a guard is not satisfied, then the next clause is tried. If no
+function clauses are satisfied, then an error is thrown.
+}
+
+\subsection{Pattern matching}{
+Simple scalar values can be specified in a function definition in
+place of a variable name. These scalar values become patterns that
+must be matched exactly in order for the function clause to execute.
+This syntactic technique is known as pattern matching.
+
+Recursive functions can be defined simply using pattern matching.
+For example the famed Fibonacci sequence can be defined recursively.
+\preformatted{fib(0) \%as\% 1
+fib(1) \%as\% 1
+fib(n) \%as\% { fib(n-1) + fib(n-2) }
+}
+This is also useful for conditionally executing a function.
+The reason you would do this is that it becomes easy to symbolically
+transform the code, making it easier to reason about.
+\preformatted{pad(x, length, TRUE) \%as\% c(rep(NA,length), x)
+pad(x, length, FALSE) \%as\% x
+}
+
+It is also possible to match on \code{NULL} and \code{NA}.
+\preformatted{sizeof(NULL) \%as\% 0
+sizeof(x) \%as\% length(x)
+}
+}
+
+}
+
+\subsection{Types}{
+A type is a custom data structure with meaning. Formally a type is
+defined by its type constructor, which codifies how to create objects
+of the given type. The lambda.r type system is fully compatible with
+the built-in S3 system. Types in lambda.r must start with a
+capital letter.
+
+\subsection{Type constructors}{
+A type constructor is responsible for creating objects of a given type.
+This is simply a function that has the name of the type. So to
+create a type \code{Point} create its type constructor.
+\preformatted{Point(x,y) \%as\% list(x=x,y=y) }
+Note that any built-in data structure can be used as a base type.
+Lambda.r simply extends the base type with additional type information.
+
+Types are then created by calling their type constructor.
+\preformatted{p <- Point(3,4)}
+
+To check whether an object is of a given type, use the \code{\%isa\%}
+operator. \preformatted{p \%isa\% Point}
+}
+
+\subsection{Type constraints}{
+Once a type is defined, it can be used to limit execution of a
+function. R is a dynamically typed language, but with type constraints
+it is possible to add static typing to certain functions. S4 does
+the same thing, albeit in a more complicated manner.
+
+Suppose we want to define a distance function for \code{Point}.
+Since it is only meaningful for \code{Point}s we do not want to
+execute it for other types. This is achieved by using a type constraint,
+which declares the function argument types as well as the
+type of the return value. Type constraints are defined by declaring the
+function signature followed by type arguments. \preformatted{distance(a,b) \%::\% Point : Point : numeric
+distance(a,b) \%as\% { sqrt((b$x - a$x)^2 + (b$y - a$y)^2) }}
+With this type constraint \code{distance} will only be called if both arguments
+are of type \code{Point}. After the function is applied, a further
+requirement is that the return value must be of type \code{numeric}.
+Otherwise lambda.r will throw an error.
+Note that it is perfectly legal to mix and match lambda.r types with
+S3 types in type constraints.
+
+}
+
+\subsection{Type variables}{
+Declaring types explicitly gives a lot of control, but it also
+limits the natural polymorphic properties of R functions.
+Sometimes all that is needed is to define the relationship
+between arguments. These relationships can be captured by
+a type variable, which is simply any single lower case letter
+in a type constraint.
+
+In the distance example, suppose we do not want to restrict the
+function to just \code{Point}s, but whatever type is used must
+be consistent for both arguments. In this case a type variable is
+sufficient. \preformatted{distance(a,b) \%::\% z : z : numeric
+distance(a,b) \%as\% { sqrt((b$x - a$x)^2 + (b$y - a$y)^2) }}
+The letter \code{z} was used to avoid confusion with the names of
+the arguments, although it would have been just as valid to use
+\code{a}.
+
+Type constraints and type variables can be applied to any lambda.r
+function, including type constructors.
+}
+
+\subsection{The ellipsis type}{
+The ellipsis can be inserted in a type constraint. This has interesting
+properties as the ellipsis represents a set of arguments. To specify
+that input values should be captured by the ellipsis, use \code{...} within
+the type constraint. For example, suppose you want a function that
+multiplies the sum of a set of numbers. The ellipsis type tells
+lambda.r to bind the types associated with the ellipsis type.
+
+\preformatted{sumprod(x, ..., na.rm=TRUE) \%::\% numeric : ... : logical : numeric
+sumprod(x, ..., na.rm=TRUE) \%as\% { x * sum(..., na.rm=na.rm) }
+
+> sumprod(4, 1,2,3,4)
+[1] 40}
+
+Alternatively, suppose you want all the values bound to the ellipsis
+to be of a certain type. Then you can append ```...``` to a concrete
+type.
+
+\preformatted{sumprod(x, ..., na.rm=TRUE) \%::\% numeric : numeric... : logical : numeric
+sumprod(x, ..., na.rm=TRUE) \%as\% { x * sum(..., na.rm=na.rm) }
+
+> sumprod(4, 1,2,3,4)
+[1] 40
+> sumprod(4, 1,2,3,4,'a')
+Error in UseFunction(sumprod, "sumprod", ...) :
+ No valid function for 'sumprod(4,1,2,3,4,a)' }
+
+If you want to preserve polymorphism but still constrain values bound
+to the ellipsis to a single type, you can use a type variable. Note that
+the same rules for type variables apply. Hence a type variable represents
+a type that is not specified elsewhere.
+
+\preformatted{sumprod(x, ..., na.rm=TRUE) \%::\% a : a... : logical : a
+sumprod(x, ..., na.rm=TRUE) \%as\% { x * sum(..., na.rm=na.rm) }
+
+> sumprod(4, 1,2,3,4)
+[1] 40
+> sumprod(4, 1,2,3,4,'a')
+Error in UseFunction(sumprod, "sumprod", ...) :
+ No valid function for 'sumprod(4,1,2,3,4,a)' }
+
+}
+
+\subsection{The don't-care type}{
+Sometimes it is useful to ignore a specific type in a constraint. Since
+we are not inferring all types in a program, this is an acceptable
+action. Using the ```.``` within a type constraint tells lambda.r to not
+check the type for the given argument.
+
+For example in \code{f(x, y) \%::\% . : numeric : numeric}, the type of
+\code{x} will not be checked.
+
+}
+
+}
+
+\subsection{Attributes}{
+The attribute system in R is a vital, yet often overlooked feature.
+This orthogonal data structure is essentially a list attached to
+any object. The benefit of using attributes is that it reduces
+the need for types since it is often simpler to reuse existing
+data structures rather than create new types.
+
+Suppose there are two kinds of \code{Point}s: those defined as
+Cartesian coordinates and those as Polar coordinates. Rather than
+create a type hierarchy, you can attach an attribute to the object.
+This keeps the data clean and separate from meta-data that only
+exists to describe the data.
+\preformatted{Point(r,theta, 'polar') \%as\% {
+ o <- list(r=r,theta=theta)
+ o at system <- 'polar'
+ o
+}
+
+Point(x,y, 'cartesian') \%as\% {
+ o <- list(x=x,y=y)
+ o at system <- 'cartesian'
+ o
+}
+}
+
+Then the \code{distance} function can be defined according to the
+coordinate system.
+\preformatted{distance(a,b) \%::\% z : z : numeric
+distance(a,b) \%when\% {
+ a at system == 'cartesian'
+ b at system == 'cartesian'
+} \%as\% {
+ sqrt((b$x - a$x)^2 + (b$y - a$y)^2)
+}
+
+distance(a,b) \%when\% {
+ a at system == 'polar'
+ b at system == 'polar'
+} \%as\% {
+ sqrt(a$r^2 + b$r^2 - 2 * a$r * b$r * cos(a$theta - b$theta))
+}
+}
+Note that the type constraint applies to both function clauses.
+
+}
+
+\subsection{Debugging}{
+As much as we would like, our code is not perfect. To help
+troubleshoot any problems that exist, lambda.r provides hooks into
+the standard debugging system. Use \code{debug.lr} as a drop-in
+replacement for \code{debug} and \code{undebug.lr} for \code{undebug}.
+In addition to being aware of multipart functions, lambda.r's
+debugging system keeps track of what is being debugged, so you can
+quickly determine which functions are being debugged. To see
+which functions are currently marked for debugging, call
+\code{which.debug}. Note that if you use \code{debug.lr} for
+all debugging then lambda.r will keep track of all debugging in
+your R session. Here is a short example demonstrating this.
+\preformatted{> f(x) \%as\% x
+> debug.lr(f)
+> debug.lr(mean)
+>
+> which.debug()
+[1] "f" "mean"
+}
+}
+
+}
+\note{
+Stable releases are uploaded to CRAN about once a year. The most recent
+package is always available on github [2] and can be installed via
+`rpackage` in `crant` [3].
+\preformatted{rpackage https://github.com/zatonovo/lambda.r/archive/master.zip
+}
+}
+\author{
+Brian Lee Yung Rowe
+
+Maintainer: Brian Lee Yung Rowe <r at zatonovo.com>
+}
+\references{
+[1] Blog posts on lambda.r: http://cartesianfaith.com/category/r/lambda-r/
+
+[2] Lambda.r source code, https://github.com/muxspace/lambda.r
+
+[3] Crant, https://github.com/muxspace/crant
+}
+\keyword{ package }
+\keyword{ programming }
+\seealso{
+\code{\link{\%as\%}}, \code{\link{describe}}, \code{\link{debug.lr}},
+\code{\link{\%isa\%}}
+}
+\examples{
+is.wholenumber <-
+ function(x, tol = .Machine$double.eps^0.5) abs(x - round(x)) < tol
+
+## Use built in types for type checking
+fib(n) \%::\% numeric : numeric
+fib(0) \%as\% 1
+fib(1) \%as\% 1
+fib(n) \%when\% {
+ is.wholenumber(n)
+} \%as\% {
+ fib(n-1) + fib(n-2)
+}
+
+fib(5)
+
+
+## Using custom types
+Integer(x) \%when\% { is.wholenumber(x) } \%as\% x
+
+fib.a(n) \%::\% Integer : Integer
+fib.a(0) \%as\% Integer(1)
+fib.a(1) \%as\% Integer(1)
+fib.a(n) \%as\% { Integer(fib.a(n-1) + fib.a(n-2)) }
+
+fib.a(Integer(5))
+
+
+## Newton-Raphson optimization
+converged <- function(x1, x0, tolerance=1e-6) abs(x1 - x0) < tolerance
+minimize <- function(x0, algo, max.steps=100)
+{
+ step <- 0
+ old.x <- x0
+ while (step < max.steps)
+ {
+ new.x <- iterate(old.x, algo)
+ if (converged(new.x, old.x)) break
+ old.x <- new.x
+ }
+ new.x
+}
+
+iterate(x, algo) \%::\% numeric : NewtonRaphson : numeric
+iterate(x, algo) \%as\% { x - algo$f1(x) / algo$f2(x) }
+
+iterate(x, algo) \%::\% numeric : GradientDescent : numeric
+iterate(x, algo) \%as\% { x - algo$step * algo$f1(x) }
+
+NewtonRaphson(f1, f2) \%as\% list(f1=f1, f2=f2)
+GradientDescent(f1, step=0.01) \%as\% list(f1=f1, step=step)
+
+
+fx <- function(x) x^2 - 4
+f1 <- function(x) 2*x
+f2 <- function(x) 2
+
+algo <- NewtonRaphson(f1,f2)
+minimize(3, algo)
+
+algo <- GradientDescent(f1, step=0.1)
+minimize(3, algo)
+}
diff --git a/tests/doRUnit.R b/tests/doRUnit.R
new file mode 100644
index 0000000..aec8158
--- /dev/null
+++ b/tests/doRUnit.R
@@ -0,0 +1,60 @@
+# From http://rwiki.sciviews.org/doku.php?id=developers:runit
+## unit tests will not be done if RUnit is not available
+if(require("RUnit", quietly=TRUE)) {
+
+ ## --- Setup ---
+
+ pkg <- "lambda.r" # <-- Change to name!
+ if(Sys.getenv("RCMDCHECK") == "FALSE") {
+ ## Path to unit tests for standalone running under Makefile (not R CMD check)
+ ## PKG/tests/../inst/unitTests
+ path <- file.path(getwd(), "..", "inst", "unitTests")
+ } else {
+ ## Path to unit tests for R CMD check
+ ## PKG.Rcheck/tests/../PKG/unitTests
+ path <- system.file(package=pkg, "unitTests")
+ }
+ cat("\nRunning unit tests\n")
+ print(list(pkg=pkg, getwd=getwd(), pathToUnitTests=path))
+
+ library(package=pkg, character.only=TRUE)
+
+ ## If desired, load the name space to allow testing of private functions
+ ## if (is.element(pkg, loadedNamespaces()))
+ ## attach(loadNamespace(pkg), name=paste("namespace", pkg, sep=":"), pos=3)
+ ##
+ ## or simply call PKG:::myPrivateFunction() in tests
+
+ ## --- Testing ---
+
+ ## Define tests
+ testSuite <- defineTestSuite(name=paste(pkg, "unit testing"),
+ dirs=path)
+ ## Run
+ tests <- runTestSuite(testSuite)
+
+ ## Default report name
+ pathReport <- file.path(path, "report")
+
+ ## Report to stdout and text files
+ cat("------------------- UNIT TEST SUMMARY ---------------------\n\n")
+ printTextProtocol(tests, showDetails=FALSE)
+ printTextProtocol(tests, showDetails=FALSE,
+ fileName=paste(pathReport, "Summary.txt", sep=""))
+ printTextProtocol(tests, showDetails=TRUE,
+ fileName=paste(pathReport, ".txt", sep=""))
+
+ ## Report to HTML file
+ printHTMLProtocol(tests, fileName=paste(pathReport, ".html", sep=""))
+
+ ## Return stop() to cause R CMD check stop in case of
+ ## - failures i.e. FALSE to unit tests or
+ ## - errors i.e. R errors
+ tmp <- getErrors(tests)
+ if(tmp$nFail > 0 | tmp$nErr > 0) {
+ stop(paste("\n\nunit testing failed (#test failures: ", tmp$nFail,
+ ", #R errors: ", tmp$nErr, ")\n\n", sep=""))
+ }
+} else {
+ warning("cannot run unit tests -- package RUnit is not available")
+}
--
Alioth's /usr/local/bin/git-commit-notice on /srv/git.debian.org/git/debian-med/r-cran-lambda.r.git
More information about the debian-med-commit
mailing list