Choose a datatable row either by clicking, actionButton() or shiny widget - r

Question

I have the shiny app below in which the user is able to choose a row to display its index with 3 ways.
Click on the row and display its index
Click on a row then press Next and display the index of the next row.
Select the rowname of a row,press Assign and display its index.
I know that I can use callback in order to enable datatable to achieve this but I do not know how to combine many callbacks.
library(shiny)
library(DT)
dat <- mtcars
callback <- JS(
"Shiny.addCustomMessageHandler(",
" 'selectRow',",
" function(index) {",
" table.row(index - 1).select();",
" }",
");",
"$('#btn-next').prop('disabled', true);",
"var selected_row = null;",
"table.on('select', function( e, dt, type, indexes ) {",
" $('#btn-next').prop('disabled', false);",
" selected_row = indexes[0];",
"});",
"table.on('deselect', function( e, dt, type, indexes ) {",
" $('#btn-next').prop('disabled', true);",
"});",
"var nrows = table.rows().count();",
"$('#btn-next').on('click', function() {",
" var next_row = selected_row + 1 < nrows ? selected_row + 1 : 0;",
" table.row(next_row).select();",
"});"
)
ui <- fluidPage(
br(),
DTOutput("dtable"),
br(),
textOutput("selectedRow"),
actionButton("btn-next", "select next row"),
pickerInput(
"rowname",
label = "Choose a row",
choices = setNames(1:nrow(dat), rownames(dat))
),
actionButton("assign", "Assign")
)
server <- function(input, output, session) {
output[["dtable"]] <- renderDT({
datatable(
dat,
extensions = "Select",
selection = "none",
callback = callback,
options = list(
columnDefs = list(
list(className = "dt-center", targets = "_all")
),
select = list(style = "single")
)
)
}, server = FALSE)
output[["selectedRow"]] <- renderText({
i <- input[["dtable_rows_selected"]]
paste0(
"Selected row: ",
ifelse(is.null(i), "none", i)
)
})
observeEvent(input[["rowname"]], {observeEvent(input[["assign"]], {
session$sendCustomMessage("selectRow", isolate(input[["rowname"]]))
})})
}
shinyApp(ui, server)

Answer 1

Full app:
library(shinydashboard)
library(shinydashboardPlus)
library(DT)
library(shinyjs)
library(shinyWidgets)
attribute_name <- c("Jack", "Bob", "Jack", "Bob")
category_id <- c(7, 7, 7, 7)
candidate_phrase_lemma <- c("apple", "olive", "banana", "tomato")
d <- data.frame(
attribute_name,
category_id,
candidate_phrase_lemma,
stringsAsFactors = FALSE
)
names <- tapply(d$candidate_phrase_lemma, d$attribute_name, I)
candidate_1 <- c("Jack", "Bob", "Jack", "Bob")
candidate_2 <- c("phone", "camera", "micro", "pc")
similarity <- c(4, 5, 6, 7)
category_id <- c(7, 7, 7, 7)
e <- data.frame(candidate_1, candidate_2, similarity, category_id)
selector <- function(id, values, items = values) {
options <- HTML(paste0(mapply(
function(value, item) {
as.character(tags$option(value = value, selected = "selected", item))
}, values, items
), collapse = ""))
as.character(
tags$select(
id = id, multiple = "multiple", options
)
)
}
dat <- data.frame(
attributes = unique(as.character(d$attribute_name)),
attributes_phrases = vapply(
1:length(names),
function(i) {
selector(paste0("slct", i), names[[i]])
},
character(1)
),
Count = lengths(names),
stringsAsFactors = FALSE
)
nrows <- nrow(dat)
initComplete <- c(
"function(settings) {",
" var table = this.api().table();",
" var nrows = table.rows().count();",
" function selectize(i) {",
" var $slct = $('#slct' + i);",
" $slct.select2({",
" width: '100%',",
" closeOnSelect: false",
" });",
" $slct.on('change', function(e) {",
" table.cell(i-1, 2).data($slct.val().length);",
" });",
" }",
" for(var i = 1; i <= nrows; i++) {",
" selectize(i);",
" }",
"}"
)
callback <- JS(
"Shiny.addCustomMessageHandler(",
" 'selectRow',",
" function(index) {",
" table.row(index - 1).select();",
" }",
");",
"$('#btn-next').prop('disabled', true);",
"var selected_row = null;",
"table.on('select', function( e, dt, type, indexes ) {",
" $('#btn-next').prop('disabled', false);",
" selected_row = indexes[0];",
"});",
"table.on('deselect', function( e, dt, type, indexes ) {",
" $('#btn-next').prop('disabled', true);",
"});",
"var nrows = table.rows().count();",
"$('#btn-next').on('click', function() {",
" var next_row = selected_row + 1 < nrows ? selected_row + 1 : 0;",
" table.row(next_row).select();",
"});"
)
js <- paste0(c(
"Shiny.addCustomMessageHandler(",
" 'addCandidate',",
" function(row_candidate) {",
" var i = row_candidate.row;",
" var candidate = row_candidate.candidate;",
" var $slct = $('#slct' + i);",
" if($slct.find(\"option[value='\" + candidate + \"']\").length === 0) {",
" var newOption = new Option(candidate, candidate, true, true);",
" $slct.append(newOption).trigger('change');",
" }",
" }",
");"
), collapse = "\n")
shinyApp(
ui = dashboardPagePlus(
tags$head(
tags$link(rel = "stylesheet", href = "https://cdnjs.cloudflare.com/ajax/libs/select2/4.0.13/css/select2.min.css"),
tags$script(src = "https://cdnjs.cloudflare.com/ajax/libs/select2/4.0.13/js/select2.min.js"),
tags$style(HTML(
".select2-selection__choice {background-color: darkblue !important;}"
)),
tags$script(HTML(js))
),
useShinyjs(),
header = dashboardHeaderPlus(),
sidebar = dashboardSidebar(),
body = dashboardBody(
DTOutput("table"),
br(),
fluidRow(
column(
4,
uiOutput("ui-rowselect")
),
column(
2,
actionButton("selectrow", "Select this row")
)
),
br(),
actionButton("btn-next", "Select next row"),
br(), br(),
conditionalPanel(
condition = "input.table_rows_selected.length > 0",
wellPanel(
uiOutput("celltext"),
splitLayout(
actionButton("bc", "Previous candidate"),
actionButton("dec", "Next candidate"),
actionButton("addWord", "Add this candidate", class = "btn-info"),
cellWidths = "auto"
)
)
)
)
),
server = function(input, output, session) {
Text <- reactiveVal()
Data <- reactiveVal()
Candidate <- reactiveVal()
rnum <- reactiveVal()
output[["table"]] <- renderDT({
datatable(
data = dat,
extensions = "Select",
selection = "none",
escape = FALSE,
rownames = FALSE,
callback = callback,
options = list(
pageLength = 5,
columnDefs = list(
list(className = "dt-center", targets = "_all")
),
select = list(style = "single"),
initComplete = JS(initComplete),
preDrawCallback = JS(
"function() { Shiny.unbindAll(this.api().table().node()); }"
),
drawCallback = JS(
"function() { Shiny.bindAll(this.api().table().node()); }"
)
)
)
}, server = FALSE)
output[["ui-rowselect"]] <- renderUI({
selectedRow <- input[["table_rows_selected"]]
choices <- if(is.null(selectedRow)) 1:nrows else (1:nrows)[-selectedRow]
pickerInput(
"rowselect",
label = "Choose a row",
choices = choices
)
})
observeEvent(input[["selectrow"]], {
session$sendCustomMessage("selectRow", input[["rowselect"]])
})
observeEvent(input[["table_rows_selected"]], {
row <- input[["table_rows_selected"]]
dat <- e[e[["candidate_1"]] %in% d[row, 1], ]
Data(dat[order(dat[["similarity"]], decreasing = TRUE), ])
rnum(1)
})
output[["celltext"]] <- renderUI({
HTML(Text())
})
observeEvent(input[["dec"]], {
rnum(rnum() + 1)
})
observeEvent(input[["bc"]], {
rnum(rnum() - 1)
})
observeEvent(list(rnum(), Data()), {
if(rnum() == 1){
disable("bc")
}else{
enable("bc")
}
if(rnum() == nrows){
disable("dec")
}else{
enable("dec")
}
Candidate(Data()[rnum(), 2])
Text(
paste(
"Similarity of <em>", Data()[rnum(), 1], "</em>",
"to candidate <em>", Candidate(), "</em>",
"is <strong>", Data()[rnum(), 3], "</strong>"
)
)
}, ignoreInit = TRUE)
observeEvent(input[["addWord"]], {
session$sendCustomMessage(
"addCandidate",
list(row = input[["table_rows_selected"]], candidate = Candidate())
)
})
}
)