R memoization.

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(...))