Increment a function in R using a closure (recursively add a function constructed using a closure to an existing function)

Question

I'm trying to create a function w(t) from some data. I do this by looping through the data, creating a function, and adding this to w(t). I'm running into infinite recursion problems that arise because I don't know when R is evaluating variables. The error message I get is:

Error: evaluation nested too deeply: infinite recursion / options(expressions=)? Error during wrapup: evaluation nested too deeply: infinite recursion / options(expressions=)?

Below is an example of a Kernalised Perceptron. I generate some linearly separable data and try to fit it. The functional addition occurs in the function kern.perceptron where I:

1. Create a function from the data: kernel <- FUN(x, ...). From the call this translates to creating a function function(t) (x %*% t)^3 where x should be evaluated. (I think this is where I may be falling down).
2. add/subtract this function to the existing function wHat

How can I correctly update the function such that wHat(t) = wHat(t) + kernel(t)?

prepend.bias <- function(X){
    cbind(rep(1, nrow(X)), X)
}

pred.perc <- function(X, w, add.bias=FALSE){
    X <- as.matrix(X)
    if (add.bias) X <- prepend.bias(X)
    sign(X %*% w)
}

polyKernel <- function(x, d=2){
    # Function that creates a kernel function for a given data point
    # Expects data point as row matrix
    function(t){
        # expects t as vector or col matrix
        t <- as.matrix(t)
        (x %*% t)^d
    }
}

pred.kperc <- function(X, w, add.bias=FALSE){
    X <- as.matrix(X)
    if (add.bias) X <- prepend.bias(X)
    as.matrix(sign(apply(X, 1, w)))
}

kern.perceptron <- function(X, Y, max.epoch=1, verbose=FALSE, 
                            FUN=polyKernel, ...) {
    wHat <- function(t) 0
    alpha <- numeric(0)
    X <- prepend.bias(X)
    bestmistakes <- Inf
    n <- nrow(X)
    for (epoch in 1:max.epoch) {
        improved <- FALSE
        mistakes <- 0
        for (i in 1:n) {
            x <- X[i,,drop=F]
            yHat <- pred.kperc(x, wHat)
            if (Y[i] != yHat) {
                alpha <- c(alpha, Y[i])
                wPrev <- wHat
                kernel <- FUN(x, ...)
                if (Y[i] == -1){
                    wHat <- function(t) wPrev(t) - kernel(t)
                } else{
                    wHat <- function(t) wPrev(t) + kernel(t)
                }

                mistakes <- mistakes + 1
            }
            else alpha <- c(alpha, 0)
        }
        totmistakes <- sum(Y != pred.kperc(X, wHat))
        if (totmistakes < bestmistakes){
            bestmistakes <- totmistakes
            pocket <- wHat
            improved <- TRUE
        }
        if (verbose) {
            message(paste("\nEpoch:", epoch, "\nMistakes In Loop:", mistakes,
                          "\nCurrent Solution Mistakes:", totmistakes, 
                          "\nBest Solution Mistakes:", bestmistakes))
            if (!improved)
                message(paste("WARNING: Epoch", epoch, "No improvement"))
        }
    }
    return(pocket)
}

set.seed(10230)
w <- c(0.3, 0.9, -2)
X <- gendata(100, 2)
Y <- pred.perc(X, w, TRUE)
wHat <- kern.perceptron(X, Y, 10, TRUE, polyKernel, d=3)

Answer 1

I think your getting a stack overflow because your createing a more and more deeply nested function wHat. You could keep a registry of kernel functions in a closure as in:

LL  <-  local({
    #initialize list of kernel functions in the closeure
    funlist = list()
    #a logical vector indicating whether or not to add or subtract the kernal functio
    .sign = logical(zero)


    #register a kernal function and it's sign
    register <- function(fun,sign,x){
        funlist<<-c(funlist,list(fun))
        add<<-c(add,sign)
    }

    # wHat uses k in the closure without having to pass it as an argument
    wHat <- function(t){

        out = 0
        for(i in seq(length(.sign))
            if (.sign[i]){
                out <- out + funlist[[i]](t)
            } else{
                out <- out - funlist[[i]](t)
            }
    }
    list(wHat,register)
})

wHat  <-  LL$wHat
register  <-  LL$register

then to register a kernal functions you call

register(KernelFun,sign)

and when you call

wHat(t)

you get the sum of the kernel functions in the registery, which I think is what you want.

Incidentally, you could do this without closures too...