public
Created

  • Download Gist
R memoization.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98
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(...))

Please sign in to comment on this gist.

Something went wrong with that request. Please try again.