Custom implementation of SVM Spectrum String Kernel for caret in R

caret-svm-spectrumkernel.R

library(kernlab)

spectrumSVM <- list(type = "Classification", library = "kernlab", loop = NULL)

spectrumSVM$parameters <- data.frame(parameter = c("C", "length"), class = c("numeric", "numeric"), label = c("Cost", "length"))

spectrumSVM$grid <- function(x, y, len = NULL, search = "grid") {
  if (search == "grid") {
    out <- expand.grid(length = 2:(len+1), C = 2^((1:len)-3))
  } else {
    out <- data.frame(length = sample(1:20, size = len, replace = TRUE), C = 2^runif(len, min = -5, max = 10))
  }
  
  out
}

spectrumSVM$fit <- function(x, y, wts, param, lev, last, weights, classProbs, ...) {
  sk <- kernlab::stringdot(type = "spectrum", length = param$length, normalized = TRUE)
  
  if (any(names(list(...)) == "prob.model") | is.numeric(y)) {
    browser()
    out <- kernlab::ksvm(x = x[,1], y = y,
                         kernel = sk,
                         scale = c(),
                         C = param$C,
                         ...)
  } else {
    out <- kernlab::ksvm(x = x[,1], y = y,
                         kernel = sk,
                         scale = c(),
                         C = param$C,
                         prob.model = classProbs,
                         ...)
  }
  
  out
}

spectrumSVM$predict <- function(modelFit, newdata, preProc = NULL, submodels = NULL) {
  svmPred <- function(obj, x) {
    hasPM <- !is.null(unlist(obj@prob.model))
    
    if (hasPM) {
      pred <- kernlab::lev(obj)[apply(kernlab::predict(obj, x, type = "probabilities"), 1, which.max)]
    } else {
      pred <- kernlab::predict(obj, x)
    }
    
    pred
  }
  
  out <- try(svmPred(modelFit, newdata[,1]), silent = TRUE)
  
  if (is.character(kernlab::lev(modelFit))) {
    if (class(out)[1] == "try-error")  {
      warning("kernlab class prediction calculations failed; returning NAs")
      out <- rep("", nrow(newdata))
      out[seq(along = out)] <- NA
    }
  } else {
    if (class(out)[1] == "try-error")  {
      warning("kernlab prediction calculations failed; returning NAs")
      out <- rep(NA, nrow(newdata))
    } 
  }
  
  if(is.matrix(out)) out <- out[,1]
  
  out
}

spectrumSVM$prob <- function(modelFit, newdata, preProc = NULL, submodels = NULL) {
  out <- try(kernlab::predict(modelFit, newdata[,1], type="probabilities"), silent = TRUE)
  
  if (class(out)[1] != "try-error") {
    ## There are times when the SVM probability model will
    ## produce negative class probabilities, so we
    ## induce vlaues between 0 and 1
    if (any(out < 0)) {
      out[out < 0] <- 0
      out <- t(apply(out, 1, function(x) x/sum(x)))
    }
    out <- out[, kernlab::lev(modelFit), drop = FALSE]
  } else {
    warning("kernlab class probability calculations failed; returning NAs")
    out <- matrix(NA, nrow(newdata) * length(kernlab::lev(modelFit)), ncol = length(kernlab::lev(modelFit)))
    colnames(out) <- kernlab::lev(modelFit)
  }
  
  out
}

spectrumSVM$sort <- function(x) {
  x[order(x$C, -x$length),]
}

spectrumSVM$levels <- function(x) {
  kernlab::lev(x)
}