so I'm trying to make a tax calculation app. In the sidebar I'm using tabsetPanel to display two panels with different inputs relating to the individual and then tax rates.
The mainPanel will also be using tabsetPanel where I plan to plot graphs etc. I have an update button that doesn't seem to be working.
ui.R
Looks like this:
shinyUI(fluidPage(
titlePanel("flatTax"),
sidebarLayout(
sidebarPanel(
h1("Flat Tax Calculator"),
helpText("Input your information below and see how a flat tax could
affect your tax bill."),
#Individual Specific Variables
tabsetPanel(
tabPanel("You",
numericInput(inputId = "incomeNum",
label = "Your annual income:",
value = 0
),
textInput(inputId = "testText",
label = "Test Input"
),
),
tabPanel("Tax Settings",
sliderInput(inputId = "basicIncome",
label = "Choose a monthly basic income",
value = 600, min = 0, max = 1200, step = 50
),
sliderInput(inputId = "taxFree",
label = "Choose a tax free allowance",
value = 10000, min = 0, max = 20000, step = 250
),
sliderInput(inputId = "flatIncomeTax",
label = "Choose a flat tax rate",
value = 50, min = 0, max = 100, step = 1
),
sliderInput(inputId = "flatPropertyTax",
label = "Choose a land value tax rate",
value = 1, min = 0, max = 100, step = 1
)),
# Action Button
actionButton(inputId = "updateButton",
label = "Update"),
plotOutput("text")
)
),
mainPanel(
tabsetPanel(
tabPanel("Summary",
h3("Test Output", textOutput("test"),
h3("Your new income tax bill is:", textOutput("incomeFT")),
h3("Your new property tax bill is:", textOutput("propertyFT")),
textOutput("annualBasicIncome")
)
),
tabPanel("Graphs",
h3("Placeholder"),
h3("Holding the place"),
h3("Plaice holster")
)
)
)
)
))
server.R
Looks like this:
shinyServer(
function(input, output) {
#action button stuff
incomeFT <- eventReactive(input$updateButton, {
((input$incomeNum-input$taxFree)/100*input$flatIncomeTax)
})
output$incomeFT <- renderPrint({
incomeFT()
})
propertyFT <- eventReactive(input$updateButton, {
input$propertyNum/100*input$flatPropertyTax
})
output$propertyFT <- renderPrint({
propertyFT()
})
annualBasicIncome <- eventReactive(input$updateButton, {
switch(as.numeric(input$relStat),
return((input$basicIncome*12)+((input$basicIncome*12)*input$childNum)),
return((2*(input$basicIncome*12))+((input$basicIncome*12)*input$childNum))
)
})
output$annualBasicIncome <- renderPrint({
annualBasicIncome()
})
test <- eventReactive(input$updateButton, {
input$testText
})
output$test <- renderText({
test()
})
})
Without reactivity it seems to work, but the button makes it less distracting to use. I've tried using verbatimTextOutput instead of textOutput but grey bars are sent across the main panel with not outputs in.
Help please?
For some reason, the actionButton does not work inside the tabsetPanel. If you put it outside it (and inside sidebarPanel) it will work. I suggest you try to use one actionButton for each tabPanel. I haven't try it, but I believe it should work. Please, if you try it, let me know the results.
Cheers.
Related
I'm a beginner in shiny app. so first I tried to build an app to calculate distance covered using time taken and speed. I got error as "argument of length zero". Then I entered req(input$num_time,input$select_time,input$slider_speed)this command after that error message is not displaying and also not getting output also. I'm not able to find where I gone wrong. Please help me in getting the output. I have shown the code I used below:
library(shiny)
#library(car)
ui <- fluidPage(
titlePanel("terrain model"),
sidebarLayout(
sidebarPanel(
helpText("To create a suitable model"),
br(),
numericInput("num_time",
label = h6("Enter time"),
value = 1),
selectInput("select_time",
label = h6(""),
choices = list("Hours"= 1,"Minutes" = 2),
selected = "1"),
sliderInput("Speed",
label = "Speed:",
min = 2, max = 4.5, value = 2),
br(),
actionButton("action",label="Refresh & Calculate")
),
mainPanel(
textOutput("text_distance")
)
)
)
server <- function(input, output) {
values <- reactiveValues()
#calculate distance travelled
observe({input$action_Calc
values$int <- isolate({ input$num_time * recode(input$select_time,"1='60';2='1'")*input$slider_speed
})
})
#Display values entered
output$text_distance <- renderText({
req(input$num_time,input$select_time,input$slider_speed)
if(input$action_Calc==0)""
else
paste("Distance:", round(values$int,0))
})
}
shinyApp(ui, server)
I don't find any use of "Refresh & Calculate" button since the calculation is performed as soon as any of the input changes.
You can try this code :
ui <- fluidPage(
titlePanel("terrain model"),
sidebarLayout(
sidebarPanel(
helpText("To create a suitable model"),
br(),
numericInput("num_time",
label = h6("Enter time"),
value = 1),
selectInput("select_time",
label = h6(""),
choices = list("Hours"= 1,"Minutes" = 2),
selected = "1"),
sliderInput("Speed",
label = "Speed:",
min = 2, max = 4.5, value = 2),
br(),
actionButton("action",label="Refresh & Calculate")
),
mainPanel(
textOutput("text_distance")
)
)
)
server <- function(input, output) {
#Display values entered
output$text_distance <- renderText({
val <- input$num_time/dplyr::recode(input$select_time,"1"=1,"2"=60)*input$Speed * 1000
paste("Distance:", round(val,0), 'meters')
})
}
shinyApp(ui, server)
I have four user inputs in my ShinyApp such that:
The first input (total_price) is always present
Optional input for rrsp which allows users to input a value (max 35,000)
Optional input for fthbi which allows users to select a value up to 10%
Other payment for cash which allows user to input a value
In my code, total_input and cash are numericInput, rrsp and fthbi are checkBoxInput + conditionalPanel
total_price is independent of the other three. However, the other other three summed up and can not exceed 20% of total_price i.e. rrsp + fthbi * total_price + cash <= total_price*0.2. How can I achieve this - basically as any of the inputs change, the limits of the remaining inputs (in the order mentioned above) should change as well.
CODE
ui <- fluidPage(
titlePanel(
'My App'
),
sidebarLayout(
sidebarPanel = sidebarPanel(
numericInput(
inputId = 'total_price',
label = 'Total Price',
value = 200000,
min = 200000
),
# Use RRSP for down-payment
checkboxInput(
inputId = 'use_rrsp',
label = 'Use RRSP?',
value = F
),
# If using RRSP, select amount to use
conditionalPanel(
condition = "input.use_rrsp == true",
numericInput(
inputId = 'rrsp', label = 'RRSP Amount?',value = 25000, min = 0, 35000
)
),
# Use first time home buyer incentive?
checkboxInput(
inputId = 'use_fthbi',
label = 'Use FTHBI?',
value = F
),
# If using FTHBI, select % to use
conditionalPanel(
condition = "input.use_fthbi == true",
sliderInput(
inputId = 'fthbi', label = 'FTHBI Percent',
step = 1, min = 0, max = 10, value = 0, post = '%'
)
),
# Cash Downpayment
numericInput(
inputId = 'cash', label = 'Cash Payment', value = 0, min = 0, max = 40000
)
),
mainPanel = mainPanel(
textOutput('main_text')
)
)
)
server <- function(input, output, session){
output$main_text <- renderText({
sprintf('Sample Text')
})
}
shinyApp(ui, server)
I've tried playing around with updateSliderInput and reactiveUI but haven't been successful..
Update
Here's the logic:
by default rrsp and ftbhi are not selected, so cash can be set to 20% of total_price
Once rrsp is selected, it should begin with a default value of 25000. The max. value for rrsp is 35000 which is less than 20% of the min. allowable total_value. If some value for cash is selected that would bring rrsp + cash > total_price, the cash value should be updated such taht the total is 20% max.
Once ftbhi is selected, the default value should be zero (updated code now). The max. value for this should be updated based on the rrsp value (if already selected) else it should be 10%.
cash should get updated as other values are selected, input.
Aou are on the right track in using the update* functions. I am not going to implement the complete logic yet the snippet below should point you in the right direction:
# Basic usage
library("shiny")
library(shinyWidgets)
ui <- fluidPage(
titlePanel(
'My App'
),
sidebarLayout(
sidebarPanel = sidebarPanel(
numericInput(
inputId = 'total_price',
label = 'Total Price',
value = 200000,
min = 200000
),
# Use RRSP for down-payment
checkboxInput(
inputId = 'use_rrsp',
label = 'Use RRSP?',
value = F
),
# If using RRSP, select amount to use
conditionalPanel(
condition = "input.use_rrsp == true",
numericInput(
inputId = 'rrsp', label = 'RRSP Amount?',value = 25000, min = 0, 35000
)
),
# Use first time home buyer incentive?
checkboxInput(
inputId = 'use_fthbi',
label = 'Use FTHBI?',
value = F
),
# If using FTHBI, select % to use
conditionalPanel(
condition = "input.use_fthbi == true",
sliderInput(
inputId = 'fthbi', label = 'FTHBI Percent',
step = 1, min = 0, max = 10, value = 0, post = '%'
)
),
# Cash Downpayment
numericInput(
inputId = 'cash', label = 'Cash Payment', value = 0, min = 0, max = 40000
)
),
mainPanel = mainPanel(
textOutput('main_text')
)
)
)
server <- function(input, output, session){
output$main_text <- renderText({
sprintf('Sample Text')
})
observe({
# check that the input exists, is not null etc. check ?req()
req(input$cash)
if(input$cash > 0)
updateSliderInput(session = session,
inputId = 'fthbi',
max = round(40000 / input$cash))
})
}
shinyApp(ui, server)
Just wrap your update function inside of observe. However, you should be carefull that you do not implement a infinite loop. In this case it is an option to determine each value, safe it in reactiveValues and use these to update your inputs.
I plot GPS data on a leaflet map using R,
the trip is visualised through an incrementing timeline provided by the sliderInput in animation mode.
sliderInput("animation", "Mesures GPS :",
min = ifelse( !exists("i.data"), 0, min(i.data$sequence)),
max = ifelse( !exists("i.data"), 1, max(i.data$sequence)),
value = 0,
step=20,
animate = animationOptions(interval = 1000, loop = FALSE),
width="100%"))
I can see the GPS points jumping over the map, and now I am looking for the way to have a "next" button ([<<], [>>]) to control more finely local steps. I have not seen any such option in the sliderInput documentation.
This could also be done by adding ad-hoc shiny actionButtons,
any suggestion?
Adapting the code from ?sliderInput:
library(shiny)
shinyApp(
ui = fluidPage(
fluidRow(
div(style = "display: inline-block;vertical-align:center;",
actionButton("left", label = "<<")),
div(style = "display: inline-block;vertical-align:center;",
sliderInput("obs", "Number of observations:",
min = 0, max = 1000, value = 500
)),
div(style = "display: inline-block;vertical-align:center;",
actionButton("right", label = ">>")),
),
plotOutput("distPlot")
),
# Server logic
server = function(input, output, session) {
output$distPlot <- renderPlot({
hist(rnorm(input$obs))
})
observeEvent(input$left, {
updateSliderInput(session, "obs", value = input$obs - 10)
})
observeEvent(input$right, {
updateSliderInput(session, "obs", value = input$obs + 10)
})
}
)
This updates by +/- 10.
I have achieved to define two interconnected or mutually dependent input in my shiny app. Right now, my problem is to set a specific initial value for these slider and numeric inputs. It seems that they always start with the minimum value, even I don't now exactly why. How can I indicate a unique starting point or an initial value for these input parameters?
I have attached a simplified part of my app in order to provide you a reproducible version of my problem here:
"ui.R"
library(shiny)
shinyUI(fluidPage(
uiOutput("Param_s"),
uiOutput("Param_n")
))
and the "server.R"
library(shiny)
shinyServer(
function(input,output) {
# Mutually dependent slider and numeric inputs
output$Param_s = renderUI({
sliderInput(inputId = "param_slide",
label= "My input parameter",
value= input$param_numeric,
min=1,
max=200)
})
output$Param_n = renderUI({
numericInput(inputId = "param_numeric",
label= "My input parameter",
value= input$param_slide,
min=1,
max=200)
})
})
I tried various things to fix the initial value but eventually nothing worked. Any help would be appreciated!!
wow! I got it guys! You should only update the two input objects at the same time and up to the same value. It means adding these two lines solved my problem to set the initial value to 60 for example:
updateSliderInput(session,"param_slide", value = 60)
updateNumericInput(session,"param_numeric", value = 60 )
Therefore the whole "server.R" would be like this:
#
library(shiny)
shinyServer(
function(input,output,session) {
# Mutually dependent slider and numeric inputs
output$Param_s = renderUI({
sliderInput(inputId = "param_slide",
label= "My input parameter",
value= input$param_numeric,
min=1,
max=200)
})
output$Param_n = renderUI({
numericInput(inputId = "param_numeric",
label= "My input parameter",
value= input$param_slide,
min=1,
max=200)
})
updateSliderInput(session,"param_slide", value = 60)
updateNumericInput(session,"param_numeric", value = 60 )
})
You should only be aware of adding these updates with an
observeEvent()
when you have these input objects on the other tabs. In my case which I am using "sidebarMenu" I used a simple line of code as this:
observeEvent(input$sidebar_id =="tab1",{
updateSliderInput(session,"param_slide", value = 60)
updateNumericInput(session,"param_numeric", value = 60 )
})
Coming from here.
You should try to avoid re-rendering (renderUI) if possible.
It's faster to update existing inputs:
library(shiny)
ui <- fluidPage(
sliderInput(
inputId = "param_slide",
label = "My input parameter",
value = 60,
min = 1,
max = 200
),
numericInput(
inputId = "param_numeric",
label = "My input parameter",
value = 60,
min = 1,
max = 200
)
)
server <- function(input, output, session) {
observeEvent(input$param_numeric, {
updateSliderInput(session, "param_slide", value = input$param_numeric)
}, ignoreInit = TRUE)
observeEvent(input$param_slide, {
updateNumericInput(session, "param_numeric", value = input$param_slide)
}, ignoreInit = TRUE)
}
shinyApp(ui, server)
Furthermore, please check this and this.
I'm building a new Shiny app and I although it works, the code is too extensive and it is not as reactive as I wanted. Right now I have at server.R
dayData <- reactive({...})
pday <- function(data){...}
output$distPlotday <- renderPlot(function() {print(pday(dayData)) })
and at ui.R
plotOutput("distPlotday")
for each variable in
checkboxGroupInput("checkGroup", "Dataset Features:",
choices = c("day","hour","source","service","relevancy","tollfree","distance","similarity"))
But I wish I could do something more fancy like this:
shinyServer(function(input, output, session) {
...
output$sliders <- renderUI({
lapply(input$checkGroup, function(i) {
fluidRow(
column(4,
selectInput(paste0('trans',i), i,
choices = c('linear','quadratic','sine')) ,
conditionalPanel(
condition = "input[[paste0('trans',i)]]== 'sine'",
withMathJax(),
h5("Put in your initial kicks for: $$a*\\sin(b*x+c)+d$$"),
textInput3(paste0('trans',i,'a'), h5('A:'),
value = 10),
textInput3(paste0('trans',i,'b'), h5('C:'),
value = 1),
textInput3(paste0('trans',i,'c'), h5('D:'),
value = 0.1),
helpText("Note: B has already been picked up")
),
plotOutput(paste0('distPlot',i))
))
})
})
...
}))
.
shinyUI(navbarPage("",
tabPanel("Data",
sidebarLayout(
sidebarPanel(
checkboxGroupInput("checkGroup", label = h5("Dataset Features:"),
choices = c("day","hour","source","service","relevancy","tollfree","distance","similarity"), inline = F,
selected = c("day","hour","source","service","relevancy","tollfree","distance","similarity"))
),
mainPanel(
numericInput("obs", label = h5("Number of observations to view"), 15, min = 10, max = 20, step = 1),
tableOutput("view")
)
)
),
tabPanel("Variable transformation", uiOutput(outputId = "sliders"))
))
Using lapply and renderUI. But
plotOutput(paste0('distPlot',i))
is not ploting anything, and the
conditionalPanel(condition = "input[[paste0('trans',i)]]== 'sine'",...)
don't show up conditionally, instead it's always there.
Any suggestions? Thanks for the help!
I wasn't sure what you wanted to do with the plotOutput call, since as far as I can tell there wasn't any example code included that linked to it. However, I managed to put together a working example for dynamically showing/hiding the selection boxes and text fields for the sine parameters.
I found it easier to implement by moving the ui generation from the server into the ui. This gets around the problem of conditions being evaluated for input that doesn't exist yet, since on the ui side the functions are just writing html.
An additional benefit is that this way the input fields don't get re-rendered every time the checkbox input changes - this means that their values persist through toggling them on and off, and that enabling or disabling a single variable won't cause the others' values to reset.
The code:
library(shiny)
vars <- c("day","hour","source","service","relevancy",
"tollfree","distance","similarity")
ui <- shinyUI(navbarPage("",
tabPanel("Data",
sidebarLayout(
sidebarPanel(
checkboxGroupInput("checkGroup", label = h5("Dataset Features:"),
choices = c("day","hour","source","service","relevancy",
"tollfree","distance","similarity"), inline = F,
selected = c("day", "hour","source","service","relevancy",
"tollfree","distance","similarity")
)
),
mainPanel(
numericInput("obs", label = h5("Number of observations to view"),
value = 15, min = 10, max = 20, step = 1),
tableOutput("view")
)
)
),
tabPanel("Variable transformation",
fluidRow(
column(4,
lapply(vars, function(i) {
div(
conditionalPanel(
condition =
# javascript expression to check that the box for
# variable i is checked in the input
paste0("input['checkGroup'].indexOf('", i,"') != -1"),
selectInput(paste0('trans',i), i,
choices = c('linear','quadratic','sine'))
),
conditionalPanel(
condition =
paste0("input['trans", i, "'] == 'sine' ",
" && input['checkGroup'].indexOf('", i,"') != -1"),
withMathJax(),
h5("Put in your initial kicks for: $$a*\\sin(b*x+c)+d$$"),
textInput(paste0('trans',i,'a'), h5('A:'), value = 10),
textInput(paste0('trans',i,'b'), h5('C:'), value = 1),
textInput(paste0('trans',i,'c'), h5('D:'), value = 0.1),
helpText("Note: B has already been picked up")
)
)
})
)
)
)
))
server <- shinyServer(function(input, output, session) {})
shinyApp(ui, server)
PS. For dynamically showing/hiding or enabling/disabling objects, the package shinyjs by Dean Attali (link) has some nice tools that allow you to call basic javascript by using only R syntax.