Update ecx

DESCRIPTION

@@ -10,7 +10,7 @@ Depends:
 License: GPL-2
 Encoding: UTF-8
 LazyData: true
-RoxygenNote: 7.2.3
+RoxygenNote: 7.3.1
 Biarch: true
 Imports:
     formula.tools,
@@ -21,6 +21,7 @@ Imports:
     tibble,
     tidyselect,
     evaluate,
+    modelbased,
     rlang,
     chk (>= 0.7.0)
 Suggests:

NAMESPACE

@@ -145,6 +145,7 @@ importFrom(graphics,mtext)
 importFrom(graphics,par)
 importFrom(graphics,plot)
 importFrom(loo,loo_model_weights)
+importFrom(modelbased,zero_crossings)
 importFrom(purrr,map)
 importFrom(purrr,map_dfr)
 importFrom(rlang,.data)

R/check_priors.R

@@ -6,6 +6,8 @@
 #' @param filename An optional \code{\link[base]{character}} vector to be used
 #' as a pdf filename in the case of a \code{\link{bayesmanecfit}}. Any non
 #' empty character string will indicate the user wants to save the plots.
+#' @param ask Should the user be asked to hit enter for next page for a 
+#' \code{\link{bayesmanecfit}} object?
 #'
 #' @seealso \code{\link{bnec}}
 #'
@@ -19,7 +21,7 @@
 #' }
 #'
 #' @export
-check_priors <- function(object, filename = NA) {
+check_priors <- function(object, filename = NA, ask = ask) {
   UseMethod("check_priors")
 }
 
@@ -41,7 +43,7 @@ check_priors <- function(object, filename = NA) {
 #' @noRd
 #'
 #' @export
-check_priors.bayesnecfit <- function(object, filename = NA) {
+check_priors.bayesnecfit <- function(object, filename = NA, ask = ask) {
   if (!is.na(filename)) {
     chk_character(filename)
   }
@@ -80,15 +82,15 @@ check_priors.bayesnecfit <- function(object, filename = NA) {
 #' @noRd
 #'
 #' @export
-check_priors.bayesmanecfit <- function(object, filename = NA) {
+check_priors.bayesmanecfit <- function(object, filename = NA, ask = TRUE) {
   if (!is.na(filename)) {
     chk_character(filename)
   }
   if (!is.na(filename)) {
     pdf(file = paste(filename, ".pdf", sep = ""), onefile = TRUE,
         width = 12, height = 4)
   } else {
-    devAskNewPage(ask = TRUE)
+    devAskNewPage(ask = ask)
   }
   for (m in seq_len(length(object$mod_fits))) {
     out_plot <- check_priors(object = pull_out(object, model = names(object$mod_fits)[m])) +

R/ecx.R

@@ -260,37 +260,71 @@ ecx.bayesmanecfit <- function(object, ecx_val = 10, resolution = 1000,
   }
 }
 
+#' @importFrom modelbased zero_crossings
+#' 
 #' @noRd
 ecx_x_relative <- function(y, ecx_val, x_vec) {
   if (length(which(!is.na(y))) == 0) {
     outval <- max(x_vec)
   } else {
     range_y <- range(y, na.rm = TRUE)
     ecx_y <- max(range_y) - diff(range_y) * (ecx_val / 100)
-    outval <- x_vec[min_abs(y - ecx_y)]
+
+    val <- min(zero_crossings(y - ecx_y))
+    if(is.na(val)) {
+      outval <- max(x_vec)
+    } else {
+      floor_x <-  x_vec[floor(val)] 
+      ceiling_x <- x_vec[ceiling(val)]
+      prop_x <- (val-floor(val))*(ceiling_x-floor_x)
+      outval <- floor_x + prop_x
+    }
   }
   outval
 }
 
+#' @importFrom modelbased zero_crossings
+#' 
 #' @noRd
 ecx_x_absolute <- function(y, ecx_val, x_vec) {
   if (length(which(!is.na(y))) == 0) {
     outval <- max(x_vec)
   } else {
     range_y <- c(0, max(y, na.rm = TRUE))
     ecx_y <- max(range_y) - diff(range_y) * (ecx_val / 100)
-    outval <- x_vec[min_abs(y - ecx_y)]
+
+    val <- min(zero_crossings(y - ecx_y))
+    if(is.na(val)) {
+      outval <- max(x_vec)
+    } else {
+      floor_x <-  x_vec[floor(val)] 
+      ceiling_x <- x_vec[ceiling(val)]
+      prop_x <- (val-floor(val))*(ceiling_x-floor_x)
+      outval <- floor_x + prop_x
+    }
   }
   outval
 }
 
+#' @importFrom modelbased zero_crossings
+#' 
 #' @noRd
 ecx_x_direct <- function(y, ecx_val, x_vec) {
   if (length(which(!is.na(y))) == 0) {
     outval <- max(x_vec)
   } else {
     ecx_y <- ecx_val
-    outval <- x_vec[min_abs(y - ecx_y)]
+
+    val <- min(zero_crossings(y - ecx_y))
+    if(is.na(val)) {
+      outval <- max(x_vec)
+    } else {
+      floor_x <-  x_vec[floor(val)] 
+      ceiling_x <- x_vec[ceiling(val)]
+      prop_x <- (val-floor(val))*(ceiling_x-floor_x)
+      outval <- floor_x + prop_x
+    }
   }
   outval
 }
+

R/nsec.R

@@ -217,9 +217,18 @@ nsec.bayesmanecfit <- function(object, sig_val = 0.01, resolution = 1000,
   }
 }
 
+#' @importFrom modelbased zero_crossings
+#' 
 #' @noRd
 nsec_fct <- function(y, reference, x_vec) {
-  x_vec[min_abs(y - reference)]
+  val <- min(zero_crossings(y - reference))
+  if(is.na(val)) {
+    return(max(x_vec))} else {
+      floor_x <-  x_vec[floor(val)] 
+      ceiling_x <- x_vec[ceiling(val)]
+      prop_x <- (val-floor(val))*(ceiling_x-floor_x)
+      return(floor_x + prop_x)
+    }
 }
 
 #' @inheritParams nsec