first draft of functional takes tab

us-amlr · Mar 21, 2024 · 8419716 · 8419716
1 parent 20ba422
commit 8419716
Show file tree

Hide file tree

Showing 10 changed files with 113 additions and 107 deletions.
diff --git a/NAMESPACE b/NAMESPACE
@@ -57,6 +57,7 @@ export(tbl_vMicroVHF_Deployed)
 export(tbl_vPinniped_Season)
 export(tbl_vTag_Resights)
 export(tbl_vTag_Resights_Leopards)
+export(tbl_vTakes)
 export(total_count)
 import(amlrDatabases)
 import(dplyr)

diff --git a/NEWS.md b/NEWS.md
@@ -6,7 +6,7 @@
 
 * Used for and developed during 2023/24 Cape Shirreff field season. Finalized after season
 
-* Updated various tab functionality, especially AFS DCC and cape-wide pup census
+* Updated various tab functionality, especially AFS DCC, cape-wide pup census, and MMPA takes
 
 * Updated `afs_capewide_pup` functions: renamed functions including changing to 'cwp_' prefix; added `cwp_loc_agg` to aggregate across locations in a consistent fashion; bug fixes (#10)
 

diff --git a/R/extract.R b/R/extract.R
@@ -161,3 +161,14 @@ tbl_vPinniped_Season <- function(src) {
            pup_mortality, pup_mortality_date, notes) %>%
     collect()
 }
+
+
+#' @name extract
+#' @export
+tbl_vTakes <- function(src) {
+  tbl(src, "vTakes") %>%
+    select(season_name, table_name, take_date, species, age_class, sex,
+           individual_identifier, location_group, take_notes, sample_types,
+           individual_id, individual_id_source,
+           record_id, season_info_id, Beach_ID, created_dt)
+}
diff --git a/R/mod_phocid_census.R b/R/mod_phocid_census.R
@@ -17,9 +17,14 @@ mod_phocid_census_ui <- function(id) {
         #                        selected = tamatoamlr::pinniped.phocid.sp)
         #   )
         mod_filter_season_ui(ns("filter_season")),
-        checkboxGroupInput(ns("species"), tags$h5("Species"), inline = TRUE,
-                           choices = tamatoamlr::pinniped.phocid.sp,
-                           selected = tamatoamlr::pinniped.phocid.sp),
+        # checkboxGroupInput(ns("species"), tags$h5("Species"), inline = TRUE,
+        #                    choices = tamatoamlr::pinniped.phocid.sp,
+        #                    selected = tamatoamlr::pinniped.phocid.sp),
+        selectInput(ns("species"), tags$h5("Species"), #inline = TRUE,
+                    choices = tamatoamlr::pinniped.phocid.sp,
+                    selected = tamatoamlr::pinniped.phocid.sp,
+                    multiple = TRUE, selectize = TRUE),
+
         uiOutput(ns("age_sex_uiOut_selectize")),
         uiOutput(ns("location_uiOut_selectize"))
       ),

diff --git a/R/mod_tag_resights.R b/R/mod_tag_resights.R
@@ -58,11 +58,7 @@ mod_tag_resights_ui <- function(id) {
 #' @name shiny_modules
 #' @export
 mod_tag_resights_server <- function(id, src, season.df, tab) {
-  stopifnot(
-    is.reactive(src),
-    is.reactive(season.df),
-    is.reactive(tab)
-  )
+  .mod_check(src, season.df, tab)
 
   moduleServer(
     id,

diff --git a/R/mod_takes.R b/R/mod_takes.R
@@ -9,31 +9,34 @@ mod_takes_ui <- function(id) {
       box(
         title = "Filters", status = "warning", solidHeader = FALSE,
         width = 6, collapsible = TRUE,
-        # mod_filter_season_ui(ns("filter_season"))
-        fluidRow(
-          column(6, uiOutput(ns("season")))
+        mod_filter_season_ui(ns("filter_season")),
+        checkboxInput(ns("pinniped_species"), "Filter takes by pinniped species",
+                      value = FALSE),
+        conditionalPanel(
+          condition = "input.pinniped_species == true", ns = ns,
+          helpText("Note this filter will remove any 'other species' dead animals"),
+          selectInput(ns("species"), tags$h5("Species"),
+                      choices = tamatoamlr::pinniped.sp,
+                      selected = tamatoamlr::pinniped.sp,
+                      multiple = TRUE, selectize = TRUE)
         )
       ),
       box(
-        title = "Summary options", status = "warning", solidHeader = FALSE, width = 6, collapsible = TRUE,
-        helpText("This tab allows you to view and summarize pinniped takes"),
+        title = "Summary options", status = "warning", solidHeader = FALSE,
+        width = 6, collapsible = TRUE,
+        helpText("This tab allows you to generate and view different summaries",
+                 "of pinniped takes, for reporting for the",
+                 "Marine Mammal Protection Act (MMPA) permit. "),
         fluidRow(
+          column(4, .summaryTimingUI(ns, c("fs_single"))),
           column(
-            width = 6,
-            selectInput(ns("view"), tags$h5("View to display"),
-                        choices = c("MMPA takes" = "mmpa"),
-                        selected = "mmpa")
-          ),
-          column(
-            width = 6,
-            conditionalPanel(
-              condition = "input.view == 'mmpa'", ns = ns,
-              helpText("reporting for Marine Mammal Protection Act (MMPA) permit")
-            )
+            width = 4,
+            radioButtons(ns("summary_type"), tags$h5("Summary type"),
+                         choices = c("By species" = "species",
+                                     "By individual" = "individual",
+                                     "By database table" = "table",
+                                     "All takes" = "all"))
           )
-          # column(4, .summaryTimingUI(ns, c("fs_single"))),
-          # column(4, .summaryLocationUI(ns, c("by_capewide", "by_beach"), "by_capewide")),
-          # column(4, .summarySpAgeSexUI(ns, c("by_sp", "by_sp_age_sex"), "by_sp"))
         )
       )
     ),
@@ -61,103 +64,85 @@ mod_takes_server <- function(id, src, season.df, tab) {
       })
 
 
-      # ### Get filter_season values
-      # filter_season <- reactive({
-      #   mod_filter_season_server(
-      #     "filter_season",  reactive(input$summary_timing), season.df
-      #   )
-      # })
-
-
-      # #-------------------------------------------------------------------------
-      # # Sample inventory view
-      #
-      # sample_inventory_collect <- reactive({
-      #   sample.inventory <- try(
-      #     tbl(src(), "vSample_Inventory") %>% collect(),
-      #     silent = TRUE
-      #   )
-      #   validate(
-      #     need(sample.inventory,
-      #          "Unable to find and load vSample_Inventory from specified database")
-      #   )
-      #   sample.inventory
-      # })
-      #
-      # sample_inventory <- reactive({
-      #   x <- sample_inventory_collect() %>%
-      #     filter(season_name == req(input$season))
-      #
-      #   if (input$summary_type == "all") {
-      #     x
-      #
-      #   } else {
-      #     x <- x %>%
-      #       # Make single column with 'most unique' ID
-      #       # case_when rolls through order of priority
-      #       mutate(on_the_fly_unique = if_else(!is.na(unk_group_id),
-      #                                          unk_group_id, on_the_fly_id),
-      #              id_unique = case_when(
-      #                !is.na(pinniped_id) ~ pinniped_id,
-      #                !is.na(pup_afs_id) ~ pup_afs_id,
-      #                !is.na(on_the_fly_unique) ~ on_the_fly_unique,
-      #                .default = NA_integer_
-      #              ))
-      #
-      #     x.grouped <- if (input$summary_type == "sample_type") {
-      #       x %>% group_by(species, sample_type)
-      #     } else if (input$summary_type == "sample_type_group") {
-      #       x %>% group_by(species, sample_type_group)
-      #     } else {
-      #       validate("invalid summary_type - please contact the database manager")
-      #     }
-      #
-      #     x.grouped %>%
-      #       summarise(package_count = n(),
-      #                 individual_seals_count = n_distinct(id_unique),
-      #                 # n_pinniped_id = n_distinct(pinniped_id, na.rm = TRUE),
-      #                 # n_on_the_fly = n_distinct(on_the_fly_unique, na.rm = TRUE),
-      #                 # n_pup_afs_id = n_distinct(pup_afs_id, na.rm = TRUE),
-      #                 # individual_seals_count =
-      #                 #   (n_pinniped_id+n_on_the_fly+n_pup_afs_id),
-      #                 n_adults_juveniles = sum(age_class %in% c("Adult", "Adult/Juvenile", "Juvenile")),
-      #                 n_pups = sum(age_class %in% c("Pup")),
-      #                 .groups = "drop") %>%
-      #       relocate(individual_seals_count, n_adults_juveniles, n_pups,
-      #                .after = package_count)
-      #   }
-      # })
+      ### Get filter_season values
+      filter_season <- reactive({
+        mod_filter_season_server(
+          "filter_season",  reactive(input$summary_timing), season.df
+        )
+      })
 
 
       #-------------------------------------------------------------------------
-      # Attendance pup weights
+      ### Finish constructing query, and collect data
+      takes_filter <- reactive({
+        req(src())
+        fs <- filter_season()
 
-      takes_collect <- reactive({
-        apw <- try(
-          tbl(src(), "vAttendance_Pup_Weights") %>% collect(),
-          silent = TRUE
+        validate(
+          need(input$summary_timing == "fs_single",
+               "Only single season summaries are currently available")
         )
+
+        # Generate SQL query, and collect
+        takes.sql <- tbl_vTakes(src()) %>%
+          filter(season_name == !!req(fs$season()),
+                 between(take_date,
+                         !!req(fs$date_range())[1],
+                         !!req(fs$date_range())[2]))
+
+        if (input$pinniped_species) {
+          takes.sql <- takes.sql %>%
+            filter(species %in% !!input$species)
+        }
+
+        takes.collect <- takes.sql %>% collect()
+
+        # Generate validate messages
         validate(
-          need(apw,
-               "Unable to find and load vAttendance_Pup_Weights from specified database")
+          need(nrow(takes.collect) > 0,
+               "No take data to view based on given filters")
         )
-        apw
+
+        takes.collect
       })
 
 
-      apw <- reactive({
-        apw_collect() %>% filter(season_name == req(input$season))
+      ### Summarize take data, as specified by user
+      takes <- reactive({
+        takes <- takes_filter()
+
+        takes_summary <- function(x, ...) {
+          x %>%
+            group_by(...) %>%
+            summarise(n_takes = n(), .groups = "drop")
+        }
+
+        if (input$summary_type == "all") {
+          takes
+        } else if (input$summary_type == "species") {
+          takes %>% takes_summary(season_name, species, age_class)
+        } else if (input$summary_type == "individual") {
+          takes %>%
+            filter(!is.na(individual_id)) %>%
+            takes_summary(season_name, species, age_class,
+                          individual_identifier, individual_id,
+                          individual_id_source)
+        } else if (input$summary_type == "table") {
+          takes %>% takes_summary(season_name, table_name, species, age_class)
+        } else {
+          validate("Invalid summary_type - please contact the database manager")
+        }
       })
 
+
       #-------------------------------------------------------------------------
       tbl_output <- reactive({
-        NULL
-        validate("invalid tbl - please contact the database manager")
+        takes()
       })
 
       plot_output <- reactive({
         NULL
-        validate("There are no plots for the views")
+        validate("There are currently no plots for MMPA takes")
       })
 
 

diff --git a/R/sysdata.rda b/R/sysdata.rda
diff --git a/R/tamatoa.R b/R/tamatoa.R
@@ -109,6 +109,7 @@ tamatoa <- function(...,
         menuItem("CCAMLR Pup Weights", tabName = .id.list$cpw, icon = icon("th")),
         menuItem("CS-PHOC: Phocid Census", tabName = .id.list$csphoc, icon = icon("th")),
         menuItem("Tag Resights", tabName = .id.list$resights, icon = icon("th", lib = "font-awesome")),
+        menuItem("Takes - MMPA", tabName = .id.list$takes, icon = icon("th", lib = "font-awesome")),
         menuItem("Views", tabName = .id.list$views, icon = icon("th", lib = "font-awesome")),
         tags$br(), tags$br(),
         column(12, uiOutput("tabs_warning")),
@@ -149,6 +150,7 @@ tamatoa <- function(...,
         tabItem(.id.list$cpw, mod_ccamlr_pup_weights_ui(.id.list$cpw)),
         tabItem(.id.list$csphoc, mod_phocid_census_ui(.id.list$csphoc)),
         tabItem(.id.list$resights, mod_tag_resights_ui(.id.list$resights)),
+        tabItem(.id.list$takes, mod_takes_ui(.id.list$takes)),
         tabItem(.id.list$views, mod_views_ui(.id.list$views))
         # tabItem("tab_pt", mod_pinnipeds_tags_ui("pinnipeds_tags"))
       )
@@ -207,6 +209,8 @@ tamatoa <- function(...,
       .id.list$csphoc, db.pool, si.list$season.df, tab)
     mod_tag_resights_server(
       .id.list$resights, db.pool, si.list$season.df, tab)
+    mod_takes_server(
+      .id.list$takes, db.pool, si.list$season.df, tab)
     mod_views_server(
       .id.list$views, db.pool, si.list$season.df, tab)
     # mod_pinnipeds_tags_server("pinnipeds_tags", db.pool)

diff --git a/data-raw/internal.R b/data-raw/internal.R
@@ -45,6 +45,7 @@
   "cpw"      = "ccamlr_pup_weights",
   "csphoc"   = "csphoc",
   "resights" = "tag_resights",
+  "takes"    = "takes", #MMPA takes tab
   "views"    = "views"
 )
 

diff --git a/man/extract.Rd b/man/extract.Rd