Edit datatable in Shiny with dropdown selection for factor variables

Question

I am trying to create a Shiny app that allows users to edit a datatable, whereby the edits are saved. Here is a minimal example:

library(shiny)
library(DT)

ui <- fluidPage(
  DT::DTOutput('df')
)

server <- function(session, input, output){
  df <- data.frame(x = factor(c("A", "B", "C"), levels = c("A", "B", "C")))
  output$df <- DT::renderDT(df,
                        editable = T)

  proxy <- dataTableProxy("df")

  observeEvent(input$df_cell_edit, {
    info <- input$df_cell_edit
    str(info)
    i <- info$row
    j <-  info$col
    v <- info$value
    df[i, j] <<- DT:::coerceValue(v, df[i, j])
    replaceData(proxy, df, resetPaging = FALSE)

  })
}

shinyApp(ui, server)

This allows me to edit the values of x in-line, but since x is a factor, I'd like to restrict the values that the user is able to input. Ideally, I would like this to be accomplished using a drop-down menu. Is this functionality possible using DT::datatable and Shiny?

Note: I know of the rhandsontable package, however I would prefer to use DT if possible.

Mercury

Could you find a solution for this? – Unger

@Unger unfortunately not. I used a combination of reactiveValues and selectInput to get what I want, but it is not a fluid design. – Mercury

You should take a look at this app from Jiena McLellan. – Sorry

@alessio thanks for sharing. This is similar to my current workaround, but unfortunately does not do what I originally want. What I wanted was the option to change factor variables directly within a datatable using dropdown menus. – Mercury

You can do that with the JS library cellEdit. See here. – Estrella

For future readers: Here and here you can find related answers using a shiny/DT-only approach. – Tacheometer

Answer 1

As I said in a comment, you can do that with the JS library cellEdit.

Here is another way, using the JS library contextMenu (a jQuery plugin).

library(shiny)
library(DT)

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 colindex = table.cell($trigger.parent()[0]).index().column;",
  "    var coldata = table.column(colindex).data().unique();",
  "    var options = coldata.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');",
  "        }",
  "      }",
  "    };",
  "  }",
  "});" 
)
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 = 5, className = "factor"
          )
        )
      )
    )
  }, server = FALSE)  
}

shinyApp(ui, server)

EDIT

Here is an improvement. In the previous app, the dropdown options are set to the unique values of the column. With the app below, you can set the dropdown options you want.

library(shiny)
library(DT)

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 = 5,
            className = "factor",
            createdCell = JS(createdCell(c(levels(iris$Species), "another level")))
          )
        )
      )
    )
  }, server = FALSE)
}

shinyApp(ui, server)

If you want to use the unique values of the column, set the option createdCell to JS(createdCell()), or simply don't set this option.

Supplicatory

this answer is awesome !!! I was just wondering if you knew how to populate the dropdown menus of every column of the datatable with another dataframe that shares some common columns with the dataframe used in the datatable ? I thought about something like this: createdCell = JS(createdCell(c(levels(dataframe2[,input$dtable_columns_selected])))) but it does not work ! – Saviour