datatable with nesting/child rows and modal - r

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)

Related

Why is this Shiny app code not reactive when using purrr:map over input variables?

EDIT WITH MWE BELOW
I have below a snippet of my code which is part of a larger app. I'm trying to rewrite the app to work with R6 classes and gargoyle as per this article. However, I cannot figure out why the observe part of the data below does not trigger except when it's initialized. To my understanding should if observe all the filters that are in input based on the map function, am I wrong?
output$filters <- renderUI({
gargoyle::watch("first thing")
data <- Data$get_data(unfiltered = TRUE)
data_names <- names(data)
if(nrow(data) > 0){
map(data_names, ~ render_ui_filter(data[[.x]], .x))
}
}
)
observe({
data <- Data$get_data(unfiltered = TRUE)
data_names <- names(data)
if(ncol(data) > 0){
each_var <- map(data_names, ~ filter_var(data[[.x]], input[[paste0("filter",.x)]]))
Transactions <- Data$set_filters(reduce(each_var, `&`))
gargoyle::trigger("second thing")
}
})
I've had a working case of the second reactive element like this:
selectedData <- reactive({
if(nrow(data()) > 0){
each_var <- map(dataFilterNames(), ~ filter_var(data()[[.x]], input[[paste0("filter",.x)]]))
reduce(each_var, `&`)
}
})
where data and dataFilterNames are reactiveVal and dataFilterNames is the column names of data.
Here you can find render_ui_filter and filter_var:
render_ui_filter <- function(x, var) {
if(all(is.null(x) | is.na(x))){
#If all data is null, don't create a filter from it
return(NULL)
}
id <- paste0("filter",var)
var <- stringr::str_to_title(var)
if (is.numeric(x)) {
if(is.integer(x)){
step = 1
}
else{
step = NULL
}
rng <- range(x, na.rm = TRUE)
sliderInput(id,
var,
min = rng[1],
max = rng[2],
value = rng,
round = TRUE,
width = "90%",
sep = " ",
step = step
)
} else if (is.factor(x)) {
levs <- levels(x)
if(length(levs) < 5){
pickerInput(id, var, choices = levs, selected = levs, multiple = TRUE,
options = list(
title = sprintf("Filter on %s...", var),
#`live-search` = TRUE,
#`actions-box` = TRUE,
size = 10
))
}else {
pickerInput(id, var, choices = levs, selected = levs, multiple = TRUE,
options = list(
title = sprintf("Filter on %s...", var),
`live-search` = TRUE,
`actions-box` = TRUE,
size = 10,
`selected-text-format` = "count > 5"
))
}
} else if (is.Date(x)){
dateRangeInput(id,
var,
start = min(x),
end = max(x),
weekstart = 1,
autoclose = FALSE,
separator = "-")
} else if (is.logical(x)) {
pickerInput(id, var, choices = unique(x), selected = unique(x), multiple = TRUE,
options = list(
title = sprintf("Filter on %s...", var),
`live-search` = TRUE,
#`actions-box` = TRUE,
size = 10
))
} else {
# Not supported
NULL
}
}
filter_var <- function(x, val) {
if(all(is.null(x) | is.na(x))){
#If all data is null, don't create a filter from it
return(TRUE)
}
if (is.numeric(x)) {
!is.na(x) & x >= val[1] & x <= val[2]
} else if (is.factor(x)) {
x %in% val
} else if(is.Date(x)){
!is.na(x) & x >= val[1] & x <= val[2]
} else if (is.logical(x)) {
x %in% val
} else {
# No control, so don't filter
TRUE
}
}
Edit: Here is a MWE that can be run in a notebook for example. It does not currently work since the gargoyle trigger triggers the observe it is in and we end up in a infinity loop. If you remove that you can see that the normal reactive part works, but the R6 version does not create the table ever.
if (interactive()){
require("shiny")
require("R6")
require("gargoyle")
require("purrr")
require("stringr")
# R6 DataSet ----
DataSet <- R6Class(
"DataSet",
private = list(
.data = NA,
.data_loaded = FALSE,
.filters = logical(0)
),
public = list(
initialize = function() {
private$.data = data.frame()
},
get_data = function(unfiltered = FALSE) {
if (!unfiltered) {
return(private$.data[private$.filters, ])
}
else{
return(private$.data)
}
},
set_data = function(data) {
stopifnot(is.data.frame(data))
private$.data <- data
private$.data_loaded <- TRUE
private$.filters <- rep(T, nrow(private$.data))
return(invisible(self))
},
set_filters = function(filters) {
stopifnot(is.logical(filters))
private$.filters <- filters
}
)
)
# Filtering ----
render_ui_filter <- function(x, var) {
if(all(is.null(x) | is.na(x))){
#If all data is null, don't create a filter from it
return(NULL)
}
id <- paste0("filter",var)
var <- stringr::str_to_title(var)
if (is.numeric(x)) {
if(is.integer(x)){
step = 1
}
else{
step = NULL
}
rng <- range(x, na.rm = TRUE)
sliderInput(id,
var,
min = rng[1],
max = rng[2],
value = rng,
round = TRUE,
width = "90%",
sep = " ",
step = step
)
} else {
# Not supported
NULL
}
}
filter_var <- function(x, val) {
if(all(is.null(x) | is.na(x))){
#If all data is null, don't create a filter from it
return(TRUE)
}
if (is.numeric(x)) {
!is.na(x) & x >= val[1] & x <= val[2]
} else {
# No control, so don't filter
TRUE
}
}
# Options ----
options("gargoyle.talkative" = TRUE)
options(shiny.trace = TRUE)
options(shiny.fullstacktrace = TRUE)
ui <- function(request){
tagList(
h4('Filters'),
uiOutput("transactionFilters"),
h4('Reactive'),
tableOutput("table_reactive"),
h4('R6'),
tableOutput("table_r6")
)
}
server <- function(input, output, session){
gargoyle::init("df_r6_filtered")
Name <- c("Jon", "Bill", "Maria", "Ben", "Tina")
Age <- c(23, 41, 32, 58, 26)
df <- reactive(data.frame(Name, Age))
df_r6 <- DataSet$new()
df_r6$set_data(data.frame(Name, Age))
output$transactionFilters <- renderUI(
map(names(df()), ~ render_ui_filter(x = df()[[.x]], var = .x))
)
selected <- reactive({
if(nrow(df()) > 0){
each_var <- map(names(df()), ~ filter_var(df()[[.x]], input[[paste0("filter",.x)]]))
reduce(each_var, `&`)
}
})
observe({
data <- df_r6$get_data(unfiltered = TRUE)
data_names <- names(data)
if(ncol(data) > 0){
each_var <- map(data_names, ~ filter_var(data[[.x]], input[[paste0("filter",.x)]]))
filters_concatted <- reduce(each_var, `&`)
df_r6$set_filters(filters_concatted)
gargoyle::trigger("df_r6_filtered")
}
})
output$table_reactive <- renderTable(df()[selected(),])
gargoyle::on("df_r6_filtered",{
output$table_r6 <- renderTable(df_r6$get_data())
})
}
shinyApp(ui, server)
}
EDIT2: I noticed that the gargoyle::trigger("df_r6_filtered") creates a infinity loop of triggering the observe component. I'm not sure how to get out of it and that's what I am looking for help with.
The answer was simpler then expected of course. Just change the observe to a observeEvent on all of the input elements regarding the filter, i.e. like this:
observeEvent(
eventExpr = {
data <- df_r6$get_data(unfiltered = TRUE)
data_names <- names(data)
map(data_names, ~ input[[paste0("filter",.x)]])
},
{
...
}
})

R/Rshiny adding item to list of factors

Why is this so difficult?! I have (what I believe is a factor vector) and I want to add an item to the list so I can use it farther down the road.
I want to add "memo.txt" to the factor vector filenames.
I have figured out how to add a factor level to the list, but not the item itself.
levels(filenames) <- c(levels(filenames), "memo.txt")
The specific section I am working in is here:
observeEvent(input$download, {
filenames <- na.omit(data[input$tbl1_rows_selected, "file_name"])
#I need to add items to "filenames" here. I then display "test" to make sure those items exist in "filenames" - ie, i want to add "memo.txt" to filenames.
output$test <- renderTable(filenames)
files <- file.path(".", "www", filenames)
URIs <- lapply(seq_along(files), function(i){
URI <- dataURI(file = files[i])
list(filename = filenames[i], uri = substr(URI, 14, nchar(URI)))
})
table <- fromJSON(toJSON(input$appts_data), simplifyDataFrame = FALSE)
session$sendCustomMessage(
"download",
list(table = table, URIs = URIs)
)
})
The entire code:
library(shiny)
library(timevis)
library(lubridate)
library(dplyr)
library(jsonlite)
library(base64enc)
starthour <- 8
today <- as.character(Sys.Date())
todayzero <- paste(today, "00:00:00")
todayAM <- paste(today, "07:00:00")
todayPM <- paste(today, "18:00:00")
items <- data.frame(
category = c("Room", "IceBreaker", "Activity", "Break"),
group = c(1, 2, 3, 4),
className = c ("red_point", "blue_point", "green_point", "purple_point"),
content = c("Big Room", "Introductions", "Red Rover", "Lunch"),
length = c(480, 60, 120, 90),
file_name = c("Toolkit_placeholder.pdf", NA, "Placeholder.txt", "Toolkit_placeholder.pdf")
)
groups <- data.frame(id = items$group, content = items$category)
data <- items %>% mutate(
id = 1:4,
start = as.POSIXct(todayzero) + hours(starthour),
end = as.POSIXct(todayzero) + hours(starthour) + minutes(items$length)
)
js <- "
function downloadZIP(x){
var csv = Papa.unparse(x.table);
var URIs = x.URIs;
domtoimage.toPng(document.getElementById('appts'), {bgcolor: 'white'})
.then(function (dataUrl) {
var zip = new JSZip();
var idx = dataUrl.indexOf('base64,') + 'base64,'.length;
var content = dataUrl.substring(idx);
zip.file('timeline.png', content, {base64: true})
.file('timeline.csv', btoa(csv), {base64: true});
for(let i=0; i < URIs.length; ++i){
zip.file(URIs[i].filename, URIs[i].uri, {base64: true});
}
zip.generateAsync({type:'base64'}).then(function (b64) {
var link = document.createElement('a');
link.download = 'mytimeline.zip';
link.href = 'data:application/zip;base64,' + b64;
link.click();
});
});
}
$(document).on('shiny:connected', function(){
Shiny.addCustomMessageHandler('download', downloadZIP);
});"
ui <- fluidPage(
tags$head(
tags$script(src = "https://cdnjs.cloudflare.com/ajax/libs/dom-to-image/2.6.0/dom-to-image.min.js"),
tags$script(src = "https://cdnjs.cloudflare.com/ajax/libs/jszip/3.5.0/jszip.min.js"),
tags$script(src = "https://cdnjs.cloudflare.com/ajax/libs/PapaParse/5.2.0/papaparse.min.js"),
tags$script(HTML(js)),
tags$style(
HTML(
"
.red_point { border-color: red; border-width: 2px; }
.blue_point { border-color: blue; border-width: 2px; }
.green_point { border-color: green; border-width: 2px; }
.purple_point { border-color: purple; border-width: 2px; }
"
)
)
),
DT::dataTableOutput("tbl1"),
conditionalPanel(
condition = "typeof input.tbl1_rows_selected !== 'undefined' && input.tbl1_rows_selected.length > 1",
actionButton(class = "btn-success",
"button2",
"GENERATE TIMELINE")
),
conditionalPanel(
condition = "input.button2 > 0",
timevisOutput("appts"),
actionButton("download", "Download timeline", class = "btn-success"),
conditionalPanel(
condition = "input.download > 0",
tableOutput("test")
)
)
)
server <- function(input, output, session) {
output$tbl1 <- DT::renderDataTable({
data
},
caption = 'Select desired options and scroll down to continue.',
selection = 'multiple',
class = "display nowrap compact",
extensions = 'Scroller',
options = list(
dom = 'Bfrtip',
paging = FALSE,
columnDefs = list(list(visible = FALSE))
))
observeEvent(input$button2, {
row_data <- data[input$tbl1_rows_selected, ]
output$appts <- renderTimevis(timevis(
data = row_data,
groups = groups,
fit = TRUE,
options = list(
editable = TRUE,
multiselect = TRUE,
align = "center",
stack = TRUE,
start = todayAM,
end = todayPM,
showCurrentTime = FALSE,
showMajorLabels = FALSE
)
))
file_list <- as.data.frame(row_data$file_name)
})
observeEvent(input$download, {
filenames <- na.omit(data[input$tbl1_rows_selected, "file_name"])
#levels(filenames) <- c(levels(filenames), "memo.txt")
#test <- "memo.txt"
#browser()
#filenames <- append(filenames,test)
# levels(filenames) <- c(levels(filenames), "memo.txt")
output$test <- renderTable(filenames)
files <- file.path(".", "www", filenames)
URIs <- lapply(seq_along(files), function(i){
URI <- dataURI(file = files[i])
list(filename = filenames[i], uri = substr(URI, 14, nchar(URI)))
})
table <- fromJSON(toJSON(input$appts_data), simplifyDataFrame = FALSE)
session$sendCustomMessage(
"download",
list(table = table, URIs = URIs)
)
})
}
shinyApp(ui, server)
EDIT w/answer(ish)
After trying (and failing) like so many others to deal with the factors, I wisened up and set my original "items" dataframe to stringAsFactors = FALSE
this is by far the easiest solution. From there the following works:
items <- data.frame(
category = c("Room", "IceBreaker", "Activity", "Break"),
group = c(1, 2, 3, 4),
className = c ("red_point", "blue_point", "green_point",
"purple_point"),
content = c("Big Room", "Introductions", "Red Rover", "Lunch"),
length = c(480, 60, 120, 90),
file_name = c("Toolkit_placeholder.pdf", NA, "Placeholder.txt",
"Toolkit_placeholder.pdf"), stringsAsFactors = FALSE
)
observeEvent(input$download, {
filenames <- na.omit(data[input$tbl1_rows_selected, "file_name"])
static_files <- "memo.txt"
filenames <- append(filenames,static_files)
output$test <- renderTable(filenames)
files <- file.path(".", "www", filenames)
URIs <- lapply(seq_along(files), function(i){
URI <- dataURI(file = files[i])
list(filename = filenames[i], uri = substr(URI, 14, nchar(URI)))
})
table <- fromJSON(toJSON(input$appts_data), simplifyDataFrame = FALSE)
session$sendCustomMessage(
"download",
list(table = table, URIs = URIs)
)
})
Instead of trying to manipulate the factors, the simplest answer was to set stringsToFactors as FALSE. I am using R version 3.6, in R 4.0 that is now the default behavior.
I have updated the original question to include the answer.
Try this code:
observeEvent(input$download, {
filenames <- na.omit(data[input$tbl1_rows_selected, "file_name"])
## added the next seven lines; no other modifications to your code.
filez <- file.path(".", "www", filenames)
fnamez <- lapply(seq_along(filez), function(i){
list(filename = filenames[i])
})
f2namez <- list(fnamez,"memo.txt")
filenamez <- unlist(f2namez)
filenamez2 <- data.frame(filenamez)
output$test <- renderTable(filenamez2)
files <- file.path(".", "www", filenames)
URIs <- lapply(seq_along(files), function(i){
URI <- dataURI(file = files[i])
list(filename = filenames[i], uri = substr(URI, 14, nchar(URI)))
})
table <- fromJSON(toJSON(input$appts_data), simplifyDataFrame = FALSE)
session$sendCustomMessage(
"download",
list(table = table, URIs = URIs)
)
})
No other modification to the remaining part of your code. This gives the following output:

Using rhandsontable in a shiny module

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;
}")
}

Difficulty getting htmlwidgets::onStaticRenderComplete to work with leaflet

I am using Shiny and trying to create synced leaflet maps that work with leafletProxy. The script which should run after the leaflet widgets have rendered doesn't seem to get called.
library(shiny)
library(leaflet)
# Modified from mapview::latticeView
sync <- function (..., ncol = 2, sync = "none", sync.cursor = FALSE,
no.initial.sync = TRUE)
{
ls <- list(...)
if (length(ls) == 1)
ls <- ls[[1]]
for (i in seq(ls)) {
if (!is.null(ls[[i]]$id)) {
ls[[i]]$elementId <- ls[[i]]$id
}
#ls[[i]] <- mapview:::mapview2leaflet(ls[[i]])
if (length(ls[[i]]$dependencies) == 0) {
ls[[i]]$dependencies = list()
}
if (is.null(ls[[i]]$elementId)) {
ls[[i]]$elementId <- paste("htmlwidget", as.integer(stats::runif(1,
1, 10000)), sep = "-")
}
}
wdth <- paste0("width:", round(1/ncol * 100, 0) - 1, "%;")
styl <- paste0("display:inline;", wdth, "float:left;border-style:solid;border-color:#BEBEBE;border-width:1px 1px 1px 1px;")
tg <- lapply(seq(ls), function(i) {
htmltools::tags$div(style = styl, leafletOutput(ls[[i]]$id))
})
sync_strng <- ""
if (!is.list(sync) && sync == "all") {
sync = list(seq(ls))
}
if (is.list(sync)) {
for (i in seq(sync)) {
synci <- sync[[i]]
sync_grid <- expand.grid(synci, synci, KEEP.OUT.ATTRS = FALSE)
sync_strng <- c(sync_strng, apply(sync_grid, MARGIN = 1,
function(combo) {
if (combo[1] != combo[2]) {
return(sprintf("leaf_widgets['%s'].sync(leaf_widgets['%s'],{syncCursor: %s, noInitialSync: %s});",
ls[[combo[1]]]$elementId, ls[[combo[2]]]$elementId,
tolower(as.logical(sync.cursor)), tolower(as.logical(no.initial.sync))))
}
return("")
}))
}
}
sync_strng <- paste0(sync_strng, collapse = "\n")
tl <- htmltools::attachDependencies(htmltools::tagList(tg,
htmlwidgets::onStaticRenderComplete(paste0("
var leaf_widgets = {}; \n
Array.prototype.map.call( \n
document.querySelectorAll(\".leaflet\"),\n
function(ldiv){\n
if (HTMLWidgets.find(\"#\" + ldiv.id) && HTMLWidgets.find(\"#\" + ldiv.id).getMap()) {\n
leaf_widgets[ldiv.id] = HTMLWidgets.find(\"#\" + ldiv.id).getMap();\n
}\n }\n );\n ",
sync_strng))), mapview:::dependencyLeafletsync())
return(htmltools::browsable(tl))
}
ui <- function(id) {
uiOutput("maps")
}
server <- function(input,output,session) {
map1 <- leaflet() %>% addTiles()
map2 <- leaflet() %>% addTiles()
output$map1 <- renderLeaflet(map1)
output$map2 <- renderLeaflet(map2)
output$maps <- renderUI({
sync2(leafletProxy('map1'), leafletProxy('map2'), sync = "all", sync.cursor = TRUE, no.initial.sync = FALSE)
})
}
runApp(shinyApp(ui, server), launch.browser=TRUE)
When the page loads, the maps are not synced, but if I go into the console and execute window.HTMLWidgets.staticRender() the post render code will run and the maps will be synced. What is causing this?

Error in renderDataTable

When I'm trying to run this code as a Shiny app in R, I'm facing this error:
Error in renderDataTable({ : unused argument (rownames = FALSE)
output$table <- renderDataTable({
if(is.null(fdata()))
{return ()}
if(input$flevel=="Weekly")
{
if(input$flevel2=="Store")
{
data<-fdata()
data <- data[data$SKU == input$xcol,]
data <- data[data$Store == input$ycol,]
data
}
else if(input$flevel2=="Region")
{
data<-fdata()
data <- data[data$SKU == input$xcol,]
data <- data[data$Region == input$ycol,]
# data <- aggregate(Sales~Date+SKU+Region_Name,data = data,FUN = sum,na.rm=TRUE)
data
}
}
else if(input$flevel=="Monthly")
{
if(input$flevel2=="Store")
{
dmsales<-MonthManp()
data<-dmsales[[4]]
data <- data[data$SKU == input$xcol,]
data <- data[data$Store == input$ycol,]
data
}
else if(input$flevel2=="Region")
{
dmsales<-MonthManp()
data<-dmsales[[4]]
data <- data[data$SKU == input$xcol,]
data <- data[data$Region == input$ycol,]
data
# data <- aggregate(Sales~Date+product_id+loc_id+Channel_Name,data = data,FUN = sum,na.rm=TRUE)
}
} }, options = list(searching = FALSE),rownames=FALSE)
All my brackets are properly closed and the rownames is inside the datatable not the options tab. Can anyone pls help me in this. I'm a newbie in Shiny.
The params for
renderDataTable are:
renderDataTable(expr, options = NULL, searchDelay = 500,
callback = "function(oTable) {}", escape = TRUE, env = parent.frame(),
quoted = FALSE, outputArgs = list())
You could use the following format:
output$table <- DT::renderDataTable({
DT::datatable(df,options = list(searching=FALSE),rownames= FALSE)
})
Hope this helps!

Resources