diff --git a/NAMESPACE b/NAMESPACE index 25faf01..e389357 100644 --- 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 index eff04a8..88e82a0 100644 --- 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 index ddba715..35f24fc 100644 --- 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 index e30c62d..c6ab760 100644 --- 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 index 2370ead..79462ac 100644 --- 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 new file mode 100644 index 0000000..3c73fe8 --- /dev/null +++ b/man/View.default.Rd @@ -0,0 +1,14 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/summary.R +\name{View.default} +\alias{View.default} +\title{Default method for View} +\usage{ +\method{View}{default}(x) +} +\arguments{ +\item{x}{} +} +\description{ +Default method for View +} diff --git a/man/View.excursion.Rd b/man/View.excursion.Rd new file mode 100644 index 0000000..8e4b53b --- /dev/null +++ b/man/View.excursion.Rd @@ -0,0 +1,14 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/summary.R +\name{View.excursion} +\alias{View.excursion} +\title{Modify view for excursions} +\usage{ +\method{View}{excursion}(x) +} +\arguments{ +\item{x}{} +} +\description{ +Modify view for excursions +} diff --git a/man/View.shift.Rd b/man/View.shift.Rd new file mode 100644 index 0000000..45dc927 --- /dev/null +++ b/man/View.shift.Rd @@ -0,0 +1,14 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/summary.R +\name{View.shift} +\alias{View.shift} +\title{Modify view for shifts} +\usage{ +\method{View}{shift}(x) +} +\arguments{ +\item{x}{a shift object} +} +\description{ +Modify view for shifts +} diff --git a/man/summarizeEventProbability.Rd b/man/summarizeEventProbability.Rd index 9e58aa1..b2db025 100644 --- a/man/summarizeEventProbability.Rd +++ b/man/summarizeEventProbability.Rd @@ -10,7 +10,8 @@ summarizeEventProbability( bin.step = 10, max.time = NA, min.time = NA, - shift.type = "either" + shift.type = "either", + time.dir = "retrograde" ) } \arguments{ diff --git a/man/viewSafely.Rd b/man/viewSafely.Rd new file mode 100644 index 0000000..a230a2c --- /dev/null +++ b/man/viewSafely.Rd @@ -0,0 +1,14 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/summary.R +\name{viewSafely} +\alias{viewSafely} +\title{viewSafely} +\usage{ +viewSafely(tib) +} +\arguments{ +\item{tib}{a tibble} +} +\description{ +viewSafely +} diff --git a/vignettes/detectShift.Rmd b/vignettes/detectShift.Rmd index 73ff5ed..7a9127f 100644 --- 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 index 77260c9..55f3550 100644 --- 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,