Repository: zatonovo/lambda.r
Branch: master
Commit: e19c763bdb43
Files: 45
Total size: 100.2 KB
Directory structure:
gitextract_s3t02gl3/
├── .Rbuildignore
├── .gitignore
├── .travis.yml
├── DESCRIPTION
├── NAMESPACE
├── R/
│ ├── duck.R
│ ├── framework.R
│ ├── introspection.R
│ └── objects.R
├── README.md
├── man/
│ ├── UseFunction.Rd
│ ├── duck.Rd
│ ├── framework.Rd
│ ├── introspection.Rd
│ └── lambda.r-package.Rd
└── tests/
├── test-all.R
└── testit/
├── test-auto_replace.1.R
├── test-auto_replace.2.R
├── test-auto_replace.3.R
├── test-dispatching.1.R
├── test-ellipsis_arguments.1.R
├── test-ellipsis_arguments.2.R
├── test-examples.R
├── test-factorial.1.R
├── test-factorial.2.R
├── test-fill_args.R
├── test-function_args.1.R
├── test-function_type.1.R
├── test-heaviside_step.1.R
├── test-heaviside_step.2.R
├── test-infix.1.R
├── test-optional_arguments.1.R
├── test-optional_arguments.2.R
├── test-parse_transforms.1.R
├── test-parse_transforms.2.R
├── test-parse_transforms.3.R
├── test-pattern_matching.R
├── test-taylor_series.1.R
├── test-type_any_type.R
├── test-type_ellipsis.R
├── test-type_functions.R
├── test-type_inheritance.R
├── test-type_integer_inheritance.R
├── test-type_variable.1.R
└── test-types.1.R
================================================
FILE CONTENTS
================================================
================================================
FILE: .Rbuildignore
================================================
^.*\.Rproj$
^\.Rproj\.user$
^rename$
^\.gitignore$
^README.md$
^LICENSE$
^tools$
^.travis.yml$
================================================
FILE: .gitignore
================================================
.RData
# History files
.Rhistory
# Example code in package build process
*-Ex.R
================================================
FILE: .travis.yml
================================================
language: r
cache: packages
r:
- oldrel
- release
- devel
================================================
FILE: DESCRIPTION
================================================
Package: lambda.r
Type: Package
Title: Modeling Data with Functional Programming
Version: 1.2.4
Date: 2019-09-15
Depends: R (>= 3.0.0)
Imports: formatR
Suggests: testit
Author: Brian Lee Yung Rowe
Maintainer: Brian Lee Yung Rowe <r@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
URL: https://github.com/zatonovo/lambda.r
BugReports: https://github.com/zatonovo/lambda.r/issues
================================================
FILE: NAMESPACE
================================================
importFrom("utils", "capture.output", "getParseData", "str", "tail")
importFrom("formatR", "tidy_source")
export("%as%")
export("%:=%")
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%")
================================================
FILE: R/duck.R
================================================
'%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))
}
================================================
FILE: R/framework.R
================================================
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, keep.parse.data=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_infix(raw)
if (is.null(args_expr)) {
args_expr <- parse_fun(it)
} else {
fast_forward(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, keep.parse.data=os$keep.parse.data)
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, keep.parse.data=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)
raw$text <- sub("%:=%","%as%", raw$text, fixed=TRUE)
it <- iterator(raw)
tree <- list(args=NULL)
args_expr <- parse_infix(raw)
if (is.null(args_expr)) {
args_expr <- parse_fun(it)
} else {
fast_forward(it, c('%as%','%when%'))
}
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, keep.parse.data=TRUE)
invisible()
}
'%:=%' <- `%as%`
################################## 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, ...)
{
# If user has added more definitions, attempt to access it
fn <- tryCatch(get_lr(fn.name), error=function(e) fn)
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, dump=FALSE)
{
if (dump) return(tree[idx:nrow(tree),])
if (rewind) idx <<- idx - 1
else idx <<- idx + 1
if (idx < cap) tree[idx,]
else NULL
}
}
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
}
fast_forward <- function(it, what) {
while (!is.null(line <- it()) && ! line$text %in% what) { }
it(rewind=TRUE)
}
parse_infix <- function(raw) {
raw <- raw[raw$token != 'expr' & raw$terminal,]
raw <- raw[1:nrow(raw) < which(raw$text %in% c('%as%','%::%','%when%'))[1],]
if (! identical(raw$token, c('SYMBOL','SPECIAL','SYMBOL'))) return(NULL)
fn.name <- raw$text[raw$token=='SPECIAL']
arg.name <- raw$text[raw$token=='SYMBOL']
data.frame(paren.level=c(0,1,1),
node=c('function.name','argument','argument'),
token=c(fn.name,arg.name),
pattern=NA, default=NA, stringsAsFactors=FALSE)
}
# 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.null(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.null(line <- it()) && line$token != "SPECIAL") next
if (line$text == '%when%')
{
line <- it()
if (line$token != "'{'")
stop("Guard missing opening block")
while (!is.null(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.null(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@attribute to attr(object,'attribute')
# f(x) %when% { x@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) { grepl('^[A-Z]', fn.string) }
is.infix <- function(fn.string) { grepl('^%[^%]+%$', fn.string) }
parse_body <- function(it)
{
body <- NULL
# Skip until we get to the
while (!is.null(line <- it()) && line$token != "SPECIAL") next
if (line$text == '%as%')
{
needs.wrapping <- FALSE
while (!is.null(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 <- tidy_source(
text=sprintf("function(%s) { %s }", arg.string, body),
indent=2, output=FALSE)
eval(parse(text=fn.string), where)
}
parse_types <- function(it, args, sig)
{
types <- NULL
while (!is.null(line <- it()) && line$token != "SPECIAL") next
if (line$text == '%::%')
{
while (!is.null(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 if (is.infix(name)) {
pattern <- 'function(...) UseFunction(`%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.null(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()
}
get_lr <- function(fn.name) {
fn <- NULL
frames <- sys.frames()
n <- length(frames)
while (n > 0) {
fn <- get0(fn.name, frames[[n]], inherits=FALSE)
if (! is.null(fn)) return(fn)
n <- n - 1
}
get(fn.name)
}
================================================
FILE: R/introspection.R
================================================
describe(fn, idx, raw=FALSE) %when% { raw } %:=% {
class(fn) <- NULL
print(fn)
}
describe(fn, idx) %when% {
idx > 0
} %:=% {
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,"%:=% ...\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,"%:=% ...\n")
}
sapply(1:length(variants),fn)
invisible()
}
================================================
FILE: R/objects.R
================================================
MissingReturnType <- "MissingReturnType"
================================================
FILE: README.md
================================================
[](https://travis-ci.org/zatonovo/lambda.r)
Description
===========
Provides a syntax for writing functional programs in R. Lambda.r has a clean
syntax for defining multi-part functions with optional guard statements.
Simple pattern matching is also supported. Types can be
easily defined and instantiated using the same functional notation. Type
checking is integrated and optional, giving the programmer complete flexibility
over their application or package.
Basic Usage
===========
Defining a function
-------------------
Functions are defined using `%as%` notation. Any block of code can be in the
function definition.
```R
fib(n) %as% { fib(n-1) + fib(n-2) }
```
Pattern matching
----------------
Multi-part function definitions are easily constructed. For simple criteria,
pattern matching of literals can be used directly in lambda.r.
```R
fib(0) %as% 1
fib(1) %as% 1
```
Strings can also be pattern matched within definitions.
Guard statements
----------------
Executing different function variants within a multi-part 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.
```R
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.
```R
fib(n) %when% {
is.numeric(n)
n >= 0
} %as% { fib(n-1) + fib(n-2) }
```
Note that in the above example the type check can be handled using a type
declaration, which is discussed below.
For functions defined in multiple parts, each separate function variant is
evaluated in the same order as they are defined. Hence a less restrictive
variant that evaluates to true defined early in the chain of function
definitions will take precedence over variants defined later. (If you are
following along in sequence, the pattern matches for `fib(0)` and `fib(1)` will
never be called since the first definition `fib(n)` will always evaulate to true).
Types
=====
Lambda.R introduces types as an alternative to classes. Types are data
structures with type information attached to it. Like classes, constructors
exist for types and one type can inherit from another type. The difference is
that types do not have embedded methods. In functional programming, functions
are first class so there is no need to embed them within the data structure.
Using types provides type safety, which means that a function variant will only
execute if the types are correct.
Defining a type
---------------
Types are defined by defining their constructor. We define constructors using
an uppercase function name. The return value of the constructor is
automatically typed. Hence the value x will be of type Integer.
```R
Integer(x) %as% x
```
Instantiating the type is as simple as calling the function. Check the type
using the standard S3 introspection function `class`. The `%isa%` operator
can also be used to test whether an object is a particular type.
```R
x <- Integer(5)
x %isa% Integer
```
Type declarations
-----------------
Type constraints can be added to a function. These 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.
```R
fib(n) %::% Integer : Integer
fib(0) %as% Integer(1)
fib(1) %as% Integer(1)
fib(n) %as% { fib(n-1) + fib(n-2) }
fib(x)
```
The call `fib(1)` will fail because `1` is not of type `Integer`.
```R
> fib(1)
Error in UseFunction("fib", ...) : No valid function for 'fib(1)'
```
Properly typing the argument by calling `fib(Integer(1))` will give the
correct output. Note that pattern matching works even with the custom type.
```R
> fib(Integer(1))
[1] 1
attr(,"class")
[1] "Integer" "numeric"
```
Type constraints must be declared prior to the function implementation. Once
declared, the type declaration will retain scope
until another type declaration with the same number of parameters is declared
(see tests/types.R for an example).
Legacy types
------------
There are plenty of built-in types that are supported just like custom types
defined in lambda.r. Use the same syntax for these types. In the example above
we can just as easily declare
```R
fib(n) %::% numeric : numeric
```
or even
```R
fib(n) %::% Integer : numeric
```
NOTE: For objects of type function, due to the precedence rules of the parser,
you cannot specify 'function' in a type constraint. Instead use 'Function'.
```R
# Do this
make.gen(n) %::% numeric : Function
# Don't do this
make.gen(n) %::% numeric : function
```
Type Variables
--------------
Type constraints are useful, but too specific of a constraint can destroy the
polymorphism of a function. To preserve this while still retaining some
type safety you can use a type variable. With type variables the actual type
is not checked. Instead it is the relationship between types that are checked.
```R
fib(n) %::% a : a
fib(0) %as% 1
fib(1) %as% 1
fib(n) %as% { fib(n-1) + fib(n-2) }
```
In this type constraint, both the input and output types must match.
Note that the only characters valid for a type variable are the lowercase
letters (i.e. a-z). If you need more than this for a single function definition,
you've got other problems.
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 ```...``` 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.
```R
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.
```R
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.
```R
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)'
```
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 ```R f(x, y) %::% . : numeric : numeric```, the type of
```x``` will not be checked.
One Shot
========
Here is the complete example using built-in types:
```R
fib(n) %::% numeric : numeric
fib(0) %as% 1
fib(1) %as% 1
fib(n) %as% { fib(n-1) + fib(n-2) }
fib(5)
seal(fib)
```
To ignore types altogether, just omit the type declaration in the above listing
and the code will evaluate the same.
Here is the same example with custom types:
```R
Integer(x) %as% x
fib(n) %::% Integer : Integer
fib(0) %as% Integer(1)
fib(1) %as% Integer(1)
fib(n) %as% { fib(n-1) + fib(n-2) }
x <- Integer(5)
fib(x)
```
The `seal` command in the first example prevents new statements from being
added to an existing function definition. Instead new definitions reset the
function. Typically you don't need this function as lambda.r will auto-replace
function definitions that have the same signature.
Sugar Coating
=============
All the great features of R function calls are still supported in lambda.r. In
addition, lambda.r provides some parse transforms to add some extra features
to make application development even faster.
Object Attributes
-----------------
Attributes are a form of meta data that decorate an object. This information
can be used to simplify type structures retaining polymorphism and compatibility
with existing functions while providing the detail needed for your application.
Lambda.R provides convenient syntax for interacting with attributes via the `@`
symbol.
```R
Temperature(x, system, units) %as%
{
x@system <- system
x@units <- units
x
}
```
These attributes can then be accessed in guards and function bodies using the
same syntax.
```R
freezing(x) %::% Temperature : logical
freezing(x) %when% {
x@system == 'metric'
x@units == 'celsius'
} %as% {
if (x < 0) { TRUE }
else { FALSE }
}
```
Note that outside of lambda.r you must use the standard attr() function to
access specific attributes. Also note that attributes have not been tested with
S4 objects.
Optional Arguments
------------------
A nice convenience in R is the ability to specify optional arguments with
default values. Lambda.R preserves this feature in multipart function
definitions. Functions are matched based on the order in which they are
defined, and this holds true with functions with optional arguments.
```R
Temperature(x, system="metric", units='celsius') %as%
{
x@system <- system
x@units <- units
x
}
> ctemp <- Temperature(20)
> ctemp
[1] 20
attr(,"system")
[1] "metric"
attr(,"units")
[1] "celsius"
attr(,"class")
[1] "Temperature" "numeric"
```
The Ellipsis Argument
---------------------
Support for the ellipsis argument is built into lambda.r. Required arguments
must still be matched, while any additional arguments will be enclosed in the
ellipsis. Here's an example using the plant data included in R's lm help page.
```R
regress(formula, ..., na.action='na.fail') %as% {
lm(formula, ..., na.action=na.action)
}
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.D9 <- regress(weight ~ group, data=data)
```
Care does need to be used with the ellipsis as it behaves like a greedy match,
so subsequent definitions may not work as you intend when using the ellipsis
argument in a function variant.
Named Arguments
---------------
The examples above all hint at supporting named arguments. Named arguments can
be mixed and matched with positional arguments just as in legacy function
definitions.
```R
lm.D9 <- regress(data=data, weight ~ group)
```
Auto Replace and Sealing Definitions
-------------------
As of version 1.1.0, lambda.r can detect a duplicate function signature and
update an existing definition. This means development is more efficient
since you can re-source files and the existing definitions will update as you
expect. This process is compatible with multi-part function definitions and
type constraints. Do note that when using type constraints, only functions
associated with the active type constraint can be auto replaced. The reason is
that there can be two identical function signatures and lambda.r really has
no way of knowing which one you mean. Hence, you have to tell lambda.r via
the type constraint.
For example take this simple reciprocal function. There are two type constraint
clauses, and three total function variants. The signatures for variants 2 and 3
are identical, so the only thing that distinguishes them are the different type
constraints associated with each one. Notice that there is an explicit bug in
the definition of variant 2.
```R
reciprocal(n) %::% numeric : numeric
reciprocal(0) %as% stop("Reciprocal of 0 is undefined")
reciprocal(n) %as% { 2/n }
reciprocal(n) %::% character : numeric
reciprocal(n) %as% { reciprocal(as.numeric(n)) }
```
To change the definition of variant 2, you must re-declare
the first type constraint. Otherwise, lambda.r would not know whether to update
variant 2 or 3.
```R
reciprocal(n) %::% numeric : numeric
reciprocal(n) %as% { 1/n }
```
Lambda.R has no way of knowing whether a function definition is complete or not.
Explicitly telling lambda.r will ensure that any new function definitions will
reset the function as opposed to append another definition.
```R
seal(freezing)
```
If providing a broad interface, be careful not to seal the function. Sealing is
analogous to making a variable final in Java, such that no further modifications
can be made. The key difference is that attempting to add further defintions to
the sealed function will overwrite the existing definition. This behavior is
intended to make application and package development more iterative.
Introspection
=============
A function in lambda.r has a lot of meta data attached to it. Accessing the raw
data can be overwhelming, so lambda.r provides facilities to extract the
useful bits. Viewing basic information about a function is accomplished by just
typing out the function in the shell. This results in a dump of the type
declarations and function signatures for the function.
```R
> fib
<function>
[[1]]
fib(n) %::% Integer:Integer
fib(0) %as% ...
[[2]]
fib(n) %::% Integer:Integer
fib(1) %as% ...
[[3]]
fib(n) %::% Integer:Integer
fib(n) %as% ...
```
Actual function bodies are not displayed to minimize clutter.
Examining Functions
-------------------
To view a full function definition, use the 'describe' function to get the
definition of a specific function variant. The numbers separating each variant
is the index to use.
```R
> describe(fib,3)
function(n) { Integer ( fib ( n - 1 ) + fib ( n - 2 ) ) }
<environment: 0x10488ed10>
```
Examining Types
---------------
A type constructor is similar to a normal function, and the same technique works
to view a type body.
```R
> describe(Integer,1)
function(x) { x }
<environment: 0x10494aca8>
```
Monads
------
If you want to play around with monads in R, `lambda.r` has your back.
Here are some examples. Note that `lambda.tools` implements some common
monadic operators.
```
Maybe(a) %:=% a
Just(a) %:=% Maybe(a)
Nothing() %:=% Maybe(NA)
mreturn(x) %as% Just(x)
m %>>=% g %when% { is.null(m) } %as% NULL
m %>>=% g %::% Just : Function : Maybe
m %>>=% g %as% g(m)
m %>>=% g %::% Nothing : Function : Maybe
m %>>=% g %as% m
m %>>=% g %::% Just : Function : Maybe
m %>>=% g %as% g(m)
```
Composition
```
f %.% g %:=% function(...) f(g(...))
> unsafelogsqrt <- log %.% sqrt
> unsafelogsqrt(100)
[1] 2.302585
```
Monadic composition
```
f %>=>% g %:=% { function(x) f(x) %>>=% g }
f %<=<% g %:=% { function(x) g(x) %>>=% f }
safelog(x) %::% numeric : Maybe
safelog(x) %when% { x <= 0 } %as% Nothing()
safelog(x) %:=% Just(log(x))
safesqrt(x) %::% numeric : Maybe
safesqrt(x) %when% { x <= 0 } %as% Nothing()
safesqrt(x) %:=% Just(sqrt(x))
safelogsqrt <- safelog %<=<% safesqrt
```
Debugging
---------
The standard debug function will not work with lambda.r functions. Instead, use
the included functions debug.lr and undebug.lr. These functions will allow you
to debug through a complete multipart function call.
Known Limitations
=================
If you try to break lambda.r, you will most likely succeed. There are things
that won't work, but most use cases should work fine. Do let me know if you
find something that fails, but don't break it just to break it. Below are
some things that won't work.
1. Complex mix and match of named and positional arguments
```R
lm.D9 <- regress(data=data, formula=weight ~ group, NULL)
```
Don't do this, please. It's bad style.
What's New
==========
Version 1.1.5
-------------
+ Support the ellipsis (...) in type constraints
+ Support a typed ellipsis (numeric...) in type constraints
+ Support ellipsis type variable (a...) in type constraints
+ Support debug.lr in functions defined in packages (currently locked)
+ Show which functions are being debugged
+ Handle default arguments that execute a function
+ Support more pattern matching (like empty lists)
+ Support guards of the form f(a,b,c) %when% { sum(a,b,c) == 1 } %as% { 1 }
+ Support guards of the form f(x) %when% { length(grep('foo',x)) > 0 } %as% { 1 }
+ Support proper import namespace for packages
+ Install from github using devtools: install_github('lambda.r','zatonovo')
+ Travis CI integration: https://travis-ci.org/zatonovo/lambda.r
Version 1.1.1
-------------
+ Support Function in every type position (only supported for return type)
+ Auto-replacing a function with 0 arguments fails
+ Fix type inheritance
+ Functions that return non-scalar values work as default values on arguments
+ Support pattern matching on NULL and NA
+ Support pattern matching on special symbol EMPTY
Version 1.1.0
-------------
+ Handle function types in type declarations
+ Support type variables
+ Auto-replace function definitions with a matching signature (no need for seal)
+ Handle 0 argument functions
Future
======
+ Support *apply and lambda expressions in guard statements
+ Support defining operators
+ Lock functions by default (check when next function is different name). Use
public() as way to indicate function can be globally modified
+ Think about supporting namespaces
+ Support take, drop, cycle
+ Support partial function application
+ Check for side effects
+ Support tail recursion
+ Support type inference
================================================
FILE: man/UseFunction.Rd
================================================
\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 }
================================================
FILE: man/duck.Rd
================================================
\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@system <- 'polar'
o
}
p <- Point(5, pi/2, 'polar')
p %hasa% theta
}
\keyword{ methods }
\keyword{ programming }
================================================
FILE: man/framework.Rd
================================================
\name{\%as\%}
\alias{\%as\%}
\alias{\%:=\%}
\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@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@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 }
================================================
FILE: man/introspection.Rd
================================================
\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 }
================================================
FILE: man/lambda.r-package.Rd
================================================
\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.2.4\cr
Date: \tab 2019-09-15\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\%} (or \code{\%:=\%}) symbol
in place of \code{<-}.
Simple functions can be defined as simply
\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) \%:=\% {
z <- x + y
sqrt(z)
}
}
\subsection{Infix notation}{
Functions can be defined using infix notation as well.
For the function \code{g} above, it can be defined as an infix operator
using
x \%g\% y \%:=\% {
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@system <- 'polar'
o
}
Point(x,y, 'cartesian') \%as\% {
o <- list(x=x,y=y)
o@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@system == 'cartesian'
b@system == 'cartesian'
} \%as\% {
sqrt((b$x - a$x)^2 + (b$y - a$y)^2)
}
distance(a,b) \%when\% {
a@system == 'polar'
b@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@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)
}
================================================
FILE: tests/test-all.R
================================================
library(testit)
test_pkg('lambda.r')
================================================
FILE: tests/testit/test-auto_replace.1.R
================================================
rm(list=ls())
assert('auto_replace.no_types_1a', {
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)
act == 3
})
assert('auto_replace.no_types_1b', {
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)
act == 3
})
# Zero argument functions
assert('auto_replace.no_types_1c', {
foo() %as% 2
foo() %as% 1
seal(foo)
act <- foo()
act == 1
})
# Zero argument functions as part of a multipart definition
assert('auto_replace.no_types_1c', {
foo(n) %as% n
foo() %as% 2
foo() %as% 1
seal(foo)
act.1 <- foo()
act.2 <- foo(5)
(act.1 == 1)
(act.2 == 5)
})
================================================
FILE: tests/testit/test-auto_replace.2.R
================================================
assert('auto_replace.types_2a', {
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.1 <- fib(3)
act.2 <- fib("3")
(act.1 == 3)
(act.2 == 3)
})
assert('auto_replace.types_2b', {
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.1 <- fib(3)
act.2 <- fib("3")
act.3 <- fib()
(act.1 == 3)
(act.2 == 3)
(act.3 == 5)
})
assert('auto_replace.types_2c', {
fib() %::% numeric
fib() %as% 3
fib() %as% 5
seal(fib)
act <- fib()
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.1 <- fib()
act.2 <- fib(4)
(act.1 == 5)
(act.2 == 4)
}
================================================
FILE: tests/testit/test-auto_replace.3.R
================================================
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.1 <- fib(3)
act.2 <- fib(2)
(act.1 == 3)
(act.2 == 2)
}
================================================
FILE: tests/testit/test-dispatching.1.R
================================================
rm(list=ls())
assert('dispatching_1a', {
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)
fib(5) == 8
})
rm(list=ls())
assert('dispatching_1b', {
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)
act.2 <- tryCatch(fib("a"), error=function(x) 'error')
(act.1 == 8)
(act.2 == 'error')
})
rm(list=ls())
assert('dispatching_1c', {
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)
act <- tryCatch(fib(5), error=function(x) 'error')
(fib(Integer(5)) == Integer(8))
(act == 'error')
})
rm(list=ls())
assert('dispatching_1d', {
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)
a <- c(1,2,5,6,3,2,1,3)
(abs_max(2,-3) == 3)
(abs_max("3","-4") == 4)
(abs_max(a) == 6)
})
rm(list=ls())
assert('different_names', {
A(a) %as% { list(a=a) }
A(b) %as% { list(b=b) }
seal(A)
(A(5)$a == 5)
(A(a=5)$a == 5)
(A(b=5)$b == 5)
})
rm(list=ls())
assert('empty_function', {
a() %as% { }
seal(a)
b(a) %as% { }
seal(b)
# Empty functions will fail
has_error(a())
has_error(b(1))
})
rm(list=ls())
assert('empty_type_constructor', {
A() %as% { }
seal(A)
B(a) %as% { }
seal(B)
# Empty functions will fail
has_error(A())
has_error(B(1))
})
================================================
FILE: tests/testit/test-ellipsis_arguments.1.R
================================================
rm(list=ls())
Prices(series, asset.class, periodicity) %as%
{
series@asset.class <- asset.class
series@periodicity <- periodicity
series@visualize <- TRUE
series
}
visualize(x, ...) %when% {
x@visualize == TRUE
} %as% {
plot(x, ...)
}
seal(Prices)
seal(visualize)
dummy(x, ...) %as% { list(...) }
seal(dummy)
assert('ellipsis_arguments_1', {
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')
attr(scatter,'visualize') <- TRUE
visualize(scatter)
visualize(scatter, main='random')
(act == 'error')
})
assert('ellipsis_unnamed_arguments 1', {
act <- dummy(1,2)
all.equal(act, list(2))
})
assert('ellipsis_unnamed_arguments 2', {
act <- dummy(1,2,3,4)
all.equal(act, list(2,3,4))
})
================================================
FILE: tests/testit/test-ellipsis_arguments.2.R
================================================
rm(list=ls())
# :vim set filetype=R
regress(formula, ..., na.action=na.fail) %as% {
lm(formula, ..., na.action=na.action)
}
seal(regress)
assert('ellipsis_arguments_2', {
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)
all(lm.2$coefficients == lm.1$coefficients)
all(lm.2$residuals == lm.1$residuals)
})
================================================
FILE: tests/testit/test-examples.R
================================================
assert('example_1', {
reciprocal(x) %::% numeric : numeric
reciprocal(x) %when% { x != 0 } %as% { 1 / x }
reciprocal(x) %::% character : numeric
reciprocal(x) %as% { reciprocal(as.numeric(x)) }
act.1 <- reciprocal(4)
act.2 <- reciprocal("4")
(act.1 == 0.25)
(act.2 == 0.25)
})
================================================
FILE: tests/testit/test-factorial.1.R
================================================
rm(list=ls())
assert('factorial_1', {
fac(0) %as% 1
fac(n) %when% { n > 0 } %as% { n * fac(n - 1) }
seal(fac)
act <- tryCatch(fac(-1), error=function(x) 'error')
(fac(1) == 1)
(fac(5) == 120)
(act == 'error')
})
================================================
FILE: tests/testit/test-factorial.2.R
================================================
rm(list=ls())
assert('factorial_2', {
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))
(fac(WholeNumber(1)) == WholeNumber(1))
(fac(WholeNumber(5)) == WholeNumber(120))
(fac(1) == WholeNumber(1))
(fac(5) == WholeNumber(120))
act <- tryCatch(fac(-1), error=function(x) 'error')
(act == 'error')
})
================================================
FILE: tests/testit/test-fill_args.R
================================================
rm(list=ls())
#act <- tryCatch(fib(3), error=function(x) 'error')
#checkEquals(act, 'error')
assert('type_fill_args_1', {
mysum(x, y, ...) %as% { (x - y) * sum(...) }
seal(mysum)
act <- mysum(2, 3, 1, 2, 3)
(act == -6)
act <- mysum(x=2, 3, 1, 2, 3)
(act == -6)
act <- mysum(2, y=3, 1, 2, 3)
(act == -6)
act <- mysum(y=3, x=2, 1, 2, 3)
(act == -6)
act <- mysum(y=3, 1, 2, 3, x=2)
(act == -6)
act <- mysum(2, 1, 2, 3, y=3)
(act == -6)
})
assert('type_fill_args_2', {
mysum(x, y=3, ...) %as% { (x - y) * sum(...) }
seal(mysum)
act <- mysum(2, 1, 1, 2, 3)
(act == -7)
act <- mysum(1, y=2, 1, 1, 2, 3)
(act == -7)
act <- mysum(y=2, x=1, 1, 1, 2, 3)
(act == -7)
act <- mysum(1, 1, 2, 3, x=2)
(act == -7)
act <- mysum(1, 1, 1, 2, 3, y=2)
(act == -7)
})
================================================
FILE: tests/testit/test-function_args.1.R
================================================
rm(list=ls())
assert('function_args_1', {
f() %as% 1
seal(f)
act <- f()
(act ==1)
})
assert('function_args_2', {
f() %::% numeric
f() %as% 1
seal(f)
act <- f()
(act ==1)
})
assert('function_args_3', {
f() %::% numeric
f() %as% 1
f(a) %::% numeric : numeric
f(a) %as% a
seal(f)
act <- f()
(act ==1)
act <- f(3)
(act ==3)
})
assert('function_args_4', {
f() %::% numeric
f() %:=% 1
f(a) %::% numeric : numeric
f(a) %:=% a
seal(f)
act <- f()
(act ==1)
act <- f(3)
(act ==3)
})
================================================
FILE: tests/testit/test-function_type.1.R
================================================
rm(list=ls())
assert('function_type_1', {
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)
('function' %in% class(act))
})
================================================
FILE: tests/testit/test-heaviside_step.1.R
================================================
assert('heaviside_1', {
h.step(n) %when% { n < 0 } %as% { 0 }
h.step(0) %as% 0.5
h.step(n) %as% 1
seal(h.step)
(h.step(-1) == 0)
(h.step(0) == 0.5)
(h.step(1) == 1)
})
================================================
FILE: tests/testit/test-heaviside_step.2.R
================================================
rm(list=ls())
assert('heaviside_2', {
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)
(h.step(-1) == 0)
(h.step(0) == 0.5)
(h.step(1) == 1)
has_error(h.step("a"))
})
================================================
FILE: tests/testit/test-infix.1.R
================================================
rm(list=ls())
assert('infix.1', {
a %mod% b %:=% { a %/% b }
seal(`%mod%`)
act <- 5 %mod% 2
exp <- 5 %/% 2
(act == exp)
})
assert('infix.2', {
a %mod% b %as% { a %/% b }
seal(`%mod%`)
act <- 5 %mod% 2
exp <- 5 %/% 2
(act == exp)
})
================================================
FILE: tests/testit/test-optional_arguments.1.R
================================================
# vim: set filetype=R
rm(list=ls())
assert('optional_arguments_1a', {
Prices(series, asset.class='equity', periodicity='daily') %as% {
series@asset.class <- asset.class
series@periodicity <- periodicity
series
}
returns(x) %when% {
x@asset.class == "equity"
x@periodicity == "daily"
} %as% {
x[2:length(x)] / x[1:(length(x) - 1)] - 1
}
seal(Prices)
seal(returns)
ps <- Prices(abs(rnorm(50)))
(attr(ps,'asset.class') == 'equity')
(attr(ps,'periodicity') == 'daily')
ps <- Prices(abs(rnorm(50)), 'fx')
(attr(ps,'asset.class') == 'fx')
(attr(ps,'periodicity') == 'daily')
ps <- Prices(abs(rnorm(50)), periodicity='monthly')
(attr(ps,'asset.class') == 'equity')
(attr(ps,'periodicity') == 'monthly')
ps <- Prices(periodicity='monthly', series=abs(rnorm(50)))
(attr(ps,'asset.class') == 'equity')
(attr(ps,'periodicity') == 'monthly')
err <- tryCatch(returns(ps), error=function(x) 'error')
(err == 'error')
ps <- Prices(abs(rnorm(50)))
(length(returns(ps)) == length(ps) - 1)
})
rm(list=ls())
assert('optional_arguments_1b', {
Temperature(x, system='metric', units='celsius') %as% {
x@system <- system
x@units <- units
x
}
freezing(x) %::% Temperature : logical
freezing(x) %when% {
x@system == 'metric'
x@units == 'celsius'
} %as% {
if (x < 0) { TRUE }
else { FALSE }
}
freezing(x) %when% {
x@system == 'metric'
x@units == 'kelvin'
} %as% {
if (x < 273) { TRUE }
else { FALSE }
}
seal(Temperature)
seal(freezing)
ctemp <- Temperature(20)
(! freezing(ctemp))
ktemp <- Temperature(20, units='kelvin')
(freezing(ktemp))
})
rm(list=ls())
assert('optional_arguments_1c', {
avg(x, fun=mean) %as% { fun(x) }
a <- 1:4
a.mean <- avg(a)
(a.mean == 2.5)
a.med <- avg(a, median)
(a.med == 2.5)
})
================================================
FILE: tests/testit/test-optional_arguments.2.R
================================================
# vim: set filetype=R
rm(list=ls())
assert('optional_arguments_no_args', {
f(name='ROOT') %as% 1
seal(f)
(f() == 1)
(f('a') == 1)
})
rm(list=ls())
assert('optional_arguments_no_args_type_constraint', {
f(name) %::% character : numeric
f(name='ROOT') %as% 1
seal(f)
(f() == 1)
(f('a') == 1)
})
rm(list=ls())
assert('optional_arguments_function', {
f(x, y=runif(5)) %as% { x + y }
seal(f)
act <- f(1)
(length(act) == 5)
})
rm(list=ls())
assert('optional_arguments_function_named', {
f(y=runif(5), x) %as% { x + y }
seal(f)
act <- f(x=1)
(length(act) == 5)
})
rm(list=ls())
assert('optional_arguments_reference_var', {
f(y=min(x), x) %as% { x + y }
seal(f)
act <- f(x=1:5)
(length(act) == 5)
(act == 2:6)
})
================================================
FILE: tests/testit/test-parse_transforms.1.R
================================================
rm(list=ls())
assert('parse_transforms_1', {
Prices(series) %as%
{
series@asset.class <- 'equity'
series@periodicity <- 'daily'
series
}
returns(x) %when% {
x@asset.class == "equity"
x@periodicity == "daily"
} %as% {
x[2:length(x)] / x[1:(length(x) - 1)] - 1
}
ps <- Prices(rnorm(50))
(attr(ps,'asset.class') == 'equity')
(attr(ps,'periodicity') == 'daily')
rs <- returns(ps)
(length(rs) == length(ps) - 1)
})
================================================
FILE: tests/testit/test-parse_transforms.2.R
================================================
rm(list=ls())
Temperature(x, system, units) %as%
{
x@system <- system
x@units <- units
x
}
freezing(x) %when% {
x@system == 'metric'
x@units == 'celsius'
} %as% {
if (x < 0) { TRUE }
else { FALSE }
}
assert('parse_transforms_2', {
temp <- Temperature(20, 'metric', 'celsius')
(attr(temp,'system') == 'metric')
(attr(temp,'units') == 'celsius')
(! freezing(temp))
})
================================================
FILE: tests/testit/test-parse_transforms.3.R
================================================
rm(list=ls())
WishartModel(n,m,Q,sd) %as% {
x <- list()
x@n <- n
x@m <- m
x@Q <- Q
x@sd <- sd
x
}
WishartMatrix(x, model) %as% {
x@n <- model@n
x@m <- model@m
x@Q <- model@Q
x@sd <- model@sd
x
}
assert('parse_transforms_3', {
model <- WishartModel(10,20,2,1)
mat <- WishartMatrix(rnorm(10), model)
(attr(mat,'n') == 10)
(attr(mat,'m') == 20)
(attr(mat,'Q') == 2)
(attr(mat,'sd') == 1)
})
================================================
FILE: tests/testit/test-pattern_matching.R
================================================
# :vim set filetype=R
rm(list=ls())
assert('pattern_null', {
fold(f, x, acc) %as% acc
fold(f, NULL, acc) %as% acc
act <- fold(function(x,y) x + y, NULL, 5)
(5 == act)
})
rm(list=ls())
assert('pattern_na', {
fold(f, x, acc) %as% acc
fold(f, NA, acc) %as% acc
act <- fold(function(x,y) x + y, NA, 5)
(5 == act)
})
rm(list=ls())
assert('pattern_empty', {
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)
(15 == act)
})
================================================
FILE: tests/testit/test-taylor_series.1.R
================================================
rm(list=ls())
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 + ...
assert('taylor_series_1', {
fac(1) %as% 1
fac(n) %when% { n > 0 } %as% { n * fac(n - 1) }
seal(fac)
# 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)
all.equal(v, sin(3.1), tolerance=0.01)
})
================================================
FILE: tests/testit/test-type_any_type.R
================================================
rm(list=ls())
assert('type_any_type_1', {
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)
(act == 5)
})
rm(list=ls())
assert('type_any_type_2', {
hypotenuse(a,b) %::% . : . : numeric
hypotenuse(a,b) %as% { (a^2 + b^2)^.5 }
seal(hypotenuse)
act <- hypotenuse(3,4)
(act ==5)
})
rm(list=ls())
assert('type_any_type_3', {
hypotenuse(a,b) %::% numeric : numeric: .
hypotenuse(a,b) %as% { (a^2 + b^2)^.5 }
seal(hypotenuse)
act <- hypotenuse(3,4)
(act ==5)
})
rm(list=ls())
assert('type_any_type_4', {
hypotenuse(a,b) %::% a : a: .
hypotenuse(a,b) %as% { (a^2 + b^2)^.5 }
seal(hypotenuse)
act <- hypotenuse(3,4)
(act ==5)
})
================================================
FILE: tests/testit/test-type_ellipsis.R
================================================
#act <- tryCatch(fib(3), error=function(x) 'error')
#checkEquals(act, 'error')
rm(list=ls())
assert('type_ellipsis_1', {
ioc(f, ...) %::% Function : ... : .
ioc(f, ...) %as% f(...)
seal(ioc)
act <- ioc(sum, 1, 2, 3)
(act == 6)
})
rm(list=ls())
assert('type_ellipsis_2', {
ioc(f, ...) %::% Function : ... : numeric
ioc(f, ...) %as% f(...)
seal(ioc)
act <- ioc(sum, 1, 2, 3)
(act == 6)
})
rm(list=ls())
assert('type_ellipsis_3', {
mysum(x, ...) %::% a : ... : numeric
mysum(x, ...) %as% sum(...)
seal(mysum)
act <- mysum('foo', 1, 2, 3)
(act == 6)
})
rm(list=ls())
assert('type_ellipsis_4', {
mysum(..., x) %::% ... : logical : numeric
mysum(..., x) %as% sum(..., na.rm=x)
seal(mysum)
act <- mysum(1, 2, 3, x=TRUE)
(act == 6)
})
rm(list=ls())
assert('type_ellipsis_var_1', {
mysum(..., x) %::% numeric... : logical : numeric
mysum(..., x) %as% sum(..., na.rm=x)
seal(mysum)
act <- mysum(1, 2, 3, x=FALSE)
(act == 6)
})
================================================
FILE: tests/testit/test-type_functions.R
================================================
rm(list=ls())
assert('zero', {
zero() %::% Function
zero() %as% { function() 1 }
act <- zero()
(act() == 1)
})
assert('one_application', {
fn.0 <- function() 0
one_application(x) %::% Function : numeric
one_application(x) %as% { x() }
act <- one_application(fn.0)
(act == 0)
})
assert('one_identity', {
fn.0 <- function() 0
one_identity(x) %::% Function : Function
one_identity(x) %as% { x }
act <- one_identity(fn.0)
identical(act, fn.0)
})
assert('two_application', {
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)
(act == 2)
act <- two_application(4,fn.1)
(act == 4)
})
assert('two_identity', {
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)
identical(act, fn.0)
act <- two_identity(2, fn.1)
identical(act, fn.1)
})
================================================
FILE: tests/testit/test-type_inheritance.R
================================================
rm(list=ls())
assert('inheritance_one_arg', {
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)
(act.a == "a")
act.b <- one.arg(b)
(act.b == "a")
act.c <- one.arg(c)
(act.c == "base")
})
rm(list=ls())
assert('inheritance_two_arg', {
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)
(act.a == "a")
act.b <- two.arg(b,b)
(act.b == "a")
act.c <- two.arg(c,b)
(act.c == "base")
})
rm(list=ls())
assert('inheritance_with_type_variable', {
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)
(act.a == "a")
act.b <- two.arg(b,b)
(act.b == "a")
act.c <- two.arg(c,b)
(act.c == "a")
})
rm(list=ls())
assert('inheritance_with_ellipsis_1', {
Base(x, ...) %as% list(x=x, ...)
A(x, z) %as% { Base(x, z=z) }
seal(Base)
seal(A)
a <- A(1, 2)
(a$x == 1)
(a$z == 2)
})
rm(list=ls())
assert('inheritance_with_ellipsis_2', {
Base(x=1, ...) %as% list(x=x, ...)
A(z) %as% { Base(z=z) }
seal(Base)
seal(A)
a <- A(2)
(a$x == 1)
(a$z == 2)
})
================================================
FILE: tests/testit/test-type_integer_inheritance.R
================================================
rm(list=ls())
assert('type_integer_1', {
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)
(act == 3)
})
rm(list=ls())
assert('type_integer_2', {
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))
(act == 3)
})
rm(list=ls())
assert('type_integer_5', {
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))
(act == 3)
})
rm(list=ls())
assert('type_integer_3', {
hypotenuse(a,b) %::% numeric : numeric : numeric
hypotenuse(a,b) %as% { (a^2 + b^2)^.5 }
seal(hypotenuse)
act <- hypotenuse(as.integer(3),4)
(act ==5)
})
rm(list=ls())
assert('type_integer_4', {
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))
(act ==5)
})
================================================
FILE: tests/testit/test-type_variable.1.R
================================================
rm(list=ls())
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)
(act == 3)
}
rm(list=ls())
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")
('error' == act)
}
rm(list=ls())
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')
('error' == act)
}
rm(list=ls())
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)
(act ==5)
}
rm(list=ls())
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')
(act == 'error')
}
rm(list=ls())
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')
(act == 'error')
}
rm(list=ls())
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)
(act == sqrt(2))
}
================================================
FILE: tests/testit/test-types.1.R
================================================
# vim: set filetype=R
rm(list=ls())
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")
(act.1 == 'error')
a <- A(2)
b <- B(3)
act.2 <- f(a,b)
(act.2 == 5)
}
rm(list=ls())
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)
(distance(point.1,point.2) == 5)
}
rm(list=ls())
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)
(distance(point.3,point.4) == 5)
}
gitextract_s3t02gl3/
├── .Rbuildignore
├── .gitignore
├── .travis.yml
├── DESCRIPTION
├── NAMESPACE
├── R/
│ ├── duck.R
│ ├── framework.R
│ ├── introspection.R
│ └── objects.R
├── README.md
├── man/
│ ├── UseFunction.Rd
│ ├── duck.Rd
│ ├── framework.Rd
│ ├── introspection.Rd
│ └── lambda.r-package.Rd
└── tests/
├── test-all.R
└── testit/
├── test-auto_replace.1.R
├── test-auto_replace.2.R
├── test-auto_replace.3.R
├── test-dispatching.1.R
├── test-ellipsis_arguments.1.R
├── test-ellipsis_arguments.2.R
├── test-examples.R
├── test-factorial.1.R
├── test-factorial.2.R
├── test-fill_args.R
├── test-function_args.1.R
├── test-function_type.1.R
├── test-heaviside_step.1.R
├── test-heaviside_step.2.R
├── test-infix.1.R
├── test-optional_arguments.1.R
├── test-optional_arguments.2.R
├── test-parse_transforms.1.R
├── test-parse_transforms.2.R
├── test-parse_transforms.3.R
├── test-pattern_matching.R
├── test-taylor_series.1.R
├── test-type_any_type.R
├── test-type_ellipsis.R
├── test-type_functions.R
├── test-type_inheritance.R
├── test-type_integer_inheritance.R
├── test-type_variable.1.R
└── test-types.1.R
Condensed preview — 45 files, each showing path, character count, and a content snippet. Download the .json file or copy for the full structured content (110K chars).
[
{
"path": ".Rbuildignore",
"chars": 95,
"preview": "^.*\\.Rproj$\n^\\.Rproj\\.user$\n^rename$\n^\\.gitignore$\n^README.md$\n^LICENSE$\n^tools$\n^.travis.yml$\n"
},
{
"path": ".gitignore",
"chars": 82,
"preview": ".RData\n\n# History files\n.Rhistory\n\n# Example code in package build process\n*-Ex.R\n"
},
{
"path": ".travis.yml",
"chars": 66,
"preview": "language: r\ncache: packages\n\nr:\n - oldrel\n - release\n - devel\n\n"
},
{
"path": "DESCRIPTION",
"chars": 583,
"preview": "Package: lambda.r\nType: Package\nTitle: Modeling Data with Functional Programming\nVersion: 1.2.4\nDate: 2019-09-15\nDepends"
},
{
"path": "NAMESPACE",
"chars": 458,
"preview": "importFrom(\"utils\", \"capture.output\", \"getParseData\", \"str\", \"tail\")\nimportFrom(\"formatR\", \"tidy_source\")\nexport(\"%as%\")"
},
{
"path": "R/duck.R",
"chars": 843,
"preview": "'%isa%' <- function(argument, type)\n{\n type <- gsub('[\\'\"]','',deparse(substitute(type)))\n type %in% class(argument)\n}"
},
{
"path": "R/framework.R",
"chars": 33991,
"preview": "EMPTY <- 'EMPTY'\n\n#' Check if name is bound to a non-lambda.r object\nis.bound <- function(name) {\n if (! exists(name, i"
},
{
"path": "R/introspection.R",
"chars": 2430,
"preview": "describe(fn, idx, raw=FALSE) %when% { raw } %:=% {\n class(fn) <- NULL\n print(fn)\n}\ndescribe(fn, idx) %when% {\n idx > "
},
{
"path": "R/objects.R",
"chars": 41,
"preview": "MissingReturnType <- \"MissingReturnType\"\n"
},
{
"path": "README.md",
"chars": 18069,
"preview": "[](https://travis-ci.org/zatonovo/lambda.r)\n\nDescription\n==="
},
{
"path": "man/UseFunction.Rd",
"chars": 1418,
"preview": "\\name{UseFunction}\n\\alias{UseFunction}\n\\alias{NewObject}\n\\title{Primary dispatcher for functional programming }\n\\descrip"
},
{
"path": "man/duck.Rd",
"chars": 1093,
"preview": "\\name{duck-typing}\n\\alias{\\%isa\\%}\n\\alias{\\%hasa\\%}\n\\alias{\\%hasall\\%}\n\\title{Functions for duck typing}\n\\description{Du"
},
{
"path": "man/framework.Rd",
"chars": 4135,
"preview": "\\name{\\%as\\%}\n\\alias{\\%as\\%}\n\\alias{\\%:=\\%}\n\\alias{\\%::\\%}\n\\alias{EMPTY}\n\\alias{seal}\n\\title{Define functions and type c"
},
{
"path": "man/introspection.Rd",
"chars": 2230,
"preview": "\\name{introspection}\n\\alias{describe}\n\\alias{debug.lr}\n\\alias{undebug.lr}\n\\alias{undebug.all}\n\\alias{is.debug}\n\\alias{wh"
},
{
"path": "man/lambda.r-package.Rd",
"chars": 13595,
"preview": "\\name{lambda.r-package}\n\\alias{lambda.r-package}\n\\alias{lambda.r}\n\\docType{package}\n\\title{\nModeling Data with Functiona"
},
{
"path": "tests/test-all.R",
"chars": 38,
"preview": "library(testit)\ntest_pkg('lambda.r')\n\n"
},
{
"path": "tests/testit/test-auto_replace.1.R",
"chars": 749,
"preview": "rm(list=ls())\n\nassert('auto_replace.no_types_1a', {\n fib(0) %as% 2\n fib(0) %as% 1\n fib(1) %as% 1\n fib(n) %as% { fib("
},
{
"path": "tests/testit/test-auto_replace.2.R",
"chars": 1201,
"preview": "assert('auto_replace.types_2a', {\n fib(n) %::% numeric : numeric\n fib(0) %as% 1\n fib(1) %as% 2\n fib(n) %as% { fib(n-"
},
{
"path": "tests/testit/test-auto_replace.3.R",
"chars": 269,
"preview": "test.auto_replace_3 <- function() {\n fib(0) %as% 2\n fib(0) %as% 1\n fib(1) %as% 1\n fib(n=5) %as% { fib(n-1) - fib(n-2"
},
{
"path": "tests/testit/test-dispatching.1.R",
"chars": 1752,
"preview": "rm(list=ls())\nassert('dispatching_1a', {\n fib(0) %as% 1\n fib(1) %as% 1\n fib(n) %when% {\n abs(n - round(n)) < .Mach"
},
{
"path": "tests/testit/test-ellipsis_arguments.1.R",
"chars": 864,
"preview": "rm(list=ls())\n\nPrices(series, asset.class, periodicity) %as% \n{\n series@asset.class <- asset.class\n series@periodicity"
},
{
"path": "tests/testit/test-ellipsis_arguments.2.R",
"chars": 569,
"preview": "rm(list=ls())\n\n# :vim set filetype=R\nregress(formula, ..., na.action=na.fail) %as% {\n lm(formula, ..., na.action=na.act"
},
{
"path": "tests/testit/test-examples.R",
"chars": 295,
"preview": "assert('example_1', {\n reciprocal(x) %::% numeric : numeric\n reciprocal(x) %when% { x != 0 } %as% { 1 / x }\n reciproc"
},
{
"path": "tests/testit/test-factorial.1.R",
"chars": 229,
"preview": "rm(list=ls())\n\nassert('factorial_1', {\n fac(0) %as% 1\n fac(n) %when% { n > 0 } %as% { n * fac(n - 1) }\n seal(fac)\n\n "
},
{
"path": "tests/testit/test-factorial.2.R",
"chars": 495,
"preview": "rm(list=ls())\n\nassert('factorial_2', {\n WholeNumber(x) %when% { x > 0 } %as% x\n\n fac(n) %::% WholeNumber : WholeNumber"
},
{
"path": "tests/testit/test-fill_args.R",
"chars": 814,
"preview": "rm(list=ls())\n\n#act <- tryCatch(fib(3), error=function(x) 'error')\n#checkEquals(act, 'error')\n\nassert('type_fill_args_1'"
},
{
"path": "tests/testit/test-function_args.1.R",
"chars": 534,
"preview": "rm(list=ls())\n\nassert('function_args_1', {\n f() %as% 1\n seal(f)\n act <- f()\n (act ==1)\n})\n\nassert('function_args_2',"
},
{
"path": "tests/testit/test-function_type.1.R",
"chars": 271,
"preview": "rm(list=ls())\n\nassert('function_type_1', {\n seq.gen(start) %::% a : Function\n seq.gen(start) %as%\n {\n value <- sta"
},
{
"path": "tests/testit/test-heaviside_step.1.R",
"chars": 183,
"preview": "assert('heaviside_1', {\n h.step(n) %when% { n < 0 } %as% { 0 }\n h.step(0) %as% 0.5\n h.step(n) %as% 1\n seal(h.step)\n\n"
},
{
"path": "tests/testit/test-heaviside_step.2.R",
"chars": 259,
"preview": "rm(list=ls())\n\nassert('heaviside_2', {\n h.step(n) %::% numeric : numeric\n h.step(n) %when% { n < 0 } %as% { 0 }\n h.st"
},
{
"path": "tests/testit/test-infix.1.R",
"chars": 257,
"preview": "rm(list=ls())\n\nassert('infix.1', {\n a %mod% b %:=% { a %/% b }\n seal(`%mod%`)\n\n act <- 5 %mod% 2\n exp <- 5 %/% 2\n ("
},
{
"path": "tests/testit/test-optional_arguments.1.R",
"chars": 1857,
"preview": "# vim: set filetype=R\n\nrm(list=ls())\nassert('optional_arguments_1a', {\n Prices(series, asset.class='equity', periodicit"
},
{
"path": "tests/testit/test-optional_arguments.2.R",
"chars": 753,
"preview": "# vim: set filetype=R\nrm(list=ls())\nassert('optional_arguments_no_args', {\n f(name='ROOT') %as% 1\n seal(f)\n (f() == 1"
},
{
"path": "tests/testit/test-parse_transforms.1.R",
"chars": 461,
"preview": "rm(list=ls())\n\nassert('parse_transforms_1', {\n Prices(series) %as% \n {\n series@asset.class <- 'equity'\n series@p"
},
{
"path": "tests/testit/test-parse_transforms.2.R",
"chars": 392,
"preview": "rm(list=ls())\n\nTemperature(x, system, units) %as%\n{\n x@system <- system\n x@units <- units\n x\n}\n\nfreezing(x) %when% {\n"
},
{
"path": "tests/testit/test-parse_transforms.3.R",
"chars": 427,
"preview": "rm(list=ls())\n\nWishartModel(n,m,Q,sd) %as% {\n x <- list()\n x@n <- n\n x@m <- m\n x@Q <- Q\n x@sd <- sd\n x\n}\n\nWishartM"
},
{
"path": "tests/testit/test-pattern_matching.R",
"chars": 539,
"preview": "# :vim set filetype=R\n\n\nrm(list=ls())\nassert('pattern_null', {\n fold(f, x, acc) %as% acc\n fold(f, NULL, acc) %as% acc\n"
},
{
"path": "tests/testit/test-taylor_series.1.R",
"chars": 1132,
"preview": "rm(list=ls())\n\ncompare <- function(a,b, xs) {\n plot(xs, a(xs), type='l')\n lines(xs, b(xs), type='l', col='blue')\n inv"
},
{
"path": "tests/testit/test-type_any_type.R",
"chars": 729,
"preview": "\nrm(list=ls())\nassert('type_any_type_1', {\n fib(n) %::% . : a\n fib(0) %as% 1\n fib(1) %as% 1\n fib(n) %as% { fib(n-1) "
},
{
"path": "tests/testit/test-type_ellipsis.R",
"chars": 978,
"preview": "#act <- tryCatch(fib(3), error=function(x) 'error')\n#checkEquals(act, 'error')\n\nrm(list=ls())\nassert('type_ellipsis_1', "
},
{
"path": "tests/testit/test-type_functions.R",
"chars": 1179,
"preview": "rm(list=ls())\n\nassert('zero', {\n zero() %::% Function\n zero() %as% { function() 1 }\n\n act <- zero()\n (act() == 1)\n})"
},
{
"path": "tests/testit/test-type_inheritance.R",
"chars": 1869,
"preview": "\n\nrm(list=ls())\nassert('inheritance_one_arg', {\n Base(x) %as% x\n A(x) %as% { Base(x) }\n B(x) %as% { A(x) }\n E(x) %as"
},
{
"path": "tests/testit/test-type_integer_inheritance.R",
"chars": 1054,
"preview": "rm(list=ls())\nassert('type_integer_1', {\n fib(n) %::% numeric : numeric\n fib(0) %as% 1\n fib(1) %as% 1\n fib(n) %as% {"
},
{
"path": "tests/testit/test-type_variable.1.R",
"chars": 1820,
"preview": "rm(list=ls())\ntest.type_variable_1 <- function() {\n fib(n) %::% a : a\n fib(0) %as% 1\n fib(1) %as% 1\n fib(n) %as% { f"
},
{
"path": "tests/testit/test-types.1.R",
"chars": 1497,
"preview": "# vim: set filetype=R\n\nrm(list=ls())\ntest.types_1 <- function() {\n A(x) %as% x\n B(x) %as% x\n\n f(a,b) %::% A : B : num"
}
]
About this extraction
This page contains the full source code of the zatonovo/lambda.r GitHub repository, extracted and formatted as plain text for AI agents and large language models (LLMs). The extraction includes 45 files (100.2 KB), approximately 32.6k tokens. Use this with OpenClaw, Claude, ChatGPT, Cursor, Windsurf, or any other AI tool that accepts text input. You can copy the full output to your clipboard or download it as a .txt file.
Extracted by GitExtract — free GitHub repo to text converter for AI. Built by Nikandr Surkov.