Nothing
# function kernelMatrix to perform the kernel operation implicitly, without using of the feature transformation
#
# @param Xtrain [matrix(1)]
# Data set for fitting.
# @param kernel_type [character(1)]
# Name of the kernel typ to be used
# @param Xt [matrix(1)]
# Matrix on which the mapping will be done. It is use to be the description matrix of
# indidiums, for which the failure times are needed to be predict
# @param bin_cat [vector(1)]
# index of binar or categorial columns in the input matrix
# @return [matrix(1)].
# The symmetric Kernel matrix
#----------------------------------------------------------------------------------------
#' computes the kernel matrix for elements taken in an argument.
#'
#' \code{Kernel}
#'
#'
#' @title Kernel
#' @param Xtrain [\code{matrix(1)}]\cr
#' Matrix of training data points.
#' @param kernel_type [\code{character(1)}]\cr
#' Type of kernel that is required.
#' @param kernel_pars [\code{vector(1)}]\cr
#' Parameters of kernels.
#' @param Xt [\code{matrix(1)}]\cr
#' Matrix of data points to be mapped.
#' @param bin_cat indexes of binary/categorical variables.
#'
#' @export
#' @return [\code{\link{Kernel}(1)}]
#' Object of class Kernel, with elements:
#' \tabular{ll}{
#' \code{Type} \tab type of kernel, \cr
#' \code{Mat} \tab matrix used to compute differences between comparable data points. \cr
#' }
#'
#' @author Cesaire J. K. Fouodo
#' @keywords internal
kernelMatrix <- function (Xtrain, kernel_type = "lin_kernel", kernel_pars,
Xt = NULL, bin_cat = integer(0)) {
nb_data <- nrow(Xtrain)
d <- ncol(Xtrain)
if (tolower(kernel_type) == "rbf_kernel") {
if (is.null(Xt)) {
XXh <- crossprod(t(rowSums(Xtrain^2)), t(rep(1, nb_data)))
omega <- XXh + t(XXh) - (2 * tcrossprod(Xtrain, Xtrain))
omega <- exp(-omega / (2 * kernel_pars[1]))
} else {
XXh1 <- crossprod(t(rowSums(Xtrain^2)),t(rep(1, nrow(Xt))))
XXh2 <- crossprod(t(rowSums(Xt^2)), t(rep(1, nb_data)))
omega <- XXh1 + t(XXh2) - 2 * tcrossprod(Xtrain, Xt)
omega <- exp(-omega / (2*kernel_pars[1]))
}
} else {
if(tolower(kernel_type) == "rbf4_kernel") {
if (is.null(Xt)) {
XXh <- crossprod(t(rowSums(Xtrain^2)), t(rep(1, nb_data)))
omega <- XXh + t(XXh) - (2 * tcrossprod(Xtrain, Xtrain))
omega <- 0.5*(3 - t(apply(omega, 2, function(i) i/ kernel_pars))) * as.vector(exp(-omega / (2 * kernel_pars[1])))
} else {
XXh1 <- crossprod(t(rowSums(Xtrain^2)), t(rep(1, nrow(Xt))))
XXh2 <- crossprod(t(rowSums(Xt^2)), t(rep(1, nb_data)))
omega <- XXh1 + t(XXh2) - 2 * tcrossprod(Xtrain, Xt)
omega <- 0.5*(3 - omega / kernel_pars) * as.vector(exp(-omega / (2 * kernel_pars[1])))
}
} else {
if (tolower(kernel_type) == "lin_kernel") {
if (is.null(Xt)) {
omega <- tcrossprod(Xtrain, Xtrain)
} else {
omega <- tcrossprod(Xtrain, Xt)
}
} else {
if (tolower(kernel_type) == "poly_kernel") {
if(is.null(Xt)){
omega <- (crossprod(Xtrain, Xtrain) + kernel_pars[1])^kernel_pars[2]
} else {
omega <- (crossprod(Xtrain, Xt) + kernel_pars[1])^kernel_pars[2]
}
} else {
if (tolower(kernel_type) == "add_kernel") {
if(is.null(Xt)){
Xt <- Xtrain
}
d <- ncol(Xtrain)
num.ord <- setdiff(1:d, bin_cat)
X.min <- apply(Xtrain[,num.ord], 2, min)
X.max <- apply(Xtrain[,num.ord], 2, max)
c.diff <- X.max - X.min
if(any(c.diff == 0)){
stop("additiv kernel can not be applied on constant column")
}
nr <- nrow(Xtrain)
sub.X <- sapply(1:nr, function(i) {
kp <- matrix(prod(dim(Xt)), ncol = ncol(Xt), nrow = nrow(Xt))
kp[,num.ord] <- t((c.diff - abs(t(Xt[,num.ord]) - Xtrain[i, num.ord])) / c.diff)
if (!(length(bin_cat) == 0)) {
kp[, bin_cat] <- t(t(Xt[, bin_cat]) == Xtrain[i, bin_cat])
}
rs <- rowSums(kp)
}, simplify = FALSE)
omega <- do.call("rbind", sub.X)
} else {
stop("Unkonwn Kernel")
}
}
}
}
}
kern <- Kernel(Type = kernel_type, Mat = omega, Kernpar = kernel_pars, bincat = bin_cat)
return(kern)
}
#--- Construct the kernel classes
#' Constructor of objects of class \code{Kernel}.
#'
#'
#' @title \code{Kernel}
#' @param Type [\code{character}]\cr
#' Type of kernel. Must be chosen from the following strings: \code{"lin_kernel"}, \code{"add_kernel"},
#' \code{"rbf_kernel"}, \code{"rbf4_kernel"} or \code{"poly_kernel"}.
#' @param Mat [\code{matrix(1)}]\cr
#' Kernel matrix.
#' @param Kernpar [\code{vector(1)}]\cr
#' Kernel parameters, when required.
#' @param bincat [\code{vector(1)}]\cr
#' Index of binary/categorical variables.
#'
#' @return [\code{\link{Kernel}(1)}]
#' Object of class Kernel, with elements:
#' \tabular{ll}{
#' \code{Type} \tab type of kernel, \cr
#' \code{Mat} \tab matrix used to perform differences between comparable data points. \cr
#' }
#'
#' @author Cesaire J. K. Fouodo
#'
#' @keywords internal
Kernel <- function(Type = NULL, Mat = NULL, Kernpar = NULL, bincat = NULL){
k <- list(Type = Type, Mat = Mat, Kernpar = Kernpar, bincat = bincat)
class(k) <- append(class(k), "Kernel")
return(k)
}
#--- Generic mutator method for the kernel type
#----------------------------------------------
#' Creator of the generic mutator \code{setType}.
#'
#'
#' @title Class \code{Kernel}
#' @param kern [\code{\link{Kernel}(1)}]\cr
#' Object taken in the argument.
#' @param value [\code{character(1)}]\cr
#' New type.
#' @keywords internal
#'
#' @author Cesaire J. K. Fouodo
setType <- function(kern, value) {
UseMethod("setType", kern)
}
#>>>> Mutators for the kernel object
#--- Default mutator method for the kernel type
#' Mutator of the field \code{Type} of the object taken in an argument.
#'
#'
#' @title Class \code{Kernel}
#' @param kern [\code{\link{Kernel}(1)}]\cr
#' Object taken in the argument.
#' @param value [\code{character(1)}]\cr
#' New type.
#'
#' @return Object taken in the argument.
#'
#' @author Cesaire J. K. Fouodo
#'
#' @keywords internal
setType.default <- function(kern, value) {
return(kern)
}
#--- Specific mutator method for the kernel type
#' Mutator of the field \code{Type} of the object of class \code{Kernel} taken in an argument.
#'
#'
#' @title \code{Kernel}
#' @param kern [\code{\link{Kernel}(1)}]\cr
#' Object taken in the argument.
#' @param kerntype [\code{character(1)}]\cr
#' Kerntype new type.
#'
#' @return Object of class \code{Kernel} with elements:
#'
#' @author Cesaire J. K. Fouodo
#'
#' @keywords internal
setType.Kernel <- function(kern, kerntype) {
kern$Type <- kerntype
return(kern)
}
#--- Generic mutator method for the kernel matrix
#' Creator of generic mutator \code{setMat}.
#'
#'
#' @title \code{Kernel}
#' @param kern [\code{\link{Kernel}(1)}]\cr
#' Object taken in the argument.
#' @param mat [\code{matrix(1)}]\cr
#' New matrix.
#' @keywords internal
#'
#' @author Cesaire J. K. Fouodo
setMat <- function(kern, mat) {
UseMethod("setMat", kern)
}
#--- Default mutator method for the kernel matrix
#' Mutator of the field \code{Mat} of the object taken in an argument.
#'
#'
#' @title \code{Kernel}
#' @param kern [\code{\link{Kernel}(1)}]\cr
#' Object taken in the argument.
#' @param kernmatrix [\code{matrix(1)}]\cr
#' New matrix.
#'
#' @return The object taken in the argument.
#' @keywords internal
#'
#' @author Cesaire J. K. Fouodo
setMatrix.default <- function(kern, kernmatrix) {
return(kern)
}
#--- Specific mutator method for the kernel matrix
#' Mutator of the field \code{Mat} of the object of class \code{Kernel} taken in an argument.
#'
#'
#' @title \code{Kernel}
#' @param kern [\code{\link{Kernel}(1)}]\cr
#' Object of class \code{Kernel} taken in the argument.
#' @param kernmat [\code{matrix(1)}]\cr
#' New kernel matrix.
#'
#' @return [\code{\link{Kernel}(1)}]
#' Object of class \code{Kernel} with elements:
#' \tabular{ll}{
#' \code{Type} \tab type of kernel, \cr
#' \code{Mat} \tab kernel matrix, \cr
#' \code{Kernpar} \tab parameters of kernel, when required, \cr
#' \code{bincat} \tab index of binary/categorical variables, when required.
#' }
#'
#' @author Cesaire J. K. Fouodo
#'
#' @keywords internal
setMat.Kernel<-function(kern, kernmat) {
kern$Mat <- kernmat
return(kern)
}
#--- Generic mutator method for the kernel parameter
#---------------------------------------------------
#' Default mutator of the field \code{Kernpar} of the object taken in an argument.
#'
#'
#' @title \code{Kernel}
#' @param kern [\code{\link{Kernel}(1)}]\cr
#' Object of class \code{Kernel} taken in the argument.
#' @param kernpar [\code{vector(1)}]\cr
#' New kernel parameters.
#'
#' @author Cesaire J. K. Fouodo
#'
#' @keywords internal
setKernpar <- function(kern, kernpar) {
UseMethod("setMat", kern)
}
#--- Default mutator method for the kernel parameter
#---------------------------------------------------
#' Default mutator of the field \code{Kernpar} of the object taken in an argument.
#'
#'
#' @title \code{Kernel}
#' @param kern [\code{\link{Kernel}(1)}]\cr
#' Object taken in the argument.
#' @param kernpar [\code{vector(1)}]\cr
#' New kernel parameters.
#'
#' @return The object taken in the argument.
#'
#' @author Cesaire J. K. Fouodo
#'
#' @keywords internal
setKernpar.default <- function(kern, kernpar) {
return(kern)
}
#--- Specific mutator method for the kernel parameter
#----------------------------------------------------
#' Mutator of the field \code{Kernpar} of the object of class \code{Kernel} taken in an argument.
#'
#'
#' @title \code{Kernel}
#' @param kern [\code{\link{Kernel}(1)}]\cr
#' Object of class \code{Kernel} taken in the argument.
#' @param kernpar [\code{vector(1)}]\cr
#' New kernel parameters.
#'
#' @return [\code{\link{Kernel}(1)}]
#' Object of class \code{Kernel} with elements:
#' \tabular{ll}{
#' \code{Type} \tab Type of kernel, \cr
#' \code{Mat} \tab Kernel matrix, \cr
#' \code{Kernpar} \tab Parameters of kernel, when required, \cr
#' \code{bincat} \tab Index of binary/categorical variables, when required,
#' }
#'
#' @author Cesaire J. K. Fouodo
#'
#' @keywords internal
setKernpar.Kernel<-function(kern, kernpar) {
kern$Kernpar <- kernpar
return(kern)
}
#--- Generic mutator method for the kernel parameter bincat: just concerning the additive kernel
#---------------------------------------------------
#' Default mutator of the field \code{bincat} of the object taken in an argument.
#'
#'
#' @title \code{Kernel}
#' @param kern [\code{\link{Kernel}(1)}]\cr
#' Object of class \code{Kernel} taken in the argument.
#' @param bincat [\code{vector(1)}]\cr
#' Index of binary/categorial variables.
#'
#' @return The object taken in the argument.
#'
#' @author Cesaire J. K. Fouodo
#'
#' @keywords internal
setBincat <- function(kern, bincat) {
UseMethod("setMat", bincat)
}
#--- Default mutator method for the kernel parameter bincat: just concerning the additive kernel
#-----------------------------------------------------------------------------------------------
#' Default mutator of the field \code{bincat} of the object taken in an argument.
#'
#'
#' @title \code{Kernel}
#' @param kern [\code{\link{Kernel}(1)}]\cr
#' Object taken in the argument.
#' @param bincat [\code{vector(1)}]\cr
#' New index of binary/categorial variables.
#'
#' @return The object taken in the argument.
#'
#' @keywords internal
#'
#' @author Cesaire J. K. Fouodo
setBincat.default <- function(kern, bincat) {
return(bincat)
}
#--- Specific mutator method for the kernel parameter bincat: just concerning the additive kernel
#----------------------------------------------------
#' Mutator of the field \code{bincat} of the object of class \code{Kernel} taken in an argument.
#'
#'
#' @title \code{Kernel}
#' @param kern [\code{\link{Kernel}(1)}]\cr
#' Object of class \code{Kernel} taken in the argument.
#' @param bincat [\code{vector(1)}]\cr
#' New index of binary/categorial variables.
#'
#' @return [\code{\link{Kernel}(1)}]
#' Object of class \code{Kernel} with elements:
#' \tabular{ll}{
#' \code{Type} \tab type of kernel, \cr
#' \code{Mat} \tab kernel matrix, \cr
#' \code{Kernpar} \tab parameters of kernel, when required, \cr
#' \code{bincat} \tab index of binary/categorical variables, when required.
#' }
#'
#' @author Cesaire J. K. Fouodo
#'
#' @keywords internal
setBincat.Kernel<-function(kern, bincat) {
kern$bincat <- bincat
return(kern)
}
#>>>> Accessors for the kernel object
#--- Generic accessor method for the kernel type
#-----------------------------------------------
#' Creator of the generic accessor \code{getType}.
#'
#'
#' @title \code{Kernel}
#' @param kern [\code{\link{Kernel}(1)}]\cr
#' Object taken in the argument.
#' @keywords internal
#'
#' @author Cesaire J. K. Fouodo
getType <- function(kern) {
UseMethod("getType", kern)
}
#--- Default accessor method for the kernel type
#-----------------------------------------------
#' Accessor for the field \code{Type} for the object taken in the argument.
#'
#'
#' @title \code{Kernel}
#' @param kern [\code{\link{Kernel}(1)}]\cr
#' Object taken in argument.
#'
#' @return \code{NULL}.
#' @keywords internal
#'
#' @author Cesaire J. K. Fouodo
getType.default <- function(kern) {
return(NULL)
}
#--- Specific accessor method for the kernel type
#------------------------------------------------
#' Accessor for the field \code{Type} of the object of class \code{Kernel} taken in an argument.
#'
#'
#' @title \code{Kernel}
#' @param kern [\code{\link{Kernel}(1)}]\cr
#' Object of class \code{Kernel}.
#'
#' @return Type of the kernel taken in the argument.
#' @keywords internal
#'
#' @author Cesaire J. K. Fouodo
getType.Kernel <- function(kern) {
return(kern$Type)
}
#--- Generic accessor method for the kernel matrix
#-----------------------------------------------
#' Creator of the generic accessor \code{getMat}.
#'
#'
#' @title \code{Kernel}
#' @param kern [\code{\link{Kernel}(1)}]\cr
#' Object taken in the argument.
#' @keywords internal
#'
#' @author Cesaire J. K. Fouodo
getMat <- function(kern) {
UseMethod("getMat", kern)
}
#--- Default accessor method for the kernel matrix
#-----------------------------------------------
#' Accessor for the field \code{Mat} for the object taken in an argument.
#'
#'
#' @title \code{Kernel}
#' @param kern [\code{\link{Kernel}(1)}]\cr
#' Object taken in the argument.
#'
#' @return \code{NULL}.
#' @keywords internal
#'
#'
#' @author Cesaire J. K. Fouodo
getMat.default <- function(kern) {
return(NULL)
}
#--- Specific accessor method for the kernel matrix
#------------------------------------------------
#' Accessor for the field \code{Mat} of the object of class \code{Kernel} taken in an argument.
#'
#'
#' @title \code{Kernel}
#' @param kern [\code{\link{Kernel}(1)}]\cr
#' Object of class \code{Kernel}.
#'
#' @return [\code{matrix(1)}]
#' The kernel matrix.
#'
#' @keywords internal
#' @author Cesaire J. K. Fouodo
getMat.Kernel<-function(kern) {
return(kern$Mat)
}
#--- Generic accessor method for the kernel parameter
#---------------------------------------------------
#' Creator of the generic accessor \code{getKernpar}.
#'
#'
#' @title \code{Kernel}
#' @param kern [\code{\link{Kernel}(1)}]\cr
#' Object taken in the argument.
#' @keywords internal
#'
#' @author Cesaire J. K. Fouodo
getKernpar <- function(kern) {
UseMethod("getKernpar", kern)
}
#--- Default accessor method for the kernel parameter
#-----------------------------------------------
#' Accessor for the field \code{Kernpar} for the object taken in an argument.
#'
#'
#' @title \code{Kernel}
#' @param kern [\code{\link{Kernel}(1)}]\cr
#' Object taken in the argument.
#'
#' @return \code{NULL}.
#' @keywords internal
#'
#' @author Cesaire J. K. Fouodo
getKernpar.default <- function(kern) {
return(NULL)
}
#--- Specific accessor method for the kernel parameter
#------------------------------------------------
#' Accessor for the field \code{Kernpar} of the object of class \code{Kernel} taken in an argument.
#'
#'
#' @title \code{Kernel}
#' @param kern [\code{\link{Kernel}(1)}]\cr
#' Object of class \code{Kernel}.
#'
#' @return [\code{vector(1)}]
#' The kernel parameters.
#' @keywords internal
#'
#' @author Cesaire J. K. Fouodo
getKernpar.Kernel <- function(kern) {
return(kern$Kernpar)
}
#--- Generic accessor method for the kernel bincat parameter: just concerning the additive kernel
#-----------------------------------------------
#' Creator of the generic accessor \code{getBincat}.
#'
#'
#' @title \code{Kernel}
#' @param kern [\code{\link{Kernel}(1)}]\cr
#' Object taken in the argument.
#' @keywords internal
#'
#' @author Cesaire J. K. Fouodo
getBincat <- function(kern) {
UseMethod("getKernpar", kern)
}
#--- Default accessor method for the kernel parameter: just concerning the additive kernel
#-----------------------------------------------
#' Accessor for the field \code{Bincat} for the object taken in the argument.
#'
#'
#' @title \code{Kernel}
#' @param kern [\code{\link{Kernel}(1)}]\cr
#' Object taken in the argument.
#'
#' @return \code{NULL}.
#' @keywords internal
#'
#' @author Cesaire J. K. Fouodo
getBinca.default <- function(kern) {
return(NULL)
}
#--- Specific accessor method for the kernel parameter: just concerning the additive kernel
#------------------------------------------------
#' Accessor for the field \code{Bincat} of the object of class \code{Kernel} taken in an argument.
#'
#'
#' @title \code{Kernel}
#' @param kern [\code{\link{Kernel}(1)}]\cr
#' Object of class \code{Kernel}.
#'
#' @return Index of binary/categorical variables.
#' @keywords internal
#'
#' @author Cesaire J. K. Fouodo
getBincat.Kernel <- function(kern) {
return(kern$bincat)
}
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.