Merge branch 'main' of https://github.com/LinkedEarth/actR

LinkedEarth · May 14, 2024 · 90fb33b · 90fb33b
2 parents 2ef47f3 + 37fa4e4
commit 90fb33b
Show file tree

Hide file tree

Showing 12 changed files with 194 additions and 34 deletions.
diff --git a/NAMESPACE b/NAMESPACE
@@ -1,5 +1,8 @@
 # Generated by roxygen2: do not edit by hand
 
+S3method(View,default)
+S3method(View,excursion)
+S3method(View,shift)
 S3method(plot,excursion)
 S3method(plot,excursionCore)
 S3method(plot,shift)
@@ -43,6 +46,7 @@ export(summaryExcursion)
 export(summaryShift)
 export(surrogateDataFun)
 export(testNullHypothesis)
+export(viewSafely)
 import(RColorBrewer)
 import(dplyr)
 import(egg)

diff --git a/R/meanShift.R b/R/meanShift.R
@@ -68,6 +68,7 @@ detectShiftCore = function(time,
   }
 
   #calculate differences in stats before and after.
+  delta.mean <- delta.sd <- NA
 
   if(calc.deltas){
 
@@ -92,8 +93,6 @@ detectShiftCore = function(time,
       }
 
     }
-  }else{
-    delta.mean <- delta.sd <- NA
   }
 
   # create a hash for each unique time-value pair
@@ -184,13 +183,23 @@ detectShift <- function(ltt = NA,
   #ensemble with uncertainties
   propagated <- propagateUncertainty(time,vals,changeFun = detectShiftCore, calc.deltas = calc.deltas, ...)
 
+  if(!is.character(time.units)){
+    time.units <- geoChronR::heuristicUnits(time)
+  }
+
+  if(time.units %in% c("AD","CE")){
+    time.dir <- "prograde"
+  }else{
+    time.dir <- "retrograde"
+  }
 
 
   propSummary <- summarizeEventProbability(propagated,
                                            bin.step = summary.bin.step,
                                            bin.vec = summary.bin.vec,
                                            min.time = min(time, na.rm = T),
-                                           max.time = max(time, na.rm = T))
+                                           max.time = max(time, na.rm = T),
+                                           time.dir = time.dir)
 
 
   #null hypothesis
@@ -213,7 +222,7 @@ detectShift <- function(ltt = NA,
   }
 
   #get a matrix of nulls
-  dsout<-propSummary
+  dsout <- propSummary
   for (direction in c('','_either','_positive','_negative','_both')){
     nhMat <- purrr::map(nh,
                         summarizeEventProbability,
@@ -270,22 +279,24 @@ detectShift <- function(ltt = NA,
   eventSummary$surrogate.method <- surrogate.method
   eventSummary$summary.bin.step <- median(propSummary$time_mid)
 
-  # out <- list(shiftDetection = dsout,
-  #             parameters = propagated$parameters,
-  #             summary.bin.step = summary.bin.step,
-  #             surrogate.method = surrogate.method,
-  #             unc.prop.n = n.ens,
-  #             null.hypothesis.n = null.hypothesis.n,
-  #             timeEns = timeEns,
-  #             valEns = valEns,
-  #             time.ens.supplied.n = time.ens.supplied.n,
-  #             vals.ens.supplied.n = vals.ens.supplied.n,
-  #             input = prepped) %>%
-  #   new_shift()
-
-  eventSummary<- structure(eventSummary,class = c("excursionCore",class(tibble::tibble())))
-
-  return(eventSummary)
+  out <- eventSummary |>
+    new_shift()
+
+  # old output
+  #. list(shiftDetection = dsout,
+  #      parameters = propagated$parameters,
+  #      summary.bin.step = summary.bin.step,
+  #      surrogate.method = surrogate.method,
+  #      unc.prop.n = n.ens,
+  #      null.hypothesis.n = null.hypothesis.n,
+  #      timeEns = timeEns,
+  #      valEns = valEns,
+  #      time.ens.supplied.n = time.ens.supplied.n,
+  #      vals.ens.supplied.n = vals.ens.supplied.n,
+  #      input = prepped)
+  #eventSummary<- structure(eventSummary,class = c("excursionCore",class(tibble::tibble())))
+
+  return(out)
 
 
 }

diff --git a/R/s3.R b/R/s3.R
@@ -11,9 +11,9 @@ new_excursionCore <- function(x = tibble::tibble()) {
 }
 
 new_shift <- function(x = list()) {
-  stopifnot(is.list(x))
+  stopifnot(tibble::is_tibble(x))
 
-  structure(x,class = c("shift",class(list())))
+  structure(x,class = c("shift",class(tibble::tibble())))
 }
 
 new_shiftCore <- function(x = tibble::tibble()) {

diff --git a/R/summarize.R b/R/summarize.R
@@ -63,7 +63,8 @@ summarizeEventProbability <- function(exc.out,
                                       bin.step = 10,
                                       max.time = NA,
                                       min.time = NA,
-                                      shift.type = "either"
+                                      shift.type = "either",
+                                      time.dir = "retrograde"
                                       ){
   if(is.na(min.time)){
     min.time <- purrr::map_dbl(exc.out$time,min,na.rm=T) %>% median(na.rm = TRUE)
@@ -86,14 +87,35 @@ summarizeEventProbability <- function(exc.out,
     dplyr::mutate(time_mid = (time_start + time_end)/2)
 
 
-  eventSumsEither   <- eventsInWindow(na.omit(good.exc$time_mid),                         start.vec = timeBins[-length(timeBins)],end.vec = timeBins[-1])
-  if(grepl("cpt.var",exc.out$parameters[[1]])){
-    eventSumsPositive <- eventsInWindow(na.omit((good.exc%>%filter(delta_sd<0))$time_mid),start.vec = timeBins[-length(timeBins)],end.vec = timeBins[-1])
-    eventSumsNegative <- eventsInWindow(na.omit((good.exc%>%filter(delta_sd>0))$time_mid),start.vec = timeBins[-length(timeBins)],end.vec = timeBins[-1])
-  }else{
-    eventSumsPositive <- eventsInWindow(na.omit((good.exc%>%filter(delta_mean<0))$time_mid),start.vec = timeBins[-length(timeBins)],end.vec = timeBins[-1])
-    eventSumsNegative <- eventsInWindow(na.omit((good.exc%>%filter(delta_mean>0))$time_mid),start.vec = timeBins[-length(timeBins)],end.vec = timeBins[-1])
+  eventSumsEither   <- eventsInWindow(na.omit(good.exc$time_mid),
+                                      start.vec = timeBins[-length(timeBins)],end.vec = timeBins[-1])
+
+  is.cpt.var <- grepl("cpt.var",exc.out$parameters[[1]])
+
+
+  if(time.dir == "retrograde" & is.cpt.var){
+    filtPos <- dplyr::filter(good.exc,delta_sd < 0)
+  }else if(time.dir == "prograde" & is.cpt.var){
+    filtPos <- dplyr::filter(good.exc,delta_sd >= 0)
+  }else if(time.dir == "retrograde" & !is.cpt.var){
+    filtPos <- dplyr::filter(good.exc,delta_mean < 0)
+  }else if(time.dir == "prograde" & !is.cpt.var){
+    filtPos <-dplyr::filter(good.exc,delta_mean >= 0)
   }
+
+  if(time.dir == "retrograde" & is.cpt.var){
+    filtNeg <- dplyr::filter(good.exc,delta_sd >= 0)
+  }else if(time.dir == "prograde" & is.cpt.var){
+    filtNeg <- dplyr::filter(good.exc,delta_sd < 0)
+  }else if(time.dir == "retrograde" & !is.cpt.var){
+    filtNeg <- dplyr::filter(good.exc,delta_mean >= 0)
+  }else if(time.dir == "prograde" & !is.cpt.var){
+    filtNeg <-dplyr::filter(good.exc,delta_mean < 0)
+  }
+
+
+  eventSumsPositive <- eventsInWindow(na.omit(filtPos$time_mid),start.vec = timeBins[-length(timeBins)],end.vec = timeBins[-1])
+  eventSumsNegative <- eventsInWindow(na.omit(filtNeg$time_mid),start.vec = timeBins[-length(timeBins)],end.vec = timeBins[-1])
   eventSumsBoth     <- apply(matrix(c(eventSumsPositive,eventSumsNegative),length(eventSumsNegative)),1,min)
 
   #now pick the one that was chosen

diff --git a/R/summary.R b/R/summary.R
@@ -1,3 +1,53 @@
+View <- function(x) {
+  UseMethod("View",x)
+}
+
+#' viewSafely
+#'
+#' @param tib a tibble
+#'
+#' @return
+#' @export
+viewSafely <- function(tib){
+  if(tibble::is_tibble(tib)){
+    out <- dplyr::mutate(tib,dplyr::across(dplyr::where(\(x) is.list(x)),\(y) y <- "Nested data not shown"))
+    tibble::view(out)
+
+  }else{
+    tibble::view(out)
+  }
+}
+
+#' Modify view for shifts
+#'
+#' @param x a shift object
+#'
+#' @return
+#' @export
+View.shift <- function(x){
+  viewSafely(x)
+}
+
+#' Default method for View
+#'
+#' @param x
+#'
+#' @return
+#' @export
+View.default <- function(x){
+  View(x)
+}
+
+#' Modify view for excursions
+#'
+#' @param x
+#'
+#' @return
+#' @export
+View.excursion <- function(x){
+  viewSafely(x)
+}
+
 #' Summarize Excursion Output
 #'
 #' @param object excursion class output
@@ -194,7 +244,7 @@ summaryShift <- function(object,
   cat("\n")
   cat(crayon::bold(glue::glue("Overall result: {sigMessage}\n\n")))
   if(n.sig > 0 ){
-    print(sig.event %>% dplyr::select(time_start,time_end,pvalue,deltas),n=nrow(sig.event))
+    print(tibble::as_tibble(sig.event) %>% dplyr::select(time_start,time_end,pvalue,deltas),n=nrow(sig.event))
   }
   cat(glue::glue("{crayon::bold('Time uncertainty considered?')} {hasTimeEnsemble}\n\n"))
   cat(glue::glue("{crayon::bold('Paleo uncertainty considered?')} {hasPaleoEnsemble}\n\n"))

diff --git a/man/View.default.Rd b/man/View.default.Rd
diff --git a/man/View.excursion.Rd b/man/View.excursion.Rd
diff --git a/man/View.shift.Rd b/man/View.shift.Rd
diff --git a/man/summarizeEventProbability.Rd b/man/summarizeEventProbability.Rd
diff --git a/man/viewSafely.Rd b/man/viewSafely.Rd
diff --git a/vignettes/detectShift.Rmd b/vignettes/detectShift.Rmd
@@ -62,10 +62,10 @@ Now we repeat the same steps over the Great Basin tree-ring record of Salzer et
 
 ```{r, warning=FALSE}
 msGb <- detectShift(great_basin,
-                     time.variable.name = "year",
+                    time.variable.name = "year",
                     vals.variable.name = "trsgi",
                     null.hypothesis.n = 50,
-                    summary.bin.step = 1,
+                    summary.bin.step = 10,
                     minimum.segment.length = 50,
                     simulate.time.uncertainty = FALSE,
                     method = "AMOC",

diff --git a/vignettes/mapping_excursions.Rmd b/vignettes/mapping_excursions.Rmd
@@ -46,6 +46,22 @@ filter(paleoData_TSid %in% sites$paleoData_TSid)
 
 tp <- split(filtNats,seq(nrow(filtNats)))
 
+
+test <- detectExcursion(tp[[1]],
+                  event.yr = 8200,
+                  event.window = rnorm(50,400,100),
+                  ref.window = rnorm(50,400,100),
+                  exc.type = "negative",
+                  n.ens = 50,
+                  sig.num = rnorm(50,2,.1),
+                  n.consecutive = sample(c(2,3,4),size = 50,replace = TRUE),
+                  null.hypothesis.n = 50,
+                  simulate.time.uncertainty = FALSE,
+                  simulate.paleo.uncertainty = TRUE,
+                  paleo.uncertainty = 0.2,
+                  min.vals = 4,
+                  paleo.ar1 = 0.8)
+
 events8.2 <- purrr::map(tp,
                   detectExcursion,
                   event.yr = 8200,