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)

Answer 1

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)