-
Notifications
You must be signed in to change notification settings - Fork 15
/
kpca.R
146 lines (129 loc) · 4.42 KB
/
kpca.R
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
#' Kernel PCA
#'
#' An S4 Class implementing Kernel PCA
#'
#' Kernel PCA is a nonlinear extension of PCA using kernel methods.
#'
#'
#' @template dimRedMethodSlots
#'
#' @template dimRedMethodGeneralUsage
#'
#' @section Parameters:
#' Kernel PCA can take the following parameters:
#' \describe{
#' \item{ndim}{the number of output dimensions, defaults to 2}
#' \item{kernel}{The kernel function, either as a function or a
#' character vector with the name of the kernel. Defaults to
#' \code{"rbfdot"}}
#' \item{kpar}{A list with the parameters for the kernel function,
#' defaults to \code{list(sigma = 0.1)}}
#' }
#'
#' The most comprehensive collection of kernel functions can be found in
#' \code{\link[kernlab]{kpca}}. In case the function does not take any
#' parameters \code{kpar} has to be an empty list.
#'
#' @section Implementation:
#'
#' Wraps around \code{\link[kernlab]{kpca}}, but provides additionally
#' forward and backward projections.
#'
#' @references
#'
#' Sch\"olkopf, B., Smola, A., M\"uller, K.-R., 1998. Nonlinear Component Analysis
#' as a Kernel Eigenvalue Problem. Neural Computation 10, 1299-1319.
#' https://doi.org/10.1162/089976698300017467
#'
#' @examples
#' \dontrun{
#' if(requireNamespace("kernlab", quietly = TRUE)) {
#'
#' dat <- loadDataSet("3D S Curve")
#' emb <- embed(dat, "kPCA")
#' plot(emb, type = "2vars")
#' }
#'
#' }
#' @include dimRedResult-class.R
#' @include dimRedMethod-class.R
#' @family dimensionality reduction methods
#' @export kPCA
#' @exportClass kPCA
kPCA <- setClass(
"kPCA",
contains = "dimRedMethod",
prototype = list(
stdpars = list(kernel = "rbfdot",
kpar = list(sigma = 0.1),
ndim = 2),
fun = function (data, pars,
keep.org.data = TRUE) {
chckpkg("kernlab")
if (is.null(pars$ndim)) pars$ndim <- 2
meta <- data@meta
orgdata <- if (keep.org.data) data@data else NULL
indata <- data@data
message(Sys.time(), ": Calculating kernel PCA")
res <- do.call(kernlab::kpca, c(list(x = indata), pars))
kernel <- get_kernel_fun(pars$kernel, pars$kpar)
message(Sys.time(), ": Trying to calculate reverse")
K_rev <- kernlab::kernelMatrix(kernel, res@rotated)
diag(K_rev) <- 0.1 + diag(K_rev)
dual_coef <- try(solve(K_rev, indata), silent = TRUE)
appl <- function (x) {
appl.meta <- if (inherits(x, "dimRedData")) x@meta else data.frame()
proj <- if (inherits(x, "dimRedData")) x@data else x
proj <- kernlab::predict(res, proj)[, 1:pars$ndim, drop = FALSE]
colnames(proj) <- paste0("kPCA", 1:ncol(proj))
new("dimRedData", data = proj, meta = appl.meta)
}
inv <-
if (inherits(dual_coef, "try-error")) {
message("No inverse function.")
function(x) NA
} else {
function (x) {
appl.meta <-
if (inherits(x, "dimRedData")) x@meta else data.frame()
proj <- if (inherits(x, "dimRedData")) x@data else x
resrot <- res@rotated[, 1:ncol(proj)]
rot <- kernlab::kernelMatrix(kernel, proj, resrot)
proj <- rot %*% dual_coef
new("dimRedData", data = proj, meta = appl.meta)
}
}
outdata <- res@rotated[, 1:pars$ndim, drop = FALSE]
colnames(outdata) <- paste0("kPCA", 1:ncol(outdata))
message(Sys.time(), ": DONE")
return(
new(
"dimRedResult",
data = new("dimRedData",
data = outdata,
meta = meta),
org.data = orgdata,
apply = appl,
inverse = inv,
has.org.data = keep.org.data,
has.apply = TRUE,
has.inverse = TRUE,
method = "kpca",
pars = pars
)
)
},
requires = c("kernlab"))
)
## get the kernel function out of the kernlab namespace:
get_kernel_fun <- function (kernel, pars) {
if (!is(kernel, "kernel")) {
if (is(kernel, "function")) {
kernel <- deparse(substitute(kernel))
} else {
kernel <- get(kernel, asNamespace("kernlab"))
}
kernel <- do.call(kernel, pars)
}
return(kernel)
}