Nothing
#' Helper functions for curve data measured at discrete points
#' @name get_srv_from_points
#' @aliases get_arc_length_param
#' @aliases get_points_from_srv
#' @description Compute the square-root-velocity transformation or the
#' parametrization with respect to arc length for a curve
#' observed at discrete points.
#' @param data_curve A \code{data.frame} with observed points on a curve.
#' Each row is one point, each variable one coordinate direction. If there is a variable \code{t},
#' it is treated as the time parametrization, not as an additional coordinate.
#' @param srv_data A \code{data.frame} with
#' first column \code{t} corresponding to the parametrization and square-root-velocity
#' vectors in the remaining columns.
#' @examples
#' data_curve1 <- data.frame(x1 = 1:6*sin(1:6), x2 = cos(1:6))
#' get_arc_length_param(data_curve1) #same parametrization as in
#' get_srv_from_points(data_curve1)
#'
#' data_curve2 <- data.frame(t = seq(0,1, length = 6), data_curve1)
#' plot(data_curve2[,2:3], type = "l", xlim = c(-6, 2), ylim = c(-2, 1))
#' srv_data <- get_srv_from_points(data_curve2)
#' #back transformed curve starts at (0,0)
#' lines(get_points_from_srv(srv_data), col = "red")
NULL
#' @describeIn get_srv_from_points Compute square-root-velocity transformation
#' for curve data measured at discrete points. The inverse transformation can
#' be computed with \code{get_points_from_s}
#' @export
#' @return \code{get_srv_from_points} returns a \code{data.frame} with
#' first column \code{t} corresponding to the parametrization and square-root-velocity
#' vectors in the remaining columns. If no parametrization is given, the curve will
#' be parametrized with respect to arc length. This parametrization will be
#' computed by a call to \code{get_arc_length_param} as well.
get_srv_from_points <- function(data_curve){
# parametrization with respect to arg length if not given
if(!("t" %in% colnames(data_curve))){
data_curve <- data.frame("t" = get_arc_length_param(data_curve), data_curve)
}
#input checking of parametrization
if(!(data_curve$t[1] == 0 & data_curve$t[nrow(data_curve)] == 1))
stop("Parametrisation must be starting at 0 and ending at 1")
if(!all(diff(data_curve$t) > 0))
stop("Parametrisation needs to be strictly increasing")
data_points <- as.matrix(data_curve[, names(data_curve) != "t"])
diff_points <- diff(data_points)
factor <- 1/(sqrt(diff(data_curve$t))*rowSums(diff_points^2)^0.25)
factor <- ifelse(is.finite(factor), factor, 0)
srv_vectors <- factor*diff_points
srv_data <- data.frame("t" = data_curve$t[-nrow(data_curve)], srv_vectors)
srv_data
}
#' @export
#' @describeIn get_srv_from_points The inverse transformation to
#' \code{get_srv_from_points}. Transforms square-root-velocity data to
#' points representing a curve (with no parametrization).
get_points_from_srv <- function(srv_data){
# extract srv vectors
srv_vectors <- as.matrix(srv_data[, names(srv_data) != "t"])
# extract parametrization
t <- c(srv_data$t, 1)
norm <- sqrt(apply(srv_vectors^2, 1, sum))
v <- apply(srv_vectors, 2, function(x) x*norm)
path <- apply(v, 2, function(x) c(0, x*diff(t)))
points <- rbind(apply(path, 2, cumsum))
data.frame(points)
}
#' @export
#' @describeIn get_srv_from_points Compute arc length parametrization.
get_arc_length_param <- function(data_curve){
# remove given parametrization if it exists
try(data_curve <- data_curve[,-t], silent = TRUE)
t_arc_length <- c(0, cumsum(sqrt(rowSums(apply(t(data_curve), 1, diff) ^ 2))))
t_arc_length <- t_arc_length/max(t_arc_length)
t_arc_length
}
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.