wip: convert to R-package
This commit is contained in:
parent
14d8a9bcdc
commit
3092f6c3f7
|
@ -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
|
|
@ -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)
|
|
@ -22,6 +22,7 @@
|
||||||
#'
|
#'
|
||||||
#' @imports RSpectra
|
#' @imports RSpectra
|
||||||
#'
|
#'
|
||||||
|
#' @export
|
||||||
approx.kronecker <- function(C, dimA, dimB) {
|
approx.kronecker <- function(C, dimA, dimB) {
|
||||||
|
|
||||||
dim(C) <- c(dimB[1L], dimA[1L], dimB[2L], dimA[2L])
|
dim(C) <- c(dimB[1L], dimA[1L], dimB[2L], dimA[2L])
|
||||||
|
|
|
@ -1,5 +1,3 @@
|
||||||
source('../tensor_predictors/matpow.R')
|
|
||||||
|
|
||||||
#' Longitudinal Sliced Inverse Regression
|
#' Longitudinal Sliced Inverse Regression
|
||||||
#'
|
#'
|
||||||
#' @param X matrix of dim \eqn{n \times p t} with each row representing a
|
#' @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
|
#' TODO: finish
|
||||||
#'
|
#'
|
||||||
|
#' @export
|
||||||
LSIR <- function(X, y, p, t, k = 1L, r = 1L) {
|
LSIR <- function(X, y, p, t, k = 1L, r = 1L) {
|
||||||
# the code assumes:
|
# the code assumes:
|
||||||
# alpha: T x r, beta: p x k, X_i: p x T, for ith observation
|
# alpha: T x r, beta: p x k, X_i: p x T, for ith observation
|
||||||
|
|
|
@ -55,6 +55,7 @@
|
||||||
#' 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
|
||||||
matpow <- function(A, pow, tol = 1e-7) {
|
matpow <- function(A, pow, tol = 1e-7) {
|
||||||
if (nrow(A) != ncol(A)) {
|
if (nrow(A) != ncol(A)) {
|
||||||
stop("Expected a square matix, but 'A' is ", nrow(A), " by ", ncol(A))
|
stop("Expected a square matix, but 'A' is ", nrow(A), " by ", ncol(A))
|
||||||
|
|
|
@ -22,6 +22,7 @@
|
||||||
#' 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
|
||||||
"%<-%" <- function(lhs, rhs) {
|
"%<-%" <- function(lhs, rhs) {
|
||||||
var.names <- make.names(as.list(substitute(lhs))[-1])
|
var.names <- make.names(as.list(substitute(lhs))[-1])
|
||||||
values <- as.list(rhs)
|
values <- as.list(rhs)
|
||||||
|
|
|
@ -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 X Matrix of dim (n, p * t) with each row the vectorized (p, t) observation.
|
||||||
#' @param p nr. predictors
|
#' @param p nr. predictors
|
||||||
#' @param t nr. timepoints
|
#' @param t nr. timepoints
|
||||||
|
@ -8,6 +9,7 @@
|
||||||
#' @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)`.
|
||||||
#'
|
#'
|
||||||
|
#' @export
|
||||||
PCA2d <- function(X, p, t, ppc, tpc, scale = FALSE) {
|
PCA2d <- function(X, p, t, ppc, tpc, scale = FALSE) {
|
||||||
stopifnot(ncol(X) == p * t, ppc <= p, tpc <= t)
|
stopifnot(ncol(X) == p * t, ppc <= p, tpc <= t)
|
||||||
|
|
||||||
|
|
|
@ -4,6 +4,8 @@
|
||||||
#'
|
#'
|
||||||
#' @note use.C required 'poi.so' beeing dynamicaly loaded.
|
#' @note use.C required 'poi.so' beeing dynamicaly loaded.
|
||||||
#' dyn.load('../tensor_predictors/poi.so')
|
#' dyn.load('../tensor_predictors/poi.so')
|
||||||
|
#'
|
||||||
|
#' @export
|
||||||
POI <- function(A, B, d,
|
POI <- function(A, B, d,
|
||||||
lambda = 0.75 * sqrt(max(rowSums(Delta^2))),
|
lambda = 0.75 * sqrt(max(rowSums(Delta^2))),
|
||||||
update.tol = 1e-3,
|
update.tol = 1e-3,
|
||||||
|
@ -33,7 +35,7 @@ POI <- function(A, B, d,
|
||||||
# The "inner" optimization loop, aka repeated coordinate optimization.
|
# The "inner" optimization loop, aka repeated coordinate optimization.
|
||||||
if (use.C) {
|
if (use.C) {
|
||||||
Z <- .Call('FastPOI_C_sub', A, B, Delta, lambda, as.integer(maxit.inner),
|
Z <- .Call('FastPOI_C_sub', A, B, Delta, lambda, as.integer(maxit.inner),
|
||||||
PACKAGE = 'poi')
|
PACKAGE = 'tensorPredictors')
|
||||||
} else {
|
} else {
|
||||||
p <- nrow(Z)
|
p <- nrow(Z)
|
||||||
for (iter.inner in 1:maxit.inner) {
|
for (iter.inner in 1:maxit.inner) {
|
||||||
|
|
|
@ -1,6 +1,13 @@
|
||||||
source('../tensor_predictors/matpow.R')
|
#' Tensor/Matrix valued Predictors for Regression and Dimension Reduction
|
||||||
source('../tensor_predictors/multi_assign.R')
|
#'
|
||||||
source('../tensor_predictors/approx_kronecker.R')
|
#' 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) {
|
log.likelihood <- function(par, X, Fy, Delta.inv, da, db) {
|
||||||
alpha <- matrix(par[1:prod(da)], da[1L])
|
alpha <- matrix(par[1:prod(da)], da[1L])
|
||||||
|
|
|
@ -3,7 +3,8 @@
|
||||||
#include <R.h>
|
#include <R.h>
|
||||||
#include <Rinternals.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 i, j, k, g;
|
||||||
|
|
||||||
int p = nrows(in_Delta);
|
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);
|
UNPROTECT(1);
|
||||||
return out_Z;
|
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);
|
||||||
|
}
|
||||||
|
|
Loading…
Reference in New Issue