wip: convert to R-package

This commit is contained in:
Daniel Kapla 2021-10-29 18:16:40 +02:00
parent 14d8a9bcdc
commit 3092f6c3f7
10 changed files with 54 additions and 9 deletions

View File

@ -0,0 +1,13 @@
Package: tensorPredictors
Type: Package
Title: Tensor/Matrix valued predictors for regression and dimension reduction
Version: 0.1
Date: 2021-10-28
Author: Daniel Kapla [aut]
Maintainer: Daniel Kapla <daniel@kapla.at>
Description: Multiple methods using tensor/matrix valued predictors for
regression or sufficient dimension reduction.
License: GPL-3
Depends:
Encoding: UTF-8
RoxygenNote: 7.1.1

View File

@ -0,0 +1,7 @@
# Generated by roxygen2: do not edit by hand
export(LSIR)
export(PCA2d)
export(POI)
export(approx.kronecker)
useDynLib(tensorPredictors, .registration = TRUE)

View File

@ -22,6 +22,7 @@
#'
#' @imports RSpectra
#'
#' @export
approx.kronecker <- function(C, dimA, dimB) {
dim(C) <- c(dimB[1L], dimA[1L], dimB[2L], dimA[2L])

View File

@ -1,5 +1,3 @@
source('../tensor_predictors/matpow.R')
#' Longitudinal Sliced Inverse Regression
#'
#' @param X matrix of dim \eqn{n \times p t} with each row representing a
@ -13,6 +11,7 @@ source('../tensor_predictors/matpow.R')
#'
#' TODO: finish
#'
#' @export
LSIR <- function(X, y, p, t, k = 1L, r = 1L) {
# the code assumes:
# alpha: T x r, beta: p x k, X_i: p x T, for ith observation

View File

@ -55,6 +55,7 @@
#' all.equal(B %*% A, t(B %*% A))
#' all.equal(A %*% B, t(A %*% B))
#'
#' @keywords internal
matpow <- function(A, pow, tol = 1e-7) {
if (nrow(A) != ncol(A)) {
stop("Expected a square matix, but 'A' is ", nrow(A), " by ", ncol(A))

View File

@ -22,6 +22,7 @@
#' c(d1, d2, d3) %<-% 1:10
#' extracting the first three valus from the vector of length 10.
#'
#' @keywords internal
"%<-%" <- function(lhs, rhs) {
var.names <- make.names(as.list(substitute(lhs))[-1])
values <- as.list(rhs)

View File

@ -1,4 +1,5 @@
#'2-Dimensional Principal Component Analysis
#'
#' @param X Matrix of dim (n, p * t) with each row the vectorized (p, t) observation.
#' @param p nr. predictors
#' @param t nr. timepoints
@ -7,7 +8,8 @@
#'
#' @details The `i`th observation is stored in a row such that its matrix equiv
#' is given by `matrix(X[i, ], p, t)`.
#'
#'
#' @export
PCA2d <- function(X, p, t, ppc, tpc, scale = FALSE) {
stopifnot(ncol(X) == p * t, ppc <= p, tpc <= t)

View File

@ -4,6 +4,8 @@
#'
#' @note use.C required 'poi.so' beeing dynamicaly loaded.
#' dyn.load('../tensor_predictors/poi.so')
#'
#' @export
POI <- function(A, B, d,
lambda = 0.75 * sqrt(max(rowSums(Delta^2))),
update.tol = 1e-3,
@ -33,7 +35,7 @@ POI <- function(A, B, d,
# The "inner" optimization loop, aka repeated coordinate optimization.
if (use.C) {
Z <- .Call('FastPOI_C_sub', A, B, Delta, lambda, as.integer(maxit.inner),
PACKAGE = 'poi')
PACKAGE = 'tensorPredictors')
} else {
p <- nrow(Z)
for (iter.inner in 1:maxit.inner) {

View File

@ -1,6 +1,13 @@
source('../tensor_predictors/matpow.R')
source('../tensor_predictors/multi_assign.R')
source('../tensor_predictors/approx_kronecker.R')
#' Tensor/Matrix valued Predictors for Regression and Dimension Reduction
#'
#' Multiple methods using tensor/matrix valued predictors for regression or
#' sufficient dimension reduction.
#'
#' @author Daniel Kapla
#'
#' @docType package
#' @useDynLib tensorPredictors, .registration = TRUE
"_PACKAGE"
log.likelihood <- function(par, X, Fy, Delta.inv, da, db) {
alpha <- matrix(par[1:prod(da)], da[1L])

View File

@ -3,7 +3,8 @@
#include <R.h>
#include <Rinternals.h>
SEXP FastPOI_C_sub(SEXP in_A, SEXP in_B, SEXP in_Delta, SEXP in_lambda, SEXP in_maxit) {
/* invoced by .Call */
extern SEXP FastPOI_C_sub(SEXP in_A, SEXP in_B, SEXP in_Delta, SEXP in_lambda, SEXP in_maxit) {
int i, j, k, g;
int p = nrows(in_Delta);
@ -72,3 +73,14 @@ SEXP FastPOI_C_sub(SEXP in_A, SEXP in_B, SEXP in_Delta, SEXP in_lambda, SEXP in_
UNPROTECT(1);
return out_Z;
}
static const R_CallMethodDef CallEntries[] = {
{"FastPOI_C_sub", (DL_FUNC) &FastPOI_C_sub, 5},
{NULL, NULL, 0}
};
/* Restrict C entry points to registered routines. */
void R_init_CVE(DllInfo *dll) {
R_registerRoutines(dll, NULL, CallEntries, NULL, NULL);
R_useDynamicSymbols(dll, FALSE);
}