Merge pull request #1 from ices-tools-dev/eg_table

Add ASD checks, UI edits, add EG table plus additional detail

DESCRIPTION

@@ -17,6 +17,7 @@ Imports:
     magrittr,
     shiny (>= 1.8.0),
     icesSAG,
+    icesASD, 
     dplyr,
     desc,
     jsonlite

NAMESPACE

@@ -8,14 +8,23 @@ importFrom(DT,renderDT)
 importFrom(DT,renderDataTable)
 importFrom(bsicons,bs_icon)
 importFrom(bslib,bs_theme)
+importFrom(bslib,card)
 importFrom(bslib,card_body)
+importFrom(bslib,card_header)
 importFrom(bslib,layout_column_wrap)
 importFrom(bslib,value_box)
 importFrom(desc,desc_get_version)
+importFrom(dplyr,arrange)
 importFrom(dplyr,bind_rows)
 importFrom(dplyr,filter)
+importFrom(dplyr,full_join)
+importFrom(dplyr,left_join)
 importFrom(dplyr,mutate)
+importFrom(dplyr,n)
+importFrom(dplyr,pull)
 importFrom(dplyr,select)
+importFrom(dplyr,slice_max)
+importFrom(dplyr,summarise)
 importFrom(golem,activate_js)
 importFrom(golem,add_resource_path)
 importFrom(golem,bundle_resources)
@@ -24,11 +33,13 @@ importFrom(golem,with_golem_options)
 importFrom(htmltools,css)
 importFrom(htmltools,h1)
 importFrom(htmltools,tags)
+importFrom(icesASD,getAdviceViewRecord)
 importFrom(icesSAG,getListStocks)
 importFrom(jsonlite,fromJSON)
 importFrom(lubridate,month)
 importFrom(lubridate,year)
 importFrom(magrittr,"%>%")
+importFrom(rlang,sym)
 importFrom(shiny,NS)
 importFrom(shiny,actionButton)
 importFrom(shiny,bindEvent)

R/app_server.R

@@ -8,7 +8,7 @@
 #' @noRd
 app_server <- function(input, output, session) {
 
-  mod_SID_SAG_checks_server("SID_SAG_checks_1")
+  mod_db_checks_server("db_checks_1")
   mod_user_checks_server("user_checks_1")
 
-}
+}

R/app_ui.R

@@ -3,7 +3,7 @@
 #' @param request Internal parameter for `{shiny}`.
 #'     DO NOT REMOVE.
 #' @importFrom shiny tagList navbarPage tabPanel fluidRow uiOutput textOutput actionButton
-#' @importFrom bslib value_box card_body layout_column_wrap bs_theme
+#' @importFrom bslib value_box card card_header card_body layout_column_wrap bs_theme 
 #' @importFrom htmltools css h1 tags
 #' @importFrom bsicons bs_icon
 #' @importFrom DT dataTableOutput DTOutput
@@ -18,8 +18,8 @@ app_ui <- function(request) {
     navbarPage(
       theme = bs_theme(bootswatch = "cyborg"),
       title = paste0("icesTEASD: Tool for Error Alignment of Stock Databases, v", desc_get_version()),
-      tabPanel("SID SAG checks",
-               mod_SID_SAG_checks_ui("SID_SAG_checks_1")
+      tabPanel("Database checks",
+               mod_db_checks_ui("db_checks_1")
       ),
       tabPanel("User checks",
                mod_user_checks_ui("user_checks_1"))

R/fct_check_db_errors.R

@@ -1,59 +1,85 @@
 #' check_db_errors
 #'
-#' @description A fct function
+#' @description A function running checks on SID and SAG database entries in a given year. 
 #'
-#' @return The return value, if any, from executing the function.
+#' @return A \emph{dataframe} of stocks with identified issues
+#' @param year A number
 #'
 #' @noRd
 #'
 #' @importFrom icesSAG getListStocks
-#' @importFrom dplyr filter select mutate bind_rows
+#' @importFrom icesASD getAdviceViewRecord
+#' @importFrom dplyr filter select mutate bind_rows left_join
 #' @importFrom magrittr %>%
 #' @importFrom shiny validate need
 #' @importFrom jsonlite fromJSON
 #'
 check_stock_db_errors <- function(year) {
 
+
   url <- paste0(
     "http://sd.ices.dk/services/odata4/StockListDWs4?$filter=ActiveYear%20eq%20",
     year
   )
+
   out <- fromJSON(url, simplifyDataFrame = TRUE)$value
-  sid_data <- unique(out)
-
-  # sid_data <- getSD(year = year) # - need to resove issue with libsodium
-  sag_data <- getListStocks(year = year)
 
+  SID_data <- unique(out)
+  SAG_data <- getListStocks(year = year)
+  ASD_data <- getAdviceViewRecord(year = year)
+
   validate(
-    need(!is.null(sid_data), "SID not responding correctly"),
-    need(!is.null(sag_data), "SAG not responding correctly")
+    need(!is.null(SID_data), "SID not responding correctly"),
+    need(!is.null(SAG_data), "SAG not responding correctly"),
+    need(!is.null(ASD_data), "ASD not responding correctly")
   )
-  sag_data <- sag_data %>% filter(Purpose == "Advice")
+
+  SAG_advice_data <- SAG_data %>% filter(Purpose == "Advice")
+  SID_selected_year <- SID_data %>%
+    filter(YearOfLastAssessment == year)
+  # SID_data <- getSD(year = year) # - need to resove issue with libsodium
 
   SID_errors <-
-    sid_data %>%
+    SID_data %>%
     filter(YearOfNextAssessment == year) %>%
     select(Stock = StockKeyLabel) %>%
-    mutate(Issue = "Year of Next Assessment in past")
-
-
-  sid_data <- sid_data %>% filter(YearOfLastAssessment == year)
+    mutate(Database = "SID",
+           Issue = "Year of Next Assessment in past")
 
+
+
   mismatch_missing_in_SID <-
-    data.frame(Stock = setdiff(sag_data$StockKeyLabel, sid_data$StockKeyLabel)) %>%
-    mutate(
-      Issue = "Stock missing from SID"
+    data.frame(Stock = setdiff(SAG_advice_data$StockKeyLabel, SID_selected_year$StockKeyLabel)) %>%
+    mutate(Database = "SID",
+      Issue = "Stock missing"
     )
-
+  
   mismatch_missing_in_SAG <-
-    data.frame(Stock = setdiff(sid_data$StockKeyLabel, sag_data$StockKeyLabel)) %>%
-    mutate(Issue = "Stock missing from SAG")
+    data.frame(Stock = setdiff(SID_selected_year$StockKeyLabel, SAG_advice_data$StockKeyLabel)) %>%
+    mutate(Database = "SAG", 
+           Issue = "Stock missing")
+
+  mismatch_missing_in_SAG[mismatch_missing_in_SAG$Stock %in% SAG_data$StockKeyLabel,] <- "No SAG entry with Purpose == Advice"
+
+  mismatches_SAG_ASD <-
+      data.frame(Stock = setdiff(SAG_data$StockKeyLabel, ASD_data$stockCode)) %>%
+      mutate(Database = "ASD",
+             Issue = "Stock missing")
+
+  replaced_advice <-
+      data.frame(Stock = setdiff(ASD_data[ASD_data$adviceStatus == "Replaced", ]$stockCode, ASD_data[ASD_data$adviceStatus == "Advice", ]$stockCode)) %>%
+      mutate(Database = "ASD",
+             Issue = "Replaced advice; latest advice missing")
+
 
-  return(
-    bind_rows(
+  issues <- bind_rows(
       SID_errors,
       mismatch_missing_in_SID,
-      mismatch_missing_in_SAG
-    )
-  )
+      mismatch_missing_in_SAG,
+      mismatches_SAG_ASD,
+    ) %>% join_expert_group(SID_data = SID_data, match_column = "Stock", year = year)
+
+  return(issues)
 }
+
+

R/mod_db_checks.R

@@ -0,0 +1,96 @@
+#' db_checks UI Function
+#'
+#' @description A shiny Module to identify errors in, and mismatches between, ICES SID and SAG databases
+#'
+#' @param id,input,output,session Internal parameters for {shiny}.
+#' @noRd
+#'
+#' @importFrom shiny NS tagList
+mod_db_checks_ui <- function(id){
+  ns <- NS(id)
+  tagList(
+      layout_column_wrap(
+        fill = T,
+        width = 1/2, heights_equal = "row",
+        card(
+          uiOutput(outputId = ns("year_selector")), 
+          actionButton(inputId = ns("check"), label = "Check for mismatches",
+                       class = "btn btn-primary"),
+          value_box(
+            title = "Stock Database issues",
+            value = textOutput(ns("n_errors")),
+            showcase = bs_icon("wrench"))
+            ),
+        card(height = "300px",
+          card_header("Overview"),
+          dataTableOutput(outputId = ns("EG_table")), full_screen = T
+          )
+      ),
+      card(height = "600px",
+        card_header("Detail"),
+        DTOutput(outputId = ns("detail_table")), full_screen = T)
+  )
+}
+
+#' db_checks Server Functions
+#'
+#' @noRd
+#' @importFrom dplyr summarise n arrange
+mod_db_checks_server <- function(id){
+  moduleServer( id, function(input, output, session){
+    ns <- session$ns
+
+    output$year_selector <- renderUI({
+      years <- seq(year(Sys.Date()),year(Sys.Date())-7)
+      if(month(Sys.Date()) <=5) {
+        default_year <- years[2]
+      } else {
+        default_year <- years[1]
+      }
+      selectInput(inputId = ns("year"), label = "Select Assessment Year", choices = years, selected = default_year, multiple = F, width = "100%")
+    })
+
+
+    data <- reactive({
+      issues <-check_stock_db_errors(year = input$year)
+    }) %>%
+      bindEvent(input$check)
+
+
+    output$EG_table <- renderDT({
+      req(!is.null(data()))
+
+      eg_df <- data() %>% summarise(.by = ExpertGroup, Issues = n()) %>% arrange(desc(Issues))
+
+      datatable(eg_df, options = list(pageLength = 20, 
+                                      dom = "tip", 
+                                      lengthMenu = c(5, 10, 15, 20)),
+                    rownames = FALSE)
+    })
+
+
+    output$detail_table <- renderDT({
+      req(!is.null(data()))
+      detail_df <- select(data(), c(Stock, Database, Issue, ExpertGroup, YearOfLastAssessment, YearOfNextAssessment, AssessmentFrequency)) %>% 
+        arrange(Stock)
+
+      datatable(detail_df,filter = "top",
+                options = list(pageLength = 20,
+                               dom = "tip",
+                               lengthMenu = c(5, 10, 15, 20)),
+                    rownames = FALSE)
+    })
+
+
+    output$n_errors <- renderText({
+      req(!is.null(data()))
+      nrow(data())
+    })
+  })
+}
+
+## To be copied in the UI
+# mod_db_checks_ui("db_checks_1")
+
+## To be copied in the server
+# mod_db_checks_server("db_checks_1")