Skip to content

Instantly share code, notes, and snippets.

@agentcoops
Created September 1, 2010 16:54
Show Gist options
  • Save agentcoops/560995 to your computer and use it in GitHub Desktop.
Save agentcoops/560995 to your computer and use it in GitHub Desktop.
require("gtools")
require("hash")
# Thunks an expression. Basic lazy evaluation.
thunk <- defmacro(x, expr=function() x)
# But it turns out this is unnecessary! R lazily evaluates its arguments!
thunk2 <- function(x) { function() { x } }
# Further:
delayedAssign("x", 1/0)
# actually is better than what I'd implemented so far: creates a promise for
# x in environment. This also lets us define madness like the following:
expStringOfVar <- function(x) { deparse(substitute(x)) }
# which is a function that returns a string of the parameter x..
# this is a function which accepts two functions, f, g, and returns a new
# f such that f in f points to g. optionally accepts the original name of
# f since we don't know how nested this call is...
modifyFnRecursion <- function(f, g, name=F) {
env <- new.env()
if (name == F) { name <- deparse(substitute(x)) }
assign(name, g, env)
environment(f) <- env
f
}
# The following is an s4 class which automatically memoizes a given function f
# without modification and handles recursion.
setClass("memoize", representation(cache="hash", f="function", reset="function"))
setMethod("initialize", "memoize",
function(.Object, f) {
f2 <- substitute(f)
originalFnName <- deparse(substitute(f2))
.Object@cache=hash()
.Object@reset= function() { .Object@cache = hash() }
.Object@f=
function(...) {
fnCallHash <- deparse(call(originalFnName, list(...)))
cachedValue <- .Object@cache[[fnCallHash]]
if (!is.null(cachedValue)) cachedValue
else {
f2 <- modifyFnRecursion(f, .Object@f, name=originalFnName)
computedValue <- f2(...)
.Object@cache[[fnCallHash]] <- computedValue
computedValue
}
}
.Object
})
# a helper function to ease initialization of memoize instances.
memoize <- function(f) {new ("memoize", f)}
# lets consider the naive recursive fib function.
fib = function(x) {if (x==1 || x==2) 1 else fib(x-2)+fib(x-1)}
# since I haven't quite figured out certain environmental scope issues we
# must define fib2 for testing.
fib2 = function(x) {if (x==1 || x==2) 1 else fib2(x-2)+fib2(x-1)}
# lets memoize fib.
mFib <- new("memoize", fib)
# and compare:
system.time(print(mFib@f(25)))
system.time(print(fib2(25)))
mFib@reset() # clear some memory...
#> system.time(print(fib2(25)))
#[1] 75025
# user system elapsed
# 2.370 0.007 2.384
#> system.time(print(mFib@f(25)))
#[1] 75025
# user system elapsed
# 0.000 0.000 0.001
# now lets try levinshtein distance.
cost <- function(x, y) ifelse(x == y, 0, 1)
levenshteinDistanceString <- function(str1, str2)
levenshteinDistance(strsplit(str1, "")[[1]],
strsplit(str2, "")[[1]])
levenshteinDistance <- function(lst1, lst2) {
if (length(lst1) == 0) length(lst2)
else if (length(lst2) == 0) length(lst1)
else min(cost(head(lst1, 1), head(lst2, 1)) +
levenshteinDistance(tail(lst1, -1), tail(lst2, -1)),
levenshteinDistance(tail(lst1, -1), lst2) + 1,
levenshteinDistance(lst1, tail(lst2, -1)) + 1)
}
# (naive) dynamic programming for free from the naive recursive solution.
# Lets define the function composition operator!
"$" <- function(...) UseMethod("$")
"$.default" <- .Primitive("$")
"$.function" <- function(f,g) function(...) f(g(...))
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment