R/pnn.optmiz_logl.R

In yap: Yet Another Probabilistic Neural Network

#' Optimize the optimal value of PNN smoothing parameter based on the cross entropy 
#'
#' The function \code{pnn.optmiz_logl} optimize the optimal value of PNN smoothing parameter by cross-validation.
#'
#' @param net    A PNN object generated by pnn.fit() 
#' @param lower  A scalar for the lower bound of the smoothing parameter, 0 by default
#' @param upper  A scalar for the upper bound of the smoothing parameter
#' @param nfolds A scalar for the number of n-fold, 4 by default
#' @param seed   The seed value for the n-fold cross-validation, 1 by default
#' @param method A scalar referring to the optimization method, 1 for Golden section searc and 2 for Brent's method
#'
#' @return The best outcome
#'
#' @seealso \code{\link{pnn.search_logl}}
#'
#' @examples
#' data(iris, package = "datasets")
#' Y <- iris[, 5]
#' X <- scale(iris[, 1:4])
#' pnet <- pnn.fit(x = X, y = Y)
#' \donttest{
#' pnn.optmiz_logl(pnet, upper = 1)
#' }

pnn.optmiz_logl <- function(net, lower = 0, upper, nfolds = 4, seed = 1, method = 1) {
  if (class(net) != "Probabilistic Neural Net") stop("net needs to be a PNN object.", call. = F)
  if (!(method %in% c(1, 2))) stop("the method is not supported.", call. = F)

  fd <- folds(seq(nrow(net$x)), n = nfolds, seed = seed)
  cv <- function(s) {
    cls <- parallel::makeCluster(min(nfolds, parallel::detectCores() - 1), type = "PSOCK")
    obj <- c("fd", "net", "pnn.fit", "pnn.predone", "pnn.predict", "dummies", "logl")
    parallel::clusterExport(cls, obj,  envir = environment())
    rs <- Reduce(rbind,
            parallel::parLapply(cls, fd,
              function(f) data.frame(ya = net$y.ind[f, ],
                                     yp = pnn.predict(pnn.fit(net$x[-f, ], net$y.raw[-f],  sigma = s),
                                                      net$x[f, ]))))
    parallel::stopCluster(cls)
    return(logl(y_pred = as.matrix(rs[, grep("^yp", names(rs))]), 
                y_true = as.matrix(rs[, grep("^ya", names(rs))])))
  }

  if (method == 1) {
    rst <- optimize(f = cv, interval = c(lower, upper))
  } else if (method == 2) {
    rst <- optim(par = mean(lower, upper), fn = cv, lower = lower, upper = upper, method = "Brent")
  }
  return(data.frame(sigma = rst[[1]], logl = rst[[2]]))
}