From 84197164e058f537483c68e279e6579e1448de68 Mon Sep 17 00:00:00 2001 From: Sam Woodman Date: Wed, 20 Mar 2024 20:39:00 -0700 Subject: [PATCH] first draft of functional takes tab --- NAMESPACE | 1 + NEWS.md | 2 +- R/extract.R | 11 +++ R/mod_phocid_census.R | 11 ++- R/mod_tag_resights.R | 6 +- R/mod_takes.R | 181 +++++++++++++++++++----------------------- R/sysdata.rda | Bin 593 -> 594 bytes R/tamatoa.R | 4 + data-raw/internal.R | 1 + man/extract.Rd | 3 + 10 files changed, 113 insertions(+), 107 deletions(-) diff --git a/NAMESPACE b/NAMESPACE index 30bfb12..4d90673 100644 --- 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 index 6a75aff..a2f7665 100644 --- 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 index 264ea2b..d4de9d1 100644 --- 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 index 9fb66e4..45ca893 100644 --- 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 index 7c902fe..48fd29e 100644 --- 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 index 92f5f4b..5942ea5 100644 --- 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 index 0ea5cb55828c3442353cfaba8f05cb0f8b7200d9..a505727db6591bc3b2cbc0339c882977333a2519 100644 GIT binary patch delta 585 zcmV-P0=E6p1kwZ%LRx4!F+o`-Q(6Az@%I1$$dM5ie_cd?5YbE$X`zv(fEoZX0MO9M zq09nc1i%0$00LkDa{!nDFaQaF0GI#?6cI8SG|0$LQ8Y4ofYa2_G}9)U)L1qlrrR^; z2(i%sHbj7s;NXC>mv^F+&eW}V<2=j@LeLRYpa71QKmikA$e=oDYPuF{ZfHp=T1FQ; zr*Dj}e`JPM>(O*+gd2$W?Uph&=7CHU8{9xLW_bZr;YIrpT*Q`?AQ+NEL81Uf#h^(a ze&`?+hLLLd=hNvO0QFN($#A&#UqNrLN*Jb(e38cE;94kVl3q2ny(bRN+bQV#kP(^Q zPzf??3RD!7r(&sLVK9RR3kC923Z`V{ZgmlUy3oB)7TD_}Hz5{C|#Ygg-RKgV~0iQZ&VzlWamfhhzp1{#*%)lm> zf1R4M2SVfFhq{4jOEu}VH34ijS$`0mWwDHaMBEOF0+~no1IdYKpir8rMI)%Y;*JIZ z5Q0R)julx+X1>XVG$LC^UNVZ#htUwzna&NGM;B^xd9|SxbqDLTppk100b#6+gF=#{ z8;M1OVt$IQ-R2=&k>$J2L3mG6yMooNFCMIOW&TtJORp}yi5bGQQoR#hD=vcE3zb|U XsvQju8^DL@N&H>O6yZWc`m}B zkOqc~)C8e5G7u5%NwiG>0BCxe0h3J*U=si)00A%n6954sMLkLCc&5aS0001J13(Lu znruT&wpUn5j*u)QK#>qa0^W@J4Jx>_x5t;?yokauH$CtOUAkz3QYs|ZZq~gBtZAVE z5hSRFe_IyHH?_Rg)U9j3WF*Y10dr(~T%9aQk{irGWMy*#tWiw2puvJxqyWJrG!{S- za%lobo_GLL8b#~2yMLu%JecwJEu6P*=p&*&mtcfVt7g4;XbIJOc6fNp*T=J0wmMes z8}kX7tbjd~R=xxt_x8g43f3IM3=oe5mEW)De}G{=D%+mDx$)^>{g_lc&cvyJP8A}@ zGSK47^zzGx+0hV#6%rkKUS*b{(1B9xiXnEP-ClF4nW_vW32|Q(UY54K! z16mfn+{tQCw62D~1{5$$MJk94Sd$%#jLbUhoS_SvkjFvj ze^wAm`KORFt9M!37`TxpM9hX!3X*xUWe7R=F_0271Em8To>PDMDrJEDb{9QwtQ; zHYy(G24Oeym$JZ>$l=L*!k~o8o@F%XF3)6{zf@r=(RPYbF$NT1U&)qbc2bQ6N?T%{ WE14R#1$)-N@pmLsg$W0;5aBS-QUSF9 diff --git a/R/tamatoa.R b/R/tamatoa.R index 3fcd2ec..f50944a 100644 --- 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 index 20ca91c..1c421fa 100644 --- 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 index 5fd70e6..f7410bb 100644 --- a/man/extract.Rd +++ b/man/extract.Rd @@ -13,6 +13,7 @@ \alias{tbl_vTag_Resights_Leopards} \alias{tbl_vMicroVHF_Deployed} \alias{tbl_vPinniped_Season} +\alias{tbl_vTakes} \title{Extract data from database} \usage{ tbl_vCensus_Phocid(src) @@ -36,6 +37,8 @@ tbl_vTag_Resights_Leopards(src) tbl_vMicroVHF_Deployed(src) tbl_vPinniped_Season(src) + +tbl_vTakes(src) } \arguments{ \item{src}{a data source; likely a \code{\link[pool]{pool}} object