I have the following example app (code below). The idea is that if a user selects the second column (index of 1), the selection goes to the third column (index of 2), as I don't want the user to be able to select the second column at all (as far as I know there is no built-in way to stop the user selecting a particular column in DT).
The issue is that while selectRows(tableProxy, c(2) works (a trivial example of a row selection), selectColumns(tableProxy, c(2)) only deselects the currently selected column and does not select the third column.
Is there an issue with my syntax, or is this a bug? If it is a bug, is there a workaround?
Reproducable example:
library(shiny)
# Define UI for application that draws a histogram
ui <- fluidPage(
fluidRow(
tags$div(title = "Iris table",
DT::dataTableOutput("irisTable"))
)
)
# Define server logic required to draw a table
server <- function(input, output) {
output$irisTable <- DT::renderDT(datatable(head(iris, 20), options = list(paging = FALSE, searching = FALSE),
rownames = FALSE,
selection = list(target = 'row+column', mode='single', selected = list(rows = c(NULL), cols = c(2)))
) %>%
formatStyle(0, target= 'row',color = 'black',
lineHeight='70%', padding = '3px 3px', fontSize = '80%')
)
tableProxy <- dataTableProxy("irisTable")
observeEvent(input$irisTable_columns_selected, {
if (input$irisTable_columns_selected == 1) {
#tableProxy %>% selectColumns(2)
selectRows(tableProxy, c(2))
selectColumns(tableProxy, c(2))
}
})
}
# Run the application
shinyApp(ui = ui, server = server)
Update: I have tried the above with the example code published here (converted to work with a single file Shiny app), and I have the same issue. I've reinstalled the DT package and it doesn't resolve the issue.
It's a bug of DT that should have been fixed via the PR rstudio/DT#528. You can install the dev version to test it by calling devtools::install_github("rstudio/DT").
Related
I have larger shiny app where I use DT to view, sort, filter, etc. a dataset. DT works great! The app has filters set to adjust the data before it is passed to DT for rendering (e.g., Data Filter and Data Slice in the screenshot below). The Table Slice functionality, however, does not yet work.
However, it would also be useful to slice the data shown in the DT table after different DT filters have been applied (e.g., sorting on price like in the screenshot below and just rendering the top 5, 10, 1,000).
My first attempt is shown in the reproducible example below. The goal is to slice the DT table after it has been sorted on price so the user can see just the top 5 or 10 rows. In the example this works fine the first time the user changes stop_index. However, changing stop_index, changes the table, and thus input$my_table_rows_all.
What I'd want is for the user to be able to move stop_index around multiple times and the value 20 stays at the top of the table and no NAs are added. Similarly, if the user moves around start_index multiple time, 11 stays at the bottom and no NAs are added.
Are there any other/better option than using proxy? I could get close to what I'm looking by changing the pageLength option. That is less effective, however, if the user wants just the top 50,000 customers on some metric (e.g., CLV). Also, that would always start the table at index 1 (0). What if the users wants 10,000:5,0000, for example?
I also thought about a draggable filter like you can have in DT for numeric variables but then based on the row-index of the table and not the values of the variable shown in the table.
As always, glad to hear any suggestions you might have.
library(shiny)
library(DT)
dat <- data.frame(row_index = 1:10, price = 11:20)
ui <- fluidPage(
titlePanel("Slice Rows Example"),
sidebarLayout(
sidebarPanel(
sliderInput("start_index", "Start index:", min = 1, max = 10, value = 1),
sliderInput("stop_index", "Stop index:", min = 1, max = 10, value = 10)
),
mainPanel(
dataTableOutput("my_table")
)
)
)
server <- function(input, output) {
output$my_table <- renderDataTable({
## No rows are shown when rownames = FALSE - strange (DT 0.25)
# datatable(dat, rownames = FALSE, options = list(saveState = TRUE, order=list(list(2, "desc"))))
datatable(dat, rownames = TRUE, options = list(saveState = TRUE, order=list(list(2, "desc"))))
})
proxy <- dataTableProxy("my_table")
observe({
print(input$my_table_rows_all)
})
observeEvent(c(input$start_index, input$stop_index), {
req(input$my_table_rows_all)
start_ind <- input$start_index
stop_ind <- input$stop_index
ind <- input$my_table_rows_all[start_ind:stop_ind]
replaceData(proxy, dat[ind, ,drop=FALSE])
})
}
shinyApp(ui, server)
Below what the example app would look like after moving stop_index to 7 and then back to 8. As you can see, the top value is no longer 20 and NAs have been added. That makes sense because my_table_rows_all was change, which is why I'm looking for an alternate approach.
You can create a reactive to filter your data with the slider inputs and just replace data inside ObserveEvent:
library(shiny)
library(DT)
dat <- data.frame(row_index = 1:10, price = 11:20)
ui <- fluidPage(
titlePanel("Slice Rows Example"),
sidebarLayout(
sidebarPanel(
sliderInput("start_index", "Start index:", min = 1, max = 10, value = 1),
sliderInput("stop_index", "Stop index:", min = 1, max = 10, value = 10)
),
mainPanel(
dataTableOutput("my_table")
)
)
)
server <- function(input, output) {
output$my_table <- renderDataTable({
## No rows are shown when rownames = FALSE - strange (DT 0.25)
# datatable(dat, rownames = FALSE, options = list(saveState = TRUE, order=list(list(2, "desc"))))
datatable(dat, rownames = TRUE, options = list(saveState = TRUE, order=list(list(2, "desc"))))
})
proxy <- dataTableProxy("my_table")
observe({
print(input$my_table_rows_all)
})
dat_f <- reactive({
dat <- dat[input$start_index:input$stop_index, ]
})
observeEvent(c(input$start_index, input$stop_index), {
replaceData(proxy, dat_f())
})
}
shinyApp(ui, server)
I am dynamically creating the elements to be inserted into a fluidRow, the problem that I am facing is that all elements are being rendered at once. So, instead of rendering each element when its renderUI function ends, they all keep waiting until the last renderUI finishes. Thus, having lots of elements in my_dataset makes the rendering really slow.
I expected that once the print(str_glue('End: {i}')) was shown, the element would be rendered. However, this was not the case, it kept waiting for all elements (including ones that were not visible on screen).
I tried using the outputOptions(..., suspendWhenHidden = TRUE) but it made no difference (as it was expected since this is the default).
MWE
library(shiny)
library(shinydashboard)
library(dplyr)
library(tidyr)
library(purrr)
library(stringr)
library(shinycssloaders)
qtd <- 500
my_dataset <- data.frame(
stringsAsFactors = F,
Name = rep('Sample', qtd),
Value = runif(qtd)
)
ui <- function() {
fluidPage(
fluidRow(
column(12, textInput(inputId = 'my_text_input', label = NULL, placeholder = 'Search', width = '100%')),
uiOutput('custom_ui')
)
)
}
server <- function(input, output, session) {
output[['custom_ui']] <- renderUI({
filtered_dataset <- my_dataset %>%
filter(grepl(input[['my_text_input']], Name, ignore.case = T)) %>%
arrange(Name)
map(1:nrow(filtered_dataset), function(i) {
item <- filtered_dataset[i,]
custom_id <- str_glue('custom_id_{i}')
output[[custom_id]] <- renderUI({
print(str_glue('Start: {i}'))
print(item)
result <- box(
width = 3,
title = item$Name,
item$Value
)
print(str_glue('End: {i}'))
result
})
column(width = 3, uiOutput(custom_id, style = 'height: 350px;') %>% withSpinner(type = 6))
})
})
}
runApp(shinyApp(ui = ui, server = server), launch.browser = T)
What you are describing is the expected behaviour. The server will not return anything to the UI before all calculations are finished.
I see you are relying a lot on renderUI. This tends to make the Shiny app slow. When the app starts, it must load, realize that it lacks a portion of the UI, ask the server to create the UI - then the server will create the HTML for all of your boxes and send them to the UI before anything is shown. You should try to keep as much as possible of the UI static.
Dependent on what you want to achieve there are probably a lot of different ways of doing it without renderUI.
Under is an example where the HTML for the boxes are created outside of renderUI. This will work, as long as you don't need input controls or outputs in the boxes - because then they need their own ID.
library(shiny)
library(shinydashboard)
library(dplyr)
library(purrr)
qtd <- 500
my_dataset <- data.frame(
stringsAsFactors = FALSE,
Name = rep('Sample', qtd),
Value = runif(qtd)
) %>%
mutate(
x = map2(
Name,
Value,
~column(
width = 3,
box(
width = 3,
title = .x,
.y
)
)
)
)
ui <- function() {
fluidPage(
fluidRow(
column(
12,
textInput(
inputId = 'my_text_input',
label = NULL,
placeholder = 'Search',
width = '100%'
)
),
uiOutput('custom_ui')
)
)
}
server <- function(input, output, session) {
# Only the filtering of the data is done inside `renderUI`
output[['custom_ui']] <- renderUI({
filtered_dataset <-
my_dataset %>%
filter(grepl(input[['my_text_input']], Name, ignore.case = TRUE)) %>%
arrange(Name) %>%
pull(x)
})
}
runApp(shinyApp(ui = ui, server = server), launch.browser = TRUE)
Last I just want to recommend this book by Hadley Wickham. I think reading this (or parts of this) book before working with Shiny will make everything easier for you.
My Shiny application elements are not being rendered once the function is complete. I have a laptop with 2 external monitors. I do Shiny development in the IDE on monitor #1. If I run the app on monitor #1, it takes about 20 seconds to complete rendering when the main calculations (function) have completed. If I run the app on the laptop or monitor #2, it takes about 3 seconds to complete rendering.
However, this is when the app is maximized to full screen. If the app is not maximized, it renders quickly no matter the display (about 3 seconds).
I can only interact with the application on a screen other than the one which displays the IDE, unless it is not maximized. I know this sounds odd but I have tested it many times and it is the only logical solution. Why this is the case I would be interested in finding out.
I have also tried with 'open in browser' enabled, it will render only after about 20 seconds.
I wrote a shiny app which will be used for searching and downloading a quite large dataset. The app works and is nearly done, but some functionalities do not work as I want:
I tried several ways of adding a function in order to download the chosen data as .csv-file. All of them failed and I was only able to download all data instead of the displayed ones.
I was not able to include a function to round data and show some columns as percentage instead of numbers. The formatRound() function within datatable() works well and I would like to use it, but the problem is that I was not able to include it in the server function. Since the user should get the whole number (with all numbers also behind the comma) for his or her work, the data should only be rounded when displayed. If I would be able to fix the rounding, the percentage problem will also be solved, since I would use the similar function formatPercentage().
I made an example using the mtcars-data and removed all wrong or not-working codes for the download and rounding problem. Any hints how I could solve my problem would be extremely appreciated! Thanks in advance!
EDIT3: Rounding problem solved with the code below thanks to #Claud H. The download function exports an empty file (no file-type) named download. Do you have any idea where the error is?
EDIT4: problems solved thanks to #Claud H. I changed mt_cars_filtered()[, c(input$results_columns_selected)]into mt_cars_filtered()[, input$indicator]. Also, I didn't know first that I had to open the web browser to download the data.
library(tidyverse)
library(shiny)
library(shinythemes)
library(DT)
library(ggthemes)
ui <- fluidPage(
sidebarLayout(
sidebarPanel(width=3,
h3("title", align = 'center'),
checkboxGroupInput("cylinder", "Cylinder", choices = c(4,6), selected = c(4)),
checkboxGroupInput('indicator', label = 'Indicators', choices = colnames(mtcars)[1:7],
selected = colnames(mtcars)[c(1:7)]),
fluidRow(p(class = 'text-center', downloadButton('download', label = 'Download')))),
mainPanel(
tabsetPanel(
tabPanel('Table',
DT::dataTableOutput('results'))
)
)
))
server <- function(input, output){
mtcars_filtered <- reactive({
mtcars %>%
filter(cyl %in% input$cylinder)
})
# Output Table
output$results <- DT::renderDataTable({
columns = input$indicator
mtcars_filtered()[, columns, drop = FALSE] %>%
datatable(style = 'bootstrap', selection = list(target = 'column'), options = list(paging = FALSE, dom = 't')) %>%
formatRound(input$indicator[grep('t', input$indicator)], 2)
})
# Download Data
output$download <- downloadHandler(
filename = function() { paste('filename', '.csv', sep = '') },
content = function(file) {
write.csv(mtcars_filtered()[,input$indicator], file, row.names = FALSE)
})
}
shinyApp(ui = ui, server = server)
Suggest looking at ?"%>%" from magrittr package
Also, check this and this answers on SO.
Your table should be fine with this kind of syntax
output$results <- DT::renderDataTable({
columns = input$indicator
mtcars_filtered()[, columns, drop = FALSE] %>%
datatable() %>%
formatCurrency( input your code here) %>%
formatPercentage( and so on ... )
}, style = 'bootstrap', options = list(paging = FALSE, dom = 't'))
Also, I didnt quite get the question about downloading. If you want to download a data FROM server, use downloadHandler() function. Something like:
output$save_data <- downloadHandler(
filename = function() { paste("filename", '.csv', sep = '') },
content = function(file) {
write.csv(mydata(), file, row.names = FALSE)
})
and downloadButton("save_data", "download") in ui.R
edit: as per your changes, download isn't working because you got wrong columns selected: there is no table called tableId, and you need to take the columns from the table called results:
write.csv(mtcars_filtered()[, c(input$results_columns_selected)], file, row.names = FALSE)
as of rounding problem, you can use your indicator variable to see if column is selected input$indicator %in% c('drat', 'qsec', 'wt') then use subsetting to select only columns with TRUE, if there are any: formatRound(input$indicator[input$indicator %in% c('drat', 'qsec', 'wt')], 2)
edit2
Seems I've understood everything you wanted to do right.
To select columns in the downloadHandler function based on your checkboxes , use indicator variable to filter it:
mtcars_filtered()[, input$indicator]
Otherwise, if you want to select them from the table itself with the mouse clicks, use input$results_columns_selected, like this:
mtcars_filtered()[, c(input$results_columns_selected)]
DT package provides the ability to save the state of a table with filters, searching and everything. I can see the content of that state(input$TableId_state) on text output. But I can't use it in any proper way. I want to do two things:
Saving a state of DT at any time, and apply it to same DT with an action button. (I want to have full data but with filters and text in search box) .
Extracting data from output table into another data table inside server function (not as output table)
I can do 2. bullet by using input$tableId_rows_all . But I need to be able to do that with the state.
In my opinion, if any of these are not possible than state function is useless and just to show off.
Here is my trial to do 2. bullet:
library(shiny)
library(DT)
data <- iris
ui <- fluidPage(
actionButton(inputId = "action", label = "Apply",icon=
icon("refresh",lib="font-awesome"),style="background-
color:#FBAF16",width =validateCssUnit(385)),
fluidRow(DT::dataTableOutput(outputId =
"Table")),hr(),fluidRow(DT::dataTableOutput(outputId = "FilteredTable"))
)
server <- function(input,output,session){
output$Table<-DT::renderDataTable(expr = {
DT::datatable(data,option = list(stateSave =
TRUE),filter=list(position="top",clear=TRUE))
})
filtereddata <- eventReactive(input$action,{
return(DT::datatable(data
,options = list(state=input$Table_state)
))
})
output$FilteredTable<- DT::renderDataTable(expr = {
return(filtereddata())
})
}
runApp(list(ui = ui, server = server),host="127.0.0.2",port=5013, launch.browser = TRUE)
I use
output$hot <- renderRHandsontable(rhandsontable(DF))
to get a table.
All works fine but I would like to allow the user to select certain columns only (implemented with shiny::updateSelectizeInput()). the data should then be updated in the full data table and not only in the columns selected. I googled but could only find a very bad description in java. Can someone help me out with this?
as requested an example:
DF = data.frame(matrix(rnorm(20), nrow=10))
rhandsontable(DF)
This is a few years late, and I will note that I don't think this will completely solve the issue as it doesn't use "updateSelectizeinput()" as requested by the OP, plus I must not be handling the select input correctly as one column always shows, but for anyone looking for a start, here is an example:
library(shiny)
library(rhandsontable)
ui <- fluidPage(
selectInput("Select", "Select", names(mtcars), multiple = T, selected = names(mtcars)),
rHandsontableOutput("cars")
)
server <- function(input, output, session) {
DF<-reactiveValues(DF = mtcars, Select = NULL)
observeEvent(input$Select,{
DF$Select <- input$Select
})
output$cars<-renderRHandsontable({
rhandsontable(DF$DF, rowHeaders = NULL)%>%
hot_cols(colWidths = ifelse(names(DF$DF) %in% DF$Select == T, 150, 0.1))
})
}
shinyApp(ui, server)
It uses 0.1 as a column width to effectively hide the column, leaving the original data frame in tact.