Adding quadrat regrouping tool

app.R

@@ -23,6 +23,8 @@ source("modules/nvcInfo_server.R", local = TRUE)
 source("modules/sidebar_ui.R", local = TRUE)
 source("modules/sidebar_server.R", local = TRUE)
 
+# source("modules/setupData_server.R", local = TRUE)
+
 source("modules/uploadData_ui.R", local = TRUE)
 source("modules/uploadData_server.R", local = TRUE)
 

modules/surveyTableValidator_server.R

@@ -47,6 +47,35 @@ surveyTableValidator <- function(input, output, session, surveyTable, sidebar_op
 
   })
 
+# Initialise Table to Re-allocate groups ---------------------------------
+  reallocateGroups_init <- data.frame("Quadrat" = character(),
+                                      "Group" = character())
+
+  reallocateGroups_rval <- reactiveVal(reallocateGroups_init)
+
+  output$reallocateGroupsTable <- rhandsontable::renderRHandsontable({
+
+    reallocateGroupsTable <- rhandsontable::rhandsontable(data = reallocateGroups_init,
+                                                          height = 300,
+                                                          rowHeaders = NULL,
+                                                          width = "100%"#,
+                                                          # overflow = "visible",
+                                                          # stretchH = "all"
+                                                          ) |>
+      rhandsontable::hot_col(col = colnames(reallocateGroups_init), halign = "htCenter") |>
+      rhandsontable::hot_context_menu(allowRowEdit = FALSE, allowColEdit = FALSE) |>
+      rhandsontable::hot_table(highlightCol = TRUE, highlightRow = TRUE, stretchH = "all") |>
+      htmlwidgets::onRender("
+      function(el, x) {
+        var hot = this.hot
+        $('a[data-value=\"validateSurveyTable\"').on('click', function(){
+          setTimeout(function() {hot.render();}, 0);
+        })
+      }")
+
+    return(reallocateGroupsTable)
+
+  })
 
 # Perform Validation Checks on surveyTable --------------------------------
   surveyTableValidation_rval <- reactiveVal(
@@ -213,9 +242,6 @@ surveyTableValidator <- function(input, output, session, surveyTable, sidebar_op
 
     surveyTableValidation <- surveyTableValidation_rval()
 
-    # print(surveyTableValidation$speciesNotAccepted)
-    # print(length(surveyTableValidation$speciesNotAccepted) > 0)
-
     if(length(surveyTableValidation$speciesNotAccepted) > 0){
 
       speciesAdjustmentTable <- data.frame("Species.Submitted" = surveyTableValidation$speciesNotAccepted,
@@ -236,8 +262,6 @@ surveyTableValidator <- function(input, output, session, surveyTable, sidebar_op
 
     }
 
-    # assign(x = "speciesAdjustmentTable", value = speciesAdjustmentTable, envir = .GlobalEnv)
-
     output$speciesAdjustmentTable <- rhandsontable::renderRHandsontable({
 
       speciesAdjustmentTable <- rhandsontable::rhandsontable(data = speciesAdjustmentTable,
@@ -284,7 +308,53 @@ surveyTableValidator <- function(input, output, session, surveyTable, sidebar_op
               ignoreInit = TRUE,
               ignoreNULL = TRUE)
 
-
+  # Update Table to to Re-allocate groups ------------------------------
+  reallocateGroupsTable_rval <- reactiveVal()
+
+  observe({
+
+    shiny::req(reallocateGroups_rval())
+
+    surveyTable <- surveyTable()
+
+    reallocateGroups <- reallocateGroups_rval()
+
+    reallocateGroupsTable <- surveyTable |>
+      dplyr::select(Quadrat, Group) |>
+      dplyr::distinct()
+
+    output$reallocateGroupsTable <- rhandsontable::renderRHandsontable({
+
+      reallocateGroupsTable <- rhandsontable::rhandsontable(data = reallocateGroupsTable,
+                                                            height = 300,
+                                                            rowHeaders = NULL,
+                                                            width = "100%"#,
+                                                            # overflow = "visible",
+                                                            # stretchH = "all"
+                                                            ) |>
+        rhandsontable::hot_col(col = colnames(reallocateGroupsTable), halign = "htCenter") |>
+        rhandsontable::hot_context_menu(allowRowEdit = FALSE, allowColEdit = FALSE) |>
+        rhandsontable::hot_table(highlightCol = TRUE, highlightRow = TRUE, stretchH = "all") |>
+        htmlwidgets::onRender("
+          function(el, x) {
+            var hot = this.hot
+            $('a[data-value=\"validateSurveyTable\"').on('click', function(){
+              setTimeout(function() {hot.render();}, 0);
+            })
+          }")
+
+      return(reallocateGroupsTable)
+
+    })
+
+    reallocateGroupsTable_rval(reallocateGroupsTable)
+
+  }) |>
+    bindEvent(surveyTable(),
+              ignoreInit = FALSE,
+              ignoreNULL = TRUE)
+
+
 # Create Text Validation Outputs ------------------------------------------
   observe({
 
@@ -496,19 +566,21 @@ surveyTableValidator <- function(input, output, session, surveyTable, sidebar_op
 
     surveyTableValidatorData <- list(
       "adjustSpecies" = input$adjustSpecies,
+      "reallocateGroups" = input$reallocateGroups,
       "combineDuplicates" = input$combineDuplicates,
       "speciesAdjustmentTable" = rhandsontable::hot_to_r(input$speciesAdjustmentTable),
+      "reallocateGroupsTable" = rhandsontable::hot_to_r(input$reallocateGroupsTable),
       "surveyTableValidation" = surveyTableValidation_rval()
     )
 
-    # print(surveyTableValidatorData)
-
     surveyTableValidatorData_rval(surveyTableValidatorData)
 
   }) |>
     bindEvent(input$adjustSpecies,
+              input$reallocateGroups,
               input$combineDuplicates,
               input$speciesAdjustmentTable,
+              input$reallocateGroupsTable,
               surveyTableValidation_rval(),
               ignoreInit = TRUE,
               ignoreNULL = TRUE)

modules/surveyTableValidator_ui.R

@@ -12,7 +12,7 @@ surveyTableValidatorUI <- function(id){
 
       bslib::layout_columns(
 
-        col_widths = c(3, 3, 3, 3),
+        col_widths = c(3, 3, 3),
 
         shiny::div(
           shiny::actionButton(inputId = ns("adjustSpecies"),
@@ -22,6 +22,11 @@ surveyTableValidatorUI <- function(id){
         shiny::div(
           shiny::actionButton(inputId = ns("combineDuplicates"),
                               label = "Combine Duplicates")
+        ),
+
+        shiny::div(
+          shiny::actionButton(inputId = ns("reallocateGroups"),
+                              label = "Re-allocate Groups")
         )
 
       ),
@@ -330,6 +335,16 @@ surveyTableValidatorUI <- function(id){
 
       shiny::div(
         rhandsontable::rHandsontableOutput(outputId = ns("speciesAdjustmentTable")) # , height = "300px"
+      ),
+
+      shiny::div(shiny::br()),
+
+      shiny::h5("Group Re-allocation Table"),
+
+      shiny::div(shiny::br()),
+
+      shiny::div(
+        rhandsontable::rHandsontableOutput(outputId = ns("reallocateGroupsTable")) # , height = "300px"
       )
 
     )

modules/surveyTable_server.R

@@ -24,15 +24,19 @@ surveyTable <- function(input, output, session, uploadDataTable, surveyTableVali
 
 # Retrieve Survey Table Correction Button ---------------------------------
   adjustSpecies <- reactiveVal()
+  reallocateGroups <- reactiveVal()
   combineDuplicates <- reactiveVal()
   speciesAdjustmentTable <- reactiveVal()
+  reallocateGroupsTable <- reactiveVal()
   combineDuplicates <- reactiveVal()
 
   observe({
 
     adjustSpecies(surveyTableValidator()$adjustSpecies)
+    reallocateGroups(surveyTableValidator()$reallocateGroups)
     combineDuplicates(surveyTableValidator()$combineDuplicates)
     speciesAdjustmentTable(surveyTableValidator()$speciesAdjustmentTable)
+    reallocateGroupsTable(surveyTableValidator()$reallocateGroupsTable)
     combineDuplicates(surveyTableValidator()$combineDuplicates)
 
   }) |>
@@ -217,9 +221,12 @@ surveyTable <- function(input, output, session, uploadDataTable, surveyTableVali
 
 
 
-# Validate Survey Data Table ----------------------------------------------
+
+
+# Survey Table Validation Actions -----------------------------------------
   surveyTable_corrected_rval <- reactiveVal()
 
+## Adjust Species Names ---------------------------------------------------
   observe({
 
     req(speciesAdjustmentTable())
@@ -259,6 +266,37 @@ surveyTable <- function(input, output, session, uploadDataTable, surveyTableVali
     bindEvent(adjustSpecies(),
               ignoreInit = TRUE,
               ignoreNULL = TRUE)
+
+## Re-allocate Groups -----------------------------------------------------
+  observe({
+
+    req(reallocateGroupsTable())
+    req(input$surveyTable)
+
+    isolate({
+
+      surveyTable <- rhandsontable::hot_to_r(input$surveyTable)
+
+      if(!is.null(reallocateGroupsTable())){
+
+        reallocateGroupsTable <- reallocateGroupsTable()
+
+        surveyTable_corrected <- surveyTable |>
+          tibble::as_tibble() |>
+          dplyr::select(-Group) |>
+          dplyr::left_join(reallocateGroupsTable, by = "Quadrat") |>
+          dplyr::select(Year, Group, Quadrat, Species, Cover)
+
+        surveyTable_corrected_rval(surveyTable_corrected)
+
+      }
+
+    })
+
+  }) |>
+    bindEvent(reallocateGroups(),
+              ignoreInit = TRUE,
+              ignoreNULL = TRUE)
 
   observe({