diff --git a/NEWS.md b/NEWS.md index ae0fe16..c816bdf 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,4 +1,5 @@ # fdasrvf 2.0.2.900 +* exposed lam to curve functions # fdasrvf 2.0.2 diff --git a/R/curve_functions.R b/R/curve_functions.R index e906dd2..67f1001 100644 --- a/R/curve_functions.R +++ b/R/curve_functions.R @@ -224,7 +224,7 @@ find_rotation_seed_coord <- function(beta1, beta2, mode="O"){ } -find_rotation_seed_unqiue <- function(q1, q2, mode="O"){ +find_rotation_seed_unqiue <- function(q1, q2, mode="O", lam=0.0){ n1 = nrow(q1) T1 = ncol(q1) scl = 4 @@ -251,7 +251,7 @@ find_rotation_seed_unqiue <- function(q1, q2, mode="O"){ dim(q1i) = c(T1*n1) q2i = q2n dim(q2i) = c(T1*n1) - gam0 = .Call('DPQ', PACKAGE = 'fdasrvf', q1i, q2i, n1, T1, 0, 1, 0, rep(0,T1)) + gam0 = .Call('DPQ', PACKAGE = 'fdasrvf', q1i, q2i, n1, T1, lam, 1, 0, rep(0,T1)) gamI = invertGamma(gam0) gam = (gamI-gamI[1])/(gamI[length(gamI)]-gamI[1]) beta2n = q_to_curve(q2n) diff --git a/R/curve_karcher_mean.R b/R/curve_karcher_mean.R index 931eaa9..8c01c28 100644 --- a/R/curve_karcher_mean.R +++ b/R/curve_karcher_mean.R @@ -6,6 +6,7 @@ #' @param mode Open ("O") or Closed ("C") curves #' @param rotated Optimize over rotation (default = T) #' @param scale Include scale (default = F) +#' @param lambda A numeric value specifying the elasticity. Defaults to `0.0`. #' @param maxit maximum number of iterations #' @param ms string defining whether the Karcher mean ("mean") or Karcher median ("median") is returned (default = "mean") #' @return Returns a list containing \item{mu}{mean srvf} @@ -28,7 +29,8 @@ #' @examples #' out <- curve_karcher_mean(beta[, , 1, 1:2], maxit = 2) #' # note: use more shapes, small for speed -curve_karcher_mean <- function (beta, mode = "O", rotated = T, scale = F, maxit = 20, ms = "mean") +curve_karcher_mean <- function (beta, mode = "O", rotated = T, scale = F, + lambda = 0.0, maxit = 20, ms = "mean") { if(ms!="mean"&ms!="median"){warning("ms must be either \"mean\" or \"median\". ms has been set to \"mean\"",immediate. = T)} if(ms!="median"){ms = "mean"} @@ -75,7 +77,7 @@ curve_karcher_mean <- function (beta, mode = "O", rotated = T, scale = F, maxit cat("\nInitializing...\n") gam = matrix(0,T1,N) for (k in 1:N) { - out = find_rotation_seed_unqiue(mu,q[, , k],mode) + out = find_rotation_seed_unqiue(mu,q[, , k],mode,lambda) gam[,k] = out$gambest } @@ -96,7 +98,7 @@ curve_karcher_mean <- function (beta, mode = "O", rotated = T, scale = F, maxit for (i in 1:N) { q1 = q[, , i] - out = find_rotation_seed_unqiue(mu,q1,mode) + out = find_rotation_seed_unqiue(mu,q1,mode,lambda) qn_t = out$q2best/sqrt(innerprod_q2(out$q2best,out$q2best)) q1dotq2 = innerprod_q2(mu,qn_t) diff --git a/R/curve_srvf_align.R b/R/curve_srvf_align.R index 17e38b8..a1baac8 100644 --- a/R/curve_srvf_align.R +++ b/R/curve_srvf_align.R @@ -6,6 +6,7 @@ #' @param mode Open ("O") or Closed ("C") curves #' @param rotated Optimize over rotation (default = T) #' @param scale Include scale (default = F) +#' @param lambda A numeric value specifying the elasticity. Defaults to `0.0`. #' @param maxit maximum number of iterations #' @param ms string defining whether the Karcher mean ("mean") or Karcher median ("median") is returned (default = "mean") #' @return Returns a list containing \item{betan}{aligned curves} @@ -18,7 +19,8 @@ #' @examples #' data("mpeg7") #' out = curve_srvf_align(beta[,,1,1:2],maxit=2) # note: use more shapes, small for speed -curve_srvf_align <- function(beta, mode="O", rotated=T, scale = F, maxit=20, ms = "mean"){ +curve_srvf_align <- function(beta, mode="O", rotated=T, scale = F, lambda = 0.0, + maxit=20, ms = "mean"){ if (mode=="C"){ isclosed = TRUE } @@ -26,7 +28,7 @@ curve_srvf_align <- function(beta, mode="O", rotated=T, scale = F, maxit=20, ms n = tmp[1] T1 = tmp[2] N = tmp[3] - out = curve_karcher_mean(beta, mode, rotated, scale, maxit, ms) + out = curve_karcher_mean(beta, mode, rotated, scale, lambda, maxit, ms) beta<-out$beta mu = out$mu betamean = out$betamean @@ -35,16 +37,16 @@ curve_srvf_align <- function(beta, mode="O", rotated=T, scale = F, maxit=20, ms qn = array(0, c(n,T1,N)) betan = array(0, c(n,T1,N)) - rotmat = array(0, c(n,n,N)) - gams = matrix(0, T1, N) - + rotmat = array(0, c(n,n,N)) + gams = matrix(0, T1, N) + # align to mean for (ii in 1:N){ q1 = q[,,ii] beta1 = beta[,,ii] - out = find_rotation_seed_unqiue(mu,q1,mode) - gams[,ii] = out$gambest + out = find_rotation_seed_unqiue(mu,q1,mode,lambda) + gams[,ii] = out$gambest beta1 = out$Rbest%*%beta1 beta1n = group_action_by_gamma_coord(beta1, out$gambest) q1n = curve_to_q(beta1n)$q @@ -52,7 +54,7 @@ curve_srvf_align <- function(beta, mode="O", rotated=T, scale = F, maxit=20, ms out = find_best_rotation(mu, q1n) qn[,,ii] = out$q2new betan[,,ii] = out$R%*%beta1n - rotmat[,,ii] = out$R + rotmat[,,ii] = out$R } return(list(betan=betan, qn=qn, betamean=betamean, q_mu=mu, rotmat = rotmat,gams = gams,v=v)) } diff --git a/man/curve_karcher_mean.Rd b/man/curve_karcher_mean.Rd index 063eea2..76157c7 100644 --- a/man/curve_karcher_mean.Rd +++ b/man/curve_karcher_mean.Rd @@ -9,6 +9,7 @@ curve_karcher_mean( mode = "O", rotated = T, scale = F, + lambda = 0, maxit = 20, ms = "mean" ) @@ -22,6 +23,8 @@ curve_karcher_mean( \item{scale}{Include scale (default = F)} +\item{lambda}{A numeric value specifying the elasticity. Defaults to \code{0.0}.} + \item{maxit}{maximum number of iterations} \item{ms}{string defining whether the Karcher mean ("mean") or Karcher median ("median") is returned (default = "mean")} diff --git a/man/curve_srvf_align.Rd b/man/curve_srvf_align.Rd index 3d86c79..9c0b9ce 100644 --- a/man/curve_srvf_align.Rd +++ b/man/curve_srvf_align.Rd @@ -9,6 +9,7 @@ curve_srvf_align( mode = "O", rotated = T, scale = F, + lambda = 0, maxit = 20, ms = "mean" ) @@ -22,6 +23,8 @@ curve_srvf_align( \item{scale}{Include scale (default = F)} +\item{lambda}{A numeric value specifying the elasticity. Defaults to \code{0.0}.} + \item{maxit}{maximum number of iterations} \item{ms}{string defining whether the Karcher mean ("mean") or Karcher median ("median") is returned (default = "mean")}