I am using shinyWidgets pickerInput within a flexdashboard sidebar. My issue is that when the options in the pickerInput are too wide they get cut off within the width of the sidebar which makes it so you cannot read the options, see which are selected, or see the deselect all button. Is there a way to have the pickerInput dropdown overflow off of the sidebar and onto the body of the page?
As an intermediate solution I have found that you can use:
choicesOpt = list(
content = stringr::str_trunc(sort(unique(COLUMN_NAME)), width = 25))
To truncate the text in the pickerInput so that you are able to see which options are selected and all of the buttons but you are still not able to read each option fully.
Edit:
Adding reprex - Looking to have the filter drop down open over the body so that everything is visible.
---
title: "TEST"
runtime: shiny
output:
flexdashboard::flex_dashboard:
orientation: rows
---
```{r setup, include=FALSE}
library(dplyr)
library(shiny)
library(DT)
library(shinyWidgets)
Name <- c("LONNGGGGGGGGGGGGGGG TEXXTTTTTTTTTTTTTTTTTT", "Bill", "Maria", "Ben", "Tina")
Age <- c(23, 41, 32, 58, 26)
df <- data.frame(Name, Age)
```
Sidebar {.sidebar}
=======================================================================
### Filters
```{r}
pickerInput(
inputId = "name",
label = "test",
choices = sort(unique(df$Name)),
selected = sort(unique(df$Name)),
multiple = TRUE,
options = list(
`actions-box` = TRUE,
`selected-text-format` = paste0("count > ", length(sort(unique(df$Name))) -1),`count-selected-text` = "All Selected")
)
```
TEST
=======================================================================
Row
-------------------------------------
```{r}
filtered_data <-
reactive ({
req(input$name)
df %>%
filter(Name %in% input$name)
})
renderDataTable(filtered_data(), class = 'cell-border stripe',
extensions = 'Buttons',
rownames = FALSE,
options = list(
columnDefs = list(list(className = 'dt-center',width = '100px', targets = "_all"))),fillContainer=TRUE)
```
This may have unintended side effects but here's a workaround to force the picker dropdown to not get cutoff.
You can add your own css class to the Sidebar section inside the {}. I used .my-class as a placeholder. Then I inserted a css chunk and added .my-class to the .section.sidebar classes from flexdashboard. If you don't do that then that css will overwrite the class. Most likely because it's loaded afterwards.
Also in the reprex provided, for whatever reason the choices were the not the actual values but instead the level positions.
So I used sort(unique(Name)) instead of sort(unique(df$Name))
```{css, echo=FALSE}
.section.sidebar.my-class {
overflow: visible;
z-index: 10;
}
```
Sidebar {.sidebar .my-class}
=======================================================================
...
Option 2: Truncate choices
The above option works as long as the height of the sidebar does not exceed the height of the browser window. Ideally you want overflow-x: visible and overflow-y: scroll. However I'm not sure if that's possible on the same div with position fixed.
Instead you could truncate your options so they fit in the window. If you want more text to be displayed you can increase the width of the sidebar.
cs = sort(unique(Name)
pickerInput(
inputId = "name",
label = "test",
choices = cs,
selected = cs,
multiple = TRUE,
options = list(
`actions-box` = TRUE,
`selected-text-format` = paste0("count > ", length(sort(unique(df$Name))) -1),`count-selected-text` = "All Selected"
),
choicesOpt = list(
content = stringr::str_trunc(cs, width = 18)
)
)
Related
I am trying to update a picker input in a flexdashboard but can't seem to correctly do it.
When a user clicks on the "ThisTabGetsClicked" tab, I want the sidebar to update and just allow the user to select one item from the drop down menu. When the user exits this tab (by clicking on another tab) I want them to have the options back again.
How can I "disable" the option for users to select more than one item in the dropdown?
Flexdashboard:
---
title: "Untitled"
output:
flexdashboard::flex_dashboard:
orientation: columns
vertical_layout: fill
---
```{r setup, include=FALSE}
library(flexdashboard)
library(shiny)
library(shinyWidgets)
library(shinyjs)
library(tidyverse)
```
MySidebar {.sidebar data-width=300}
==============================
```{r}
useShinyjs(rmd = TRUE)
items = c("I1", "I2", "I3", "I4", "I5")
shinyWidgets::pickerInput(
inputId = "select",
choices = items,
selected = items[1],
multiple = TRUE,
options = list(
`actions-box`= TRUE,
size = 10,
`selected-text-format` = "count > 3"
)
)
```
# Home {data-orientation=rows}
=====================================
### Box1
1
c2
### Box2.1
2.1
### Box2.2
2.2
# ThisTabGetsClicked {data-orientation=rows}
=====================================
Here, I want to update the side bar dropdown to only display one input
```{r}
only_one_item_allowed = reactive({
input$select[1]
})
```
```{r}
observeEvent(input$apply, {
updatePickerInput(inputId = "select",
choices = only_one_provincia_allowed(),
selected = only_one_provincia_allowed(),
options = list(
size = 10
)
)
})
```
I am building a datatable in R Shiny to display data with many columns and rows. I had two problems at first:
When the user was scrolling down the table, the header of the table disappeared. This has been fixed thanks to this SO post.
When a user wishes to go left or right of the table, he has to scroll to the bottom of the page (or top depending on where you display the scrollbar). This is an inconvenience to repeat this task especially when displaying many rows. So, my aim is to add a horizontal scrollbar to the fixed header. Would this be possible?
I searched the internet and I found this post that may contain the answer but not sure how to implement it in my case.
The following reproducible code will spawn a table with 50 rows and 30 columns:
library(shiny)
library(shinyWidgets)
library(shinydashboard)
library(dplyr)
library(data.table)
library(tidyverse)
library(DT)
myFun <- function(n = 5000) {
a <- do.call(paste0, replicate(5, sample(LETTERS, n, TRUE), FALSE))
paste0(a, sprintf("%04d", sample(9999, n, TRUE)), sample(LETTERS, n, TRUE))
}
dt <- setDT(data.frame(replicate(30,sample(myFun(50),50,rep=TRUE))))
ui <- fluidPage(theme = "slate",
navbarPage(title = "Test",
header = tagList(
useShinydashboard(),
),
tabPanel(
"Table",
fluidRow(
box(dataTableOutput("mytable"),
width = 12,
collapsible = FALSE,
title = "",
solidHeader = T
)
)
)
)
)
# server
server <- function(input, output) {
output$mytable <-
renderDataTable(
dt,
filter = list(position = "top", clear = FALSE, plain = TRUE),
extensions = c("FixedHeader"),
options = list(
scrollX = T,
fixedHeader=T,
pageLength = 50,
autoWidth = F,
search = list(regex = TRUE),
# the following is used to cut the string if its too long
columnDefs = list(
list(
targets = "_all",
render = JS(
"function(data, type, row, meta) {",
"return type === 'display' && data != null && data.length > 5 ?",
"'<span title=\"' + data + '\">' + data.substr(0, 5) + '...</span>' : data;",
"}"
)
)
)
),
rownames = FALSE
)
}
# app
shinyApp(ui, server)
Will generate a Shiny app:
Any help is kindly appreciated. Thanks in advance.
The vertical scrollbar that appears is actually for the whole page, not the datatable. You need to restrict the height of your datatable, so it doesn't overflow the page, and add the vertical bar. You can do that by adding
scrollY = 300
to your table options, where "300" is the height of your datatable. Depending on your userbase, what devices they are using etc. you will need to adjust this number or find an appropriate way of setting it automatically.
The above would also fix the problem with disappearing header, since you are actually scrolling table body instead of the whole page.
I have a simple shiny app.
#ui.r
navbarPage(
"Application",
tabPanel("General",
sidebarLayout(
sidebarPanel(
uiOutput("tex2")
),
mainPanel(
DT::dataTableOutput("hot3")
)
)))
#server.r
library(shiny)
library(DT)
library(tidyverse)
server <- function(input, output,session) {
output$tex2<-renderUI({
numericInput("text2","Rows selected",
value = 1,
min=1
)
})
output$hot3 <-DT::renderDataTable(
iris%>% rowid_to_column("Row") %>% mutate(Row = ""),
rownames = FALSE,
extensions = "Select",
options = list(
columnDefs = list(list(className = "select-checkbox", targets = 0, orderable = FALSE)),
select = list(style = "os", selector = "td:first-child")),
selection=list(mode="single")
)
}
What I need to do is display the number of rows selected in the datatable in the numericInput() in the sidebarPanel. This number is already displayed under the table but I would like to have it in the numericInput() as well. If I want to select multiple items, I need to keep the command key pressed on my Mac. On a Windows machine it should be the control key I believe. Or use shift to select multiple adjacent items.
Here is a minimal example using an RMarkdown document with a shiny backend to show how to get the number of selected rows.
---
title: "Untitled"
output: html_document
runtime: shiny
---
```{r echo=FALSE}
library(DT)
library(tidyverse)
dataTableOutput("irisTable")
output$irisTable <- renderDataTable(
iris %>% rowid_to_column("Row") %>% mutate(Row = ""),
rownames = FALSE,
extensions = "Select",
options = list(
columnDefs = list(list(className = "select-checkbox", targets = 0, orderable = FALSE)),
select = list(style = "multi", selector = "td:first-child")
))
p("Selected rows are...")
renderText(input$irisTable_rows_selected)
```
Please note that in comparison to my answer to your previous post, I've changed the select.style behaviour to select = list(style = "multi", selector = "td:first-child"); this allows you to select multiple entries by single-clicking on rows (instead of having to hold the Command/Ctrl key).
When I check the check boxes, drop down appears with a default value selected. I change selection in drop down and when I uncheck the check box, the value in the drop down goes back to default. I want to retain the values in the dropdown. Here is my reproducible code:
---
title: "Untitled"
output:
flexdashboard::flex_dashboard:
runtime: shiny
---
```{r setup, include=FALSE}
library(flexdashboard)
library(shiny)
library(shinydashboard)
```
Column {.sidebar}
-----------------------------------------------------------------------
```{r}
cars <- mtcars
checkboxGroupInput("rowfilters", "Select row filters:",
c("Cylinder" = "cyl",
"Gear" = "gear"))
renderUI({
if("cyl" %in% input$rowfilters){
selectInput('CYL', label = "Select Cylinder:",
choices = as.character(unique(cars$cyl)), multiple = TRUE,
selected = "6")
}
})
renderUI({
if("gear" %in% input$rowfilters){
selectInput('GEAR', label = "Select Gear:",
choices = as.character(unique(cars$gear)), multiple = TRUE,
selected = "4")
}
})
```
Here when I check "Cylinder" and "Gear", two dropdowns "Select Cylinder", and "Select Gear" appear with a default values. I now change the value in "Select Cylinder:" to 6,4 and 8. Now when I uncheck "Gear", the dropdown "Select Gear" disappears, which is what I want. However, the value in "Select Cylinder" goes back to default value "6". I want "Select Cylinder" to retain my previous selection 6,4, and 8.
Please let me know if you have any suggestions? Thank you.
Problem
The reason why your code works this way is that your renderUI depends on the checkboxGroupInput, so whenever you tick the checkboxes your app is actually rerendering the selectInput-s with the default values.
Suggestion
My suggestion would be to render all the inputs, but hide the selectInput-s initially. Upon using the checkboxGroupInput, you can then toggle the visibilty of the elements.
This way they don't get rerendered and thus their values will stay the same.
Solution
We are going to use the shinyjs package as it allows us to hide/show elements, etc.
Include useShinyjs(rmd = TRUE)
In order to use shinyjs with flexdashboard you need to include the useShinyjs function in the R chunk.
Render the two selectInput
We will render the selectInput on init, but hide them with the hidden function from shinyjs.
hidden(selectInput(
"CYL", label = "Select Cylinder:",
choices = as.character(unique(cars$cyl)), multiple = TRUE,
selected = "6"
))
hidden(selectInput(
"GEAR", label = "Select Gear:",
choices = as.character(unique(cars$gear)), multiple = TRUE,
selected = "4"
))
Add observers for toggling visibilty.
We can toggle visibility on and off for the selectInput based on the value of the checkboxGroupInput.
observe( {
if("cyl" %in% input$rowfilters) {
shinyjs::show("CYL")
} else {
shinyjs::hide("CYL")
}
})
observe( {
if("gear" %in% input$rowfilters) {
shinyjs::show("GEAR")
} else {
shinyjs::hide("GEAR")
}
})
Complete code
---
title: "Untitled"
output:
flexdashboard::flex_dashboard:
runtime: shiny
---
```{r setup, include=FALSE}
library(flexdashboard)
library(shiny)
library(shinydashboard)
library(shinyjs)
```
Column {.sidebar}
-----------------------------------------------------------------------
```{r}
useShinyjs(rmd = TRUE)
observe( {
if("cyl" %in% input$rowfilters) {
shinyjs::show("CYL")
} else {
shinyjs::hide("CYL")
}
})
observe( {
if("gear" %in% input$rowfilters) {
shinyjs::show("GEAR")
} else {
shinyjs::hide("GEAR")
}
})
cars <- mtcars
checkboxGroupInput(
"rowfilters", "Select row filters:",
c(
"Cylinder" = "cyl",
"Gear" = "gear"
)
)
hidden(selectInput(
"CYL", label = "Select Cylinder:",
choices = as.character(unique(cars$cyl)), multiple = TRUE,
selected = "6"
))
hidden(selectInput(
"GEAR", label = "Select Gear:",
choices = as.character(unique(cars$gear)), multiple = TRUE,
selected = "4"
))
```
I would like to make a datatable using DT that does not change width when the browser window changes. The example below almost does what I am trying to do, all of the column widths are locked except the first column, which is still flexible. I would like all of the columns to be locked without specifying widths in pixels for each column.
library(DT)
library(dplyr)
datatable(mtcars,
options = list(
autowidth = TRUE
)) %>%
formatStyle(columns = 1:ncol(mtcars),
`width` = "100%")
The following Rmd document gives a fixed width of 100 pixels to the datatable
---
output: html_document
---
```{r}
shiny::div(
width = "100px",
DT::datatable(mtcars))
```
The usage in shiny is similar
shiny::shinyApp(
ui = shiny::div(
width = "100px",
DT::datatable(mtcars)),
server = function(...){}
)