/
pca.R
131 lines (116 loc) · 4.15 KB
/
pca.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
#' Principal Component Analysis
#'
#' S4 Class implementing PCA.
#'
#' PCA transforms the data in orthogonal components so that the first
#' axis accounts for the larges variance in the data, all the
#' following axes account for the highest variance under the
#' constraint that they are orthogonal to the preceding axes. PCA is
#' sensitive to the scaling of the variables. PCA is by far the
#' fastest and simples method of dimensionality reduction and should
#' probably always be applied as a baseline if other methods are tested.
#'
#' @template dimRedMethodSlots
#'
#' @template dimRedMethodGeneralUsage
#'
#' @section Parameters:
#' PCA can take the following parameters:
#' \describe{
#' \item{ndim}{The number of output dimensions.}
#' \item{center}{logical, should the data be centered, defaults to \code{TRUE}.}
#' \item{scale.}{logical, should the data be scaled, defaults to \code{FALSE}.}
#' }
#'
#' @section Implementation:
#'
#' Wraps around \code{\link{prcomp}}. Because PCA can be reduced to a
#' simple rotation, forward and backward projection functions are
#' supplied.
#'
#' @references
#'
#' Pearson, K., 1901. On lines and planes of closest fit to systems of points in
#' space. Philosophical Magazine 2, 559-572.
#'
#' @examples
#' dat <- loadDataSet("Iris")
#' emb <- embed(dat, "PCA")
#'
#' plot(emb, type = "2vars")
#' if(requireNamespace("scatterplot3d", quietly = TRUE))
#' plot(inverse(emb, getDimRedData(emb)), type = "3vars")
#'
#' @include dimRedResult-class.R
#' @include dimRedMethod-class.R
#' @family dimensionality reduction methods
#' @export PCA
#' @exportClass PCA
PCA <- setClass(
"PCA",
contains = "dimRedMethod",
prototype = list(
stdpars = list(ndim = 2,
center = TRUE,
scale. = FALSE),
fun = function (data, pars,
keep.org.data = TRUE) {
ndim <- pars$ndim
pars$ndim <- NULL
meta <- data@meta
orgdata <- if (keep.org.data) data@data else NULL
data <- data@data
res <- do.call(
prcomp,
c(list(x = data), pars)
)
# evaluate results here for functions
data <- res$x[, seq_len(ndim), drop = FALSE]
ce <- res$center
sc <- res$scale
rot <- res$rotation[, seq_len(ndim)]
rerot <- t(rot)
appl <- function(x) {
appl.meta <- if (inherits(x, "dimRedData")) x@meta else data.frame()
proj <- if (inherits(x, "dimRedData")) x@data else x
if (ncol(proj) != ncol(orgdata))
stop("x must have the same number of dimensions ",
"as the original data")
if (ce[1] != FALSE) proj <- t(apply(proj, 1, function(x) x - ce))
if (sc[1] != FALSE) proj <- t(apply(proj, 1, function(x) x / sc))
proj <- proj %*% rot
proj <- new("dimRedData", data = proj, meta = appl.meta)
return(proj)
}
inv <- function(x) {
appl.meta <- if (inherits(x, "dimRedData")) x@meta else data.frame()
proj <- if (inherits(x, "dimRedData")) x@data else x
if (ncol(proj) > ncol(data))
stop("x must have less or equal number of dimensions ",
"as the original data")
d <- ncol(proj)
reproj <- proj %*% rerot[seq_len(d), ]
if (sc[1] != FALSE)
reproj <- t(apply(reproj, 1, function(x) x * sc))
if (ce[1] != FALSE)
reproj <- t(apply(reproj, 1, function(x) x + ce))
reproj <- new("dimRedData", data = reproj, meta = appl.meta)
return(reproj)
}
res <- new(
"dimRedResult",
data = new("dimRedData",
data = data,
meta = meta),
org.data = orgdata,
apply = appl,
inverse = inv,
has.org.data = keep.org.data,
has.apply = TRUE,
has.inverse = TRUE,
method = "PCA",
pars = pars
)
return(res)
})
)