Using rhandsontable in a shiny module - r

The application
On startup, a 3 x 3 table is generated with values from 1 to 9 in a random order. What the app user can see is a blank 3 x 3 rhandsontable that he/she will use to try to guess where the generated values are. When the user clicks on the "Submit" button, the cells that contain the correct values turn green and all other cells remain as they are.
My issue
The cells where the user guessed right do not turn green when the user clicks the button. In other words, the conditional formatting does not work even though I got it to work before (that was in the first version of the app when I did not make use of shiny modules).
What I have done
The full project is in the following Github repository that potential users may want to clone instead of copying and pasting the code below: https://github.com/gueyenono/number_game
My project folder has 4 files. The first two files are the usual ui.R and server.R, which essentially call shiny modules (i.e. hot_module_ui() and hot_module()) . The modules are contained within the global.R file. The last file, update_hot.R, contains a function used in the modules.
ui.R
This file loads the required packages, provides a title for the app and calls hot_module_ui(). The module just displays a blank 3 x 3 rhandsontable and an actionButton().
library(shiny)
library(rhandsontable)
source("R/update_hot.R")
ui <- fluidPage(
titlePanel("The number game"),
mainPanel(
hot_module_ui("table1")
)
)
server.R
This file calls the hot_module(), which contains the code for the conditional formatting.
server <- function(input, output, session) {
callModule(module = hot_module, id = "table1")
}
update_hot.R
This is the function which is called when the "Submit" button is called. The function has two arguments:
hot: the handsontable in the app
x: the values generated on startup
This is what the function does (full code for the file is at the end of this section):
Get the user inputs
user_input <- hot_to_r(hot)
Compare user inputs (user_input) to the true values (x) and store the row and column indices of the cells where the user guessed right
i <- which(user_input == x, arr.ind = TRUE)
row_correct <- i[, 1] - 1
col_correct <- i[, 2] - 1
Update the current handsontable object with the row and column indices and use the renderer argument of the hot_cols() function to make background of corresponding cells green. Note that I use the hot_table() function to update the existing rhandsontable object.
hot %>%
hot_table(contextMenu = FALSE, row_correct = row_correct, col_correct = col_correct) %>%
hot_cols(renderer = "function(instance, td, row, col, prop, value, cellProperties){
Handsontable.renderers.TextRenderer.apply(this, arguments);
if(instance.params){
// Correct cell values
row_correct = instance.params.row_correct
row_correct = row_correct instanceof Array ? row_correct : [row_correct]
col_correct = instance.params.col_correct
col_correct = col_correct instanceof Array ? col_correct : [col_correct]
for(i = 0; i < col_correct.length; i++){
if (col_correct[i] == col && row_correct[i] == row) {
td.style.background = 'green';
}
}
return td;
}")
Here is the full code for update_hot.R
update_hot <- function(hot, x){
# Get user inputs (when the submit button is clicked)
user_input <- hot_to_r(hot)
# Get indices of correct user inputs
i <- which(user_input == x, arr.ind = TRUE)
row_correct <- i[, 1] - 1
col_correct <- i[, 2] - 1
# Update the hot object with row_index and col_index for user in the renderer
hot %>%
hot_table(contextMenu = FALSE, row_correct = row_correct, col_correct = col_correct) %>%
hot_cols(renderer = "function(instance, td, row, col, prop, value, cellProperties){
Handsontable.renderers.TextRenderer.apply(this, arguments);
if(instance.params){
// Correct cell values
row_correct = instance.params.row_correct
row_correct = row_correct instanceof Array ? row_correct : [row_correct]
col_correct = instance.params.col_correct
col_correct = col_correct instanceof Array ? col_correct : [col_correct]
for(i = 0; i < col_correct.length; i++){
if (col_correct[i] == col && row_correct[i] == row) {
td.style.background = 'green';
}
}
return td;
}")
}
global.R
This is the file, which contains the shiny modules. The UI module (hot_module_ui()) has:
- an rHandsontableOutput
- an actionButton
- I added a tableOutput in order to see where the generated values are (useful for testing the code)
The server module (hot_module()) calls the update_hot() function and attempts to update the handsontable in the app whenever the user clicks on the "Submit" button. I attempted to achieve this by using an observeEvent and a reactive value react$hot_display. On startup, react$hot_display contains a 3 x 3 data frame of NAs. When the button is clicked, it is updated with the new version of the handsontable (containing user inputs and conditional formatting). Here is the full code for global.R:
hot_module_ui <- function(id){
ns <- NS(id)
tagList(
rHandsontableOutput(outputId = ns("grid")),
br(),
actionButton(inputId = ns("submit"), label = "Submit"),
br(),
tableOutput(outputId = ns("df"))
)
}
hot_module <- function(input, output, session){
values <- as.data.frame(matrix(sample(9), nrow = 3))
react <- reactiveValues()
observe({
na_df <- values
na_df[] <- as.integer(NA)
react$hot_display <- rhandsontable(na_df, rowHeaders = NULL, colHeaders = NULL)
})
observeEvent(input$submit, {
react$hot_display <- update_hot(hot = input$grid, x = values)
})
output$grid <- renderRHandsontable({
react$hot_display
})
output$df <- renderTable({
values
})
}
As mentioned at the beginning, the conditional formatting does not work when the "Submit" button is clicked and I am not sure why. Once again, you can access the full code on the following Github repository:
https://github.com/gueyenono/number_game

I finally found the solution to my issue. One of the biggest lessons I learned was that the hot_to_r() function does not work in custom functions. It must be used in the server function of a shiny app. This means that passing an rhandsontable object to a custom function and retrieving the data from within the function may not be a good idea (which was my story).
I am not sure it will be of interest to anyone, but here is my code, which works as intended:
ui.R
library(rhandsontable)
library(shiny)
source("R/update_hot.R")
shinyUI(fluidPage(
# Application title
titlePanel("The Number Game"),
module_ui(id = "tab")
))
server.R
library(shiny)
shinyServer(function(input, output, session) {
callModule(module = module_server, id = "tab")
})
global.R
module_ui <- function(id){
ns <- NS(id)
tagList(
rHandsontableOutput(outputId = ns("hot")),
actionButton(inputId = ns("submit"), label = "OK"),
actionButton(inputId = ns("reset"), label = "Reset")
)
}
module_server <- function(input, output, session){
clicked <- reactiveValues(submit = FALSE, reset = FALSE)
initial_hot <- rhandsontable(as.data.frame(matrix(NA_integer_, nrow = 3, ncol = 3)))
correct_values <- as.data.frame(matrix(1:9, nrow = 3, byrow = TRUE))
observeEvent(input$submit, {
clicked$submit <- TRUE
clicked$reset <- FALSE
})
updated_hot <- eventReactive(input$submit, {
input_values <- hot_to_r(input$hot)
update_hot(input_values = input_values, correct_values = correct_values)
})
observeEvent(input$reset, {
clicked$reset <- TRUE
clicked$submit <- FALSE
})
reset_hot <- eventReactive(input$reset, {
initial_hot
})
output$hot <- renderRHandsontable({
if(!clicked$submit & !clicked$reset){
out <- initial_hot
} else if(clicked$submit & !clicked$reset){
out <- updated_hot()
} else if(clicked$reset & !clicked$submit){
out <- reset_hot()
}
out
})
}
R/update_hot.R
update_hot <- function(input_values, correct_values){
equal_ids <- which(input_values == correct_values, arr.ind = TRUE)
unequal_ids <- which(input_values != correct_values, arr.ind = TRUE)
rhandsontable(input_values) %>%
hot_table(row_correct = as.vector(equal_ids[, 1]) - 1,
col_correct = as.vector(equal_ids[, 2]) - 1,
row_incorrect = as.vector(unequal_ids[, 1]) - 1,
col_incorrect = as.vector(unequal_ids[, 2]) - 1) %>%
hot_cols(renderer = "function(instance, td, row, col, prop, value, cellProperties){
Handsontable.renderers.TextRenderer.apply(this, arguments);
if(instance.params){
// Correct cell values
row_correct = instance.params.row_correct
row_correct = row_correct instanceof Array ? row_correct : [row_correct]
col_correct = instance.params.col_correct
col_correct = col_correct instanceof Array ? col_correct : [col_correct]
// Incorrect cell values
row_incorrect = instance.params.row_incorrect
row_incorrect = row_incorrect instanceof Array ? row_incorrect : [row_incorrect]
col_incorrect = instance.params.col_incorrect
col_incorrect = col_incorrect instanceof Array ? col_incorrect : [col_incorrect]
for(i = 0; i < col_correct.length; i++){
if (col_correct[i] == col && row_correct[i] == row) {
td.style.background = 'green';
}
}
for(i = 0; i < col_incorrect.length; i++){
if (col_incorrect[i] == col && row_incorrect[i] == row) {
td.style.background = 'red';
}
}
}
return td;
}")
}

Related

Getting variable data from a data set in Shiny R

I need to be able to access each variable's data in my data frame, after the user has selected and uploaded a local csv file. This code is the part of my Shiny script where I create and modify the csv file read in by the user. "rv" is the data, which is a reactiveValues dataframe, so it can be modified.
Variable names are chosen by the user through a radio button group (shown here, but defined in the ui part of the script). The other code is in the server portion of the script.
radioButtons('radiovarGroup1',label = h5("Choose a Variable to Analyze:"),
choices = list('TA' = 'TA','PP' = 'PP', 'US' = 'us', 'UD' = 'ud', 'UE' = 'ue',
'UG' = 'ug', 'UH' = 'uh', 'XR' = 'xr', 'RW' = 'rw', 'PA' = 'pa', 'TB4' = 'tb4',
'TV2' = 'tv2', 'TV4' = 'tv4', 'TV8' = 'tv8', 'TV20' = 'tv20', 'TV40' = 'tv40',
'MV2' = 'mv2', 'MV4' = 'mv4', 'MV8' = 'mv8', 'MV20' = 'mv20', 'MV40' = 'mv40',
'VB' = 'vb', 'TA40' = 'ta40', 'TA120' = 'ta120', 'SD' = 'sd'),inline = TRUE, selected = NULL),
var_names = c('TA','PP','US','UD','UE','UG','UH','XR','RW','PA','TB4','TV2','TV4',
'TV8','TV20','TV40','MV2','MV4','MV8','MV20','MV40','VB','TA40','TA120','SD')
rv <- reactiveValues(df = NULL)
#This function is responsible for loading in the selected file
observe({
req(input$file_selector)
rv$df <- read.csv(paste0(parseDirPath(c(home = 'C:\\Users\\Ruben\\Desktop\\Test_QC_Program\\FiveMin'), file_dir()),'\\',input$file_selector),skip=1) # Simplified for testing
})
# This previews the CSV data file
output$filetable <- renderDataTable({
rv$df
})
observeEvent(input$qc_final_cols, {
if (input$qc_final_cols){
for (v in 1:length(var_names)){
ind <- which(colnames(rv$df) == var_names[v])
rv$df <- rv$df %>%
add_column(z = NA,.after = ind)
colnames(rv$df)[ind+1] <- paste0(var_names[v],'_QC')
rv$df <- rv$df %>%
add_column(y = NA,.after = ind+1)
colnames(rv$df)[ind+2] <- paste0(var_names[v],'_Final')
}
}
})
output$checked_var <- renderPrint({
input$radiovarGroup1})
variable_data <- reactive({get(rv$df[,which(colnames(rv$df) == input$radiovarGroup1)])})
Why do I keep getting an "object of type closure is not subsettable' error returned for variable_data? I can render the rv$df data table just fine, but I can't extract data from it for some reason.

Shiny R: Update a textInput when a pattern matches a given character vector in a data frame

My problem is that I have a given data frame and I have to search for different patterns. When the pattern matches the given character vector the content of the same row, but of a different column should update a textInput.
I created a little shiny app as an example, because my original code is too big. The example works, but I'm using for loops and I don't want to do this. Do anyone know a better solution? Is there a solution with a vectorised function? I really would appreciate if someone knows a dplyr solution.
Example:
library(shiny)
ui <- fluidPage(
textInput(inputId="wave1", label="wavelength"),
textInput(inputId="wave2", label="wavelength")
)
server <- name <- function(input,output,session) {
df <- data.frame("color" = c("red","blue","green"), "wavelength" = c("700 nm","460 nm","520 nm"))
for (i in 1:nrow(df)) {
if(grepl("lue",df$color[i],fixed=TRUE) == TRUE){updateTextInput(session, inputId="wave1", label = NULL, value = df$wavelength[i],placeholder = NULL)}
}
for (i in 1:nrow(df)) {
if(grepl("ee",df$color[i],fixed=TRUE) == TRUE){updateTextInput(session, inputId="wave2", label = NULL, value = df$wavelength[i],placeholder = NULL)}
}
}
shinyApp(ui = ui, server = server)
Any help would be appreciated.
Instead of looping, you can index the dataframe directly from the result of grep:
server <- name <- function(input,output,session) {
df <- data.frame("color" = c("red","blue","green"), "wavelength" = c("700 nm","460 nm","520 nm"))
updateTextInput(session, inputId="wave1", label = NULL,
value = df$wavelength[grep("lue", df$color, fixed=TRUE)],
placeholder = NULL)
updateTextInput(session, inputId="wave2", label = NULL,
value = df$wavelength[grep("ee", df$color, fixed=TRUE)],
placeholder = NULL)
}
And one way to do this using dplyr is:
server <- name <- function(input,output,session) {
df <- data.frame("color" = c("red","blue","green"), "wavelength" = c("700 nm","460 nm","520 nm"))
updateTextInput(session, inputId="wave1", label = NULL,
value = dplyr::filter(df, grepl("lue", color, fixed=TRUE)) %>% dplyr::pull(wavelength),
placeholder = NULL)
updateTextInput(session, inputId="wave2", label = NULL,
value = dplyr::filter(df, grepl("ee", color, fixed=TRUE)) %>% dplyr::pull(wavelength),
placeholder = NULL)
}

Interactive Highlighting in R DataTables

Thanks for the time.
I am trying to get a shiny app to work correctly, and for some reason I am having difficulty on a highlighting issue when rendering a DT data table.
For example, this works:
output$DT = DT::renderDataTable({DT = datatable(DT,options = list(searching = FALSE,paging = FALSE,lengthChange = FALSE,ordering = FALSE,rownames= FALSE)) %>%
formatStyle('TEST',backgroundColor = styleEqual(c(1,2,3,4,5), c('chartreuse', 'chartreuse4','yellow','indianred','indianred4'))) )})
However, when attempting to add this additional line, the highlighting is not appearing, yet the code runs:
%>%
formatStyle('TEST2',backgroundColor = styleEqual(c(TRUE,FALSE),c('green','red'))
I have also tried styleInterval, and am getting the same results.
Thanks.
Reproducible Code:
ui <- fluidPage(
dataTableOutput('DF')
)
server <- function(input, output, session) {
DF = as.data.frame(matrix(NA,nrow=2,ncol = 2))
DF$V1 = c(TRUE,FALSE)
DF$V2 = c(1,2)
output$DF = renderDataTable(DF)
output$DF = DT::renderDataTable({DF = datatable(DF,options = list(searching = FALSE,paging = FALSE,lengthChange = FALSE,ordering = FALSE,rownames= FALSE)) %>%
formatStyle('V2',backgroundColor = styleEqual(c(1,2,3,4,5), c('chartreuse', 'blue','yellow','indianred','indianred4'))) %>%
formatStyle('V1',backgroundColor = styleEqual(c(TRUE,FALSE),c('green','red')))})
}
shinyApp(ui = ui, server = server) # RUN THE APPLICATION
> styleEqual(c(TRUE,FALSE),c('green','red'))
[1] "value == 'TRUE' ? 'green' : value == 'FALSE' ? 'red' : ''"
attr(,"class")
[1] "JS_EVAL"
value is not 'TRUE' or 'FALSE', it is true or false.
You can do:
...... %>%
formatStyle('V1',
backgroundColor = JS("value == true ? 'green' : value == false ? 'red' : ''"))

simplify the subset of a table using multiple conditions in R shiny

I am writing a shiny app (shinydashboard) that looks like the figure (the app run on my company private network,so I can't share the link to it).
The dataset consists of a table containing the expression values of different genes (rows) for different samples (columns).
The app should return a subset of that table based on the search criteria selected by the user. Information about the samples are stored in a different table (B38.Metadata in the code), that looks like this:
SampleID,RNA.ID,RNAseq.ID,Name,Description,Tissue Type,...
CP3027,CP3027,74,Hs514,Aortic_Endothelial,Vascular system,Endothelial,...
CP3028,CP3028,76,HEr1,Aortic_Endothelial,Vascular system,Endothelial,...
At every search, the metadata are checked and the main table is subset accordingly.
My approach has been to write a function for each search types (SearchByGene,SearchByTissue,...), and
use if-else statements to account for all the possible combinations.
For example, filter by GeneName, Tissue type, and Name, but not for the other options.
This led to a massive 14 if-else block, spanning almost 50 lines of code (see below).
everything works, but the code is dreadful to read and debug.
Furthermore the idea of adding additional search possibilities (e.g. search by sequencing technique)
made me shiver.
I considered using a switch construct, but, having multiple conditions to test I'm not sure it will clean the code too much.
Is there a way of simplify the if-else block with something easier to read and, especially, maintain?
Searchfunction <- function(dataSet2){
selectedTable <- reactive({
# Create a DF with only the gene names
DFgeneLevel <- DummyDFgeneLevel(dataSet2) # not used for now
# Subset by Columns first
if(is.null(input$tissues) && is.null(input$samples) && is.null(input$Name)){
TableByColumns <- dataSet2
} else if(!is.null(input$tissues) && !is.null(input$samples) && !is.null(input$Name)){
TableByTissue <- SearchByTissue(input$tissues,B38.metadata,dataSet2)
TableBySample <- SearchBySample(input$samples,TableByTissue)
TableByColumns <- SearchByName(input$Name,B38.metadata,TableBySample)
} else if(!is.null(input$tissues)){
if(is.null(input$samples) && is.null(input$Name)){
TableByColumns <- SearchByTissue(input$tissues,B38.metadata,dataSet2)
} else if(is.null(input$samples) && !is.null(input$Name)){
TableByTissue <- SearchByTissue(input$tissues,B38.metadata,dataSet2)
TableByColumns <- SearchByName(input$Name,B38.metadata,TableByTissue)
} else if(!is.null(input$samples) && is.null(input$Name)){
TableByTissue <- SearchByTissue(input$tissues,B38.metadata,dataSet2)
TableByColumns <- SearchBySample(input$samples,TableByTissue)
}
} else if(is.null(input$tissues)){
if(is.null(input$samples) && !is.null(input$Name)){
TableByColumns <- SearchByName(input$Name,B38.metadata,dataSet2)
} else if(!is.null(input$samples) && is.null(input$Name)){
TableByColumns <- SearchBySample(input$samples,dataSet2)
} else if(!is.null(input$samples) && !is.null(input$Name)){
TableByName <- SearchBySample(input$samples,dataSet2)
TableByColumns <- SearchByName(input$Name,B38.metadata,TableByName)
}
}
# Collect all the inputs & subset by Rows
#genes.Selected <- toupper(genes.Selected) # can't use it as some genes contains lowerletters
genesFromList <- unlist(strsplit(input$genesLists,","))
genes.Selected <- unlist(strsplit(input$SearchCrit," "))
if(input$SearchCrit == '' && input$genesLists == 0){
TableByRow <- TableByColumns
} else if(input$SearchCrit != '' && input$genesLists != 0){
TableByList <- subset(TableByColumns, TableByColumns$GeneName %in% genesFromList)
TableByRow <- subset(TableByList, TableByList$GeneName %in% genes.Selected)
} else if(input$SearchCrit != '' && input$genesLists == 0){
TableByRow <- subset(TableByColumns, TableByColumns$GeneName %in% genes.Selected)
} else if(input$SearchCrit == '' && input$genesLists != 0) {
TableByRow <- subset(TableByColumns, TableByColumns$GeneName %in% genesFromList)
}
return(TableByRow)
})
}
Is that what you are trying to achieve ?
Filter samples that match your attributes based on your metadata and display gene expressions only for these samples ?
library(shiny)
library(dplyr)
ui <- fluidPage(
titlePanel("mtcars"),
sidebarLayout(
sidebarPanel(
selectInput("vs",
label = "vs",
choices = c(0, 1),
selected = NULL,
multiple = TRUE),
selectInput("carb",
label = "carb",
choices = c(1, 2, 3, 4, 6, 8),
selected = NULL,
multiple = TRUE),
selectInput("gear",
label = "gear",
choices = c(3, 4, 5),
selected = NULL,
multiple = TRUE)
),
mainPanel(
tabsetPanel(
tabPanel("Expression values", tableOutput("mainTable")),
tabPanel("ID filtering", tableOutput("table"))
)
)
)
)
server <- function(input, output) {
samples.df <- data.frame(ID = paste0("ID", as.character(round(runif(nrow(mtcars),
min = 0,
max = 100 * nrow(mtcars))))),
gear = as.factor(mtcars$gear),
carb = as.factor(mtcars$carb),
vs = as.factor(mtcars$vs))
values.df <- cbind(paste0("Feature", 1:20),
as.data.frame(matrix(runif(20 * nrow(samples.df)), nrow = 20)))
colnames(values.df) <- c("Feature", as.character(samples.df$ID))
vs.values <- reactive({
if (is.null(input$vs)) {
return(c(0, 1))
} else {
return(input$vs)
}
})
carb.values <- reactive({
if (is.null(input$carb)) {
return(c(1, 2, 3, 4, 6, 8))
} else {
return(input$carb)
}
})
gear.values <- reactive({
if (is.null(input$gear)) {
return(c(3, 4, 5))
} else {
return(input$gear)
}
})
filtered.samples.df <- reactive({
return(samples.df %>% filter(gear %in% gear.values(),
vs %in% vs.values(),
carb %in% carb.values()))
})
filtered.values.df <- reactive({
selected.samples <- c("Feature", names(values.df)[names(values.df) %in% filtered.samples.df()$ID])
return(values.df %>% select(selected.samples))
})
output$mainTable <- renderTable({
filtered.values.df()
})
output$table <- renderTable({
filtered.samples.df()
})
}
shinyApp(ui = ui, server = server)
You can try something like this, where we loop over the inputs and subset on the according column if the input is not null.
Hope this helps!
library(shiny)
ui <- fluidPage(
selectizeInput('mpg','mpg:',unique(mtcars$mpg),multiple=T),
selectizeInput('cyl','cyl:',unique(mtcars$cyl),multiple=T),
selectizeInput('gear','gear:',unique(mtcars$gear),multiple=T),
selectizeInput('carb','carb:',unique(mtcars$carb),multiple=T),
tableOutput('mytable')
)
server <- function(input,output)
{
output$mytable <- renderTable({
df = mtcars
select_inputs = c('mpg','cyl','gear','carb')
for (inp in select_inputs)
{
if(!is.null(input[[inp]]))
{
df = df[df[[inp]] %in% input[[inp]],]
}
}
df
})
}
shinyApp(ui,server)

datatable with nesting/child rows and modal

I am trying to make a datatable that has two layers of nesting. The first one is used for grouping rows (https://github.com/rstudio/shiny-examples/issues/9#issuecomment-295018270) and the second should open a modal (R shinyBS popup window).
I can get this to work individually but the second layer of nesting is creating problems. As soon as there is a second nesting the data in the table no longer show up in the collapsed group.
So there is at least one issue with what I have done so far and that is how to get it to display correctly when there are multiple nestings.
After that I am not sure the modal would currently work. I wonder if the ids won't conflict the way it is done now.
Any hints are appreciated.
# Libraries ---------------------------------------------------------------
library(DT)
library(shiny)
library(shinyBS)
library(shinyjs)
library(tibble)
library(dplyr)
library(tidyr)
library(purrr)
# Funs --------------------------------------------------------------------
# Callback for nested rows
nest_table_callback <- function(nested_columns, not_nested_columns){
not_nested_columns_str <- not_nested_columns %>% paste(collapse="] + '_' + d[") %>% paste0("d[",.,"]")
paste0("
table.column(1).nodes().to$().css({cursor: 'pointer'});
// Format data object (the nested table) into another table
var format = function(d) {
if(d != null){
var result = ('<table id=\"child_' + ",not_nested_columns_str," + '\">').replace('.','_') + '<thead><tr>'
for (var col in d[",nested_columns,"]){
result += '<th>' + col + '</th>'
}
result += '</tr></thead></table>'
return result
}else{
return '';
}
}
var format_datatable = function(d) {
var dataset = [];
for (i = 0; i < + d[",nested_columns,"]['model'].length; i++) {
var datarow = [];
for (var col in d[",nested_columns,"]){
datarow.push(d[",nested_columns,"][col][i])
}
dataset.push(datarow)
}
var subtable = $(('table#child_' + ",not_nested_columns_str,").replace('.','_')).DataTable({
'data': dataset,
'autoWidth': true,
'deferRender': true,
'info': false,
'lengthChange': false,
'ordering': true,
'paging': false,
'scrollX': false,
'scrollY': false,
'searching': false
});
};
table.on('click', 'td.details-control', function() {
var td = $(this), row = table.row(td.closest('tr'));
if (row.child.isShown()) {
row.child.hide();
td.html('⊕');
} else {
row.child(format(row.data())).show();
td.html('&CircleMinus;');
format_datatable(row.data())
}
});
"
)
}
# This function will create the buttons for the datatable, they will be unique
shinyInput <- function(FUN, len, id, ...) {inputs <- character(len)
for (i in seq_len(len)) {
inputs[i] <- as.character(FUN(paste0(id, i), ...))}
inputs
}
add_view_col <- . %>% {bind_cols(.,View = shinyInput(actionButton, nrow(.),'button_', label = "View", onclick = 'Shiny.onInputChange(\"select_button\", this.id)' ))}
# Example nested data -----------------------------------------------------
collapse_col <- "to_nest"
modal_col <- "to_modal"
# nested data
X <- mtcars %>%
rownames_to_column("model") %>%
as_data_frame %>%
select(mpg, cyl, model, everything()) %>%
nest(-mpg, -cyl, .key=!!modal_col) %>% #-#-#-#-#-#- WORKS IF THIS IS REMOVED #-#-#-#-#-#
nest(-mpg, .key=!!collapse_col)
data <- X %>%
{bind_cols(data_frame(' ' = rep('⊕',nrow(.))),.)} %>%
mutate(!!collapse_col := map(!!rlang::sym(collapse_col), add_view_col))
collapse_col_idx <- which(collapse_col == colnames(data))
not_collapse_col_idx <- which(!(seq_along(data) %in% c(1,collapse_col_idx)))
callback <- nest_table_callback(collapse_col_idx, not_collapse_col_idx)
ui <- fluidPage( DT::dataTableOutput('my_table'),
uiOutput("popup")
)
server <- function(input, output, session) {
my_data <- reactive(data)
output$my_table <- DT::renderDataTable(my_data(),
options = list(columnDefs = list(
list(visible = FALSE, targets = c(0,collapse_col_idx) ), # Hide row numbers and nested columns
list(orderable = FALSE, className = 'details-control', targets = 1) # turn first column into control column
)
),
server = FALSE,
escape = -c(2),
callback = JS(callback),
selection = "none"
)
# Here I created a reactive to save which row was clicked which can be stored for further analysis
SelectedRow <- eventReactive(input$select_button,
as.numeric(strsplit(input$select_button, "_")[[1]][2])
)
# This is needed so that the button is clicked once for modal to show, a bug reported here
# https://github.com/ebailey78/shinyBS/issues/57
observeEvent(input$select_button, {
toggleModal(session, "modalExample", "open")
}
)
DataRow <- eventReactive(input$select_button,
my_data()[[collapse_col_idx]][[SelectedRow()]]
)
output$popup <- renderUI({
bsModal("modalExample",
paste0("Data for Row Number: ", SelectedRow()),
"",
size = "large",
column(12, DT::renderDataTable(DataRow()))
)
})
}
shinyApp(ui, server)

Resources