Created
April 12, 2018 10:22
-
-
Save pvictor/d2c934c858aa221118398c0f6c394928 to your computer and use it in GitHub Desktop.
Module Shiny pour définir des groupes
This file contains hidden or bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| # ------------------------------------------------------------------------ | |
| # | |
| # 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) |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment