skip to Main Content

This is my drag and drop app:

library(shiny)
library(shinyjqui)
library(shinyjs)
library(dplyr)


###### part 1 ------------------------------------------------------------------
#creating the list of items
df <- structure(list(AG = c("A",  "B", "C", "D")),
                row.names = c(NA,-4L), class = "data.frame")

# cells of table
connections1 <- paste0("droppable_cell", ifelse(1:2 == 1, "", 1:2), "_1")
connections2 <- paste0("droppable_cell", ifelse(1:2 == 1, "", 1:2), "_2")

connections <- c(connections1, connections2)

# Define a named list for vec_suggestion1 
vec_suggestion1 <- list(  
  droppable_cell_1 =   c("A", "B", "A", "B"),
  droppable_cell_2 =  c("A", "B", "B", "A")
)

# Create the data frame
my_df <- data.frame(connections = connections,
  stringsAsFactors = FALSE
)

my_df$vec_suggestion1 <- vec_suggestion1[my_df$connections]


###### part 2 ------------------------------------------------------------------

myComplexTableUI <-   div(id = "capture", class = "table-container",
                          div(class = "grid-table",
                              id = "montag",
                              div(class = "grid-row",
                                  div(class = "grid-cell grid-cell-text", "Montag"),
                                  lapply(1:2, function(i) {
                                    div(id = paste0("droppable_cell_", i), class = "grid-cell droppable-cell", "")
                                  })
                              )
                          )
                        
                        )

###### part 3 ------------------------------------------------------------------
# my js

jsCode <- "
$(function() {
    function createSortable(day) {
        $('[id^=droppable_cell' + day + '_]').sortable({
            connectWith: '#A, #B, [id^=droppable_cell' + day + '_]',
            drop: function(event, ui) {
                $(this).append(ui.draggable);
            }
        });
    }

    createSortable('1'); // For day1
    createSortable('2'); // For day2

  $('[id^=droppable_cell]').on('sortupdate', function(e, ui) {
        var cellId = $(this).attr('id');
        var item = ui.item.text();
        Shiny.setInputValue('dropEvent', {cell: cellId, item: item}, {priority: 'event'});
    });
});

shinyjs.pageCol = function(params) {
    $('[id^=droppable_cell]').sortable({
        connectWith: '#A, #B, [id^=droppable_cell_1], [id^=droppable_cell_2]',
        drop: function(event, ui) {
            $(this).append(ui.draggable);
        }
    });

    var dataArray = Object.values(params[0]);
    dataArray = dataArray[0].map((col, i) => dataArray.map(row => row[i]));

    console.log('dataArray: ', dataArray);

    var cacheA = $('#A').html();
    var cacheB = $('#B').html();

    var cacheGridCells1 = $('[id^=droppable_cell_1]').html();

shinyjs.setSuggestion = function (idxSuggestion) {
  $.each(dataArray, function (index, value) {
    var cellSelector = '#' + dataArray[index][0];
    var classIndex = idxSuggestion === 1 ? 1 : 2;
    
    // Retrieve the items for the current cell from dataArray
    var items = dataArray[index][idxSuggestion];
    if (typeof items === 'string') {
      items = [items]; // Convert to array if there is only one item
    }
    
    // Clear the cell content
    $(cellSelector).html('');
    
    // Append each item to the cell
    $.each(items, function (i, item) {
      if (item === null) {
        return true;
      }
      
      // Determine the style based on the item value
      var itemStyle = '';
      if (item === 'A') {
        itemStyle = 'background-color: #ffcc66;'; // Corresponding to Bootstrap's warning color
      } else if (item === 'B') {
        itemStyle = 'background-color: #5cb85c;'; // Corresponding to Bootstrap's success color
      }
      
      var cellHTML = '<div data-value="' + item
                   + '" class="btn btn-default ui-sortable-handle" style="' + itemStyle + ' margin: 1px;" jqui_sortable_idx="letters__' 
                   + (index + 1).toString()
                   + '">'
                   + item
                   + '</div>';
      
      $(cellSelector).append(cellHTML);
    });
  });
}
    shinyjs.resetDnD = function (params) {
    $('#A').html(cacheA).sortable('refresh');
    $('#B').html(cacheB).sortable('refresh');
    $('[id^=droppable_cell_1]').html(cacheGridCells1).sortable('refresh');
    }
};



      "
ui <- fluidPage(
  
  useShinyjs(),
  extendShinyjs(text = jsCode, functions = c("pageCol", "setSuggestion")),
  
  ###### part 4 ------------------------------------------------------------------
  
  # css table design
  tags$head(
    tags$style(
      HTML("
        .custom-title-panel button {
          margin-left: 10px;
          margin-top: 10px; 
        }
        .grid-table {
          width: 220px;
          border-collapse: collapse;
        }
        .grid-cell {
          width: 100%;
          height: 210px;
          border: 1px solid black;
          background-color: white;
          text-align: left;
          margin: 0;
          padding: 5px;
        }
        .grid-cell-text {
          display: flex;
          align-items: center;
          justify-content: center;
          height: 50px;
          background-color: steelblue;
          color: white;
          font-size: 18px;
        }
        .table-container {
          display: flex;
          position: absolute;
          left: 260px;
          top: 20px;
          margin-top: 0px;
          overflow: hidden;
        }
      ")
    )
  ),
  
  ##################################################################################
  
  
  # btn reset
  tags$script(
    HTML(
      "$(document).ready(function() {
          $('#btn_resetDnD').click(function() {
            $('.droppable-cell').html(''); // Remove content from all elements with the class 'droppable_cell'
          });
        });"
    )
  ),

  
  # my items:      
  tags$div(
    style = "position: relative; height: 50px;", # Setting a height to contain the buttons
    tags$div(style = "position: absolute; top: 30px; left: 20px;",
             orderInput("A", "", items = df$AG[1], as_source = TRUE, connect = connections, width = "100%", item_class = "warning")
    ),
    tags$div(style = "position: absolute; top: 30px; left: 65px;",
             orderInput("B", "", items = df$AG[2], as_source = TRUE, connect = connections, width = "100%", item_class = "success")
    )
  ),
  
  # my table:
  myComplexTableUI,
  
  # my buttons:
  tags$div(style = "position: absolute; top: 500px; left: 260px; display: flex; flex-direction: row;",
           actionButton("btn_suggestion1", "Suggestion1"),
           actionButton("btn_resetDnD", "Reset")
           
  )
  )


server <- function(input, output, session) {
  
  shinyjs::js$pageCol(my_df)
  
  observeEvent(input$btn_suggestion1, {
    shinyjs::disable("btn_suggestion1")
    shinyjs::js$setSuggestion(1)
    shinyjs::enable("btn_suggestion1")
  })
  
}

shinyApp(ui, server)

The app is doing basically this:
enter image description here

I would like to dynamically create the ‘vec_suggestion1’ input, which is currently hardcoded. I want the system to recognize and save the user’s input when they drag it to ‘droppable_cell1’.

vec_suggestion1 <- list(  
  droppable_cell_1 =   c("A", "B", "A", "B"),
  droppable_cell_2 =  c("A", "B", "B", "A")
)

I am aiming to provide the user with the ability to drag and drop their ideal combinations of A and B. This information should be dynamically saved to ‘vec_suggestion2’. Subsequently, any additional combinations of A’s and B’s should also be saved, but to ‘vec_suggestion3’, ‘vec_suggestion4’, and so on. Along with the creation of each new vector, a corresponding new button should be added, such as ‘btn_suggestion2’, ‘btn_suggestion3’, etc.

2

Answers


  1. There are a few steps you can follow to achieve this in R Shiny

    Create a reactiveValues object to store the combination vectors, then to update when the user drags and drops. could be initiated as empty list.

    now to update the reactiveValues object in the "sortupdate" event: In the "sortupdate" event, retrieve the cell id and the item dragged, and then use the update function to update the values$suggestions object with the new combination. now adding a button and corresponding action using renderUI and uiOutput functions. Within renderUI now using observeEvent function for defining actions for all buttons

    In event, using the renderUI function to generate a new list of items for droppable_cell1 and droppable_cell2 based on values in values$suggestions for particular combination index.

    Hope this helps!

    Login or Signup to reply.
  2. The following approach drops the custom JS and uses an orderInput for each cell, which simplifies keeping track of the lists. For now I dropped the item_class to keep things simple (We could save lists of divs to save the styling). However, the procedure to save custom combinations sould be clear:

    library(shiny)
    library(shinyjqui)
    library(dplyr)
    
    df <-structure(list(AG = c("A",  "B", "C", "D")), row.names = c(NA, -4L), class = "data.frame")
    
    # cells of table
    tableOrderInputIds <- paste0("Montag", "_droppable_cell_", 1:2)
    
    # Define a named list for vec_suggestion1
    # should vec_suggestions be global? Shared across shiny sessions?
    if (file.exists("vec_suggestions.RData")) {
      load(file = "vec_suggestions.RData")
    } else {
      vec_suggestions <- list(
        vec_suggestion1 = list(
          Montag_droppable_cell_1 = c("A", "B", "A", "B"),
          Montag_droppable_cell_2 = c("A", "B", "B", "A")
        ),
        vec_suggestion2 = list(
          Montag_droppable_cell_1 = c("B", "B", "B", "B"),
          Montag_droppable_cell_2 = c("A", "A", "A", "A")
        )
      )
    }
    
    ###### part 2 ------------------------------------------------------------------
    
    myComplexTableUI <- div(id = "capture",
                            class = "table-container",
                            div(
                              class = "grid-table",
                              id = "montag",
                              div(
                                class = "grid-row",
                                div(class = "grid-cell grid-cell-text", "Montag"),
                                lapply(tableOrderInputIds, function(x) {
                                  div(
                                    orderInput(
                                      inputId = x,
                                      label = NULL,
                                      items = NULL,
                                      connect = tableOrderInputIds,
                                      width = "100%",
                                      style = "min-height: 200px;"
                                    ),
                                    class = "grid-cell"
                                  )
                                })
                              )
                            ))
    
    ui <- fluidPage(
      # css table design
      tags$head(tags$style(
        HTML(
          "
            .custom-title-panel button {
              margin-left: 10px;
              margin-top: 10px;
            }
            .grid-table {
              width: 220px;
              border-collapse: collapse;
            }
            .grid-cell {
              width: 100%;
              height: 210px;
              border: 1px solid black;
              background-color: white;
              text-align: left;
              margin: 0;
              padding: 5px;
            }
            .grid-cell-text {
              display: flex;
              align-items: center;
              justify-content: center;
              height: 50px;
              background-color: steelblue;
              color: white;
              font-size: 18px;
            }
            .table-container {
              display: flex;
              position: absolute;
              left: 260px;
              top: 20px;
              margin-top: 0px;
              overflow: hidden;
            }
          "
        )
      )),
      # my items:
      tags$div(
        style = "position: relative; height: 50px;",
        # Setting a height to contain the buttons
        tags$div(
          style = "position: absolute; top: 30px; left: 20px;",
          orderInput(
            "A",
            "",
            items = df$AG[1],
            as_source = TRUE,
            connect = tableOrderInputIds,
            width = "100%"
          )
        ),
        tags$div(
          style = "position: absolute; top: 30px; left: 65px;",
          orderInput(
            "B",
            "",
            items = df$AG[2],
            as_source = TRUE,
            connect = tableOrderInputIds,
            width = "100%"
          )
        )
      ),
      # my table:
      myComplexTableUI,
      # my buttons:
      column(
        12,
        selectizeInput(
          "select_suggestion",
          "Select / Add suggestion",
          choices = names(vec_suggestions),
          multiple = FALSE,
          options = list('create' = TRUE,
                         'persist' = FALSE)
        ),
        actionButton("load_suggestion", "Load suggestion"),
        actionButton("btn_resetDnD", "Reset"),
        actionButton("save_suggestion", "Save suggestion"),
        style = "position: absolute; top: 500px; left: 20px;"
      )
    )
    
    server <- function(input, output, session) {
      # user_suggestion <- reactiveValues(droppable_cell_1 = NULL, droppable_cell_2 = NULL)
      user_suggestion <- do.call(shiny::reactiveValues, setNames(vector(mode = "list", length = length(tableOrderInputIds)), tableOrderInputIds))
      
      observeEvent(input$load_suggestion, {
        lapply(tableOrderInputIds, function(x) {
          updateOrderInput(session, inputId = x, items = vec_suggestions[[input$select_suggestion]][[x]])
        })
      }, ignoreNULL = FALSE)
      
      observeEvent(input$save_suggestion, {
        # should vec_suggestions be global? Shared across shiny sessions?
        vec_suggestions <<- modifyList(vec_suggestions, setNames(list(reactiveValuesToList(user_suggestion)), input$select_suggestion))
        save(vec_suggestions, file = "vec_suggestions.RData")
        showNotification("Saved suggestions to disk.")
      })
      
      observeEvent(input$btn_resetDnD, {
        lapply(tableOrderInputIds, function(x) {
          updateOrderInput(session, inputId = x, items = list())
        })
      })
      
      observe({
        lapply(tableOrderInputIds, function(x) {
          user_suggestion[[x]] <- input[[x]]
        })
      })
    }
    
    shinyApp(ui, server)
    

    result

    Login or Signup to reply.
Please signup or login to give your own answer.
Back To Top
Search