Skip to content

Instantly share code, notes, and snippets.

@pvictor
Created April 12, 2018 10:22
Show Gist options
  • Save pvictor/d2c934c858aa221118398c0f6c394928 to your computer and use it in GitHub Desktop.
Save pvictor/d2c934c858aa221118398c0f6c394928 to your computer and use it in GitHub Desktop.
Module Shiny pour définir des groupes
# ------------------------------------------------------------------------
#
# 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