Shiny feedbackDanger doesnt work inside eventReactive where function is called - r

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)

Related

Delet an outputTable with a actionButton Shiny R

I'm trying show the TableOuput first, according to the user inputs, there are: "media" and "desv_pad". When I click on the button "rodar", the table is showed. After that, I need to delete the output Table "saida" when a press the actionButton "reset", then my interface will be clean to receive new inputs and run again, but my code isn't working.
library(shiny)
ui <- fluidPage(
sidebarLayout(
sidebarPanel("Inputs",
numericInput(inputId = "media",
label = "Mean:",
value = 0,
min = 0),
numericInput(inputId = "desv_pad",
label = "Standard Deviation:",
value = 1,
min = 0),
numericInput(inputId = "delta",
label = "Mean Shift:",
value = 0.5,
min = 0,
max = 2,
step = 0.25),
numericInput(inputId = "n",
label = "Size of Samples:",
value = 5,
min = 0,
max = 10,
step = 1),
numericInput(inputId = "alfa",
label = "% alpha",
value = 0.27,
min = 0,
step = 0.1),
numericInput(inputId = "beta",
label = "% beta:",
value = 97,
min = 0,
step = 0.1),
numericInput(inputId = "xb_teo",
label = "%X max:",
value = 10,
min = 0),
actionButton("rodar", "Run")
),
mainPanel(
tags$h4( tableOutput('saida')),
tags$br(),
tags$br(),
tags$br(),
tags$br(),
tags$br(),
tags$br(),
actionButton("reset", "Reset")
)
)
)
server <- function(input, output)
{
v <- reactiveValues(data = NULL)
observeEvent(input$rodar,{
output$saida <- renderTable({ #resultado,
passo_n <- 0
#Recebendo os inputs:
n <-input$n
Xb_teo <- input$xb_teo# input Xbarra percentual teorico definido pelo usuario
med<- input$media #input da media
desv_pad <- input$desv_pad #input do desvio padrao
alfa <- input$alfa #% determinado pelo usuario
beta <- input$beta #% determinado pelo usuario
delta <- input$delta
v$data <- c(n, Xb_teo,med, desv_pad, alfa, beta, delta)
})
})
observeEvent(input$reset, {
v$data <- NULL
})
output$saida <- renderTable({
if(is.null(v$data)) return()
v$data
})
}
shinyApp(ui = ui, server = server)
There are lot of undefined variables in your code. I have replaced them with constants for now.
Put output$saida outside observeEvent. Try this app :
library(shiny)
ui <- fluidPage(
sidebarLayout(
sidebarPanel("Inputs",
numericInput(inputId = "media",
label = "Mean:",
value = 0,
min = 0),
numericInput(inputId = "desv_pad",
label = "Standard Deviation:",
value = 1,
min = 0),
numericInput(inputId = "delta",
label = "Mean Shift:",
value = 0.5,
min = 0,
max = 2,
step = 0.25),
numericInput(inputId = "n",
label = "Size of Samples:",
value = 5,
min = 0,
max = 10,
step = 1),
numericInput(inputId = "alfa",
label = "% alpha",
value = 0.27,
min = 0,
step = 0.1),
numericInput(inputId = "beta",
label = "% beta:",
value = 97,
min = 0,
step = 0.1),
numericInput(inputId = "xb_teo",
label = "%X max:",
value = 10,
min = 0),
actionButton("rodar", "Run")
),
mainPanel(
tags$h4( tableOutput('saida')),
tags$br(),
tags$br(),
tags$br(),
tags$br(),
tags$br(),
tags$br(),
actionButton("reset", "Reset")
)
)
)
server <- function(input, output)
{
v <- reactiveValues(data = NULL)
observeEvent(input$rodar,{
passo_n <- 0
#Recebendo os inputs:
n <-input$n
Xb_teo <- input$xb_teo# input Xbarra percentual teorico definido pelo usuario
med<- input$media #input da media
desv_pad <- input$desv_pad #input do desvio padrao
alfa <- input$alfa #% determinado pelo usuario
beta <- input$beta #% determinado pelo usuario
delta <- input$delta
v$data <- c(n, Xb_teo,med, desv_pad, alfa, beta, delta)
})
observeEvent(input$reset, {
v$data <- NULL
})
output$saida <- renderTable({
v$data
})
}
shinyApp(ui = ui, server = server)

How to trigger observeEvent and action with different input types in R Shiny?

What I have
I made a Shiny app that shows a plot with some points.
You can manually change the y axis. There is a button that allows to automatically adjust the y axis so it fits the data. There is a drop-down box that allows you to select data.
I have this code:
library(shiny)
# user interface ----------------------------------------------------------
ui <- fluidPage(
fluidRow(plotOutput("myplot")),
tabsetPanel(
tabPanel(
"Input",
fluidRow(
column(
2,
numericInput(inputId = "ymax", label = "y-axis maximum", value = 30),
numericInput(inputId = "ymin", label = "y-axis minimum", value = 9),
actionButton("fity", label = "zoom to fit")
),
column(
2,
selectInput(inputId = "yaxis", label = "y-axis",
choices = list("1 to 5" = 1,
"3 to 7" = 2)
),
checkboxInput("mybx", label = "checkbox", value = TRUE)
)
)
),
fluidRow()
)
)
# server function ---------------------------------------------------------
server <- function(input, output, session) {
ydata <- reactive({
switch(input$yaxis,
"1" = {
updateCheckboxInput(session, "mybx", value = TRUE)
1:5},
"2" = {
updateCheckboxInput(session, "mybx", value = FALSE)
3:7}
)
})
observeEvent(input$fity, {
newymax <- trunc(max(ydata())) + 1
newymin <- trunc(min(ydata()))
updateNumericInput(session, "ymax", value = newymax)
updateNumericInput(session, "ymin", value = newymin)}
)
output$myplot <- renderPlot({
par(mar = c(4, 4, 0.1, 0.1))
plot(x = 1:5, y = ydata(), ylim = c(input$ymin, input$ymax))
})
}
shinyApp(ui = ui, server = server)
What I want to do
I want that the fit-y-axis code triggered by the action button will also be triggered when I'm changing the data with the dropdown box.
Things I've tried:
This. But I think it doesn't like getting a selectInput together with the button.
Putting the fit-y-axis code into a separate function, calling the function from both ydata <- reactive and observeEvent. Did not work. Cries about recursion (obviously - it's calling ydata again from inside ydata!).
Any help would be appreciated.
Why not just have another observeEvent that monitors the change in the yaxis input?
library(shiny)
# user interface ----------------------------------------------------------
ui <- fluidPage(
fluidRow(plotOutput("myplot")),
tabsetPanel(
tabPanel(
"Input",
fluidRow(
column(
2,
numericInput(inputId = "ymax", label = "y-axis maximum", value = 30),
numericInput(inputId = "ymin", label = "y-axis minimum", value = 9),
actionButton("fity", label = "zoom to fit")
),
column(
2,
selectInput(inputId = "yaxis", label = "y-axis",
choices = list("1 to 5" = 1,
"3 to 7" = 2)
),
checkboxInput("mybx", label = "checkbox", value = TRUE)
)
)
),
fluidRow()
)
)
server <- function(input, output, session) {
ydata <- reactive({
switch(input$yaxis,
"1" = {
updateCheckboxInput(session, "mybx", value = TRUE)
1:5},
"2" = {
updateCheckboxInput(session, "mybx", value = FALSE)
3:7}
)
})
observeEvent(input$fity, {
newymax <- trunc(max(ydata())) + 1
newymin <- trunc(min(ydata()))
updateNumericInput(session, "ymax", value = newymax)
updateNumericInput(session, "ymin", value = newymin)}
)
observeEvent(input$yaxis, {
newymax <- trunc(max(ydata())) + 1
newymin <- trunc(min(ydata()))
updateNumericInput(session, "ymax", value = newymax)
updateNumericInput(session, "ymin", value = newymin)}
)
output$myplot <- renderPlot({
par(mar = c(4, 4, 0.1, 0.1))
plot(x = 1:5, y = ydata(), ylim = c(input$ymin, input$ymax))
})
}
shinyApp(ui = ui, server = server)
But this makes your 'zoom to fit' button redundant.

R shiny bigger window

Can you guys help me, how not to need to scroll, or make the window of the application bigger, so you can see the slider bars and plots at once? Or that slidebar and the plot will be side by side.see picture
Here is the code:
library(deSolve)
library(shiny)
ui <- verticalLayout(
titlePanel("Zvolte údaje"),
sliderInput(inputId = "time_values", label = "Počet dnů", value = 10, min = 1, max = 100),
sliderInput(inputId = "beta", label ="Míra nákazy", value = 0.05, min = 0, max = 1, step = 0.01),
sliderInput(inputId = "gamma", label ="Míra uzdravení", value = 0.5, min = 0, max = 1, step = 0.1),
(plotOutput("plot"))
)
server <- function(input, output) {
sir_equations <- function(time, variables, parameters) {
with(as.list(c(variables, parameters)), {
dS <- -beta * I * S
dI <- beta * I * S - gamma * I
dR <- gamma * I
return(list(c(dS, dI, dR)))
})
}
initial_values <- c(S = 1000, I = 1, R = 0)
sir_values_1 <- reactiveValues(val = data.frame())
observe({
sir_values_1$val <- as.data.frame(ode(
y = initial_values,
times = seq(0, input$time_values),
func = sir_equations,
parms = c(beta=input$beta, gamma=input$gamma)
))
})
output$plot <- renderPlot({
with(sir_values_1$val, {
plot(sir_values_1$val$time, sir_values_1$val$S, type = "l", col = "blue",
xlab = "Doba (dny)", ylab = "Počet lidí")
lines(sir_values_1$val$time, sir_values_1$val$I, col = "red")
lines(sir_values_1$val$time, sir_values_1$val$R, col = "green")
legend("right", c("zdraví", "nakažení", "uzdravení"),
col = c("blue", "red", "green"), lty = 1, bty = "n")
})
})
}
shinyApp(ui = ui, server = server)
Thank you
I'm not familiar with verticalLayout() but if you use fluidPage() you can achieve this result.
I also simplified your code to an example everyone can run. You'll receive more help when you simplify your code as much as possible; remove as many libraries as you can, simplify your data set and reactive values, etc.
library(shiny)
ui <- fluidPage(
titlePanel("Zvolte údaje"),
fluidRow(
column(width = 4,
sliderInput(inputId = "bins", label = "Number of bins:", min = 1, max = 50, value = 30),
sliderInput(inputId = "beta", label ="Slider 2", value = 0.05, min = 0, max = 1, step = 0.01),
sliderInput(inputId = "gamma", label ="Slider 3", value = 0.5, min = 0, max = 1, step = 0.1)
),
column(width = 8,
plotOutput("plot")
)
)
)
server <- function(input, output) {
output$plot <- renderPlot({
x <- faithful$waiting
bins <- seq(min(x), max(x), length.out = input$bins + 1)
hist(x, breaks = bins, col = "#75AADB", border = "white",
xlab = "Waiting time to next eruption (in mins)",
main = "Histogram of waiting times")
})
}
shinyApp(ui = ui, server = server)

Calculate in Shinyapps

I want to calculate some values and return the values to my shiny app:
ui <- fluidPage(
sidebarLayout(
sidebarPanel(numericInput(inputId = "ME",
label = "Maternal effect:",
min = -1,
max = 1,
value = 0.5),
numericInput(inputId = "CE",
label = "Child effect:",
min = -1,
max = 1,
value = 0.5)
),
mainPanel(h3(textOutput("Power"))
)
)
)
server <- function(input, output) {
bzc <- sqrt(abs(input$CE)) * sign(input$CE)
bzm <- sqrt(abs(input$ME)) * sign(input$ME)
results <- bzc * bzm
output$Power <- renderPrint({results
})
}
shinyApp(ui = ui, server = server)
This doesnt apprear to work. Any tips on how to calculate in the shiny app?
The error-messages arise, because you have input-objects outside of the render-functions. If you want to calculate something, which you want to reuse in multiple plots, then use a reactive or observe-function.
For all other cases it is enough add the code for bzc, bzm and result inside the render-functions:
ui <- fluidPage(
sidebarLayout(
sidebarPanel(numericInput(inputId = "ME",
label = "Maternal effect:",
min = -1,
max = 1,
value = 0.5),
numericInput(inputId = "CE",
label = "Child effect:",
min = -1,
max = 1,
value = 0.5)
),
mainPanel(h3(textOutput("Power"))
)
)
)
server <- function(input, output) {
output$Power <- renderPrint({
bzc <- sqrt(abs(input$CE)) * sign(input$CE)
bzm <- sqrt(abs(input$ME)) * sign(input$ME)
results <- bzc * bzm
results
})
}
shinyApp(ui = ui, server = server)

RShiny reactive error

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
)}
})
}

Resources