lambda.r/0000755000176200001440000000000013157271277011746 5ustar liggesuserslambda.r/inst/0000755000176200001440000000000013156117135012712 5ustar liggesuserslambda.r/inst/unitTests/0000755000176200001440000000000013156117135014714 5ustar liggesuserslambda.r/inst/unitTests/runit.optional_arguments.2.R0000644000176200001440000000143413156117135022253 0ustar liggesusers# vim: set filetype=R test.optional_arguments_no_args <- function() { f(name='ROOT') %as% 1 seal(f) checkEquals(f(), 1) checkEquals(f('a'), 1) } test.optional_arguments_no_args_type_constraint <- function() { f(name) %::% character : numeric f(name='ROOT') %as% 1 seal(f) checkEquals(f(), 1) checkEquals(f('a'), 1) } test.optional_arguments_function <- function() { f(x, y=runif(5)) %as% { x + y } seal(f) act <- f(1) checkTrue(length(act) == 5) } test.optional_arguments_function_named <- function() { f(y=runif(5), x) %as% { x + y } seal(f) act <- f(x=1) checkTrue(length(act) == 5) } test.optional_arguments_reference_var <- function() { f(y=min(x), x) %as% { x + y } seal(f) act <- f(x=1:5) checkTrue(length(act) == 5) checkEquals(act, 2:6) } lambda.r/inst/unitTests/runit.parse_transforms.1.R0000644000176200001440000000074113156117135021730 0ustar liggesuserstest.parse_transforms_1 <- function() { 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)) checkEquals(attr(ps,'asset.class'), 'equity') checkEquals(attr(ps,'periodicity'), 'daily') rs <- returns(ps) checkEquals(length(rs), length(ps) - 1) } lambda.r/inst/unitTests/runit.type_functions.R0000644000176200001440000000233613156117135021254 0ustar liggesuserstest.zero <- function() { zero() %::% Function zero() %as% { function() 1 } act <- zero() checkEquals(act(), 1) } test.one_application <- function() { fn.0 <- function() 0 one_application(x) %::% Function : numeric one_application(x) %as% { x() } act <- one_application(fn.0) checkEquals(act, 0) } test.one_identity <- function() { fn.0 <- function() 0 one_identity(x) %::% Function : Function one_identity(x) %as% { x } act <- one_identity(fn.0) checkEquals(act, fn.0) } test.two_application <- function() { fn.1 <- function(x) x two_application(x,y) %::% Function : numeric : numeric two_application(x,y) %as% { x(y) } two_application(y,x) %::% numeric : Function : numeric two_application(y,x) %as% { x(y) } act <- two_application(fn.1,2) checkEquals(act, 2) act <- two_application(4,fn.1) checkEquals(act, 4) } test.two_identity <- function() { fn.0 <- function() 0 fn.1 <- function(x) x two_identity(x,y) %::% Function : numeric : Function two_identity(x,y) %as% { x } two_identity(y,x) %::% numeric : Function : Function two_identity(y,x) %as% { x } act <- two_identity(fn.0, 1) checkEquals(act, fn.0) act <- two_identity(2, fn.1) checkEquals(act, fn.1) } lambda.r/inst/unitTests/runit.type_variable.1.R0000644000176200001440000000356213156117135021172 0ustar liggesuserstest.type_variable_1 <- function() { fib(n) %::% a : a fib(0) %as% 1 fib(1) %as% 1 fib(n) %as% { fib(n-1) + fib(n-2) } seal(fib) #act <- tryCatch(f(2,3), error=function(x) 'error') #checkEquals(act, 'error') act <- fib(3) checkEquals(act, 3) } # This is not working from the shell but works interactively ignore.type_variable_2 <- function() { fib(n) %::% b : a fib(0) %as% 1 fib(1) %as% 1 fib(n) %as% { fib(n-1) + fib(n-2) } seal(fib) act <- tryCatch(f(2), error=function(x) 'error') cat("\ntest.type_variable_2: act =",act,"\n") checkEquals('error', act) } # This is not working from the shell but works interactively ignore.type_variable_3 <- function() { fib(n) %::% a : b fib(0) %as% 1 fib(1) %as% 1 fib(n) %as% { fib(n-1) + fib(n-2) } seal(fib) act <- tryCatch(f(2), error=function(x) 'error') checkEquals('error', act) } test.type_variable_4 <- function() { hypotenuse(a,b) %::% a : a : a hypotenuse(a,b) %as% { (a^2 + b^2)^.5 } seal(hypotenuse) #act <- tryCatch(f(2), error=function(x) 'error') #checkEquals(act, 'error') act <- hypotenuse(3,4) checkEquals(act,5) } test.type_variable_5 <- function() { hypotenuse(a,b) %::% a : b : a hypotenuse(a,b) %as% { (a^2 + b^2)^.5 } seal(hypotenuse) act <- tryCatch(hypotenuse(5,12), error=function(x) 'error') checkEquals(act, 'error') } test.type_variable_6 <- function() { hypotenuse(a,b) %::% a : a : b hypotenuse(a,b) %as% { (a^2 + b^2)^.5 } seal(hypotenuse) act <- tryCatch(hypotenuse(5,12), error=function(x) 'error') checkEquals(act, 'error') } test.mixed_type_variable_1 <- function() { Point(x,y) %as% list(x=x,y=y) distance(a,b) %::% Point : Point : z distance(a,b) %as% { ((a$x - b$x)^2 + (a$y - b$y)^2)^.5 } seal(distance) point.1 <- Point(2, 2) point.2 <- Point(1, 1) act <- distance(point.1, point.2) checkEquals(act, sqrt(2)) } lambda.r/inst/unitTests/runit.type_any_type.R0000644000176200001440000000134413156117135021072 0ustar liggesuserstest.type_any_type_1 <- function() { fib(n) %::% . : a fib(0) %as% 1 fib(1) %as% 1 fib(n) %as% { fib(n-1) + fib(n-2) } seal(fib) act <- fib(4) checkEquals(act, 5) } test.type_any_type_2 <- function() { hypotenuse(a,b) %::% . : . : numeric hypotenuse(a,b) %as% { (a^2 + b^2)^.5 } seal(hypotenuse) act <- hypotenuse(3,4) checkEquals(act,5) } test.type_any_type_3 <- function() { hypotenuse(a,b) %::% numeric : numeric: . hypotenuse(a,b) %as% { (a^2 + b^2)^.5 } seal(hypotenuse) act <- hypotenuse(3,4) checkEquals(act,5) } test.type_any_type_4 <- function() { hypotenuse(a,b) %::% a : a: . hypotenuse(a,b) %as% { (a^2 + b^2)^.5 } seal(hypotenuse) act <- hypotenuse(3,4) checkEquals(act,5) } lambda.r/inst/unitTests/runit.type_integer_inheritance.R0000644000176200001440000000205513156117135023250 0ustar liggesuserstest.type_integer_1 <- function() { fib(n) %::% numeric : numeric fib(0) %as% 1 fib(1) %as% 1 fib(n) %as% { fib(n-1) + fib(n-2) } seal(fib) act <- fib(3) checkEquals(act, 3) } test.type_integer_2 <- function() { fib(n) %::% numeric : numeric fib(0) %as% 1 fib(1) %as% 1 fib(n) %as% { fib(n-1) + fib(n-2) } seal(fib) act <- fib(as.integer(3)) checkEquals(act, 3) } test.type_integer_5 <- function() { fib(n) %::% numeric : numeric fib(0) %as% as.integer(1) fib(1) %as% as.integer(1) fib(n) %as% { as.integer(fib(n-1) + fib(n-2)) } seal(fib) act <- fib(as.integer(3)) checkEquals(act, 3) } test.type_integer_3 <- function() { hypotenuse(a,b) %::% numeric : numeric : numeric hypotenuse(a,b) %as% { (a^2 + b^2)^.5 } seal(hypotenuse) act <- hypotenuse(as.integer(3),4) checkEquals(act,5) } test.type_integer_4 <- function() { hypotenuse(a,b) %::% numeric : numeric : numeric hypotenuse(a,b) %as% { (a^2 + b^2)^.5 } seal(hypotenuse) act <- hypotenuse(as.integer(3), as.integer(4)) checkEquals(act,5) } lambda.r/inst/unitTests/runit.examples.R0000644000176200001440000000047113156117135020017 0ustar liggesuserstest.example_1 <- function() { reciprocal(x) %::% numeric : numeric reciprocal(x) %when% { x != 0 } %as% { 1 / x } reciprocal(x) %::% character : numeric reciprocal(x) %as% { reciprocal(as.numeric(x)) } act <- reciprocal(4) checkEquals(act, 0.25) act <- reciprocal("4") checkEquals(act, 0.25) } lambda.r/inst/unitTests/runit.parse_transforms.3.R0000644000176200001440000000070713156117135021734 0ustar liggesusersWishartModel(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 } test.parse_transforms_3 <- function() { model <- WishartModel(10,20,2,1) mat <- WishartMatrix(rnorm(10), model) checkEquals(attr(mat,'n'), 10) checkEquals(attr(mat,'m'), 20) checkEquals(attr(mat,'Q'), 2) checkEquals(attr(mat,'sd'),1) } lambda.r/inst/unitTests/runit.taylor_series.1.R0000644000176200001440000000214713156117135021226 0ustar liggesuserscompare <- function(a,b, xs) { plot(xs, a(xs), type='l') lines(xs, b(xs), type='l', col='blue') invisible() } # f <- taylor(sin, pi) # xs <- seq(2,4.5,0.02) # compare(sin,f, xs) # # p <- function(x) x^4 + 3 * (x-2)^3 - 2 * x^2 + 1 # p1 <- function(x) 4*x^3 + 9*(x-2)^2 - 4*x # p2 <- function(x) 12*x^2 + 18*(x-2) - 4 # p3 <- function(x) 24*x + 18 # # f <- taylor(p, 1) # xs <- seq(-5,5,0.02) # compare(p,f, xs) # # f(x) ~ f(a) + f'(a) * (x - a) + f''(a) / 2! * (x - a)^2 + ... test.taylor_series_1 <- function() { seal(fac) fac(1) %as% 1 fac(n) %when% { n > 0 } %as% { n * fac(n - 1) } # TODO: Implement this properly for k > 2 d(f, 1, h=10^-9) %as% function(x) { (f(x + h) - f(x - h)) / (2*h) } d(f, 2, h=10^-9) %as% function(x) { (f(x + h) - 2*f(x) + f(x - h)) / h^2 } taylor(f, a, step=2) %as% taylor(f, a, step, 1, function(x) f(a)) taylor(f, a, 0, k, g) %as% g taylor(f, a, step, k, g) %as% { df <- d(f,k) g1 <- function(x) { g(x) + df(a) * (x - a)^k / fac(k) } taylor(f, a, step-1, k+1, g1) } f <- taylor(sin, pi) v <- f(3.1) checkEquals(v, sin(3.1), tolerance=0.01) } lambda.r/inst/unitTests/runit.type_inheritance.R0000644000176200001440000000364213156117135021536 0ustar liggesusers test.inheritance_one_arg <- function() { Base(x) %as% x A(x) %as% { Base(x) } B(x) %as% { A(x) } E(x) %as% { Base(x) } one.arg(x) %::% A : character one.arg(x) %as% { "a" } one.arg(x) %::% Base : character one.arg(x) %as% { "base" } seal(Base) seal(A) seal(B) seal(E) seal(one.arg) a <- A(1) b <- B(2) c <- E(3) act.a <- one.arg(a) checkEquals(act.a, "a") act.b <- one.arg(b) checkEquals(act.b, "a") act.c <- one.arg(c) checkEquals(act.c, "base") } test.inheritance_two_arg <- function() { Base(x) %as% x A(x) %as% { Base(x) } B(x) %as% { A(x) } E(x) %as% { Base(x) } two.arg(x,y) %::% A : B : character two.arg(x,y) %as% { "a" } two.arg(x,y) %::% Base : Base : character two.arg(x,y) %as% { "base" } seal(Base) seal(A) seal(B) seal(E) seal(two.arg) a <- A(1) b <- B(2) c <- E(3) act.a <- two.arg(a,b) checkEquals(act.a, "a") act.b <- two.arg(b,b) checkEquals(act.b, "a") act.c <- two.arg(c,b) checkEquals(act.c, "base") } test.inheritance_with_type_variable <- function() { Base(x) %as% x A(x) %as% { Base(x) } B(x) %as% { A(x) } E(x) %as% { Base(x) } two.arg(x,y) %::% a : B : character two.arg(x,y) %as% { "a" } two.arg(x,y) %::% Base : Base : character two.arg(x,y) %as% { "base" } seal(Base) seal(A) seal(B) seal(E) seal(two.arg) a <- A(1) b <- B(2) c <- E(3) act.a <- two.arg(a,b) checkEquals(act.a, "a") act.b <- two.arg(b,b) checkEquals(act.b, "a") act.c <- two.arg(c,b) checkEquals(act.c, "a") } test.inheritance_with_ellipsis_1 <- function() { Base(x, ...) %as% list(x=x, ...) A(x, z) %as% { Base(x, z=z) } seal(Base) seal(A) a <- A(1, 2) checkEquals(a$x, 1) checkEquals(a$z, 2) } test.inheritance_with_ellipsis_2 <- function() { Base(x=1, ...) %as% list(x=x, ...) A(z) %as% { Base(z=z) } seal(Base) seal(A) a <- A(2) checkEquals(a$x, 1) checkEquals(a$z, 2) } lambda.r/inst/unitTests/runit.types.1.R0000644000176200001440000000272113156117135017504 0ustar liggesusers# vim: set filetype=R test.types_1 <- function() { A(x) %as% x B(x) %as% x f(a,b) %::% A : B : numeric f(a,0) %when% { a < 5; a > 0 } %as% { z <- a + 2; unclass(z * 2) } f(a,b) %when% { a < 0 } %as% { unclass(abs(a) + b) } f(a,b) %as% { unclass(a + b) } seal(A) seal(B) seal(f) act.1 <- tryCatch(f(2,3), error=function(x) 'error') cat("[test.types_1] act.1 =",act.1,"\n") checkEquals(act.1, 'error') a <- A(2) b <- B(3) act.2 <- f(a,b) checkEquals(act.2, 5) } test.types_2.1 <- function() { Point(x,y) %as% list(x=x,y=y) Polar(r,theta) %as% list(r=r,theta=theta) distance(a,b) %::% Point : Point : numeric distance(a,b) %as% { ((a$x - b$x)^2 + (a$y - b$y)^2)^.5 } distance(a,b) %::% Polar : Polar : numeric distance(a,b) %as% { (a$r^2 + b$r^2 - 2 * a$r * b$r * cos(a$theta - b$theta))^.5 } seal(Point) seal(Polar) seal(distance) point.1 <- Point(2,3) point.2 <- Point(5,7) checkEquals(distance(point.1,point.2), 5) } test.types_2.2 <- function() { Point(x,y) %as% list(x=x,y=y) Polar(r,theta) %as% list(r=r,theta=theta) distance(a,b) %::% Point : Point : numeric distance(a,b) %as% { ((a$x - b$x)^2 + (a$y - b$y)^2)^.5 } distance(a,b) %::% Polar : Polar : numeric distance(a,b) %as% { (a$r^2 + b$r^2 - 2 * a$r * b$r * cos(a$theta - b$theta))^.5 } seal(Point) seal(Polar) seal(distance) point.3 <- Polar(3,pi/2) point.4 <- Polar(4,pi) checkEquals(distance(point.3,point.4), 5) } lambda.r/inst/unitTests/runit.ellipsis_arguments.1.R0000644000176200001440000000147613156117135022257 0ustar liggesusersPrices(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) test.ellipsis_arguments_1 <- function() { ps <- Prices(rnorm(50), 'equity', 'daily') visualize(ps, main='Prices', xlab='time') scatter <- matrix(rnorm(200), ncol=2) act <- tryCatch(visualize(scatter), error=function(x) 'error') checkEquals(act, 'error') attr(scatter,'visualize') <- TRUE visualize(scatter) visualize(scatter, main='random') } test.ellipsis_unnamed_arguments <- function() { act <- dummy(1,2) checkEquals(act, list(2)) act <- dummy(1,2,3,4) checkEquals(act, list(2,3,4)) } lambda.r/inst/unitTests/runit.parse_transforms.2.R0000644000176200001440000000063413156117135021732 0ustar liggesusersTemperature(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 } } test.parse_transforms_2 <- function() { temp <- Temperature(20, 'metric', 'celsius') checkEquals(attr(temp,'system'), 'metric') checkEquals(attr(temp,'units'), 'celsius') checkTrue(! freezing(temp)) } lambda.r/inst/unitTests/runit.factorial.1.R0000644000176200001440000000037113156117135020303 0ustar liggesuserstest.factorial_1 <- function() { fac(0) %as% 1 fac(n) %when% { n > 0 } %as% { n * fac(n - 1) } seal(fac) checkEquals(fac(1), 1) checkEquals(fac(5), 120) act <- tryCatch(fac(-1), error=function(x) 'error') checkEquals(act, 'error') } lambda.r/inst/unitTests/runit.auto_replace.3.R0000644000176200001440000000042613156117135021005 0ustar liggesuserstest.auto_replace_3 <- function() { fib(0) %as% 2 fib(0) %as% 1 fib(1) %as% 1 fib(n=5) %as% { fib(n-1) - fib(n-2) } fib(n=2) %as% { fib(n-1) + fib(n-2) } seal(fib) # These are failing act <- fib(3) checkEquals(act, 3) act <- fib(2) checkEquals(act, 2) } lambda.r/inst/unitTests/runit.heaviside_step.2.R0000644000176200001440000000053213156117135021333 0ustar liggesuserstest.heaviside_2 <- function() { h.step(n) %::% numeric : numeric h.step(n) %when% { n < 0 } %as% { 0 } h.step(0) %as% 0.5 h.step(n) %as% 1 seal(h.step) checkEquals(h.step(-1), 0) checkEquals(h.step(0), 0.5) checkEquals(h.step(1), 1) # TODO: This throws an error in the shell but not via RUnit #checkException(h.step("a")) } lambda.r/inst/unitTests/runit.function_args.1.R0000644000176200001440000000113513156117135021177 0ustar liggesuserstest.function_args_1 <- function() { f() %as% 1 seal(f) act <- f() checkEquals(act,1) } test.function_args_2 <- function() { f() %::% numeric f() %as% 1 seal(f) act <- f() checkEquals(act,1) } test.function_args_3 <- function() { f() %::% numeric f() %as% 1 f(a) %::% numeric : numeric f(a) %as% a seal(f) act <- f() checkEquals(act,1) act <- f(3) checkEquals(act,3) } test.function_args_4 <- function() { f() %::% numeric f() %:=% 1 f(a) %::% numeric : numeric f(a) %:=% a seal(f) act <- f() checkEquals(act,1) act <- f(3) checkEquals(act,3) } lambda.r/inst/unitTests/runit.optional_arguments.1.R0000644000176200001440000000365513156117135022261 0ustar liggesusers# vim: set filetype=R test.optional_arguments_1a <- function() { 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))) checkEquals(attr(ps,'asset.class'), 'equity') checkEquals(attr(ps,'periodicity'), 'daily') ps <- Prices(abs(rnorm(50)), 'fx') checkEquals(attr(ps,'asset.class'), 'fx') checkEquals(attr(ps,'periodicity'), 'daily') ps <- Prices(abs(rnorm(50)), periodicity='monthly') checkEquals(attr(ps,'asset.class'), 'equity') checkEquals(attr(ps,'periodicity'), 'monthly') ps <- Prices(periodicity='monthly', series=abs(rnorm(50))) checkEquals(attr(ps,'asset.class'), 'equity') checkEquals(attr(ps,'periodicity'), 'monthly') err <- tryCatch(returns(ps), error=function(x) 'error') checkEquals(err, 'error') ps <- Prices(abs(rnorm(50))) checkEquals(length(returns(ps)), length(ps) - 1) } test.optional_arguments_1b <- function() { Temperature(x, system='metric', units='celsius') %as% { x@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) checkTrue(! freezing(ctemp)) ktemp <- Temperature(20, units='kelvin') checkTrue(freezing(ktemp)) } test.optional_arguments_1c <- function() { avg(x, fun=mean) %as% { fun(x) } a <- 1:4 a.mean <- avg(a) checkEquals(a.mean, 2.5) a.med <- avg(a, median) checkEquals(a.med, 2.5) } lambda.r/inst/unitTests/runit.auto_replace.2.R0000644000176200001440000000236413156117135021007 0ustar liggesuserstest.auto_replace.types_2a <- function() { fib(n) %::% numeric : numeric fib(0) %as% 1 fib(1) %as% 2 fib(n) %as% { fib(n-1) - fib(n-2) } fib(n) %as% { fib(n-1) + fib(n-2) } fib(n) %::% character : numeric fib(n) %as% { fib(as.numeric(n)) } fib(n) %::% numeric : numeric fib(1) %as% 1 seal(fib) act <- fib(3) checkEquals(act, 3) act <- fib("3") checkEquals(act, 3) } test.auto_replace.types_2b <- function() { fib() %::% numeric fib() %as% 3 fib(n) %::% numeric : numeric fib(0) %as% 1 fib(1) %as% 2 fib(n) %as% { fib(n-1) - fib(n-2) } fib(n) %as% { fib(n-1) + fib(n-2) } fib(n) %::% character : numeric fib(n) %as% { fib(as.numeric(n)) } fib(n) %::% numeric : numeric fib(1) %as% 1 fib() %as% 5 seal(fib) act <- fib(3) checkEquals(act, 3) act <- fib("3") checkEquals(act, 3) act <- fib() checkEquals(act, 5) } test.auto_replace.types_2c <- function() { fib() %::% numeric fib() %as% 3 fib() %as% 5 seal(fib) act <- fib() checkEquals(act, 5) } test.auto_replace.types_2d <- function() { fib() %::% numeric fib() %as% 3 fib(n) %::% numeric : numeric fib(n) %as% n fib() %as% 5 seal(fib) act <- fib() checkEquals(act, 5) act <- fib(4) checkEquals(act, 4) } lambda.r/inst/unitTests/runit.infix.1.R0000644000176200001440000000042413156117135017453 0ustar liggesuserstest.infix.1 <- function() { a %mod% b %:=% { a %/% b } seal(`%mod%`) act <- 5 %mod% 2 exp <- 5 %/% 2 checkEquals(act, exp) } test.infix.2 <- function() { a %mod% b %as% { a %/% b } seal(`%mod%`) act <- 5 %mod% 2 exp <- 5 %/% 2 checkEquals(act, exp) } lambda.r/inst/unitTests/runit.factorial.2.R0000644000176200001440000000102513156117135020301 0ustar liggesuserstest.factorial_2 <- function() { WholeNumber(x) %when% { x > 0 } %as% x fac(n) %::% WholeNumber : WholeNumber fac(0) %as% WholeNumber(1) fac(n) %when% { n > 0 } %as% { n * fac(n - 1) } fac(n) %::% numeric : WholeNumber fac(n) %as% fac(WholeNumber(n)) checkEquals(fac(WholeNumber(1)), WholeNumber(1)) checkEquals(fac(WholeNumber(5)), WholeNumber(120)) checkEquals(fac(1), WholeNumber(1)) checkEquals(fac(5), WholeNumber(120)) act <- tryCatch(fac(-1), error=function(x) 'error') checkEquals(act, 'error') } lambda.r/inst/unitTests/runit.fill_args.R0000644000176200001440000000162213156117135020142 0ustar liggesusers#act <- tryCatch(fib(3), error=function(x) 'error') #checkEquals(act, 'error') test.type_fill_args_1 <- function() { mysum(x, y, ...) %as% { (x - y) * sum(...) } seal(mysum) act <- mysum(2, 3, 1, 2, 3) checkEquals(act, -6) act <- mysum(x=2, 3, 1, 2, 3) checkEquals(act, -6) act <- mysum(2, y=3, 1, 2, 3) checkEquals(act, -6) act <- mysum(y=3, x=2, 1, 2, 3) checkEquals(act, -6) act <- mysum(y=3, 1, 2, 3, x=2) checkEquals(act, -6) act <- mysum(2, 1, 2, 3, y=3) checkEquals(act, -6) } test.type_fill_args_2 <- function() { mysum(x, y=3, ...) %as% { (x - y) * sum(...) } seal(mysum) act <- mysum(2, 1, 1, 2, 3) checkEquals(act, -7) act <- mysum(1, y=2, 1, 1, 2, 3) checkEquals(act, -7) act <- mysum(y=2, x=1, 1, 1, 2, 3) checkEquals(act, -7) act <- mysum(1, 1, 2, 3, x=2) checkEquals(act, -7) act <- mysum(1, 1, 1, 2, 3, y=2) checkEquals(act, -7) } lambda.r/inst/unitTests/runit.heaviside_step.1.R0000644000176200001440000000033213156117135021330 0ustar liggesuserstest.heaviside_1 <- function() { h.step(n) %when% { n < 0 } %as% { 0 } h.step(0) %as% 0.5 h.step(n) %as% 1 seal(h.step) checkTrue(h.step(-1) == 0) checkTrue(h.step(0) == 0.5) checkTrue(h.step(1) == 1) } lambda.r/inst/unitTests/runit.type_ellipsis.R0000644000176200001440000000174113156117135021067 0ustar liggesusers#act <- tryCatch(fib(3), error=function(x) 'error') #checkEquals(act, 'error') test.type_ellipsis_1 <- function() { ioc(f, ...) %::% Function : ... : . ioc(f, ...) %as% f(...) seal(ioc) act <- ioc(sum, 1, 2, 3) checkEquals(act, 6) } test.type_ellipsis_2 <- function() { ioc(f, ...) %::% Function : ... : numeric ioc(f, ...) %as% f(...) seal(ioc) act <- ioc(sum, 1, 2, 3) checkEquals(act, 6) } test.type_ellipsis_3 <- function() { mysum(x, ...) %::% a : ... : numeric mysum(x, ...) %as% sum(...) seal(mysum) act <- mysum('foo', 1, 2, 3) checkEquals(act, 6) } test.type_ellipsis_4 <- function() { mysum(..., x) %::% ... : logical : numeric mysum(..., x) %as% sum(..., na.rm=x) seal(mysum) act <- mysum(1, 2, 3, x=TRUE) checkEquals(act, 6) } test.type_ellipsis_var_1 <- function() { mysum(..., x) %::% numeric... : logical : numeric mysum(..., x) %as% sum(..., na.rm=x) seal(mysum) act <- mysum(1, 2, 3, x=FALSE) checkEquals(act, 6) } lambda.r/inst/unitTests/runit.auto_replace.1.R0000644000176200001440000000145013156117135021001 0ustar liggesuserstest.auto_replace.no_types_1a <- function() { fib(0) %as% 2 fib(0) %as% 1 fib(1) %as% 1 fib(n) %as% { fib(n-1) + fib(n-2) } seal(fib) act <- fib(3) checkEquals(act, 3) } test.auto_replace.no_types_1b <- function() { fib(0) %as% 2 fib(0) %as% 1 fib(1) %as% 1 fib(n) %as% { fib(n-1) - fib(n-2) } fib(n) %as% { fib(n-1) + fib(n-2) } seal(fib) act <- fib(3) checkEquals(act, 3) } # Zero argument functions test.auto_replace.no_types_1c <- function() { foo() %as% 2 foo() %as% 1 seal(foo) act <- foo() checkEquals(act, 1) } # Zero argument functions as part of a multipart definition test.auto_replace.no_types_1c <- function() { foo(n) %as% n foo() %as% 2 foo() %as% 1 seal(foo) act <- foo() checkEquals(act, 1) act <- foo(5) checkEquals(act, 5) } lambda.r/inst/unitTests/runit.pattern_matching.R0000644000176200001440000000104313156117135021524 0ustar liggesusers# :vim set filetype=R test.pattern_null <- function() { fold(f, x, acc) %as% acc fold(f, NULL, acc) %as% acc act <- fold(function(x,y) x + y, NULL, 5) checkEquals(5, act) } test.pattern_na <- function() { fold(f, x, acc) %as% acc fold(f, NA, acc) %as% acc act <- fold(function(x,y) x + y, NA, 5) checkEquals(5, act) } test.pattern_empty <- function() { fold(f, EMPTY, acc) %as% acc fold(f,x,acc) %as% { fold(f,x[-1], f(x[1],acc)) } plus <- function(x,y) x + y act <- fold(plus, 1:5, 0) checkEquals(15, act) } lambda.r/inst/unitTests/runit.dispatching.1.R0000644000176200001440000000347713156117135020646 0ustar liggesuserstest.dispatching_1a <- function() { fib(0) %as% 1 fib(1) %as% 1 fib(n) %when% { abs(n - round(n)) < .Machine$double.eps^0.5 } %as% { fib(n-1) + fib(n-2) } seal(fib) checkEquals(fib(5), 8) } test.dispatching_1b <- function() { fib(n) %::% numeric : numeric fib(0) %as% 1 fib(1) %as% 1 fib(n) %as% { fib(n-1) + fib(n-2) } seal(fib) act.1 <- fib(5) checkEquals(act.1, 8) act.2 <- tryCatch(fib("a"), error=function(x) 'error') checkEquals(act.2, 'error') } test.dispatching_1c <- function() { Integer(x) %as% x fib(n) %::% Integer : Integer fib(0) %as% Integer(1) fib(1) %as% Integer(1) fib(n) %as% { Integer(fib(n-1) + fib(n-2)) } seal(Integer) seal(fib) checkEquals(fib(Integer(5)), Integer(8)) act <- tryCatch(fib(5), error=function(x) 'error') checkEquals(act, 'error') } test.dispatching_1d <- function() { abs_max(a,b) %::% numeric : numeric : numeric abs_max(a,b) %when% { a != b } %as% { pmax(abs(a), abs(b)) } abs_max(a,b) %::% character : character : numeric abs_max(a,b) %as% { abs_max(as.numeric(a), as.numeric(b)) } abs_max(a) %as% { max(abs(a)) } seal(abs_max) checkEquals(abs_max(2,-3), 3) checkEquals(abs_max("3","-4"), 4) a <- c(1,2,5,6,3,2,1,3) checkEquals(abs_max(a), 6) } test.different_names <- function() { A(a) %as% { list(a=a) } A(b) %as% { list(b=b) } seal(A) checkEquals(A(5)$a, 5) checkEquals(A(a=5)$a, 5) checkEquals(A(b=5)$b, 5) } test.empty_function <- function() { a() %as% { } seal(a) b(a) %as% { } seal(b) # Empty functions will fail checkException(a(), NULL) checkException(b(1), NULL) } test.empty_type_constructor <- function() { A() %as% { } seal(A) B(a) %as% { } seal(B) # Empty functions will fail checkException(A(), NULL) checkException(B(1), NULL) } lambda.r/inst/unitTests/runit.function_type.1.R0000644000176200001440000000042113156117135021221 0ustar liggesuserstest.function_type_1 <- function() { seq.gen(start) %::% a : Function seq.gen(start) %as% { value <- start - 1 function() { value <<- value + 1 return(value) } } seal(seq.gen) act <- seq.gen(1) checkTrue('function' %in% class(act)) } lambda.r/inst/unitTests/runit.ellipsis_arguments.2.R0000644000176200001440000000110713156117135022247 0ustar liggesusers# :vim set filetype=R regress(formula, ..., na.action=na.fail) %as% { lm(formula, ..., na.action=na.action) } seal(regress) test.ellipsis_arguments_2 <- function() { ctl <- c(4.17,5.58,5.18,6.11,4.50,4.61,5.17,4.53,5.33,5.14) trt <- c(4.81,4.17,4.41,3.59,5.87,3.83,6.03,4.89,4.32,4.69) data <- data.frame(group=gl(2,10,20,labels=c("Ctl","Trt")), weight=c(ctl, trt)) lm.1 <- regress(weight ~ group, data=data) lm.2 <- regress(data=data, formula=weight ~ group) checkTrue(all(lm.2$coefficients == lm.1$coefficients)) checkTrue(all(lm.2$residuals == lm.1$residuals)) } lambda.r/tests/0000755000176200001440000000000013156117135013077 5ustar liggesuserslambda.r/tests/doRUnit.R0000644000176200001440000000415513156117135014613 0ustar liggesusers# From http://rwiki.sciviews.org/doku.php?id=developers:runit ## unit tests will not be done if RUnit is not available if(require("RUnit", quietly=TRUE)) { ## --- Setup --- pkg <- "lambda.r" # <-- Change to name! if(Sys.getenv("RCMDCHECK") == "FALSE") { ## Path to unit tests for standalone running under Makefile (not R CMD check) ## PKG/tests/../inst/unitTests path <- file.path(getwd(), "..", "inst", "unitTests") } else { ## Path to unit tests for R CMD check ## PKG.Rcheck/tests/../PKG/unitTests path <- system.file(package=pkg, "unitTests") } cat("\nRunning unit tests\n") print(list(pkg=pkg, getwd=getwd(), pathToUnitTests=path)) library(package=pkg, character.only=TRUE) ## If desired, load the name space to allow testing of private functions ## if (is.element(pkg, loadedNamespaces())) ## attach(loadNamespace(pkg), name=paste("namespace", pkg, sep=":"), pos=3) ## ## or simply call PKG:::myPrivateFunction() in tests ## --- Testing --- ## Define tests testSuite <- defineTestSuite(name=paste(pkg, "unit testing"), dirs=path) ## Run tests <- runTestSuite(testSuite) ## Default report name pathReport <- file.path(path, "report") ## Report to stdout and text files cat("------------------- UNIT TEST SUMMARY ---------------------\n\n") printTextProtocol(tests, showDetails=FALSE) printTextProtocol(tests, showDetails=FALSE, fileName=paste(pathReport, "Summary.txt", sep="")) printTextProtocol(tests, showDetails=TRUE, fileName=paste(pathReport, ".txt", sep="")) ## Report to HTML file printHTMLProtocol(tests, fileName=paste(pathReport, ".html", sep="")) ## Return stop() to cause R CMD check stop in case of ## - failures i.e. FALSE to unit tests or ## - errors i.e. R errors tmp <- getErrors(tests) if(tmp$nFail > 0 | tmp$nErr > 0) { stop(paste("\n\nunit testing failed (#test failures: ", tmp$nFail, ", #R errors: ", tmp$nErr, ")\n\n", sep="")) } } else { warning("cannot run unit tests -- package RUnit is not available") } lambda.r/NAMESPACE0000644000176200001440000000064513156117135013161 0ustar liggesusersimportFrom("utils", "capture.output", "getParseData", "str", "tail") 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%") lambda.r/R/0000755000176200001440000000000013156117135012136 5ustar liggesuserslambda.r/R/introspection.R0000644000176200001440000000457613156117135015175 0ustar liggesusersdescribe(fn, idx, raw=FALSE) %when% { raw } %as% { class(fn) <- NULL print(fn) } describe(fn, idx) %when% { idx > 0 } %as% { variants <- attr(fn,'variants') types <- attr(fn,'types') if (length(variants) < 1) stop("Nothing to describe") if (idx > length(variants)) stop("Invalid index specified") variants[[idx]]$def } seal(describe) debug.lr <- function(x) { name <- deparse(substitute(x)) os <- getOption('lambdar.debug') if (is.null(os)) os <- list() os[[name]] <- TRUE options(lambdar.debug=os) if (! any(c('lambdar.fun','lambdar.type') %in% class(x))) return(debug(x)) variants <- attr(x,'variants') sapply(variants, function(v) debug(v$def)) invisible() } undebug.lr <- function(x) { if (is.function(x)) { name <- deparse(substitute(x)) } else { name <- x x <- get(x, parent.frame(), inherits=TRUE) } os <- getOption('lambdar.debug') if (is.null(os)) return(invisible()) os[[name]] <- NULL options(lambdar.debug=os) if (! any(c('lambdar.fun','lambdar.type') %in% class(x))) return(undebug(x)) variants <- attr(x,'variants') sapply(variants, function(v) undebug(v$def)) invisible() } #' Undebug all registered functions undebug.all <- function() { sapply(which.debug(), undebug.lr) invisible() } is.debug <- function(fn.name) { os <- getOption('lambdar.debug') fn.name %in% names(os) } which.debug <- function() { names(getOption('lambdar.debug')) } print.lambdar.fun <- function(x, ...) { variants <- attr(x,'variants') types <- attr(x,'types') if (is.null(variants)) stop("Oops: lambda.r function incorrectly defined") if (length(variants) < 1) stop("Function has no clauses") cat("\n") fn <- function(idx) { f <- variants[[idx]] cat("[[",idx,"]]\n",sep='') if (!is.null(f$type.index)) cat(types[[f$type.index]]$signature,"\n") cat(f$signature,"%as% ...\n") } sapply(1:length(variants),fn) invisible() } print.lambdar.type <- function(x, ...) { variants <- attr(x,'variants') types <- attr(x,'types') if (is.null(variants)) stop("Oops: lambda.R type constructor incorrectly defined") cat("\n") fn <- function(idx) { f <- variants[[idx]] cat("[[",idx,"]]\n",sep='') if (!is.null(f$type.index)) cat(types[[f$type.index]]$signature,"\n") cat(f$signature,"%as% ...\n") } sapply(1:length(variants),fn) invisible() } lambda.r/R/objects.R0000644000176200001440000000005113156117135013706 0ustar liggesusersMissingReturnType <- "MissingReturnType" lambda.r/R/duck.R0000644000176200001440000000151313156117135013207 0ustar liggesusers'%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)) } lambda.r/R/framework.R0000644000176200001440000010127313156117135014262 0ustar liggesusersEMPTY <- 'EMPTY' #' Check if name is bound to a non-lambda.r object is.bound <- function(name) { if (! exists(name, inherits=TRUE)) return(FALSE) o <- get(name, inherits=TRUE) ! any(c('lambdar.fun','lambdar.type') %in% class(o)) } # f(a,b) %::% A : B : C '%::%' <- function(signature, types) { os <- options(keep.source=TRUE) s.expr <- paste(deparse(substitute(signature)), collapse="\n") t.expr <- paste(deparse(substitute(types)), collapse="\n") text <- paste(s.expr,t.expr, sep=" %::% ") raw <- getParseData(parse(text=text)) # SPECIAL tokens now appear with a leading white space raw$text <- sub("^ ","", raw$text) it <- iterator(raw) tree <- list(args=NULL) args_expr <- parse_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) invisible() } # f(a,0) %when% { a < 5; a > 0 } %as% { z <- a + 2; z * 2 } # f(a,b) %when% { a < 0 } %as% { abs(a) + b } # f(a,b) %as% { a + b } '%as%' <- function(signature, body) { os <- options(keep.source=TRUE) s.expr <- paste(deparse(substitute(signature)), collapse="\n") b.expr <- paste(deparse(substitute(body)), collapse="\n") text <- paste(s.expr,b.expr, sep=" %as% ") raw <- getParseData(parse(text=text)) # SPECIAL tokens now appear with a leading white space raw$text <- sub("^ ","", raw$text) 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) 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, ...) { 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 NA } } get_name <- function(it) { line <- it() if (line$token != 'SYMBOL_FUNCTION_CALL') stop("Function must start with a symbol (instead of ",line$token,")") line$text } fast_forward <- function(it, what) { while (!is.na(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.na(line <- it()) && line$token != "SPECIAL") { line.token <- line$token if (line.token == 'expr') next if (line.token == "'('") { paren.level <- paren.level + 1 if (paren.level == 1) next # Opening function parenthesis } if (line.token == "')'") { paren.level <- paren.level - 1 if (paren.level < 1) # Closing function parenthesis { # Check for 0 argument function if (is.null(token) && is.null(pattern)) break # Otherwise... if (!is.null(token) && token == EMPTY) { token <- NULL pattern <- EMPTY } if (is.null(token)) token <- paste('.lambda',arg.idx,sep='_') if (is.null(pattern)) pattern <- NA #else pattern <- strip_quotes(paste(pattern, collapse=' ')) else pattern <- paste(pattern, collapse=' ') if (is.null(default)) default <- NA #else default <- strip_quotes(paste(default, collapse=' ')) else default <- paste(default, collapse=' ') out <- rbind(out, c(1,node,token,pattern,default)) break } } #cat("paren.level:",paren.level,"\n") if (paren.level == 1) { if (!in.default && line.token %in% c('SYMBOL','SYMBOL_SUB','SYMBOL_FUNCTION_CALL')) { token <- line$text next } if (line.token == 'EQ_SUB') { in.default <- TRUE next } # Close current node if (line.token == "','") { if (!is.null(token) && token == EMPTY) { token <- NULL pattern <- EMPTY } if (is.null(token)) token <- paste('.lambda',arg.idx,sep='_') if (is.null(pattern)) pattern <- NA #else pattern <- strip_quotes(paste(pattern, collapse=' ')) else pattern <- paste(pattern, collapse=' ') if (is.null(default)) default <- NA #else default <- strip_quotes(paste(default, collapse=' ')) else default <- paste(default, collapse=' ') out <- rbind(out, c(paren.level,node,token,pattern,default)) token <- pattern <- default <- NULL node <- 'argument' arg.idx <- arg.idx + 1 in.default <- FALSE next } # TODO: Current structure will fail if a default uses a function call # with multiple arguments (due to the comma) if (in.default) { default <- c(default, line$text) #cat("Adding to default value:",line$text,"\n") } else pattern <- c(pattern, line$text) } else { default <- c(default, line$text) #cat("Default is now",default,"\n") } } out } strip_quotes <- function(x) sub('^[\'"]([^\'"]+)[\'"]$', '\\1', x) parse_guard <- function(it) { guards <- NULL while (!is.na(line <- it()) && line$token != "SPECIAL") next if (line$text == '%when%') { line <- it() if (line$token != "'{'") stop("Guard missing opening block") while (!is.na(line <- it()) && line$token != "'}'") { if (line$token %in% c("'{'")) stop("Invalid symbol '",line$text,"'in function definition") #if (line$token %in% c('expr',"','")) next if (line$token %in% c('expr')) next guards <- rbind(guards, line) } #while (!is.na(line <- it()) && line$token != "SPECIAL") next } else it(rewind=TRUE) guards[,c('line1','token','text')] } guard_fn <- function(raw.args, tree, where) { lines <- NULL # Add any pattern matches if (any(!is.na(raw.args$pattern))) { patterns <- raw.args[!is.na(raw.args$pattern),] f <- function(x) { if (patterns$pattern[x] == 'NULL') paste("is.null(", patterns$token[x],")", sep='') else if (patterns$pattern[x] == 'NA') paste("is.na(", patterns$token[x],")", sep='') else if (patterns$pattern[x] == 'EMPTY') paste("length(", patterns$token[x],") == 0 || ", "(!is.null(dim(",patterns$token[x],")) && ", "nrow(",patterns$token[x],") == 0)" , sep='') else paste(patterns$token[x],'==',patterns$pattern[x], sep=' ') } lines <- sapply(1:nrow(patterns), f) } # Add explicit guards if (!is.null(tree)) { f <- function(x) paste(tree[tree$line1 %in% x,]$text, collapse=' ') index <- array(unique(tree$line1)) lines <- c(lines,apply(index,1,f)) } if (length(lines) < 1) return(NULL) body <- paste(lines, collapse=' & ') arg.string <- paste(raw.args$token, collapse=',') fn.string <- sprintf("function(%s) { %s }", arg.string, body) eval(parse(text=fn.string), where) } # A parse transform to change object@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.na(line <- it()) && line$token != "SPECIAL") next if (line$text == '%as%') { needs.wrapping <- FALSE while (!is.na(line <- it()) && TRUE) { if (line$token %in% c('expr')) next body <- rbind(body, line) } } else it(rewind=TRUE) body[,c('line1','token','text')] } body_fn <- function(raw.args, tree, where) { if (tree$token[1] == "'{'") tree <- tree[2:(nrow(tree)-1), ] lines <- NULL if (!is.null(tree)) { f <- function(x) paste(tree[tree$line1 %in% x,]$text, collapse=' ') index <- unique(tree$line1) lines <- lapply(index,f) } if (length(lines) < 1) return(NULL) body <- paste(lines, collapse='\n') if (is.null(raw.args)) arg.string <- '' else arg.string <- paste(raw.args$token, collapse=',') fn.string <- sprintf("function(%s) { %s }", arg.string, body) eval(parse(text=fn.string), where) } parse_types <- function(it, args, sig) { types <- NULL while (!is.na(line <- it()) && line$token != "SPECIAL") next if (line$text == '%::%') { while (!is.na(line <- it()) && TRUE) { if (line$token %in% c("'{'", "'}'", "'('", "')'")) stop("Invalid symbol '",line$text,"'in definition of ",sig) if (line$token != "SYMBOL") next types <- rbind(types, line) } } if (is.null(args)) { if (nrow(types) != 1) stop("Incorrect number of parameters in type declaration for ",sig) } else { if (nrow(args) != nrow(types) - 1) stop("Incorrect number of parameters in type declaration for ",sig) } types[,c('line1','token','text')] } from_root_env <- function(frames) { length(frames) < 3 } add_variant <- function(fn.name, tree, where) { #cat("NOTE: Environment for",fn.name,"is\n", sep=' ') #print(sprintf("NOTE: Environment for %s is",fn.name)) #print(where) env <- capture.output(str(as.environment(where), give.attr=FALSE)) if (! is.null(tree$def)) { attr(tree$def,'topenv') <- env attr(tree$def,'name') <- fn.name } else { cat("NOTE: Empty body definition encountered for",tree$signature,"\n") } setup_parent(fn.name, where) fn <- get(fn.name, where) #cat(sprintf("The parent.env(%s) is\n", fn.name)) #print(parent.env(environment(fn))) #cat("\n") variants <- attr(fn,'variants') active.type <- attr(fn,'active.type') args <- NULL if (is.null(tree$args)) tree$accepts <- c(0,0) else { args <- tree$args required.args <- length(args$default[is.na(args$default)]) if ('...' %in% tree$args$token) tree$accepts <- c(required.args-1, Inf) #tree$accepts <- c(required.args : nrow(args) - 1, Inf) else tree$accepts <- c(required.args, nrow(args)) type.index <- get_type_index(fn, nrow(args), active.type) if (!is.null(type.index) && length(type.index) > 0) tree$type.index <- type.index } # Replace existing function clauses if there is a signature match idx <- has_variant(variants, args, tree$guard, active.type) if (length(idx) > 0) variants[[idx]] <- tree else variants[[length(variants) + 1]] <- tree attr(fn,'variants') <- variants assign(fn.name, fn, where) #if (! from_root_env(frames)) attach(where, name='lambda.r_temp_env') .sync_debug(fn.name) invisible() } get_variant <- function(fn, arg.length) { # u:0.007 s:0.000 raw <- attr(fn,'variants') len <- length(raw) matches <- vector(length=len) for (j in 1:len) { accepts <- raw[[j]]$accepts matches[j] <- arg.length >= accepts[1] && arg.length <= accepts[2] } raw[matches] } # Check whether this function already has the given variant has_variant <- function(variants, args, guard=NULL, active.type=NULL) { if (length(variants) == 0) return(variants) keys <- colnames(args)[! colnames(args) %in% 'default'] fn <- function(x) { v <- variants[[x]] if (!is.null(v$type.index) && !is.null(active.type) && v$type.index != active.type) return(NA) var.len <- ifelse(is.null(v$args), 0, nrow(v$args)) arg.len <- ifelse(is.null(args), 0, nrow(args)) if (var.len != arg.len) return(NA) if (var.len == 0) return (x) if (!is.null(v$guard) || !is.null(guard)) { if (!is.null(v$guard) && is.null(guard)) return(NA) if (is.null(v$guard) && !is.null(guard)) return(NA) dv <- deparse(v$guard) dg <- deparse(guard) if (length(dv) != length(dg)) return(NA) if (!all(deparse(v$guard) == deparse(guard))) return(NA) } args$pattern[is.na(args$pattern)] <- ".lambdar_NA" v$args$pattern[is.na(v$args$pattern)] <- ".lambdar_NA" ifelse(all(v$args[,keys] == args[,keys]),x, NA) } out <- sapply(1:length(variants), fn) out[!is.na(out)] } # Adds type constraint to function # If an existing type constraint is encountered, then the active.type index # will be set to this type constraint. This has the same effect as adding a # new constraint. add_type <- function(fn.name, tree) { frames <- sys.frames() if (length(frames) < 3) where <- topenv(parent.frame(2)) else where <- target_env(sys.calls()[[length(frames)-2]], length(frames)) setup_parent(fn.name, where) fn <- get(fn.name, where) types <- attr(fn,'types') if (is.null(tree$args)) tree$accepts <- c(0,0) else { args <- tree$args tree$accepts <- c(length(args$default[is.na(args$default)]), nrow(args)) } f <- function(x) { ifelse(types[[x]]$signature == tree$signature, x, NA) } if (length(types) > 0) { out <- sapply(1:length(types), f) } else out <- NA out <- out[!is.na(out)] idx <- ifelse(length(out) == 0, length(types) + 1, out[1]) types[[idx]] <- tree attr(fn,'types') <- types attr(fn,'active.type') <- idx assign(fn.name, fn, where) invisible() } # Type declarations are scoped based on when they are created. They continue # until a new type declaration is added. get_type <- function(fn, idx) { if (is.null(idx)) return(NULL) raw <- attr(fn,'types') if (length(raw) < 1) return(NULL) match <- raw[[idx]] # Use Function as a proxy for function char.type <- match$types$text match$types$text <- gsub('\\bFunction\\b','function',char.type, perl=TRUE) match } # Get the index for the most recent type declaration for the given arg.length get_type_index <- function(fn, arg.length, active.type) { raw <- attr(fn,'types') if (length(raw) < 1) return(NULL) if (!is.null(active.type) && !is.null(raw[[active.type]]$args) && nrow(raw[[active.type]]$args) == arg.length) return(active.type) match.fn <- function(x) any(arg.length >= raw[[x]]$accepts & arg.length <= raw[[x]]$accepts) matches <- data.frame(idx=(1:length(raw)), v=sapply(1:length(raw), match.fn)) if (!all(matches$v)) return(NULL) max(matches$idx[matches$v==TRUE]) } setup_parent <- function(parent, where) { # Overwrite a final definition (as opposed to appending) if (exists(parent, where)) { parent.def <- get(parent, where) is.final <- attr(parent.def, 'sealed') if ((!is.null(is.final) && is.final == TRUE) || (! any(c('lambdar.fun','lambdar.type') %in% class(parent.def))) ) { parent.def <- init_function(parent, where) assign(parent, parent.def, where) } } else { parent.def <- init_function(parent, where) assign(parent, parent.def, where) } } init_function <- function(name, where) { if (is.type(name)) { pattern <- 'function(...) NewObject(%s,"%s",...)' } else 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.na(line <- it()) && TRUE) { line.token <- line$token if (line.token == 'expr') next if (line.token == "'('") { paren.level <- paren.level + 1 if (paren.level == 1) next # Opening function parenthesis } if (line.token == "')'") { paren.level <- paren.level - 1 if (paren.level < 1) # Closing function parenthesis { out <- rbind(out, c(1,node,paste(token,collapse=' '),NA,NA)) break } } if (paren.level == 1 && line.token == "','") { out <- rbind(out, c(paren.level,node,paste(token,collapse=' '),NA,NA)) token <- NULL arg.idx <- arg.idx + 1 next } token <- c(token, line$text) } out } .sync_debug <- function(fn.name) { os <- getOption('lambdar.debug') if (is.null(os)) return(invisible()) os[[fn.name]] <- NULL options(lambdar.debug=os) invisible() } lambda.r/MD50000644000176200001440000000522013157271277012255 0ustar liggesusers4e92c39cf64e3824ba4cd11eb898da6e *DESCRIPTION ca3a1ecc796004a7df7fff727b9a071a *NAMESPACE 1f1c9a9a097262fe0f7e3517eacefbee *R/duck.R faad7505b495be721120b590f71a2089 *R/framework.R adac14153bc41e3607ed9dec5da7830a *R/introspection.R c5d9ed228976ea81509c224506d65f2f *R/objects.R 97ceabf07d26fc1d390ed1bff9cceb55 *inst/unitTests/runit.auto_replace.1.R 225c406a39eb8f4318e19ac356ee5bd6 *inst/unitTests/runit.auto_replace.2.R 0e382f059b346b22f83b9dad307d3569 *inst/unitTests/runit.auto_replace.3.R 774e7bcaa994519ae86405c8d68387f3 *inst/unitTests/runit.dispatching.1.R 66fc3ac59a85c97a7719fd76fdede470 *inst/unitTests/runit.ellipsis_arguments.1.R 783580a79a572f49b0c28b5f74515abf *inst/unitTests/runit.ellipsis_arguments.2.R cb96ac32893792bd0fc5522e1d7deff6 *inst/unitTests/runit.examples.R f51390873d9ace14ff2c3c55a0867d35 *inst/unitTests/runit.factorial.1.R 080c9faea036e772a4bd4dd02dac65fa *inst/unitTests/runit.factorial.2.R 253426aaff845e9ffe8525e9c974f9c9 *inst/unitTests/runit.fill_args.R 1e71378d1ff9e32ee99992aa92189603 *inst/unitTests/runit.function_args.1.R d00182c9d7417129db68fc46d62fe471 *inst/unitTests/runit.function_type.1.R 65d13a07127f9509f88b624c6d16bb46 *inst/unitTests/runit.heaviside_step.1.R 979dce6f4f885fee49c796de79ec1ec8 *inst/unitTests/runit.heaviside_step.2.R 9dfabd92c09733909552ad26bccd8fc0 *inst/unitTests/runit.infix.1.R 9a61eb814b14d27344b3754263c153a0 *inst/unitTests/runit.optional_arguments.1.R c72938f7a98c6447fcbd768df14a717e *inst/unitTests/runit.optional_arguments.2.R cf791378a6213f7e874142eef8740170 *inst/unitTests/runit.parse_transforms.1.R a0f5aa44def62f0c236233fec1212661 *inst/unitTests/runit.parse_transforms.2.R 37f2bd279ecd0795fb230d1080f8ddba *inst/unitTests/runit.parse_transforms.3.R e8be891b03015204266313dd585da349 *inst/unitTests/runit.pattern_matching.R a1dfd153edb537cad1b9dc8c7942843d *inst/unitTests/runit.taylor_series.1.R d77fa33d1812e5be0b38431731594f41 *inst/unitTests/runit.type_any_type.R 5c30ae25c9229e753301695d28af2234 *inst/unitTests/runit.type_ellipsis.R ae772e8e2067de9da0b2b65d49d6afe8 *inst/unitTests/runit.type_functions.R 31dc52fd5a66f12a6c643e2b83c0fe53 *inst/unitTests/runit.type_inheritance.R 1188d14fa191eef5536250d967631a19 *inst/unitTests/runit.type_integer_inheritance.R 2440de145b19f5b20d7a9881d0ad0366 *inst/unitTests/runit.type_variable.1.R c6c8fe9189580c87fe3e35b0de73365b *inst/unitTests/runit.types.1.R a2c77e08d37644ae9f2ad53a00a487de *man/UseFunction.Rd 7954e4e489368550f3b029ae69756bc3 *man/duck.Rd c6780ccc995ee695572bc53982194816 *man/framework.Rd ad73256313b25f4a7ab5079204872ebd *man/introspection.Rd 9ab04d13bf4d3335d155e358ec28b7f7 *man/lambda.r-package.Rd 8e4fcf20f64e5f762f1e52d089e32ee9 *tests/doRUnit.R lambda.r/DESCRIPTION0000644000176200001440000000111213157271277013447 0ustar liggesusersPackage: lambda.r Type: Package Title: Modeling Data with Functional Programming Version: 1.2 Date: 2017-09-12 Depends: R (>= 3.0.0) Suggests: RUnit 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 NeedsCompilation: no Packaged: 2017-09-16 17:33:39 UTC; brian Repository: CRAN Date/Publication: 2017-09-16 18:51:43 UTC lambda.r/man/0000755000176200001440000000000013156117135012510 5ustar liggesuserslambda.r/man/lambda.r-package.Rd0000644000176200001440000003243113156117135016053 0ustar liggesusers\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\cr Date: \tab 2017-09-12\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) } lambda.r/man/framework.Rd0000644000176200001440000001004713156117135014776 0ustar liggesusers\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 } lambda.r/man/UseFunction.Rd0000644000176200001440000000261213156117135015242 0ustar liggesusers\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 } lambda.r/man/duck.Rd0000644000176200001440000000210513156117135013723 0ustar liggesusers\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 } lambda.r/man/introspection.Rd0000644000176200001440000000426613156117135015707 0ustar liggesusers\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 }