Add dropdown list to every column in a DT table where the values from the dropdown lists are fetched from another dataframe

Question

Based on the very useful reproductive example found here, I have added a dropdown list to every columns of my DT table.

However I'm looking for a way to populate those dropdown lists with values from another dataframe that shares the same column names than the one use in the DT table.

I tried to subset the second dataframe (here "iris2") with the input$dtable_columns_selected but I think I'm missing something here...

My attempt:

library(shiny)
library(DT)

Sepal.Length <- c(10,11,12,13,14)
Sepal.Width <- c(1,2,3,4,5)
Petal.Length <- c(10,11,12,13,14)
Petal.Width <- c(1,2,3,4,5)
Species <- c("SpeciesA", "SpeciesB","SpeciesC", "SpeciesD", "SpeciesE")

iris2 <- data.frame(Sepal.Length, Sepal.Width,Petal.Length,Petal.Width)

callback <- c(
  "var id = $(table.table().node()).closest('.datatables').attr('id');",
  "$.contextMenu({",
  "  selector: '#' + id + ' td.factor input[type=text]',",
  "  trigger: 'hover',",
  "  build: function($trigger, e){",
  "    var levels = $trigger.parent().data('levels');",
  "    if(levels === undefined){",
  "      var colindex = table.cell($trigger.parent()[0]).index().column;",
  "      levels = table.column(colindex).data().unique();",
  "    }",
  "    var options = levels.reduce(function(result, item, index, array){",
  "      result[index] = item;",
  "      return result;",
  "    }, {});",
  "    return {",
  "      autoHide: true,",
  "      items: {",
  "        dropdown: {",
  "          name: 'Edit',",
  "          type: 'select',",
  "          options: options,",
  "          selected: 0",
  "        }",
  "      },",
  "      events: {",
  "        show: function(opts){",
  "          opts.$trigger.off('blur');",
  "        },",
  "        hide: function(opts){",
  "          var $this = this;",
  "          var data = $.contextMenu.getInputValues(opts, $this.data());",
  "          var $input = opts.$trigger;",
  "          $input.val(options[data.dropdown]);",
  "          $input.trigger('change');",
  "        }",
  "      }",
  "    };",
  "  }",
  "});"
)

createdCell <- function(levels){
  if(missing(levels)){
    return("function(td, cellData, rowData, rowIndex, colIndex){}")
  }
  quotedLevels <- toString(sprintf("\"%s\"", levels))
  c(
    "function(td, cellData, rowData, rowIndex, colIndex){",
    sprintf("  $(td).attr('data-levels', '[%s]');", quotedLevels),
    "}"
  )
}

ui <- fluidPage(
  tags$head(
    tags$link(
      rel = "stylesheet",
      href = "https://cdnjs.cloudflare.com/ajax/libs/jquery-contextmenu/2.8.0/jquery.contextMenu.min.css"
    ),
    tags$script(
      src = "https://cdnjs.cloudflare.com/ajax/libs/jquery-contextmenu/2.8.0/jquery.contextMenu.min.js"
    )
  ),
  DTOutput("dtable")
)

server <- function(input, output){
  output[["dtable"]] <- renderDT({
    datatable(
      iris, editable = "cell", callback = JS(callback),
      options = list(
        columnDefs = list(
          list(
            targets = "_all",
            className = "factor",
            createdCell = JS(createdCell(c(levels(iris2[,input$dtable_columns_selected]))))
          )
        )
      )
    )
  }, server = FALSE)
}

shinyApp(ui, server)

[Here](https://stackoverflow.com/questions/69344974/dt-dynamically-change-column-values-based-on-selectinput-from-another-column-in/69389649#69389649) and [here](https://stackoverflow.com/questions/69959720/edit-datatable-in-shiny-with-dropdown-selection-for-dt-v0-19/69991231#69991231) you can find related answers. — ismirsehregal, Jan 19 '22 at 12:37
Thanks ismirsehregal for your reply ! But my dt table has 25 columns and I don't understand how the scripts provided in these posts allow to populate the dropdown lists with the values of another dataframe. Could you help me a bit more to put me on track please ? — wanderzen, Jan 19 '22 at 17:09
Not sure if this is intended but the `selectizeInput` approach won't work here because the currently displayed selection needs to be available in the choices (your example data does not comply with this restriction). E.g. this: `selectizeInput("test", "test", choices = 1:10, selected = 12)` doesn't work. — ismirsehregal, Jan 20 '22 at 13:23

Stéphane Laurent · Accepted Answer · 2022-01-21T19:59:09.877

This seems to work:

library(shiny)
library(DT)
library(jsonlite)

Sepal.Length <- c(10,11,12,13,14)
Sepal.Width  <- c(1,2,3,4,5)
Petal.Length <- c(10,11,12,13,14)
Petal.Width  <- c(1,2,3,4,5)
Species      <- c("SpeciesA", "SpeciesB", "SpeciesC", "SpeciesD", "SpeciesE")

iris2 <- data.frame(
  Sepal.Length, 
  Sepal.Width, 
  Petal.Length, 
  Petal.Width,
  Species
)

callback <- c(
  "var id = $(table.table().node()).closest('.datatables').attr('id');",
  "$.contextMenu({",
  "  selector: '#' + id + ' td input[type=text]',",
  "  trigger: 'hover',",
  "  build: function($trigger, e){",
  "    var levels = $trigger.parent().data('levels');",
  "    if(levels === undefined){",
  "      var colindex = table.cell($trigger.parent()[0]).index().column;",
  "      levels = table.column(colindex).data().unique();",
  "    }",
  "    var options = levels.reduce(function(result, item, index, array){",
  "      result[index] = item;",
  "      return result;",
  "    }, {});",
  "    return {",
  "      autoHide: true,",
  "      items: {",
  "        dropdown: {",
  "          name: 'Edit',",
  "          type: 'select',",
  "          options: options,",
  "          selected: 0",
  "        }",
  "      },",
  "      events: {",
  "        show: function(opts){",
  "          opts.$trigger.off('blur');",
  "        },",
  "        hide: function(opts){",
  "          var $this = this;",
  "          var data = $.contextMenu.getInputValues(opts, $this.data());",
  "          var $input = opts.$trigger;",
  "          $input.val(options[data.dropdown]);",
  "          $input.parent().html($input.val());",
  "        }",
  "      }",
  "    };",
  "  }",
  "});"
)

createdCell <- function(dat2){
  dat2_json <- toJSON(dat2, dataframe = "values")
  c(
    "function(td, cellData, rowData, rowIndex, colIndex){",
    sprintf("  var matrix = %s;", dat2_json),
    "  var tmatrix = matrix[0].map((col, i) => matrix.map(row => row[i]));", # we transpose
    "  $(td).attr('data-levels', JSON.stringify(tmatrix[colIndex]));",
    "}"
  )
}

ui <- fluidPage(
  tags$head(
    tags$link(
      rel = "stylesheet",
      href = "https://cdnjs.cloudflare.com/ajax/libs/jquery-contextmenu/2.8.0/jquery.contextMenu.min.css"
    ),
    tags$script(
      src = "https://cdnjs.cloudflare.com/ajax/libs/jquery-contextmenu/2.8.0/jquery.contextMenu.min.js"
    )
  ),
  DTOutput("dtable")
)

server <- function(input, output){
  output[["dtable"]] <- renderDT({
    datatable(
      iris, editable = list(target = "cell", numeric = "none"), 
      callback = JS(callback), rownames = FALSE,
      options = list(
        columnDefs = list(
          list(
            targets = "_all",
            createdCell = JS(createdCell(iris2))
          )
        )
      )
    )
  }, server = FALSE)
}

shinyApp(ui, server)

EDIT

The previous callback changes the value of the cell only on the display of the table, it does not change the data of the table. It is better to use the following callback:

callback <- c(
  "var id = $(table.table().node()).closest('.datatables').attr('id');",
  "$.contextMenu({",
  "  selector: '#' + id + ' td input[type=text]',",
  "  trigger: 'hover',",
  "  build: function($trigger, e){",
  "    var levels = $trigger.parent().data('levels');",
  "    if(levels === undefined){",
  "      var colindex = table.cell($trigger.parent()[0]).index().column;",
  "      levels = table.column(colindex).data().unique();",
  "    }",
  "    var options = levels.reduce(function(result, item, index, array){",
  "      result[index] = item;",
  "      return result;",
  "    }, {});",
  "    return {",
  "      autoHide: true,",
  "      items: {",
  "        dropdown: {",
  "          name: 'Edit',",
  "          type: 'select',",
  "          options: options,",
  "          selected: 0",
  "        }",
  "      },",
  "      events: {",
  "        show: function(opts){",
  "          opts.$trigger.off('blur');",
  "        },",
  "        hide: function(opts){",
  "          var $this = this;",
  "          var data = $.contextMenu.getInputValues(opts, $this.data());",
  "          var $input = opts.$trigger;",
  "          var td = $input.parent();",
  "          $input.remove();",
  "          table.cell(td).data(options[data.dropdown]).draw();",
  "        }",
  "      }",
  "    };",
  "  }",
  "});"
)

Add dropdown list to every column in a DT table where the values from the dropdown lists are fetched from another dataframe

1 Answers1

EDIT