Merge pull request #55 from astamm/karcher_mean

NAMESPACE

@@ -51,11 +51,13 @@ export(function_group_warp_bayes)
 export(gam_to_h)
 export(gam_to_v)
 export(gauss_model)
+export(get_curve_centroid)
 export(get_distance_matrix)
 export(get_hilbert_sphere_distance)
 export(get_identity_warping)
 export(get_l2_distance)
 export(get_l2_inner_product)
+export(get_l2_norm)
 export(get_shape_distance)
 export(get_warping_distance)
 export(gradient)
@@ -100,4 +102,4 @@ importFrom(coda,effectiveSize)
 importFrom(foreach,"%dopar%")
 importFrom(graphics,boxplot)
 importFrom(graphics,plot)
-useDynLib(fdasrvf, .registration=TRUE)
+useDynLib(fdasrvf, .registration = TRUE)

R/RcppExports.R

@@ -0,0 +1,59 @@
+# Generated by using Rcpp::compileAttributes() -> do not edit by hand
+# Generator token: 10BE3573-1514-4C36-9D1C-5A225CD40393
+
+dpcode <- function(q1, q1L, q2L, times, cut) {
+    .Call(`_fdasrvf_dpcode`, q1, q1L, q2L, times, cut)
+}
+
+simucode <- function(iter, p, qt1_5, qt2_5, L, tau, times, kappa, alpha, beta, powera, dist, dist_min, best_match, match, thin, cut) {
+    .Call(`_fdasrvf_simucode`, iter, p, qt1_5, qt2_5, L, tau, times, kappa, alpha, beta, powera, dist, dist_min, best_match, match, thin, cut)
+}
+
+itercode <- function(iter, n, m, mu_5, match_matrix, qt_matrix, qt_fitted_matrix, L, tau, times, kappa, alpha, beta, powera, best_vec, dist_vec, best_match_matrix, mu_prior, var_const, sumdist, thin, mu_q, mu_q_standard, logmax, burnin, AVG) {
+    .Call(`_fdasrvf_itercode`, iter, n, m, mu_5, match_matrix, qt_matrix, qt_fitted_matrix, L, tau, times, kappa, alpha, beta, powera, best_vec, dist_vec, best_match_matrix, mu_prior, var_const, sumdist, thin, mu_q, mu_q_standard, logmax, burnin, AVG)
+}
+
+calcY <- function(area, gy) {
+    .Call(`_fdasrvf_calcY`, area, gy)
+}
+
+cuL2norm2 <- function(x, y) {
+    .Call(`_fdasrvf_cuL2norm2`, x, y)
+}
+
+trapzCpp <- function(x, y) {
+    .Call(`_fdasrvf_trapzCpp`, x, y)
+}
+
+order_l2norm <- function(x, y) {
+    .Call(`_fdasrvf_order_l2norm`, x, y)
+}
+
+find_grad_2D <- function(dfdu, dfdv, f, n, t, d) {
+    .Call(`_fdasrvf_find_grad_2D`, dfdu, dfdv, f, n, t, d)
+}
+
+check_cross <- function(f, n, t, D) {
+    .Call(`_fdasrvf_check_cross`, f, n, t, D)
+}
+
+find_phistar <- function(w, q, b, n, t, d, K) {
+    .Call(`_fdasrvf_find_phistar`, w, q, b, n, t, d, K)
+}
+
+mlogit_warp_grad_wrap <- function(m1, m2, alpha, beta, ti, gami, q, y, max_itri, toli, deltai, displayi) {
+    .Call(`_fdasrvf_mlogit_warp_grad_wrap`, m1, m2, alpha, beta, ti, gami, q, y, max_itri, toli, deltai, displayi)
+}
+
+DPQ2 <- function(Q1, T1, Q2, T2, m1, n1, n2, tv1, tv2, n1v, n2v, lam1, nbhd_dim) {
+    .Call(`_fdasrvf_DPQ2`, Q1, T1, Q2, T2, m1, n1, n2, tv1, tv2, n1v, n2v, lam1, nbhd_dim)
+}
+
+DPQ <- function(Q1, Q2, n1, N1, lam1, pen1, Disp) {
+    .Call(`_fdasrvf_DPQ`, Q1, Q2, n1, N1, lam1, pen1, Disp)
+}
+
+rlbfgs <- function(q1, q2, time, maxiter, lam, penalty) {
+    .Call(`_fdasrvf_rlbfgs`, q1, q2, time, maxiter, lam, penalty)
+}
+

R/curve_functions.R

@@ -197,8 +197,7 @@ find_rotation_seed_coord <- function(beta1, beta2,
       }
       dim(q1i) <- M * L
       dim(q2ni) <- M * L
-      gam0 <- .Call('DPQ', PACKAGE = 'fdasrvf', q1i, q2ni,
-                    L, M, lambda, 1, 0, rep(0, M))
+      gam0 <- DPQ(q1i, q2ni, L, M, lambda, 1, 0)
       gamI <- invertGamma(gam0)
       gam <- (gamI - gamI[1]) / (gamI[length(gamI)] - gamI[1])
       beta2new <- group_action_by_gamma_coord(beta2n, gam)
@@ -254,9 +253,6 @@ find_rotation_seed_unique <- function(q1, q2,
   # Variables for DPQ2 algorithm
   grd <- seq(0, 1, length.out = M)
   nbhd_dim <- 7L
-  Gvec <- rep(0, M)
-  Tvec <- rep(0, M)
-  size <- 0
 
   scl <- 4
   minE <- Inf
@@ -290,11 +286,7 @@ find_rotation_seed_unique <- function(q1, q2,
       dim(q1i) <- M * L
       dim(q2ni) <- M * L
 
-      ret <- .Call(
-        "DPQ2", PACKAGE = "fdasrvf",
-        q1i, grd, q2ni, grd, L, M, M, grd, grd, M,
-        M, Gvec, Tvec, size, lambda, nbhd_dim
-      )
+      ret <- DPQ2(q1i, grd, q2ni, grd, L, M, M, grd, grd, M, M, lambda, nbhd_dim)
       Gvec <- ret$G[1:ret$size]
       Tvec <- ret$T[1:ret$size]
       gamI <- stats::approx(Tvec, Gvec, xout = grd)$y

R/fdasrvf-package.R

@@ -56,7 +56,7 @@
 #'   Detection of Climate Impacts from Localized Sources”, Envirometrics,
 #'   10.1002/env.2826, 2023.
 #'
-#' @useDynLib fdasrvf, .registration=TRUE
+#' @useDynLib fdasrvf, .registration = TRUE
 #' @importFrom Rcpp sourceCpp
 #' @importFrom foreach %dopar%
 #' @aliases fdasrvf fdasrvf-package

R/image_funcs.R

@@ -135,7 +135,7 @@ compgrad2D <- function(f){
         dfdv = array(0,dim=dim(f))
     }
 
-    out = .Call('find_grad_2D', PACKAGE = 'fdasrvf', dfdu, dfdv, f, n, t, d)
+    out <- find_grad_2D(dfdu, dfdv, f, n, t, d)
 
     return(list(dfdu=out$dfdu,dfdv=out$dfdv))
 }
@@ -269,7 +269,7 @@ findphistar <- function(q, b){
 
     w = array(0,dim=c(n,t,d,K))
 
-    out = .Call('find_phistar', PACKAGE = 'fdasrvf', w, q, b, n, t, d, K)
+    out <- find_phistar(w, q, b, n, t, d, K)
 
     return (out)
 }
@@ -300,7 +300,7 @@ check_crossing <- function(f) {
     if (D!=2)
         stop("Third dimension of first argument to be 2")
 
-    diffeo = .Call('check_cross', PACKAGE = 'fdasrvf', f, n, t, D)
+    diffeo <- check_cross(f, n, t, D)
 
     if (diffeo == 0)
         is_diffeo = F

R/optimum.reparam.R

@@ -79,22 +79,14 @@ optimum.reparam <- function(Q1,T1,Q2,T2,
   switch(
     method,
     DP = {
-      G <- rep(0, M)
-      T <- rep(0, M)
-      size <- 0
-      ret <- .Call(
-        "DPQ2", PACKAGE = "fdasrvf",
-        Q1, T1, Q2, T2, L, M, M, T1, T2, M, M, G, T, size, lambda, nbhd_dim
-      )
+      ret <- DPQ2(Q1, T1, Q2, T2, L, M, M, T1, T2, M, M, lambda,
+                  nbhd_dim)
       G <- ret$G[1:ret$size]
       Tf <- ret$T[1:ret$size]
       gam0 <- stats::approx(Tf, G, xout = T2)$y
     },
     DPo = {
-      gam0 <- .Call(
-        "DPQ", PACKAGE = "fdasrvf",
-        Q2, Q1, L, M, lambda, pen, 0, rep(0, M)
-      )
+      gam0 <- DPQ(Q2, Q1, L, M, lambda, pen, 0)
     },
     SIMUL = {
       if (lambda > 0)
@@ -109,7 +101,7 @@ optimum.reparam <- function(Q1,T1,Q2,T2,
     },
     RBFGS = {
       time1 <- seq(0, 1, length.out=length(Q1))
-      gam0 <- .Call("_fdasrvf_rlbfgs_optim", PACKAGE = "fdasrvf", Q1, Q2, time1, 30, lambda, pen-1)
+      gam0 <- rlbfgs(Q1, Q2, time1, 30, lambda, pen - 1)
       gam0 <- c(gam0)
     }
   )