R/select_cols_module.R

In spada: A 'shiny' Package for Data Analysis

# ui --------------------------------------------------------------------------
select_cols_ui <- function(id) {
  ns <- NS(id)

  card(
    card_header('Select Columns', class = 'mini-header'),
    card_body(
      selectizeInput(
        ns('vars_sel'),
        'Variable',
        NULL,
        multiple = T,
        options = list(plugins = list('remove_button', 'clear_button')),
        width = '80%'
      ),

      radioButtons(ns('radio_var_sel'), NULL,
                   c('Drop' = 'drop', 'Keep' = 'keep'), inline = T)
    ),
    card_footer(btn_task(ns('btn_sel'), 'Apply selection', icon('check')))
  )
}

# server ----------------------------------------------------------------------
select_cols_server <- function(id) {
  moduleServer(id, function(input, output, session) {
	  ns <- session$ns

    df_names <- reactive(get_act_dt(session) |> names())

    observe({
      req(df_names())
      updateSelectizeInput(
        session,
        'vars_sel',
        choices = c('', df_names())
      )
    }) |> bindEvent(df_names())

    observe({
      if(input$vars_sel |> length() == 0){
        msg('Select at least one variable')
        return()
      } else if(input$radio_var_sel == 'drop' && (all(df_names() %in% input$vars_sel))){
        msg('Leave at least 1 variable')
        return()
      } else {

        running_modal()
        temp <- copy(get_act_dt(session))

        if(input$radio_var_sel == 'keep') {

          temp <- temp[, .SD, .SDcols = input$vars_sel]

        } else if (input$radio_var_sel == 'drop'){
          temp <- temp[, .SD, .SDcols = setdiff(df_names(), input$vars_sel)]
        }

        update_act_dt(session, copy(temp), updated_cols = temp |> names(),
                      change_type = 'select_cols')
        rm(temp)
        remove_running_modal()
      }
    }) |> bindEvent(input$btn_sel)

  })
}