wip: convert to package

This commit is contained in:
Daniel Kapla 2021-11-04 13:05:15 +01:00
parent 3092f6c3f7
commit db550c77bd
11 changed files with 67 additions and 53 deletions

58
.gitignore vendored
View File

@ -1,4 +1,4 @@
# ---> C ## C compiler and compiled library files
# Prerequisites # Prerequisites
*.d *.d
@ -43,24 +43,7 @@
*.idb *.idb
*.pdb *.pdb
# Kernel Module Compile Results ## R environment, data and pacakge build intermediate files/folders
*.mod*
*.cmd
.tmp_versions/
modules.order
Module.symvers
Mkfile.old
dkms.conf
# ---> R
# History files
.Rhistory
.Rapp.history
# Session Data files
*.RData
*.Rdata
# R Data Object files # R Data Object files
*.Rds *.Rds
*.rds *.rds
@ -68,22 +51,13 @@ dkms.conf
# Example code in package build process # Example code in package build process
*-Ex.R *-Ex.R
# Output files from R CMD build
/*.tar.gz
# Output files from R CMD check # Output files from R CMD check
/*.Rcheck/ /*.Rcheck/
# RStudio files
.Rproj.user/
# produced vignettes # produced vignettes
vignettes/*.html vignettes/*.html
vignettes/*.pdf vignettes/*.pdf
# OAuth2 token, see https://github.com/hadley/httr/releases/tag/v0.3
.httr-oauth
# knitr and R markdown default cache directories # knitr and R markdown default cache directories
/*_cache/ /*_cache/
/cache/ /cache/
@ -92,8 +66,32 @@ vignettes/*.pdf
*.utf8.md *.utf8.md
*.knit.md *.knit.md
# Shiny token, see https://shiny.rstudio.com/articles/shinyapps.html # R documentation
rsconnect/ *.Rd
## R session, RStudio and VSCode files
# RStudio files
.Rproj.user/
# History files
.Rhistory
.Rapp.history
# Session Data files
*.RData
*.Rdata
# VSCode configuration
.vscode/
## Archives, compressed files/folders
# Output files from R CMD build
*.tar.gz
*.zip
## Further project development folders/files
# General Work In Progress files # General Work In Progress files
wip/ wip/
# PDFs
*.pdf

View File

@ -1,6 +1,6 @@
Package: tensorPredictors Package: tensorPredictors
Type: Package Type: Package
Title: Tensor/Matrix valued predictors for regression and dimension reduction Title: Sufficient Dimension Reduction for Matrix Valued Predictors
Version: 0.1 Version: 0.1
Date: 2021-10-28 Date: 2021-10-28
Author: Daniel Kapla [aut] Author: Daniel Kapla [aut]
@ -8,6 +8,8 @@ Maintainer: Daniel Kapla <daniel@kapla.at>
Description: Multiple methods using tensor/matrix valued predictors for Description: Multiple methods using tensor/matrix valued predictors for
regression or sufficient dimension reduction. regression or sufficient dimension reduction.
License: GPL-3 License: GPL-3
Depends: Depends: R(>= 3.0)
Imports: stats
Suggests: RSpectra
Encoding: UTF-8 Encoding: UTF-8
RoxygenNote: 7.1.1 RoxygenNote: 7.1.1

View File

@ -4,4 +4,6 @@ export(LSIR)
export(PCA2d) export(PCA2d)
export(POI) export(POI)
export(approx.kronecker) export(approx.kronecker)
export(reduce)
import(stats)
useDynLib(tensorPredictors, .registration = TRUE) useDynLib(tensorPredictors, .registration = TRUE)

View File

@ -13,15 +13,13 @@
#' #'
#' @examples #' @examples
#' A <- matrix(seq(14), 7, 2) #' A <- matrix(seq(14), 7, 2)
#' B <- matrix(c(T, F), 3, 4) #' B <- matrix(c(1, 0), 3, 4)
#' C <- kronecker(A, B) # the same as 'C <- A %x% B' #' C <- kronecker(A, B) # the same as 'C <- A %x% B'
#' approx.kronecker(C, dim(A), dim(B)) #' approx.kronecker(C, dim(A), dim(B))
#' #'
#' @seealso C.F. Van Loan / Journal of Computational and Applied Mathematics #' @seealso C.F. Van Loan / Journal of Computational and Applied Mathematics
#' 123 (2000) 85-100 (pp. 93-95) #' 123 (2000) 85-100 (pp. 93-95)
#' #'
#' @imports RSpectra
#'
#' @export #' @export
approx.kronecker <- function(C, dimA, dimB) { approx.kronecker <- function(C, dimA, dimB) {
@ -29,8 +27,9 @@ approx.kronecker <- function(C, dimA, dimB) {
R <- aperm(C, c(2L, 4L, 1L, 3L)) R <- aperm(C, c(2L, 4L, 1L, 3L))
dim(R) <- c(prod(dimA), prod(dimB)) dim(R) <- c(prod(dimA), prod(dimB))
svdR <- try(RSpectra::svds(R, 1L), silent = TRUE) if (requireNamespace("RSpectra", quietly = TRUE)) {
if (is(svdR, 'try-error')) { svdR <- RSpectra::svds(R, 1L)
} else {
svdR <- svd(R, 1L, 1L) svdR <- svd(R, 1L, 1L)
} }

View File

@ -21,7 +21,7 @@
#' #'
#' @seealso \code{\link{solve}}, \code{\link{qr}}, \code{\link{svd}}. #' @seealso \code{\link{solve}}, \code{\link{qr}}, \code{\link{svd}}.
#' #'
#' @examples #' @examples \dontrun{
#' # General full rank square matrices. #' # General full rank square matrices.
#' A <- matrix(rnorm(121), 11, 11) #' A <- matrix(rnorm(121), 11, 11)
#' all.equal(matpow(A, 1), A) #' all.equal(matpow(A, 1), A)
@ -54,6 +54,7 @@
#' all.equal(B %*% B %*% A %*% B %*% B, B %*% B) #' all.equal(B %*% B %*% A %*% B %*% B, B %*% B)
#' all.equal(B %*% A, t(B %*% A)) #' all.equal(B %*% A, t(B %*% A))
#' all.equal(A %*% B, t(A %*% B)) #' all.equal(A %*% B, t(A %*% B))
#' }
#' #'
#' @keywords internal #' @keywords internal
matpow <- function(A, pow, tol = 1e-7) { matpow <- function(A, pow, tol = 1e-7) {

View File

@ -7,7 +7,7 @@
#' @details The parameter names \code{lhs} and \code{rhs} stand for "Left Hand #' @details The parameter names \code{lhs} and \code{rhs} stand for "Left Hand
#' Side" and "Right Hand Side", respectively. #' Side" and "Right Hand Side", respectively.
#' #'
#' @examples #' @examples \dontrun{
#' c(a, b) %<-% list(1, 2) #' c(a, b) %<-% list(1, 2)
#' # is equivalent to #' # is equivalent to
#' ## a <- 1 #' ## a <- 1
@ -15,12 +15,13 @@
#' #'
#' # Switching the values of a, b could be done by. #' # Switching the values of a, b could be done by.
#' c(a, b) %<-% list(b, a) #' c(a, b) %<-% list(b, a)
#' note the usage of 'list' on the right side, otherwise an exraction of the #' # note the usage of 'list' on the right side, otherwise an exraction of the
#' first two values of the concatenated object is performed. See next: #' # first two values of the concatenated object is performed. See next:
#' #'
#' # Extract values. #' # Extract values.
#' c(d1, d2, d3) %<-% 1:10 #' c(d1, d2, d3) %<-% 1:10
#' extracting the first three valus from the vector of length 10. #' # extracting the first three valus from the vector of length 10.
#' }
#' #'
#' @keywords internal #' @keywords internal
"%<-%" <- function(lhs, rhs) { "%<-%" <- function(lhs, rhs) {
@ -30,4 +31,5 @@
for (i in seq_along(var.names)) { for (i in seq_along(var.names)) {
assign(var.names[i], values[[i]], envir = env) assign(var.names[i], values[[i]], envir = env)
} }
lhs
} }

View File

@ -1,10 +1,14 @@
#'2-Dimensional Principal Component Analysis #'2-Dimensional Principal Component Analysis
#' #'
#' @param X Matrix of dim (n, p * t) with each row the vectorized (p, t) observation. #' @param X Matrix of \code{dim (n, p * t)} with each row the vectorized
#' \eqn{p \times t} observation.
#' @param p nr. predictors #' @param p nr. predictors
#' @param t nr. timepoints #' @param t nr. timepoints
#' @param ppc reduced nr. predictors (p-principal components) #' @param ppc reduced nr. predictors (p-principal components)
#' @param tpc reduced nr. timepoints (t-principal components) #' @param tpc reduced nr. timepoints (t-principal components)
#' @param scale passed to \code{\link{scale}} before processing \code{X}.
#'
#' @return list with 2d pca estimated reduction estimates.
#' #'
#' @details The `i`th observation is stored in a row such that its matrix equiv #' @details The `i`th observation is stored in a row such that its matrix equiv
#' is given by `matrix(X[i, ], p, t)`. #' is given by `matrix(X[i, ], p, t)`.

View File

@ -19,13 +19,10 @@ POI <- function(A, B, d,
# TODO: # TODO:
stopifnot(method == 'FastPOI-C') stopifnot(method == 'FastPOI-C')
if (nrow(A) < 100) { if (requireNamespace("RSpectra", quietly = TRUE)) {
Delta <- eigen(A, symmetric = TRUE)$vectors[, 1:d, drop = FALSE] Delta <- RSpectra::eigs_sym(A, d)$vectors
} else { } else {
Delta <- try(RSpectra::eigs_sym(A, d)$vectors, silent = TRUE) Delta <- eigen(A, symmetric = TRUE)$vectors[, 1:d, drop = FALSE]
if (is(Delta, 'try-error')) {
Delta <- eigen(A, symmetric = TRUE)$vectors[1:d, , drop = FALSE]
}
} }
# Set initial value. # Set initial value.

View File

@ -9,11 +9,11 @@
#' #'
#' @return a \eqn{n\times p}{n x p} matrix with samples in its rows. #' @return a \eqn{n\times p}{n x p} matrix with samples in its rows.
#' #'
#' @examples #' @examples \dontrun{
#' \dontrun{
#' rmvnorm(20, sigma = matrix(c(2, 1, 1, 2), 2)) #' rmvnorm(20, sigma = matrix(c(2, 1, 1, 2), 2))
#' rmvnorm(20, mu = c(3, -1, 2)) #' rmvnorm(20, mu = c(3, -1, 2))
#' } #' }
#'
#' @keywords internal #' @keywords internal
rmvnorm <- function(n = 1, mu = rep(0, p), sigma = diag(p)) { rmvnorm <- function(n = 1, mu = rep(0, p), sigma = diag(p)) {
if (!missing(sigma)) { if (!missing(sigma)) {

View File

@ -5,6 +5,8 @@
#' #'
#' @author Daniel Kapla #' @author Daniel Kapla
#' #'
#' @import stats
#'
#' @docType package #' @docType package
#' @useDynLib tensorPredictors, .registration = TRUE #' @useDynLib tensorPredictors, .registration = TRUE
"_PACKAGE" "_PACKAGE"
@ -158,7 +160,13 @@ tensor_predictor <- function(X, Fy, p, t, k = 1L, r = 1L, d1 = 1L, d2 = 1L,
)) ))
} }
#' TODO: Write this properly! #' Reduce new data using estimated reduction.
#'
#' @param object estimated reduction object.
#' @param data new data to apply reduce
#' @param use which type of reduction/internal variables should be used
#'
#' @export
reduce <- function(object, data, use = 'Gamma') { reduce <- function(object, data, use = 'Gamma') {
if (use == 'Gamma') { if (use == 'Gamma') {
projection <- object$Gamma projection <- object$Gamma

View File

@ -74,13 +74,14 @@ extern SEXP FastPOI_C_sub(SEXP in_A, SEXP in_B, SEXP in_Delta, SEXP in_lambda, S
return out_Z; return out_Z;
} }
/* List of registered routines (e.g. C entry points) */
static const R_CallMethodDef CallEntries[] = { static const R_CallMethodDef CallEntries[] = {
{"FastPOI_C_sub", (DL_FUNC) &FastPOI_C_sub, 5}, {"FastPOI_C_sub", (DL_FUNC) &FastPOI_C_sub, 5},
{NULL, NULL, 0} {NULL, NULL, 0}
}; };
/* Restrict C entry points to registered routines. */ /* Restrict C entry points to registered routines. */
void R_init_CVE(DllInfo *dll) { void R_init_tensorPredictors(DllInfo *dll) {
R_registerRoutines(dll, NULL, CallEntries, NULL, NULL); R_registerRoutines(dll, NULL, CallEntries, NULL, NULL);
R_useDynamicSymbols(dll, FALSE); R_useDynamicSymbols(dll, FALSE);
} }