Read only indicator in Shiny? - r

I have an existing Shiny script with standard widgets from the Shiny library. Now I wish to add something to show temperature on a graphical scale? This would be a read-only value, so it wouldn't make sense to use a slider unless the slider can be locked and only changed programatically. Is that possible? If not, what are other suggestions?
To clarify:
Is it possible to have a Shiny slider as read only. The user can not slide it but it can be programmatically changed. Here is a Shiny slider:
library(shiny)
ui <- fluidPage(
sliderInput("aa", "Temp",
min = -20, max = 20,
value = 10, step = 10)
)
server <- function(input, output) { }
shinyApp(ui, server)
I'm not familiar with Shiny Dashboard but I saw taskItem. Can these be "dropped in" and used with a normal Shiny app that uses fluidPage, sidebarPanel, mainPanel? How does one remove the bullet point and the percentage? Here is an example of a taskItem.
library(shiny)
library(shinydashboard)
ui <- dashboardPage(
dashboardHeader(),
dashboardSidebar(),
dashboardBody(
taskItem(value = temp <- 89, color = "red",
"Temp"
))
)
server <- function(input, output) { }
temp <- 89
shinyApp(ui, server)

AFAIK, sliderInput cannot be used as an output. However here's a potential solution using progressBar from shinyWidgets package
library(shiny)
library(shinyWidgets)
ui <- fluidPage(
sidebarLayout(
sidebarPanel(
h3("Sidebar")
),
mainPanel(
br(), br(), br(),
progressBar("tempbar", value = 0, title = "Temperature", status = "danger")
)
)
)
server <- function(input, output, session) {
temp <- 89
updateProgressBar(session, id = "tempbar", value = temp)
}
shinyApp(ui, server)
shiny app with temperature bar
Replace temp in server with whatever calculated value you might have. For fixed temperature value just set it in ui, no need to use updateProgressBar. By default progressBar is scaled from 0-100. To modify see documentation for it.

You can use updateSliderInput to achieve such an behaviour. Couple this with shinyjs::disabled and you get what you want. I would however look for a less hackish solution:
library(shiny)
library(shinyjs)
ui <- fluidPage(
## add style to remove the opacity effect of disabled elements
tags$head(
tags$style(HTML("
.irs-disabled {
opacity: 1
}")
)
),
useShinyjs(),
disabled(sliderInput("aa", "Temp",
min = -20, max = 20,
value = 10, step = 10)),
actionButton("Change", "Change")
)
server <- function(input, output, session) {
observeEvent(input$Change, {
new_temp <- sample(seq(-20, 20, 10), 1)
updateSliderInput(session, "aa", value = new_temp)
})
}
shinyApp(ui, server)

Related

How to add a currency sign in a numericinput

Is there a way to have a £ sign inside a numeric input box? So that when someone enters a number it is automatically in currency format. if anyone has a solution or can point me in the right direction much appreciated.
Have tried to look for examples online, have only found one thing that uses the paste function but that was for a valueBox function which I have tried and failed to incorporate into this problem.
library(shiny)
ui <- fluidPage(
fluidRow(
numericInput("Selectcost", "Enter the cost", value = "", step= 0.01, min= 0, max= 50)
))
server <- function(input, output) {
}
shinyApp(ui = ui, server = server)
An option could be to use the shinyWidgets package :
library(shiny)
library(shinyWidgets)
ui <- fluidPage(
fluidRow(
shinyWidgets::numericInputIcon("Selectcost",
"Enter the cost",
value = "",
step= 0.01,
min= 0,
max= 50,
icon = list(NULL, icon("pound-sign")))
))
server <- function(input, output) {
}
shinyApp(ui = ui, server = server)
The shinyWidgets package has a great new function (added as of version 0.5.4, also a disclaimer, I added it via a pull request), autonumericInput that will allow you to do just this. It is based on the javascript library autonumeric. There are a lot of options to the function, but the documentation is extensive and for simple uses most can be ignored.
What you are trying to do can be accomplished as follows:
library(shiny)
library(shinyWidgets)
ui <- fluidPage(
h1("Autonumeric Input Example"),
shinyWidgets::autonumericInput(
inputId = "cost",
label = "Enter the cost",
value = 100,
currencySymbol = "£",
currencySymbolPlacement = "p",
decimalPlaces = 2
),
verbatimTextOutput("res1")
)
server <- function(input, output) {
output$res1 <- renderText(input$cost)
}
shinyApp(ui = ui, server = server)
which results in:
sample output from the above code chunk
Hopefully this is useful!

Unable to lift state in Shiny

I am trying to lift state of the number of bins one level up from a module. This is a common technique in react, and I suspect shiny as well, when some data needs to be shared between different components (modules in shiny parlance)
This is the code I currently have
ui.R
library(shiny)
library(shinydashboard)
source("modules/my.R", local=my <- new.env())
ui <- dashboardPage(
dashboardHeader(title="Dashboard"),
dashboardSidebar(
sidebarMenu(
menuItem("App 1", tabName="app1"),
menuItem("App 2", tabName="app2"),
id="selectedMenu"
)
),
dashboardBody(
uiOutput("foo")
)
)
server.R
library(shiny)
source("modules/my.R", local=my <- new.env())
server <- function(input, output) {
reactive = reactive({3})
callModule(my$my, "foo", numBins=reactive)
plot <- my$myUI("foo")
output$foo <- renderUI({
if (input$selectedMenu == "app1") {
return(plot)
} else {
return(br())
}
})
}
and this is the module
library(shiny)
myUI <- function(id) {
ns <- NS(id)
tagList(
fluidRow(
box(
plotOutput(outputId = ns("distPlot")),
width=12
)
),
fluidRow(
box(
sliderInput(inputId = ns("bins"), label = "Number of bins:", min = 1, max = 50, value = 30),
width=12
)
)
)
}
my <- function(input, output, session, numBins) {
output$distPlot <- renderPlot({
numBins()
x <- faithful$waiting
bins <- seq(min(x), max(x), length.out = numBins() + 1)
hist(x, breaks = bins, col = "#75AADB", border = "white",
xlab = "Waiting time to next eruption (in mins)",
main = "Histogram of waiting times")
})
observe({
updateSliderInput(session, "bins", value=numBins())
})
}
I am trying to lift numBins out at the server.R level, and inject it in the module. However, it seems that the plot is not re-rendered. Initialisation seems to work however. I get the right number of bins, but moving the slider does nothing.
Please feel free to comment on other things that look dodgy. I am just a beginner with shiny and R (I do however have experience with react)
Edit
I have a simpler version with just two sliders, trying to make one change when the other is moved, by having numBins shared between the two from below.
library(shiny)
library(shinydashboard)
source("modules/my.R", local=my <- new.env())
ui <- dashboardPage(
dashboardHeader(title="Dashboard"),
dashboardSidebar(),
dashboardBody(
uiOutput("central")
)
)
library(shiny)
source("modules/my.R", local=my <- new.env())
server <- function(input, output) {
numBins = reactiveVal(value=3)
callModule(my$my, "slider1", id="slider1", numBins=numBins)
callModule(my$my, "slider2", id="slider2", numBins=numBins)
output$central <- renderUI({
tagList(
my$myUI("slider1"),
my$myUI("slider2")
)})
}
library(shiny)
myUI <- function(id) {
ns <- NS(id)
fluidRow(
box(
sliderInput(inputId = ns("bins"), label = "Number of bins:", min = 1, max = 50, value = 30),
width=12
)
)
}
my <- function(input, output, session, id, numBins) {
ns <- NS(id)
observeEvent(
numBins,
{
cat("1234", file=stderr())
updateSliderInput(session, ns("bins"), value=numBins())
})
}
Still not working and kind of ugly to have to provide the id twice for the server function.
I'm trying to answer your edited example with two synced sliders. My solution is to let the module return the value of the sliderInput, and also receive an input coupledValue which is used in in observeEvent to update the sliderInput value.
my.R
Somewhat counterintuitively (at least to me when I first learned about it), you do not need to wrap the id "bins" into an ns() inside the updateSliderInput().
library(shiny)
myUI <- function(id) {
ns <- NS(id)
fluidRow(
box(
sliderInput(inputId = ns("bins"), label = "Number of bins:", min = 1, max = 50, value = 30),
width=12
)
)
}
my <- function(input, output, session, id, coupledValue) {
observeEvent(coupledValue(), {
updateSliderInput(session, "bins", value=coupledValue())
})
return(reactive(input$bins))
}
server.R
The numBins() reactive becomes unnecessary, as well as the additional environment you provided within source().
library(shiny)
source("modules/my.R")
server <- function(input, output) {
valSlider1 <- callModule(my, "slider1", id="slider1", coupledValue = valSlider2)
valSlider2 <- callModule(my, "slider2", id="slider2", coupledValue = valSlider1)
}
ui.R
library(shiny)
library(shinydashboard)
source("modules/my.R")
ui <- dashboardPage(
dashboardHeader(title="Dashboard"),
dashboardSidebar(),
dashboardBody(
myUI("slider1"),
myUI("slider2")
)
)
If you want to sync to multiple inputs, you can use return(list(input1 = ..., input2 = ...)) as your return value from the module. When you pass that whole named list into another module, e.g. with the name coupledValues, you will have to reference it as coupledValues$input1() and coupledValues$input2() (note the () after the $).
Discalimer: This answer is based on In sync sliderInput and textInput
I am not sure if this is the best use case for shiny modules. Anyways, here's a way without using modules. Let me know if using modules is a must and I'll try and update my answer.
library(shiny)
ui <- fluidPage(
lapply(1:2, function(x) {
sliderInput(paste0("slider", x), paste0("Slider ", x), min = 1, max = 50, value = 30)
}),
verbatimTextOutput("test")
)
server <- function(input, output, session) {
observeEvent(input$slider1, {
if(input$slider1 != input$slider2) {
updateSliderInput(session, "slider2", value = input$slider1)
}
})
observeEvent(input$slider2, {
if(input$slider1 != input$slider2) {
updateSliderInput(session, "slider1", value = input$slider2)
}
})
output$test <- renderPrint({
c("Slider 1" = input$slider1, "Slider 2" = input$slider2)
})
}
shinyApp(ui, server)
Using return works nice for smaller applications, though using a strategy of reactiveValues pays of in larger apps.
I found the strategy in a blog post by rTask Communication between modules and its whims
The idea is to use r as a reactiveValues and pass it to each callModule.
Inside the module, you create a new reactiveValues based on r, e.g. r$my <- reactiveValues()
Then you don't need to return your module output and you don't need to pass any reactive variable except for r
Here I edited your code according to this strategy (and a few minor things, posted already):
ui.R
library(shiny)
library(shinydashboard)
source("modules/my.R")
ui <- dashboardPage(
dashboardHeader(title="Dashboard"),
dashboardSidebar(),
dashboardBody(
myUI("slider1"),
myUI("slider2")
)
)
server.R
library(shiny)
source("modules/my.R")
server <- function(input, output) {
r <- reactiveValues()
numBins = reactiveVal(value=3)
callModule(my, "slider1", id="slider1", r = r)
callModule(my, "slider2", id="slider2", r = r)
}
my.R
library(shiny)
myUI <- function(id) {
ns <- NS(id)
fluidRow(
box(
sliderInput(inputId = ns("bins"), label = "Number of bins:", min = 1, max = 50, value = 30),
width=12
)
)
}
my <- function(input, output, session, id, r) {
r$my <- reactiveValues()
observe({
r$my <- input$bins
})
observeEvent(
r$my,
{
cat("1234", file=stderr())
updateSliderInput(session, "bins", value=r$my)
})
}
Slightly too late to compete for the bounty. But as I have done the thinking, here is my contribution. This differs from all the existing answers in that it neither uses coupled sliders, nor observers.
First let me ensure I understand your intent: You want to pass the number of bins from the slider in the sub-module, back to the parent module, before passing it from the parent module into the output calculation of the (same) sub-module. (If I have misunderstood your intend, see note below for an alternative).
This would make more sense if you were passing values between two different sub-modules. Modules in Shiny are intended to pass their own values within themselves, so as to avoid cluttering the parent module.
If this is your intention, I recommend the following:
UI (essentially unchanged):
library(shiny)
library(shinydashboard)
source("modules/my.R")
ui <- dashboardPage(
dashboardHeader(title="Dashboard"),
dashboardSidebar(
sidebarMenu(
menuItem("App 1", tabName="app1"),
menuItem("App 2", tabName="app2"),
id="selectedMenu"
)
),
dashboardBody(
uiOutput("foo")
)
)
Server:
library(shiny)
source("modules/my.R")
server <- function(input, output) {
resource_numBins = reactive({ # reactive value is defined
if(exists('my_realised')
& !is.null(my_realised$num_bin())){ # conditions to prevent errors/warnings
return(my_realised$num_bins())
}else{
return(3) # required initial value
}
})
# reactive value passed to module
my_realised <- callModule(my, "foo", numBins = resource_numBins)
# my_realised stores values returned by module
output$foo <- renderUI({
if (input$selectedMenu == "app1") {
return(myUI("foo", initial_num_bins = resource_numBins()))
} else {
return(br())
}
})
}
Module (some white space removed):
library(shiny)
myUI <- function(id, initial_num_bins) {
ns <- NS(id)
tagList(
fluidRow( box(
plotOutput(outputId = ns("distPlot")), width=12
) ),
fluidRow( box(
sliderInput(inputId = ns("bins"), label = "Number of bins:",
min = 1, max = 50, value = initial_num_bins),
width=12
) )
)
}
my <- function(input, output, session, numBins) { # module receives value from parent
output$distPlot <- renderPlot({
x <- faithful$waiting
bins <- seq(min(x), max(x), length.out = numBins() + 1)
hist(x, breaks = bins, col = "#75AADB", border = "white",
xlab = "Waiting time to next eruption (in mins)",
main = "Histogram of waiting times")
})
return(list(num_bins = reactive({input$bins}))) # module returns slider value to parent
}
Note that the complexity of resource_numBins is due to it also being used as the initial value, and needing to persist when menu item "App 2" is selected. Without these additional requirements this reactive would simplify to:
resource_numBins = reactive({ # reactive value is defined
return(my_realised$num_bins())
})
As sub-modules will pass values between themselves without first needing to pass a value back to the parent, the other problem you might be seeking to solve is how to use a sub-module to update the value in a parent module. For this I suggest my existing answer here. Either approach will let you use the value from the sub-module in the parent module.

Storing entire code inside the action button

I want to put my whole code inside the action button. As i click the button my whole code dashboard should be visible in my screen(which i am getting right now in my code)
But firstly i must be able to see only that button.
Here is the sample dashboard which i am trying to put in my button.
I have not make the button in this code as this is quite straight forward.Can somebody help please?
library(shinydashboard)
ui <- dashboardPage(
dashboardHeader(title = "Basic dashboard"),
dashboardSidebar(),
dashboardBody(
# Boxes need to be put in a row (or column)
fluidRow(
box(plotOutput("plot1", height = 250)),
box(
title = "Controls",
sliderInput("slider", "Number of observations:", 1, 100, 50)
)
)
)
)
server <- function(input, output) {
set.seed(122)
histdata <- rnorm(500)
output$plot1 <- renderPlot({
data <- histdata[seq_len(input$slider)]
hist(data)
})
}
shinyApp(ui, server)
You can use req in outputs, for e.g.:
output$plot1 <- renderPlot({
req(input$button)
data <- histdata[seq_len(input$slider)]
hist(data)
})
Then the output will only be shown if the input is being used.
You can also put things in conditionalPanel(). You can use that in the UI part of the script. For example:
fluidRow(conditionalPanel(condition = "input.button == true",
box(plotOutput("plot1", height = 250)),
box(
title = "Controls",
sliderInput("slider", "Number of observations:", 1, 100, 50)
)
)
Note that the condition is in javascript.
I've given your button a name and made it TRUE/FALSE but you would need to adapt that depending on the input button.

Return a table from R shiny observe()

I want to create a vector by using observe() in R shiny. In the code blow, how can I create a vactor where all the input$n are concatenated. At the present time, I can only display a single value but could not concatenate and display all the inputs from the sliderInput.
ui.R
library(shiny)
fluidPage(
titlePanel("Observer demo"),
fluidRow(
column(4, wellPanel(
sliderInput("n", "N:",
min = 10, max = 1000, value = 200, step = 10)
)),
column(8,
tableOutput("text")
)
)
)
server.R
library(shiny)
function(input, output, session) {
observed=reactiveValues(
input=NULL
)
observe({
observed$input=input$n
# observed$input=c(observed$input,input$n) # tried this but not working
})
output$text <- renderTable({
observed$input
})
}
If you add print(observed$input) in your observer, you will see that when you use observed$input=c(observed$input,input$n) you run into an infinite loop as the observe is reactive to observe$input and will run again as soon as you modify it.
To prevent this, you can use isolate:
observed$input=c(isolate(observed$input),input$n)
As in #Pork Chop 's answer, you can also use observeEvent to only observe input$n.
Try this, you can use cbind or rbind depending on your needs
rm(list = ls())
library(shiny)
ui <- fluidPage(
titlePanel("Observer demo"),
fluidRow(
column(4, wellPanel(
sliderInput("n", "N:",
min = 10, max = 1000, value = 200, step = 10)
)),
column(8,
tableOutput("text")
)
)
)
server <- function(input, output, session) {
observed=reactiveValues(
input=NULL
)
observeEvent(input$n,{
observed$input <- cbind(observed$input,input$n)
})
output$text <- renderTable({
print(observed$input)
observed$input
})
}
shinyApp(ui <- ui, server <- server)

Disasble shiny sliderInput using shinyjs

I am building multiple lm() models using dplyr. I want to allow a user to change the independent variable value in a Shiny app - via shiny::sliderInput(). But only do so where "goodness of fit" say R^2 is greater than a threshold - otherwise disable the slider. I have tried to use the shinyjs::disable() function. See below, but can't get it to work. Any ideas on what I am doing wrong ?
library(shiny)
library(shinyjs)
# Define UI for application that draws a histogram
ui <- shinyUI(fluidPage(
sidebarLayout(
sidebarPanel(
sliderInput("test","Nice number",min = 1,max = 50,value = 30)
),
mainPanel(
textOutput("valueText")
)
)
))
# Define server to disable slider if value selected
server <- shinyServer(function(input, output) {
value <- reactive(input$test)
output$valueText <- renderText(paste(value()))
#How to diasble slider?
reactive(if(value()==35){
shinyjs::disable('test')
}
)
})
# Run the application
shinyApp(ui = ui, server = server)
You have to call useShinyjs() in ui.R.
This is the code:
library(shiny)
library(shinyjs)
# Define UI for application that draws a histogram
ui <- shinyUI(
tagList(
useShinyjs(),
fluidPage(
sidebarLayout(
sidebarPanel(
sliderInput("test","Nice number",min = 1,max = 50,value = 30)
),
mainPanel(
textOutput("valueText")
)
)
)
)
)
# Define server to disable slider if value selected
server <- shinyServer(function(input, output) {
value <- reactive(input$test)
output$valueText <- renderText(paste(value()))
#How to diasble slider?
observeEvent(value(), {
if(value()==35){
shinyjs::disable('test')
}
})
})
# Run the application
shinyApp(ui = ui, server = server)

Resources