146 lines
4.2 KiB
R
146 lines
4.2 KiB
R
#' Implementation of the CVE method.
|
|
#'
|
|
#' Conditional Variance Estimator (CVE) is a novel sufficient dimension
|
|
#' reduction (SDR) method assuming a model
|
|
#' \deqn{Y \sim g(B'X) + \epsilon}{Y ~ g(B'X) + epsilon}
|
|
#' where B'X is a lower dimensional projection of the predictors.
|
|
#'
|
|
#' @param formula Formel for the regression model defining `X`, `Y`.
|
|
#' See: \code{\link{formula}}.
|
|
#' @param data data.frame holding data for formula.
|
|
#' @param method The different only differe in the used optimization.
|
|
#' All of them are Gradient based optimization on a Stiefel manifold.
|
|
#' \itemize{
|
|
#' \item "simple" Simple reduction of stepsize.
|
|
#' \item "linesearch" determines stepsize with backtracking linesearch
|
|
#' using Armijo-Wolf conditions.
|
|
#' \item TODO: further
|
|
#' }
|
|
#' @param ... Further parameters depending on the used method.
|
|
#' TODO: See ...
|
|
#' @examples
|
|
#' library(CVE)
|
|
#' ds <- dataset("M5")
|
|
#' X <- ds$X
|
|
#' Y <- ds$Y
|
|
#' dr <- cve(Y ~ X, k = 1)
|
|
#'
|
|
#' @references Fertl L, Bura E. Conditional Variance Estimation for Sufficient Dimension Reduction, 2019
|
|
#'
|
|
#' @import stats
|
|
#' @importFrom stats model.frame
|
|
#' @export
|
|
cve <- function(formula, data, method = "simple", ...) {
|
|
# check for type of `data` if supplied and set default
|
|
if (missing(data)) {
|
|
data <- environment(formula)
|
|
} else if (!is.data.frame(data)) {
|
|
stop('Parameter `data` must be a `data.frame` or missing.')
|
|
}
|
|
|
|
# extract `X`, `Y` from `formula` with `data`
|
|
model <- stats::model.frame(formula, data)
|
|
X <- as.matrix(model[,-1, drop=FALSE])
|
|
Y <- as.matrix(model[, 1, drop=FALSE])
|
|
|
|
# pass extracted data on to [cve.call()]
|
|
dr <- cve.call(X, Y, method = method, ...)
|
|
|
|
# overwrite `call` property from [cve.call()]
|
|
dr$call <- match.call()
|
|
return(dr)
|
|
}
|
|
|
|
#' @rdname cve
|
|
#' @export
|
|
cve.call <- function(X, Y, method = "simple", nObs = nrow(X)^.5, k, ...) {
|
|
|
|
# TODO: replace default value of `k` by `max.dim` when fast enough
|
|
if (missing(k)) {
|
|
stop("TODO: parameter `k` (rank(B)) is required, replace by `max.dim`.")
|
|
}
|
|
|
|
# parameter checking
|
|
if (!(is.matrix(X) && is.matrix(Y))) {
|
|
stop('X and Y should be matrices.')
|
|
}
|
|
if (nrow(X) != nrow(Y)) {
|
|
stop('Rows of X and Y are not compatible.')
|
|
}
|
|
if (ncol(X) < 2) {
|
|
stop('X is one dimensional, no need for dimension reduction.')
|
|
}
|
|
if (ncol(Y) > 1) {
|
|
stop('Only one dimensional responces Y are supported.')
|
|
}
|
|
|
|
# call C++ CVE implementation
|
|
# dr ... Dimension Reduction
|
|
dr <- cve_cpp(X, Y, tolower(method), k = k, nObs = nObs, ...)
|
|
|
|
# augment result information
|
|
dr$method <- method
|
|
dr$call <- match.call()
|
|
class(dr) <- "cve"
|
|
return(dr)
|
|
}
|
|
|
|
# TODO: write summary
|
|
# summary.cve <- function() {
|
|
# # code #
|
|
# }
|
|
|
|
#' Ploting helper for objects of class \code{cve}.
|
|
#'
|
|
#' @param x Object of class \code{cve} (result of [cve()]).
|
|
#' @param content Specifies what to plot:
|
|
#' \itemize{
|
|
#' \item "history" Plots the loss history from stiefel optimization
|
|
#' (default).
|
|
#' \item ... TODO: add (if there are any)
|
|
#' }
|
|
#' @param ... Pass through parameters to [plot()] and [lines()]
|
|
#'
|
|
#' @seealso see \code{\link{par}} for graphical parameters to pass through.
|
|
#' @importFrom graphics plot lines points
|
|
#' @method plot cve
|
|
#' @export
|
|
plot.cve <- function(x, ...) {
|
|
|
|
H <- x$history
|
|
H_1 <- H[H[, 1] > 0, 1]
|
|
|
|
defaults <- list(
|
|
main = "History",
|
|
xlab = "Iterations i",
|
|
ylab = expression(loss == L[n](V^{(i)})),
|
|
xlim = c(1, nrow(H)),
|
|
ylim = c(0, max(H)),
|
|
type = "l"
|
|
)
|
|
|
|
call.plot <- match.call()
|
|
keys <- names(defaults)
|
|
keys <- keys[match(keys, names(call.plot)[-1], nomatch = 0) == 0]
|
|
|
|
for (key in keys) {
|
|
call.plot[[key]] <- defaults[[key]]
|
|
}
|
|
|
|
call.plot[[1L]] <- quote(plot)
|
|
call.plot$x <- quote(1:length(H_1))
|
|
call.plot$y <- quote(H_1)
|
|
|
|
eval(call.plot)
|
|
|
|
if (ncol(H) > 1) {
|
|
for (i in 2:ncol(H)) {
|
|
H_i <- H[H[, i] > 0, i]
|
|
lines(1:length(H_i), H_i)
|
|
}
|
|
}
|
|
x.ends <- apply(H, 2, function(h) { length(h[h > 0]) })
|
|
y.ends <- apply(H, 2, function(h) { min(h[h > 0]) })
|
|
points(x.ends, y.ends)
|
|
}
|