inst/apps/dragging_selectInputs/app.R

In MayaGans/dragulaR: Drag and Drop Elements in 'Shiny' using 'Dragula Javascript Library'

library(shiny)
library(dragulaR)

# creating a vector of blocks - note the two ANOVA blocks
# we can use make.unique to create an index for each block and it's dropdown menu
test <- make.unique(c("ONE", "TWO"))

aggBlocks <- function(data, name)
{
  div(style = "
      text-align: center;
      font-size: 12px;
      background-color: #A9A9A9;
      border-radius: 10px;
      color: black;
      margin-bottom: 5px;
      min-width: 100px;
      min-height:50px;
      ",
      drag = name,
      id = name,
      if (name == "ONE") {

        selectInput(name, "Dropdown", choices = c("group_1", "group_2", "group_3"), selectize = FALSE)
      } else {
        name
      }
  )
}


library(shiny)

ui <- fluidPage(

  # once the block enters the drag div
  # the block ID, selectInput ID should update
  # to ONE.1, ONE.2 etc etc
  # so that we can get the input$ONE.1 and distinguish it from input$ONE.2
  tags$script(HTML(

    ""
)),

  sidebarPanel(

    fluidRow(style = "margin: 15px;",
             column(6,
                    h3("Drag:"),
                    div( style="border: solid 2px black;",
                         div(id = "Available", style = "min-height: 600px;",
                             lapply(test, aggBlocks, data = test))
                    )
             ),
             column(6,
                    h3("Drop:"),
                    # Within the JS file we'll replace all the dropped select boxes IDs
                    # with unique IDs on every drop event
                    # is ondrop(event) valid here?
                    div(id = "container", ondrop="drop(event)", style="border: solid 2px black;",
                         div(id = "Model", style = "min-height: 600px;")
                    )
             )
    ),
    dragulaOutput("dragula")

  ),

  mainPanel(
    fluidRow(column(6,
                    h1("Debug"),
                    tableOutput('debug')
                    ),
    column(6,
           # create a div to see the new ids and trouble shoot
           # by setting the innerhtml outside of the drop loop I know that my file is being read
           # maybe the problem is with ondrop? or the function itself?
           # but this should be returning ONE, ONE_1, ONE_2 etc. etc.....
           # see drag_ids.js
           div(id ="inside_drop_zone", style="margin-top:50px;background-color:#d3d3d3;")
    ))),

includeScript(path = "drag_ids.js"))

server <- function(input, output, session) {

  output$dragula <- renderDragula({
    dragula(c("Available", "Model"), copyOnly = 'Available', removeOnSpill = TRUE)
  })

  d <-  reactive({
    req(length(input$dragula$Model) > 0)
    # by giving each dragged one a unique name with an underscore
    dat <- data.frame(id = make.unique(unlist(input$dragula$Model), sep="_"))
    # we can use JS to give each select box in the drop area a unique ID
    # then paste the input[[dat$id]] for each row to get the select box's values?
    # instead of pasting this will eventually give the value of the selected input
    dat$select_value <- paste0("input[[", dat$id, "]]")
    dat
  })

  output$debug <- renderTable({
    d()
  })

}

shinyApp(ui = ui, server = server)