This was a fun one. I learned that the group
variable of a SortableJS
object can be an object with more information in it... such as a put
function which determines if objects may be placed.
Demo (gif):
App:
library(shiny)
library(sortable)
max_1_item_opts <- sortable_options(
# inspiration from https://jsbin.com/nacoyah/edit?js,output
# Sortable.create(qux, {
# group: {
# name: 'qux',
# put: function (to) {
# return to.el.children.length < 4;
# }
# },
# animation: 100
# });
# I have not seen a group value be done as an object before this post.
# Glad to see `sortable` handle it!
group = list(
# use a group name to allow sharing between lists
name = "my_shared_group",
# add a `put` function that can determine if an element may be placed
put = htmlwidgets::JS("
function(to) {
// only allow a 'put' if there is less than 1 child already
return to.el.children.length < 1;
}
")
)
)
ui <- fluidPage(
fluidRow(
column(
width = 3,
tags$h2("Main list"),
rank_list(
# text = "Main List",
labels = sample(paste0("list item ", 1:5)),
input_id = "main_list",
# be sure to have the same group name
options = sortable_options(group = "my_shared_group")
),
),
column(
width = 12 - 3,
tags$h2("1 item per list max!!!"),
column(width = 12/3, # 1/3 of width available
rank_list(
# text = "List 1",
labels = c(),
input_id = "list_1",
options = max_1_item_opts
)
),
column(width = 12/3,
rank_list(
# text = "List 2",
labels = c(),
input_id = "list_2",
options = max_1_item_opts
)
),
column(width = 12/3,
rank_list(
# text = "List 3",
labels = c(),
input_id = "list_3",
options = max_1_item_opts
)
)
)
),
# display answers
tags$p("Answers"),
"Main: ", verbatimTextOutput("result_main"),
"1st: ", verbatimTextOutput("result_1"),
"2nd: ", verbatimTextOutput("result_2"),
"3rd: ", verbatimTextOutput("result_3")
)
server <- function(input, output) {
output$result_main <- renderPrint({
# This matches the input_id of each rank list
input$main_list
})
output$result_1 <- renderPrint({ input$list_1 })
output$result_2 <- renderPrint({ input$list_2 })
output$result_3 <- renderPrint({ input$list_3 })
}
shinyApp(ui, server)
I did not incorporate the CSS into app. Please look into using class
argument for rank_list
. For inspiration on how the css is currently defined, see sortable's compiled css.
Note: The JS fiddle provided used a jQuery sortable plugin. The R sortable
package was built using SortableJS (which is independent of the jQuery sortable plugin)