🐛 misc fixes

ecoisilva · Feb 22, 2024 · c9152c1 · c9152c1
1 parent 175930d
commit c9152c1
Show file tree

Hide file tree

Showing 9 changed files with 154 additions and 62 deletions.
diff --git a/R/fct_helpers.R b/R/fct_helpers.R
@@ -556,7 +556,6 @@ extract_svf <- function(data, fit = NULL,
     fit <- list(fit)
   }
 
-  x <- 1
   out <- lapply(seq_along(data), function(x) {
 
     if (is.null(fit[[x]])) {
@@ -577,45 +576,52 @@ extract_svf <- function(data, fit = NULL,
     lag <- V[[1]]$lag
     lag[1] <- lag[2]/1000
 
-    if (!is.null(fit[[x]])) {
-      fit[[x]]$tau <- fit[[x]]$tau[fit[[x]]$tau > 0]
-      SVF <- ctmm:::svf.func(fit[[x]], moment = TRUE)
-      svf <- SVF$svf
-      DOF <- SVF$DOF
+    if (length(lag) == 1) {
+      out <- NULL
+    } else {
+      if (!is.null(fit[[x]])) {
+        fit[[x]]$tau <- fit[[x]]$tau[fit[[x]]$tau > 0]
+        SVF <- ctmm:::svf.func(fit[[x]], moment = TRUE)
+        svf <- SVF$svf
+        DOF <- SVF$DOF
+
+        if (any(diag(fit[[x]]$COV) > 0)) {
+          SVF <- Vectorize(function(t) svf(t))(lag)
+          dof <- Vectorize(function(t) { DOF(t) })(lag)
+          svf.lower <- Vectorize(function(dof) CI.lower(dof, level) )(dof)
+          svf.upper <- Vectorize(function(dof) CI.upper(dof, level) )(dof)
+        }
+      }
+
+      VAR <- data.frame(svf = VAR$SVF,
+                        dof = VAR$DOF,
+                        lag = VAR$lag) %>%
+        dplyr::slice_min(lag, prop = fraction) %>%
+        dplyr::mutate(lag = x_unit %#% lag)
 
-      if(any(diag(fit[[x]]$COV) > 0)) {
-        SVF <- Vectorize(function(t) svf(t))(lag)
-        dof <- Vectorize(function(t) { DOF(t) })(lag)
-        svf.lower <- Vectorize(function(dof) CI.lower(dof, level) )(dof)
-        svf.upper <- Vectorize(function(dof) CI.upper(dof, level) )(dof)
+      VAR$svf_lower <- y_unit %#% ( VAR$svf * CI.lower(VAR$dof, level) )
+      VAR$svf_upper <- y_unit %#% ( VAR$svf * CI.upper(VAR$dof, level) )
+      VAR$svf_low50 <- y_unit %#% ( VAR$svf * CI.lower(VAR$dof, .5) )
+      VAR$svf_upp50 <- y_unit %#% ( VAR$svf * CI.upper(VAR$dof, .5) )
+      VAR$svf <- y_unit %#% VAR$svf
+
+      FIT <- NULL
+      if (!is.null(fit[[x]])) {
+        FIT <- data.frame(
+          svf = y_unit %#% 
+            sapply(lag, Vectorize(function(t) { svf(t) })),
+          lag = x_unit %#% lag,
+          svf_lower = SVF * (y_unit %#% svf.lower),
+          svf_upper = SVF * (y_unit %#% svf.upper))
       }
+
+      out <- list(data = VAR,
+                  fit = FIT,
+                  x_unit = x_unit,
+                  y_unit = y_unit)
     }
 
-    VAR <- data.frame(svf = VAR$SVF,
-                      dof = VAR$DOF,
-                      lag = VAR$lag) %>%
-      dplyr::slice_min(lag, prop = fraction) %>%
-      dplyr::mutate(lag = x_unit %#% lag)
-
-    VAR$svf_lower <- y_unit %#% ( VAR$svf * CI.lower(VAR$dof, level) )
-    VAR$svf_upper <- y_unit %#% ( VAR$svf * CI.upper(VAR$dof, level) )
-    VAR$svf_low50 <- y_unit %#% ( VAR$svf * CI.lower(VAR$dof, .5) )
-    VAR$svf_upp50 <- y_unit %#% ( VAR$svf * CI.upper(VAR$dof, .5) )
-    VAR$svf <- y_unit %#% VAR$svf
-
-    FIT <- NULL
-    if (!is.null(fit[[x]])) {
-      FIT <- data.frame(
-        svf = y_unit %#% sapply(lag, Vectorize(function(t) { svf(t) })),
-        lag = x_unit %#% lag,
-        svf_lower = SVF * (y_unit %#% svf.lower),
-        svf_upper = SVF * (y_unit %#% svf.upper))
-    }
-
-    return(list(data = VAR,
-                fit = FIT,
-                x_unit = x_unit,
-                y_unit = y_unit))
+    return(out)
 
   }) # end of lapply
 

diff --git a/R/global.R b/R/global.R
@@ -27,6 +27,7 @@ rlang::on_load(rlang::local_use_cli(inline = TRUE))
 utils::globalVariables(
   c(".data", "group", "seed",
 
+    "id",
     "x", "y",
     "long", "lat",
     "longitude", "latitude",
@@ -35,11 +36,27 @@ utils::globalVariables(
     "duration", "dur",
     "interval", "dti", "dti_notes",
 
+    "value", "low", "high",
+    "est", "lci", "uci",
     "error", "error_lci", "error_uci",
     "CI_low", "CI_high",
 
+    "svf",
+    "svf_lower",
+    "svf_upper",
+    "svf_low50",
+    "svf_upp50",
+
     "par_modal",
 
+    "type",
+    "variable",
+
+    "n",
+    "m",
+    "subpop",
+    "overlaps",
+
     "buffalo",
     "coati",
     "pelican",

diff --git a/R/mod_blocks.R b/R/mod_blocks.R
@@ -105,10 +105,15 @@ mod_blocks_server <- function(id,
                if (length(out) > 1) out <- do.call(rbind, out)
                else out <- out[[1]]
 
-               unit <- fix_unit(mean(out$value), out$unit[1])$unit
-               out <- c("mean" = fix_unit(mean(out$value), unit)$value,
-                        "min" = fix_unit(min(out$value), unit)$value,
-                        "max" = fix_unit(max(out$value), unit)$value)
+               unit <- fix_unit(mean(out$value, na.rm = TRUE),
+                                out$unit[1])$unit
+               out <- c(
+                 "mean" = fix_unit(
+                   mean(out$value, na.rm = TRUE), unit)$value,
+                 "min" = fix_unit(
+                   min(out$value, na.rm = TRUE), unit)$value,
+                 "max" = fix_unit(
+                   max(out$value, na.rm = TRUE), unit)$value)
 
                if (length(data) != 1) 
                  subtitle <- span(ifelse(out[2] == 0, "0", out[2]), 
@@ -312,7 +317,7 @@ mod_blocks_server <- function(id,
           percentage = prepare_outputs()[["perc"]],
           icon = ifelse(type == "n", FALSE, TRUE),
           value = prepare_outputs()[["value"]],
-          interval = prepare_outputs()[["subtitle"]],
+          intervals = prepare_outputs()[["subtitle"]],
           rightBorder = options[["rightBorder"]],
           marginBottom = options[["rightBorder"]])
 

diff --git a/R/mod_tab_about.R b/R/mod_tab_about.R
@@ -41,7 +41,7 @@ mod_tab_about_ui <- function(id) {
           # 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"),
@@ -137,7 +137,7 @@ mod_tab_about_ui <- function(id) {
                     no = tags$i(class = "fa fa-square-o",
                                 style = "color: var(--danger);")),
                   individual = TRUE),
-                
+
                 # div(class = "btn-nobg",
                 #     shinyWidgets::radioGroupButtons(
                 #       inputId = ns("which_meta"),

diff --git a/R/mod_tab_data_upload.R b/R/mod_tab_data_upload.R
@@ -637,6 +637,21 @@ mod_tab_data_upload_server <- function(id, rv) {
           class(datList[[1]])[1] != "ctmm")
         datList <- list(datList)
 
+      tmp <- list()
+      new_nms <- c()
+      old_nms <- names(datList)
+      for (x in seq_along(datList)) {
+        if (nrow(datList[[x]]) > 1) {
+          new_nms <- c(new_nms, old_nms[[x]])
+          tmp[[x]] <- datList[[x]] 
+        } else {
+          message("Individual ", x, " removed (only one location).")
+          tmp[[x]] <- NULL
+        }
+      }
+      datList <- tmp[!sapply(tmp, is.null)]
+      names(datList) <- new_nms
+
       rv$datList <- datList
       rv$fitList <- NULL
       rv$svfList <- NULL
@@ -891,14 +906,17 @@ mod_tab_data_upload_server <- function(id, rv) {
 
       req(rv$is_valid)
 
+      if (length(rv$datList) == 1)
+        txt_extra <- ", and the individual is " else
+          txt_extra <- ", and the individuals are "
+
       msg_log(
         style = "success",
         message = paste0("Species and individual ",
                          msg_success("validated"), "."),
         detail = paste0("Species selected is the ",
                         msg_success(rv$species_binom),
-                        ", and the individual is ",
-                        msg_success(toString(rv$id)), "."))
+                        txt_extra, msg_success(toString(rv$id)), "."))
 
       shinyFeedback::showToast(
         type = "success",
@@ -1145,7 +1163,7 @@ mod_tab_data_upload_server <- function(id, rv) {
     output$upload_time <- renderText({
       req(rv$time)
 
-      out <- fix_uFnit(rv$time[1], "seconds", convert = TRUE)
+      out <- fix_unit(rv$time[1], "seconds", convert = TRUE)
 
       return(paste0("Model fitting took approximately ",
                     out$value, " ", out$unit, "."))

diff --git a/R/mod_tab_design.R b/R/mod_tab_design.R
@@ -1916,8 +1916,6 @@ mod_tab_design_server <- function(id, rv) {
         #   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
@@ -2159,7 +2157,7 @@ mod_tab_design_server <- function(id, rv) {
             "Expected run time for the next phase", br(),
             "is approximately",
             wrap_none(span(
-              expt$range, expt$unit, class = "cl-dgr"), ".")
+              expt$range, class = "cl-dgr"), ".")
           )),
           type = "warning",
           showCancelButton = TRUE,
@@ -2224,6 +2222,7 @@ mod_tab_design_server <- function(id, rv) {
 
         rv$needs_fit <- FALSE
         rv$simfitList <- fitList
+        rv$is_isotropic <- fitList[[1]]$sigma@isotropic[[1]]
 
         lapply(seq_along(fitList), function(x) {
           rv$dev$tbl <<- rbind(
@@ -2787,7 +2786,7 @@ mod_tab_design_server <- function(id, rv) {
     ## Sample sizes: ----------------------------------------------------
 
     output$devBlock_n <- renderUI({
-      req(rv$simList, rv$dev$n[[1]])
+      req(rv$dev$n[[1]])
 
       n <- rv$dev$n[[1]]