I am trying to set custom values for shiny slider (1,5,10,15,20,25 and 30). I tried step but then the results either (0,5,10,15,20,25,30) or (1,6,11,16,21,26,31). Is there any way yo define custom values for slider?
Thanks!
plotpath <- "/Volumes/share-ites-1-$/Projects/Scientifica/Simulations_Scientifica"
ui <- fluidPage(
titlePanel("LandClim Simulations"),
sidebarLayout(
sidebarPanel(
sliderInput(inputId = "temp",
label = "Temperature increase:",
value = 1, min = 1, max = 2,
step = 1, animate = TRUE ),
sliderInput(inputId = "prec",
label = "Precipitation change:",
value = 0, min = -2, max = 2,
step = 1, animate = TRUE ),
sliderInput(inputId = "decade",
label = "Time (decade):",
value = 1, min = 0, max = 30,
step = 5, animate = TRUE )
),
mainPanel(imageOutput("image"))
)
)
server <- function(input, output) {
output$image <- renderImage( deleteFile = FALSE, {
return(list(
src = paste(plotpath,"/Temp",input$temp,"Prec",input$prec,"Dec",input$decade,".png",sep = ""),
contentType = "image/png"))
} ) }
shinyApp(ui = ui, server = server)
The shinyWidgets package now solves this for you with a slider that allows custom values. Updated code for your third slider would look like this:
shinyWidgets::sliderTextInput(inputId = "decade",
label = "Time (decade):",
choices = c(1,5,10,15,20,25,30))
Although Shiny gives options to customize the slider Input,I do not think there is a way to to get output in the form (1,5,10...).This is because the difference between your 1st and 2nd point is 4 and thereafter it is 5 which will be inconsistent with the way step parameter works.Step can only generate numbers based on constant differences between slider inputs.
Depending on the need to have a slider, to have inputs with variable breaks you could use one of the other options, like
selectInput
https://shiny.rstudio.com/reference/shiny/latest/selectInput.html
or even checkboxInput
https://shiny.rstudio.com/reference/shiny/latest/checkboxInput.html
This can be easily done using sliderTextInput function in shiny. No need to add all this complex js function. Just a few lines of code will do the trick.Install the shinywidgets package which contains the sliderTextInput function. Do the following :
sliderTextInput("decade","Time (decade):,
choices = c(1,5,10,15,20,25,30),
selected = c(1,5,10,15,20,25,30),
animate = FALSE, grid = FALSE,
hide_min_max = FALSE, from_fixed = FALSE,
to_fixed = FALSE, from_min = NULL, from_max = NULL, to_min = NULL,
to_max = NULL, force_edges = FALSE, width = NULL, pre = NULL,
post = NULL, dragRange = TRUE)
Related
I'm using the sliderInput function with the animate argument to perform an automatic calculation in my shinyApp. However, using animate is affecting other reactions in my app. I would like to stop this side effect that is occurring in other reactivities.
For example, I have a dropdownMenu inside an if else structure. But, because of the animate argument, I can't click the option in the top right corner when I start the animation. It is disappearing with each calculation that the animate is doing. See:
I tried use isolate() in pred_1() but it stop the valueBox and the conditional structure (if else structure).
I'd like to just make animate not affect other reactivity in the app.
My app:
library(shiny)
library(shinydashboard)
header <- dashboardHeader(
title = "Dashboard",
titleWidth = 300,
dropdownMenuOutput(
outputId = "drop1"
)
)
sidebar <- dashboardSidebar(
width = 300
)
body <- dashboardBody(
sliderInput(
inputId = "one",
label = "Registro 1",
value = 1,
animate = animationOptions(
interval = 500, loop = TRUE
),
min = 1,
max = 10,
step = 1,
ticks = TRUE
),
sliderInput(
inputId = "two",
label = "Registro 2",
value = 1,
animate = animationOptions(
interval = 500, loop = TRUE
),
min = 1,
max = 10,
step = 1,
ticks = TRUE
),
sliderInput(
inputId = "three",
label = "Sum 3",
value = 1,
animate = animationOptions(
interval = 500, loop = TRUE
),
min = 1,
max = 10,
step = 1,
ticks = TRUE
),
valueBoxOutput(
outputId = "box1"
)
)
ui <- dashboardPage(
header = header,
sidebar = sidebar,
body = body
)
server <- function(session, input, output) {
fx <- function(x, y) {
x + y
}
fy <- function(x) {
x
}
reac_0 <- reactive({
tibble::tibble(
one = input$one,
two = input$two,
three = input$three
)
})
chuveiro <- reactive({
temp <- reac_0()
fx(
x = temp$one,
y = temp$two
)
})
luz <- reactive({
temp <- reac_0()
fy(
x = temp$three
)
})
fdrop <- function(x) {
if (x <= 5) {
dropdownMenu(
type = "notifications",
badgeStatus = NULL,
headerText = "Not 1",
notificationItem(
text = HTML(
"<text style='color:#020202;'>Without.</text>"
),
status = "danger",
icon = icon("times"),
href = NULL
)
)
} else (
dropdownMenu(
type = "notifications",
badgeStatus = "danger",
headerText = "Not 2",
notificationItem(
text = HTML(
"<a style='color:#020202;'
href='https://www.instagram.com' target='_blank' title='A'>
With</a>"
),
status = "success",
icon = icon("tags")
)
)
)
}
output$drop1 <- renderMenu({
expr = fdrop(x = luz())
})
output$box1 <- renderValueBox({
expr = valueBox(
value = chuveiro(),
subtitle = "Sum"
)
})
}
shinyApp(ui, server)
So how can I make one reactivity effect another in a shinyApp?
I would like to click normally on the dropdownMenu notification with the sliderInput working with animate.
I tried isolating each argument of sliderInput, but not work.
The reac0() reactive is triggered whenever an input changes. Then it triggers every reactive that includes it, even if the value used in that reactive has not changed.
Your code :
reac_0 <- reactive({
tibble::tibble(
one = input$one,
two = input$two,
three = input$three
)
})
luz <- reactive({
temp <- reac_0()
fy(
x = temp$three
)
})
triggers luz() whenever one, two or three changes.
An alternative would be to use input$three directly:
luz <- reactive({
fy(
x = input$three
)
})
This way, the change or animation of slider one and two won't trigger luz() which won't trigger the menu rendering.
Of course, since the value of slider three is used to render the menu, any update of its value has to trigger the menu rendering.
I'm pretty new to shiny and am struggling on how to use check boxes to update values in a bar chart. The idea I'm after is when a user ticks on a check box, a numerical value is generated that will be added to an aggregate from other inputs to make a bar chart. Here is the code I have gotten to work so far:
library(shiny)
ui <- fluidPage(
titlePanel("TCO Calculator"),
mainPanel(
sidebarPanel(
helpText("Product 1 information:"),
numericInput(
inputId = "price_1",
label = "Purchase Price",
value = "0",
min = 0,
width = '50%'
),
numericInput(
inputId = "install_1",
label = "Installation cost",
value = "0",
min = 0,
width = '50%'
),
selectInput("disposal_1", "Disposal Cost",
choices = list(Buyback = (10),
Dump = (30),
Reuse = (5)),
width = '50%'),
checkboxGroupInput("maint_1", "Maintenance:",
choices = c("Waxing",
"Stripping", "Burnishing"),
selected = NULL)
),
sidebarPanel(
helpText("Product 2 information:"),
numericInput(
inputId = "price_2",
label = "Purchase Price",
value = "0",
min = 0,
width = '50%'
),
numericInput(
inputId = "install_2",
label = "Installation cost",
value = "0",
min = 0,
width = '50%'
),
# make list?
selectInput("disposal_2", "Disposal Cost",
choices = list(Buyback = (10),
Dump = (30),
Reuse = (5)),
width = '50%'),
checkboxGroupInput("maint_2", "Maintenance:",
choices = NULL,
selected = NULL,
inline = FALSE,
width = NULL,
choiceNames = c("Waxing",
"Stripping", "Burnishing"),
choiceValues = c(10, 20, 40))
),
plotOutput("costPlot")))
server <- function(input, output, session) {
# aggregate inputs into reactive bar chart values.
select_price <- reactive({
c(input$price_1 + input$install_1
+ as.numeric(input$disposal_1),
input$price_2 + input$install_2 +
as.numeric(input$disposal_2))
})
# Bar chart.
my_bar <- output$costPlot <- renderPlot({
barplot(select_price(),
beside = T,
border=F,
las=2 ,
col=c(rgb(0.3,0.1,0.4,0.6) ,
rgb(0.3,0.5,0.4,0.6)) ,
space = 3,
ylab = "Total cost per square foot, US Dollar")
abline(v=c(4.9 , 6.1) , col="grey")
legend("top", legend = c("Product 1", "Product 2" ),
col = c(rgb(0.3,0.1,0.4,0.6),
rgb(0.3,0.5,0.4,0.6)),
bty = "n",
pch=20 , pt.cex = 4,
cex = 1.6, horiz = FALSE,
inset = c(0.05, 0.05))
my_bar
})
}
shinyApp(ui = ui, server = server)
I've been successful with the numericInput and selectInput stuff so far, I am having trouble putting together a concise way to include check boxes (with corresponding numeric values) into a reactive function that I can path into select_price(), like I have done with the numeric and selectBox stuff. Things go sideways when I try to map from other examples. I feel like there is an elegant, or in least working solution that exists. Any insight towards how to solve this would be so appreciated, thanks!
I am not sure whether this entirely solves all your problems but try this:
For maint_2, you correctly separate choiceNames and choiceValues. For maint_1 you dont't
checkboxGroupInput("maint_1", "Maintenance:",
choices = NULL,
selected = NULL,
choiceNames = c("Waxing", "Stripping", "Burnishing"),
choiceValues = c(10, 20, 40))
Then you can add input$maint_1 and input$maint_2 to your reactive (also wrapped in as.numeric(). I also use sum for + as you don't have a default for input$maint_1 and input$maint_2. sum evaluates this to 0 while + throws an error.
select_price <- reactive({
c(sum(input$price_1, input$install_1, as.numeric(input$disposal_1), as.numeric(input$maint_1)),
sum(input$price_2, input$install_2, as.numeric(input$disposal_2), as.numeric(input$maint_1)))
})
i'm newly to the R world and i'm just trying to build a Dashboard on Shiny.
My problem is that i want to display some text only if certain conditions are met in the renderplotly function.
shinyUI(fluidPage(
titlePanel("Posti occupati in terapia intensiva"),
sidebarLayout(
sidebarPanel(
selectInput("region","Scegli regione",unique(as.character(region_dataset$denominazione_regione),)
),
dateInput("day","Scegli data", min=region_dataset$data[1], max=region_dataset$data[nrow(region_dataset)], format="dd/mm/yyyy",value=region_dataset$data[nrow(region_dataset)]
),
),
mainPanel(
plotlyOutput(outputId = "TI"),
textOutput(outputId= "text")
)
),
))
This is the ui page and i show you the server
shinyServer(function(input, output) {
output$TI <- renderPlotly({
day <- input$day
region <- input$region
request <- filter(region_dataset,region_dataset$data==day & region_dataset$denominazione_regione==region)
plot_ly(as.data.frame(request$terapia_intensiva),
domain = list(x = c(0, 1), y = c(0, 1)),
value = request$terapia_intensiva,
title = list(text = "Posti occupati TI"),
type = "indicator",
mode = "gauge+number+delta",
delta = (reference = as.integer(request$terapia_intensiva[nrow(request$data)-1])),
gauge = list(
axis =list(range = list(NULL, request$posti_TI)),
bar = list(color = "darkmagenta"),
borderwidth = 3,
steps = list(
list(range = c(0, 0.33*request$posti_TI), color = "green"),
list(range = c(0.33*request$posti_TI, 0.66*request$posti_TI), color = "yellow"),
list(range = c(0.66*request$posti_TI, request$posti_TI), color = "red")),
threshold = list(
line = list(color = "cyan", width = 5),
thickness = 0.75,
value = request$posti_TI)))
})
output$text <- renderText("Numero massimo di posti occupati")
})
My problem is that i want to display the text in the panel only if request$terapia_intensiva>request$posti_TI
I can't find out a solution to this problem, i've tried using reactive function and conditional panel but with no results.
Thanks for helping.
renderText() can contain logic, so
output$text <- renderText({
if (request$terapia_intensiva>request$posti_TI) "Numero massimo di posti occupati"
})
If the if() returns FALSE, renderText returns NULL. If you want to be explicit, you can always add else NULL or else rturn(NULL) if you wish.
I have an app wherein users can input numeric values for certain fields (using numericInput()). Alternatively, they can choose to select values from a reference table (via a checkboxInput() field).
I'm able to code this behaviour in the script properly. But I also want that if the checkboxInput field is selected, the values displayed in the numericInput() get updated i.e. the default values or previously written values are overwritten.
In the screenshot, the numericInput fields are highlighted in yellow. The top field has a default value of 14 whereas the others are empty. I want that the if the "Copy reference values?" checkboxInput is selected, the copied values get displayed in the corresponding fields (k1 = 72.49 for "Flow Coef. for dP" etc.)
My code is as below:
fluidRow(
column(4,
numericInput(inputId = "Area",
label = tags$div(HTML(paste("rea (m", tags$sup(2), ")", sep = ""))),
min = 1, max = 100, step = 0.1, value = 14),
numericInput(inputId = "k1", label = "Flow coef. for dP", min = 1.0, max = 600.0, value = ""),
numericInput(inputId = "k2", label = "Flow exponent for dP" , min = 1.0, max = 20.0, value = "")
checkboxInput("copyVals", "Copy Reference Values?", value = FALSE)
)
You'll want to use an observeEvent and updateNumericInputs. Since you didn't provide a reproducible example here is a mockup:
library("shiny")
library("DT")
data <- data.frame(area = 18.61, k1 = 74.29, k2 = 1.44)
server <- function(input, output, session) {
# assuming your data is reactive, not static
data_reac <- reactive({
data
})
output$parm_tab <- renderDataTable({
datatable(data_reac())
})
# set the values if checked
observeEvent(input$copyVals == TRUE, {
c_data <- data_reac()
updateNumericInput(session, "area", value = c_data$area)
updateNumericInput(session, "k1", value = c_data$k1)
updateNumericInput(session, "k2", value = c_data$k2)
}, ignoreInit = TRUE)
}
ui <- fluidPage(
sidebarLayout(
sidebarPanel(
numericInput(inputId = "area", label = "Area", min = 1, max = 100, step = 0.1, value = 14),
numericInput(inputId = "k1", label = "Flow coef. for dP", min = 1.0, max = 600.0, value = ""),
numericInput(inputId = "k2", label = "Flow exponent for dP" , min = 1.0, max = 20.0, value = ""),
checkboxInput("copyVals", "Copy Reference Values?", value = FALSE)
)
, mainPanel(
dataTableOutput("parm_tab")
)
)
)
shinyApp(ui = ui, server = server)
Before
After
I have a number of numericInputs put into several columns of a DT datatable. I would like to allow users to click a button, which then copies inputs from the first column to the other columns. I'm able to make this work for numericInputs that are not part of a datatable, but nothing happens to numericInputs inside of a datatable. A simplified example of my problem is given below. I also include a working example for a standalone numericInput, which is not part of a datatable, to demonstrate the behavior I'm looking for.
library(shiny)
library(DT)
shinyApp(
server = shinyServer(function(input, output, session) {
output$Table <- DT::renderDataTable({
observeEvent(input$button1, {
v <- input$Number.1.1
updateNumericInput(session,"Number.2.1", value = v)
})
temp <- data.frame(c(1:5))
temp$Numbers.1 <- ""
temp$Numbers.2 <- ""
sapply(1:5, FUN = function(i){
temp$Numbers.1[i] <<- as.character(numericInput(paste0("Number.1.", i), "", value = NULL, min = 0, max = 10, step = 0.01))
})
sapply(1:5, FUN = function(i){
temp$Numbers.2[i] <<- as.character(numericInput(paste0("Number.2.", i), "", value = NULL, min = 0, max = 10, step = 0.01))
})
datatable(temp,escape = FALSE, rownames = FALSE, options = list(sort = FALSE, paging = FALSE, searching = FALSE))
})
observeEvent(input$button2,{
v <- input$Number.3
updateNumericInput(session,"Number.4", value = v)
})
}),
ui = fluidPage(
br(),
actionButton("button1","Copy"),
dataTableOutput("Table"),
br(),
actionButton("button2","Copy"),
numericInput("Number.3", "Number 3", value = NULL, min = 0, max = 10, step = 0.1),
numericInput("Number.4", "Number 4", value = NULL, min = 0, max = 10, step = 0.1)
)
)
I have also tried placing the observeEvent outside of the renderDataTable, but that was no help. Since the button works fine for standalone numericInputs, I'm guessing this is some sort of scoping issue, but I've been unable to figure out how to resolve it.
Thanks in advance for any help!
I solved my problem. (It turns out I actually knew the answer, but was having a brain fart.) The datatable() function inside of renderDataTable({}) should read:
datatable(temp,escape = FALSE, rownames = FALSE, options = list(sort = FALSE, paging = FALSE, searching = FALSE,
preDrawCallback = JS('function() { Shiny.unbindAll(this.api().table().node()); }'),
drawCallback = JS('function() { Shiny.bindAll(this.api().table().node()); } ')))