Module Shiny pour définir des groupes

module_choix_groupes.R

#  ------------------------------------------------------------------------
#
# Title : Module choix groupe
#    By : Vic
#  Date : 2018-04-12
#    
#  ------------------------------------------------------------------------




# Packages ----------------------------------------------------------------

library("shiny")



# Funs --------------------------------------------------------------------

toggleBtnUi <- function(message) {
  js <- sprintf(
    paste(
      "Shiny.addCustomMessageHandler('%s', function(data) {",
      "if (data.type == 'disable') {",
      "$('#' + data.id).prop('disabled', true);",
      "$('#' + data.id).addClass('disabled');",
      "}",
      "if (data.type == 'enable') {",
      "$('#' + data.id).prop('disabled', false);",
      "$('#' + data.id).removeClass('disabled');",
      "}",
      "});", collapse = "\n"
    )
    , message
  )
  tags$script(js)
}


toggleBtnServer <- function(session, message, id, type = "disable") {
  session$sendCustomMessage(
    type = message,
    message = list(id = id, type = type)
  )
}



# Module ------------------------------------------------------------------

choixGroupeUI <- function(id) {
  
  ns <- NS(id)
  
  tagList(
    tags$div(id = ns("placeholder-grp-select")),
    tagList(
      tags$div(
        class="btn-group btn-group-justified", role="group",
        tags$div(
          class="btn-group", role="group",
          actionButton(inputId = ns("remove_grp"), label = "Enlever un groupe", icon = icon("minus"))
        ),
        tags$div(
          class="btn-group", role="group",
          actionButton(inputId = ns("add_grp"), label = "Ajouter un groupe", icon = icon("plus"))
        )
      ),
      toggleBtnUi(ns("toggle-btn"))
    )
  )
}


choixGroupeServer <- function(input, output, session, choix, n_grp_init = 2, n_grp_min = 2, n_grp_max = 10) {
  
  # Namespace
  ns <- session$ns
  jns <- function(id) paste0("#", ns(id))
  
  if (n_grp_init == n_grp_min) {
    toggleBtnServer(session, message = ns("toggle-btn"), id = ns("remove_grp"), type = "disable")
  }
  
  # Initialisation
  insertUI(
    selector = jns("placeholder-grp-select"),
    ui = tagList(
      lapply(
        X = seq_len(n_grp_init),
        FUN = function(i) {
          tags$div(
            id = ns(paste0("ctn-grp-", i)),
            selectizeInput(
              inputId = ns(paste0("grp_", i)), 
              label = paste("Groupe", i),
              multiple = TRUE, width = "100%",
              choices = isolate(choix()),
              selected = "",
              options = list(plugins = list("remove_button"))
            )
          )
        }
      )
    )
  )
  
  # Nombre de groupe
  nbre_grp <- reactiveValues(x = n_grp_init)
  
  # Id des selectize
  grp_id <- reactiveValues(x = paste0("grp_", n_grp_init))
  
  # List choix
  choix_select <- reactiveValues()
  observeEvent(reactiveValuesToList(input), {
    for (i in seq_len(n_grp_max)) {
      if (i <= nbre_grp$x) {
        choix_select[[paste0("grp_", i)]] <- input[[paste0("grp_", i)]]
      }
    }
  }, ignoreNULL = FALSE)
  
  observeEvent(input$add_grp, {
    lesautres <- seq_len(nbre_grp$x)
    lesautreschoix <- lapply(lesautres, function(x) choix_select[[paste0("grp_", x)]])
    lesautreschoix <- unlist(lesautreschoix, use.names = FALSE)
    nbre_grp$x <- nbre_grp$x + 1
    if (nbre_grp$x > n_grp_min) {
      toggleBtnServer(session, message = ns("toggle-btn"), id = ns("remove_grp"), type = "enable")
    } else {
      toggleBtnServer(session, message = ns("toggle-btn"), id = ns("remove_grp"), type = "disable")
    }
    if (!is.null(n_grp_max)) {
      if (nbre_grp$x <= n_grp_max) {
        grp_id$x <- c(grp_id$x, paste0("grp_", nbre_grp$x))
        insertUI(
          selector = jns("placeholder-grp-select"), where = "beforeEnd",
          ui = tags$div(
            id = ns(paste0("ctn-grp-", nbre_grp$x)),
            selectizeInput(
              inputId = ns(paste0("grp_", nbre_grp$x)), 
              label = paste("Groupe", nbre_grp$x),
              multiple = TRUE, width = "100%",
              choices = setdiff(choix(), lesautreschoix), 
              selected = NULL,
              options = list(plugins = list("remove_button"))
            )
          )
        )
      }
      if (nbre_grp$x == n_grp_max) {
        toggleBtnServer(session, message = ns("toggle-btn"), id = ns("add_grp"), type = "disable")
      } else {
        toggleBtnServer(session, message = ns("toggle-btn"), id = ns("add_grp"), type = "enable")
      }
    } else {
      grp_id$x <- c(grp_id$x, paste0("grp_", nbre_grp$x))
      insertUI(
        selector = jns("placeholder-grp-select"), where = "beforeEnd",
        ui = tags$div(
          id = ns(paste0("ctn-grp-", nbre_grp$x)),
          selectizeInput(
            inputId = ns(paste0("grp_", nbre_grp$x)), 
            label = paste("Groupe", nbre_grp$x),
            multiple = TRUE, width = "100%",
            selected = "",
            choices = setdiff(choix(), lesautreschoix),
            options = list(plugins = list("remove_button"))
          )
        )
      )
      if (nbre_grp$x == n_grp_min) {
        toggleBtnServer(session, message = ns("toggle-btn"), id = ns("remove_grp"), type = "disable")
      } else {
        toggleBtnServer(session, message = ns("toggle-btn"), id = ns("remove_grp"), type = "enable")
      }
    }
  })
  
  observeEvent(input$remove_grp, {
    # if (nbre_grp$x > n_grp_min) {
      removeUI(selector = jns(paste0("ctn-grp-", nbre_grp$x)), immediate = TRUE)
      choix_select[[paste0("grp_", nbre_grp$x)]] <- NULL
      nbre_grp$x <- nbre_grp$x - 1
      # if (nbre_grp$x > n_grp_min) {
      #   
      # }
      if (nbre_grp$x == n_grp_min) {
        toggleBtnServer(session, message = ns("toggle-btn"), id = ns("remove_grp"), type = "disable")
      } else {
        toggleBtnServer(session, message = ns("toggle-btn"), id = ns("remove_grp"), type = "enable")
      }
      if (nbre_grp$x < n_grp_max) {
        toggleBtnServer(session, message = ns("toggle-btn"), id = ns("add_grp"), type = "enable")
      }
    # }
  })
  
  
  # Update des choix si le nombre de modalite change en entree du module
  observeEvent(choix(), {
    lapply(
      X = seq_len(n_grp_max),
      FUN = function(x) {
        celuila <- x
        lesautres <- setdiff(seq_len(n_grp_max), celuila)
        lesautreschoix <- lapply(lesautres, function(x) {choix_select[[paste0("grp_", x)]]})
        lesautreschoix <- unlist(lesautreschoix, recursive = TRUE, use.names = FALSE)
        updateSelectizeInput(
          session = session,
          inputId = paste0("grp_", x),
          choices = setdiff(choix(), lesautreschoix),
          selected = intersect(choix(), choix_select[[paste0("grp_", x)]])
        )
      }
    )
  })
  
  
  # Choix dependant d'un select a l'autre
  lapply(
    X = seq_len(n_grp_max),
    FUN = function(x) {
      celuila <- x
      lesautres <- setdiff(seq_len(n_grp_max), celuila)
      observeEvent(
        list(
          lapply(lesautres, function(x) {choix_select[[paste0("grp_", x)]]})
        ), {
          leschoix <- choix()
          lesautreschoix <- lapply(lesautres, function(x) {choix_select[[paste0("grp_", x)]]})
          lesautreschoix <- unlist(lesautreschoix, recursive = TRUE, use.names = FALSE)
          ceschoix <- choix_select[[paste0("grp_", celuila)]]
          updateSelectizeInput(
            session = session,
            inputId = paste0("grp_", celuila),
            choices = setdiff(leschoix, lesautreschoix),
            selected = ceschoix
          )
        }
      )
    }
  )
  
  # Pour retourner uniquement le nbre de grp selectionne
  # return(reactive(reactiveValuesToList(choix_select)))
  return(reactive(reactiveValuesToList(choix_select)[seq_len(nbre_grp$x)]))
}



# App ---------------------------------------------------------------------



# ui ----

ui <- fluidPage(
  tags$h2("Module choix groupes"),
  
  fluidRow(
    column(
      width = 4,
      sliderInput(
        inputId = "modalites",
        label = "Modalités",
        min = 2, max = 26, value = 5
      ),
      choixGroupeUI("grrrr")
    ),
    column(
      width = 8,
      verbatimTextOutput(outputId = "res_mod")
    )
  )
)

# server ----

server <- function(input, output, session) {
  
  modalites_r <- reactive({
    LETTERS[seq_len(input$modalites)]
  })
  
  res <- callModule(module = choixGroupeServer, id = "grrrr", choix = modalites_r)
  
  output$res_mod <- renderPrint(res())
}

# app ----

shinyApp(ui = ui, server = server)