Goal:
In my app, the user is supposed to upload a .csv file. If a file other than .csv is uploaded, a warning message (showFeedbackWarning()) should appear around the the fileInput() widget. If the user corrects his input and uploads a .csv file, the message should disappear again (hideFeedback()).
All this already works in the app. But now I would like to change the colour of the progress bar in fileInput() to another colour for example red (like in this example). However, the warning message should still appear in its default colour orange.
Problem:
shinyFeedback overwrites my custom CSS and the colour of the progress bar is not changed. I can of course use !important, but then the colour of the bar in the warning message also turns red and I don't want this.
Do any of you know how to solve this problem?
Reprex:
library(shiny)
library(shinyFeedback)
ui <- fluidPage(
useShinyFeedback(),
fileInput(
inputId = "upload",
label = "Upload file:",
accept = ".csv"
),
tags$style(".progress-bar {
background-color: red;
}"),
verbatimTextOutput("text")
)
server <- function(input, output, session) {
data_in <- reactive({
req(input$upload)
ext <- tools::file_ext(input$upload$name)
if (ext == "csv") {
hideFeedback("upload")
read.delim(
input$upload$datapath,
sep = ";"
)
} else {
showFeedbackWarning(
inputId = "upload"
)
}
})
output$text <- renderPrint({
class(data_in())
})
}
shinyApp(ui, server)
We can use shinyjs to change the color dynamically:
library(shiny)
library(shinyjs)
library(shinyFeedback)
ui <- fluidPage(
useShinyFeedback(),
useShinyjs(),
fileInput(
inputId = "upload",
label = "Upload file:",
accept = ".csv"
),
# tags$style(".progress-bar {
# background-color: blue;
# }"),
verbatimTextOutput("text")
)
server <- function(input, output, session) {
data_in <- reactive({
req(input$upload)
ext <- tools::file_ext(input$upload$name)
if (ext == "csv") {
hideFeedback("upload")
runjs('document.querySelector("#upload_progress > div").style.setProperty("background-color", "green", "important");')
read.delim(
input$upload$datapath,
sep = ";"
)
} else {
showFeedbackWarning(
inputId = "upload",
color = "red"
)
}
})
output$text <- renderPrint({
class(data_in())
})
}
shinyApp(ui, server)
Related
Let's say I have 4 sets of UI/Server modules in 4 different directories ("./X1/Y1/", "./X1/Y2/", "./X2/Y1/", "./X2/Y2/"). I want to load the selected set based on the input in the sidebar.
I tried using source() within dashboardBody(), but I was not successful.
library(shiny)
library(shinydashboard)
# path to modules
in_path <- "C:/a/b/c/"
# ui
ui <- dashboardPage(
dashboardHeader(title = "test"),
dashboardSidebar(
br(),
selectInput('f1', 'Folder 1', choices = c("X1", "X2")),
helpText(""),
selectInput('f2', 'Folder 2', choices = c("Y1", "Y2")),
br(),
actionButton("load", "Load", icon("thumbs-up"), width = "85%")
),
dashboardBody(
# UI module here from, e.g., "C:/a/b/c/X1/Y2/my_UI.R"
)
)
# server
server <- function(input, output, session) {
# server module here from, e.g., "C:/a/b/c/X1/Y2/my_Server.R"
}
shinyApp(ui, server)
As shiny modules are simply functions, I'd source them in the beginning, and use uiOutput to display the differnt modules.
Here's a working example of the general idea (sample module code proudly stolen from the official Shiny documentation):
<mod1.R>
counterButton <- function(id, label = "Counter") {
ns <- NS(id)
tagList(
actionButton(ns("button"), label = label),
verbatimTextOutput(ns("out"))
)
}
counterServer <- function(id) {
moduleServer(
id,
function(input, output, session) {
count <- reactiveVal(0)
observeEvent(input$button, {
count(count() + 1)
})
output$out <- renderText({
count()
})
count
}
)
}
<mod2.R>
csvFileUI <- function(id, label = "CSV file") {
ns <- NS(id)
tagList(
fileInput(ns("file"), label),
checkboxInput(ns("heading"), "Has heading"),
selectInput(ns("quote"), "Quote", c(
"None" = "",
"Double quote" = "\"",
"Single quote" = "'"
))
)
}
csvFileServer <- function(id, stringsAsFactors = TRUE) {
moduleServer(
id,
## Below is the module function
function(input, output, session) {
# The selected file, if any
userFile <- reactive({
# If no file is selected, don't do anything
validate(need(input$file, message = FALSE))
input$file
})
# The user's data, parsed into a data frame
dataframe <- reactive({
read.csv(userFile()$datapath,
header = input$heading,
quote = input$quote,
stringsAsFactors = stringsAsFactors)
})
# We can run observers in here if we want to
observe({
msg <- sprintf("File %s was uploaded", userFile()$name)
cat(msg, "\n")
})
# Return the reactive that yields the data frame
return(dataframe)
}
)
}
<app.R>
library(shiny)
source("mod1.R")
source("mod2.R")
my_mods <- list("Counter Button" = list(ui = counterButton,
server = counterServer),
"CSV Uploader" = list(ui = csvFileUI ,
server = csvFileServer))
ui <- fluidPage(
sidebarLayout(
sidebarPanel(
selectInput("mod_sel",
"Which Module should be loaded?",
names(my_mods))
),
mainPanel(
uiOutput("content"),
verbatimTextOutput("out")
)
)
)
server <- function(input, output) {
uuid <- 1
handler <- reactiveVal()
output$content <- renderUI({
my_mods[[req(input$mod_sel)]]$ui(paste0("mod", uuid))
})
observeEvent(input$mod_sel, {
handler(my_mods[[req(input$mod_sel)]]$server(paste0("mod", uuid)))
uuid <<- uuid + 1
})
output$out <- renderPrint(req(handler())())
}
shinyApp(ui, server)
Some Explanation
You put the module code in mod[12].R and it is rather straight forward.
In your main app, you load both(!) source files and for housekeeping reasons, I put both modules functions (ui and server) in a list, but this is not strictly necessary, but facilitates future extension.
In your UI you have an uiOutput which renders dynamically according to the selected module.
In your server you put the code to dynamically render the UI and call the respective server function.
The uid construct is basically there to force a fresh render, whenever you change the selection. Otherwise, you may see still some old values whenever you come back to a module which you have rendered already.
I have this shiny app. The main aim is to upload excel sheet with data and plot some graphs in tabs. User is able to select a sheet to make the graph. The seet will render to observe the selected data. This works well.
But I am struggling to manipulate with input data to make the graph.
I tried to use reactive value named data and then make the graph from that. I am quite new with shiny apps.
library(shiny)
library(readxl)
library(dplyr)
library(tidyverse)
library(lubridate)
ui <- fluidPage(
titlePanel("OTD project update"),
sidebarPanel(
fileInput('file1', 'Insert File', accept = c(".xlsx")),
textInput('file1sheet','Name of Sheet (Case-Sensitive)')),
mainPanel(tabsetPanel(
type = "tabs",
tabPanel("Data", tableOutput("value")),
tabPanel("OTD", plotOutput("OTD"))
)
)
)
server <- function(input, output) {
sheets_name <- reactive({
if (!is.null(input$file1)) {
return(excel_sheets(path = input$file1$datapath))
} else {
return(NULL)
}
})
output$value <- renderTable({
if (!is.null(input$file1) &&
(input$file1sheet %in% sheets_name())) {
return(read_excel(input$file1$datapath,
sheet = input$file1sheet))
} else {
return(NULL)
}
})
data <- reactive({
if (!is.null(input$file1) &&
(input$file1sheet %in% sheets_name())) {
return(read_excel(input$datapath,
sheet = input$file1sheet))
} else {
return(NULL)
}
})
}
shinyApp(ui, server)
It may be better to use the sheet names in radio buttons to pick instead of typing it. Also, there was a typo. Try this
library(shiny)
library(readxl)
library(dplyr)
library(tidyverse)
library(lubridate)
library(DT)
ui <- fluidPage(
titlePanel("OTD project update"),
sidebarPanel(
fileInput('file1', 'Insert File', accept = c(".xlsx")),
#textInput('file1sheet','Name of Sheet (Case-Sensitive)')
uiOutput("sheet")
),
mainPanel(tabsetPanel(
type = "tabs",
tabPanel("Data", DTOutput("table")),
tabPanel("OTD", plotOutput("plot"))
)
)
)
server <- function(input, output) {
sheets_name <- reactive({
if (!is.null(input$file1)) {
return(excel_sheets(path = input$file1$datapath))
} else {
return(NULL)
}
})
data <- reactive({
req(sheets_name())
if (!is.null(input$file1)) {
return(read_excel(input$file1$datapath, sheet = input$mysheet))
} else {
return(NULL)
}
})
output$sheet <- renderUI({
req(sheets_name())
radioButtons("mysheet", "Select a Sheet", choices = sheets_name())
})
output$table <- renderDT(data())
output$plot <- renderPlot({plot(cars)})
}
shinyApp(ui, server)
I want to change colour of the actionLink once it is clicked. I could not find any post which will achieve this.
What I found:
R Shiny toggle text of actionLink
shiny module: update color of button
But these were of no help. Here is the sample code from the answer from the first link (by #Julien Navarre)
library(shiny)
library(shinyjs)
shinyApp(
ui = shinyUI(
fluidPage(useShinyjs(),
actionLink("button", "Show additional"),
hidden(div(id='text_div', verbatimTextOutput("text")))
)
),
server = function(input, output, session){
observeEvent(input$button, {
toggle('text_div')
output$text <- renderText({"Additional"})
if (input$button %% 2 == 1) {
txt <- "Hide Additional"
} else {
txt <- "Show Additional"
}
updateActionButton(session, "button", label = txt)
})
}
)
In this code, once the label is changed, the colour of the label should also change. For example, Show Additional link should have a green colour, whereas Hide Additional should have red colour.
I tried updateactionLink with color argument but there is no such argument.
How can I achieve this?
One way would be to use css and addClass, removeClass from {shinyjs}:
library(shiny)
library(shinyjs)
shinyApp(
ui = shinyUI(
fluidPage(useShinyjs(),
tags$head(
tags$style(HTML("
a.action-button {
color: #00ff00;
}
a.action-button.red {
color: #ff0000;
}"))
),
actionLink("button", "Show additional"),
hidden(div(id='text_div', verbatimTextOutput("text")))
)
),
server = function(input, output, session){
observeEvent(input$button, {
if (input$button %% 2 == 1) {
txt <- "Hide Additional"
shinyjs::addClass("button", "red")
} else {
txt <- "Show Additional"
shinyjs::removeClass("button", "red")
}
toggle('text_div')
output$text <- renderText({"Additional"})
updateActionButton(session, "button", label = txt)
})
}
)
I have a simple shiny app in which I need to upload a csv and then I should be able to reset it by clicking the action button. If there is no file an error message should be displayed. The issue is that this error message is not displayed after clicking the reset button.
library(shiny)
library(shinyjs)
library(tidyverse)
ui <- fluidPage(
sidebarLayout(
sidebarPanel(
useShinyjs(),
fileInput('inFile', 'Choose 1st file'),
tags$hr(),
actionButton('reset', 'Reset')
),
mainPanel(
textOutput("choose")
)
)
)
server <- function(input, output, session) {
rv <- reactiveValues(
data = NULL,
clear = FALSE
)
########1st
observe({
req(input$inFile)
req(!rv$clear)
rv$data <- read.csv(input$inFile$datapath,header = T)
})
observeEvent(input$inFile, {
rv$clear <- FALSE
}, priority = 1000)
observeEvent(input$reset, {
rv$data <- NULL
rv$clear <- TRUE
reset('inFile')
}, priority = 1000)
output$choose <- reactive({
if(is.null(input$inFile))
{
"You must upload 1st csv at least"
}
else
{
"Now we can process the data!"
}
})
}
shinyApp(ui, server)
Just a little typo on line 49.
This line
if(is.null(input$inFile))
should be
if(is.null(rv$data))
I want to be able to upload multiple images with file input and display the single image selected in the UI
ui.R
library(shiny)
ui <- fluidPage(
sidebarLayout(
sidebarPanel(
fileInput("file","Upload the file", multiple = TRUE), # fileinput() function is used to get the file upload contorl option
uiOutput("selectfile")
),
mainPanel(
uiOutput('images')
)
)
)
server.R
server <- function(input,output) {
## Side bar select input widget coming through renderUI()
# Following code displays the select input widget with the list of file loaded by the user
output$selectfile <- renderUI({
if(is.null(input$file)) {return()}
list(hr(),
helpText("Select the files for which you need to see data and summary stats"),
selectInput("Select", "Select", choices=input$file$name)
)
})
output$images <- renderImage({
if(is.null(input$file)) {return(NULL)}
for (i in 1:nrow(input$file))
{
if(input$file$name[i] == input$Select){
list(src=input$file$datapath[i],
alt= "error")
print(input$file$name[i])
print(input$file$datapath[i])
}
}
})
}
With this solution, the prints of the datapath and the name shows me the right answer but i keep getting the same error after trying to render the image: "Warning: Error in basename: a character vector argument expected".
Here is a solution using base64 encoding.
library(shiny)
library(base64enc)
ui <- fluidPage(
sidebarLayout(
sidebarPanel(
fileInput("file", "Upload the file", multiple = TRUE),
uiOutput("selectfile")
),
mainPanel(
uiOutput('image')
)
)
)
server <- function(input,output) {
output$selectfile <- renderUI({
req(input$file)
list(hr(),
helpText("Select the files for which you need to see data and summary stats"),
selectInput("Select", "Select", choices=input$file$name)
)
})
output$image <- renderUI({
req(input$Select)
i <- which(input$file$name == input$Select)
if(length(i)){
base64 <- dataURI(file = input$file$datapath[i], mime = input$file$type[i])
tags$img(src = base64, alt= "error")
}
})
}
shinyApp(ui, server)