Skip to content

Commit

Permalink
⚡ prepare for main
Browse files Browse the repository at this point in the history
  • Loading branch information
@ecoisilva
ecoisilva committed Feb 9, 2024
1 parent da65eed commit 74ed8a5
Show file tree
Hide file tree
Showing 9 changed files with 165 additions and 125 deletions.
17 changes: 10 additions & 7 deletions R/app_server.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -34,6 +34,9 @@ app_server <- function(input, output, session) {
species = NULL,
id = NULL,

which_m = NULL,
which_meta = "none",

groups = list(intro = list(A = c(), B = c()),
final = list(A = c(), B = c())),
grouped = FALSE,
Expand Down Expand Up @@ -171,14 +174,14 @@ app_server <- function(input, output, session) {
shinydashboard::menuSubItem(
tabName = "ctsd",
text = info$ctsd[["title"]],
icon = shiny::icon(info$ctsd[["icon"]])) },
icon = shiny::icon(info$ctsd[["icon"]])) } #,

if (is.null(rv$which_meta) ||
req(rv$which_meta) != "none") {
shinydashboard::menuSubItem(
tabName = "meta",
text = info$meta[["title"]],
icon = shiny::icon(info$meta[["icon"]])) }
# if (is.null(rv$which_meta) ||
# req(rv$which_meta) != "none") {
# shinydashboard::menuSubItem(
# tabName = "meta",
# text = info$meta[["title"]],
# icon = shiny::icon(info$meta[["icon"]])) }
)),

# Tab 8: Report
Expand Down
4 changes: 2 additions & 2 deletions R/mod_comp_m.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -279,9 +279,9 @@ mod_comp_m_server <- function(id, rv, set_analysis = NULL) {
# bindEvent(rv$is_analyses)

observe({
req(length(rv$simList) > 1)
req(rv$which_meta, length(rv$simList) > 1)

wheel_step <- ifelse("compare" %in% req(rv$which_meta), 2, 1)
wheel_step <- ifelse("compare" %in% rv$which_meta, 2, 1)
shinyWidgets::updateAutonumericInput(
session = session,
inputId = "nsims",
Expand Down
118 changes: 59 additions & 59 deletions R/mod_tab_about.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -38,17 +38,17 @@ mod_tab_about_ui <- function(id) {
wrap_none(span("speed and distance traveled",
class = "cl-sea-d"), ".")),
br(),
p(style = "max-width: 685px;",
span(class = "help-block",
style = "text-align: center !important;",

fontawesome::fa("circle-exclamation", fill = "#dd4b39"),
span("Note:", class = "help-block-note"),
"This is the", span( "development", class = "cl-dgr"),
"version of the application, currently undergoing",
"testing. Use with caution, as it may crash",
"or behave unexpectedly.")),
p(style = "margin-bottom: 35px;")
# p(style = "max-width: 685px;",
# span(class = "help-block",
# style = "text-align: center !important;",
#
# fontawesome::fa("circle-exclamation", fill = "#dd4b39"),
# span("Note:", class = "help-block-note"),
# "This is the", span( "development", class = "cl-dgr"),
# "version of the application, currently undergoing",
# "testing. Use with caution, as it may crash",
# "or behave unexpectedly.")),
# p(style = "margin-bottom: 35px;")

) # end of column (text)
), # end of box // intro
Expand Down Expand Up @@ -138,53 +138,53 @@ mod_tab_about_ui <- function(id) {
style = "color: var(--danger);")),
individual = TRUE),

div(class = "btn-nobg",
shinyWidgets::radioGroupButtons(
inputId = ns("which_meta"),
label = span("Analytical target:",
style = "font-size: 16px;"),
choiceNames = c(
tagList(span(
"Single", span("individual",
class = "cl-sea"))),
tagList(span(
"Mean of",
span("sampled population",
class = "cl-sea"))),
tagList(span(
"Compare", span("two", class = "cl-sea"),
"sampled populations"))),
choiceValues = list("none", "mean", "compare"),
selected = character(0),
checkIcon = list(
yes = tags$i(class = "fa fa-check-square",
style = "color: var(--sea);"),
no = tags$i(class = "fa fa-square-o",
style = "color: var(--danger);")),
direction = "vertical")),

div(class = "btn-nobg",
shinyWidgets::radioGroupButtons(
inputId = ns("which_m"),
label = span("Deployment:",
style = "font-size: 16px;"),
choiceNames = c(
tagList(span(em(
'"I plan to deploy a',
span("set", class = "cl-jgl"),
'number of VHF/GPS tags."'))),
tagList(span(em(
'"I want to determine the',
span("minimum", class = "cl-jgl"),
'number of VHF/GPS tags."')))),
choiceValues = list("set_m", "get_m"),
selected = character(0),
checkIcon = list(
yes = tags$i(class = "fa fa-check-square",
style = "color: var(--jungle);"),
no = tags$i(class = "fa fa-square-o",
style = "color: var(--danger);")),
direction = "vertical"))
# div(class = "btn-nobg",
# shinyWidgets::radioGroupButtons(
# inputId = ns("which_meta"),
# label = span("Analytical target:",
# style = "font-size: 16px;"),
# choiceNames = c(
# tagList(span(
# "Single", span("individual",
# class = "cl-sea"))),
# tagList(span(
# "Mean of",
# span("sampled population",
# class = "cl-sea"))),
# tagList(span(
# "Compare", span("two", class = "cl-sea"),
# "sampled populations"))),
# choiceValues = list("none", "mean", "compare"),
# selected = character(0),
# checkIcon = list(
# yes = tags$i(class = "fa fa-check-square",
# style = "color: var(--sea);"),
# no = tags$i(class = "fa fa-square-o",
# style = "color: var(--danger);")),
# direction = "vertical")),
#
# div(class = "btn-nobg",
# shinyWidgets::radioGroupButtons(
# inputId = ns("which_m"),
# label = span("Deployment:",
# style = "font-size: 16px;"),
# choiceNames = c(
# tagList(span(em(
# '"I plan to deploy a',
# span("set", class = "cl-jgl"),
# 'number of VHF/GPS tags."'))),
# tagList(span(em(
# '"I want to determine the',
# span("minimum", class = "cl-jgl"),
# 'number of VHF/GPS tags."')))),
# choiceValues = list("set_m", "get_m"),
# selected = character(0),
# checkIcon = list(
# yes = tags$i(class = "fa fa-check-square",
# style = "color: var(--jungle);"),
# no = tags$i(class = "fa fa-square-o",
# style = "color: var(--danger);")),
# direction = "vertical"))

) # end of div
) # end of fluidRow
Expand Down Expand Up @@ -274,7 +274,7 @@ mod_tab_about_server <- function(id, rv) {
observe({
rv$which_data <- input$which_data
rv$which_question <- input$which_question
rv$which_meta <- input$which_meta
# rv$which_meta <- input$which_meta

req(input$which_m)
}, label = "o-about_workflow")
Expand Down
26 changes: 18 additions & 8 deletions R/mod_tab_ctsd.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -779,17 +779,28 @@ mod_tab_ctsd_server <- function(id, rv) {
shinyalert::shinyalert(
title = "Oops!",
text = span(
"Data selected is from individual",
HTML(paste0(span(rv$id, class = "cl-dgr"),
",")), "but parameters are from",
HTML(paste0(span(rv$tmp$id, class = "cl-dgr"), ".")),
br(), "Please extract parameters in the",
"Data selected is from different individual(s).",
"Please extract parameters in the",
icon("paw", class = "cl-mdn"),
span("Species", class = "cl-mdn"), "tab",
"for the appropriate individual before",
"estimating home range."),
html = TRUE,
size = "xs")
# shinyalert::shinyalert(
# title = "Oops!",
# text = span(
# "Data selected is from individual",
# HTML(paste0(span(rv$id, class = "cl-dgr"),
# ",")), "but parameters are from",
# HTML(paste0(span(rv$tmp$id, class = "cl-dgr"), ".")),
# br(), "Please extract parameters in the",
# icon("paw", class = "cl-mdn"),
# span("Species", class = "cl-mdn"), "tab",
# "for the appropriate individual before",
# "estimating home range."),
# html = TRUE,
# size = "xs")
}

## If no signature of velocity persists in data:
Expand Down Expand Up @@ -1512,8 +1523,8 @@ mod_tab_ctsd_server <- function(id, rv) {
if (rv$grouped) {
nm <- names(rv$simList)[[sim_no]]
group <- ifelse(nm %in% rv$groups[[2]]$A, "A", "B")
truth <- ctsd_truth[[group]]
}
truth <- ctsd_truth[[group]]

out_est_df <- out_est_df %>%
dplyr::add_row(seed = rv$seedList[[sim_no]],
Expand All @@ -1528,7 +1539,6 @@ mod_tab_ctsd_server <- function(id, rv) {
lci = ((sdList[[i]][[1]] %#% tmpunit) - truth) / truth,
est = ((sdList[[i]][[2]] %#% tmpunit) - truth) / truth,
uci = ((sdList[[i]][[3]] %#% tmpunit) - truth) / truth)

}

rv$speedDatList <- dataList
Expand Down Expand Up @@ -2591,7 +2601,7 @@ mod_tab_ctsd_server <- function(id, rv) {
req(rv$ctsdList, rv$speedEst, rv$speedErr)
req(nrow(rv$speedEst) == length(rv$simList),
nrow(rv$speedErr) == length(rv$simList))

mod_blocks_server(
id = "sdBlock_est",
rv = rv, type = "ctsd", name = "speedEst")
Expand Down
56 changes: 29 additions & 27 deletions R/mod_tab_data_upload.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -738,32 +738,33 @@ mod_tab_data_upload_server <- function(id, rv) {
### Model fitting:

expt <- timing_fit()
confirm_time <- NULL

if ((expt$max %#% expt$unit) > (15 %#% "minutes")) {

out_expt <- fix_unit(expt$max, expt$unit, convert = TRUE)

shinyalert::shinyalert(
className = "modal_warning",
title = "Do you wish to proceed?",
callbackR = function(x) { rv$confirm_time <- x },
text = tagList(span(
"Expected run time for the next phase", br(),
"is approximately",
wrap_none(span(out_expt$value, out_expt$unit,
class = "cl-dgr"), ".")
)),
type = "warning",
showCancelButton = TRUE,
cancelButtonText = "Stop",
confirmButtonCol = pal$mdn,
confirmButtonText = "Proceed",
html = TRUE)

} else { confirm_time <- TRUE }

req(confirm_time)
rv$confirm_time <- NULL

# if ((expt$max %#% expt$unit) > (15 %#% "minutes")) {
#
# out_expt <- fix_unit(expt$max, expt$unit, convert = TRUE)
#
# shinyalert::shinyalert(
# className = "modal_warning",
# title = "Do you wish to proceed?",
# callbackR = function(x) { rv$confirm_time <- x },
# text = tagList(span(
# "Expected run time for the next phase", br(),
# "is approximately",
# wrap_none(span(out_expt$value, out_expt$unit,
# class = "cl-dgr"), ".")
# )),
# type = "warning",
# showCancelButton = TRUE,
# cancelButtonText = "Stop",
# confirmButtonCol = pal$mdn,
# confirmButtonText = "Proceed",
# html = TRUE)
#
# } else { rv$confirm_time <- TRUE }
rv$confirm_time <- TRUE

req(rv$confirm_time)
start_fit <- Sys.time()
msg_log(
style = "warning",
Expand Down Expand Up @@ -911,6 +912,7 @@ mod_tab_data_upload_server <- function(id, rv) {
positionClass = "toast-bottom-right"))

shinyjs::show(id = "uploadBox_parameters")
rv$confirm_time <- FALSE

}) %>% # end of observe,
bindEvent(input$validate_upload)
Expand Down Expand Up @@ -1143,7 +1145,7 @@ mod_tab_data_upload_server <- function(id, rv) {
output$upload_time <- renderText({
req(rv$time)

out <- fix_unit(rv$time[1], "seconds", convert = TRUE)
out <- fix_uFnit(rv$time[1], "seconds", convert = TRUE)

return(paste0("Model fitting took approximately ",
out$value, " ", out$unit, "."))
Expand Down
49 changes: 35 additions & 14 deletions R/mod_tab_design.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -1895,23 +1895,34 @@ mod_tab_design_server <- function(id, rv) {

} else if (rv$data_type != "simulated") {

# fit <- prepare_mod(
# tau_p = rv$tau_p[[1]][2, ],
# tau_v = rv$tau_v[[1]][2, ],
# sigma = rv$sigma[[1]][2, ],
# mu = rv$mu[[1]])

fit <- ctmm:::mean.ctmm(x = rv$fitList[rv$id]) %>%
suppressMessages() %>%
suppressWarnings() %>%
quiet()
fit <- prepare_mod(
tau_p = rv$tau_p[[1]][2, ],
tau_v = rv$tau_v[[1]][2, ],
sigma = rv$sigma[[1]][2, ],
mu = rv$mu[[1]])

# fit <- tryCatch( # error
# ctmm:::mean.ctmm(x = rv$fitList[rv$id]) %>%
# suppressMessages() %>%
# suppressWarnings() %>%
# quiet(),
# error = function(e) e)
#
# if (inherits(fit, "error")) {
# msg_log(
# style = "danger",
# message = paste0(
# "Mean fit ", msg_danger("failed"), "."))
# return(NULL)
# }

rv$is_isotropic <- fit$sigma@isotropic[[1]]

# Recenter to 0,0 (not needed if using prepare_mod):
fit$mu[[1, "x"]] <- 0
fit$mu[[1, "y"]] <- 0

if ("compare" %in% req(rv$which_meta)) {
if ("compare" %in% rv$which_meta) {
if (length(rv$tau_p) == 3 ||
length(rv$tau_v) == 3 ||
length(rv$sigma) == 3 || length(rv$mu) == 3) {
Expand Down Expand Up @@ -2049,6 +2060,7 @@ mod_tab_design_server <- function(id, rv) {
positionClass = "toast-bottom-right")
)


shinybusy::show_modal_spinner(
spin = "fading-circle",
color = "var(--sea)",
Expand All @@ -2060,12 +2072,21 @@ mod_tab_design_server <- function(id, rv) {
))
)

if (req(rv$which_meta) == "compare")
req(length(rv$tau_p) == 3)
if (rv$which_meta == "compare")
req(length(rv$tau_p) == 3)

start <- Sys.time()
simList <- simulating_data()

# if (is.null(simList)) {
#
# shinybusy::remove_modal_spinner()
# msg_log(
# style = "danger",
# message = paste0(
# "Simulation ", msg_danger("failed"), "."))
# }
#
# req(simList)
if (!rv$grouped) {
rv$seedList <- list(rv$seed0)
names(simList) <- c(rv$seed0)
Expand Down
Loading

0 comments on commit 74ed8a5

Please sign in to comment.