I have a package built so that I am able to test functions using test that. I have 2 scenarios where I test function. One scenario works fine (Sce. A) and other (Sce. B) does not work
Sce.B
## app.R (location : D:/Windows/Analytics/R Programming/GitHub/App/pacakge1)
library(shiny)
ui <- fluidPage(
numericInput("x", "X", value = 5),
textOutput("txt"),
actionButton("button", "Submit")
)
server <- function(input, output, session) {
server_1(input, output, session , y1)
}
shinyApp(ui, server)
## file. R (Location : D:/Windows/Analytics/R Programming/GitHub/App/pacakge1/R
server_1 <- function(input, output, session , y1){
y1 <- reactiveValues(a = 0)
function1 <- function(){
y1$a = 2 * input$x
}
observeEvent(input$button,{
function1()
})
output$txt <- renderText({
y1$a
})
}
## test server (location : D:/Windows/Analytics/R Programming/GitHub/App/pacakge1/tests/testthat)
library(testthat)
library(shinytest)
library(shiny)
testServer(expr = {
# y1 <- session$getReturned()
session$setInputs(x = 7)
function1()
expect_equal(y1$a, 14)
})
When I test above above scenario (Sce. B). It does not work well. So I need to test if y1$a returns 14 or not
But scenario A below works well since I am not writing server function outside
Sce.A
##app.R (Same location as above)
library(shiny)
ui <- fluidPage(
numericInput("x", "X", value = 5),
textOutput("txt"),
actionButton("button", "Submit")
)
server <- function(input, output, session) {
y1 <- reactiveValues(a = 0)
function1 <- function(){
y1$a = 2 * input$x
}
observeEvent(input$button,{
function1()
})
output$txt <- renderText({
y1$a
})
}
shinyApp(ui, server)
##test server (same location as above)
library(testthat)
library(shinytest)
library(shiny)
testServer(expr = {
# y1 <- session$getReturned()
session$setInputs(x = 7)
function1()
expect_equal(y1$a, 14)
})
Above test passes and allworks well..
But Scenario B is not working.
So the question is here, can we not test functions from other files?
Related
Suppose I have the following shiny app that renders a data table from the package DT:
library(shiny)
ui <- fluidPage(uiOutput("abc"))
server <- function(input, output, session) {
output$abc <- renderUI({DT::dataTableOutput("dt_output")}) # line 4
output$dt_output <- DT::renderDataTable({data.table(a = 1:3, b = 4:6)}) # line 5
}
runApp(list(ui = ui, server = server))
How would you combine lines 4 and 5, with the constraint that output$abc must remain a uiOutput?
My attempt at combining (the code below) led to an error, "cannot coerce type closure":
output$abc <- renderUI({DT::dataTableOutput(
DT::renderDataTable({data.table(a = 1:3, b = 4:6)}))})
This should work:
library(shiny)
ui <- fluidPage(
uiOutput("abc")
)
server <- function(input, output, session) {
output$abc <- renderUI({
output$aa <- DT::renderDataTable(head(mtcars))
DT::dataTableOutput("aa")
})
}
runApp(list(ui = ui, server = server))
I am trying to build an app which; 1) calculates the number of boxes, based on a data.frame, 2) For each box, creates a UI and a corresponding module that will trigger events when the action buttons are clicked, using a subset of that data.frame.
If I am not being explicit enough; the app has n UI's and in each UI, x buttons. I want to loop callModule to create n server functions so when I click on action button in any given UI, I trigger an event specific to that UI.
The problem I am having is that the callModule function apparently does not duplicate itself in a for loop. Instead, I always get only the last id and dataframe (as if the callModule overwrites itself).
I hope I was explicit enough. Here is a MWE:
server.R
library(shinydashboardPlus)
library(shiny)
library(shinydashboard)
source('modules.R')
shinyServer(function(input, output, session) {
# dataframe filtered / updated
dtst <- reactive({
iris[1:input$filter_d, ]
})
# number of items rendered
output$ui <- renderUI({
r <- tagList()
for(k in 1:input$n){
r[[k]] <- u_SimpleTaskView(id = k, d = dtst()[k, ]) # <- grab a subset or column of df
}
r
})
for(y in 1:isolate({input$n})){
callModule(m_UpdateTask, id = y, d = dtst()[, y])
}
})
ui.R
dheader <- dashboardHeaderPlus(title = "s")
dsidebar <- dashboardSidebar(
sidebarMenu(
menuItem("tst", tabName = "tst", icon = icon("bolt"))
)
)
dbody <- dashboardBody(
tabItems(
tabItem(tabName = "tst",
numericInput("n", "number of ui and module pairs", value = 10),
numericInput("filter_d", "RANDOM FILTER", value = 100),
uiOutput("ui")
)
) )
dashboardPagePlus(
title = "s",
header = dheader,
sidebar = dsidebar,
body = dbody
)
modules.R
u_SimpleTaskView <- function(id, d){
ns <- NS(id)
if(length(d) < 5){
# nothing
}else{
renderUI({
tagList(
br(),
HTML(paste0("<strong>Rows: </strong>", "xxxx")),
numericInput("divider", label = "number of rows", value = 2),
br(),
actionButton("go", "go")
)
})
}
}
m_UpdateTask <- function(input, output, session, d){
observeEvent(input$go, {
showModal(
modalDialog(
HTML(paste0("unique: ", length(unique(d))/input$divider ) )
)
)
})
}
Besides not being really minimal (no need for libraries shinydashboardPlus or shinydashboard) there are a couple of issues with your code.
renderUI is a server function not a UI function
If you create controls in the module UI you have to use the namespace function, otherwise you cannot use them in your module server function.
As it is a bit too complicated for me to debug your code directly, let me give you an example from which you can see how to use modules in the way you wanted:
library(shiny)
library(glue)
mod_ui <- function(id, base_df) { ## 3
ns <- NS(id) ## 1
tagList(
helpText(glue("The input parameter 'base_df' has {NROW(base_df)} rows.")),
numericInput(ns("n"), "n:", 2),
textOutput(ns("out"))
)
}
mod <- function(input, output, session) {
get_nr <- reactive(input$n) ## 2
output$out <- renderText(glue("Number selected: {get_nr()}"))
return(list(get_nr = get_nr)) ## 4
}
ui <- fluidPage(
numericInput("n", "number of uis:", 2),
uiOutput("uis"),
textOutput("sum")
)
server <- function(input, output, session) {
handlers <- list()
output$uis <- renderUI({
ret <- lapply(seq.int(input$n),
function(i) mod_ui(glue("mod_{i}"),
data.frame(x = seq.int(i)))) ## 5
tagList(ret)
})
observe(
handlers <<- lapply(seq.int(input$n),
function(i) callModule(mod, glue("mod_{i}"))) ## 6
)
output$sum <- renderText({ ## 7
req(length(handlers) > 0)
m_sum <- sum(sapply(handlers, function(h) h$get_nr()))
glue("Sum of all n: {m_sum}")
})
}
shinyApp(ui, server)
Explanation
In mod_ui we define all the elements one module should have. note the use of ns() for the controls' ids to make use of the namespacing.
In mod (the module server function) we can access controls as we would in the main server function ( i.e. directly liek in input$n.
We can pass arguments to any of the module's functions (like base_df).
If we want to use some of the reactives in the main app, we shoudl return them from the modules server function.
In our main app we use a loop to create the desired number of modules.
We use an observer to store the handlers from the modules in a list
We can access the modules reactives via the handler which we defined earlier.
Update 2021
shiny 1.5.0 introduced an easier interface for modules. The code below uses this "new" interface:
library(shiny)
library(glue)
mod_ui <- function(id, base_df) {
ns <- NS(id)
tagList(
helpText(glue("The input parameter 'base_df' has {NROW(base_df)} rows.")),
numericInput(ns("n"), "n:", 2),
textOutput(ns("out"))
)
}
mod <- function(id) {
moduleServer(id,
function(input, output, session) {
get_nr <- reactive(input$n)
output$out <- renderText(glue("Number selected: {get_nr()}"))
return(list(get_nr = get_nr))
}
)
}
ui <- fluidPage(
numericInput("n", "number of uis:", 2),
uiOutput("uis"),
textOutput("sum")
)
server <- function(input, output, session) {
handlers <- list()
output$uis <- renderUI({
ret <- lapply(seq.int(input$n),
function(i) mod_ui(glue("mod_{i}"),
data.frame(x = seq.int(i))))
tagList(ret)
})
observe({
handlers <<- lapply(seq.int(input$n),
function(i) mod(glue("mod_{i}")))
})
output$sum <- renderText({
req(length(handlers) > 0)
m_sum <- sum(sapply(handlers, function(h) {
res <- h$get_nr()
if(is.null(res)) {
0
} else {
res
}
}))
glue("Sum of all n: {m_sum}")
})
}
shinyApp(ui, server)
I'm trying to dynamically create some content with a for loop using renderUI and uiOutput but every rendered element only contains the information from the last iteration in the for loop. Example:
require(shiny)
ui <- fluidPage(
uiOutput("out1"),
uiOutput("out2")
)
server <- function(input, output, session) {
count <- 1
for(a in c("hello", "world")){
name <- paste0("out", count)
output[[name]] <- renderUI({
strong(a)
})
count <- count + 1
}
}
shinyApp(ui = ui, server = server)
This outputs world twice instead of hello world
It works when using sapply instead of a for loop:
require(shiny)
ui <- fluidPage(
uiOutput("out1"),
uiOutput("out2")
)
server <- function(input, output, session) {
vec <- c("hello", "world")
sapply(seq_along(vec), function(x) {
name <- paste0("out", x)
output[[name]] <- renderUI({
strong(vec[x])
})
})
}
shinyApp(ui = ui, server = server)
As an alternative to Alexandre's answer I figured out using local({}) also works thanks to Zygmunt Zawadzki's comment:
ui <- fluidPage(
uiOutput("out1"),
uiOutput("out2")
)
server <- function(input, output, session) {
count <- 1
for(a in c("hello", "world")){
local({
b <-a #this has to be added as well
name <- paste0("out", count)
output[[name]] <- renderUI({
strong(b)
})
})
count <- count + 1
}
}
shinyApp(ui = ui, server = server)
I have a shiny app that runs a simulation. The goal is to show the user the calculation steps in between as a plot.
How do I force shiny to update the plot?
An MWE would look like this
library(shiny)
server <- function(input, output, session) {
# base plot as a placeholder
output$myplot <- renderPlot(plot(1:1, main = "Placeholder"))
# wait until the button is triggered
observeEvent(input$run, {
print("Do some calculations in 3 steps")
for (i in seq_len(3)) {
print("Do some calculations")
# ...
x <- seq_len(i * 100)
y <- (x + 1)^2 - 1 # this will do for now
print("Plot the data ")
# ISSUE HERE!
# this should render the current step of the simulation, instead it
# renders only after the whole code is run (i.e., after step 3)
output$myplot <- renderPlot(plot(x, y, main = sprintf("Round %i", i), type = "l"))
print("Wait for 1 second for the user to appreciate the plot...")
Sys.sleep(1)
}
})
}
ui <- fluidPage(
actionButton("run", "START"),
plotOutput("myplot")
)
shinyApp(ui = ui, server = server)
The issue is, that shiny runs the code and produces one plot at the end of the simulation, however, I want to get a plot at each simulation step (displayed for at least one second).
Any help/hint is greatly appreciated.
Appendix
I have looked at this post, but replacing the text with a plot/renderPlot doesn't yield the correct results.
You could nest an observer into an observeEvent to make it work. Based on Jeff Allen's code from the SO topic you linked.
Crucial part:
observeEvent(input$run, {
rv$i <- 0
observe({
isolate({
rv$i <- rv$i + 1
})
if (isolate(rv$i) < maxIter){
invalidateLater(2000, session)
}
})
})
Full code:
library(shiny)
server <- function(input, output, session) {
rv <- reactiveValues(i = 0)
maxIter <- 3
output$myplot <- renderPlot( {
if(rv$i > 0) {
x <- seq_len(rv$i * 100)
y <- (x + 1)^2 - 1 # this will do for now
plot(x, y, main = sprintf("Round %i", rv$i), type = "l")
} else {
plot(1:1, main = "Placeholder")
}
})
observeEvent(input$run, {
rv$i <- 0
observe({
isolate({
rv$i <- rv$i + 1
})
if (isolate(rv$i) < maxIter){
invalidateLater(2000, session)
}
})
})
}
ui <- fluidPage(
actionButton("run", "START"),
plotOutput("myplot")
)
shinyApp(ui = ui, server = server)
Beginner to R and shiny here!
Tried to make a minimal working example... I want to check a condition on a reactive input value. What am I doing wrong?
library(shiny)
ui<-fluidPage(
numericInput(inputId="a", label=NULL, value=0),
textOutput(outputId="out")
)
server <- function(input, output) {
x <- reactive(input$a)
if (x() < 4)
{y<-1}
else
{y<-0}
output$out <- renderText({y})
}
shinyApp(ui = ui, server = server)
The error message:
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.)
You just need to use reactive with your if so that shiny knows that y changes when x does.
library(shiny)
ui<-fluidPage(
numericInput(inputId="a", label=NULL, value=0),
textOutput(outputId="out")
)
server <- function(input, output) {
x <- reactive(input$a)
y <- reactive( if (x()<4) 1 else 0 )
output$out <- renderText({ y() })
}
shinyApp(ui = ui, server = server)
The answer above from John Paul is certainly acceptable, but I thought you might like to see another way as a part of your learning process. I will let StackOverflow sort out which is more advisable.
library(shiny)
ui<-fluidPage(
numericInput(inputId="a", label=NULL, value=0),
textOutput(outputId="out")
)
server <- function(input, output) {
state <- reactiveValues()
observe({
state$x <- input$a
state$y <- ifelse(state$x < 4, 1, 0)
})
output$out <- renderText({ state$y })
}
shinyApp(ui = ui, server = server)
here's my attempt.
1) as stated, you don't need to wrap input$a in reactive context and save as x. just use input$a
2) you don't need reactiveValues in this simple example. just save y as a reactive variable. then, in the renderText, access by calling the function ("y()")
library(shiny)
ui<-fluidPage(
numericInput(inputId="a", label=NULL, value=0),
textOutput(outputId="out")
)
server <- function(input, output) {
y <- reactive({
if (input$a < 4) {
return(1)
} else {
return(0)
}
}
)
output$out <- renderText({y()})
}
shinyApp(ui = ui, server = server)