R/mod_viz_config.R

In datasketch/DSAppTemplate: DS App Template

#' viz_config UI Function
#'
#' @description A shiny Module.
#'
#' @param id,input,output,session Internal parameters for {shiny}.
#'
#' @noRd 
#'
#' @importFrom shiny NS tagList
#' @importFrom dplyr %>%
mod_viz_config_ui <- function(id){
  ns <- NS(id)
  tagList(
    uiOutput(ns("controls"))
  )
}
    
#' viz_config Server Function
#'
#' @noRd 
mod_viz_config_server <- function(id, r){
  
  moduleServer( id, function(input, output, session){
    ns <- session$ns
  
  fillValueSelected <- reactive({
    r$datasetColumnSelected[1]
  })
  
  colourMethodChoices <- reactive({
    colour_method_choices <- list("colourpalette" = "colourpalette", "custom" = "custom")
    names(colour_method_choices) <- shi18ny::i_(names(colour_method_choices), lang = r$lang(), i18n = r$i18n)
    colour_method_choices
  })
  
  background <- reactive({
    dsthemer::dsthemer_get("datasketch")$background_color
  })
  
  colourPaletteChoices <- reactive({
    c("Accent", "Dark2", "Paired", "Pastel1",
      "Pastel2", "Set1", "Set2", "Set3", "Greys")
  })
  
  dataLabelChoices <- reactive({
    label <- c("node_name", "total", "percentage")
    names(label) <- shi18ny::i_(c("node_name", "total", "percentage"), lang = r$lang(), i18n = r$i18n)
    label
  })
  
  categoriesFill <- reactive({
    req(r$plot_data_orig)
    d <- r$plot_data_orig %>% dplyr::distinct() %>% as.data.frame()
    nodes_unique <- c()
    for(col in names(d)){
      nodes_unique <- c(nodes_unique, unique(d[,col]))
    }
    unique(nodes_unique)
  })
  
  categoriesMissingsEncode <- reactive({
    categoriesFill()[!is.na(categoriesFill())]
  })
  
  colourCustomChoices <- reactive({
    paletero::paletero_cat(categoriesFill(), palette = "Set1")
  }) 
  
  maxCustomChoices <- reactive({
    length(categoriesFill())
  })
  
  fillFlow <- reactive({
    flow <- c("from", "to")
    names(flow) <- shi18ny::i_(c("left_to_right", "right_to_left"), lang = r$lang(), i18n = r$i18n)
    flow
  })
  
  hasdataNA <- reactive({
    data <- r$plot_data_orig
    cols_contain_na <- purrr::map_lgl(.x = data,
                                      .f = function(.x) any(is.na(.x)))
    if(length(input$code_as_na > 0)){
      cols_contain_na <- c(cols_contain_na, TRUE)
    }
    any(cols_contain_na)
  })
  
  input_drop_na <- reactive({
    if(is.null(input$drop_na)){
      drop_na <- FALSE
    } else {
      drop_na <- input$drop_na
    }
    drop_na
  })
  
  path <- "parmesan"
  parmesan <- parmesan::parmesan_load(path)
  parmesan_input <- parmesan::parmesan_watch(input, parmesan)
  parmesan::parmesan_alert(parmesan, env = environment())
  parmesan_lang <- reactive({shi18ny::i_(parmesan, lang = r$lang(), i18n = r$i18n, keys = c("label", "choices", "text"))})
  
  parmesan::output_parmesan(ns("controls"),
                            parmesan = parmesan_lang,
                            input = input,
                            output = output,
                            env = environment())
  
  observe({
    r$colour_method <- input$colour_method
  })

  })
  
}