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

user_13440409 0
Viewed 380

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)
dt shiny r
1 Answers

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();",
  "        }",
  "      }",
  "    };",
  "  }",
  "});"
)
user_11001070
Related