Shiny: checkboxes in DT make row more changing height - css

I am implementing some checkboxes in R shiny DT, however for some reasons it seems like the checkbox is contained in a box higher than the cell itself, so I am ending up with a very unpleasant layout as far less rows fit the same page.
Is there a way to control the height in which the checkbox or other components as props are contained, in order to fix the cell? the checkbox itself is much smaller than the actual cells and would fit perfectly in a normal cell.
below some code to reproduce the problem if you want to play with it.
library(DT)
ui <- basicPage(
h2("The mtcars data"),
DT::dataTableOutput("mytable")
)
server <- function(input, output) {
shinyInput <- function(FUN, len, id, ...) {
inputs <- character(len)
for (i in seq_len(len)) {
inputs[i] <- as.character(FUN(paste0(id, i), ...))
}
inputs
}
mtcars <- data.frame(mtcars, newvar=shinyInput(checkboxInput,nrow(mtcars),"chkbx_",label="",value=TRUE,width=NULL))
output$mytable = DT::renderDataTable({
DT::datatable(mtcars, escape = FALSE, selection = 'none', options = list(searching = FALSE, ordering = FALSE))
})
}
shinyApp(ui, server)

You need to modify CSS of the app in order to achieve this. The quickest solution is to add a style tag to your UI:
ui <- basicPage(
tags$style(HTML("
td > div.form-group > div.checkbox {
margin: 0px;
}
td > div.form-group {
margin: 0px;
}
")),
h2("The mtcars data"),
DT::dataTableOutput("mytable")
)
This will remove margins from all form-groups and checkboxes inside table cells in the app.

Related

R Remove padding from datatable cells

I have a datatable in my shiny web app in which I have inserted checkboxes. However, my actual dataset is quite large. Therefore I would like to compress the datatable respectively reduce the padding.
Although I have already found some approaches, this did not work with the checkboxes.
Can anyone help me?
Many thanks in advane!
Here is my reproducible example:
library(shiny)
library(DT)
library(tidyverse)
shinyApp(
ui <- fluidPage(
DT::dataTableOutput('x1')
),
server<-function(input, output, session) {
# create a character vector of shiny inputs
shinyInput<-function(FUN, len, id, ...) {
inputs <- character(len)
for (i in seq_len(len)) {
inputs[i] <- as.character(FUN(paste0(id, i), label=NULL, ...))
}
inputs
}
# a sample data frame
values <- reactiveValues(res=data.frame(
iris %>% slice(10),
v2=shinyInput(checkboxInput, 10, 'v2_', value=FALSE)
)
)
# render the table containing shiny inputs
output$x1 <- DT::renderDataTable(
datatable(values$res, escape = F),
server=FALSE,
escape=FALSE
)
}
)
You need a little CSS. Strictly speaking of the padding, that's straight forward. This rule targets table data cells elements (<td>) contained within the table with the id "x1"
ui <- fluidPage(
DT::dataTableOutput('x1'),
tags$style(HTML("
#x1 td {
padding-top: 0;
padding-bottom: 0;
}
"))
)
This compacts it some. If you want to compact it more, you'll need to find what's driving the row height then target that. For example, the checkboxes have a bottom margin. You could remove that as well. If you're not aware, you can see the applied css by using using your browser's devtools. For Chrome, right click on a row and select "Inspect"

How do I sort values in a shiny app dropdown menu

This is the code I am currently working with:
library(shiny)
library(data.table)
# Create the data table
dt <- data.table(
name = c("")
)
# Define the Shiny app UI
ui <- fluidPage(
tags$head(
tags$style(HTML("
.wrapper {
max-width: 1300px;
margin-left: auto;
margin-right: auto;
}
#media (min-width: 1300px) {
.wrapper {
margin-left: auto;
margin-right: auto;
}
}
"))
),
# Wrap the contents of the page in a div with the wrapper class
div(class = "wrapper",
# Add a file input button
fileInput("file", "Upload CSV file"),
# Add a sidebar layout
sidebarLayout(
# Add a sidebar panel
sidebarPanel(
# Add checkboxes for each column in the data table
checkboxGroupInput("columns", "Columns:", names(dt), selected = NULL),
# Add a dropdown menu for the unique values of each selected column
uiOutput("values")
),
# Add a main panel
mainPanel(
# Add a data table to the main panel
DT::dataTableOutput("table")
)
)
)
)
# Define the Shiny app server logic
server <- function(input, output, session) {
# Read the CSV file and replace the existing data in dt
observeEvent(input$file, {
if (is.null(input$file)) return()
dt <<- fread(input$file$datapath)
# Update the checkboxGroupInput with the names of the new data in dt
updateCheckboxGroupInput(session, "columns", choices = names(dt), selected = names(dt)[1])
})
# Create a reactive expression for the unique values of the selected columns
values <- reactive({
lapply(input$columns, function(x) {
selectInput(x, x, c("All", unique(dt[, x, with = FALSE])), selected = "All")
})
})
# Render the dropdown menus
output$values <- renderUI({
tagList(values())
})
# Create a reactive expression for the subset of the data table
subset <- reactive({
filters <- lapply(input$columns, function(x) {
if (input[[x]] == "All") {
TRUE
} else {
dt[[x]] %in% input[[x]]
}
})
dt[Reduce(`&`, filters), ]
})
# Render the data table
output$table <- DT::renderDataTable({
subset()
}, options = list(pageLength = 100)) # set pageLength = 100 to show 100 entries by default
}
# Run the Shiny app
shinyApp(ui, server)
The idea is that when new data is uploaded via a browse button prompt, radio buttons appear to select columns, and for the columns selected, dropdown menus are dynamically created that subset displayed data according to the unique values.
I want to modify the code so that the unique values in the dropdown menus are sorted, yet I can't for the life of me figure out how to modify the code without creating errors in reading the data.
I changed this line of code:
selectInput(x, x, c("All", unique(dt[, x, with = FALSE])), selected = "All")
to this:
selectInput(x, x, c("All", unique(dt[order(dt[, x, with = FALSE]), x, with = FALSE])), selected = "All")
The sort() function kept producing errors, but order() worked.

How to add columns to input matrix without shrinking matrix size in r shiny?

Whenever I add columns to the matrix, the columns shrink in width until they become way too small. Is there a way to increase the width of the page so that the matrix columns don't shrink? Thanks
output$mat <- renderUI({
rw<-list(1:input$numoc)
for (i in (1:input$numoc)) {
rw[[1]][[i]] = paste("Outcome", i, sep=" ")
}
clm<-list(1:input$inp1)
for (i in (1:input$inp1)) {
clm[[1]][[i]] = paste("Treatment", i, sep=" ")
}
matrix1 <- matrix(seq(from=1, to=((input$numoc)*(input$inp1)), by=1), input$inp1, input$numoc, dimnames = list(clm[[1]],rw[[1]]))
matrixInput("mat", "Probabilities", matrix1, rows=list(names=TRUE), cols=list(names=TRUE))
})
That is possible using CSS. Once we have overwritten table-layout: fixed; of the HTML element table the header cells respond to the min-width attribute. You can adapt the minimum width to your needs.
Make sure you use the correct inputID to select the HTML table. In CSS the ID is preceded by #.
Disadvantage (of course): at some point you get a horizontal scroll bar.
library(shiny)
library(shinyMatrix)
# Define UI for application that draws a histogram
ui <- fluidPage(
tags$head(
tags$style(HTML(
"div#mat table {
table-layout: auto;
}
div#mat .matrix-input-col-header-cell div {
min-width: 100px;
}"
))),
# Application title
titlePanel("Min Col Width"),
# Sidebar with a slider input for number of bins
sidebarLayout(
sidebarPanel(
sliderInput("numoc", "Number of bins:",
min = 1, max = 50, value = 5),
numericInput("inp1", "Inp1", 1)
),
mainPanel(
uiOutput("mat") # show the matrix
)
)
)
# Server as provided by the asker
server <- function(input, output) {
output$mat <- renderUI({
rw <- list(1:input$numoc)
for (i in (1:input$numoc)) {
rw[[1]][[i]] <- paste("Outcome", i, sep = " ")
}
clm <- list(1:input$inp1)
for (i in (1:input$inp1)) {
clm[[1]][[i]] <- paste("Treatment", i, sep = " ")
}
matrix1 <- matrix(seq(from=1, to=((input$numoc)*(input$inp1)), by=1), input$inp1, input$numoc, dimnames = list(clm[[1]],rw[[1]]))
matrixInput("mat", "Probabilities", matrix1, rows=list(names=TRUE), cols=list(names=TRUE))
})
}
shinyApp(ui = ui, server = server)
I tested this sample in Firefox and the R-Studio App Viewer.

R Shiny - Dynamic download link in datatable

I want to add a download link in each row of a datatable in shiny.
So far I have
server <- function(input, output) {
v<-eventReactive(input$button,{
temp<-data.frame(TBL.name=paste("Data ",1:10))
temp<-cbind(
temp,
#Dynamically create the download and action links
Attachments=sapply(seq(nrow(temp)),function(i){as.character(downloadLink(paste0("downloadData_",i),label = "Download Attachments"))})
)
})
# Table of selected dataset ----
output$table <- renderDataTable({
v()
}, escape = F)}
ui <- fluidPage(
sidebarPanel(
actionButton("button", "eventReactive")
),
mainPanel(
dataTableOutput("table")
)
)
I have the download links in the table for each row. Now I want to add a different file location for each row. For example, each download link will result in a download of a different zip-folder. Can I use downloadHandler for this?
I do not believe you can embed downloadButtons/downloadLinks directly in a datatable. However, you can create hidden downloadLinks that get triggered by links embedded in your table. This produces the same end result. To do so you must:
Dynamically generate downloadLinks/downloadButtons.
Use css to set their visibility to hidden.
Embed normal links/buttons in the table
Set the onClick field of these links to trigger the corresponding hidden downloadLink.
Here is code from an example using the mtcars dataset.
library(tidyverse)
library(shiny)
ui <- fluidPage(
tags$head(
tags$style(HTML("
.hiddenLink {
visibility: hidden;
}
"))
),
dataTableOutput("cars_table"),
uiOutput("hidden_downloads")
)
server <- function(input, output, session) {
data <- mtcars
lapply(1:nrow(data), function(i) {
output[[paste0("downloadData", i)]] <- downloadHandler(
filename = function() {
paste("data-", i, ".csv", sep="")
},
content = function(file) {
write.csv(data, file)
}
)
})
output$hidden_downloads <- renderUI(
lapply(1:nrow(data), function(i) {
downloadLink(paste0("downloadData", i), "download", class = "hiddenLink")
}
)
)
output$cars_table <- renderDataTable({
data %>%
mutate(link = lapply(1:n(),
function(i)
paste0('<a href="#" onClick=document.getElementById("downloadData',i, '").click() >Download</a>')
))
}, escape = F)
}
shinyApp(ui, server)
Since each downloadLink label must correspond to a name in output, I don't think there is a way to create an arbitrary set of downloads using the standard Shiny download* functions.
I solved this using DT and javascript. DT allows javascript to be associated with a datatable. The javascript can then tell Shiny to send a file to the client and the client can force the data to be downloaded.
I created a minimal example gist. Run in RStudio with:
runGist('b77ec1dc0031f2838f9dae08436efd35')
Safari is not supporting .click() anymore since v12.0. Hence, I adapted the hidden link solution from abanker with the dataTable/actionButton described by P Bucher, and the .click() workaround described here. Here is the final code:
library(shiny)
library(shinyjs)
library(DT)
# Random dataset
pName <- paste0("File", c(1:20))
shinyApp(
ui <- fluidPage( useShinyjs(),
DT::dataTableOutput("data"),
uiOutput("hidden_downloads") ),
server <- function(input, output) {
# Two clicks are necessary to make the download button to work
# Workaround: duplicating the first click
# 'fClicks' will track whether click is the first one
fClicks <- reactiveValues()
for(i in seq_len(length(pName)))
fClicks[[paste0("firstClick_",i)]] <- F
# Creating hidden Links
output$hidden_downloads <- renderUI(
lapply(seq_len(length(pName)), function(i) downloadLink(paste0("dButton_",i), label="")))
# Creating Download handlers (one for each button)
lapply(seq_len(length(pName)), function(i) {
output[[paste0("dButton_",i)]] <- downloadHandler(
filename = function() paste0("file_", i, ".csv"),
content = function(file) write.csv(c(1,2), file))
})
# Function to generate the Action buttons (or actionLink)
makeButtons <- function(len) {
inputs <- character(len)
for (i in seq_len(len)) inputs[i] <- as.character(
actionButton(inputId = paste0("aButton_", i),
label = "Download",
onclick = 'Shiny.onInputChange(\"selected_button\", this.id, {priority: \"event\"})'))
inputs
}
# Creating table with Action buttons
df <- reactiveValues(data=data.frame(Name=pName,
Actions=makeButtons(length(pName)),
row.names=seq_len(length(pName))))
output$data <- DT::renderDataTable(df$data, server=F, escape=F, selection='none')
# Triggered by the action button
observeEvent(input$selected_button, {
i <- as.numeric(strsplit(input$selected_button, "_")[[1]][2])
shinyjs::runjs(paste0("document.getElementById('aButton_",i,"').addEventListener('click',function(){",
"setTimeout(function(){document.getElementById('dButton_",i,"').click();},0)});"))
# Duplicating the first click
if(!fClicks[[paste0("firstClick_",i)]])
{
click(paste0('aButton_', i))
fClicks[[paste0("firstClick_",i)]] <- T
}
})
}
)

Interactive Column/Table Updates with textInput in R Shiny

UPDATE
I've gotten to what I think is the root problem. The following R Shiny App produces a UI with 2 text input boxes, as well as event observers that print messages to the console as the text changes in their respective text input boxes. The issue is that only one of these event observers works correctly, and I can't figure out why.
ui.R (shortened)
library(shiny)
library(shinydashboard)
library(DT)
library(data.table)
shinyUI(
renderUI({
fluidPage(
column(12, dataTableOutput("Main_table")),
box(textInput("TEST_BOX", label=NULL, value="TEST"))
)
})
)
server.R (shortened)
shinyServer(function(input, output) {
test <- reactiveValues()
test$data <- data.table(ID = 1, Group = 1)
output$Main_table <- renderDataTable({
datatable(data.frame(test$data,
New_Group=as.character(textInput("BOX_ID", label = NULL, value = "TEST2",
width = '100px'))), escape=F
)})
observeEvent(input$TEST_BOX, {
print("Test Box Success")
})
observeEvent(input$BOX_ID, {
print("Box ID Success")
})
})
Original Post:
I'm attempting to create a simple app in R Shiny to allow the user to interactively update the values in a column of a small table, then be able to hit a "Save Changes" button and update the table to include their selections.
I've gotten really close with the code below (I think), but for some reason the inputs cbox_1 to cbox_10 always come back as NULL.
ui.R
library(shiny)
library(shinydashboard)
library(DT)
library(data.table)
shinyUI(fluidPage(
dashboardBody(uiOutput("MainBody")
)
))
server.R
# Load libraries
library(shiny)
library(shinydashboard)
library(DT)
library(data.table)
# Define server logic
shinyServer(function(input, output) {
# Create sample data
vals <- reactiveValues()
vals$Data <- data.table(ID = 1:10, Group = 1:1)
# Create main UI with Save Changes button and additional text input box for testing.
output$MainBody <- renderUI({
fluidPage(
box(width=12,
h3(strong("Group Testing"),align="center"),
hr(),
box(textInput("test", label=NULL, value="TESTING")),
column(6, offset = 5, actionButton("save_changes","Save changes")),
column(12, dataTableOutput("Main_table"))
)
)
})
# Function to be used to create multiple text input boxes.
shinyInput = function(FUN, len, id, ...) {
inputs = character(len)
for (i in seq_len(len)) {
inputs[i] = as.character(FUN(paste0(id, i), label = NULL, value = vals$Data$Group[i], width = '100px', ...))
}
inputs
}
# Renders table to include column with text input boxes. Uses function above.
output$Main_table <- renderDataTable({
datatable(data.frame(vals$Data, New_Group=shinyInput(textInput, nrow(vals$Data),"cbox_")), options = list(dom = 't', pageLength = nrow(vals$Data), paging=FALSE, searching=FALSE), rownames=FALSE,
escape=F)
}
)
# Tests if the test input box works.
observeEvent(input$test, {
print("Success1")
})
# Tests if the first input box in the table works.
observeEvent(input$cbox_1, {
print("Success2")
})
# Tests if the Save Changes button works.
observeEvent(input$save_changes, {
print("Success3")
# Assigns the values in the input boxes (New_Group) to the existing Group column.
for (i in 1:nrow(vals$Data)) {
vals$Data$Group[i] <- eval(paste0("input$cbox_", i))
}
datatable(data.frame(vals$Data, New_Group=shinyInput(textInput, nrow(vals$Data),"cbox_")), options = list(pageLength = nrow(vals$Data), paging=FALSE, searching=FALSE), rownames=FALSE,
escape=F)
})
})
The first two observeEvents at the end of the code are solely for testing purposes. "Success2" is never printed even when the contents of the first box are changed. "Success1" is printed when the test box is changed, but I'm not sure why one works and the other doesn't. I've tried inserting a browser() statement in various places of the code to check the value of cbox_1, but it always comes back NULL. I'd also be open to alternate solutions to this problem if I'm approaching it completely wrong. Thanks.
After further research, an approach utilizing the rhandsontable package seemed like the best solution. I modeled my code after this example:
Data input via shinyTable in R shiny application
I also utilized several of the options described here:
https://jrowen.github.io/rhandsontable/#introduction

Resources