del: old CVE implementation
This commit is contained in:
parent
9e46a2d3d7
commit
03153ef05e
|
|
@ -1,13 +0,0 @@
|
||||||
Package: CVE
|
|
||||||
Type: Package
|
|
||||||
Title: Conditional Variance Estimator for Sufficient Dimension Reduction
|
|
||||||
Version: 1.0
|
|
||||||
Date: 2019-07-29
|
|
||||||
Author: Loki
|
|
||||||
Maintainer: Loki <loki@no.mail>
|
|
||||||
Description: Implementation of the Conditional Variance Estimation (CVE) method. This package version is writen by using Rcpp, RcppArmadillo.
|
|
||||||
License: GPL-3
|
|
||||||
Imports: Rcpp (>= 1.0.2)
|
|
||||||
LinkingTo: Rcpp, RcppArmadillo
|
|
||||||
Encoding: UTF-8
|
|
||||||
RoxygenNote: 6.1.1
|
|
||||||
|
|
@ -1,18 +0,0 @@
|
||||||
# Generated by roxygen2: do not edit by hand
|
|
||||||
|
|
||||||
S3method(plot,cve)
|
|
||||||
export(cve)
|
|
||||||
export(cve.call)
|
|
||||||
export(dataset)
|
|
||||||
export(estimateBandwidth)
|
|
||||||
export(rStiefel)
|
|
||||||
import(Rcpp)
|
|
||||||
import(stats)
|
|
||||||
importFrom(Rcpp,evalCpp)
|
|
||||||
importFrom(graphics,lines)
|
|
||||||
importFrom(graphics,plot)
|
|
||||||
importFrom(graphics,points)
|
|
||||||
importFrom(stats,model.frame)
|
|
||||||
importFrom(stats,rbinom)
|
|
||||||
importFrom(stats,rnorm)
|
|
||||||
useDynLib(CVE)
|
|
||||||
159
CVE/R/CVE.R
159
CVE/R/CVE.R
|
|
@ -1,159 +0,0 @@
|
||||||
#' 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)
|
|
||||||
#'
|
|
||||||
#' # sample dataset
|
|
||||||
#' ds <- dataset("M5")
|
|
||||||
#'
|
|
||||||
#' # call ´cve´ with default method (aka "simple")
|
|
||||||
#' dr.simple <- cve(ds$Y ~ ds$X, k = ncol(ds$B))
|
|
||||||
#' # plot optimization history (loss via iteration)
|
|
||||||
#' plot(dr.simple, main = "CVE M5 simple")
|
|
||||||
#'
|
|
||||||
#' # call ´cve´ with method "linesearch" using ´data.frame´ as data.
|
|
||||||
#' data <- data.frame(Y = ds$Y, X = ds$X)
|
|
||||||
#' # Note: ´Y, X´ are NOT defined, they are extracted from ´data´.
|
|
||||||
#' dr.linesearch <- cve(Y ~ ., data, method = "linesearch", k = ncol(ds$B))
|
|
||||||
#' plot(dr.linesearch, main = "CVE M5 linesearch")
|
|
||||||
#'
|
|
||||||
#' @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)
|
|
||||||
}
|
|
||||||
|
|
||||||
#' @param nObs as describet in the Paper.
|
|
||||||
#' @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()]
|
|
||||||
#'
|
|
||||||
#' @usage ## S3 method for class 'cve'
|
|
||||||
#' plot(x, content = "history", ...)
|
|
||||||
#' @seealso see \code{\link{par}} for graphical parameters to pass through
|
|
||||||
#' as well as \code{\link{plot}} for standard plot utility.
|
|
||||||
#' @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)
|
|
||||||
}
|
|
||||||
|
|
@ -1,113 +0,0 @@
|
||||||
# Generated by using Rcpp::compileAttributes() -> do not edit by hand
|
|
||||||
# Generator token: 10BE3573-1514-4C36-9D1C-5A225CD40393
|
|
||||||
|
|
||||||
#' Gradient computation of the loss `L_n(V)`.
|
|
||||||
#'
|
|
||||||
#' The loss is defined as
|
|
||||||
#' \deqn{L_n(V) := \frac{1}{n}\sum_{j=1}^n y_2(V, X_j) - y_1(V, X_j)^2}{L_n(V) := 1/n sum_j( (y_2(V, X_j) - y_1(V, X_j)^2 )}
|
|
||||||
#' with
|
|
||||||
#' \deqn{y_l(s_0) := \sum_{i=1}^n w_i(V, s_0)Y_i^l}{y_l(s_0) := sum_i(w_i(V, s_0) Y_i^l)}
|
|
||||||
#'
|
|
||||||
#' @rdname optStiefel
|
|
||||||
#' @keywords internal
|
|
||||||
#' @name gradient
|
|
||||||
NULL
|
|
||||||
|
|
||||||
#' Stiefel Optimization.
|
|
||||||
#'
|
|
||||||
#' Stiefel Optimization for \code{V} given a dataset \code{X} and responces
|
|
||||||
#' \code{Y} for the model \deqn{Y\sim g(B'X) + \epsilon}{Y ~ g(B'X) + epsilon}
|
|
||||||
#' to compute the matrix `B` such that \eqn{span{B} = span(V)^{\bot}}{%
|
|
||||||
#' span(B) = orth(span(B))}.
|
|
||||||
#'
|
|
||||||
#' @param X data points
|
|
||||||
#' @param Y response
|
|
||||||
#' @param k assumed \eqn{rank(B)}
|
|
||||||
#' @param nObs parameter for bandwidth estimation, typical value
|
|
||||||
#' \code{nObs = nrow(X)^lambda} with \code{lambda} in the range [0.3, 0.8].
|
|
||||||
#' @param tau Initial step size
|
|
||||||
#' @param tol Tolerance for update error used for stopping criterion
|
|
||||||
#' \eqn{|| V(j) V(j)' - V(j+1) V(j+1)' ||_2 < tol}{%
|
|
||||||
#' \| V_j V_j' - V_{j+1} V_{j+1}' \|_2 < tol}.
|
|
||||||
#' @param maxIter Upper bound of optimization iterations
|
|
||||||
#'
|
|
||||||
#' @return List containing the bandwidth \code{h}, optimization objective \code{V}
|
|
||||||
#' and the matrix \code{B} estimated for the model as a orthogonal basis of the
|
|
||||||
#' orthogonal space spaned by \code{V}.
|
|
||||||
#'
|
|
||||||
#' @rdname optStiefel
|
|
||||||
#' @keywords internal
|
|
||||||
#' @name optStiefel_simple
|
|
||||||
NULL
|
|
||||||
|
|
||||||
#' @rdname optStiefel
|
|
||||||
#' @keywords internal
|
|
||||||
#' @name optStiefel_linesearch
|
|
||||||
NULL
|
|
||||||
|
|
||||||
#' Estimated bandwidth for CVE.
|
|
||||||
#'
|
|
||||||
#' Estimates a propper bandwidth \code{h} according
|
|
||||||
#' \deqn{h = \chi_{p-q}^{-1}\left(\frac{nObs - 1}{n-1}\right)\frac{2 tr(\Sigma)}{p}}{%
|
|
||||||
#' h = qchisq( (nObs - 1)/(n - 1), p - q ) 2 tr(Sigma) / p}
|
|
||||||
#'
|
|
||||||
#' @param X data matrix of dimension (n x p) with n data points X_i of dimension
|
|
||||||
#' q. Therefor each row represents a datapoint of dimension p.
|
|
||||||
#' @param k Guess for rank(B).
|
|
||||||
#' @param nObs Ether numeric of a function. If specified as numeric value
|
|
||||||
#' its used in the computation of the bandwidth directly. If its a function
|
|
||||||
#' `nObs` is evaluated as \code{nObs(nrow(x))}. The default behaviou if not
|
|
||||||
#' supplied at all is to use \code{nObs <- nrow(x)^0.5}.
|
|
||||||
#'
|
|
||||||
#' @seealso [qchisq()]
|
|
||||||
#'
|
|
||||||
#' @export
|
|
||||||
estimateBandwidth <- function(X, k, nObs) {
|
|
||||||
.Call('_CVE_estimateBandwidth', PACKAGE = 'CVE', X, k, nObs)
|
|
||||||
}
|
|
||||||
|
|
||||||
#' Random element from Stiefel Manifold `S(p, q)`.
|
|
||||||
#'
|
|
||||||
#' Draws an element of \eqn{S(p, q)} which is the Stiefel Manifold.
|
|
||||||
#' This is done by taking the Q-component of the QR decomposition
|
|
||||||
#' from a `(p, q)` Matrix with independent standart normal entries.
|
|
||||||
#' As a semi-orthogonal Matrix the result `V` satisfies \eqn{V'V = I_q}.
|
|
||||||
#'
|
|
||||||
#' @param p Row dimension
|
|
||||||
#' @param q Column dimension
|
|
||||||
#'
|
|
||||||
#' @return Matrix of dim `(p, q)`.
|
|
||||||
#'
|
|
||||||
#' @seealso <https://en.wikipedia.org/wiki/Stiefel_manifold>
|
|
||||||
#'
|
|
||||||
#' @export
|
|
||||||
rStiefel <- function(p, q) {
|
|
||||||
.Call('_CVE_rStiefel', PACKAGE = 'CVE', p, q)
|
|
||||||
}
|
|
||||||
|
|
||||||
#' Conditional Variance Estimation (CVE) method.
|
|
||||||
#'
|
|
||||||
#' This version uses a "simple" stiefel optimization schema.
|
|
||||||
#'
|
|
||||||
#' @param X data points
|
|
||||||
#' @param Y response
|
|
||||||
#' @param k assumed \eqn{rank(B)}
|
|
||||||
#' @param nObs parameter for bandwidth estimation, typical value
|
|
||||||
#' \code{nObs = nrow(X)^lambda} with \code{lambda} in the range [0.3, 0.8].
|
|
||||||
#' @param h Bandwidth, if not specified \code{nObs} is used to compute a bandwidth.
|
|
||||||
#' on the other hand if given (positive floating point number) \code{nObs} is ignored.
|
|
||||||
#' @param tau Initial step size (default 1)
|
|
||||||
#' @param tol Tolerance for update error used for stopping criterion (default 1e-5)
|
|
||||||
#' @param slack Ratio of small negative error allowed in loss optimization (default -1e-10)
|
|
||||||
#' @param maxIter Upper bound of optimization iterations (default 50)
|
|
||||||
#' @param attempts Number of tryes with new random optimization starting points (default 10)
|
|
||||||
#'
|
|
||||||
#' @return List containing the bandwidth \code{h}, optimization objective \code{V}
|
|
||||||
#' and the matrix \code{B} estimated for the model as a orthogonal basis of the
|
|
||||||
#' orthogonal space spaned by \code{V}.
|
|
||||||
#'
|
|
||||||
#' @keywords internal
|
|
||||||
cve_cpp <- function(X, Y, method, k, nObs, h = -1., tauInitial = 1., rho1 = 0.1, rho2 = 0.9, tol = 1e-5, maxIter = 50L, maxLineSearchIter = 10L, attempts = 10L) {
|
|
||||||
.Call('_CVE_cve_cpp', PACKAGE = 'CVE', X, Y, method, k, nObs, h, tauInitial, rho1, rho2, tol, maxIter, maxLineSearchIter, attempts)
|
|
||||||
}
|
|
||||||
|
|
||||||
109
CVE/R/datasets.R
109
CVE/R/datasets.R
|
|
@ -1,109 +0,0 @@
|
||||||
#' Generates test datasets.
|
|
||||||
#'
|
|
||||||
#' Provides sample datasets. There are 5 different datasets named
|
|
||||||
#' M1, M2, M3, M4 and M5 describet in the paper references below.
|
|
||||||
#' The general model is given by:
|
|
||||||
#' \deqn{Y ~ g(B'X) + \epsilon}
|
|
||||||
#'
|
|
||||||
#' @param name One of \code{"M1"}, \code{"M2"}, \code{"M3"}, \code{"M4"} or \code{"M5"}
|
|
||||||
#' @param n nr samples
|
|
||||||
#' @param p Dim. of random variable \code{X}.
|
|
||||||
#' @param p.mix Only for \code{"M4"}, see: below.
|
|
||||||
#' @param lambda Only for \code{"M4"}, see: below.
|
|
||||||
#'
|
|
||||||
#' @return List with elements
|
|
||||||
#' \itemize{
|
|
||||||
#' \item{X}{data}
|
|
||||||
#' \item{Y}{response}
|
|
||||||
#' \item{B}{Used dim-reduction matrix}
|
|
||||||
#' \item{name}{Name of the dataset (name parameter)}
|
|
||||||
#' }
|
|
||||||
#'
|
|
||||||
#' @section M1:
|
|
||||||
#' The data follows \eqn{X\sim N_p(0, \Sigma)}{X ~ N_p(0, Sigma)} for a subspace
|
|
||||||
#' dimension of \eqn{k = 2} with a default of \eqn{n = 200} data points.
|
|
||||||
#' The link function \eqn{g} is given as
|
|
||||||
#' \deqn{g(x) = \frac{x_1}{0.5 + (x_2 + 1.5)^2} + 0.5\epsilon}{g(x) = x_1 / (0.5 + (x_2 + 1.5)^2) + 0.5 epsilon}
|
|
||||||
#' @section M2:
|
|
||||||
#' \eqn{X\sim N_p(0, \Sigma)}{X ~ N_p(0, Sigma)} with \eqn{k = 2} with a default of \eqn{n = 200} data points.
|
|
||||||
#' The link function \eqn{g} is given as
|
|
||||||
#' \deqn{g(x) = x_1 x_2^2 + 0.5\epsilon}{g(x) = x_1 x_2^2 + 0.5 epsilon}
|
|
||||||
#' @section M3:
|
|
||||||
#' TODO:
|
|
||||||
#' @section M4:
|
|
||||||
#' TODO:
|
|
||||||
#' @section M5:
|
|
||||||
#' TODO:
|
|
||||||
#'
|
|
||||||
#' @import stats
|
|
||||||
#' @importFrom stats rnorm rbinom
|
|
||||||
#' @export
|
|
||||||
dataset <- function(name = "M1", n, B, p.mix = 0.3, lambda = 1.0) {
|
|
||||||
# validate parameters
|
|
||||||
stopifnot(name %in% c("M1", "M2", "M3", "M4", "M5"))
|
|
||||||
|
|
||||||
# set default values if not supplied
|
|
||||||
if (missing(n)) {
|
|
||||||
n <- if (name %in% c("M1", "M2")) 200 else if (name != "M5") 100 else 42
|
|
||||||
}
|
|
||||||
if (missing(B)) {
|
|
||||||
p <- 12
|
|
||||||
if (name == "M1") {
|
|
||||||
B <- cbind(
|
|
||||||
c( 1, 1, 1, 1, 1, 1, 0, 0, 0, 0, 0, 0),
|
|
||||||
c( 1,-1, 1,-1, 1,-1, 0, 0, 0, 0, 0, 0)
|
|
||||||
) / sqrt(6)
|
|
||||||
} else if (name == "M2") {
|
|
||||||
B <- cbind(
|
|
||||||
c(c(1, 0), rep(0, 10)),
|
|
||||||
c(c(0, 1), rep(0, 10))
|
|
||||||
)
|
|
||||||
} else {
|
|
||||||
B <- matrix(c(rep(1 / sqrt(6), 6), rep(0, 6)), 12, 1)
|
|
||||||
}
|
|
||||||
} else {
|
|
||||||
p <- dim(B)[1]
|
|
||||||
# validate col. nr to match dataset `k = dim(B)[2]`
|
|
||||||
stopifnot(
|
|
||||||
name %in% c("M1", "M2") && dim(B)[2] == 2,
|
|
||||||
name %in% c("M3", "M4", "M5") && dim(B)[2] == 1
|
|
||||||
)
|
|
||||||
}
|
|
||||||
|
|
||||||
# set link function `g` for model `Y ~ g(B'X) + epsilon`
|
|
||||||
if (name == "M1") {
|
|
||||||
g <- function(BX) { BX[1] / (0.5 + (BX[2] + 1.5)^2) }
|
|
||||||
} else if (name == "M2") {
|
|
||||||
g <- function(BX) { BX[1] * BX[2]^2 }
|
|
||||||
} else if (name %in% c("M3", "M4")) {
|
|
||||||
g <- function(BX) { cos(BX[1]) }
|
|
||||||
} else { # name == "M5"
|
|
||||||
g <- function(BX) { 2 * log(abs(BX[1]) + 1) }
|
|
||||||
}
|
|
||||||
|
|
||||||
# compute X
|
|
||||||
if (name != "M4") {
|
|
||||||
# compute root of the covariance matrix according the dataset
|
|
||||||
if (name %in% c("M1", "M3")) {
|
|
||||||
# Variance-Covariance structure for `X ~ N_p(0, \Sigma)` with
|
|
||||||
# `\Sigma_{i, j} = 0.5^{|i - j|}`.
|
|
||||||
Sigma <- matrix(0.5^abs(kronecker(1:p, 1:p, '-')), p, p)
|
|
||||||
# decompose Sigma to Sigma.root^T Sigma.root = Sigma for usage in creation of `X`
|
|
||||||
Sigma.root <- chol(Sigma)
|
|
||||||
} else { # name %in% c("M2", "M5")
|
|
||||||
Sigma.root <- diag(rep(1, p)) # d-dim identity
|
|
||||||
}
|
|
||||||
# data `X` as multivariate random normal variable with
|
|
||||||
# variance matrix `Sigma`.
|
|
||||||
X <- replicate(p, rnorm(n, 0, 1)) %*% Sigma.root
|
|
||||||
} else { # name == "M4"
|
|
||||||
X <- t(replicate(100, rep((1 - 2 * rbinom(1, 1, p.mix)) * lambda, p) + rnorm(p, 0, 1)))
|
|
||||||
}
|
|
||||||
|
|
||||||
# responce `y ~ g(B'X) + epsilon` with `epsilon ~ N(0, 1 / 2)`
|
|
||||||
Y <- apply(X, 1, function(X_i) {
|
|
||||||
g(t(B) %*% X_i) + rnorm(1, 0, 0.5)
|
|
||||||
})
|
|
||||||
|
|
||||||
return(list(X = X, Y = Y, B = B, name = name))
|
|
||||||
}
|
|
||||||
|
|
@ -1,16 +0,0 @@
|
||||||
#' Conditional Variance Estimator (CVE)
|
|
||||||
#'
|
|
||||||
#' Conditional Variance Estimator for Sufficient Dimension
|
|
||||||
#' Reduction
|
|
||||||
#'
|
|
||||||
#' TODO: And some details
|
|
||||||
#'
|
|
||||||
#'
|
|
||||||
#' @references Fertl Likas, Bura Efstathia. Conditional Variance Estimation for Sufficient Dimension Reduction, 2019
|
|
||||||
#'
|
|
||||||
#' @docType package
|
|
||||||
#' @author Loki
|
|
||||||
#' @import Rcpp
|
|
||||||
#' @importFrom Rcpp evalCpp
|
|
||||||
#' @useDynLib CVE
|
|
||||||
"_PACKAGE"
|
|
||||||
|
|
@ -1 +0,0 @@
|
||||||
runtime_test Runtime comparison of CVE against MAVE for M1 - M5 datasets.
|
|
||||||
|
|
@ -1,89 +0,0 @@
|
||||||
# Usage:
|
|
||||||
# ~$ Rscript runtime_test.R
|
|
||||||
|
|
||||||
library(CVE) # load CVE
|
|
||||||
|
|
||||||
#' Writes progress to console.
|
|
||||||
tell.user <- function(name, start.time, i, length) {
|
|
||||||
cat("\rRunning Test (", name, "):",
|
|
||||||
i, "/", length,
|
|
||||||
" - elapsed:", format(Sys.time() - start.time), "\033[K")
|
|
||||||
}
|
|
||||||
subspace.dist <- function(B1, B2){
|
|
||||||
P1 <- B1 %*% solve(t(B1) %*% B1) %*% t(B1)
|
|
||||||
P2 <- B2 %*% solve(t(B2) %*% B2) %*% t(B2)
|
|
||||||
return(norm(P1 - P2, type = 'F'))
|
|
||||||
}
|
|
||||||
|
|
||||||
# Number of simulations
|
|
||||||
SIM.NR <- 50
|
|
||||||
# maximal number of iterations in curvilinear search algorithm
|
|
||||||
MAXIT <- 50
|
|
||||||
# number of arbitrary starting values for curvilinear optimization
|
|
||||||
ATTEMPTS <- 10
|
|
||||||
# set names of datasets
|
|
||||||
dataset.names <- c("M1", "M2", "M3", "M4", "M5")
|
|
||||||
# Set used CVE method
|
|
||||||
methods <- c("simple") # c("legacy", "simple", "sgd", "linesearch")
|
|
||||||
|
|
||||||
# Setup error and time tracking variables
|
|
||||||
error <- matrix(NA, SIM.NR, length(methods) * length(dataset.names))
|
|
||||||
time <- matrix(NA, SIM.NR, ncol(error))
|
|
||||||
colnames(error) <- kronecker(paste0(dataset.names, '-'), methods, paste0)
|
|
||||||
colnames(time) <- colnames(error)
|
|
||||||
|
|
||||||
# only for telling user (to stdout)
|
|
||||||
count <- 0
|
|
||||||
start.time <- Sys.time()
|
|
||||||
# Start simulation loop.
|
|
||||||
for (sim in 1:SIM.NR) {
|
|
||||||
# Repeat for each dataset.
|
|
||||||
for (name in dataset.names) {
|
|
||||||
count <- count + 1
|
|
||||||
tell.user(name, start.time, count, SIM.NR * length(dataset.names))
|
|
||||||
|
|
||||||
# Create a new dataset
|
|
||||||
ds <- dataset(name)
|
|
||||||
# Prepare X, Y and combine to data matrix
|
|
||||||
Y <- ds$Y
|
|
||||||
X <- ds$X
|
|
||||||
data <- cbind(Y, X)
|
|
||||||
# get dimensions
|
|
||||||
dim <- ncol(X)
|
|
||||||
truedim <- ncol(ds$B)
|
|
||||||
|
|
||||||
for (method in methods) {
|
|
||||||
dr.time <- system.time(
|
|
||||||
dr <- cve.call(X, Y,
|
|
||||||
method = method,
|
|
||||||
k = truedim,
|
|
||||||
attempts = ATTEMPTS
|
|
||||||
)
|
|
||||||
)
|
|
||||||
dr <- dr[[truedim]]
|
|
||||||
|
|
||||||
key <- paste0(name, '-', method)
|
|
||||||
error[sim, key] <- subspace.dist(dr$B, ds$B) / sqrt(2 * truedim)
|
|
||||||
time[sim, key] <- dr.time["elapsed"]
|
|
||||||
}
|
|
||||||
}
|
|
||||||
}
|
|
||||||
|
|
||||||
cat("\n\n## Time [sec] Means:\n")
|
|
||||||
print(colMeans(time))
|
|
||||||
cat("\n## Error Means:\n")
|
|
||||||
print(colMeans(error))
|
|
||||||
|
|
||||||
at <- seq(ncol(error)) + rep(seq(ncol(error) / length(methods)) - 1, each = length(methods))
|
|
||||||
boxplot(error,
|
|
||||||
main = paste0("Error (Nr of simulations ", SIM.NR, ")"),
|
|
||||||
ylab = "Error",
|
|
||||||
las = 2,
|
|
||||||
at = at
|
|
||||||
)
|
|
||||||
boxplot(time,
|
|
||||||
main = paste0("Time (Nr of simulations ", SIM.NR, ")"),
|
|
||||||
ylab = "Time [sec]",
|
|
||||||
las = 2,
|
|
||||||
at = at
|
|
||||||
)
|
|
||||||
Binary file not shown.
|
|
@ -1,20 +0,0 @@
|
||||||
% Generated by roxygen2: do not edit by hand
|
|
||||||
% Please edit documentation in R/package.R
|
|
||||||
\docType{package}
|
|
||||||
\name{CVE-package}
|
|
||||||
\alias{CVE}
|
|
||||||
\alias{CVE-package}
|
|
||||||
\title{Conditional Variance Estimator (CVE)}
|
|
||||||
\description{
|
|
||||||
Conditional Variance Estimator for Sufficient Dimension
|
|
||||||
Reduction
|
|
||||||
}
|
|
||||||
\details{
|
|
||||||
TODO: And some details
|
|
||||||
}
|
|
||||||
\references{
|
|
||||||
Fertl Likas, Bura Efstathia. Conditional Variance Estimation for Sufficient Dimension Reduction, 2019
|
|
||||||
}
|
|
||||||
\author{
|
|
||||||
Loki
|
|
||||||
}
|
|
||||||
|
|
@ -1,58 +0,0 @@
|
||||||
% Generated by roxygen2: do not edit by hand
|
|
||||||
% Please edit documentation in R/CVE.R
|
|
||||||
\name{cve}
|
|
||||||
\alias{cve}
|
|
||||||
\alias{cve.call}
|
|
||||||
\title{Implementation of the CVE method.}
|
|
||||||
\usage{
|
|
||||||
cve(formula, data, method = "simple", ...)
|
|
||||||
|
|
||||||
cve.call(X, Y, method = "simple", nObs = nrow(X)^0.5, k, ...)
|
|
||||||
}
|
|
||||||
\arguments{
|
|
||||||
\item{formula}{Formel for the regression model defining `X`, `Y`.
|
|
||||||
See: \code{\link{formula}}.}
|
|
||||||
|
|
||||||
\item{data}{data.frame holding data for formula.}
|
|
||||||
|
|
||||||
\item{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
|
|
||||||
}}
|
|
||||||
|
|
||||||
\item{...}{Further parameters depending on the used method.
|
|
||||||
TODO: See ...}
|
|
||||||
|
|
||||||
\item{nObs}{as describet in the Paper.}
|
|
||||||
}
|
|
||||||
\description{
|
|
||||||
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.
|
|
||||||
}
|
|
||||||
\examples{
|
|
||||||
library(CVE)
|
|
||||||
|
|
||||||
# sample dataset
|
|
||||||
ds <- dataset("M5")
|
|
||||||
|
|
||||||
# call ´cve´ with default method (aka "simple")
|
|
||||||
dr.simple <- cve(ds$Y ~ ds$X, k = ncol(ds$B))
|
|
||||||
# plot optimization history (loss via iteration)
|
|
||||||
plot(dr.simple, main = "CVE M5 simple")
|
|
||||||
|
|
||||||
# call ´cve´ with method "linesearch" using ´data.frame´ as data.
|
|
||||||
data <- data.frame(Y = ds$Y, X = ds$X)
|
|
||||||
# Note: ´Y, X´ are NOT defined, they are extracted from ´data´.
|
|
||||||
dr.linesearch <- cve(Y ~ ., data, method = "linesearch", k = ncol(ds$B))
|
|
||||||
plot(dr.linesearch, main = "CVE M5 linesearch")
|
|
||||||
|
|
||||||
}
|
|
||||||
\references{
|
|
||||||
Fertl L., Bura E. Conditional Variance Estimation for Sufficient Dimension Reduction, 2019
|
|
||||||
}
|
|
||||||
|
|
@ -1,42 +0,0 @@
|
||||||
% Generated by roxygen2: do not edit by hand
|
|
||||||
% Please edit documentation in R/RcppExports.R
|
|
||||||
\name{cve_cpp}
|
|
||||||
\alias{cve_cpp}
|
|
||||||
\title{Conditional Variance Estimation (CVE) method.}
|
|
||||||
\usage{
|
|
||||||
cve_cpp(X, Y, method, k, nObs, h = -1, tauInitial = 1, rho1 = 0.1,
|
|
||||||
rho2 = 0.9, tol = 1e-05, maxIter = 50L, maxLineSearchIter = 10L,
|
|
||||||
attempts = 10L)
|
|
||||||
}
|
|
||||||
\arguments{
|
|
||||||
\item{X}{data points}
|
|
||||||
|
|
||||||
\item{Y}{response}
|
|
||||||
|
|
||||||
\item{k}{assumed \eqn{rank(B)}}
|
|
||||||
|
|
||||||
\item{nObs}{parameter for bandwidth estimation, typical value
|
|
||||||
\code{nObs = nrow(X)^lambda} with \code{lambda} in the range [0.3, 0.8].}
|
|
||||||
|
|
||||||
\item{h}{Bandwidth, if not specified \code{nObs} is used to compute a bandwidth.
|
|
||||||
on the other hand if given (positive floating point number) \code{nObs} is ignored.}
|
|
||||||
|
|
||||||
\item{tol}{Tolerance for update error used for stopping criterion (default 1e-5)}
|
|
||||||
|
|
||||||
\item{maxIter}{Upper bound of optimization iterations (default 50)}
|
|
||||||
|
|
||||||
\item{attempts}{Number of tryes with new random optimization starting points (default 10)}
|
|
||||||
|
|
||||||
\item{tau}{Initial step size (default 1)}
|
|
||||||
|
|
||||||
\item{slack}{Ratio of small negative error allowed in loss optimization (default -1e-10)}
|
|
||||||
}
|
|
||||||
\value{
|
|
||||||
List containing the bandwidth \code{h}, optimization objective \code{V}
|
|
||||||
and the matrix \code{B} estimated for the model as a orthogonal basis of the
|
|
||||||
orthogonal space spaned by \code{V}.
|
|
||||||
}
|
|
||||||
\description{
|
|
||||||
This version uses a "simple" stiefel optimization schema.
|
|
||||||
}
|
|
||||||
\keyword{internal}
|
|
||||||
|
|
@ -1,64 +0,0 @@
|
||||||
% Generated by roxygen2: do not edit by hand
|
|
||||||
% Please edit documentation in R/datasets.R
|
|
||||||
\name{dataset}
|
|
||||||
\alias{dataset}
|
|
||||||
\title{Generates test datasets.}
|
|
||||||
\usage{
|
|
||||||
dataset(name = "M1", n, B, p.mix = 0.3, lambda = 1)
|
|
||||||
}
|
|
||||||
\arguments{
|
|
||||||
\item{name}{One of \code{"M1"}, \code{"M2"}, \code{"M3"}, \code{"M4"} or \code{"M5"}}
|
|
||||||
|
|
||||||
\item{n}{nr samples}
|
|
||||||
|
|
||||||
\item{p.mix}{Only for \code{"M4"}, see: below.}
|
|
||||||
|
|
||||||
\item{lambda}{Only for \code{"M4"}, see: below.}
|
|
||||||
|
|
||||||
\item{p}{Dim. of random variable \code{X}.}
|
|
||||||
}
|
|
||||||
\value{
|
|
||||||
List with elements
|
|
||||||
\itemize{
|
|
||||||
\item{X}{data}
|
|
||||||
\item{Y}{response}
|
|
||||||
\item{B}{Used dim-reduction matrix}
|
|
||||||
\item{name}{Name of the dataset (name parameter)}
|
|
||||||
}
|
|
||||||
}
|
|
||||||
\description{
|
|
||||||
Provides sample datasets. There are 5 different datasets named
|
|
||||||
M1, M2, M3, M4 and M5 describet in the paper references below.
|
|
||||||
The general model is given by:
|
|
||||||
\deqn{Y ~ g(B'X) + \epsilon}
|
|
||||||
}
|
|
||||||
\section{M1}{
|
|
||||||
|
|
||||||
The data follows \eqn{X\sim N_p(0, \Sigma)}{X ~ N_p(0, Sigma)} for a subspace
|
|
||||||
dimension of \eqn{k = 2} with a default of \eqn{n = 200} data points.
|
|
||||||
The link function \eqn{g} is given as
|
|
||||||
\deqn{g(x) = \frac{x_1}{0.5 + (x_2 + 1.5)^2} + 0.5\epsilon}{g(x) = x_1 / (0.5 + (x_2 + 1.5)^2) + 0.5 epsilon}
|
|
||||||
}
|
|
||||||
|
|
||||||
\section{M2}{
|
|
||||||
|
|
||||||
\eqn{X\sim N_p(0, \Sigma)}{X ~ N_p(0, Sigma)} with \eqn{k = 2} with a default of \eqn{n = 200} data points.
|
|
||||||
The link function \eqn{g} is given as
|
|
||||||
\deqn{g(x) = x_1 x_2^2 + 0.5\epsilon}{g(x) = x_1 x_2^2 + 0.5 epsilon}
|
|
||||||
}
|
|
||||||
|
|
||||||
\section{M3}{
|
|
||||||
|
|
||||||
TODO:
|
|
||||||
}
|
|
||||||
|
|
||||||
\section{M4}{
|
|
||||||
|
|
||||||
TODO:
|
|
||||||
}
|
|
||||||
|
|
||||||
\section{M5}{
|
|
||||||
|
|
||||||
TODO:
|
|
||||||
}
|
|
||||||
|
|
||||||
|
|
@ -1,27 +0,0 @@
|
||||||
% Generated by roxygen2: do not edit by hand
|
|
||||||
% Please edit documentation in R/RcppExports.R
|
|
||||||
\name{estimateBandwidth}
|
|
||||||
\alias{estimateBandwidth}
|
|
||||||
\title{Estimated bandwidth for CVE.}
|
|
||||||
\usage{
|
|
||||||
estimateBandwidth(X, k, nObs)
|
|
||||||
}
|
|
||||||
\arguments{
|
|
||||||
\item{X}{data matrix of dimension (n x p) with n data points X_i of dimension
|
|
||||||
q. Therefor each row represents a datapoint of dimension p.}
|
|
||||||
|
|
||||||
\item{k}{Guess for rank(B).}
|
|
||||||
|
|
||||||
\item{nObs}{Ether numeric of a function. If specified as numeric value
|
|
||||||
its used in the computation of the bandwidth directly. If its a function
|
|
||||||
`nObs` is evaluated as \code{nObs(nrow(x))}. The default behaviou if not
|
|
||||||
supplied at all is to use \code{nObs <- nrow(x)^0.5}.}
|
|
||||||
}
|
|
||||||
\description{
|
|
||||||
Estimates a propper bandwidth \code{h} according
|
|
||||||
\deqn{h = \chi_{p-q}^{-1}\left(\frac{nObs - 1}{n-1}\right)\frac{2 tr(\Sigma)}{p}}{%
|
|
||||||
h = qchisq( (nObs - 1)/(n - 1), p - q ) 2 tr(Sigma) / p}
|
|
||||||
}
|
|
||||||
\seealso{
|
|
||||||
[qchisq()]
|
|
||||||
}
|
|
||||||
|
|
@ -1,42 +0,0 @@
|
||||||
% Generated by roxygen2: do not edit by hand
|
|
||||||
% Please edit documentation in R/RcppExports.R
|
|
||||||
\name{gradient}
|
|
||||||
\alias{gradient}
|
|
||||||
\alias{optStiefel_simple}
|
|
||||||
\alias{optStiefel_linesearch}
|
|
||||||
\title{Gradient computation of the loss `L_n(V)`.}
|
|
||||||
\arguments{
|
|
||||||
\item{X}{data points}
|
|
||||||
|
|
||||||
\item{Y}{response}
|
|
||||||
|
|
||||||
\item{k}{assumed \eqn{rank(B)}}
|
|
||||||
|
|
||||||
\item{nObs}{parameter for bandwidth estimation, typical value
|
|
||||||
\code{nObs = nrow(X)^lambda} with \code{lambda} in the range [0.3, 0.8].}
|
|
||||||
|
|
||||||
\item{tau}{Initial step size}
|
|
||||||
|
|
||||||
\item{tol}{Tolerance for update error used for stopping criterion
|
|
||||||
\eqn{|| V(j) V(j)' - V(j+1) V(j+1)' ||_2 < tol}{%
|
|
||||||
\| V_j V_j' - V_{j+1} V_{j+1}' \|_2 < tol}.}
|
|
||||||
|
|
||||||
\item{maxIter}{Upper bound of optimization iterations}
|
|
||||||
}
|
|
||||||
\value{
|
|
||||||
List containing the bandwidth \code{h}, optimization objective \code{V}
|
|
||||||
and the matrix \code{B} estimated for the model as a orthogonal basis of the
|
|
||||||
orthogonal space spaned by \code{V}.
|
|
||||||
}
|
|
||||||
\description{
|
|
||||||
The loss is defined as
|
|
||||||
\deqn{L_n(V) := \frac{1}{n}\sum_{j=1}^n y_2(V, X_j) - y_1(V, X_j)^2}{L_n(V) := 1/n sum_j( (y_2(V, X_j) - y_1(V, X_j)^2 )}
|
|
||||||
with
|
|
||||||
\deqn{y_l(s_0) := \sum_{i=1}^n w_i(V, s_0)Y_i^l}{y_l(s_0) := sum_i(w_i(V, s_0) Y_i^l)}
|
|
||||||
|
|
||||||
Stiefel Optimization for \code{V} given a dataset \code{X} and responces
|
|
||||||
\code{Y} for the model \deqn{Y\sim g(B'X) + \epsilon}{Y ~ g(B'X) + epsilon}
|
|
||||||
to compute the matrix `B` such that \eqn{span{B} = span(V)^{\bot}}{%
|
|
||||||
span(B) = orth(span(B))}.
|
|
||||||
}
|
|
||||||
\keyword{internal}
|
|
||||||
|
|
@ -1,28 +0,0 @@
|
||||||
% Generated by roxygen2: do not edit by hand
|
|
||||||
% Please edit documentation in R/CVE.R
|
|
||||||
\name{plot.cve}
|
|
||||||
\alias{plot.cve}
|
|
||||||
\title{Ploting helper for objects of class \code{cve}.}
|
|
||||||
\usage{
|
|
||||||
## S3 method for class 'cve'
|
|
||||||
plot(x, content = "history", ...)
|
|
||||||
}
|
|
||||||
\arguments{
|
|
||||||
\item{x}{Object of class \code{cve} (result of [cve()]).}
|
|
||||||
|
|
||||||
\item{...}{Pass through parameters to [plot()] and [lines()]}
|
|
||||||
|
|
||||||
\item{content}{Specifies what to plot:
|
|
||||||
\itemize{
|
|
||||||
\item "history" Plots the loss history from stiefel optimization
|
|
||||||
(default).
|
|
||||||
\item ... TODO: add (if there are any)
|
|
||||||
}}
|
|
||||||
}
|
|
||||||
\description{
|
|
||||||
Ploting helper for objects of class \code{cve}.
|
|
||||||
}
|
|
||||||
\seealso{
|
|
||||||
see \code{\link{par}} for graphical parameters to pass through
|
|
||||||
as well as \code{\link{plot}} for standard plot utility.
|
|
||||||
}
|
|
||||||
|
|
@ -1,25 +0,0 @@
|
||||||
% Generated by roxygen2: do not edit by hand
|
|
||||||
% Please edit documentation in R/RcppExports.R
|
|
||||||
\name{rStiefel}
|
|
||||||
\alias{rStiefel}
|
|
||||||
\title{Random element from Stiefel Manifold `S(p, q)`.}
|
|
||||||
\usage{
|
|
||||||
rStiefel(p, q)
|
|
||||||
}
|
|
||||||
\arguments{
|
|
||||||
\item{p}{Row dimension}
|
|
||||||
|
|
||||||
\item{q}{Column dimension}
|
|
||||||
}
|
|
||||||
\value{
|
|
||||||
Matrix of dim `(p, q)`.
|
|
||||||
}
|
|
||||||
\description{
|
|
||||||
Draws an element of \eqn{S(p, q)} which is the Stiefel Manifold.
|
|
||||||
This is done by taking the Q-component of the QR decomposition
|
|
||||||
from a `(p, q)` Matrix with independent standart normal entries.
|
|
||||||
As a semi-orthogonal Matrix the result `V` satisfies \eqn{V'V = I_q}.
|
|
||||||
}
|
|
||||||
\seealso{
|
|
||||||
<https://en.wikipedia.org/wiki/Stiefel_manifold>
|
|
||||||
}
|
|
||||||
427
CVE/src/CVE.cpp
427
CVE/src/CVE.cpp
|
|
@ -1,427 +0,0 @@
|
||||||
// only `RcppArmadillo.h` which includes `Rcpp.h`
|
|
||||||
#include <RcppArmadillo.h>
|
|
||||||
|
|
||||||
// through the depends attribute `Rcpp` is tolled to create
|
|
||||||
// hooks for `RcppArmadillo` needed by the build process.
|
|
||||||
//
|
|
||||||
// [[Rcpp::depends(RcppArmadillo)]]
|
|
||||||
|
|
||||||
// required for `R::qchisq()` used in `estimateBandwidth()`
|
|
||||||
#include <Rmath.h>
|
|
||||||
|
|
||||||
// for proper error handling
|
|
||||||
#include <stdexcept>
|
|
||||||
|
|
||||||
//' Estimated bandwidth for CVE.
|
|
||||||
//'
|
|
||||||
//' Estimates a propper bandwidth \code{h} according
|
|
||||||
//' \deqn{h = \chi_{p-q}^{-1}\left(\frac{nObs - 1}{n-1}\right)\frac{2 tr(\Sigma)}{p}}{%
|
|
||||||
//' h = qchisq( (nObs - 1)/(n - 1), p - q ) 2 tr(Sigma) / p}
|
|
||||||
//'
|
|
||||||
//' @param X data matrix of dimension (n x p) with n data points X_i of dimension
|
|
||||||
//' q. Therefor each row represents a datapoint of dimension p.
|
|
||||||
//' @param k Guess for rank(B).
|
|
||||||
//' @param nObs Ether numeric of a function. If specified as numeric value
|
|
||||||
//' its used in the computation of the bandwidth directly. If its a function
|
|
||||||
//' `nObs` is evaluated as \code{nObs(nrow(x))}. The default behaviou if not
|
|
||||||
//' supplied at all is to use \code{nObs <- nrow(x)^0.5}.
|
|
||||||
//'
|
|
||||||
//' @seealso [qchisq()]
|
|
||||||
//'
|
|
||||||
//' @export
|
|
||||||
// [[Rcpp::export]]
|
|
||||||
double estimateBandwidth(const arma::mat& X, arma::uword k, double nObs) {
|
|
||||||
using namespace arma;
|
|
||||||
|
|
||||||
uword n = X.n_rows; // nr samples
|
|
||||||
uword p = X.n_cols; // dimension of rand. var. `X`
|
|
||||||
|
|
||||||
// column mean
|
|
||||||
mat M = mean(X);
|
|
||||||
// center `X`
|
|
||||||
mat C = X.each_row() - M;
|
|
||||||
// trace of covariance matrix, `traceSigma = Tr(C' C)`
|
|
||||||
double traceSigma = accu(C % C);
|
|
||||||
// compute estimated bandwidth
|
|
||||||
double qchi2 = R::qchisq((nObs - 1.0) / (n - 1), static_cast<double>(k), 1, 0);
|
|
||||||
|
|
||||||
return 2.0 * qchi2 * traceSigma / (p * n);
|
|
||||||
}
|
|
||||||
|
|
||||||
//' Random element from Stiefel Manifold `S(p, q)`.
|
|
||||||
//'
|
|
||||||
//' Draws an element of \eqn{S(p, q)} which is the Stiefel Manifold.
|
|
||||||
//' This is done by taking the Q-component of the QR decomposition
|
|
||||||
//' from a `(p, q)` Matrix with independent standart normal entries.
|
|
||||||
//' As a semi-orthogonal Matrix the result `V` satisfies \eqn{V'V = I_q}.
|
|
||||||
//'
|
|
||||||
//' @param p Row dimension
|
|
||||||
//' @param q Column dimension
|
|
||||||
//'
|
|
||||||
//' @return Matrix of dim `(p, q)`.
|
|
||||||
//'
|
|
||||||
//' @seealso <https://en.wikipedia.org/wiki/Stiefel_manifold>
|
|
||||||
//'
|
|
||||||
//' @export
|
|
||||||
// [[Rcpp::export]]
|
|
||||||
arma::mat rStiefel(arma::uword p, arma::uword q) {
|
|
||||||
arma::mat Q, R;
|
|
||||||
arma::qr_econ(Q, R, arma::randn<arma::mat>(p, q));
|
|
||||||
return Q;
|
|
||||||
}
|
|
||||||
|
|
||||||
//' Gradient computation of the loss `L_n(V)`.
|
|
||||||
//'
|
|
||||||
//' The loss is defined as
|
|
||||||
//' \deqn{L_n(V) := \frac{1}{n}\sum_{j=1}^n y_2(V, X_j) - y_1(V, X_j)^2}{L_n(V) := 1/n sum_j( (y_2(V, X_j) - y_1(V, X_j)^2 )}
|
|
||||||
//' with
|
|
||||||
//' \deqn{y_l(s_0) := \sum_{i=1}^n w_i(V, s_0)Y_i^l}{y_l(s_0) := sum_i(w_i(V, s_0) Y_i^l)}
|
|
||||||
//'
|
|
||||||
//' @rdname optStiefel
|
|
||||||
//' @keywords internal
|
|
||||||
//' @name gradient
|
|
||||||
double gradient(const arma::mat& X,
|
|
||||||
const arma::mat& X_diff,
|
|
||||||
const arma::mat& Y,
|
|
||||||
const arma::mat& Y_rep,
|
|
||||||
const arma::mat& V,
|
|
||||||
const double h,
|
|
||||||
arma::mat* G = 0 // out
|
|
||||||
) {
|
|
||||||
using namespace arma;
|
|
||||||
|
|
||||||
uword n = X.n_rows;
|
|
||||||
|
|
||||||
// orthogonal projection matrix `Q = I - VV'` for dist computation
|
|
||||||
mat Q = -(V * V.t());
|
|
||||||
Q.diag() += 1;
|
|
||||||
// calc pairwise distances as `D` with `D(i, j) = d_i(V, X_j)`
|
|
||||||
vec D_vec = sum(square(X_diff * Q), 1);
|
|
||||||
mat D = reshape(D_vec, n, n);
|
|
||||||
// calc weights as `W` with `W(i, j) = w_i(V, X_j)`
|
|
||||||
mat W = exp(D / (-2.0 * h));
|
|
||||||
// column-wise normalization via 1-norm
|
|
||||||
W = normalise(W, 1);
|
|
||||||
vec W_vec = vectorise(W);
|
|
||||||
// weighted `Y` means (first and second order)
|
|
||||||
vec y1 = W.t() * Y;
|
|
||||||
vec y2 = W.t() * square(Y);
|
|
||||||
// loss for each `X_i`, meaning `L(i) = L_n(V, X_i)`
|
|
||||||
vec L = y2 - square(y1);
|
|
||||||
// `loss = L_n(V)`
|
|
||||||
double loss = mean(L);
|
|
||||||
// check if gradient as output variable is set
|
|
||||||
if (G != 0) {
|
|
||||||
// `G = grad(L_n(V))` a.k.a. gradient of `L` with respect to `V`
|
|
||||||
vec scale = (repelem(L, n, 1) - square(Y_rep - repelem(y1, n, 1))) % W_vec % D_vec;
|
|
||||||
mat X_diff_scale = X_diff.each_col() % scale;
|
|
||||||
(*G) = X_diff_scale.t() * X_diff * V;
|
|
||||||
(*G) *= -2.0 / (h * h * n);
|
|
||||||
}
|
|
||||||
|
|
||||||
return loss;
|
|
||||||
}
|
|
||||||
|
|
||||||
//' Stiefel Optimization.
|
|
||||||
//'
|
|
||||||
//' Stiefel Optimization for \code{V} given a dataset \code{X} and responces
|
|
||||||
//' \code{Y} for the model \deqn{Y\sim g(B'X) + \epsilon}{Y ~ g(B'X) + epsilon}
|
|
||||||
//' to compute the matrix `B` such that \eqn{span{B} = span(V)^{\bot}}{%
|
|
||||||
//' span(B) = orth(span(B))}.
|
|
||||||
//'
|
|
||||||
//' @param X data points
|
|
||||||
//' @param Y response
|
|
||||||
//' @param k assumed \eqn{rank(B)}
|
|
||||||
//' @param nObs parameter for bandwidth estimation, typical value
|
|
||||||
//' \code{nObs = nrow(X)^lambda} with \code{lambda} in the range [0.3, 0.8].
|
|
||||||
//' @param tau Initial step size
|
|
||||||
//' @param tol Tolerance for update error used for stopping criterion
|
|
||||||
//' \eqn{|| V(j) V(j)' - V(j+1) V(j+1)' ||_2 < tol}{%
|
|
||||||
//' \| V_j V_j' - V_{j+1} V_{j+1}' \|_2 < tol}.
|
|
||||||
//' @param maxIter Upper bound of optimization iterations
|
|
||||||
//'
|
|
||||||
//' @return List containing the bandwidth \code{h}, optimization objective \code{V}
|
|
||||||
//' and the matrix \code{B} estimated for the model as a orthogonal basis of the
|
|
||||||
//' orthogonal space spaned by \code{V}.
|
|
||||||
//'
|
|
||||||
//' @rdname optStiefel
|
|
||||||
//' @keywords internal
|
|
||||||
//' @name optStiefel_simple
|
|
||||||
double optStiefel_simple(
|
|
||||||
const arma::mat& X,
|
|
||||||
const arma::vec& Y,
|
|
||||||
const int k,
|
|
||||||
const double h,
|
|
||||||
const double tauInitial,
|
|
||||||
const double tol,
|
|
||||||
const int maxIter,
|
|
||||||
arma::mat& V, // out
|
|
||||||
arma::vec& history // out
|
|
||||||
) {
|
|
||||||
using namespace arma;
|
|
||||||
|
|
||||||
// get dimensions
|
|
||||||
const uword n = X.n_rows; // nr samples
|
|
||||||
const uword p = X.n_cols; // dim of random variable `X`
|
|
||||||
const uword q = p - k; // rank(V) e.g. dim of ortho space of span{B}
|
|
||||||
|
|
||||||
// all `X_i - X_j` differences, `X_diff.row(i * n + j) = X_i - X_j`
|
|
||||||
mat X_diff(n * n, p);
|
|
||||||
for (uword i = 0, k = 0; i < n; ++i) {
|
|
||||||
for (uword j = 0; j < n; ++j) {
|
|
||||||
X_diff.row(k++) = X.row(i) - X.row(j);
|
|
||||||
}
|
|
||||||
}
|
|
||||||
const vec Y_rep = repmat(Y, n, 1);
|
|
||||||
const mat I_p = eye<mat>(p, p);
|
|
||||||
|
|
||||||
// initial start value for `V`
|
|
||||||
V = rStiefel(p, q);
|
|
||||||
|
|
||||||
// init optimization `loss`es, `error` and stepsize `tau`
|
|
||||||
// double loss_next = datum::inf;
|
|
||||||
double loss;
|
|
||||||
double error = datum::inf;
|
|
||||||
double tau = tauInitial;
|
|
||||||
int iter;
|
|
||||||
// main optimization loop
|
|
||||||
for (iter = 0; iter < maxIter && error > tol; ++iter) {
|
|
||||||
// calc gradient `G = grad_V(L)(V)`
|
|
||||||
mat G;
|
|
||||||
loss = gradient(X, X_diff, Y, Y_rep, V, h, &G);
|
|
||||||
// matrix `A` for colescy-transform of the gradient
|
|
||||||
mat A = tau * ((G * V.t()) - (V * G.t()));
|
|
||||||
// next iteration step of `V`
|
|
||||||
mat V_tau = inv(I_p + A) * (I_p - A) * V;
|
|
||||||
// loss after step `L(V(tau))`
|
|
||||||
double loss_tau = gradient(X, X_diff, Y, Y_rep, V_tau, h);
|
|
||||||
|
|
||||||
// store `loss` in `history` and increase `iter`
|
|
||||||
history(iter) = loss;
|
|
||||||
|
|
||||||
// validate if loss decreased
|
|
||||||
if ((loss_tau - loss) > 0.0) {
|
|
||||||
// ignore step, retry with half the step size
|
|
||||||
tau = tau / 2.;
|
|
||||||
error = datum::inf;
|
|
||||||
} else {
|
|
||||||
// compute step error (break condition)
|
|
||||||
error = norm((V * V.t()) - (V_tau * V_tau.t()), 2) / (2 * q);
|
|
||||||
// shift for next iteration
|
|
||||||
V = V_tau;
|
|
||||||
loss = loss_tau;
|
|
||||||
}
|
|
||||||
}
|
|
||||||
|
|
||||||
// store final `loss`
|
|
||||||
history(iter) = loss;
|
|
||||||
|
|
||||||
return loss;
|
|
||||||
}
|
|
||||||
|
|
||||||
//' @rdname optStiefel
|
|
||||||
//' @keywords internal
|
|
||||||
//' @name optStiefel_linesearch
|
|
||||||
double optStiefel_linesearch(
|
|
||||||
const arma::mat& X,
|
|
||||||
const arma::vec& Y,
|
|
||||||
const int k,
|
|
||||||
const double h,
|
|
||||||
const double tauInitial,
|
|
||||||
const double tol,
|
|
||||||
const int maxIter,
|
|
||||||
const double rho1,
|
|
||||||
const double rho2,
|
|
||||||
const int maxLineSearchIter,
|
|
||||||
arma::mat& V, // out
|
|
||||||
arma::vec& history // out
|
|
||||||
) {
|
|
||||||
using namespace arma;
|
|
||||||
|
|
||||||
// get dimensions
|
|
||||||
const uword n = X.n_rows; // nr samples
|
|
||||||
const uword p = X.n_cols; // dim of random variable `X`
|
|
||||||
const uword q = p - k; // rank(V) e.g. dim of ortho space of span{B}
|
|
||||||
|
|
||||||
// all `X_i - X_j` differences, `X_diff.row(i * n + j) = X_i - X_j`
|
|
||||||
mat X_diff(n * n, p);
|
|
||||||
for (uword i = 0, k = 0; i < n; ++i) {
|
|
||||||
for (uword j = 0; j < n; ++j) {
|
|
||||||
X_diff.row(k++) = X.row(i) - X.row(j);
|
|
||||||
}
|
|
||||||
}
|
|
||||||
const vec Y_rep = repmat(Y, n, 1);
|
|
||||||
const mat I_p = eye<mat>(p, p);
|
|
||||||
const mat I_2q = eye<mat>(2 * q, 2 * q);
|
|
||||||
|
|
||||||
// initial start value for `V`
|
|
||||||
V = rStiefel(p, q);
|
|
||||||
|
|
||||||
// first gradient initialization
|
|
||||||
mat G;
|
|
||||||
double loss = gradient(X, X_diff, Y, Y_rep, V, h, &G);
|
|
||||||
|
|
||||||
// set first `loss` in history
|
|
||||||
history(0) = loss;
|
|
||||||
|
|
||||||
// main curvilinear optimization loop
|
|
||||||
double error = datum::inf;
|
|
||||||
int iter = 0;
|
|
||||||
while (iter++ < maxIter && error > tol) {
|
|
||||||
// helper matrices `lU` (linesearch U), `lV` (linesearch V)
|
|
||||||
// as describet in [Wen, Yin] Lemma 4.
|
|
||||||
mat lU = join_rows(G, V); // linesearch "U"
|
|
||||||
mat lV = join_rows(V, -1.0 * G); // linesearch "V"
|
|
||||||
// `A = G V' - V G'`
|
|
||||||
mat A = lU * lV.t();
|
|
||||||
|
|
||||||
// set initial step size for curvilinear line search
|
|
||||||
double tau = tauInitial, lower = 0., upper = datum::inf;
|
|
||||||
|
|
||||||
// TODO: check if `tau` is valid for inverting
|
|
||||||
|
|
||||||
// set line search internal gradient and loss to cycle for next iteration
|
|
||||||
mat V_tau; // next position after a step of size `tau`, a.k.a. `V(tau)`
|
|
||||||
mat G_tau; // gradient of `V` at `V(tau) = V_tau`
|
|
||||||
double loss_tau; // loss (objective) at position `V(tau)`
|
|
||||||
int lsIter = 0; // linesearch iter
|
|
||||||
// start line search
|
|
||||||
do {
|
|
||||||
mat HV = inv(I_2q + (tau/2.) * lV.t() * lU) * lV.t();
|
|
||||||
// next step `V`
|
|
||||||
V_tau = V - tau * (lU * (HV * V));
|
|
||||||
|
|
||||||
double LprimeV = -trace(G.t() * A * V);
|
|
||||||
|
|
||||||
mat lB = I_p - (tau / 2.) * lU * HV;
|
|
||||||
|
|
||||||
loss_tau = gradient(X, X_diff, Y, Y_rep, V_tau, h, &G_tau);
|
|
||||||
|
|
||||||
double LprimeV_tau = -2. * trace(G_tau.t() * lB * A * (V + V_tau));
|
|
||||||
|
|
||||||
// Armijo condition
|
|
||||||
if (loss_tau > loss + (rho1 * tau * LprimeV)) {
|
|
||||||
upper = tau;
|
|
||||||
tau = (lower + upper) / 2.;
|
|
||||||
// Wolfe condition
|
|
||||||
} else if (LprimeV_tau < rho2 * LprimeV) {
|
|
||||||
lower = tau;
|
|
||||||
if (upper == datum::inf) {
|
|
||||||
tau = 2. * lower;
|
|
||||||
} else {
|
|
||||||
tau = (lower + upper) / 2.;
|
|
||||||
}
|
|
||||||
} else {
|
|
||||||
break;
|
|
||||||
}
|
|
||||||
} while (++lsIter < maxLineSearchIter);
|
|
||||||
|
|
||||||
// compute error (break condition)
|
|
||||||
// Note: `error` is the decrease of the objective `L_n(V)` and not the
|
|
||||||
// norm of the gradient as proposed in [Wen, Yin] Algorithm 1.
|
|
||||||
error = loss - loss_tau;
|
|
||||||
|
|
||||||
// cycle `V`, `G` and `loss` for next iteration
|
|
||||||
V = V_tau;
|
|
||||||
loss = loss_tau;
|
|
||||||
G = G_tau;
|
|
||||||
|
|
||||||
// store final `loss`
|
|
||||||
history(iter) = loss;
|
|
||||||
}
|
|
||||||
|
|
||||||
return loss;
|
|
||||||
}
|
|
||||||
|
|
||||||
//' Conditional Variance Estimation (CVE) method.
|
|
||||||
//'
|
|
||||||
//' This version uses a "simple" stiefel optimization schema.
|
|
||||||
//'
|
|
||||||
//' @param X data points
|
|
||||||
//' @param Y response
|
|
||||||
//' @param k assumed \eqn{rank(B)}
|
|
||||||
//' @param nObs parameter for bandwidth estimation, typical value
|
|
||||||
//' \code{nObs = nrow(X)^lambda} with \code{lambda} in the range [0.3, 0.8].
|
|
||||||
//' @param h Bandwidth, if not specified \code{nObs} is used to compute a bandwidth.
|
|
||||||
//' on the other hand if given (positive floating point number) \code{nObs} is ignored.
|
|
||||||
//' @param tau Initial step size (default 1)
|
|
||||||
//' @param tol Tolerance for update error used for stopping criterion (default 1e-5)
|
|
||||||
//' @param slack Ratio of small negative error allowed in loss optimization (default -1e-10)
|
|
||||||
//' @param maxIter Upper bound of optimization iterations (default 50)
|
|
||||||
//' @param attempts Number of tryes with new random optimization starting points (default 10)
|
|
||||||
//'
|
|
||||||
//' @return List containing the bandwidth \code{h}, optimization objective \code{V}
|
|
||||||
//' and the matrix \code{B} estimated for the model as a orthogonal basis of the
|
|
||||||
//' orthogonal space spaned by \code{V}.
|
|
||||||
//'
|
|
||||||
//' @keywords internal
|
|
||||||
// [[Rcpp::export]]
|
|
||||||
Rcpp::List cve_cpp(
|
|
||||||
const arma::mat& X,
|
|
||||||
const arma::vec& Y,
|
|
||||||
const std::string method,
|
|
||||||
const int k,
|
|
||||||
const double nObs,
|
|
||||||
double h = -1., // default value to be overwritten
|
|
||||||
const double tauInitial = 1.,
|
|
||||||
const double rho1 = 0.1,
|
|
||||||
const double rho2 = 0.9,
|
|
||||||
const double tol = 1e-5,
|
|
||||||
const int maxIter = 50,
|
|
||||||
const int maxLineSearchIter = 10,
|
|
||||||
const int attempts = 10
|
|
||||||
) {
|
|
||||||
using namespace arma;
|
|
||||||
|
|
||||||
// tracker of current best results
|
|
||||||
mat V_best;
|
|
||||||
double loss_best = datum::inf;
|
|
||||||
// estimate bandwidth
|
|
||||||
if (h <= 0.0) {
|
|
||||||
h = estimateBandwidth(X, k, nObs);
|
|
||||||
}
|
|
||||||
|
|
||||||
// loss history for each optimization attempt
|
|
||||||
// each column contaions the iteration history for the loss
|
|
||||||
mat history = mat(maxIter + 1, attempts);
|
|
||||||
|
|
||||||
// multiple stiefel optimization attempts
|
|
||||||
for (int i = 0; i < attempts; ++i) {
|
|
||||||
// declare output variables
|
|
||||||
mat V; // estimated `V` space
|
|
||||||
vec hist = vec(history.n_rows, fill::zeros); // optimization history
|
|
||||||
double loss;
|
|
||||||
if (method == "simple") {
|
|
||||||
loss = optStiefel_simple(
|
|
||||||
X, Y, k, h,
|
|
||||||
tauInitial, tol, maxIter,
|
|
||||||
V, hist
|
|
||||||
);
|
|
||||||
} else if (method == "linesearch") {
|
|
||||||
loss = optStiefel_linesearch(
|
|
||||||
X, Y, k, h,
|
|
||||||
tauInitial, tol, maxIter, rho1, rho2, maxLineSearchIter,
|
|
||||||
V, hist
|
|
||||||
);
|
|
||||||
} else {
|
|
||||||
throw std::invalid_argument("Unknown method.");
|
|
||||||
}
|
|
||||||
if (loss < loss_best) {
|
|
||||||
loss_best = loss;
|
|
||||||
V_best = V;
|
|
||||||
}
|
|
||||||
// add history to history collection
|
|
||||||
history.col(i) = hist;
|
|
||||||
}
|
|
||||||
|
|
||||||
// get `B` as kernal of `V.t()`
|
|
||||||
mat B = null(V_best.t());
|
|
||||||
|
|
||||||
return Rcpp::List::create(
|
|
||||||
Rcpp::Named("history") = history,
|
|
||||||
Rcpp::Named("loss") = loss_best,
|
|
||||||
Rcpp::Named("h") = h,
|
|
||||||
Rcpp::Named("V") = V_best,
|
|
||||||
Rcpp::Named("B") = B
|
|
||||||
);
|
|
||||||
}
|
|
||||||
|
|
@ -1,14 +0,0 @@
|
||||||
|
|
||||||
## With R 3.1.0 or later, you can uncomment the following line to tell R to
|
|
||||||
## enable compilation with C++11 (where available)
|
|
||||||
##
|
|
||||||
## Also, OpenMP support in Armadillo prefers C++11 support. However, for wider
|
|
||||||
## availability of the package we do not yet enforce this here. It is however
|
|
||||||
## recommended for client packages to set it.
|
|
||||||
##
|
|
||||||
## And with R 3.4.0, and RcppArmadillo 0.7.960.*, we turn C++11 on as OpenMP
|
|
||||||
## support within Armadillo prefers / requires it
|
|
||||||
CXX_STD = CXX11
|
|
||||||
|
|
||||||
PKG_CXXFLAGS = $(SHLIB_OPENMP_CXXFLAGS)
|
|
||||||
PKG_LIBS = $(SHLIB_OPENMP_CXXFLAGS) $(LAPACK_LIBS) $(BLAS_LIBS) $(FLIBS)
|
|
||||||
|
|
@ -1,14 +0,0 @@
|
||||||
|
|
||||||
## With R 3.1.0 or later, you can uncomment the following line to tell R to
|
|
||||||
## enable compilation with C++11 (where available)
|
|
||||||
##
|
|
||||||
## Also, OpenMP support in Armadillo prefers C++11 support. However, for wider
|
|
||||||
## availability of the package we do not yet enforce this here. It is however
|
|
||||||
## recommended for client packages to set it.
|
|
||||||
##
|
|
||||||
## And with R 3.4.0, and RcppArmadillo 0.7.960.*, we turn C++11 on as OpenMP
|
|
||||||
## support within Armadillo prefers / requires it
|
|
||||||
CXX_STD = CXX11
|
|
||||||
|
|
||||||
PKG_CXXFLAGS = $(SHLIB_OPENMP_CXXFLAGS)
|
|
||||||
PKG_LIBS = $(SHLIB_OPENMP_CXXFLAGS) $(LAPACK_LIBS) $(BLAS_LIBS) $(FLIBS)
|
|
||||||
|
|
@ -1,68 +0,0 @@
|
||||||
// Generated by using Rcpp::compileAttributes() -> do not edit by hand
|
|
||||||
// Generator token: 10BE3573-1514-4C36-9D1C-5A225CD40393
|
|
||||||
|
|
||||||
#include <RcppArmadillo.h>
|
|
||||||
#include <Rcpp.h>
|
|
||||||
|
|
||||||
using namespace Rcpp;
|
|
||||||
|
|
||||||
// estimateBandwidth
|
|
||||||
double estimateBandwidth(const arma::mat& X, arma::uword k, double nObs);
|
|
||||||
RcppExport SEXP _CVE_estimateBandwidth(SEXP XSEXP, SEXP kSEXP, SEXP nObsSEXP) {
|
|
||||||
BEGIN_RCPP
|
|
||||||
Rcpp::RObject rcpp_result_gen;
|
|
||||||
Rcpp::RNGScope rcpp_rngScope_gen;
|
|
||||||
Rcpp::traits::input_parameter< const arma::mat& >::type X(XSEXP);
|
|
||||||
Rcpp::traits::input_parameter< arma::uword >::type k(kSEXP);
|
|
||||||
Rcpp::traits::input_parameter< double >::type nObs(nObsSEXP);
|
|
||||||
rcpp_result_gen = Rcpp::wrap(estimateBandwidth(X, k, nObs));
|
|
||||||
return rcpp_result_gen;
|
|
||||||
END_RCPP
|
|
||||||
}
|
|
||||||
// rStiefel
|
|
||||||
arma::mat rStiefel(arma::uword p, arma::uword q);
|
|
||||||
RcppExport SEXP _CVE_rStiefel(SEXP pSEXP, SEXP qSEXP) {
|
|
||||||
BEGIN_RCPP
|
|
||||||
Rcpp::RObject rcpp_result_gen;
|
|
||||||
Rcpp::RNGScope rcpp_rngScope_gen;
|
|
||||||
Rcpp::traits::input_parameter< arma::uword >::type p(pSEXP);
|
|
||||||
Rcpp::traits::input_parameter< arma::uword >::type q(qSEXP);
|
|
||||||
rcpp_result_gen = Rcpp::wrap(rStiefel(p, q));
|
|
||||||
return rcpp_result_gen;
|
|
||||||
END_RCPP
|
|
||||||
}
|
|
||||||
// cve_cpp
|
|
||||||
Rcpp::List cve_cpp(const arma::mat& X, const arma::vec& Y, const std::string method, const int k, const double nObs, double h, const double tauInitial, const double rho1, const double rho2, const double tol, const int maxIter, const int maxLineSearchIter, const int attempts);
|
|
||||||
RcppExport SEXP _CVE_cve_cpp(SEXP XSEXP, SEXP YSEXP, SEXP methodSEXP, SEXP kSEXP, SEXP nObsSEXP, SEXP hSEXP, SEXP tauInitialSEXP, SEXP rho1SEXP, SEXP rho2SEXP, SEXP tolSEXP, SEXP maxIterSEXP, SEXP maxLineSearchIterSEXP, SEXP attemptsSEXP) {
|
|
||||||
BEGIN_RCPP
|
|
||||||
Rcpp::RObject rcpp_result_gen;
|
|
||||||
Rcpp::RNGScope rcpp_rngScope_gen;
|
|
||||||
Rcpp::traits::input_parameter< const arma::mat& >::type X(XSEXP);
|
|
||||||
Rcpp::traits::input_parameter< const arma::vec& >::type Y(YSEXP);
|
|
||||||
Rcpp::traits::input_parameter< const std::string >::type method(methodSEXP);
|
|
||||||
Rcpp::traits::input_parameter< const int >::type k(kSEXP);
|
|
||||||
Rcpp::traits::input_parameter< const double >::type nObs(nObsSEXP);
|
|
||||||
Rcpp::traits::input_parameter< double >::type h(hSEXP);
|
|
||||||
Rcpp::traits::input_parameter< const double >::type tauInitial(tauInitialSEXP);
|
|
||||||
Rcpp::traits::input_parameter< const double >::type rho1(rho1SEXP);
|
|
||||||
Rcpp::traits::input_parameter< const double >::type rho2(rho2SEXP);
|
|
||||||
Rcpp::traits::input_parameter< const double >::type tol(tolSEXP);
|
|
||||||
Rcpp::traits::input_parameter< const int >::type maxIter(maxIterSEXP);
|
|
||||||
Rcpp::traits::input_parameter< const int >::type maxLineSearchIter(maxLineSearchIterSEXP);
|
|
||||||
Rcpp::traits::input_parameter< const int >::type attempts(attemptsSEXP);
|
|
||||||
rcpp_result_gen = Rcpp::wrap(cve_cpp(X, Y, method, k, nObs, h, tauInitial, rho1, rho2, tol, maxIter, maxLineSearchIter, attempts));
|
|
||||||
return rcpp_result_gen;
|
|
||||||
END_RCPP
|
|
||||||
}
|
|
||||||
|
|
||||||
static const R_CallMethodDef CallEntries[] = {
|
|
||||||
{"_CVE_estimateBandwidth", (DL_FUNC) &_CVE_estimateBandwidth, 3},
|
|
||||||
{"_CVE_rStiefel", (DL_FUNC) &_CVE_rStiefel, 2},
|
|
||||||
{"_CVE_cve_cpp", (DL_FUNC) &_CVE_cve_cpp, 13},
|
|
||||||
{NULL, NULL, 0}
|
|
||||||
};
|
|
||||||
|
|
||||||
RcppExport void R_init_CVE(DllInfo *dll) {
|
|
||||||
R_registerRoutines(dll, NULL, CallEntries, NULL, NULL);
|
|
||||||
R_useDynamicSymbols(dll, FALSE);
|
|
||||||
}
|
|
||||||
Loading…
Reference in New Issue