OrderInputs within DT cells

[tsolloway]

Hello,

I'm new to this and am having a problem placing a single orderInput into a DT cell and connecting with other orderInput in cells of the same column. My goal is to make each column cell dragable/sortable within the column. I can't figure out how to connect the orderInputs.

I'm noticing the orderInputs' html within the DT is different from orderInputs I would just generate in the UI. Any guidance on what I'm missing here?

Bests, Tyler

library(shiny)
library(shinyjqui)

ui <- shinyUI(
  fluidPage(
    h2('Reorder'),
    DT::dataTableOutput('mytable')
  )
)

server = shinyServer(function(input, output, session) {

  data <- head(mtcars)

  # helper function for making inputboxes in a DT
  shinyInput = function(FUN, BrandID, stem, items, id,connect,  ...) { 
    unlist(lapply(seq_len(length(items)), function(x){
      as.character(FUN(inputId=paste(id, stem, BrandID[x], sep="_"), label = NULL, items=items[x],connect[-x], ...))
    }))
  } 

  # datatable with orderinputs
  output$mytable = DT::renderDataTable({
    x <- data.frame(
      sapply(1:ncol(data), function(x){
        shinyInput(FUN=shinyjqui::orderInput,
                   BrandID=as.character(rownames(data)), 
                   stem=names(data)[x], 
                   items=as.character(data[,x]),
                   id="OrdImp",
                   connect=paste("OrdImp", names(data)[x], as.character(rownames(data)), sep="_"),
                   as_source=T,
                   width="20%", 
                   item_class='primary')
      })
    )
    names(x) <- names(data)
    rownames(x) <- rownames(data)

    data.frame(x)
  }, server = T, escape = F, selection="none", filter="none", options = list( 
    dom='t', ordering=F, paging=F,
    preDrawCallback = JS('function() {Shiny.unbindAll(this.api().table().node());}'), 
    drawCallback = JS('function() {Shiny.bindAll(this.api().table().node());} ') 
  ))
}
)

shinyApp(ui = ui, server = server)

[DamianRodziewicz]

Hi @tsolloway,

I took a look at the example you provided. Looks like it won't be easy to implement with the orderInput. orderInput generates the divs itself and it won't be possible to include this structure into the datatables at this stage.

If you want to sort elements in a column of a datatable in shiny, you can take a look at following code that I wrote:

library(shiny)
library(purrr)
library(DT)

ui <- shinyUI(
  fluidPage(
    tags$head(tags$script(src = "https://ajax.googleapis.com/ajax/libs/jqueryui/1.12.1/jquery-ui.min.js")),
    h2("Reorder"),
    DT::dataTableOutput("mytable")
  )
)

moveValue <- function(values, source, target) {
  movedValue <- values[source]

  values[-source] %>%
    append(movedValue, target - 1)
}

server = shinyServer(function(input, output, session) {
  data <- reactiveVal(cbind(list(id = c(1, 2, 3, 4, 5, 6)), head(mtcars)))

  create_div <- function(value, row, column) {
    as.character(
      div(`data-row` = row, `data-column` = column, class = "droppable-container",
          div(`data-row` = row, `data-column` = column, class = "btn btn-primary draggable-value", style = "cursor: pointer",
              value)))
  }

  html_data <- reactive({
    as.data.frame(imap(data(), function(values, column) {
      unlist(imap(values, function(value, row) { create_div(value, row, column) }))
    }))
  })

  output$mytable = DT::renderDataTable({
    isolate(html_data())
  }, server = T, escape = F, selection="none", filter="none", options = list(
    dom = "t", ordering=F, paging=F,
    preDrawCallback = JS("function() {Shiny.unbindAll(this.api().table().node());}"),
    drawCallback = JS('
      function() {
        Shiny.bindAll(this.api().table().node());

        jQuery(".draggable-value").draggable({
          revert: "invalid",
          cursor: "pointer"
        });

        jQuery(".droppable-container").droppable({
          accept:".draggable-value",
          drop: function( event, ui ) {
            var data = {
              targetColumn: event.target.attributes["data-column"].value,
              targetRow: parseInt(event.target.attributes["data-row"].value),
              sourceColumn: ui.draggable.attr("data-column"),
              sourceRow: parseInt(ui.draggable.attr("data-row"))
            }

            ui.draggable.css({ top: 0, left: 0 })

            Shiny.setInputValue("drag_and_drop_event", data);
          }
        })
      }
    ')
  ))

  proxy <- DT::dataTableProxy("mytable")

  observe({
    DT::replaceData(proxy, html_data())
  })

  observe({
    dragAndDropEvent <- input[["drag_and_drop_event"]]

    if (!is.null(dragAndDropEvent)) {
      if (dragAndDropEvent$targetColumn == dragAndDropEvent$sourceColumn) {
        values <- isolate(data())

        values[dragAndDropEvent$sourceColumn] <- values[[dragAndDropEvent$sourceColumn]] %>%
          moveValue(dragAndDropEvent$sourceRow, dragAndDropEvent$targetRow)

        data(values)
      }
    }
  })
})

shinyApp(ui = ui, server = server)

Best, Damian, Appsilon Data Science

[tsolloway]

Amazing. Thank you so much! Too cool! I'm sorry I was daft by going down a poor solution, but you're too kind leading me to the proper one. Thank you!