R shiny ColVis and datatable search - regex

I have TableTools and ColVis working together, but, as it was explained in another post (R shiny DataTables ColVis behavior), when clicking the Show/hide columns button, the list mixes up with the values in the table underneath, and I cannot make the list disappear.
In that post is mentioned that shiny atm is not compatible with the current data.table version, and I'd like to know if there's any other solution around. Here's my code:
ui.R
library(shiny)
library(shinythemes)
library(ggplot2)
addResourcePath('datatables','\\Users\\Ser\\Downloads\\DataTables-1.10.7\\DataTables-1.10.7\\media')
addResourcePath('tabletools','\\Users\\Ser\\Downloads\\TableTools-2.2.4\\TableTools-2.2.4')
shinyUI(fluidPage(theme = shinytheme("Journal"),
tags$head(
tags$style(HTML("
#import url('//fonts.googleapis.com/css?family=Lobster|Cabin:400,700');
"))
),
headerPanel(
h1("List Manager",
style = "font-family: 'Lobster', cursive;
font-weight: 500; line-height: 1.1;
color: #ad1d28;")),
sidebarLayout(
sidebarPanel(
#File Upload Manager
fileInput('file1', 'Choose file to upload'),
tagList(
singleton(tags$head(tags$script(src='//cdnjs.cloudflare.com/ajax/libs/datatables/1.10.7/js/jquery.dataTables.min.js',type='text/javascript'))),
singleton(tags$head(tags$script(src='//cdnjs.cloudflare.com/ajax/libs/datatables-tabletools/2.1.5/js/TableTools.min.js',type='text/javascript'))),
singleton(tags$head(tags$script(src='//cdnjs.cloudflare.com/ajax/libs/datatables-tabletools/2.1.5/js/ZeroClipboard.min.js',type='text/javascript'))),
singleton(tags$head(tags$link(href='//cdnjs.cloudflare.com/ajax/libs/datatables-tabletools/2.1.5/css/TableTools.min.css',rel='stylesheet',type='text/css'))),
singleton(tags$head(tags$script(src='//cdn.datatables.net/colvis/1.1.0/js/dataTables.colVis.min.js',type='text/javascript'))),
singleton(tags$script(HTML("if (window.innerHeight < 400) alert('Screen too small');")))
)),
mainPanel(
dataTableOutput("mytable"))
)))
server.R
shinyServer(function(input, output) {
output$mytable = renderDataTable({
inFile <- input$file1
if (is.null(inFile))
return(NULL)
read.table(inFile$datapath, header=TRUE, sep='')
}, options = list(
"dom" = 'TC<"clear">lfrtip',
"colVis" = list(
"activate"="click",
"align"="right"),
"oTableTools" = list(
"sSwfPath" = "//cdnjs.cloudflare.com/ajax/libs/datatables-tabletools/2.1.5/swf/copy_csv_xls.swf",
"aButtons" = list(
"copy",
"print",
list("sExtends" = "collection",
"sButtonText" = "Save",
"aButtons" = c("csv","xls")
)
)
)
)
)
})
I also have another question: I'd like to search "<" or ">" values in the searchboxes at the bottom of the table, but I can't make it work. I don't know if I have to add anything to the code so it can be done (such as "regex" or similar).

You may try the DT package instead of hacking the JS libraries by yourself. Here is a minimal example:
library(shiny)
library(DT)
library(shinythemes)
shinyApp(
ui = fluidPage(
theme = shinytheme('journal'),
fluidRow(column(12, DT::dataTableOutput('foo')))
),
server = function(input, output) {
output$foo = DT::renderDataTable(
iris,
filter = 'bottom',
extensions = list(ColVis = list(activate= "click", align = "right")),
options = list(dom = 'C<"clear">lfrtip')
)
}
)
See http://rstudio.github.io/DT/extensions.html for more info on DataTables extensions.

Related

Shiny - download markdown file

library(shiny)
library(ggplot2)
report.Rmd
date: "2023-01-15"
output: html_document
params:
x_column: "Sepal.Width"
y_column: "Sepal.Length"
library(ggplot2)
ggplot(data = iris)+
aes_string(params$x_column,params$y_column)+
geom_point()
shiny app
library(shiny)
library(ggplot)
library(rmarkdown)
ui <- fluidPage(
titlePanel("Iris Data"),
sidebarLayout(
sidebarPanel(
selectizeInput("xcol",
"Choose X Axis",
choices = names(iris)
),
selectizeInput("ycol",
"Choose Y Axis",
choices = names(iris)
),
downloadButton("project", "Download plot")
),
mainPanel(
plotOutput("plot")
)
)
)
server <- function(input, output) {
filename = "report.html
output$plot <- renderPlot({
ggplot(data=iris)+
aes_string(x=input$xcol, y=input$ycol)+
geom_point()
})
output$print <- downloadHandler({
filename="report.html"
content = function(file) {
rmarkdown::render("report.Rmd",
output_file=file, params=list(x_column = input$xcol,
y_column = input$ycol))
}
})
}
I can't get the app to render my rmarkdown file. I can't seem to see the mistake. report.Rmd is in my working directory. I can get it to work outside of shiny, but in shiny it says there is an error and the content is missing without a default value
There are two issues with your code. First, you used the id Project for the downloadButton but named the output print. Second, the API of downloadHandler is a bit different from reactive or renderXXX, i.e. you have to pass filename and content as arguments.
Note: Also it's good practice to copy the report file to a temporary directory before processing it and to evaluate the document in a child of the global environment. See Generating downloadable reports. As an example where missing the last step fails to render an Rmd correctly see this post. Finally, note that aes_string is deprecated since ggplot2 3.4.0. Instead it's recommended to use the .data pro-noun as I do in the code below.
library(shiny)
library(ggplot2)
ui <- fluidPage(
titlePanel("Iris Data"),
sidebarLayout(
sidebarPanel(
selectizeInput("xcol",
"Choose X Axis",
choices = names(iris)
),
selectizeInput("ycol",
"Choose Y Axis",
choices = names(iris)
),
downloadButton("print", "Download plot")
),
mainPanel(
plotOutput("plot")
)
)
)
server <- function(input, output) {
output$plot <- renderPlot({
ggplot(data = iris) +
aes(.data[[params$x_column]], .data[[params$y_column]]) +
geom_point()
})
output$print <- downloadHandler(
filename = "report.html",
content = function(file) {
tempReport <- file.path(tempdir(), "report.Rmd")
file.copy("report.Rmd", tempReport, overwrite = TRUE)
rmarkdown::render(tempReport,
output_file = file,
params = list(
x_column = input$xcol,
y_column = input$ycol
),
envir = new.env(parent = globalenv())
)
}
)
}
shinyApp(ui, server)
#>
#> Listening on http://127.0.0.1:5776
#> Warning: `aes_string()` was deprecated in ggplot2 3.0.0.
#> ℹ Please use tidy evaluation ideoms with `aes()`

Anonymise selected column in R shiny using sapply

I am creating an R Shiny app, where a user can upload their own csv, and the app generates a synthetic dataset. I am trying to add an additional function where the user can select a column they wish to anonymise to make it a shareable file. The rest of the app is currently working, however when I select the column which I want to anonomise, when I press update, the datatable isn't refreshing.
Any help or insight here would be greatly appreciated! I've tried and tried to solve it, but am stuck.
A shortened/reproducible version of the code app is below
`
library(shiny)
library(synthpop)
library(DT)
library(tidyverse)
library(data.table)
library(rsconnect)
library(fontawesome)
library(DT)
library(htmltools)
library(shinythemes)
library(RcppRoll)
library(grid)
library(reactable)
library(shinydashboard)
library(shinydashboardPlus)
library(formattable)
library(dashboardthemes)
library(deidentifyr)
library(anonymizer)
library(digest)
# User interface
ui <- fluidPage(theme = shinytheme("cosmo"),
navbarPage("Synthetic data",
# Upload data tab
tabPanel("Upload data",
sidebarLayout(
sidebarPanel(width = 3,
h4(strong("Upload original data")),
br(),
fileInput(inputId = "datafile", label = "1. Upload a csv file then press 'Update' below.
Note, the larger your dataset, the longer it will take to load", multiple = FALSE, placeholder = "No file selected",
accept = c("text/csv", "text/comma-separated-values,text/plain", ".csv")),
actionButton(inputId = "update", label = "Update", icon = icon("fas fa-sync")),
br(),
br(),
h5(strong("2. To view and download the synthesised dataset, click on the 'Synthetic data' tab at the top"))),
mainPanel(dataTableOutput("table"), style = "font-size:80%"))),
# Synthetic data download
tabPanel("Synthetic data",
sidebarLayout(
sidebarPanel(width = 3,
h4(strong("Anonomise data?")),
br(),
uiOutput(outputId = "anon"),
br(),
actionButton(inputId = "update2", label = "Update", icon = icon("fas fa-sync"))),
mainPanel(dataTableOutput("synth"), style = "font-size:75%"))),
))
# Server function
server <- function(input, output, session) {
options(shiny.maxRequestSize=20*1024^2)
contentsrea <- reactive({
inFile <- input$datafile
if(is.null(inFile))
return(NULL)
dataset <- read_csv(inFile$datapath)
})
observeEvent(input$update, {
if(!is.null(input$datafile)){
original <- read_csv(input$datafile$datapath)
my.seed <- 17914709
synResult <- syn(original, seed = my.seed, maxfaclevels = 150)
# Synthetic data
df <- synResult$syn
# Add 'SYNTH' to column headings
colnames(df) <- paste("SYNTH", colnames(df), sep="_")
# Variable dropdown to anonomise data
output$anon <- renderUI({
selectInput(inputId = "anon",
label="1. Select the variable you'd like to anonomise (i.e., athlete name). If not necessary, leave as blank",
choices = c(" ", colnames(df)),
selected = NULL)
})
## Original
output$table <- DT::renderDataTable(original,
caption = htmltools::tags$caption(
style = 'caption-side: top; text-align: left; color: black; font-size:140%',
h3(strong("Original data"))), server = FALSE, rownames=FALSE,
options = list(bFilter=0, iDisplayLength=18,
columnDefs = list(list(className = 'dt-center', targets = '_all')),
dom = 'frtip'))
# Synthetic dataset
output$synth <- DT::renderDataTable(df,
caption = htmltools::tags$caption(
style = 'caption-side: top; text-align: left; color: black; font-size:140%',
h3(strong("Simulated synthetic data"))),
server = FALSE, rownames=FALSE, extensions = c("Buttons"),
options = list(iDisplayLength=18, bFilter=0,
columnDefs = list(list(className = 'dt-center', targets = '_all')),
dom = 'Bfrtip'))
}})
}
# Synthetic dataset with update for anon
observeEvent(input$update2, {
if(!is.null(input$datafile)){
output$synth <- DT::renderDataTable({
# Anonomise
df$ID <- sapply(input$anon, digest, algo = "crc32")
datatable(df,
caption = htmltools::tags$caption(
style = 'caption-side: top; text-align: left; color: black; font-size:140%',
h3(strong("Simulated synthetic data"))),
server = FALSE, rownames=FALSE, extensions = c("Buttons"),
options = list(iDisplayLength=18, bFilter=0,
columnDefs = list(list(className = 'dt-center', targets = '_all')),
dom = 'Bfrtip'))
})
}})
# Run the app ----
shinyApp(ui, server)
`
I have tried removing the update button ans using a reactive table, as well as other anonomise functions. I am completely stuck.

Save DT table with additional information (Shiny)

I was wondering if it is possible to save DT table content together with some additional information which is not part of the data frame/table like app version number, date of execution, sliderInput value etc.
Thank you!
Reprex below:
library(shiny)
library(DT)
ui <- fluidPage(
sidebarLayout(
sidebarPanel(
sliderInput(inputId = "range", "Set range", 1, 10, 5, 1)
),
mainPanel(
DT::dataTableOutput("table")
)
)
)
server <- function(input, output) {
dfr <- data.frame(var1 <- c(1,2,3),
var2 <- c(11, 22, 33))
output$table <- DT::renderDataTable(
datatable(dfr, extensions = 'Buttons',
class="cell-border stripe",
rownames = FALSE, colnames = c("var1", "var2"),
options = list(dom = "Blfrtip",
buttond = list("copy", list(extend = "collection",
buttons = c("csv", "excel", "pdf"),
text = "Download")), pageLength=10, autoWidth = TRUE,
searchHighlight = TRUE, filter = "top"))
)
}
shinyApp(ui = ui, server = server)
You could save the contents of the data frame and the other information in a list and then save the list.
Or, any R object can have attributes which are completely arbitrary and under your control. You could set attributes of the data frame to record the information you want.
Personally, I'd use the list approach, purely because I don't like attributes.
Here's a suggestion in response to OP's request below.
library(shiny)
library(DT)
ui <- fluidPage(
sidebarLayout(
sidebarPanel(
sliderInput(inputId = "range", "Set range", 1, 10, 5, 1),
actionButton("saveRds", "Save to Rds"),
actionButton("loadRds", "Load from Rds")
),
mainPanel(
DT::dataTableOutput("table"),
wellPanel(h4("Current data"), verbatimTextOutput("text")),
wellPanel(h4("File data"), verbatimTextOutput("loadedData"))
)
)
)
server <- function(input, output) {
dfr <- data.frame(var1 <- c(1,2,3),
var2 <- c(11, 22, 33))
output$table <- DT::renderDataTable(
datatable(dfr, extensions = 'Buttons',
class="cell-border stripe",
rownames = FALSE, colnames = c("var1", "var2"),
options = list(dom = "Blfrtip",
buttond = list("copy", list(extend = "collection",
buttons = c("csv", "excel", "pdf"),
text = "Download")), pageLength=10, autoWidth = TRUE,
searchHighlight = TRUE, filter = "top"))
)
listInfo <- reactive({
list("data"=dfr, "version"="WebApp Version 1.0", "runDate"=date(), "sliderValue"=input$range)
})
output$text <- renderPrint({
listInfo()
})
observeEvent(input$saveRds, {
saveRDS(listInfo(), "data.Rds")
})
fileData <- reactive({
req(input$loadRds)
readRDS("data.Rds")
})
output$loadedData <- renderPrint({
fileData()
})
}
shinyApp(ui = ui, server = server)
The way you implement "save to file" will depend on the file format: Excel files will clearly have different requirements to PDF files, for example. As a minimum effort demonstation, I've created "Save to Rds" and "Load from RDS" buttons in the sidebar and added a verbatimTextOutput to display the contents of the file when it's loaded. [I'm not sufficiently familiar with DT to know how to add the buttons in the table toolbar.]
OP's effort was pretty close: it's just that writing a list to CSV file takes a little more effort than just calling write.csv...

Wrong display - How to fit well a selectinput in a shinydashboard header and style it

I want to put a selectInput inside the dashboardHeaderPlus but this makes that the header extends itself out of bounds, messing even with the sidebar as it's shown in the image:
What it's intended to happen, is making the selectInput look like the Facebook search bar, which means centered without affecting the header and styled with a magnifying glass icon if it's possible. Just like this:
Image: Actual output / Intended output
library(shiny)
library(shinydashboard)
library(shinydashboardPlus)
library(shinyWidgets)
MenuProfesor <- function(){
selectInput(inputId = "Search",
label = NULL,
selected = FALSE,
multiple = FALSE,
choices = c('1','2','3','4'))
}
header <- dashboardHeaderPlus(
title = 'Planificación UAI',
enable_rightsidebar = FALSE,
left_menu = tagList( MenuProfesor())
)
ui <- dashboardPage(
header,
dashboardSidebar(),
dashboardBody()
)
server <- function(input, output, session) {
}
shinyApp(ui, server)
Does this work for you?:
library(shiny)
library(shinydashboard)
library(shinydashboardPlus)
library(shinyWidgets)
header <- dashboardHeaderPlus(
title = 'Planificación UAI',
tags$li(class = "dropdown",
tags$li(class = "dropdown", div(searchInput(
inputId = "search",
label = NULL,
placeholder = "Search...",
btnSearch = icon("search"),
btnReset = icon("remove"),
width = "100%"
), style= "width: 25%; margin-left: auto; margin-right: auto; margin-top:-43px; margin-bottom:-10px;"))),
enable_rightsidebar = FALSE,
fixed = TRUE
)
ui <- dashboardPage(
header,
dashboardSidebar(),
dashboardBody()
)
server <- function(input, output, session) {}
shinyApp(ui, server)
Result:
Also you might want to check this related question.

Popup list of selectInput is hiding behind navBarPage

Please consider below ShinyApp with navBarPage & selectInput.
shinyApp(
ui = fluidPage(
selectInput("variable", "Variable:",
c("Cylinders" = "cyl",
"Transmission" = "am",
"Gears" = "gear")),
navbarPage(title = "",
tabPanel("Scene 01",
fluidRow(tableOutput("data"))
),
tabPanel("Scene 02", fluidRow()))
),
server = function(input, output) {
output$data <- renderTable({
mtcars[, c("mpg", input$variable), drop = FALSE]
}, rownames = TRUE)
}
)
As you see, when the popup-baloon of selectInput opens (i.e. when User clicks on the drop-down icon of selectInput), it hides behind the strip of navBarPage. Is there any way to bring that popup-baloon forward, instead of hiding behind the navBarPage srip.
Appreciate for your help.
Thanks,
You can use css to make the z-index of selectinput dropdown more than that of nav-bar header using the following tag:
tags$div(tags$style(HTML( ".selectize-dropdown, .selectize-dropdown.form-control{z-index:10000;}")))
In your app it would be as follows:
shinyApp(
ui = fluidPage(
tags$div(tags$style(HTML( ".selectize-dropdown, .selectize-dropdown.form-control{z-index:10000;}"))),
selectInput("variable", "Variable:",
c("Cylinders" = "cyl",
"Transmission" = "am",
"Gears" = "gear")),
navbarPage(title = "",
tabPanel("Scene 01",
fluidRow(tableOutput("data"))
),
tabPanel("Scene 02", fluidRow()))
),
server = function(input, output) {
output$data <- renderTable({
mtcars[, c("mpg", input$variable), drop = FALSE]
}, rownames = TRUE)
}
)
You will get something like this:
Hope it helps!