I have this sample app to display and download dataTable. But it is also printing HTML script on top of the downloaded attachment. It is printing logo and title HTML but I also want to preserve them on the app.
library(shiny)
library(DT)
ui <- fluidPage(
titlePanel(title = tags$div(img(src = "test.jpg", width = 170, height = 115, align = "left"))),
titlePanel(title = tags$div(class = "header" , tags$p("Cars", tags$br(), tags$h4("MTCARS", style = "text-align: center; color:navy;"), style = "text-align: center; color:navy;"))),
dataTableOutput("table_output")
)
server <- function(input, output, session){
output$table_output <- renderDataTable(server=FALSE,{
DT::datatable(head(mtcars), extensions = c('Buttons'),
options = list(autoWidth = FALSE, dom = 'lfrtipB',
buttons = list(list(extend = "csv", text = "CSV", filename = "cars",
exportOptions = list(modifier = list(page = "all"))),
list(extend = "excel", text = "EXCEL", filename = "cars",
exportOptions = list(modifier = list(page = "all"))),
list(extend = "pdf", text = "PDF", filename = "cars",
exportOptions = list(modifier = list(page = "all")))
))) })
}
shinyApp(ui, server)
I had to change the UI function to get the proper attachment.
ui <- fluidPage(
img(src = "test.jpg", width = 170, height = 115, align = "left"),
tags$div(class = "header" , tags$h2("Cars", tags$br(), tags$h4("MTCARS", style = "text-align: center; color:navy;"), style = "text-align: center; color:navy;")),
dataTableOutput("table_output")
)
Related
sorry if this is repetitive and so simple it is annoying, but I am new to Shiny.
I need help with a shiny app I am trying to create for my golf game. I have loaded a CSV file with previous distance and accuracy observations to Rstudio and completed a script file with what will generally be done: data preprocessing and then visualizations.
I am now struggling with converting that to the app.R file, specifically, how to create a widget where I can add new numeric observations to the current data frame. The end goal is to use the app to log data as I play (practice or an actual round), which updates in real time for quick insight into the average distance and accuracy for each club.
Here is the very basic shiny code I have got to work for the numeric input:
`library(shiny)
# Define UI for application that draws a histogram
ui <- fluidPage(
titlePanel("Numeric Add Test"),
column(3,
numericInput("num",
h3("Numeric input"),
value = 1,
min = 50,
max = 400,
step = 25))
)
# Define server logic required to draw a histogram
server <- function(input, output) {
}
# Run the application
shinyApp(ui = ui, server = server)`
I have found ways to include an 'add' button to a list, but what I am hoping to do is have the new numeric input be added to the specified variable (club, distance, accuracy) in the referenced dataset. This action would change the existing data, but add to it and grow the dataset over time.
Not sure if this helps for context at all, but below is the script file for preprocessing and visuals I described above:
`######### Golf Data Practice for App #############
## Read in Data set and address the column names starting with a number
Golfdata <- data.frame(read_csv("Shiny Apps/Golf Dataset .csv"))
Golfdata <- as.data.frame(Golfdata)
#Drop the last two columns for only clubs. Then create shot bias DF as well.
Clubs <- Golfdata %>% select(-c(11,12))
ShotBias <- Golfdata %>% select(c(11,12))
#Visualize the Average club distance
##Convert the club df by summarizing each variable by its average,
## then use the gather() to convert to long instead of wide to finally
## prepare the df for visualizing.
ClubAverage <- Clubs %>% summarise_all(mean) %>% gather(ClubAverage) %>%
mutate_if(is.numeric, round, digits = 0)
library(ggplot2)
value <- ClubAverage$value
ggplot(ClubAverage) +
aes(x = fct_reorder(ClubAverage, value, .desc = TRUE), y = value, label = value,
color = ClubAverage) +
geom_col( show.legend = FALSE, fill = "white") +
geom_text(nudge_y = 10, color = "black", size=4, fontface = "bold") +
labs(x = "Club",
y = "Yards", title = "Average Club Distance") +
theme(panel.background = element_rect(fill="forestgreen"),
panel.grid.major.x = element_blank(),
panel.grid.major = element_line(color = "yellow"),
panel.grid.minor = element_line(color = "yellow1")) +
theme(plot.title = element_text(size = 24L,
face = "bold", hjust = 0.5), axis.title.y = element_text(size = 18L, face = "bold"), axis.title.x =
element_text(size = 18L,
face = "bold"))
## Visualize the Average Accuracy ##
## This time, summarize the columns by their mean,
## but keep as wide -- no gather() function needed.
AverageShotBias <- ShotBias %>% summarise_all(mean)
ggplot(AverageShotBias) +
aes(x = Accuracy.Bias, y = Distance.Bias) +
geom_point(shape = "circle filled",
size = 18L, fill = "yellow") +
labs(x = "Accuracy", y = "Distance", title = "Average Shot Bias") +
theme(panel.background = element_rect(fill="forestgreen")) +
theme(plot.title = element_text(size = 24L, face = "bold", hjust = 0.5), axis.title.y =
element_text(size = 14L,
face = "bold"), axis.title.x = element_text(size = 14L, face = "bold")) +
xlim(-1, 1) +
ylim(-1, 1) +
geom_hline(yintercept = 0, size=1) +
geom_vline(xintercept = 0, size=1)`
Something I have found regarding the add button is the code here:
` ,actionButton('add','add')
,verbatimTextOutput('list')
)`
This does create an add button, which after updating the server code does create a list of added inputs, however I would like to be able to adjust the code for adding the observation to the variables in the data set.
I assume I would create an add button for each variable, just need to understand better how to do that.
The structure of your data used in the plot is not clear, but this is how to get the inputs or update dataset using eventReactive or observeEvent in the server. you can read this to learn the difference
server <- function(input, output) {
distance <- eventReactive(input$addButton, {
input$distInput
}, ignoreInit = T, ignoreNULL = F)
accbias <- eventReactive(input$accBiasButton, {
input$accslider
})
distbias <- eventReactive(input$DistBiasButton, {
input$distslider
}, ignoreNULL=F)
output$plot1 <- renderPlot({
input$distInput
mydist <- distance()
# plot
})
output$plot2 <- renderPlot({
input$distInput # use the inputs here
mydist <- distance() # or the reactives
})
}
the two output plots in your code have the same outputId
Follow UP to my Question: I have written the code for the ui, now I am still trying to figure out how to code the server properly so the distance and accuracy numeric inputs can be added to a data frame. That data frame will then be used to create the two visuals.
library(shiny)
library(gridlayout)
library(DT)
library(tidyverse)
ui <- grid_page(
layout = c(
"title title title",
"h1 h2 h3 ",
"h4 h4 h5 "
),
row_sizes = c(
"100px",
"0.86fr",
"1.14fr"
),
col_sizes = c(
"250px",
"0.71fr",
"1.29fr"
),
gap_size = "1rem",
grid_card_text(
area = "title",
content = "My Golf Data",
alignment = "center",
is_title = FALSE
),
grid_card(
area = "h2",
title = "Distance Input",
numericInput(
inputId = "distInput",
label = "Distance",
value = 50L,
min = 50L,
max = 400L,
step = 15L
),
actionButton(
inputId = "addButton",
label = "Add",
width = "100%"
)
),
grid_card(
area = "h1",
title = "Club Select",
radioButtons(
inputId = "clubRadiobuttons",
label = "",
choices = list(
Driver = "D",
`5Wood` = "5W",
`4H` = "4H",
`5I` = "5I",
`6I` = "6I",
`7I` = "7I",
`8I` = "8I",
`9I` = "9I",
PW = "PW",
SW = "SW"
),
width = "100%"
)
),
grid_card(
area = "h3",
title = "Accuracy",
sliderInput(
inputId = "accslider",
label = "Accuracy Bias",
min = -1L,
max = 1L,
value = 0L,
width = "98%",
step = 1L
),
actionButton(
inputId = "accBiasButton",
label = "Add Acc Bias",
width = "100%"
),
sliderInput(
inputId = "distslider",
label = "Distance Bias",
min = -1L,
max = 1L,
value = 0L,
width = "100%",
step = 1L
),
actionButton(
inputId = "DistBiasButton",
label = "Add Dist Bias",
width = "100%"
)
),
grid_card(
area = "h5",
title = "Average Club Distance",
plotOutput(
outputId = "plot",
width = "100%",
height = "400px"
)
),
grid_card(
area = "h4",
title = "Accuracy Average",
plotOutput(
outputId = "plot",
width = "100%",
height = "400px"
)
)
)
server <- function(input, output) {
}
shinyApp(ui, server)
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.
I am trying to build a shiny app with shinyMobile, and storing the results using shinyStore, I have been looking at several answers but I haven't been able to fix this. I think there might be an issue with the multiple option.
Here is the code:
library(shiny)
library(shinyMobile)
library(shinyStore)
Species_List <- structure(list(Scientific_name = c("Juncus alpinoarticulatus ssp. nodulosus",
"Diphasiastrum complanatum ssp. complana-tum", "Rubus macrophyllus",
"Equisetum scirpoides", "Trifolium hybridum ssp. hybridum", "Narthecium ossifragum",
"Peucedanum oreoselinum", "Sonchus oleraceus", "Juncus subnodulosus",
"Minuartia viscosa"), Danish_name = c("siv, stilk-", "ulvefod, flad",
"brombær, storbladet", "padderok, tråd-", "kløver, alsike-",
"benbræk", "svovlrod, bakke-", "svinemælk, almindelig", "siv, butblomstret",
"norel, klæbrig")), row.names = c(NA, -10L), class = "data.frame")
shinyApp(
ui = f7Page(
title = "Species app",
f7SingleLayout(
navbar = f7Navbar(
title = "Select Species",
hairline = TRUE,
shadow = TRUE
),
toolbar = f7Toolbar(
position = "bottom",
f7Link(label = "Link 1", href = "https://www.google.com"),
f7Link(label = "Link 2", href = "https://www.google.com")
),
initStore("store", "shinyStore-ex1"),
# A button to save current input to local storage
actionButton("save", "Save", icon("save")),
# A button to clear the input values and local storage
actionButton("clear", "Clear", icon("stop")),
# main content
f7Shadow(
intensity = 16,
hover = TRUE,
f7SmartSelect(inputId = "SpeciesListSc",
label = "Select all species",
multiple = TRUE,
choices = unique(Species_List$Scientific_name),
virtualList = T,
openIn = "sheet")
)
)
),
server = function(input, output, session) {
observe({
if (input$save <= 0){
updateF7SmartSelect(session, inputId = "SpeciesListSc", selected = isolate(input$store)$SpeciesListSc, choices = unique(Species_List$Scientific_name), multiple = TRUE)
}
})
observe({
if (input$save > 0){
updateStore(session, name = "SpeciesListSc", isolate(input$SpeciesListSc))
}
})
}
)
I was trying to implement a bootstrap5 carousel in a Shiny App. Unfortunately any output (text, table, ..) will not render in any slide expect from the first one. Is there a workaround to make this actually work?
library(shiny)
ui = fluidPage(theme = bs_theme(version = 5),
div(id="carouselExampleIndicators", class="carousel slide", `data-bs-ride`="carousel",
div(class="carousel-indicators",
tags$button(`data-bs-target`="#carouselExampleIndicators", `data-bs-slide-to`="0", class="active", `aria-current`="true", `aria-label`="Slide 1"),
tags$button(`data-bs-target`="#carouselExampleIndicators", `data-bs-slide-to`="1", `aria-label`="Slide 2")),
div(class = "carousel-inner",
div(class = "carousel-item active",
div(textOutput(outputId = "txt1"), style = "display: flex; justify-content: center;")),
div(class = "carousel-item",
div(textOutput(outputId = "txt2"),style = "display: flex; justify-content: center;"))),
tags$button(class="carousel-control-prev", `data-bs-target` = "#carouselExampleIndicators", `data-bs-slide`="prev",
span(class="carousel-control-prev-icon", `aria-hidden` = "true"),
span("prev", class="visually-hidden")),
tags$button(class="carousel-control-next", `data-bs-target` = "#carouselExampleIndicators", `data-bs-slide`="next",
span(class="carousel-control-next-icon", `aria-hidden` = "true"),
span(class="visually-hidden")))
)
server = function(input, output, session){
output$txt1 = renderText({
"displayed"
})
output$txt2 = renderText({
"not displayed"
})
}
shinyApp(ui, server)
I want to fetch user choice from selectInput and store it as a string to be use as filename to save a plot. If user change selectInput choice, the string variable should also update to reflect change.
Here are my code so far and the xxx variable obviously is not a string. Can anyone assist?
pacman::p_load(dplyr, tidyverse, reshape, ggplot2, shiny, shinydashboard)
mtcars_colName <- colnames(mtcars)
x_coord <- mtcars_colName[c(1:2)]
y_coord <- mtcars_colName[c(3:7)]
#Put plots on shiny ui
ui <- dashboardPage(
dashboardHeader(title = 'mtcars data'),
dashboardSidebar(
sidebarMenu(
menuItem("mtcars data comparison", tabName = 'mtcars_data_comparison', icon = icon('dragon'))
)
),
dashboardBody(
tabItems(
tabItem('mtcars_data_comparison',
fluidPage(
downloadButton("downloadPlot", "Download mtcars plot"),
box(plotOutput('metrics_plot'), width = 8, height = '100%'),
box(selectInput('y_metrics', 'mtcars y-axis', choices = y_coord), width = 4),
box(selectInput('x_metrics', 'mtcars x-axis', choices = x_coord), width = 4)
),
)
)
)
)
server <- function(input, output, session){
mtcars_plot <- reactive({ggplot(mtcars, aes_string(x=input$x_metrics, y=input$y_metrics)) +
geom_jitter(width =0.05) +
scale_y_continuous(labels = scales::comma) +
theme(
axis.text.x = element_blank(),
axis.line = element_line(),
axis.ticks.x = element_blank(),
panel.grid.major = element_blank(),
panel.grid.minor = element_blank(),
panel.border = element_blank(),
panel.background = element_blank())
})
output$metrics_plot <- renderPlot({
mtcars_plot()
})
rv <- reactiveValues(value_store = character())
observeEvent(input$y_metrics, {
rv$value_store <- input$y_metrics
})
output$download10XPlot <- downloadHandler(
file = paste(rv$value_store, '.pdf', sep=''),
content = function(file) {
sep <- switch(input$filetype, "csv" = ",", "tsv" = "\t")
# pdf(file = file, width = 11, height = 8.5)
pdf(file, sep = sep)
print(TenX_plot())
dev.off()}
)
}
shinyApp(ui, server)
We can try
output$download10XPlot <- downloadHandler(
file = function() {paste(isolate(input$y_seq_metrics), '.pdf', sep='')},
content = function(file) {
pdf(file = file, width = 11, height = 8.5)
print(TenX_plot())
dev.off()}
)