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
Related
I have this R Shiny that gives me values of Meters covered based on the drill selected and the time selected by the user. Here is my code.
library(shiny)
library(dplyr)
# MyData <- read.csv("/Users/sonamoravcikova/Desktop/ShinyTest/ForShiny1.csv")
MyData <- structure(list(Drill = c("GP Warm Up", "5v2 Rondo", "11v11", "10v6 Drop
Behind Ball"), PlayerLoadPerMinute = c(7.72949670665213, 6.49382926701571,
9.67483408668731, 5.86770863636364), MetersPerMinute = c(69.9524820610687,
45.823744973822, 95.9405092879257, 58.185375), class = "data.frame", row.names
= c(NA, -4L)))
# Define UI ----
ui <- fluidPage(
titlePanel("Practice Planner"),
sidebarLayout(
sidebarPanel(
#Select number of drills
numericInput("num", h3("Number of Drills"), value = 1),
),
mainPanel(
#Show boxes for the number of drill selected and select drill type
selectInput("DrillName1",
label = "Choose a Drill:",
choices = unique(MyData$Drill),
selected = NULL,
multiple = FALSE),
sliderInput("slider1",
label = h3("Slider"),
min = 0,
max = 60,
value = 0),
textOutput("MpM1"),
br(),
conditionalPanel(
condition = "input.num > '1'",
selectInput("DrillName2",
label = "Choose a Drill:",
choices = unique(MyData$Drill),
selected = NULL,
multiple = FALSE),
sliderInput("slider2",
label = h3("Slider"),
min = 0,
max = 60,
value = 0),
textOutput("MpM2")),
br(),
conditionalPanel(
condition = "input.num > '2'",
selectInput("DrillName3",
label = "Choose a Drill:",
choices = unique(MyData$Drill),
selected = NULL,
multiple = FALSE),
sliderInput("slider3",
label = h3("Slider"),
min = 0,
max = 60,
value = 0),
textOutput("MpM3"))
)
)
)
# Define server logic ----
server <- function(input, output, session) {
#Calculate number of meters covered
lapply(1:10, function(x) {
output[[paste0("MpM", x)]] <- renderText({
chosendrill <- input[[paste0("DrillName", x)]]
MpM <- MyData %>%
distinct(MetersPerMinute, .keep_all = T)
MpM_text <- (MpM$MetersPerMinute[MpM$Drill == chosendrill]) * (input[[paste0("slider", x)]])
paste0("Meters covered: ", paste0(MpM_text, collapse = " "))
})
})
}
# Create Shiny app ----
shinyApp(ui = ui, server = server)
Now I'm trying to just add all of the values that I get for the individual drills together so that I will get Meters covered for the whole session but I have no idea how to do that. So if someone could help me out where to start I would appreciate it. Thanks
I am begginer in shiny an I am stucked adding feedback in my app.
I have tried a few things like write this code inside the eventReactive function like use the function feedBackDanger.
Below, there is a simplified full code with the ui, the idea is that i need the user get some Error (but not the console Error) if he set 'zero' in kind variable when mean is 3,6 or 9.
Also the actionButton 'simulate' should be disable when this condition is selected.
ui <- shinyUI(fluidPage(
titlePanel(h1("Simulation", align = 'center')),
sidebarLayout(
sidebarPanel(
numericInput(inputId = "n", label = "Size of Sample", min = 1,
step = 1, value = 1),
numericInput(inputId = "mean", label = "Mean of Sample", min = 1,
step = 1, value = 1),
numericInput(inputId = "var", label = "Variance", min = 1,
step = 0.25, value = 1),
radioButtons("kind", "Sample kind", choices = c("two", "zero")),
actionButton("simulate", "Simulate"),
width = 200
),
mainPanel(
plotOutput("distPlot", width = 500, height = 500)
)
)
))
# Define server logic required to draw a histogram
server <- shinyServer(function(input, output, session) {
s_fin <-function(n,
mean,
var,
kind){
a <- rnorm(n, mean, var)
if(kind == 'two'){
a <- a + 2
}
if(kind == 'zero'& mean %in% c(3,6,9)){
print('ERROR: function error')
stop(call. = T)}
return(a)
}
simulation <- eventReactive(input$simulate,{
s_fin(n = input$n,
mean = input$mean,
var = input$var,
kind = input$kind)
})
output$distPlot <- renderPlot({
hist(simulation())
})
})
shinyApp(ui, server)
The next code works to me (a just add useShinyFeedback() in ui.R, and put the error function instead of print):
library(shinyFeedback)
ui <- shinyUI(fluidPage(
useShinyFeedback(),
titlePanel(h1("Simulation", align = 'center')),
sidebarLayout(
sidebarPanel(
numericInput(inputId = "n", label = "Size of Sample", min = 1,
step = 1, value = 1),
numericInput(inputId = "mean", label = "Mean of Sample", min = 1,
step = 1, value = 1),
numericInput(inputId = "var", label = "Variance", min = 1,
step = 0.25, value = 1),
radioButtons("kind", "Sample kind", choices = c("two", "zero")),
actionButton("simulate", "Simulate"),
width = 200
),
mainPanel(
plotOutput("distPlot", width = 500, height = 500)
)
)
))
# Define server logic required to draw a histogram
server <- shinyServer(function(input, output, session) {
s_fin <-function(n,
mean,
var,
kind){
a <- rnorm(n, mean, var)
if(kind == 'two'){
a <- a + 2
}
if(kind == 'zero'& mean %in% c(3,6,9)){
showFeedbackDanger(
inputId = "mean",
text = "Not use mean 3, 6 or 9"
)
shinyjs::disable("simulate")
}else{
hideFeedback("mean")
shinyjs::enable("simulate")
}
return(a)
}
simulation <- eventReactive(input$simulate,{
s_fin(n = input$n,
mean = input$mean,
var = input$var,
kind = input$kind)
})
output$distPlot <- renderPlot({
hist(simulation())
})
})
shinyApp(ui, server)
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 creating a version of a sample size and power calculator. After running the code, when selecting the option "Sample Size", any updates to the sample size are immediate after moving around sliders or other numeric Inputs. However for the option "Power" (both coming from the first "selectInput" option), updates are not immediate if at all occurring.
I'm not sure if the correct move forward is to use a reactive expression.
library(shiny)
library(pwr)
ui <- fluidPage(
titlePanel("Sample Size and Power Calculator"),
sidebarLayout(
sidebarPanel(
#What are we calculating?
selectInput(inputId = "type",
label = strong("Calculator Options"),
choices = c("Pick an Option",
"Power",
"Sample Size"),
selected = "Pick an Option"),
#Display only if Sample Size is selected, ask for necessary parameters
conditionalPanel(
condition = "input.type == 'Sample Size'",
#1. Standard Deviation
numericInput(inputId = "stddev",
label = "Standard Deviation",
value = 10,
min = 1,
max = 400,
step = 1),
#2. Power
sliderInput(inputId = "power",
label = "Power of Study",
min = 0.5,
max = 0.99,
value = 0.8,
step = 0.01),
h6("Power as a decimal not percentage."),
h6("(0.8 means 80% power)"),
#3. Alpha (Significance)
sliderInput(inputId = "alpha",
label = "Significance of Study",
min = 0.01,
max = 0.2,
value = 0.05,
step = 0.01),
h6("Significance of study is most traditionally 0.05 (5%)"),
#4. Meandiff (Difference Between Groups)
numericInput(inputId = "meandiff",
label = "Expected Difference Between Group Means",
value = 20),
#5. Alternative Test
selectInput(inputId = "alt",
label = strong("Alternative Test Options"),
choices = c("Two-Sided" = "two.sided",
"Upper" = "greater",
"Lower" = "less"),
selected = "Two-Sided"),
h6("If unsure, leave at 'Two-Sided'.")
),
#Display only if Power is selected, ask for necessary parameters
conditionalPanel(
condition = "input.type == 'Power'",
#1. Standard Deviation
numericInput(inputId = "stddev",
label = "Standard Deviation",
value = 10,
min = 1,
max = 400,
step = 1),
#2. Size Per Group
numericInput(inputId = "npergroup",
label = "Number per Group",
value = 120),
h6("Assuming equal number in each group, enter number for ONE group."),
#3. Alpha (Significance)
sliderInput(inputId = "alpha",
label = "Significance of Study",
min = 0.01,
max = 0.2,
value = 0.05,
step = 0.01),
h6("Significance of study is most traditionally 0.05 (5%)"),
#4. Meandiff (Difference Between Groups)
numericInput(inputId = "meandiff",
label = "Expected Difference Between Group Means",
value = 20),
#5. Alternative Test
selectInput(inputId = "alt",
label = strong("Alternative Test Options"),
choices = c("Two-Sided" = "two.sided",
"Upper" = "greater",
"Lower" = "less"),
selected = "Two-Sided"),
h6("If unsure, leave at 'Two-Sided'.")
)
),
#Output:
mainPanel(
textOutput(outputId = "intro"),
textOutput(outputId = "desc"),
conditionalPanel(
condition = "input.type == 'Sample Size'",
textOutput(outputId = "samplesize")
),
conditionalPanel(
condition = "input.type == 'Power'",
textOutput(outputId = "power")
)
)
)
)
server <- function(input, output) {
#Introductory Text
output$intro <- renderText({
"Select an option and adjust the sliders and parameters."
})
#Description of what has been chosen
output$desc <- renderText({
paste("You chose: ", input$type)
})
#If Sample Size is selected, what is the sample size
output$samplesize <- renderText({
paste("Sample Size Per Group for Two-Sample t-test for Mean Diff
Assuming Two Groups and Equal Variances: ",
as.character(ceiling(pwr.t.test(d = input$meandiff / input$stddev,
sig.level = input$alpha,
power = input$power,
type = "two.sample",
alternative = input$alt)$n)))
})
#If Power is selected, what is the power
output$power <- renderText({
paste("Power for Two-Sample t-test for Mean Diff Assuming Two Groups and
Equal Variances: ",
format(round(pwr.t.test(d = input$meandiff / input$stddev,
sig.level = input$alpha,
n = input$npergroup,
type = "two.sample",
alternative = input$alt)$power * 100, 2),
nsmall = 2))
})
}
shinyApp(ui = ui, server = server)
It would be ideal that all the input ids are unique. Below I added 2 for those duplicated input ids. All of them are in the power analysis. After this change, the code works.
library(shiny)
library(pwr)
ui <- fluidPage(
titlePanel("Sample Size and Power Calculator"),
sidebarLayout(
sidebarPanel(
#What are we calculating?
selectInput(inputId = "type",
label = strong("Calculator Options"),
choices = c("Pick an Option",
"Power",
"Sample Size"),
selected = "Pick an Option"),
#Display only if Sample Size is selected, ask for necessary parameters
conditionalPanel(
condition = "input.type == 'Sample Size'",
#1. Standard Deviation
numericInput(inputId = "stddev",
label = "Standard Deviation",
value = 10,
min = 1,
max = 400,
step = 1),
#2. Power
sliderInput(inputId = "power",
label = "Power of Study",
min = 0.5,
max = 0.99,
value = 0.8,
step = 0.01),
h6("Power as a decimal not percentage."),
h6("(0.8 means 80% power)"),
#3. Alpha (Significance)
sliderInput(inputId = "alpha",
label = "Significance of Study",
min = 0.01,
max = 0.2,
value = 0.05,
step = 0.01),
h6("Significance of study is most traditionally 0.05 (5%)"),
#4. Meandiff (Difference Between Groups)
numericInput(inputId = "meandiff",
label = "Expected Difference Between Group Means",
value = 20),
#5. Alternative Test
selectInput(inputId = "alt",
label = strong("Alternative Test Options"),
choices = c("Two-Sided" = "two.sided",
"Upper" = "greater",
"Lower" = "less"),
selected = "Two-Sided"),
h6("If unsure, leave at 'Two-Sided'.")
),
#Display only if Power is selected, ask for necessary parameters
conditionalPanel(
condition = "input.type == 'Power'",
#1. Standard Deviation
numericInput(inputId = "stddev2",
label = "Standard Deviation",
value = 10,
min = 1,
max = 400,
step = 1),
#2. Size Per Group
numericInput(inputId = "npergroup",
label = "Number per Group",
value = 120),
h6("Assuming equal number in each group, enter number for ONE group."),
#3. Alpha (Significance)
sliderInput(inputId = "alpha2",
label = "Significance of Study",
min = 0.01,
max = 0.2,
value = 0.05,
step = 0.01),
h6("Significance of study is most traditionally 0.05 (5%)"),
#4. Meandiff (Difference Between Groups)
numericInput(inputId = "meandiff2",
label = "Expected Difference Between Group Means",
value = 20),
#5. Alternative Test
selectInput(inputId = "alt2",
label = strong("Alternative Test Options"),
choices = c("Two-Sided" = "two.sided",
"Upper" = "greater",
"Lower" = "less"),
selected = "Two-Sided"),
h6("If unsure, leave at 'Two-Sided'.")
)
),
#Output:
mainPanel(
textOutput(outputId = "intro"),
textOutput(outputId = "desc"),
conditionalPanel(
condition = "input.type == 'Sample Size'",
textOutput(outputId = "samplesize")
),
conditionalPanel(
condition = "input.type == 'Power'",
textOutput(outputId = "power")
)
)
)
)
server <- function(input, output) {
#Introductory Text
output$intro <- renderText({
"Select an option and adjust the sliders and parameters."
})
#Description of what has been chosen
output$desc <- renderText({
paste("You chose: ", input$type)
})
#If Sample Size is selected, what is the sample size
output$samplesize <- renderText({
paste("Sample Size Per Group for Two-Sample t-test for Mean Diff
Assuming Two Groups and Equal Variances: ",
as.character(ceiling(pwr.t.test(d = input$meandiff / input$stddev,
sig.level = input$alpha,
power = input$power,
type = "two.sample",
alternative = input$alt)$n)))
})
#If Power is selected, what is the power
output$power <- renderText({
paste("Power for Two-Sample t-test for Mean Diff Assuming Two Groups and
Equal Variances: ",
format(round(pwr.t.test(d = input$meandiff2 / input$stddev2,
sig.level = input$alpha2,
n = input$npergroup,
type = "two.sample",
alternative = input$alt2)$power * 100, 2),
nsmall = 2))
})
}
shinyApp(ui = ui, server = server)
I am building a simple RShiny App that calculates sample size and power, but I keep getting this error message---
Warning: Error in .getReactiveEnvironment()$currentContext: Operation not allowed without an active reactive context. (You tried to do something that can only be done from inside a reactive expression or observer.)
I couldn't figure out how to fix it. This is my first time using RShiny. If anyone can help, I really appreciate that! Thanks a lot!
library(shiny)
ui <- fluidPage(
headerPanel("Power and Sample Size Calculator"),
fluidRow(column(12,
wellPanel(
helpText("Two proportions (equal sample size in each group) power/sample size analysis"),
selectInput (inputId = "choice",
label = " Please Choose What You Want To Calculate",
c("Power","Sample Size"),selected = NULL,
multiple = FALSE,
selectize = TRUE, width = NULL, size = NULL)
)),
column(4,
wellPanel(
conditionalPanel(
condition = "input$choice = Power",
numericInput (inputId = "tau",
label = "Effect Size",
value = "0.2",
min = 0, max =1),
numericInput (inputId = "n",
label = "Sample Size in Each Group",
value = "200",
min = 0,
max = 100000000),
sliderInput (inputId = "alpha",
label = "Significance Level ⍺= ",
value = "0.05",
min = 0.001, max = 0.10)),
conditionalPanel(
condition = "input$choice=Sample Size",
numericInput (inputId = "tau",
label = "Effect Size",
value = "0.2",
min = 0, max =1),
sliderInput (inputId = "alpha",
label = "Significance Level ⍺= ",
value = "0.05",
min = 0.001, max = 0.10),
numericInput (inputId = "beta",
label = "Power",
value = "0.8",
min = 0,
max = 1))
)
),
column(8,
wellPanel(
htmlOutput("Result")
))
))
server <- function(input, output) {
choice <- switch (input$choice,
"Power" = 1, "Sample Size" = 2)
output$Result <- renderUI({
if(choice==1){
final=reactive({pwr.2p.test(h = input$tau, n = input$n, sig.level = input$alpha, power = )
})
}
if(choice==2){
final=reactive({pwr.2p.test(h = input$tau, n = , sig.level = input$alpha, power = input$beta)
})}
HTML(final)
}
)
}
shinyApp(ui=ui, server=server)
I don't think it is required to have reactive for final. try this below.
it works for me, except for pwr.2p.test, looks like that is some function you are trying to use. Also, I did not understand why you had HTML(final), use of renderUishould generate html by default. Let me know how did it go. Good luck
server <- function(input, output) {
choice <- reactive({
switch(input$choice,"Power" = 1,"Sample Size" = 2)})
output$Result <- renderUI({
if (input$choice == 'Power') {
pwr.2p.test( h = input$tau,
n = input$n,
sig.level = input$alpha,
power = input$beta
)}
if (input$choice == 'Sample Size') {
pwr.2p.test( h = input$tau,
n = ,
sig.level = input$alpha,
power = input$beta
)}
})
}