Create a gist now

Instantly share code, notes, and snippets.

#' Find zero crossings in an fd object
#'
#' @import fda
#' @import magrittr
#'
#' @param fd an fd object
#' @param Lfdobj the derivative (0, 1, 2)
#' @param slope The slope of interest at the zero crossing
#' @param eps The prediction granularity
#' @param min Localize the zero crossing search to be greater than min
#' @param max Localize the zero crossing search to be less than max
#'
zero_crossings <- function(fd, Lfdobj = 0, slope = 1, eps = 1e-3,
min = NULL, max = NULL){
xrange <- fd$basis$rangeval
if(is.null(min)){
min = xrange[1]
}
if(is.null(max)){
max = xrange[2]
}
x <- seq(min, max, by = eps)
y <- predict(fd, Lfdobj = Lfdobj, newdata = x, returnMatrix = T)
y_up <- matrix(y[-dim(y)[1],], ncol = ncol(y))
y_down <- matrix(y[-1,], ncol = ncol(y))
zero_cross <- sign(y_up) != sign(y_down)
positive_slopes <- sign(y_up) < 1
negative_slopes <- sign(y_up) > -1
if(slope == 1){
out_idx <- apply(zero_cross & positive_slopes, MARGIN = 2, FUN = which) %>%
lapply(., FUN = function(x){if(length(x)<1){
return(NA)
}else{
return(x[1])}})%>%
unlist()
}else{
out_idx <- apply(zero_cross & negative_slopes, MARGIN = 2, FUN = which) %>%
lapply(., FUN = function(x){if(length(x)<1){
return(NA)
}else{
return(x[1])}})%>%
unlist()
}
out <- x[out_idx]
return(out)
}
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment