Nothing
#' tab_report UI Function
#'
#' @description Final report tab.
#'
#' @param id,input,output,session Internal parameters for {shiny}.
#'
#' @noRd
#'
#' @importFrom shiny NS tagList
#'
mod_tab_report_ui <- function(id) {
ns <- NS(id)
tagList(
fluidRow(
# [left column] -----------------------------------------------------
div(class = "col-xs-12 col-sm-4 col-md-4 col-lg-2",
div(class = "tabBox_noheaders",
shinydashboardPlus::box(
id = ns("repBox_details"),
width = NULL,
headerBorder = FALSE,
div(class = "tabBox_main",
shinydashboard::tabBox(
id = ns("repTabs_details"),
width = NULL, side = "right",
tabPanel(
title = "Settings:",
value = ns("repPanel_settings"),
icon = icon("hammer"),
### Research question(s) --------------------------
uiOutput(outputId = ns("report_question")),
uiOutput(outputId = ns("report_device")),
p(style = "padding-top: 0px"),
p(HTML(" "),
"No. of simulations:") %>%
tagAppendAttributes(class = 'label_split'),
fluidRow(
column(width = 12,
verbatimTextOutput(
outputId = ns("rep_nsims"))
)), p(style = "padding-bottom: 5px;"),
uiOutput(outputId = ns("report_emulate")),
p(style = "padding-bottom: 5px;"),
shinyWidgets::autonumericInput(
inputId = ns("ci"),
label = span("Credible intervals:",
style = "align: left !important;"),
currencySymbol = "%",
currencySymbolPlacement = "s",
decimalPlaces = 0,
minimumValue = 0,
maximumValue = 100,
value = 95),
actionButton(
inputId = ns("build_report"),
icon = icon("bookmark"),
label = "Build report",
width = "100%",
class = "btn-primary")
) # end of panel
)) # end of tabBox // repTabs_details
) # end of box // repBox_details
), # end of div (no headers)
shinydashboardPlus::box(
title = span("Home range:", class = "ttl-box"),
id = ns("repBox_hr_err"),
status = "info",
width = NULL,
solidHeader = FALSE,
collapsible = FALSE,
mod_blocks_ui(ns("repBlock_hrErr")),
br()
), # end of box
shinydashboardPlus::box(
title = span("Speed:", class = "ttl-box"),
id = ns("repBox_speed_err"),
status = "info",
width = NULL,
solidHeader = FALSE,
collapsible = FALSE,
mod_blocks_ui(ns("repBlock_speedErr")),
br()
), # end of box
shinydashboardPlus::box(
title = span("Distance:", class = "ttl-box"),
id = ns("repBox_dist_err"),
status = "info",
width = NULL,
solidHeader = FALSE,
collapsible = FALSE,
mod_blocks_ui(ns("repBlock_distErr")),
br()
) # end of box
), # end of UI column (left)
# [right column] ----------------------------------------------------
div(class = "col-xs-12 col-sm-8 col-md-8 col-lg-10",
## Parameter information: ---------------------------------------
div(class = "col-lg-6 no-padding-left tabBox_noheaders",
shinydashboardPlus::box(
id = ns("repBox_pars"),
width = NULL,
headerBorder = FALSE,
shinydashboard::tabBox(
id = ns("repTabs_pars"),
width = NULL,
tabPanel(title = "Species:",
value = ns("regPanel_species"),
icon = icon("paw"),
splitLayout(
mod_blocks_ui(ns("repBlock_taup")),
mod_blocks_ui(ns("repBlock_tauv"))
), mod_blocks_ui(ns("repBlock_sigma"))
), # end of panel (1 out of 2)
tabPanel(title = "Sampling design:",
value = ns("repPanel_schedule"),
icon = icon("stopwatch"),
splitLayout(
mod_blocks_ui(ns("repBlock_dur")),
mod_blocks_ui(ns("repBlock_dti")))
) # end of panel (2 out of 2)
) # end of tabBox
)), # end of box // regBox_pars
div(class = "col-lg-6 no-padding-right tabBox_noheaders",
shinydashboardPlus::box(
id = ns("regBox_pars_sizes"),
width = NULL,
headerBorder = FALSE,
shinydashboard::tabBox(
id = ns("repTabs_pars_size"),
width = NULL,
tabPanel(title = "Sample sizes:",
value = ns("repPanel_sizes"),
icon = icon("calculator"),
uiOutput(ns("repUI_sizes")))
) # end of tabBox
) # end of box // regBox_pars_sizes
) # end of div
), # end of UI column (right)
## Final report: ----------------------------------------------------
div(class = "col-xs-12 col-sm-8 col-md-8 col-lg-10",
shinydashboardPlus::box(
title = span("General report:", class = "ttl-tab"),
icon = fontawesome::fa(name = "box-archive",
height = "21px",
margin_left = "14px",
margin_right = "8px",
fill = "var(--sea-dark)"),
id = ns("repBox_analyses"),
width = NULL,
headerBorder = FALSE,
div(class = "col-report-left no-padding-left",
uiOutput(ns("end_report"))),
div(class = "col-report-right no-padding-right",
div(id = "section-two_questions",
uiOutput(ns("end_report_both"))),
div(id = ns("section-comparison"),
p("Quick comparison with other",
wrap_none(span("designs",
class = "cl-sea"), "?")) %>%
tagAppendAttributes(class = "subheader"),
column(width = 12, align = "center",
style = paste("z-index: 999;"),
uiOutput(ns("highlighting_reg"))),
uiOutput(outputId = ns("reportPlots_error")),
uiOutput(ns("repPlotLegend3")),
uiOutput(ns("end_comparison"))
) # end of div [section-comparison]
) # end of div
), # end of box, "repBox_analyses"
shinydashboardPlus::box(
title = span("Meta-analyses report:", class = "ttl-tab"),
icon = fontawesome::fa(name = "box-archive",
height = "21px",
margin_left = "14px",
margin_right = "8px",
fill = "var(--sea-dark)"),
id = ns("repBox_meta"),
width = NULL,
headerBorder = FALSE,
div(class = "col-report-left no-padding-left",
shinyWidgets::radioGroupButtons(
inputId = ns("reportInput_target"),
width = "100%",
label = "Show outputs for:",
choices = c(
"Home range" = "hr",
"Speed & distance" = "ctsd"),
selected = "hr",
checkIcon = list(yes = icon("circle-check")),
justified = TRUE),
mod_viz_meta_ui("viz_meta_2")),
div(class = "col-report-right no-padding-right",
uiOutput(ns("end_meta")))
) # end of box, "repBox_meta"
), # end of div
# [bottom column] ---------------------------------------------------
div(class = "col-xs-12 col-sm-12 col-md-12 col-lg-12",
## Tables: ------------------------------------------------------
shinydashboardPlus::box(
title = span("Tables:", class = "ttl-box"),
id = ns("repBox_tables"),
width = NULL,
solidHeader = FALSE,
reactable::reactableOutput(ns("endTable"))
) # end of box // tables
) # end of UI column (bottom)
) # end of fluidRow
) # end of tagList
}
#' tab_report Server Functions
#'
#' @noRd
mod_tab_report_server <- function(id, rv) {
moduleServer(id, function(input, output, session) {
ns <- session$ns
pal <- load_pal()
# MAIN REACTIVE VALUES ------------------------------------------------
rv$report <- reactiveValues()
sims_hrange <- get_hrange_file()
sims_speed <- get_speed_file()
# DYNAMIC UI ELEMENTS -------------------------------------------------
observe({
req(rv$which_question)
if (length(rv$which_question) == 1) {
shinyjs::hide(id = "reportInput_target")
} else {
rv$set_analysis <- "hr"
shinyjs::show(id = "reportInput_target")
}
}) %>% # end of observe,
bindEvent(input$build_report)
observe({
rv$set_analysis <- input$reportInput_target
}) %>% bindEvent(input$reportInput_target)
## Hide elements at start: --------------------------------------------
shinyjs::hide(id = "end_comparison")
shinyjs::hide(id = "repBox_hr_err")
shinyjs::hide(id = "repBox_speed_err")
shinyjs::hide(id = "repBox_dist_err")
shinyjs::hide(id = "repBox_analyses")
shinyjs::hide(id = "repBox_tables")
shinyjs::hide(id = "repBox_meta")
observe({
req(rv$active_tab == 'report')
rv$report$species <- NULL
rv$report$schedule <- NULL
rv$report$analyses <- NULL
shinyjs::hide(id = "repBox_analyses")
output$end_report <- renderUI({ NULL })
output$end_report_both <- renderUI({ NULL })
}) %>% # end of observe,
bindEvent(rv$active_tab)
## Rendering research questions: --------------------------------------
output$report_question <- renderUI({
ui_hr <- staticBlock("Home range", active = FALSE)
ui_sd <- staticBlock("Speed & distance", active = FALSE)
out_ui <- tagList(ui_hr, ui_sd)
if (!is.null(rv$which_question)) {
if ("Home range" %in% rv$which_question) {
ui_hr <- staticBlock("Home range", active = TRUE)
}
if ("Speed & distance" %in% rv$which_question) {
ui_sd <- staticBlock("Speed & distance", active = TRUE)
}
out_ui <- tagList(ui_hr, ui_sd)
}
return(out_ui)
}) # end of renderUI, "report_question"
## Rendering device limitations: --------------------------------------
output$report_device <- renderUI({
req(rv$which_limitations)
if ("loss" %in% rv$which_limitations) {
ui_loss <- staticBlock(
paste0(rv$lost$perc * 100, "%"), active = TRUE)
} else if (!("loss" %in% rv$which_limitations)) {
ui_loss <- staticBlock("No data loss", active = FALSE)
}
if ("error" %in% rv$which_limitations) {
ui_error <- staticBlock(paste(rv$error, "meters"), active = TRUE)
} else if (!("error" %in% rv$which_limitations)) {
ui_error <- staticBlock("No error", active = FALSE)
}
if ("limit" %in% rv$which_limitations) {
ui_limit <- staticBlock(paste(rv$storage, "locations"),
type = "max", active = TRUE)
} else if (!("limit" %in% rv$which_limitations)) {
ui_limit <- staticBlock("No limit", active = FALSE)
}
out <- tagList(
br(),
span("Data loss:", class = "txt-label"), ui_loss,
p(style = "margin-top: 5px; margin-bottom: 0px"),
span("Location error:", class = "txt-label"), ui_error,
p(style = "margin-top: 5px; margin-bottom: 0px"),
span("Storage limit:", class = "txt-label"), ui_limit)
return(out)
}) # end of renderUI, "report_device"
## Rendering if uncertainty was propagated or not: --------------------
output$report_emulate <- renderUI({
ui <- staticBlock("Without individual varation", active = FALSE)
if (req(rv$is_emulate)) {
ui <- staticBlock("With individual varation", active = TRUE)
}
out_ui <- tagList(ui)
return(out_ui)
}) # end of renderUI, "report_emulate"
## Rendering schedule comparison inputs: ------------------------------
output$highlighting_reg <- renderUI({
req(rv$which_question, rv$which_meta)
req(rv$which_meta == "none")
if ("Home range" %in% rv$which_question) {
out <- out_hr <- shinyWidgets::pickerInput(
inputId = ns("highlight_dur"),
label = span("Sampling duration (in days):",
class = "txt-label"),
choices = 2^seq(1, 12, by = 1),
options = list(title = "(select here)"),
width = "200px")
}
if ("Speed & distance" %in% rv$which_question) {
dat <- sims_speed[[2]]
out <- out_sd <- shinyWidgets::pickerInput(
inputId = ns("highlight_dti"),
label = span("Sampling interval:",
class = "txt-label"),
choices = unique(dat$dti_notes),
options = list(title = "(select here)"),
width = "200px")
}
if (length(rv$which_question) > 1) {
out <- tagList(out_hr, out_sd)
}
return(out)
}) # end of renderUI, "highlighting_reg"
observe({
req(input$highlight_dur)
rv$highlight_dur <- input$highlight_dur
})
observe({
req(input$highlight_dti)
rv$highlight_dti <- input$highlight_dti
})
## Rendering total number of simulations: -----------------------------
output$rep_nsims <- renderText({
req(rv$simList)
return(length(rv$simList))
}) # end of renderText, "rep_nsims"
# OPERATIONS ----------------------------------------------------------
## Credible intervals for home range estimation: ----------------------
observe({
req(rv$active_tab == 'report')
req(rv$which_meta, rv$tau_p[[1]], rv$dur$value, rv$dur$unit)
ci <- ifelse(is.null(input$ci), .95, input$ci/100)
taup_unit <- "days"
input_taup <- taup_unit %#%
rv$tau_p[[1]]$value[2] %#% rv$tau_p[[1]]$unit[2]
input_dur <- taup_unit %#% rv$dur$value %#% rv$dur$unit
if (rv$which_meta == "none") {
dat <- sims_hrange[[1]] %>%
dplyr::mutate(tau_p = round("days" %#% .data$tau_p, 1)) %>%
dplyr::mutate(duration = round("days" %#% .data$duration, 1))
out_taup <- dat$tau_p[which.min(abs(dat$tau_p - input_taup))]
out_dur <- dat$dur[which.min(abs(dat$dur - input_dur))]
newdat <- dat %>%
dplyr::filter(.data$tau_p == out_taup) %>%
dplyr::filter(.data$duration == out_dur)
} else {
req(rv$hr$tbl)
newdat <- data.frame(
tau_p = input_taup,
duration = input_dur,
error = rv$hr$tbl$area_err,
error_lci = rv$hr$tbl$area_err_min,
error_uci = rv$hr$tbl$area_err_max)
out_taup <- input_taup
out_dur <- input_dur
}
rv$hr_coi <- data.frame(
lci = min(newdat$error, na.rm = TRUE),
est = mean(newdat$error, na.rm = TRUE),
uci = max(newdat$error, na.rm = TRUE),
ci = ci)
# Credible intervals:
rv$hr_cri <- .extract_cri(newdat$error, ci)
}) # end of observe
observe({ # For comparison with new duration:
req(rv$highlight_dur > 0)
shinyjs::show(id = "end_comparison")
ci <- ifelse(is.null(input$ci), .95, input$ci/100)
input_taup <- "days" %#% rv$tau_p[[1]]$value[2] %#%
rv$tau_p[[1]]$unit[2]
dat <- sims_hrange[[1]] %>%
dplyr::mutate(tau_p = round("days" %#% .data$tau_p, 1)) %>%
dplyr::mutate(duration = round("days" %#% .data$duration, 1))
out_taup <- dat$tau_p[which.min(abs(dat$tau_p - input_taup))]
out_dur <- as.numeric(rv$highlight_dur)
newdat <- dat %>%
dplyr::filter(.data$tau_p == out_taup) %>%
dplyr::filter(.data$duration == out_dur)
rv$hr_coi_new <- data.frame(
lci = mean(newdat$error_lci, na.rm = TRUE),
est = mean(newdat$error, na.rm = TRUE),
uci = mean(newdat$error_uci, na.rm = TRUE),
ci = ci)
# Credible intervals:
rv$hr_cri_new <- .extract_cri(newdat$error, ci)
}) %>% # end of observe,
bindEvent(rv$highlight_dur)
## Credible intervals for speed & distance estimation: ----------------
observe({
req(rv$active_tab == 'report')
req(rv$which_meta, rv$tau_v, rv$dti$value, rv$dti$unit)
ci <- ifelse(is.null(input$ci), .95, input$ci/100)
input_tauv <- rv$tau_v[[1]]$value[2] %#% rv$tau_v[[1]]$unit[2]
input_dur <- "days" %#% rv$dur$value %#% rv$dur$unit
input_dti <- rv$dti$value %#% rv$dti$unit
if (rv$which_meta == "none") {
dat <- sims_speed[[1]] %>%
dplyr::mutate(dur = round("days" %#% .data$dur, 0))
out_tauv <- dat$tau_v[which.min(abs(dat$tau_v - input_tauv))]
out_dti <- dat$dti[which.min(abs(dat$dti - input_dti))]
out_dur <- dat$dur[which.min(abs(dat$dur - input_dur))]
newdat <- dat %>%
dplyr::filter(.data$tau_v == out_tauv) %>%
dplyr::filter(.data$dur == out_dur) %>%
dplyr::filter(.data$dti == out_dti)
} else {
req(rv$sd$tbl)
newdat <- data.table::data.table(
# tau_v = input_tauv,
# dur = input_dur,
# dti = input_dti,
error = rv$sd$tbl$ctsd_err,
error_lci = rv$sd$tbl$ctsd_err_min,
error_uci = rv$sd$tbl$ctsd_err_max)
}
rv$sd_coi <- data.frame(
lci = mean(newdat$error_lci, na.rm = TRUE),
est = mean(newdat$error, na.rm = TRUE),
uci = mean(newdat$error_uci, na.rm = TRUE),
ci = ci)
# Credible intervals:
rv$sd_cri <- .extract_cri(newdat$error, ci)
}) # end of observe
observe({ # For comparison with new interval:
req(rv$highlight_dti > 0)
shinyjs::show(id = "end_comparison")
ci <- ifelse(is.null(input$ci), .95, input$ci/100)
input_tauv <- rv$tau_v[[1]]$value[2] %#% rv$tau_v[[1]]$unit[2]
dat <- sims_speed[[1]]
out_tauv <- dat$tau_v[which.min(abs(dat$tau_v - input_tauv))]
opts <- sims_speed[[1]] %>%
dplyr::select(.data$dti, .data$dti_notes) %>%
unique()
out_dti <- fix_unit(
opts$dti[match(rv$highlight_dti, opts$dti_notes)], "seconds")
newdat <- dat %>%
dplyr::filter(.data$tau_v == out_tauv) %>%
dplyr::filter(.data$dti == out_dti$value)
rv$sd_coi_new <- data.frame(
lci = mean(newdat$error_lci, na.rm = TRUE),
est = mean(newdat$error, na.rm = TRUE),
uci = mean(newdat$error_uci, na.rm = TRUE),
ci = ci)
# Credible intervals:
rv$sd_cri_new <- .extract_cri(newdat$error, ci)
}) %>% # end of observe,
bindEvent(rv$highlight_dti)
# REPORT --------------------------------------------------------------
observe({
req(rv$which_question,
rv$data_type,
rv$is_analyses,
rv$simList)
proceed <- TRUE
questions <- NULL
if ("Home range" %in% rv$which_question) {
req(rv$hr_completed)
questions <- "Home range"
if (is.null(rv$hr_cri) || is.null(rv$hrErr)) {
shinyalert::shinyalert(
type = "error",
title = "Warning",
text = tagList(span(
"No", span("home range estimation", class = "cl-dgr"),
"outputs were generated for the final report."
)),
html = TRUE,
size = "xs")
msg_log(
style = "error",
message = paste(
"No",
msg_danger("home range estimation"),
"outputs available."),
detail = "Return to the 'Sampling design' tab.")
proceed <- FALSE
}
}
if ("Speed & distance" %in% rv$which_question) {
req(rv$sd_completed)
add_to <- ifelse(length(rv$which_question) > 1, ", ", "")
questions <- paste0(questions, add_to, "Speed & distance")
if (is.null(rv$is_ctsd)) {
# shinyalert::shinyalert(
# type = "error",
# title = "Warning",
# text = tagList(span(
# "No", span("speed estimation", class = "cl-dgr"),
# "outputs were generated for the final report."
# )),
# html = TRUE,
# size = "xs")
msg_log(
style = "error",
message = paste(
"No",
msg_danger("speed estimation"),
"outputs available."),
detail = "Return to the 'Sampling design' tab.")
proceed <- FALSE
}
}
msg_log(
style = "warning",
message = paste0("Building ",
msg_warning("report"), "..."),
detail = paste("Current question(s):", questions))
boxnames <- c("analyses", "tables")
for (i in 1:length(boxnames)) {
shinyjs::show(id = paste0("repBox_", boxnames[i]))
}
}) %>% # end of observe,
bindEvent(input$build_report)
### Reporting DATA: ---------------------------------------------------
observe({
req(rv$which_question,
rv$data_type,
rv$is_analyses,
rv$simList)
css_bold <- "font-weight: bold;"
css_mono <- "font-family: var(--monosans);"
if (length(rv$id) == 1) {
out_id <- span(rv$id, class = "cl-grn")
} else {
out_id <- span(
"multiple individuals",
wrap_none("(", span(toString(rv$id),
class = "cl-grn"), ")"))
}
switch(rv$data_type,
"selected" = {
out_species <- span(
"These outputs are based on parameters",
"extracted from", out_id, "of the species",
span(rv$species_common, class = "cl-grn"),
wrap_none("(", em(rv$species_binom), ")."))
},
"uploaded" = {
out_species <- span(
"These outputs are based on parameters extracted",
"from ", out_id, "and species",
wrap_none(em(rv$species, class = "cl-grn"), "."))
},
"simulated" = {
out_species <- span(
"These outputs are based on a",
span("simulated", class = "cl-grn"),
"dataset.")
}
) # end of switch
out_bias <- NULL
if (rv$add_note) {
out_bias <- span(
style = paste(css_mono, css_bold),
"However, due to ",
span("very low effective sample sizes", class = "cl-dgr"),
"of the", rv$data_type, "data, these parameters may not be",
"accurate, and lead to negatively biased outputs.")
}
rv$report$species <- p(
out_species,
span(style = paste(css_mono, css_bold),
"Please see",
icon("paw", class = "cl-sea"),
span("Species", class = "cl-sea"),
"parameters for more details."),
out_bias)
}) %>% # end of observe,
bindEvent(input$build_report)
### Reporting DESIGN: -------------------------------------------------
observe({
req(rv$which_question,
rv$data_type,
rv$is_analyses,
rv$simList)
N1 <- N2 <- NULL
tau_p <- tau_p <- NULL
tau_v <- tau_v <- NULL
dur <- dur <- NULL
dti <- dti <- NULL
dur_unit <- dur_unit <- NULL
dti_unit <- dti_unit <- NULL
ideal_dti <- ideal_dti <- NULL
ideal_dur <- ideal_dur <- NULL
if ("Home range" %in% rv$which_question) req(rv$hr_completed)
if ("Speed & distance" %in% rv$which_question) req(rv$sd_completed)
pars <- .build_parameters(rv)
list2env(pars, envir = environment())
rv$hr_col <- rv$ctsd_col <- data.frame(
hex = pal$sea,
css = "cl-sea")
if (dur$value <= ideal_dur$value) {
rv$hr_col$hex <- pal$dgr
rv$hr_col$css <- "cl-dgr"
}
if (!is.infinite(ideal_dti$value)) {
if (dti$value <= ideal_dti$value) {
diff_dti <- tau_v / (rv$dti$value %#% rv$dti$unit)
} else {
diff_dti <- 1 / (tau_v / (rv$dti$value %#% rv$dti$unit))
}
min_dti <- fix_unit(dti_unit %#% (tau_v * 3), dti_unit)
if (dti$value > 3 * ideal_dti$value) {
rv$ctsd_col$hex <- pal$dgr
rv$ctsd_col$css <- "cl-dgr"
}
if ((dti$value %#% dti$unit) <= tau_v) {
dti_text <- span(
wrap_none("\u03C4", tags$sub("v"), "/",
round(diff_dti, 1)))
} else {
dti_text <- span(
round(diff_dti, 1), icon(name = "xmark"),
wrap_none("\u03C4", tags$sub("v")))
}
}
### For home range estimation:
if ("Home range" %in% rv$which_question) {
req(rv$hr_cri)
out_schedule <- out_reg_hr <-
p("The minimum", span("sampling duration", class = "cl-sea"),
"recommended for", span("home range", class = "cl-grn"),
"estimation should be at least 30", icon(name = "xmark"),
span("position autocorrelation", class = "cl-sea"),
wrap_none("parameter (\u03C4", tags$sub("p"), "),"),
"or \u2248", wrap_none(ideal_dur$value, " ", ideal_dur$unit,
css = "cl-grn", end = "."),
"Your current duration is",
round(dur$value / (dur$unit %#% tau_p), 0),
icon(name = "xmark"), wrap_none("\u03C4", tags$sub("p")),
"\u2248", wrap_none(dur$value, " ", dur$unit, ","),
"resulting in an effective sample size equivalent to",
N1, "independent locations.")
} # end of "Home range"
## Speed and distance estimation:
if ("Speed & distance" %in% rv$which_question) {
req(rv$sd_cri)
out_schedule <- out_reg_ctsd <-
p("The ", span("sampling interval", class = "cl-sea"),
"for", span("speed & distance", class = "cl-grn"),
"estimation should ideally be near or less than the",
span("velocity autocorrelation", class = "cl-sea"),
wrap_none("parameter (", tags$sub("v"), "),"),
"or \u2264", wrap_none(ideal_dti$value, " ", ideal_dti$unit,
css = "cl-grn", end = "."),
"Or, at a minimum, less than 3", icon(name = "xmark"),
wrap_none("\u03C4", tags$sub("v")), "(\u2264",
wrap_none(min_dti$value, " ", min_dti$unit, ")"),
"for longer sampling durations.",
"Your current interval (\u0394t) is",
dti_text,
"\u2248", wrap_none(dti$value, " ", dti$unit,
color = rv$ctsd_col[1], end = ","),
"resulting in an effective sample size equivalent to",
N2, "independently sampled velocities.")
} # end of "Speed & distance"
### Both home range and speed & distance:
if (length(rv$which_question) > 1)
out_schedule <- tagList(out_reg_hr, out_reg_ctsd)
rv$report$schedule <- out_schedule
}) %>% # end of observe,
bindEvent(input$build_report)
### Reporting OUTPUTS: ------------------------------------------------
observe({
req(rv$which_question,
rv$data_type,
rv$is_analyses,
rv$simList)
if (rv$which_meta != "none") req(rv$meta_tbl)
N1 <- N2 <- NULL
tau_p <- tau_p <- NULL
tau_v <- tau_v <- NULL
dur <- dur <- NULL
dti <- dti <- NULL
dur_unit <- dur_unit <- NULL
dti_unit <- dti_unit <- NULL
ideal_dti <- ideal_dti <- NULL
ideal_dur <- ideal_dur <- NULL
ci <- ifelse(is.null(input$ci), .95, input$ci/100)
if ("Home range" %in% rv$which_question) {
req(rv$hr_cri, rv$hrErr)
}
if ("Speed & distance" %in% rv$which_question) {
is_ctsd <- FALSE
if (!is.null(rv$is_ctsd)) {
if (rv$is_ctsd) {
req(rv$sd_cri, rv$speedErr)
is_ctsd <- TRUE
}
}
}
css_bold <- "font-weight: bold;"
css_mono <- "font-family: var(--monosans);"
#### Initialize:
out_analyses <- NULL
rv$report$analyses <- NULL
if ("Home range" %in% rv$which_question)
req(rv$hrEst, rv$hr_completed)
if ("Speed & distance" %in% rv$which_question)
req(rv$sd_completed)
pars <- .build_parameters(rv)
list2env(pars, envir = environment())
if (rv$which_meta == "none") {
txt_single <- span(
style = paste(css_mono, css_bold),
"To obtain credible intervals from multiple",
"simulations, select a different",
span("analytical target", class = "cl-sea"),
"(mean of sampled population, or comparing population means)",
"in the", icon("house", class = "cl-mdn"),
span("Home", class = "cl-mdn"), "tab.")
} else {
txt_meta_no_ci <- span(
"The number of simulations was insufficient so credible",
"intervals (CIs) could", span("not", class = "cl-dgr"),
"be calculated.",
span(
style = paste(css_mono, css_bold),
"Please run more simulations in the corresponding",
shiny::icon("compass-drafting", class = "cl-sea"),
span("Analyses", class = "cl-sea"), "tab(s) to obtain",
wrap_none(span("valid CIs", class = "cl-dgr"), ".")))
}
#### Home range estimation:
if ("Home range" %in% rv$which_question) {
hr_cri <- c(.err_to_txt(rv$hr_cri$lci),
.err_to_txt(rv$hr_cri$est),
.err_to_txt(rv$hr_cri$uci))
txt_hr_uncertainty <- "estimation."
if (!is.na(rv$hr_cri$lci) && !is.na(rv$hr_cri$uci))
txt_hr_uncertainty <- ifelse(
rv$hr_cri$uci < .3 & rv$hr_cri$lci > -.3,
"estimation, and with low uncertainty.",
"estimation, but with high uncertainty.")
opts_dur <- 2^seq(1, 12, by = 1)
plot_dur <- opts_dur[which.min(abs(
opts_dur - ("days" %#% dur$value %#% dur$unit)))]
if (dur$value >= ideal_dur$value) {
rv$report$is_hr <- TRUE
txt_hr <- span(
style = css_bold,
"Your current sampling duration appears sufficient",
"for home range", txt_hr_uncertainty)
} else {
rv$report$is_hr <- FALSE
txt_hr <- span(
style = css_bold,
"Your current sampling duration may be insufficient",
"for home range estimation.")
}
txt_hr_extra <- NULL
if (rv$which_meta == "none") txt_hr_extra <- txt_single
else {
if (!is.na(hr_cri[1]) && !is.na(hr_cri[3])) {
txt_hr_extra <- span(
"There is a", wrap_none(ci, "%", css = "cl-blk"),
"probability the relative error will lie between",
wrap_none(hr_cri[1], "%", css = "cl-blk"),
"and", wrap_none(hr_cri[3], "%", end = ".", css = "cl-blk"))
} else txt_hr_extra <- txt_meta_no_ci
}
txt_nsim <- .get_txt_nsim(rv, set_target = "hr")
out_analyses <- out_hr <- p(
txt_hr,
txt_nsim,
txt_hr_extra)
} # end of 'Home range'
## Speed and distance estimation:
if ("Speed & distance" %in% rv$which_question) {
if (is_ctsd) {
req(rv$speedEst, rv$distEst)
sd_cri <- c(round(rv$sd_cri$lci * 100, 1),
round(rv$sd_cri$est * 100, 0),
round(rv$sd_cri$uci * 100, 1))
txt_sd_uncertainty <- "estimation."
if (!is.na(rv$sd_cri$lci) && !is.na(rv$sd_cri$uci))
txt_sd_uncertainty <- ifelse(
rv$sd_cri$uci < .3 & rv$sd_cri$lci > -.3,
"estimation, and with low uncertainty.",
"estimation, but with high uncertainty.")
}
dti_options <- sims_speed[[1]] %>%
dplyr::select(.data$dti, .data$dti_notes) %>%
unique()
index_dti <- which.min(
abs(dti_options$dti - (dti$value %#% dti$unit)))
plotted_dti <- sub('^\\w+\\s\\w+\\s\\w+\\s', '',
dti_options[index_dti, 2])
N2 <- rv$dev$N2
if (is.list(rv$dev$N2)) N2 <- do.call(c, N2)
N2 <- mean(N2, na.rm = TRUE)
if (N2 >= 100) {
rv$report$is_sd <- TRUE
txt_sd <- span(
style = paste(css_mono, css_bold),
"Your current sampling interval appears sufficient",
"for speed & distance", txt_sd_uncertainty)
} else if (N2 >= 30) {
rv$report$is_sd <- FALSE
txt_sd <- span(
style = paste(css_mono, css_bold),
"Your current sampling interval may be sufficient",
"for speed & distance estimation.")
} else if (N2 > 0) {
rv$report$is_sd <- FALSE
txt_sd <- span(
style = paste(css_mono, css_bold),
"Your current sampling interval may be insufficient",
"for speed & distance estimation.")
} else {
rv$report$is_sd <- FALSE
txt_sd <- span(
style = paste(css_mono, css_bold),
"Your current sampling interval was too coarse",
"for speed & distance estimation.")
}
if (is_ctsd) {
txt_sd_extra <- NULL
if (rv$which_meta == "none") txt_sd_extra <- txt_single
else {
if (!is.na(sd_cri[1]) && !is.na(sd_cri[3]))
txt_sd_extra <- span(
"There is a", wrap_none(ci, "%", css = "cl-blk"),
"probability that the relative error will lie within",
wrap_none(sd_cri[1], "%", css = "cl-blk"), "and",
wrap_none(sd_cri[3], "%", end = ".", css = "cl-blk"))
else txt_sd_extra <- txt_meta_no_ci
}
txt_nsim <- .get_txt_nsim(rv, set_target = "ctsd")
out_analyses <- p(
txt_sd,
txt_nsim,
txt_sd_extra)
} else {
txt_sd_extra <- NULL
if (is.na(hr_cri[1]) ||
is.na(hr_cri[3])) txt_sd_extra <- txt_meta_no_ci
out_analyses <- p(
txt_sd,
txt_sd_extra)
}
} # end of "Speed & distance"
req(length(rv$which_question) == 1)
rv$report$analyses <- out_analyses
}) %>% # end of observe,
bindEvent(input$build_report)
observe({
req(length(rv$which_question) > 1,
rv$hr_completed,
rv$sd_completed,
rv$simList)
if (rv$which_meta != "none") {
req(rv$metaErr, rv$meta_tbl) }
#### Initialize:
is_hr <- rv$report$is_hr
is_sd <- rv$report$is_sd
req(!is.null(is_hr), !is.null(is_sd))
req(rv$hr_completed, rv$sd_completed)
txt_hr_uncertainty <- NULL
txt_sd_uncertainty <- NULL
is_hr_ci <- FALSE
is_sd_ci <- FALSE
#### Styles:
css_bold <- "font-weight: bold;"
css_mono <- "font-family: var(--monosans);"
#### For number of simulations:
sufficient <- span("sufficient", class = "cl-sea")
insufficient <- span("insufficient", class = "cl-dgr")
if (length(rv$simList) > 1) {
txt_nsim <- span(length(rv$simList), "simulations",
style = css_bold)
} else {
txt_nsim <- span("a", span("single", style = css_bold),
"simulation")
}
#### For home range estimation:
hrErr_est <- hrErr_lci <- hrErr_uci <- NA
if (rv$which_meta == "none") {
hrErr_lci <- .err_to_txt(rv[["hrErr"]]$lci)
hrErr_est <- .err_to_txt(rv[["hrErr"]]$est)
hrErr_uci <- .err_to_txt(rv[["hrErr"]]$uci)
} else {
tmp <- rv$meta_tbl %>%
dplyr::filter(.data$group == "All") %>%
dplyr::filter(.data$type == "hr") %>%
dplyr::slice(which.max(.data$m))
hrErr_lci <- tmp[["error_lci"]]
hrErr_est <- tmp[["error"]]
hrErr_uci <- tmp[["error_uci"]]
}
if (length(rv$simList) > 1) {
hrErr_lci <- .err_to_txt(rv$hr_cri$lci)
hrErr_uci <- .err_to_txt(rv$hr_cri$uci)
if (!is.na(hrErr_lci) && !is.na(hrErr_uci)) {
txt_hr_uncertainty <- case_when(
abs(hrErr_uci) > 50 && abs(hrErr_lci) > 50 ~
"(with high uncertainty)",
abs(hrErr_uci) > 10 && abs(hrErr_lci) > 10 ~
"(with low uncertainty)",
TRUE ~ "(with very low uncertainty)")
is_hr_ci <- TRUE
}
}
# Speed and distance errors:
sdErr_est <- sdErr_lci <- sdErr_uci <- NA
if (any(rv$dev$N2 > 0)) {
sdErr_lci <- .err_to_txt(rv[["speedErr"]]$lci)
sdErr_est <- .err_to_txt(rv[["speedErr"]]$est)
sdErr_uci <- .err_to_txt(rv[["speedErr"]]$uci)
if (length(rv$simList) > 1) {
req(rv$sd_cri)
sdErr_lci <- round(rv$sd_cri$lci * 100, 1)
sdErr_uci <- round(rv$sd_cri$uci * 100, 1)
if (!is.na(sdErr_lci) && !is.na(sdErr_uci)) {
txt_sd_uncertainty <- case_when(
abs(sdErr_uci) > 50 && abs(sdErr_lci) > 50 ~
"(with high uncertainty)",
abs(sdErr_uci) > 10 && abs(sdErr_lci) > 10 ~
"(with low uncertainty)",
TRUE ~ "(with very low uncertainty)")
is_sd_ci <- TRUE
}
}
}
if (is_hr & !is_sd) {
out <- span(
style = paste(css_mono, css_bold),
"Your current sampling schedule appears",
sufficient, "for home range",
ifelse(is_hr_ci,
wrap_none("estimation ", txt_hr_uncertainty, ","),
"estimation,"),
"but", insufficient, "for speed & distance",
ifelse(is_sd_ci,
wrap_none("estimation ", txt_sd_uncertainty, "."),
"estimation."))
if (any(rv$dev$N2 == 0))
out <- span(
style = paste(css_mono, css_bold),
"Your current sampling schedule appears",
sufficient, "for home range",
ifelse(is_hr_ci,
wrap_none("estimation ", txt_hr_uncertainty, ","),
"estimation,"),
"and is",
span("inappropriate", class = "cl-dgr"),
"for speed & distance",
ifelse(is_sd_ci,
wrap_none("estimation ", txt_sd_uncertainty, "."),
"estimation."))
}
if (!is_hr & is_sd) {
out <- span(
style = paste(css_mono, css_bold),
"Your current sampling schedule may be",
insufficient, "for home range",
ifelse(is_hr_ci,
wrap_none("estimation ", txt_hr_uncertainty, ","),
"estimation,"),
"but appears", sufficient, "for speed & distance",
ifelse(is_sd_ci,
wrap_none("estimation ", txt_sd_uncertainty, "."),
"estimation."))
}
if (is_hr & is_sd) {
out <- span(
style = paste(css_mono, css_bold),
"Your current sampling schedule appears",
sufficient, "for both home range",
ifelse(is_hr_ci,
wrap_none("estimation ", txt_hr_uncertainty, ","),
"estimation,"),
"and for speed & distance",
ifelse(is_sd_ci,
wrap_none("estimation ", txt_sd_uncertainty, "."),
"estimation."))
}
if (!is_hr & !is_sd) {
out <- span(
style = paste(css_mono, css_bold),
"Your current sampling schedule may be",
insufficient, "for both home range",
ifelse(is_hr_ci,
wrap_none("estimation ", txt_hr_uncertainty, ","),
"estimation,"),
"and for speed & distance",
ifelse(is_sd_ci,
wrap_none("estimation ", txt_sd_uncertainty, "."),
"estimation."))
if (any(rv$dev$N2 == 0))
out <- span(
style = paste(css_mono, css_bold),
"Your current sampling schedule may be",
insufficient, "for home range",
ifelse(is_hr_ci,
wrap_none("estimation ", txt_hr_uncertainty, ","),
"estimation,"),
"and is",
span("inappropriate", class = "cl-dgr"),
"for speed & distance",
ifelse(is_sd_ci,
wrap_none("estimation ", txt_sd_uncertainty, "."),
"estimation."))
}
if (rv$which_meta == "none") {
if (is.na(hrErr_lci) || is.na(hrErr_uci)) {
out_hr_err <- span(
ifelse(hrErr_est == 0, "less than 0.01%",
paste0(round(hrErr_est * 100, 1), "%")),
"for home range estimation,")
} else {
out_hr_err <- span(
ifelse(hrErr_est == 0, "less than 0.01%",
paste0(hrErr_est, "%")),
paste0("[", hrErr_lci,
", ", hrErr_uci, "%]"),
"for home range estimation,")
}
if (is.na(sdErr_lci) || is.na(sdErr_uci)) {
out_sd_err <- span(
"and", ifelse(sdErr_est == 0, "less than 0.01%",
paste0(sdErr_est, "%")),
"for speed estimation.")
} else {
out_sd_err <- span(
"and", ifelse(sdErr_est == 0, "less than 0.01%",
paste0(sdErr_est, "%")),
paste0("[", sdErr_lci,
", ", sdErr_uci, "%]"),
"for speed estimation.")
}
} else {
hrmetaErr <- dplyr::filter(rv$metaErr, .data$type == "hr")
sdmetaErr <- dplyr::filter(rv$metaErr, .data$type == "ctsd")
if (is.na(hrmetaErr$lci) || is.na(hrmetaErr$uci)) {
out_hr_err <- span(
ifelse(hrmetaErr$est == 0, "less than 0.01%",
paste0(round(hrmetaErr$est * 100, 1), "%")),
"for home range estimation,")
} else {
out_hr_err <- span(
ifelse(hrmetaErr$est == 0, "less than 0.01%",
paste0(hrmetaErr$est, "%")),
paste0("[", hrmetaErr$lci,
", ", hrmetaErr$uci, "%]"),
"for home range estimation,")
}
if (is.na(sdmetaErr$lci) || is.na(sdmetaErr$uci)) {
out_sd_err <- span(
"and", ifelse(sdmetaErr$est == 0, "less than 0.01%",
paste0(sdmetaErr$est, "%")),
"for speed estimation.")
} else {
out_sd_err <- span(
"and", ifelse(sdmetaErr$est == 0, "less than 0.01%",
paste0(sdmetaErr$est, "%")),
paste0("[", sdmetaErr$lci,
", ", sdmetaErr$uci, "%]"),
"for speed estimation.")
}
}
out_extra <- ""
if (is.null(txt_hr_uncertainty)) {
if (rv$which_meta == "none") {
out_extra <- span(
style = paste(css_mono, css_bold),
"To obtain credible intervals from multiple",
"simulations, select a different",
span("analytical target", class = "cl-sea"),
"in the", icon("house", class = "cl-mdn"),
span("Home", class = "cl-mdn"), "tab.")
} else {
out_extra <- span(
"The number of simulations was insufficient so credible",
"intervals (CIs) could", span("not", class = "cl-dgr"),
"be calculated.",
span(
style = paste(css_mono, css_bold),
"Please run more simulations in the corresponding",
shiny::icon("compass-drafting", class = "cl-sea"),
span("Analyses", class = "cl-sea"), "tab to obtain",
wrap_none(span("valid CIs", class = "cl-dgr"), ".")))
}
}
out_analyses <- p(
out,
"Your error estimate based on",
txt_nsim, "was", out_hr_err,
if (any(rv$dev$N2 > 0)) { out_sd_err
} else { span("but the sampling interval was",
"too coarse to estimate speed.") },
out_extra
)
rv$report$analyses <- out_analyses
}) %>% # end of observe,
bindEvent(input$build_report)
## Reporting META-ANALYSES: -------------------------------------------
observe({
req(rv$which_meta)
if (rv$which_meta == "none") {
shinyjs::hide(id = "end_meta")
} else { shinyjs::show(id = "end_meta") }
}) # end of observe
output$end_meta <- renderUI({
req(rv$which_meta != "none")
req(rv$report$meta, !is.null(rv$grouped))
div(id = "report_meta",
style = paste("padding-left: 14px;",
"padding-right: 14px;"),
rv$report$meta)
}) # end of renderUI, "end_meta"
observe({
req(rv$active_tab == "report",
rv$which_meta != "none")
rv$report$meta <- out_meta <- span("")
set_target <- NULL
txt_target <- NULL
txt_title <- NULL
get_truth <- NULL
get_coi <- NULL
get_cri <- NULL
set_style_title <- NULL
txt_link_meta <- NULL
txt_ratio_order <- NULL
if (rv$which_meta == "none") {
req(!rv$grouped)
}
if (rv$which_meta == "compare") {
req(rv$grouped, rv$groups)
req(rv$metaErr, rv$metaList, rv$metaList_groups[["is_final"]])
}
req(!is.null(rv$is_emulate),
rv$metaList)
css_bold <- "font-weight: bold;"
css_mono <- "font-family: var(--monosans);"
list2env(.build_outputs(rv), envir = environment())
i <- 0
for (target in set_target) {
i <- i + 1
meta <- as.data.frame(rv$metaList[[target]]$meta)
tmpunit <- extract_units(rownames(
meta[grep("mean", rownames(meta)), ]))
est <- meta[grep("mean", rownames(meta)), ]$est
lci <- meta[grep("mean", rownames(meta)), ]$low
uci <- meta[grep("mean", rownames(meta)), ]$high
truth <- tmpunit %#% get_truth[[target]]
meta_dt <- meta[1, ] %>%
dplyr::mutate(
error_est = (.data$est - truth)/truth,
error_lci = (.data$low - truth)/truth,
error_uci = (.data$high - truth)/truth) %>%
dplyr::select(.data$error_est,
.data$error_lci,
.data$error_uci) %>%
dplyr::rowwise() %>%
dplyr::mutate(
within_threshold =
(.data$error_est >= -rv$error_threshold &
.data$error_est <= rv$error_threshold),
overlaps_with_threshold =
(.data$error_lci <= rv$error_threshold &
.data$error_uci >= -rv$error_threshold),
status = dplyr::case_when(
within_threshold ~ "Yes",
!within_threshold & overlaps_with_threshold ~ "Near",
TRUE ~ "No"))
txt_meta_groups <- NULL
if (rv$which_meta == "compare") {
meta_group_truth <- rv$metaList_groups[["intro"]][[target]]
meta_group <- rv$metaList_groups[["final"]][[target]]
is_subpop <- meta_group_truth$logs$subpop_detected
is_subpop_detected <- meta_group$logs$subpop_detected
txt_subpop_cont <- if (is_subpop == is_subpop_detected)
"As expected, sub-populations were" else
"However, sub-populations were"
if (meta_group_truth$mods$subpop_detected[[2,2]] < 2) {
txt_subpop <- span(
"There was insufficient evidence in the", rv$data_type,
"dataset to detect sub-populations.")
txt_subpop_cont <- "With the simulations, sub-populations were"
} else if (is_subpop) {
txt_subpop <- span(
"We expected to detect a sub-population",
"through meta_group-analyses.")
} else {
txt_subpop <- span(
"We expected no sub-populations to be detected",
"through meta_group-analyses.")
}
col_subpop <- dplyr::case_when(
is_subpop == is_subpop_detected ~ "cl-sea-d",
meta_group_truth$mods$subpop_detected[[2,2]] < 2 ~ "cl-gld",
TRUE ~ "cl-dgr"
)
txt_subpop_detected <- span(
txt_subpop_cont, span(
if (is_subpop_detected) "detected" else "not detected",
class = col_subpop),
ifelse(meta_group$mods$subpop_detected[[2,2]] < 2,
"(though with \u0394AICc \uFF1C 2).",
"(\u0394AICc \uFF1E 2).")
)
expected_ratio <- .get_ratios(meta_group_truth)
observed_ratio <- .get_ratios(meta_group)
ratio <- paste0(round(observed_ratio$est, 2), ":1")
status_ratio <- list(
"truth" = dplyr::between(observed_ratio$est,
expected_ratio$lci,
expected_ratio$uci),
"one_expected" = expected_ratio$lci <= 1 &
expected_ratio$uci >= 1,
"one_observed" = observed_ratio$lci <= 1 &
observed_ratio$uci >= 1)
txt_ratio <- span(
"The", txt_target[[target]], "ratio", txt_ratio_order,
ifelse(
status_ratio$one_observed,
paste0("overlapped with one (i.e., ",
"no difference between groups)."),
paste0("did not overlap with one (ratio point estimate of ",
wrap_none(ratio, ")."))))
sufficient_simulations <- status_ratio$truth &&
(status_ratio$one_expected == status_ratio$one_observed) &&
!is.na(get_cri[[target]][["lci"]]) &&
!is.na(get_cri[[target]][["uci"]])
txt_simulations <- span(
style = paste(css_mono, css_bold),
if (sufficient_simulations) {
tagList("The number of simulations appears sufficient",
"to obtain valid", wrap_none(
txt_target[[target]], color = pal$sea, " ratios."))
} else {
tagList("The number of simulations appears insufficient",
"to obtain valid", wrap_none(
txt_target[[target]], color = pal$dgr, " ratios."))
}
)
txt_meta_groups <- p(txt_subpop,
txt_subpop_detected,
txt_ratio, txt_simulations)
} # end of if (rv$which_meta == "compare")
txt_nsims <- ifelse(
length(rv$simList) == 1,
"for a single simulation",
paste("for", length(rv$simList), "simulations"))
switch(meta_dt$status,
"Yes" = {
txt_mean <- span(
style = css_mono,
"The mean", txt_target[[target]], txt_nsims,
"is", span("within", class = "cl-sea"), "the",
paste0("\u00B1", rv$error_threshold * 100, "%"),
"error threshold.")
},
"Near" = {
txt_mean <- span(
style = css_mono,
"The mean", txt_target[[target]], txt_nsims,
"is", span("near", class = "cl-grn"), "the",
paste0("\u00B1", rv$error_threshold * 100, "%"),
"error threshold.")
},
"No" = {
txt_mean <- span(
style = css_mono,
"The mean", txt_target[[target]], txt_nsims,
span("falls outside", class = "cl-dgr"), "the",
paste0("\u00B1", rv$error_threshold * 100, "%"),
"error threshold.")
})
if (is.na(get_coi[[target]][["lci"]]) &&
is.na(get_coi[[target]][["uci"]])) {
txt_uncertainty <- "however, run more simulations to confirm."
} else {
txt_uncertainty <- ifelse(
get_coi[[target]][["uci"]] < .3 &&
get_coi[[target]][["lci"]] > -.3,
"with low uncertainty.",
"with high uncertainty.")
}
switch(
meta_dt$status,
"Yes" = {
txt_final <- span(
style = paste(css_mono, css_bold),
"The number of simulations appears",
wrap_none("sufficient", color = pal$sea),
"to accurately estimate mean",
wrap_none(txt_target[[target]], end = ","),
txt_uncertainty)
},
"Near" = {
txt_final <- span(
style = paste(css_mono, css_bold),
"The number of simulations appears",
wrap_none("insufficient", color = pal$grn),
"to accurately estimate man",
wrap_none(txt_target[[target]], end = ","),
txt_uncertainty)
},
"No" = {
txt_final <- span(
style = paste(css_mono, css_bold),
"The number of simulations appears",
wrap_none("insufficient", color = pal$dgr),
"to accurately estimate mean",
wrap_none(txt_target[[target]], end = ","),
txt_uncertainty)
})
if (length(get_cri) > 0) {
if (!is.na(get_cri[[target]][["lci"]]) &&
!is.na(get_cri[[target]][["uci"]])) {
txt_final <- tagList(
txt_final,
span(
style = paste("font-weight: 800;",
"font-family: var(--monosans);"),
"Please run more simulations in the corresponding",
shiny::icon("compass-drafting", class = "cl-sea"),
span("Analyses", class = "cl-sea"), "tab to confirm."))
}
}
index <- which(set_target == target)
if (index == 1) {
out_meta <- tagList(
span(txt_title[[target]],
style = set_style_title),
br(),
p(txt_mean,
txt_final,
txt_meta_groups))
} else {
out_meta <- tagList(
out_meta,
br(),
tagList(
span(txt_title[[target]],
style = set_style_title),
br(),
p(txt_mean,
txt_final,
txt_meta_groups)))
}
} # end of [target] loop
rv$report$meta <- tagList(
out_meta,
br(), txt_link_meta)
}) # end of observe
## Rendering complete report: -----------------------------------------
observe({
req(rv$which_question,
rv$report$species,
rv$report$schedule)
if (is.null(rv$report$analyses)) {
shinyjs::hide(id = "repBox_analyses")
shinyjs::hide(id = "section-comparison")
m <- length(rv$simList)
m <- ifelse(m == 1, "one simulation", "two simulations")
if (rv$which_meta != "none") {
shinyalert::shinyalert(
type = "warning",
title = "Warning",
text = tagList(span(
"Only", m, "currently available.",
"Run more", span("simulations", class = "cl-grn"),
"in one of the previous analyses tabs."
)),
html = TRUE,
size = "xs")
msg_log(
style = "error",
message = paste(
msg_danger("Insufficient simulations"),
"to generate a report."),
detail = "Return to the analyses tab(s).")
}
}
req(rv$report$analyses)
if (length(rv$which_question) > 1) {
shinyjs::hide(id = "section-comparison")
} else { shinyjs::show(id = "section-comparison") }
is_both <- ifelse(length(rv$which_question) > 1, "Yes", "No")
switch(
is_both,
"No" = {
if (rv$which_question == "Home range") {
output$end_report <- renderUI({
out <- tagList(
rv$report$species,
rv$report$schedule,
div(width = 12, align = "center",
style = "z-index: 999;",
shinyWidgets::awesomeCheckbox(
inputId = ns("scale_density"),
label = span("Scaled density to 1",
icon("wrench")),
value = TRUE)),
ggiraph::girafeOutput(
outputId = ns("repPlot_hr"),
width = "100%", height = "100%"),
uiOutput(ns("repPlotLegend1")),
# fluidRow(
# style = "text-align: center;",
# span("Precision of",
# wrap_none(span("designs",
# class = "cl-sea"), ":")) %>%
# tagAppendAttributes(class = "subheader"),
# actionButton(
# inputId = ns("explain_precision"),
# icon = icon("circle-question"),
# label = NULL,
# style = paste("background-color: #fff;",
# "color: black;",
# "padding: 0;",
# "margin: -5px 0 0 0;")) %>%
# bsplus::bs_attach_modal(id_modal = "modal_precision")
# ), # end of fluidRow
ggiraph::girafeOutput(
outputId = ns("repPlot_precision"),
width = "100%", height = "100%"),
uiOutput(ns("repPlotLegend2")),
rv$report$analyses) # end of tagList
}) # end of renderUI, "end_report"
} # end of hr only section
if (rv$which_question == "Speed & distance") {
output$end_report <- renderUI({
out <- tagList(
rv$report$species,
rv$report$schedule,
div(width = 12, align = "center",
style = "z-index: 999;",
shinyWidgets::awesomeCheckbox(
inputId = ns("scale_density"),
label = span("Scaled density to 1",
icon("wrench")),
value = TRUE)),
ggiraph::girafeOutput(
outputId = ns("repPlot_sd"),
width = "100%", height = "100%"),
uiOutput(ns("repPlotLegend1")),
# fluidRow(
# span("Precision of",
# wrap_none(span("designs",
# class = "cl-sea"), ":")) %>%
# tagAppendAttributes(class = "subheader"),
# actionButton(
# inputId = ns("explain_precision"),
# icon = icon("circle-question"),
# label = NULL,
# style = paste("background-color: #fff;",
# "color: black;",
# "padding: 0;",
# "margin: -5px 0 0 0;")) %>%
# bsplus::bs_attach_modal(
# id_modal = "modal_precision")
# ), # end of fluidRow
ggiraph::girafeOutput(
outputId = ns("repPlot_precision"),
width = "100%", height = "100%"),
uiOutput(ns("repPlotLegend2")),
rv$report$analyses) # end of tagList
}) # end of renderUI, "end_report"
} # end of sd only section
},
"Yes" = {
output$end_report <- renderUI({
out <- tagList(
rv$report$species,
rv$report$schedule,
rv$report$analyses)
})
output$end_report_both <- renderUI({
req(length(rv$which_question) > 1)
out <- div(
tagList(
splitLayout(
cellWidths = c("50%", "50%"),
tagList(
p(span("AKDE error", class = "cl-mdn")) %>%
tagAppendAttributes(class = "subheader"),
ggiraph::girafeOutput(
outputId = ns("repPlot_hr"),
width = "100%", height = "100%")),
tagList(
p(span("CTSD error", class = "cl-mdn")) %>%
tagAppendAttributes(class = "subheader"),
ggiraph::girafeOutput(
outputId = ns("repPlot_sd"),
width = "100%", height = "100%"))),
uiOutput(ns("repPlotLegend1")),
# fluidRow(
# span("Precision of",
# wrap_none(span("designs",
# class = "cl-sea"), ":")) %>%
# tagAppendAttributes(class = "subheader"),
# actionButton(
# inputId = ns("explain_precision"),
# icon = icon("circle-question"),
# label = NULL,
# style = paste("background-color: #fff;",
# "color: black;",
# "padding: 0;",
# "margin: -5px 0 0 0;")) %>%
# bsplus::bs_attach_modal(
# id_modal = "modal_precision")
# ), # end of fluidRow
ggiraph::girafeOutput(
outputId = ns("repPlot_precision"),
width = "100%", height = "100%"),
uiOutput(ns("repPlotLegend2")),
# div(id = "report_meta",
# style = paste0("background-color: #f4f4f4;",
# "padding: 20px;",
# "margin-top: 20px;"),
# rv$report$meta)
) # end of tagList
) # end of div
}) # end of renderUI, "end_report_both"
}) # end of switch
if (rv$which_meta == "none") {
shinyjs::show(id = "section-highlight_dur")
shinyjs::show(id = "section-highlight_dti")
shinyjs::hide(id = "repBox_meta")
} else {
shinyjs::hide(id = "section-highlight_dur")
shinyjs::hide(id = "section-highlight_dti")
shinyjs::show(id = "repBox_meta")
}
}) %>% bindEvent(input$build_report)
## Reporting COMPARISON (if available): ------------------------------
observe({
out_comp <- out_comp_hr <- span("")
ci <- ifelse(is.null(input$ci), .95, input$ci/100)
if (length(rv$which_question) == 1 &
"Home range" %in% rv$which_question) {
req(rv$highlight_dur)
highlighted_dur <- as.numeric(rv$highlight_dur)
est <- .err_to_txt(rv$hr_cri_new$est)
lci <- .err_to_txt(rv$hr_cri_new$lci)
uci <- .err_to_txt(rv$hr_cri_new$uci)
txt_level <- ifelse(
rv$hr_cri_new$uci < .3 & rv$hr_cri_new$lci > -.3,
"and with low", "but with high")
ideal_dur <- fix_unit(
("days" %#% rv$tau_p[[1]]$value[2] %#%
rv$tau_p[[1]]$unit[2]) * 10,
"days")
if (highlighted_dur >= ideal_dur$value) {
out_comp <- out_comp_hr <- p(
"Your new sampling duration would likely be sufficient",
"for", span("home range", class = "cl-grn"),
"estimation,", txt_level, "uncertainty:",
"for a duration of",
highlighted_dur, "days, there is a",
wrap_none(ci, "%", css = "cl-blk"),
"probability that the relative error will lie within",
wrap_none(lci, "%", css = "cl-blk"),
"and", wrap_none(uci, "%", end = ".", css = "cl-blk"))
} else {
out_comp <- out_comp_hr <- p(
"Your new sampling duration would likely be insufficient",
"for", span("home range", class = "cl-grn"),
"estimation.", br(),
"For a duration of", highlighted_dur,
"days, there is high uncertainty",
wrap_none("(", ci, "%", css = "cl-blk"),
"probability that the relative error will lie within",
wrap_none(lci, "%", css = "cl-blk"),
"and", wrap_none(uci, "%", end = ").", css = "cl-blk"))
}
} # end of 'Home range'
## Speed and distance estimation:
if (length(rv$which_question) == 1 &
"Speed & distance" %in% rv$which_question) {
req(rv$highlight_dti)
opts <- sims_speed[[1]] %>%
dplyr::select(.data$dti, .data$dti_notes) %>%
unique()
highlighted_dti <- opts$dti[
match(rv$highlight_dti, opts$dti_notes)]
out_dti <- fix_unit(highlighted_dti, "seconds", convert = TRUE)
est <- .err_to_txt(rv$sd_cri_new$est)
lci <- .err_to_txt(rv$sd_cri_new$lci)
uci <- .err_to_txt(rv$sd_cri_new$uci)
txt_level <- ifelse(
rv$sd_cri_new$uci < .3 & rv$sd_cri_new$lci > -.3,
"and with low", "but with high")
ideal_dti <- fix_unit(
(rv$tau_v[[1]]$value[2] %#%
rv$tau_v[[1]]$unit[2]) / 3, "seconds")
if (highlighted_dti <= ideal_dti$value) {
out_comp <- out_comp_sd <- p(
"Your new sampling interval would likely be sufficient",
"for", span("speed & distance", class = "cl-grn"),
"estimation,", txt_level, "uncertainty:",
"for a sampling interval of",
wrap_none(out_dti$value, " ", out_dti$unit, ", there"),
"is a", wrap_none(ci, "%", css = "cl-blk"),
"probability that the relative error will lie within",
wrap_none(lci, "%", css = "cl-blk"),
"and", wrap_none(uci, "%", end = ".", css = "cl-blk"))
} else {
out_comp <- out_comp_sd <- p(
"Your new sampling interval would likely be insufficient",
"for", span("speed & distance", class = "cl-grn"),
"estimation. For a sampling interval of",
wrap_none(out_dti$value, " ", out_dti$unit, ", there is"),
"high uncertainty",
wrap_none("(", ci, "%", css = "cl-blk"),
"probability that the relative error will lie within",
wrap_none(lci, "%", css = "cl-blk"),
"and", wrap_none(uci, "%", end = ").", css = "cl-blk"))
}
} # end of "Speed & distance"
### Both home range and speed & distance:
if (length(rv$which_question) > 1) {
out_analyses <-
span("Your new sampling schedule (...)",
"for", span("home range", class = "cl-grn"), "...",
"for", span("speed & distance", class = "cl-grn"), "...")
}
output$end_comparison <- renderUI({
div(id = "report_comparison",
style = paste0("background-color: #f4f4f4;",
"padding: 20px;",
"margin-top: 20px;"),
out_comp)
}) # end of renderUI, "end_comparison"
}) # end of observe
# PLOTS ---------------------------------------------------------------
## Rendering density plots: -------------------------------------------
output$repPlotLegend1 <- renderUI({
req(rv$which_question, rv$which_meta, input$ci)
req(rv$tau_p[[1]], rv$tau_v[[1]], rv$dur, rv$dti)
m <- ifelse(rv$which_meta == "none", 400, length(rv$simList))
taup_unit <- ifelse(rv$which_meta == "none",
"days", rv$tau_p[[1]]$unit[2])
input_taup <- taup_unit %#%
rv$tau_p[[1]]$value[2] %#% rv$tau_p[[1]]$unit[2]
input_tauv <- rv$tau_v[[1]]$value[2] %#% rv$tau_v[[1]]$unit[2]
input_dur <- taup_unit %#% rv$dur$value %#% rv$dur$unit
input_dti <- rv$dti$value %#% rv$dti$unit
dt_hr <- sims_hrange[[1]] %>%
dplyr::mutate(tau_p = round("days" %#% .data$tau_p, 1)) %>%
dplyr::mutate(duration = round("days" %#% .data$duration, 1))
out_taup <- dt_hr$tau_p[which.min(abs(dt_hr$tau_p - input_taup))]
if (rv$which_meta != "none") {
taup_unit <- fix_unit(input_taup, taup_unit)$unit
dur_for_hr <- paste0(round(input_dur, 1), " ", taup_unit, ",")
} else {
dur_for_hr <- paste(
dt_hr$dur[which.min(
abs(dt_hr$dur - input_dur))],
" ", taup_unit, ",")
}
dt_sd <- sims_speed[[1]] %>%
dplyr::mutate(dur = round("days" %#% .data$dur, 1))
out_tauv <- dt_sd$tau_v[which.min(abs(dt_sd$tau_v - input_tauv))]
out_tauv <- fix_unit(out_tauv, "seconds", convert = TRUE)
tauv_unit <- out_tauv$unit
dur_for_sd <- dt_sd$dur[which.min(abs(dt_sd$dur - input_dur))]
dt_sd <- sims_speed[[1]] %>%
dplyr::select(.data$dti, .data$dti_notes) %>%
unique()
out_dti <- dt_sd$dti[which.min(abs(dt_sd$dti - input_dti))]
dti_for_sd <- dt_sd$dti_notes[match(out_dti, dt_sd$dti)]
txt_highlight <- ""
add_txt_highlight <- FALSE
if (!is.null(rv$highlight_dur)) {
if (rv$highlight_dur != "") add_txt_highlight <- TRUE
}
if (!is.null(rv$highlight_dti)) {
if (rv$highlight_dti != "") add_txt_highlight <- TRUE
}
if (add_txt_highlight) {
txt_highlight <- span(
"The comparison requested is in",
wrap_none(
fontawesome::fa("diamond", fill = "black"),
" in ", span("black", style = "color: black;"), "."))
}
if (length(rv$which_question) > 1) {
if (rv$which_meta == "none") {
sim_hr_details <- paste0(
"movement processes with \u03C4\u209A = ",
out_taup, " day(s);")
sim_sd_details <- paste0(
"\u03C4\u1D65 = ",
out_tauv$value, " ", out_tauv$unit, ".")
} else {
input_tauv <- tauv_unit %#% input_tauv
tauv_unit <- abbrv_unit(tauv_unit)
sim_hr_details <- paste0(
"movement processes with \u03C4\u209A = ",
round(input_taup, 1), " ", taup_unit, ";")
sim_sd_details <- paste0(
"\u03C4\u1D65 = ",
round(input_tauv, 1), " ", tauv_unit, ".")
}
ui <- tagList(
fontawesome::fa("circle-exclamation", fill = pal$dgr),
span("Note:", class = "help-block-note"),
"These plots show the probability density of estimate errors",
"based on ", m, " simulations, with the medians",
wrap_none(
"(", fontawesome::fa("diamond"), " in lighter colors),"),
"and the", wrap_none(input$ci, "%"),
"credible intervals (shaded areas + lines).",
"For AKDE, the ", m, " simulations were based on",
sim_hr_details,
"for CTSD,",
sim_sd_details,
"Your simulation(s)' mean",
"estimate errors are the circles", wrap_none(
"(", fontawesome::fa("circle", prefer_type = "solid"), ")"),
"in darker colors.")
} else {
switch(
rv$which_question,
"Home range" = {
if (rv$which_meta == "none") {
sim_details <- paste0(
"movement processes with \u03C4\u209A = ",
out_taup, " day(s),")
} else {
sim_details <- paste0(
"movement processes with \u03C4\u209A = ",
round(input_taup, 1), " ", taup_unit, ";")
}
ui <- tagList(
fontawesome::fa("circle-exclamation", fill = pal$dgr),
span("Note:", class = "help-block-note"),
"This plot shows the probability density of estimate",
"errors based on", m, "simulations for",
sim_details,
"and for a sampling duration of",
dur_for_hr, "with the median",
wrap_none(
"(", fontawesome::fa("diamond", fill = pal$sea),
" in ", span("light blue", class = "cl-sea"), "),"),
"and the", wrap_none(input$ci, "%"),
"credible intervals (shaded area).",
"In contrast, your simulation(s)' mean",
"error is the circle", wrap_none(
"(", fontawesome::fa("circle", prefer_type = "solid",
fill = pal$sea_d), ")"),
"in", wrap_none(span("darker blue",
class = "cl-sea-d"), "."),
txt_highlight)
},
"Speed & distance" = {
input_tauv <- tauv_unit %#% input_tauv
tauv_unit <- abbrv_unit(tauv_unit)
if (rv$which_meta == "none") {
sim_details <- paste0(
"movement processes with \u03C4\u1D65 = ",
out_tauv$value, " ", out_tauv$unit)
} else {
sim_details <- paste0(
"movement processes with \u03C4\u1D65 = ",
round(input_tauv, 1), " ", tauv_unit)
}
ui <- tagList(
fontawesome::fa("circle-exclamation", fill = pal$dgr),
span("Note:", class = "help-block-note"),
"This plot shows the probability density of estimate",
"errors based on", m, "simulations for",
sim_details,
"and for a sampling interval of",
wrap_none(dti_for_sd, ","), "with the median",
wrap_none(
"(", fontawesome::fa("diamond", fill = pal$sea),
" in ", span("light blue", class = "cl-sea"), "),"),
"and the", wrap_none(input$ci, "%"),
"credible intervals (shaded area).",
"Your simulation(s)' mean",
"error is the circle", wrap_none(
"(", fontawesome::fa("circle", prefer_type = "solid",
fill = pal$sea_d), ")"),
"in", wrap_none(span("darker blue",
class = "cl-sea-d"), "."),
txt_highlight)
},
stop(paste0("No handler for ",
rv$which_question, "."))
)
}
ui <- span(class = "help-block", ui)
return(ui)
}) # end of renderUI, "repPlotLegend1"
#### Accuracy of home range simulations: ------------------------------
output$repPlot_hr <- ggiraph::renderGirafe({
req(rv$which_question, rv$which_meta, input$ci)
x <- NULL
m <- ifelse(rv$which_meta == "none", 400, length(rv$simList))
taup_unit <- ifelse(rv$which_meta == "none",
"days", rv$tau_p[[1]]$unit[2])
input_ci <- ifelse(is.null(input$ci), .95, input$ci/100)
input_taup <- taup_unit %#%
rv$tau_p[[1]]$value[2] %#% rv$tau_p[[1]]$unit[2]
input_dur <- taup_unit %#% rv$dur$value %#% rv$dur$unit
is_both <- FALSE
rv$ft_size <- 13
if (length(rv$which_question) > 1) {
is_both <- TRUE
rv$ft_size <- 16
}
tooltip_css <- paste(
"font-family: 'Roboto Condensed', sans-serif;",
"background-color: #222d32;",
"font-size: 14px;",
"padding: 5px;",
"color: #fff;")
# Preparing if () statements:
is_dur <- FALSE
if (!is.null(rv$highlight_dur))
if (!is.na(as.numeric(rv$highlight_dur)))
is_dur <- TRUE
is_log <- FALSE
if (!is.null(input$scale_density))
if (input$scale_density)
is_log <- TRUE
# Prepare datasets:
if (rv$which_meta == "none") {
dt_hr <- sims_hrange[[1]] %>%
dplyr::mutate(tau_p = round("days" %#% .data$tau_p, 1)) %>%
dplyr::mutate(duration = round("days" %#% .data$duration, 1))
out_taup <- dt_hr$tau_p[which.min(abs(dt_hr$tau_p - input_taup))]
dur_for_hr <- dt_hr$dur[which.min(abs(dt_hr$dur - input_dur))]
# Create density data frames:
ds1_hr <- dt_hr %>%
dplyr::filter(.data$tau_p == out_taup) %>%
dplyr::filter(.data$duration == dur_for_hr) %>%
stats::na.omit()
} else {
req(rv$hr$tbl)
dt_hr <- data.frame(
tau_p = input_taup,
duration = input_dur,
error = rv$hr$tbl$area_err,
error_lci = rv$hr$tbl$area_err_min,
error_uci = rv$hr$tbl$area_err_max)
out_taup <- input_taup
dur_for_hr <- input_dur
# Create density data frames:
ds1_hr <- stats::na.omit(dt_hr)
}
rv$report$dur_for_hr <- paste0(round(dur_for_hr, 1),
" ", taup_unit)
# Calculate median/ci:
med <- stats::median(ds1_hr$error)
ds1_hr <- stats::density(ds1_hr$error)
ds1_hr <- data.frame(x = ds1_hr$x, y = ds1_hr$y)
rv$report$ds1_hr <- data.frame(
"median" = med,
"max" = max(ds1_hr$x),
"min" = min(ds1_hr$x),
"done" = FALSE)
if (is_log) ds1_hr$y <- ds1_hr$y / max(ds1_hr$y)
ci1_hr <- subset(
ds1_hr, x >= rv$hr_cri$lci & x <= rv$hr_cri$uci)
if (is_dur) {
req(rv$hr_cri_new)
out_dur_new <- dt_hr$dur[
abs(dt_hr$dur - as.numeric(rv$highlight_dur)) %>%
which.min()]
ds2_hr <- dt_hr %>%
dplyr::filter(.data$tau_p == out_taup) %>%
dplyr::filter(.data$duration == out_dur_new) %>%
stats::na.omit()
med <- stats::median(ds2_hr$error)
ds2_hr <- stats::density(ds2_hr$error)
ds2_hr <- data.frame(x = ds2_hr$x, y = ds2_hr$y)
rv$report$ds2_hr <- data.frame(
"median" = med,
"max" = max(ds2_hr$x),
"min" = min(ds2_hr$x))
rv$hr_cri_new <- suppressWarnings(
.extract_cri(ds2_hr$x, ci = input_ci))
if (is_log) ds2_hr$y <- ds2_hr$y / max(ds2_hr$y)
ci2_hr <- subset(
ds2_hr, x >= rv$hr_cri_new$lci & x <= rv$hr_cri_new$uci)
hr_p1 <- ggplot2::geom_line(
data = ds2_hr, mapping = ggplot2::aes(
x = .data$x,
y = .data$y),
col = pal$mdn, linetype = "dotted")
hr_p2 <- ggplot2::geom_area(
data = ci2_hr,
mapping = ggplot2::aes(x = .data$x,
y = .data$y),
alpha = 0.2, fill = pal$mdn)
hr_p3 <- ggplot2::geom_segment(
data = rv$hr_cri_new,
mapping = ggplot2::aes(
x = .data$lci,
xend = .data$uci,
y = 0, yend = 0,
col = "est_new", linetype = "est_new"),
size = .8) %>%
suppressWarnings()
hr_p4 <- ggplot2::geom_point(
mapping = ggplot2::aes(
x = rv$report$ds2_hr[["median"]],
y = 0,
col = "est_new", shape = "est_new"),
size = 6) %>%
suppressWarnings()
}
lbl <- c(
paste0("AKDE error"),
paste0("Median AKDE error + ", rv$hr_cri$ci * 100,
"% HDI for ", rv$report$dur_for_hr))
brk <- c("now", "est")
val_fill <- val_col <- c("now" = pal$sea_d, "est" = pal$sea)
val_linetype <- c("now" = "blank", "est" = "solid")
val_shape <- c("now" = 19, "est" = 18)
override_size <- c(.8, .8)
override_stroke <- c(4, 4)
if (is_dur) {
lbl <- c(
lbl, paste0("Median AKDE error + ", rv$hr_cri$ci * 100,
"% HDI for ", rv$highlight_dur, " days"))
brk <- c(brk, "est_new")
val_fill <- val_col <- c(val_fill, "est_new" = pal$mdn)
val_linetype <- c(val_linetype, "est_new" = "solid")
val_shape <- c(val_shape, "est_new" = 18)
override_size <- c(override_size, .8)
override_stroke <- c(override_stroke, 4)
}
y_lab <- ifelse(input$scale_density,
"Probability density", "Density")
p <- ds1_hr %>%
ggplot2::ggplot(ggplot2::aes(x = .data$x,
y = .data$y)) +
ggplot2::geom_vline(xintercept = 0, alpha = 1) +
{ if (is_dur) hr_p1 } +
{ if (is_dur) hr_p2 } +
ggplot2::geom_line(
ggplot2::aes(col = "est"),
linetype = "dotted") +
{ if (!is.na(rv$hr_cri$lci) && !is.na(rv$hr_cri$lci))
ggplot2::geom_area(
data = ci1_hr,
mapping = ggplot2::aes(x = .data$x,
y = .data$y,
fill = "est"),
alpha = 0.4) } +
{ if (is_dur) hr_p3 } +
{ if (!is.na(rv$hr_cri$lci) && !is.na(rv$hr_cri$lci))
ggplot2::geom_segment(
data = ~ head(.x, 1),
mapping = ggplot2::aes(
x = rv$hr_cri$lci,
xend = rv$hr_cri$uci,
y = 0, yend = 0, col = "est",
linetype = "est"),
size = .8) %>%
suppressWarnings() } +
{ if (is_dur) hr_p4 } +
ggplot2::geom_point(
data = ~ head(.x, 1),
mapping = ggplot2::aes(
x = rv$report$ds1_hr[["median"]], y = 0,
col = "est", shape = "est"),
size = 6) %>%
suppressWarnings() +
{ if (!is.null(rv$hrErr))
ggplot2::geom_point(
data = ~ head(.x, 1),
ggplot2::aes(x = mean(rv$hrErr$est, na.rm = TRUE),
y = 0, col = "now", shape = "now"),
size = 6, alpha = .7) %>%
suppressWarnings()
} +
ggplot2::scale_x_continuous(labels = scales::percent) +
{ if (!is.null(input$scale_density))
if (input$scale_density)
ggplot2::scale_y_continuous(breaks = seq(0, 1, .5))
} +
ggplot2::scale_color_manual(
name = "", labels = lbl, breaks = brk,
values = val_col) +
{ if (!is.na(rv$hr_cri$lci) && !is.na(rv$hr_cri$lci))
ggplot2::scale_fill_manual(
name = "", labels = lbl, breaks = brk,
values = val_fill) } +
{ if (!is.na(rv$hr_cri$lci) && !is.na(rv$hr_cri$lci))
ggplot2::scale_linetype_manual(
name = "", labels = lbl, breaks = brk,
values = val_linetype) } +
ggplot2::scale_shape_manual(
name = "", labels = lbl, breaks = brk,
values = val_shape) +
ggplot2::labs(x = "Estimate error (%)",
y = y_lab) +
theme_movedesign(font_available = rv$is_font,
ft_size = rv$ft_size,
title_y = FALSE) +
ggplot2::theme(
legend.position = "none",
axis.title.x = ggplot2::element_blank())
p
rv$report$ds1_hr[["done"]] <- TRUE
ggiraph::girafe(
ggobj = suppressMessages(suppressWarnings(p)),
width_svg = 6, height_svg = 4,
options = list(
ggiraph::opts_zoom(max = 5),
ggiraph::opts_hover(
css = paste("r: 4pt;",
"fill: #006263;",
"stroke: #006263;")),
ggiraph::opts_selection(
type = "single",
css = paste("r: 4pt;",
"fill: #004647;",
"stroke: #004647;")),
ggiraph::opts_toolbar(saveaspng = FALSE)))
}) %>% # end of renderGirafe // repPlot_hr
bindEvent(list(input$build_report,
input$scale_density,
rv$highlight_dur))
#### Accuracy of speed & distance simulations: ------------------------
observe({
req(rv$simList, rv$tau_v[[1]],
rv$dur, rv$dti,
input$ci, rv$which_question)
is_both <- FALSE
rv$ft_size <- 13
if (!is.null(rv$which_question)) {
if (length(rv$which_question) > 1) {
is_both <- TRUE
rv$ft_size <- 16
}
}
req("Speed & distance" %in% rv$which_question)
input_ci <- ifelse(is.null(input$ci), .95, input$ci/100)
input_tauv <- rv$tau_v[[1]]$value[2] %#% rv$tau_v[[1]]$unit[2]
input_dur <- "days" %#% rv$dur$value %#% rv$dur$unit
input_dti <- rv$dti$value %#% rv$dti$unit
tooltip_css <- paste(
"font-family: 'Roboto Condensed', sans-serif;",
"background-color: #222d32;",
"font-size: 14px;",
"padding: 5px;",
"color: #fff;")
# Preparing if () statements:
is_dti <- FALSE
if (!is.null(rv$highlight_dti)) {
if (rv$highlight_dti != "")
is_dti <- TRUE
}
is_log <- FALSE
if (!is.null(input$scale_density)) {
if (input$scale_density)
is_log <- TRUE
}
# Prepare datasets:
dt_sd <- sims_speed[[1]] %>%
dplyr::mutate(dur = round("days" %#% .data$dur, 0)) %>%
dplyr::mutate(tau_p = round("days" %#% .data$tau_p, 0))
sd_opts <- sims_speed[[1]] %>%
dplyr::mutate(dur = round("days" %#% .data$dur, 0)) %>%
dplyr::select(.data$dti, .data$dti_notes) %>%
unique()
out_tauv <- dt_sd$tau_v[which.min(abs(dt_sd$tau_v - input_tauv))]
dur_for_sd <- dt_sd$dur[which.min(abs(dt_sd$dur - input_dur))]
out_dti <- dt_sd$dti[which.min(abs(dt_sd$dti - input_dti))]
txt_dti <- sd_opts$dti_notes[match(out_dti, sd_opts$dti)]
rv$report$txt_dti <- txt_dti
# Create density data frames:
ds1_sd <- dt_sd %>%
dplyr::filter(.data$tau_v == out_tauv) %>%
dplyr::filter(.data$dur == dur_for_sd) %>%
dplyr::filter(.data$dti == out_dti) %>%
stats::na.omit()
med <- stats::median(ds1_sd$error)
ds1_sd <- stats::density(ds1_sd$error)
ds1_sd <- data.frame(x = ds1_sd$x, y = ds1_sd$y)
rv$report$ds1_sd <- data.frame(
"median" = med,
"max" = max(ds1_sd$x),
"min" = min(ds1_sd$x),
"done" = FALSE)
if (is_log) ds1_sd$y <- ds1_sd$y / max(ds1_sd$y)
ci1_sd <- subset(
ds1_sd, x >= rv$sd_cri$lci & x <= rv$sd_cri$uci)
if (is_dti) {
req(rv$sd_cri_new)
dti_new <- sd_opts$dti[match(rv$highlight_dti,
sd_opts$dti_notes)]
out_dti_new <- dt_sd$dti[which.min(abs(dt_sd$dti - dti_new))]
txt_dti_new <- sd_opts$dti_notes[match(out_dti_new,
sd_opts$dti)]
rv$report$txt_dti_new <- txt_dti_new
ds2_sd <- dt_sd %>%
dplyr::filter(.data$tau_v == out_tauv) %>%
dplyr::filter(.data$dur == dur_for_sd) %>%
dplyr::filter(.data$dti == out_dti_new) %>%
stats::na.omit()
med <- stats::median(ds2_sd$error)
if (nrow(ds2_sd) > 2) {
msg_log(style = "warning",
message = paste0("Duration too low for ",
msg_warning("comparison"), "."))
shinyFeedback::showToast(
type = "error",
message = "Interval invalid.",
.options = list(
timeOut = 2500,
extendedTimeOut = 3500,
progressBar = TRUE,
closeButton = TRUE,
preventDuplicates = TRUE,
positionClass = "toast-bottom-right")
)
req(nrow(ds2_sd) > 2)
}
ds2_sd <- stats::density(ds2_sd$error)
ds2_sd <- data.frame(x = ds2_sd$x, y = ds2_sd$y)
rv$report$ds2_sd <- data.frame(
"median" = med,
"max" = max(ds2_sd$x),
"min" = min(ds2_sd$x))
rv$sd_cri_new <- suppressWarnings(
.extract_cri(ds2_sd$x, ci = input_ci))
if (is_log) ds2_sd$y <- ds2_sd$y / max(ds2_sd$y)
ci2_sd <- subset(
ds2_sd, x >= rv$sd_cri_new$lci & x <= rv$sd_cri_new$uci)
sd_p1 <- ggplot2::geom_line(
data = ds2_sd, mapping = ggplot2::aes(x = .data$x,
y = .data$y),
col = pal$mdn, linetype = "dotted")
sd_p2 <- ggplot2::geom_area(
data = ci2_sd,
mapping = ggplot2::aes(x = .data$x,
y = .data$y),
alpha = 0.2, fill = pal$mdn)
sd_p3 <- ggplot2::geom_segment(
data = rv$sd_cri_new,
mapping = ggplot2::aes(
x = .data$lci,
xend = .data$uci,
y = 0, yend = 0,
col = "est_new", linetype = "est_new"),
size = .8)
sd_p4 <- ggplot2::geom_point(
data = ds2_sd,
mapping = ggplot2::aes(
x = mean(.data$x), y = 0,
col = "est_new", shape = "est_new"),
size = 6)
}
lbl <- c(
paste0("CTSD error"),
paste0("Median CTSD error + ", rv$sd_cri$ci * 100,
"% HDI for ", txt_dti))
brk <- c("now", "est")
val_fill <- val_col <- c(
"now" = ifelse(is_both, pal$grn_d, pal$sea_d),
"est" = ifelse(is_both, pal$grn, pal$sea))
val_linetype <- c("now" = "blank", "est" = "solid")
val_shape <- c("now" = 19, "est" = 18)
override_size <- c(.8, .8)
override_stroke <- c(4, 4)
if (is_dti) {
lbl <- c(
lbl, paste0("Median CTSD error + ", rv$sd_cri$ci * 100,
"% HDI for ", txt_dti_new))
brk <- c(brk, "est_new")
val_fill <- val_col <- c(val_fill, "est_new" = pal$mdn)
val_linetype <- c(val_linetype, "est_new" = "solid")
val_shape <- c(val_shape, "est_new" = 18)
override_size <- c(override_size, .8)
override_stroke <- c(override_stroke, 4)
}
y_lab <- ifelse(input$scale_density,
"Probability density", "Density")
#### Speed simulations:
output$repPlot_sd <- ggiraph::renderGirafe({
p <- ds1_sd %>%
ggplot2::ggplot(ggplot2::aes(x = .data$x,
y = .data$y)) +
ggplot2::geom_vline(xintercept = 0, alpha = 1) +
{if (is_dti) sd_p1 } +
{if (is_dti) sd_p2 } +
ggplot2::geom_line(
ggplot2::aes(col = "est"),
linetype = "dotted") +
{ if (!is.na(rv$sd_cri$lci) && !is.na(rv$sd_cri$lci))
ggplot2::geom_area(
data = ci1_sd,
mapping = ggplot2::aes(x = .data$x,
y = .data$y,
fill = "est"),
alpha = 0.4) } +
{ if (is_dti) sd_p3 } +
{ if (!is.na(rv$sd_cri$lci) && !is.na(rv$sd_cri$lci))
ggplot2::geom_segment(
data = ~ head(.x, 1),
mapping = ggplot2::aes(
x = rv$sd_cri$lci,
xend = rv$sd_cri$uci,
y = 0, yend = 0, col = "est",
linetype = "est"),
size = .8)
} +
{ if (is_dti) sd_p4 } +
ggplot2::geom_point(
data = ~ head(.x, 1),
mapping = ggplot2::aes(
x = mean(ds1_sd$x), y = 0,
col = "est", shape = "est"),
size = 6) +
{ if (!is.null(rv$speedErr))
ggplot2::geom_point(
data = ~ head(.x, 1),
ggplot2::aes(x = mean(rv$speedErr$est, na.rm = TRUE),
y = 0, col = "now", shape = "now"),
size = 6, alpha = .7)
} +
ggplot2::scale_x_continuous(labels = scales::percent) +
{ if (!is.null(input$scale_density))
if (input$scale_density)
ggplot2::scale_y_continuous(breaks = seq(0, 1, .5))
} +
ggplot2::scale_color_manual(
name = "", labels = lbl, breaks = brk,
values = val_col) +
{ if (!is.na(rv$sd_cri$lci) && !is.na(rv$sd_cri$lci))
ggplot2::scale_fill_manual(
name = "", labels = lbl, breaks = brk,
values = val_fill) } +
{ if (!is.na(rv$sd_cri$lci) && !is.na(rv$sd_cri$lci))
ggplot2::scale_linetype_manual(
name = "", labels = lbl, breaks = brk,
values = val_linetype) } +
ggplot2::scale_shape_manual(
name = "", labels = lbl, breaks = brk,
values = val_shape) +
ggplot2::labs(x = "Estimate error (%)",
y = y_lab) +
theme_movedesign(font_available = rv$is_font,
ft_size = rv$ft_size,
title_y = FALSE) +
ggplot2::theme(
legend.position = "none",
axis.title.x = ggplot2::element_blank())
rv$report$ds1_sd[["done"]] <- TRUE
ggiraph::girafe(
ggobj = p,
width_svg = 6, height_svg = 4,
options = list(
ggiraph::opts_zoom(max = 5),
ggiraph::opts_hover(
css = paste("r: 4pt;",
"fill: #006263;",
"stroke: #006263;")),
ggiraph::opts_selection(
type = "single",
css = paste("r: 4pt;",
"fill: #004647;",
"stroke: #004647;")),
ggiraph::opts_toolbar(saveaspng = FALSE)))
}) # end of renderGirafe // repPlot_sd
}) %>% # end of observe,
bindEvent(list(input$build_report,
input$scale_density,
rv$highlight_dti))
## Rendering precision plot: ------------------------------------------
output$repPlotLegend2 <- renderUI({
req(rv$which_question, rv$which_meta, input$ci)
req(rv$which_meta == "none")
req(rv$tau_p[[1]], rv$tau_v[[1]], rv$dur, rv$dti)
m <- ifelse(rv$which_meta == "none", 400, length(rv$simList))
taup_unit <- ifelse(rv$which_meta == "none",
"days", rv$tau_p[[1]]$unit[2])
input_taup <- taup_unit %#%
rv$tau_p[[1]]$value[2] %#% rv$tau_p[[1]]$unit[2]
input_dur <- taup_unit %#% rv$dur$value %#% rv$dur$unit
input_dti <- rv$dti$value %#% rv$dti$unit
dt_hr <- sims_hrange[[1]] %>%
dplyr::mutate(tau_p = round("days" %#% .data$tau_p, 1)) %>%
dplyr::mutate(duration = round("days" %#% .data$duration, 1))
out_taup <- dt_hr$tau_p[which.min(abs(dt_hr$tau_p - input_taup))]
if (rv$which_meta != "none") {
taup_unit <- fix_unit(input_taup, taup_unit)$unit
dur_for_hr <- paste0(round(input_dur, 1),
" ", taup_unit, ",")
} else {
dur_for_hr <- paste(
round(dt_hr$dur[which.min(abs(dt_hr$dur - input_dur))], 1),
" ", taup_unit, ",")
}
if (!is.null(rv$tau_v)) {
input_tauv <- rv$tau_v[[1]]$value[2] %#% rv$tau_v[[1]]$unit[2]
dt_sd <- sims_speed[[1]] %>%
dplyr::mutate(dur = round("days" %#% .data$dur, 1))
out_tauv <- dt_sd$tau_v[which.min(abs(dt_sd$tau_v - input_tauv))]
out_tauv <- fix_unit(out_tauv, "seconds", convert = TRUE)
}
dt_sd <- sims_speed[[1]] %>%
dplyr::mutate(dur = round(input_dur, 0)) %>%
dplyr::select(.data$dti, .data$dti_notes) %>%
unique()
out_dti <- dt_sd$dti[which.min(abs(dt_sd$dti - input_dti))]
dti_for_sd <- dt_sd$dti_notes[match(out_dti, dt_sd$dti)]
dti_for_sd
if (length(rv$which_question) > 1) {
ui <- tagList(
fontawesome::fa("circle-exclamation", fill = pal$dgr),
span("Note:", class = "help-block-note"),
"This plot has the same information as above,",
"but showing each expected error in a different line.",
"If your simulations",
wrap_none(
"(", fontawesome::fa("circle", prefer_type = "solid"),
" and ", fontawesome::fa("diamond"), " in darker colors)"),
"do not show lines, then the credible intervals (CIs) were",
"too large or the number of simulations",
wrap_none("insufficient", color = pal$dgr, end = "."),
"Run more simulations to obtain valid CIs.")
} else {
switch(
rv$which_question,
"Home range" = {
if (rv$which_meta == "none") {
sim_details <- paste0(
"movement processes with \u03C4\u209A = ",
out_taup, " day(s),")
} else {
sim_details <- paste0(
"movement processes with \u03C4\u209A = ",
round(input_taup, 1), " ", taup_unit, ",")
}
ui <- tagList(
fontawesome::fa("circle-exclamation", fill = pal$dgr),
span("Note:", class = "help-block-note"),
"This plot shows the expected error",
"based on", m, "simulations for",
sim_details,
"for a sampling duration of",
dur_for_hr, "with the medians",
wrap_none(
"(", fontawesome::fa("diamond", fill = pal$sea),
" in ", span("light blue", class = "cl-sea"), "),"),
"and the", wrap_none(input$ci, "%"),
"credible intervals (lines in",
wrap_none(span("light blue", class = "cl-sea"), ")."),
"For comparison, your simulation(s)",
"mean error (with CIs if applicable) is the circle",
wrap_none(
"(", fontawesome::fa("circle", prefer_type = "solid",
fill = pal$sea_d), ")"),
"in", wrap_none(span("darker blue",
class = "cl-sea-d"), "."))
},
"Speed & distance" = {
# if (rv$which_meta == "none") {
# sim_details <- paste0(
# "movement processes with \u03C4\u1D65 = ",
# out_tauv$value, out_tauv$unit)
# } else {
# sim_details <- paste0(
# "movement processes with \u03C4\u1D65 = ",
# out_tauv$value, out_tauv$unit)
# }
ui <- tagList(
fontawesome::fa("circle-exclamation", fill = pal$dgr),
span("Note:", class = "help-block-note"),
"This plot shows the expected error",
"based on", m, "simulations for",
"movement processes with \u03C4\u1D65 = ",
out_tauv$value, out_tauv$unit,
"for a sampling interval of",
wrap_none(dti_for_sd, ","), "with the medians",
wrap_none(
"(", fontawesome::fa("diamond", fill = pal$sea),
" in ", span("light blue", class = "cl-sea"), "),"),
"and the", wrap_none(input$ci, "%"),
"credible intervals (lines in",
wrap_none(span("light blue", class = "cl-sea"), ")."),
"For comparison, your simulation(s)",
"mean error (with CIs, if applicable) is the circle",
wrap_none(
"(", fontawesome::fa("circle", prefer_type = "solid",
fill = pal$sea_d), ")"),
"in", wrap_none(span("darker blue",
class = "cl-sea-d"), "."))
},
stop(paste0("No handler for ",
rv$which_question, "."))
)
}
ui <- span(class = "help-block", ui)
return(ui)
}) # end of renderUI, "repPlotLegend2"
output$repPlot_precision <- ggiraph::renderGirafe({
req(rv$hr_cri, rv$sd_cri)
req(rv$which_meta == "none")
is_both <- FALSE
if (!is.null(rv$which_question))
if (length(rv$which_question) > 1)
is_both <- TRUE
is_dur <- FALSE
if (!is.null(rv$highlight_dur)) {
if (!is.na(as.numeric(rv$highlight_dur)))
is_dur <- TRUE
}
is_dti <- FALSE
if (!is.null(rv$highlight_dti)) {
if (rv$highlight_dti != "")
is_dti <- TRUE
}
girafe_height <- 2
details <- data.frame(
# To plot:
question = character(0),
group = character(0),
type = character(0),
value = numeric(0),
lci = numeric(0),
uci = numeric(0),
# For scale_manual:
label = character(0),
fill = character(0),
col = character(0),
linetype = character(0),
shape = numeric(0))
details_length <- 0
xmin <- xmax <- NA
if (is_dur && !is_both) {
req(rv$report$ds2_hr, rv$hr_cri_new)
details <- details %>%
dplyr::add_row(
question = "Home range",
group = "est_new",
type = "hr_est_new",
value = rv$report$ds2_hr[["median"]],
lci = rv$hr_cri_new$lci,
uci = rv$hr_cri_new$uci,
label = paste0("AKDE error for ",
rv$highlight_dur, " days"),
fill = pal$mdn,
col = pal$mdn,
linetype = "solid",
shape = 18)
girafe_height <- 2.5
details_length <- details_length + 1
xmin <- min(xmin, rv$report$ds2_hr[["min"]])
xmax <- max(xmax, rv$report$ds2_hr[["max"]])
}
if (is_dti && !is_both) {
req(rv$report$ds2_sd, rv$sd_cri_new)
details <- details %>%
dplyr::add_row(
question = "Speed & distance",
group = "est_new",
type = "sd_est_new",
value = rv$report$ds2_sd[["median"]],
lci = rv$sd_cri_new$lci,
uci = rv$sd_cri_new$uci,
label = paste0("CTSD error for ",
rv$report$txt_dti_new),
fill = pal$mdn,
col = pal$mdn,
linetype = "solid",
shape = 18)
girafe_height <- 2.5
details_length <- details_length + 1
xmin <- min(xmin, rv$report$ds2_sd[["min"]])
xmax <- max(xmax, rv$report$ds2_sd[["max"]])
}
if ("Home range" %in% rv$which_question) {
req(rv$report$ds1_hr[["done"]])
details <- details %>%
dplyr::add_row(
question = "Home range",
group = "est",
type = "hr_est",
value = rv$report$ds1_hr[["median"]],
lci = rv$hr_cri$lci,
uci = rv$hr_cri$uci,
label = paste0("AKDE error for ",
rv$report$dur_for_hr),
fill = pal$sea,
col = pal$sea,
linetype = "solid",
shape = 18)
if (!is.null(rv$simList)) {
ci <- ifelse(is.null(input$ci), .95, input$ci/100)
err <- suppressWarnings(.extract_cri(rv$hrErr$est, ci))
err <- data.frame(
lci = ifelse(is.null(err$lci), NA, err$lci),
mean = mean(rv$hrErr$est, na.rm = TRUE),
uci = ifelse(is.null(err$uci), NA, err$uci))
}
input_dur <- "days" %#% rv$dur$value %#% rv$dur$unit
details <- details %>%
dplyr::add_row(
question = "Home range",
group = "now",
type = "hr_now",
value = ifelse(!is.null(rv$hrErr), err[[2]], NA),
lci = ifelse(!is.null(rv$hrErr), err[[1]], NA),
uci = ifelse(!is.null(rv$hrErr), err[[3]], NA),
label = paste0("AKDE error for ",
round(input_dur, 1), " days"),
fill = pal$sea_d,
col = pal$sea_d,
linetype = "dashed",
shape = 19)
details_length <- details_length + 2
xmin <- rv$report$ds1_hr[["min"]]
xmax <- rv$report$ds1_hr[["max"]]
} # end of hr
if ("Speed & distance" %in% rv$which_question) {
req(rv$report$ds1_sd[["done"]])
details <- details %>%
dplyr::add_row(
question = "Speed & distance",
group = "est",
type = "sd_est",
value = rv$report$ds1_sd[["median"]],
lci = rv$sd_cri$lci,
uci = rv$sd_cri$uci,
label = paste0("CTSD error for ",
rv$report$txt_dti),
fill = ifelse(is_both, pal$grn, pal$sea),
col = ifelse(is_both, pal$grn, pal$sea),
linetype = "solid",
shape = 18)
if (!is.null(rv$simList)) {
ci <- ifelse(is.null(input$ci), .95, input$ci/100)
err <- suppressWarnings(
.extract_cri(rv$speedErr$est, ci = ci))
err <- data.frame(
lci = err$lci,
mean = mean(rv$speedErr$est, na.rm = TRUE),
uci = err$uci)
}
input_dur <- "days" %#% rv$dur$value %#% rv$dur$unit
input_dti <- rv$dti$value %#% rv$dti$unit
sd_opts <- movedesign::fixrates %>%
dplyr::select(.data$dti, .data$dti_notes) %>%
unique()
out_dti <- sd_opts$dti[which.min(abs(sd_opts$dti - input_dti))]
input_dti <- sd_opts$dti_notes[match(out_dti, sd_opts$dti)]
input_dti
details <- details %>%
dplyr::add_row(
question = "Speed & distance",
group = "now",
type = "sd_now",
value = ifelse(!is.null(rv$speedErr), err[[2]], NA),
lci = ifelse(!is.null(rv$speedErr), err[[1]], NA),
uci = ifelse(!is.null(rv$speedErr), err[[3]], NA),
label = paste0("CTSD error for ", input_dti),
fill = ifelse(is_both, pal$grn_d, pal$sea_d),
col = ifelse(is_both, pal$grn_d, pal$sea_d),
linetype = "dashed",
shape = 19)
details_length <- details_length + 2
xmin <- min(xmin, rv$report$ds1_sd[["min"]])
xmax <- max(xmax, rv$report$ds1_sd[["max"]])
} # end of sd
details <- details %>%
dplyr::filter(!is.na(.data$value)) %>%
dplyr::mutate(group = factor(.data$group,
levels = c("est_new",
"est",
"now"))) %>%
droplevels()
if (is_both) {
add_val <- ifelse(is.null(rv$speedErr), 1, 0)
details_length <- 2 + add_val
girafe_height <- 3
}
override_size <- rep(4, details_length)
override_stroke <- rep(1, details_length)
y_labels <- rep("___", details_length)
p <- ggplot2::ggplot() +
ggplot2::geom_vline(xintercept = 0) +
ggplot2::geom_point(
data = details,
mapping = ggplot2::aes(
x = .data$value,
y = .data$type,
group = .data$question,
col = .data$type,
fill = .data$type,
shape = .data$type),
size = 5) +
ggplot2::geom_segment(
data = details,
mapping = ggplot2::aes(
x = .data$lci,
y = .data$type,
group = .data$question,
col = .data$type,
xend = .data$uci,
yend = .data$type),
linewidth = .8) +
{ if (is_both) {
ggplot2::scale_x_continuous(
labels = scales::percent)
} else {
ggplot2::scale_x_continuous(
labels = scales::percent,
limits = c(xmin, xmax)) }
} +
ggplot2::scale_y_discrete(
labels = y_labels) +
ggplot2::scale_color_manual(
name = "", labels = details$label,
breaks = details$type,
values = details$col) +
ggplot2::scale_fill_manual(
name = "", labels = details$label,
breaks = details$type,
values = details$fill) +
ggplot2::scale_shape_manual(
name = "", labels = details$label,
breaks = details$type,
values = details$shape) +
ggplot2::scale_linetype_manual(
name = "", labels = details$label,
breaks = details$type,
values = details$linetype) +
ggplot2::labs(x = "Estimate error (%)", y = "") +
theme_movedesign(font_available = rv$is_font) +
ggplot2::theme(
axis.text.y = ggplot2::element_text(color = "#ffffff"),
legend.position = "bottom",
legend.direction = "vertical",
legend.title = ggplot2::element_blank()) +
ggplot2::guides(
shape = ggplot2::guide_legend(
override.aes = list(
alpha = 1,
size = override_size,
stroke = override_stroke)))
ggiraph::girafe(
ggobj = p,
width_svg = 6, height_svg = girafe_height,
options = list(
ggiraph::opts_zoom(max = 5),
ggiraph::opts_hover(
css = paste("r: 4pt;",
"fill: #006263;",
"stroke: #006263;")),
ggiraph::opts_selection(
type = "single",
css = paste("r: 4pt;",
"fill: #004647;",
"stroke: #004647;")),
ggiraph::opts_toolbar(saveaspng = FALSE)))
}) # end of renderGirafe // repPlot_precision
## Rendering simulations + quick comparison plots: --------------------
output$repPlotLegend3 <- renderUI({
req(rv$which_question,
input$ci, rv$tau_p[[1]], rv$tau_v[[1]], rv$dur, rv$dti)
req(length(rv$which_question) == 1)
input_taup <- "days" %#%
rv$tau_p[[1]]$value[2] %#% rv$tau_p[[1]]$unit[2]
input_dur <- "days" %#% rv$dur$value %#% rv$dur$unit
input_dti <- rv$dti$value %#% rv$dti$unit
dat <- sims_hrange[[1]] %>%
dplyr::mutate(tau_p = round("days" %#% .data$tau_p, 1)) %>%
dplyr::mutate(duration = round("days" %#% .data$duration, 1))
out_taup <- dat$tau_p[which.min(abs(dat$tau_p - input_taup))]
switch(
rv$which_question,
"Home range" = {
max_dur <- max(dat$duration)
unit <- ifelse(out_taup == 1, "day", "days")
ui <- tagList(
fontawesome::fa("triangle-exclamation", fill = pal$dgr),
span("Warning:", class = "help-block-note"),
"This plot shows only the mean expected errors and",
"(confidence intervals) simulated for",
"movement processes with \u03C4\u209A = ",
span(out_taup, unit, class = "cl-dgr"),
"and for different sampling",
"durations (from 1 day to", wrap_none(max_dur, " days)"),
"in grey.",
"As sampling duration increases, we will expect lower",
"estimate errors (points) and",
"lower uncertainty (shaded area).", br(),
"These are based on aggregated information from",
"pre-run simulations, so values may not match.",
"Evaluate with",
wrap_none("caution", css = "cl-dgr", "."))
},
"Speed & distance" = {
dt_sd <- sims_speed[[1]] %>%
dplyr::mutate(duration = round("days" %#% .data$dur, 1)) %>%
dplyr::select(.data$duration) %>%
unique()
max_dur <- max(dt_sd$duration)
ui <- tagList(
fontawesome::fa("circle-exclamation", fill = pal$dgr),
span("Note:", class = "help-block-note"),
"This plot shows only the mean expected errors and",
"(confidence intervals) simulated",
"for different sampling durations",
"(from 1 day to", wrap_none(max_dur, " days)"), "in grey.",
"As sampling duration increases, we will expect lower",
"estimate errors (points) and",
"lower uncertainty (shaded area).", br(),
"These are based on aggregated information from",
"pre-run simulations, so values may not match.",
"Evaluate with",
wrap_none("caution", css = "cl-dgr", "."))
},
stop(paste0("No handler for ",
rv$which_question, "."))
)
ui <- span(class = "help-block", ui)
return(ui)
}) # end of renderUI, "repPlotLegend3"
output$repPlot_comp_hr <- ggiraph::renderGirafe({
req(rv$which_meta, rv$hrErr)
tooltip_css <- paste(
"font-family: 'Roboto Condensed', sans-serif;",
"background-color: #222d32;",
"font-size: 14px;",
"padding: 5px;",
"color: #fff;")
input_taup <- "days" %#%
rv$tau_p[[1]]$value[2] %#% rv$tau_p[[1]]$unit[2]
input_dur <- "days" %#% rv$dur$value %#% rv$dur$unit
dat <- sims_hrange[[2]] %>%
dplyr::mutate(tau_p = round("days" %#% .data$tau_p, 1)) %>%
dplyr::mutate(duration = round("days" %#% .data$duration, 1))
index_taup <- which.min(abs(dat$tau_p - input_taup))
filtering <- dat$tau_p[index_taup]
newdat_filtered <- dat_filtered <- dat %>%
dplyr::filter(tau_p == filtering)
index_dur <- which.min(abs(dat_filtered$duration - input_dur))
if (rv$which_meta != "none") {
req(rv$hr$tbl)
newdat_filtered <- data.frame(
tau_p = input_taup,
duration = input_dur,
error = mean(rv$hr$tbl$area_err, na.rm = TRUE),
error_lci = mean(rv$hr$tbl$area_err_min, na.rm = TRUE),
error_uci = mean(rv$hr$tbl$area_err_max, na.rm = TRUE))
index_dur <- 1
}
dat$id <- 1:nrow(dat)
if (rv$highlight_dur > 0) {
dur_NEW <- as.numeric(rv$highlight_dur)
is_highlight <- TRUE
} else {
is_highlight <- NULL
}
pd <- ggplot2::position_dodge(width = 0.6)
if (rv$highlight_dur > 0) {
newdat <- dat_filtered %>%
dplyr::filter(.data$duration == dur_NEW)
y_start <- dplyr::pull(newdat, .data$error_lci)
y_end <- dplyr::pull(newdat, .data$error_uci)
p1 <- ggplot2::geom_segment(
ggplot2::aes(x = .data$dur_NEW,
xend = .data$dur_NEW,
y = .data$y_start,
yend = .data$y_end),
col = pal$mdn,
linetype = "solid",
size = 1.5, alpha = .8)
p2 <- ggiraph::geom_point_interactive(
data = newdat,
mapping = ggplot2::aes_string(
x = "duration",
y = "error"),
size = 3, col = pal$mdn)
}
p <- ggplot2::ggplot() +
ggplot2::geom_ribbon(
data = dat_filtered,
mapping = ggplot2::aes_string(
x = "duration",
y = "error",
ymin = "error_lci",
ymax = "error_uci"),
col = NA, fill = "grey90",
alpha = .5) +
ggplot2::geom_line(
data = dat_filtered,
mapping = ggplot2::aes_string(x = "duration",
y = "error",
group = "tau_p"),
col = "grey20", linetype = "dotted",
size = 0.5) +
ggplot2::geom_point(
data = dat_filtered,
mapping = ggplot2::aes_string(x = "duration",
y = "error",
group = "tau_p"),
size = 2.5, shape = 18, col = "grey40") +
ggplot2::geom_segment(
data = newdat_filtered[index_dur,],
ggplot2::aes_string(x = "duration",
xend = "duration",
y = "error_lci",
yend = "error_uci"),
col = pal$sea,
linetype = "solid",
size = 1.5, alpha = .8) +
ggplot2::geom_point(
data = newdat_filtered[index_dur,],
mapping = ggplot2::aes_string(x = "duration",
y = "error",
group = "tau_p"),
col = pal$sea,
position = pd, size = 5) +
ggplot2::geom_hline(yintercept = 0,
linetype = "solid", size = .5) +
ggplot2::scale_y_continuous(labels = scales::percent) +
ggplot2::labs(x = "Sampling duration (in days)",
y = "Estimate error (%)") +
{ if (rv$highlight_dur > 0) p1 } +
{ if (rv$highlight_dur > 0) p2 } +
theme_movedesign(font_available = rv$is_font,
ft_size = rv$ft_size) +
ggplot2::theme(legend.position = "none")
ggiraph::girafe(
ggobj = p,
width_svg = 6, height_svg = 4.5,
options = list(
ggiraph::opts_tooltip(css = tooltip_css),
ggiraph::opts_zoom(max = 5),
ggiraph::opts_hover(
css = paste("r: 4pt;",
"fill: #006263;",
"stroke: #006263;")),
ggiraph::opts_selection(
type = "single",
css = paste("r: 4pt;",
"fill: #004647;",
"stroke: #004647;"))))
}) # end of renderGirafe // repPlot_comp_hr
output$repPlot_comp_sd <- ggiraph::renderGirafe({
req(rv$speedErr)
tooltip_css <- paste(
"font-family: 'Roboto Condensed', sans-serif;",
"background-color: #222d32;",
"font-size: 14px;",
"padding: 5px;",
"color: #fff;")
input_tauv <- rv$tau_v[[1]]$value[2] %#% rv$tau_v[[1]]$unit[2]
input_dur <- "days" %#% rv$dur$value %#% rv$dur$unit
input_dti <- rv$dti$value %#% rv$dti$unit
reveal_if <- FALSE
if (!is.null(rv$highlight_dti)) {
if (rv$highlight_dti != "") reveal_if <- TRUE
}
sims <- sims_speed[[2]]
dat <- sims %>%
dplyr::mutate(dur = round("days" %#% .data$dur, 0))
dat$id <- 1:nrow(dat)
opts <- sims %>%
dplyr::select(.data$dti, .data$dti_notes) %>%
unique()
if (reveal_if) {
dti_new <- opts$dti[match(rv$highlight_dti,
opts$dti_notes)]
is_highlight <- TRUE
} else {
is_highlight <- NULL
}
index_dur <- which.min(abs(dat$dur - input_dur))
filtering_dur <- dat$dur[index_dur]
index_tauv <- which.min(abs(dat$tau_v - input_tauv))
filtering_tauv <- dat$tau_v[index_tauv]
index_dti <- which.min(abs(dat$dti - input_dti))
filtering_dti <- dat$dti[index_dti]
dat_filtered <- dat %>%
dplyr::filter(.data$tau_v == filtering_tauv) %>%
dplyr::filter(.data$dti == filtering_dti) %>%
stats::na.omit()
pd <- ggplot2::position_dodge(width = 0.6)
if (reveal_if) {
newdat <- dat %>%
dplyr::filter(.data$tau_v == filtering_tauv) %>%
dplyr::filter(.data$dti == dti_new) %>%
stats::na.omit()
}
p <- ggplot2::ggplot(
data = dat_filtered,
mapping = ggplot2::aes(
x = .data$dur,
y = .data$error,
group = as.factor(.data$dti),
ymin = .data$error - .data$ci,
ymax = .data$error + .data$ci)) +
ggplot2::geom_hline(yintercept = 0,
linetype = "solid", size = .5) +
ggplot2::geom_ribbon(
fill = pal$sea,
alpha = .2) +
ggplot2::geom_line(
col = pal$sea, linetype = "dotted",
size = 0.5) +
ggplot2::geom_point(
size = 2.5, shape = 18, col = pal$sea) +
{ if (reveal_if)
ggplot2::geom_ribbon(
data = newdat,
ggplot2::aes(x = .data$dur,
y = .data$error,
group = as.factor(.data$dti),
ymin = .data$error - .data$ci,
ymax = .data$error + .data$ci),
alpha = .1, fill = pal$mdn,
position = ggplot2::position_dodge(width = 0.3)) } +
{ if (reveal_if)
ggplot2::geom_line(
data = newdat,
ggplot2::aes(x = .data$dur,
y = .data$error,
group = as.factor(.data$dti)),
size = .5, alpha = .8,
linetype = "solid", col = pal$mdn,
position = ggplot2::position_dodge(
width = 0.3)) } +
{ if (reveal_if)
ggiraph::geom_point_interactive(
data = newdat,
ggplot2::aes(x = .data$dur,
y = .data$error,
group = as.factor(.data$dti)),
size = 3, col = pal$mdn) } +
ggplot2::scale_y_continuous(labels = scales::percent) +
ggplot2::labs(x = "Sampling duration (in days)",
y = "Estimate error (%)") +
theme_movedesign(font_available = rv$is_font) +
ggplot2::theme(legend.position = "none")
ggiraph::girafe(
ggobj = p,
width_svg = 6, height_svg = 4.5,
options = list(
ggiraph::opts_tooltip(css = tooltip_css),
ggiraph::opts_zoom(max = 5),
ggiraph::opts_hover(
css = paste("r: 4pt;",
"fill: #006263;",
"stroke: #006263;")),
ggiraph::opts_selection(
type = "single",
css = paste("r: 4pt;",
"fill: #004647;",
"stroke: #004647;"))))
}) # end of renderGirafe // repPlot_comp_sd
output$reportPlots_error <- renderUI({
req(rv$which_question)
if ("Home range" %in% rv$which_question) {
out <- out_hr <- ggiraph::girafeOutput(
outputId = ns("repPlot_comp_hr"),
width = "100%", height = "100%")
}
if ("Speed & distance" %in% rv$which_question) {
out <- out_sd <- ggiraph::girafeOutput(
outputId = ns("repPlot_comp_sd"),
width = "100%", height = "100%")
}
# if (length(rv$which_question) > 1) {
# out <- tagList(out_hr, out_sd)
# }
return(out)
}) # end of renderUI, "reportPlots_error"
# TABLES --------------------------------------------------------------
## Final report table (combining previous results): -------------------
build_tbl_report <- reactive({
n_sims <- length(rv$simList)
dt_dv <- rv$dev$tbl
dt_dv <- dt_dv %>% dplyr::slice_tail(n = n_sims)
if ("Home range" %in% rv$which_question) {
req(rv$hr$tbl)
dt_hr <- rv$hr$tbl
dt_hr <- dplyr::filter(dt_hr, .data$data == "Initial")
dt_hr <- dplyr::slice_tail(dt_hr, n = n_sims)
}
if ("Speed & distance" %in% rv$which_question) {
req(rv$sd$tbl)
dt_sd <- rv$sd$tbl
dt_sd <- dplyr::filter(dt_sd, .data$data == "Initial")
dt_sd <- dplyr::slice_tail(dt_sd, n = n_sims)
}
dat <- data.frame(
seed = numeric(0),
device = character(0),
taup = character(0),
tauv = character(0),
sigma = character(0),
dur = character(0),
dti = character(0),
n = numeric(0),
N1 = numeric(0),
N2 = numeric(0))
tmpdat <- suppressMessages(dplyr::full_join(dat, dt_dv))
if ("Home range" %in% rv$which_question) {
tmphr <- dt_hr %>% dplyr::select(-c(.data$device))
tmpdat <- suppressMessages(
tmpdat %>%
dplyr::group_by(.data$seed) %>%
dplyr::full_join(dt_hr))
}
if ("Speed & distance" %in% rv$which_question) {
tmpdat <- suppressMessages(
tmpdat %>%
dplyr::full_join(dt_sd))
}
tmpdat <- tmpdat %>%
dplyr::distinct() %>%
dplyr::group_by(.data$seed) %>%
dplyr::summarize(dplyr::across(
dplyr::everything(),
~ifelse(all(is.na(.)), NA, .[!is.na(.)][1])))
return(tmpdat)
}) # end of reactive
observe({
req(rv$active_tab == 'report',
rv$which_question,
rv$dev$tbl,
rv$simList,
!rv$is_report)
rv$report$tbl <- build_tbl_report()
dat <- rv$report$tbl
if (length(rv$simList) == 1) {
if (nrow(dat) >= 2) {
if (all(dat[nrow(dat) - 1,3:7] == dat[nrow(dat), 3:7]))
dat <- dplyr::coalesce(dat[1, ], dat[2, ])
}
}
rv$report$tbl <- dplyr::distinct(dat)
rv$is_report <- TRUE
set.seed(NULL)
}) # end of observe
output$endTable <- reactable::renderReactable({
req(rv$report$tbl,
rv$is_analyses,
rv$which_question,
rv$is_report)
if (length(rv$which_question) == 2)
req(rv$hr_completed, rv$sd_completed)
choices <- choices_subset <- c(
"group",
"taup",
"tauv",
"sigma",
"dur",
"dti",
"n",
"N1",
"N2",
"area",
"area_err",
"area_err_min",
"area_err_max",
"ctsd",
"ctsd_err",
"ctsd_err_min",
"ctsd_err_max",
"dist",
"dist_err")
if (length(rv$which_question) == 1) {
if (rv$which_question == "Home range")
choices_subset <- choices[c(1:8, 10:13)]
if (rv$which_question == "Speed & distance")
choices_subset <- choices[c(1:7, 9, 14:19)]
}
nms <- data.frame(
group = "Group",
taup = "\u03C4\u209A",
tauv = "\u03C4\u1D65",
sigma = "\u03C3\u209A",
dur = "Duration",
dti = "Interval",
n = "n",
N1 = "N (area)",
N2 = "N (speed)",
area = "Area",
area_err = "Error",
area_err_min = "95% LCI",
area_err_max = "95% UCI",
ctsd = "Speed",
ctsd_err = "Error",
ctsd_err_min = "95% LCI",
ctsd_err_max = "95% UCI",
dist = "Distance",
dist_err = "Error")
dat <- dplyr::select(rv$report$tbl,
-c(.data$device, .data$seed))
if (!rv$grouped) {
dat <- dplyr::select(dat, -.data$group)
choices_subset <- choices_subset[-1]
}
if (!is.null(choices_subset)) {
dat <- dplyr::select(dat, choices_subset)
}
if ("Home range" %in% rv$which_question) {
nms_sizes <- reactable::colGroup(
name = "Sample sizes",
columns = c("n", "N1"))
nms_hr <- reactable::colGroup(
name = "Home range",
columns = c("area",
"area_err",
"area_err_min",
"area_err_max"))
colgroups <- list(nms_sizes,
nms_hr)
}
if ("Speed & distance" %in% rv$which_question) {
nms_sizes <- reactable::colGroup(
name = "Sample sizes",
columns = c("n", "N2"))
nms_ctsd <- reactable::colGroup(
name = "Speed",
columns = c("ctsd",
"ctsd_err",
"ctsd_err_min",
"ctsd_err_max"))
nms_dist <- reactable::colGroup(
name = "Distance",
columns = c("dist", "dist_err"))
colgroups <- list(nms_sizes,
nms_ctsd,
nms_dist)
}
if (length(rv$which_question) == 2) {
nms_sizes <- reactable::colGroup(
name = "Sample sizes",
columns = c("n", "N1", "N2"))
colgroups <- list(nms_sizes,
nms_hr,
nms_ctsd,
nms_dist)
}
namedcolumns <- list(
group = if ("group" %in% choices_subset) {
reactable::colDef(
minWidth = 80, name = nms[1, "group"]) },
taup = if ("taup" %in% choices_subset) {
reactable::colDef(
minWidth = 100, name = nms[1, "taup"],
style = list(fontWeight = "bold")) },
tauv = if ("tauv" %in% choices_subset) {
reactable::colDef(
minWidth = 100, name = nms[1, "tauv"],
style = list(fontWeight = "bold")) },
sigma = if ("sigma" %in% choices_subset) {
reactable::colDef(
minWidth = 100, name = nms[1, "sigma"]) },
dur = if ("dur" %in% choices_subset) {
reactable::colDef(
minWidth = 80, name = nms[1, "dur"],
style = list(fontWeight = "bold")) },
dti = if ("dti" %in% choices_subset) {
reactable::colDef(
minWidth = 80, name = nms[1, "dti"],
style = list(fontWeight = "bold")) },
n = if ("n" %in% choices_subset) {
reactable::colDef(
name = nms[1, "n"],
style = format_num,
format = reactable::colFormat(
separators = TRUE, locale = "en-US", digits = 0)) },
N1 = if ("N1" %in% choices_subset) {
reactable::colDef(
minWidth = 80, name = nms[1, "N1"],
style = format_num,
format = reactable::colFormat(
separators = TRUE, locale = "en-US", digits = 1)) },
N2 = if ("N2" %in% choices_subset) {
reactable::colDef(
minWidth = 80, name = nms[1, "N2"],
style = format_num,
format = reactable::colFormat(
separators = TRUE, locale = "en-US", digits = 1)) },
area = if ("area" %in% choices_subset) {
reactable::colDef(
minWidth = 100, name = nms[1, "area"]) },
area_err = if ("area_err" %in% choices_subset) {
reactable::colDef(
minWidth = 80, name = nms[1, "area_err"],
style = format_perc,
format = reactable::colFormat(
separators = TRUE, locale = "en-US",
percent = TRUE, digits = 1)) },
area_err_min = if ("area_err_min" %in% choices_subset) {
reactable::colDef(
minWidth = 80, name = nms[1, "area_err_min"],
style = format_perc,
format = reactable::colFormat(
separators = TRUE, locale = "en-US",
percent = TRUE, digits = 1)) },
area_err_max = if ("area_err_max" %in% choices_subset) {
reactable::colDef(
minWidth = 80, name = nms[1, "area_err_max"],
style = format_perc,
format = reactable::colFormat(
separators = TRUE, locale = "en-US",
percent = TRUE, digits = 1)) },
ctsd = if ("ctsd" %in% choices_subset) {
reactable::colDef(
minWidth = 100, name = nms[1, "ctsd"]) },
ctsd_err = if ("ctsd_err" %in% choices_subset) {
reactable::colDef(
minWidth = 80, name = nms[1, "ctsd_err"],
style = format_perc,
format = reactable::colFormat(
separators = TRUE, locale = "en-US",
percent = TRUE, digits = 1)) },
ctsd_err_min = if ("ctsd_err_min" %in% choices_subset) {
reactable::colDef(
minWidth = 80, name = nms[1, "ctsd_err_min"],
style = format_perc,
format = reactable::colFormat(
separators = TRUE, locale = "en-US",
percent = TRUE, digits = 1)) },
ctsd_err_max = if ("ctsd_err_max" %in% choices_subset) {
reactable::colDef(
minWidth = 80, name = nms[1, "ctsd_err_max"],
style = format_perc,
format = reactable::colFormat(
separators = TRUE, locale = "en-US",
percent = TRUE, digits = 1)) },
dist = if ("dist" %in% choices_subset) {
reactable::colDef(
minWidth = 100, name = nms[1, "dist"]) },
dist_err = if ("dist_err" %in% choices_subset) {
reactable::colDef(
minWidth = 80, name = nms[1, "dist_err"],
style = format_perc,
format = reactable::colFormat(
separators = TRUE, locale = "en-US",
percent = TRUE, digits = 1)) }
)
namedcolumns[sapply(namedcolumns, is.null)] <- NULL
dt <- reactable::reactable(
dat,
compact = TRUE,
highlight = TRUE,
striped = TRUE,
defaultPageSize = 5,
paginationType = "jump",
showPageSizeOptions = TRUE,
pageSizeOptions = c(5, 10, 20),
showPageInfo = FALSE,
defaultColDef =
reactable::colDef(
headerClass = "rtable_header",
align = "center",
minWidth = 50),
columns = namedcolumns,
columnGroups = colgroups
) # end of reactable
return(dt)
}) # end of renderReactable // endTable
# BLOCKS --------------------------------------------------------------
## Timescale parameters: ----------------------------------------------
observe({
req(rv$tau_p[[1]])
mod_blocks_server(
id = "repBlock_taup",
rv = rv, type = "tau", name = "tau_p",
input_name = list(
chr = "data_taup0",
html = wrap_none("Position autocorrelation ",
"(\u03C4", tags$sub("p"), ")")))
}) # end of observe
observe({
req(rv$tau_v[[1]])
mod_blocks_server(
id = "repBlock_tauv",
rv = rv, type = "tau", name = "tau_v",
input_name = list(
chr = "data_tauv0",
html = wrap_none("Velocity autocorrelation ",
"(\u03C4", tags$sub("v"), ")")))
}) # end of observe
## Location variance: -------------------------------------------------
observe({
req(rv$sigma[[1]])
mod_blocks_server(
id = "repBlock_sigma",
rv = rv, type = "sigma", name = "sigma",
input_name = list(
chr = "data_sigma0",
html = wrap_none("Location variance ",
"(\u03C3", tags$sub("p"), ")")))
}) # end of observe
## Sampling schedule: -------------------------------------------------
observe({
req(rv$active_tab == 'report')
req(rv$datList, rv$id)
mod_blocks_server(
id = "repBlock_dur",
rv = rv, data = rv$simList,
type = "dur")
mod_blocks_server(
id = "repBlock_dti",
rv = rv, data = rv$simList,
type = "dti")
}) # end of observe
## Sample sizes: ------------------------------------------------------
output$repUI_sizes <- renderUI({
req(rv$dev$is_valid)
if (is.null(rv$which_question) ||
length(rv$which_question) > 1) {
out <- tagList(
mod_blocks_ui(ns("repBlock_n")),
splitLayout(
mod_blocks_ui(ns("repBlock_Narea")),
mod_blocks_ui(ns("repBlock_Nspeed"))
))
}
if (length(rv$which_question) == 1 &&
"Home range" %in% rv$which_question) {
out <- splitLayout(
mod_blocks_ui(ns("repBlock_n")),
mod_blocks_ui(ns("repBlock_Narea"))) }
if (length(rv$which_question) == 1 &&
"Speed & distance" %in% rv$which_question) {
out <- splitLayout(
mod_blocks_ui(ns("repBlock_n")),
mod_blocks_ui(ns("repBlock_Nspeed"))) }
return(out)
}) # end of renderUI, "repUI_sizes"
observe({
req(rv$active_tab == 'report', rv$simList)
mod_blocks_server(
id = "repBlock_n",
rv = rv, data = rv$simList, type = "n",
options = list(rightBorder = FALSE,
marginBottom = TRUE))
}) # end of observe
observe({
req(rv$active_tab == 'report', rv$simList, rv$simfitList)
mod_blocks_server(
id = "repBlock_Narea",
rv = rv, data = rv$simList, obj = rv$simfitList,
type = "N", name = "area")
}) # end of observe
observe({
req(rv$active_tab == 'report',
rv$ctsdList, rv$simList, rv$simfitList)
mod_blocks_server(
id = "repBlock_Nspeed",
rv = rv, data = rv$simList, obj = rv$ctsdList,
type = "N", name = "speed")
}) # end of observe
## Outputs: -----------------------------------------------------------
observe({
req(!is.null(rv$simList), rv$hrErr, rv$which_meta)
req(nrow(rv$hrErr) == length(rv$simList))
if ("Home range" %in% rv$which_question) {
shinyjs::show(id = "repBox_hr_err")
} else { shinyjs::hide(id = "repBox_hr_err") }
if (rv$which_meta == "none") {
mod_blocks_server(
id = "repBlock_hrErr",
rv = rv, type = "hr", name = "hrErr")
} else {
req(rv$metaErr)
mod_blocks_server(
id = "repBlock_hrErr",
rv = rv, type = "hr", name = "metaErr")
}
}) # end of observe
observe({
req(rv$simList, rv$speedErr, rv$which_meta)
req(nrow(rv$speedErr) == length(rv$simList))
if ("Speed & distance" %in% rv$which_question)
shinyjs::show(id = "repBox_speed_err") else
shinyjs::hide(id = "repBox_speed_err")
if (rv$which_meta == "none") {
mod_blocks_server(
id = "repBlock_speedErr",
rv = rv, type = "ctsd", name = "speedErr")
} else {
req(rv$metaErr)
mod_blocks_server(
id = "repBlock_speedErr",
rv = rv, type = "ctsd", name = "metaErr")
}
}) # end of observe
# observe({
# req(rv$ctsdList, rv$distErr)
# req(nrow(rv$distErr) == length(rv$simList))
#
# if ("Speed & distance" %in% rv$which_question)
# shinyjs::show(id = "repBox_dist_err") else
# shinyjs::hide(id = "repBox_dist_err")
#
# mod_blocks_server(
# id = "repBlock_distErr",
# rv = rv, type = "dist", name = "distErr")
#
# }) # end of observe
}) # end of moduleServer
}
## To be copied in the UI
# mod_tab_report_ui("tab_report_1")
## To be copied in the server
# mod_tab_report_server("tab_report_1")
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.