Related
I am trying to place a button inside the datatable where if the user wants to reset the sorted column they can hit the button and table gets reset or changed to it's original order. At the moment, when I press the button, it is not triggering any event on click. The event should replace the data in the server part.
I am currently following these posts:
shiny DT datatable - reset filters
https://github.com/rstudio/DT/issues/76
Reset a DT table to the original sort order
However, in the last two posts above, even though they get the job done, the button is not part of the datatable.
Here is my reprex:
library(DT)
library(shiny)
library(shinyjs)
# function placed in the global.R
clearSorting <- function(proxy) {
shinyjs::runjs(paste0("$('#' + document.getElementById('", proxy$id,"').getElementsByTagName('table')[0].id).dataTable().fnSort([]);"))
}
# ui.R
ui <- fluidPage(
DT::DTOutput(outputId = "table"),
shinyjs::useShinyjs()
)
# servcer.R
server <- function(input, output) {
output$table <- renderDT({
DT::datatable(data = iris,
filter = 'top',
extensions = c('Buttons'),
options = list(scrollY = 600,
scrollX = TRUE,
autoWidth = TRUE,
dom = '<"float-left"l><"float-right"f>rt<"row"<"col-sm-4"B><"col-sm-4"i><"col-sm-4"p>>',
buttons = list(
list(
extend = '',
text = 'Reset Table',
action = JS("function() {document.getElementById('reset_sort').click();}")
)
),
scrollCollapse= TRUE,
lengthChange = TRUE,
widthChange= TRUE))
})
observeEvent(input$reset_sort, {
data <- iris
clearSorting(proxy = DT::dataTableProxy(outputId = "table"))
DT::replaceData(proxy = DT::dataTableProxy(outputId = "table"),
data = data,
rownames = FALSE)
})
}
shinyApp(ui = ui, server = server)
Here is a way:
library(DT)
js <- c(
"function(e, dt, node, config){",
" dt.iterator('table', function(s){",
" s.aaSorting.length = 0;",
" s.aiDisplay.sort(function(a,b){",
" return a-b;",
" });",
" s.aiDisplayMaster.sort(function(a,b){",
" return a-b;",
" });",
" }).draw();",
"}"
)
datatable(
iris,
extensions = "Buttons",
options = list(
dom = "Bfrtip",
buttons = list(
list(
extend = "collection",
text = "Reset columns order",
action = JS(js)
)
)
)
)
To use it in Shiny, you may need to set server = FALSE in renderDT:
output$table <- renderDT({
......
}, server = FALSE)
I have created a function that dynamically creates multiple bucket lists dependent on prior inputs without manually creating each add_rank_list.
However, I have not been able to style it, as with non-dynamic creation of bucket lists.
The following example demonstrates this.
It is styled with a HTML tag. class = c("default-sortable", "custom-sortable") is then included as an option within bucket_list. However, I cannot place this code without error in the dynamically created bucket_lists' code.
library(shiny)
library(sortable)
ui <- fluidPage(
tags$style(
HTML("
.rank-list-container.custom-sortable {
border-color:#FFFFFF;
}
.custom-sortable .rank-list-item {
border-color:#FFFFFF;
}
")),
uiOutput("bucket_1_and_2"),
fluidRow( column(6,uiOutput("bucket_1")),column(6,
uiOutput("bucket_2")))
)
server <- function(input, output, session) {
bucket_1 <- reactive({lapply(c("Default","Styling"), function(x) {
add_rank_list(
text = "",
input_id = paste0("bucket_1_",x),
labels = x
)
})
})
output$bucket_1_and_2 <- renderUI({
do.call("bucket_list", args = c(
header = "",
group_name = "bucket_sort",
orientation = "horizontal",
# The following code does not function:
# class = c("default-sortable", "custom-sortable"),
bucket_1()
))
})
output$bucket_1 <- renderUI({
bucket_list(
header = "",
group_name = "bucket_sort",
orientation = "horizontal",
class = c("default-sortable", "custom-sortable"),
add_rank_list(
text = "",
input_id = "bucket_1",
labels = "Custom"
))
}
)
output$bucket_2 <- renderUI({
bucket_list(
header = "",
group_name = "bucket_sort",
orientation = "horizontal",
class = c("default-sortable", "custom-sortable"),
add_rank_list(
text = "",
input_id = "bucket_2",
labels = "Styling"
))
}
)
}
shinyApp(ui, server)
Help much appreciated.
I never used bucked_list so I'm not sure, but perhaps you want:
output$bucket_1_and_2 <- renderUI({
bucketLists <- lapply(bucket_1(), function(x){
bucket_list(
header = "",
group_name = "bucket_sort",
orientation = "horizontal",
class = c("default-sortable", "custom-sortable"),
x
)
})
do.call(tagList, buckedLists)
})
Problem: I have the following app. Essentially, I want to press the button to load the data. After the first time I load the data via button press I want to get ask if I want to save my changes. If yes, confirmation that changes were successfully saved, else show some other data (other data not included).
Approach I tried to solve it with observeEvent expressions which are triggered via reactiveValues. However, as you will observe when running the script below, this does not work out as expected.
Question: Any idea on what is wrong?
library(shiny)
library(shinyWidgets)
library(rhandsontable)
shinyApp(
ui = fluidPage(
actionButton("show", "Show data", width = "100%"),
rHandsontableOutput("data_table")
),
server = function(input, output) {
rv <- reactiveValues(
# Triggers
pressed_first_time = 0,
confirm_module = TRUE,
save_module = TRUE,
table_change = TRUE
)
observeEvent(input$show, ignoreInit = TRUE, {
if (rv$pressed_first_time == 0){
rv$pressed_first_time <- isolate(rv$pressed_first_time + 1)
rv$table_change <- isolate(!rv$table_change)
cat("pressed_first time")
} else {
rv$pressed_first_time <- isolate(rv$pressed_first_time + 1)
rv$confirm_module <- isolate(!rv$confirm_module)
}
})
observeEvent(rv$confirm_module, ignoreInit = TRUE,{
confirmSweetAlert(
session = session,
inputId = session$ns("show_confirmation"),
title = "Be careful, your changes might be lost",
text = "Do you want to save your changes?",
type = "question",
btn_labels = c("Cancel", "Save"),
btn_colors = NULL,
closeOnClickOutside = FALSE,
showCloseButton = FALSE,
html = FALSE
)
cat("confirmation module")
rv$save_module <- isolate(!rv$save_module)
})
observeEvent(rv$save_module, ignoreInit = TRUE, {
if (isTRUE(input$show_confirmation)) {
sendSweetAlert(
session = session,
title = "Saved",
text = "Updated data has been successfully saved",
type = "success"
)
rv$table_change <- isolate(!rv$table_change)
cat("saving module")
} else {
return()
}
})
data_to_modify <- eventReactive(rv$table_change, ignoreInit = TRUE, {
mtcars
})
handson_df <- eventReactive(rv$table_change, ignoreInit = TRUE, {
cat("create handsons")
req(data_to_modify())
rhandsontable(data_to_modify())
})
output$data_table <- renderRHandsontable({
cat("plot module")
req(handson_df())
htmlwidgets::onRender(handson_df(),change_hook)
})
}
)
I think its just that you need session inside the server, as in:
server = function(input, output, session) {...
Actually, I found out the problem. The link from data_to_modify to handson_df was missing. In the below solution I put them together but in principle adding another reactiveValue triggering handson_df from data_to_modify will also work
library(shiny)
library(rhandsontable)
shinyApp(
ui = fluidPage(
actionButton("show", "Show data", width = "100%"),
rHandsontableOutput("data_table")
),
server = function(input, output) {
rv <- reactiveValues(
# Triggers
pressed_first_time = 0,
confirm_module = TRUE,
save_module = TRUE,
table_change = TRUE
)
observeEvent(input$show, ignoreInit = TRUE, {
if (rv$pressed_first_time == 0){
rv$pressed_first_time <- 1
rv$table_change <- isolate(!rv$table_change)
cat("pressed_first time")
} else {
rv$pressed_first_time <- 1
rv$confirm_module <- isolate(!rv$confirm_module)
}
})
observeEvent(rv$confirm_module, ignoreInit = TRUE,{
confirmSweetAlert(
session = session,
inputId = session$ns("show_confirmation"),
title = "Be careful, your changes might be lost",
text = "Do you want to save your changes?",
type = "question",
btn_labels = c("Cancel", "Save"),
btn_colors = NULL,
closeOnClickOutside = FALSE,
showCloseButton = FALSE,
html = FALSE
)
})
observeEvent(input$show_confirmation, ignoreInit = TRUE, {
if (isTRUE(input$show_confirmation)) {
sendSweetAlert(
session = session,
title = "Saved",
text = "Updated data has been successfully saved",
type = "success"
)
rv$table_change <- isolate(!rv$table_change)
cat("saving module")
} else {
return()
}
})
data_to_modify <- eventReactive(rv$table_change, ignoreInit = TRUE, {
rhandsontable(mtcars)
})
# handson_df <- eventReactive(rv$table_change, ignoreInit = TRUE, {
# cat("create handsons")
# req(data_to_modify())
# rhandsontable(data_to_modify())
# })
output$data_table <- renderRHandsontable({
cat("plot module")
req(data_to_modify())
data_to_modify()
# htmlwidgets::onRender(handson_df(),change_hook)
})
}
)
What I am attempting to do, is to allow the user to pass in a configuration/lookup excel table into shiny, display this table in shiny, allow the user to make cells edits in shiny, and use the values that were edited from the editable table for calculations. My problem arises for the last step "use the values that were edited from the editable table for calculations".
The excel file consists of 2 tabs with data of the following content:
Tab1 Name: "parameters"
data.frame(Name = c("a", "b", "c"), Value = c(1:3))
Tab2 Name: "parameters2"
data.frame(Name = c("a", "b", "c"), Value = c(4:6))
The ideal shiny app would do the following:
1) At upload, perform a calculation adding the unchanged first values of Tab 1 and Tab 2. This would be 1 + 4 = 5.
2) If user edits Tab 1's value of 1 to 8, then the calculation would result in 8 + 4 = 12.
Effectively, I want to use the edited tables values to update all my calculations if the user makes any edits to it. I know this can be done by simply uploading a new file in shiny, but I would rather allow them to do this in shiny as opposed to uploading a new file.
Here is my shiny app. Appreciate any help/guidance!
library(shiny)
library(DT)
shinyApp(
ui <- fluidPage(
fileInput(inputId = "config", label = "Upload Configuration File",
multiple = F, accept = c(".xlsx", ".xls")),
verbatimTextOutput("txt"),
tagList(tags$head(tags$style(type = 'text/css','.navbar-brand{display:none;}')),
navbarPage(title = "",
tabPanel(title = "Parameters",
dataTableOutput(outputId = "edit.param", width = 2)),
tabPanel(title = "Parameters2",
dataTableOutput(outputId = "edit.param2", width = 2))
)
)
),
server = function(input, output, session) {
config.path = reactive({
inFile = input$config
if(is.null(inFile)) {
return(NULL)
} else {
return(inFile$datapath)
}
})
df.param = reactive({
read_excel(path = config.path(), sheet = "parameters")
})
df.param2 = reactive({
read_excel(path = config.path(), sheet = "parameters2")
})
output$edit.param = renderDT(df.param(), selection = "none", server = F, editable = "cell")
output$edit.param2 = renderDT(df.param2(), selection = "none", server = F, editable = "cell")
observeEvent(input$edit.param_cell_edit, {
df.param()[input$edit.param_cell_edit$row, input$edit.param_cell_edit$col] <<- input$edit.param_cell_edit$value
})
observeEvent(input$edit.param2_cell_edit, {
df.param()[input$edit.param2_cell_edit$row, input$edit.param2_cell_edit$col] <<- input$edit.param2_cell_edit$value
})
output$txt = reactive({
df.param()$value[1] + df.param2()$value[1]
})
}
)
I also tried this for the server section and had no luck either:
output$edit.param = renderDT(df.param(), selection = "none", server = F, editable = "cell")
output$edit.param2 = renderDT(df.param2(), selection = "none", server = F, editable = "cell")
observe(input$edit.param_cell_edit)
observe(input$edit.param2_cell_edit)
Could you try this? (I have not tried).
library(shiny)
library(DT)
shinyApp(
ui <- fluidPage(
fileInput(inputId = "config", label = "Upload Configuration File",
multiple = F, accept = c(".xlsx", ".xls")),
verbatimTextOutput("txt"),
tagList(tags$head(tags$style(type = 'text/css','.navbar-brand{display:none;}')),
navbarPage(title = "",
tabPanel(title = "Parameters",
dataTableOutput(outputId = "edit_param", width = 2)),
tabPanel(title = "Parameters2",
dataTableOutput(outputId = "edit_param2", width = 2))
)
)
),
server = function(input, output, session) {
config.path = reactive({
inFile = input$config
if(is.null(inFile)) {
return(NULL)
} else {
return(inFile$datapath)
}
})
df_param <- reactiveVal()
observe({
req(config.path())
df_param(read_excel(path = config.path(), sheet = "parameters"))
})
df_param2 <- reactiveVal()
observe({
req(config.path())
df_param2(read_excel(path = config.path(), sheet = "parameters2"))
})
output$edit_param = renderDT({
req(df_param())
datatable(isolate(df_param()), selection = "none", editable = "cell")
})
output$edit_param2 = renderDT({
req(df_param2())
datatable(isolate(df_param2()), selection = "none", editable = "cell")
})
proxy <- dataTableProxy("edit_param")
proxy2 <- dataTableProxy("edit_param2")
observeEvent(input$edit_param_cell_edit, {
info <- input$edit_param_cell_edit
df_param(editData(df_param(), info, proxy, resetPaging = FALSE))
})
observeEvent(input$edit_param2_cell_edit, {
info <- input$edit_param2_cell_edit
df_param2(editData(df_param2(), info, proxy2, resetPaging = FALSE))
})
output$txt = renderPrint({
df_param()$value[1] + df_param2()$value[1]
})
}
)
Goal: I would like for the user to upload their own data frame, specify the columns in their data frame that provide "Name", "Longitude", and "Latitude" data, then create a table using DataTable (DT package).
Issue: The data frame appears on the render table after the user makes the selections, but when they attempt to sort each column or interact with the data, or even change a selection for "Name", "Longitude", or "Latitude", the following error message appears on the console:
ERROR: [on_request_read] parse error
Here's my code for the ui and server pages I have (note: I am using dashboardPage for layout):
Reproducible Example
ui <- dashboardPage(
dashboardHeader(title = "Test") ,
dashboardSidebar(
sidebarMenu(
menuItem("Selections", tabName = "selections"),
menuItem("Data Table", tabName = "dataTable")
)
),
dashboardBody(
tabItems(
tabItem(
tabName = "selections",
selectInput("mapChoice",
label = "Choose a map:",
choices = c("",
"New Map from Data Table"),
selected = ""),
conditionalPanel("input.mapChoice == 'New Map from Data Table'",
fileInput("userData",
label = "Choose CSV File",
accept=c('text/csv',
'text/comma-separated-values,text/plain',
'.csv')),
uiOutput("newMapUI")
),
###############################################
# Bookmark widget
shinyURL.ui(width = "400px")
###############################################
),
tabItem(
tabName = "dataTable",
DT::dataTableOutput("table")
)
)
)
)
server <- function(input, output, session) {
############################################################
# Add in function for saving and recording urls as bookmarks
shinyURL.server(session)
############################################################
userData <- reactive({
path <- input$userData
if (is.null(path))
return (NULL)
results <- read.csv(file = path$datapath,
header = TRUE,
stringsAsFactors = FALSE)
results
})
output$newMapUI <- renderUI({
list(
# Specify the column for labeling
if (!is.null(userData())) {
selectizeInput("nameCol",
label = "Choose the column to be used for
point labels: ",
choices = c(names(userData())),
multiple = TRUE,
options = list(placeholder = 'Name',
maxItems = 1))
},
# Specify longitude column
if (!is.null(userData())) {
selectizeInput("lonCol",
label = "Choose the column containing longitude
values: ",
choices = c(names(userData())),
multiple = TRUE,
options = list(placeholder = 'Longitude',
maxItems = 1))
},
# Specify latitude column
if (!is.null(userData())) {
selectizeInput("latCol",
label = "Choose the column conatining latitude
values: ",
choices = c(names(userData())),
multiple = TRUE,
options = list(placeholder = 'Latitude',
maxItems = 1))
}
)
})
nameCol <- reactive({
as.character(input$nameCol)
})
lonCol <- reactive({
as.character(input$lonCol)
})
latCol <- reactive({
as.character(input$latCol)
})
newUserData <- reactive({
if (is.null(userData()))
return (NULL)
# Create the new data frame:
if (length(nameCol()) != 0 &&
length(lonCol()) != 0 &&
length(latCol()) != 0) {
userData <- userData()
name <- nameCol()
lonCol <- lonCol()
latCol <- latCol()
results <- data.frame(Name = userData[, name],
Longitude = userData[, lonCol],
Latitude = userData[, latCol])
results$Name <- as.character(results$Name)
results$Longitude <- as.numeric(results$Longitude)
results$Latitude <- as.numeric(results$Latitude)
}
results
})
mapData <- reactive({
data <- data.frame()
if (input$mapChoice == "New Map from Data Table") {
if (length(nameCol()) != 0 &&
length(lonCol()) != 0 &&
length(latCol() != 0)) {
data <- newUserData()
}
}
data
})
output$table <- DT::renderDataTable({
datatable(mapData(),
extensions = c('Buttons', 'FixedHeader', 'Scroller'),
options = list(dom = 'Bfrtip',
buttons = list('copy', 'print',
list(extend = 'csv',
filename = 'map data',
text = 'Download')
),
scrollX = TRUE,
pageLength = nrow(mapData()),
fixedHeader = TRUE,
deferRender = FALSE,
scrollY = 400,
scroller = FALSE,
autowidth = TRUE
)
)
}
) # End of table render
}
shinyApp(ui = ui, server = server)
Note: If I attempted to use this data for a plot, that will also not work. (Plotting the points on a map is my end goal).
Update1: For some dumb reason, this snippet app runs perfectly fine as expected, yet these lines of code are directly from my application. I will continue to update as more things occur.
Update2: After heavy searching and debugging, I finally caught the source of the error message via help of the js provided by the browser while running the app. The error is trying to use shinyURL in combination with DT and fileInput. My guess is that shinyURL is attempting to save a url, which is entirely too long for the browser, and which provides info that the user gave. In other words, it might be trying to save the fileInput data with the url info..? I'm adding the shinyURL function to the example above, so that it will provide the exact same error message I was stuck on. I don't need a solution immediately, but I am curious about what's really happening. (Lines that produce error are highlighted with ### above and below.
Solution
The issue was expected in my latest update, the combination of the user uploaded file and the interaction of the data frame in DT caused the URL generate by shinyURL to be entirely too long.
To find a work around that allows shinyURL to still be in the application, I did some investigating and discovered that DT output creates its own input objects such as input$tableId_rows_current, which tried to save all of the indices of the table every time the user interacted with. So, as soon as the data frame was too large, any interaction with it would pass a url query error, which showed up on the console in R Studio as ERROR [on_request_read] parse error.
Luckily, shinyURL also has an inherent way of ignoring user selected inputs. How? Just simply place a "." at the beginning of the input ID when creating new widgets. Or, in the case of DT table output, place a period at the beginning of your data table output ID, so that all of the inherent DT inputs are ignored.
Code Solution:
ui <- dashboardPage(
dashboardHeader(title = "Test") ,
dashboardSidebar(
sidebarMenu(
menuItem("Selections", tabName = "selections"),
menuItem("Data Table", tabName = "dataTable")
)
),
dashboardBody(
tabItems(
tabItem(
tabName = "selections",
selectInput("mapChoice",
label = "Choose a map:",
choices = c("",
"New Map from Data Table"),
selected = ""),
conditionalPanel("input.mapChoice == 'New Map from Data Table'",
#########################################################
# Add in a period before file input ID
#########################################################
fileInput(".userData",
label = "Choose CSV File",
accept=c('text/csv',
'text/comma-separated-values,text/plain',
'.csv')),
uiOutput("newMapUI")
),
# # Bookmark widget
shinyURL.ui(width = "400px")
),
tabItem(
tabName = "dataTable",
########################################################
# Add in a period before data table output ID
########################################################
DT::dataTableOutput(".table")
)
)
)
)
server <- function(input, output, session) {
# # Add in function for saving and recording urls as bookmarks
shinyURL.server(session)
userData <- reactive({
path <- input$.userData
if (is.null(path))
return (NULL)
results <- read.csv(file = path$datapath,
header = TRUE,
stringsAsFactors = FALSE)
results
})
output$newMapUI <- renderUI({
list(
# Specify the column for labeling
if (!is.null(userData())) {
selectizeInput("nameCol",
label = "Choose the column to be used for
point labels: ",
choices = c(names(userData())),
multiple = TRUE,
options = list(placeholder = 'Name',
maxItems = 1))
},
# Specify longitude column
if (!is.null(userData())) {
selectizeInput("lonCol",
label = "Choose the column containing longitude
values: ",
choices = c(names(userData())),
multiple = TRUE,
options = list(placeholder = 'Longitude',
maxItems = 1))
},
# Specify latitude column
if (!is.null(userData())) {
selectizeInput("latCol",
label = "Choose the column conatining latitude
values: ",
choices = c(names(userData())),
multiple = TRUE,
options = list(placeholder = 'Latitude',
maxItems = 1))
}
)
})
nameCol <- reactive({
as.character(input$nameCol)
})
lonCol <- reactive({
as.character(input$lonCol)
})
latCol <- reactive({
as.character(input$latCol)
})
newUserData <- reactive({
if (is.null(userData()))
return (NULL)
# Create the new data frame:
if (length(nameCol()) != 0 &&
length(lonCol()) != 0 &&
length(latCol()) != 0) {
userData <- userData()
name <- nameCol()
lonCol <- lonCol()
latCol <- latCol()
results <- data.frame(Name = userData[, name],
Longitude = userData[, lonCol],
Latitude = userData[, latCol])
results$Name <- as.character(results$Name)
results$Longitude <- as.numeric(results$Longitude)
results$Latitude <- as.numeric(results$Latitude)
}
results
})
mapData <- reactive({
data <- data.frame()
if (input$mapChoice == "New Map from Data Table") {
if (length(nameCol()) != 0 &&
length(lonCol()) != 0 &&
length(latCol() != 0)) {
data <- newUserData()
}
}
data
})
output$.table <- DT::renderDataTable({
datatable(mapData(),
extensions = c('Buttons', 'FixedHeader', 'Scroller'),
options = list(dom = 'Bfrtip',
buttons = list('copy', 'print',
list(extend = 'csv',
filename = 'map data',
text = 'Download')
),
scrollX = TRUE,
pageLength = nrow(mapData()),
fixedHeader = TRUE,
deferRender = FALSE,
scrollY = 400,
scroller = FALSE,
autowidth = TRUE
)
)
}
) # End of table render
}
shinyApp(ui = ui, server = server)