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 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("\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("\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 ================================================ [![Build Status](https://travis-ci.org/zatonovo/lambda.r.png)](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 [[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 ) ) } ``` 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 } ``` 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 } \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) }