I am trying to write a Shiny app for a class I'm teaching that draws a random sample from a dataset and computes summary statistics. Whenever I press the reset button on the UI, a new subset should be sampled. Here is my code so far:
shinyServer(function(input, output) {
# Output for Ch. 1 Problems: Central Tendency
# Prepare data
observeEvent(input$Ch1.Prob.CT.reset, {
Ch1.Prob.CT.n <- sample(8:12, 1)
Ch1.Prob.CT.obs <- sample(1:nrow(cars), Ch1.Prob.CT.n)
})
data <- eventReactive(input$Ch1.Prob.CT.reset, {
cars[Ch1.Prob.CT.obs, 'dist', drop=F]
})
# Outputs
output$Ch1.Prob.CT.Data <- renderDataTable({
data()
})
output$Ch1.Prob.CT.Mean.out <- renderUI({
if (is.na(input$Ch1.Prob.CT.Mean.in)) { # Error checking
p("No answer provided")
} else if (round(input$Ch1.Prob.CT.Mean.in, digits = 4) == round(mean(Ch1.Prob.CT.data[,1]), digits = 4)) {
p("Correct", style = "color:green")
} else {
p("Incorrect", style = "color:red")
}
})
})
The problem is that the sample is not random; it is always the same, every time. Even when I press the reset button, the sample is exactly the same as the one before.
Why is Shiny not randomizing? And how can I make it randomize again?
Add a line such as
set.seed(as.integer(Sys.time()))
before you need random numbers
Such code:
observeEvent(input$xxx, {
x <- ...
})
f <- eventReactive(input$xxx, {
[do something with x]
})
does not work.
You can simply remove the observer and do:
f <- eventReactive(input$xxx, {
x <- ...
[do something with x]
})
If you want to use a variable subject to modifications inside an observer, you have to use a reactive list, like this :
values <- reactiveValues()
values$x <- [initial value of x]
observeEvent(input$xxx, {
values$x <- ...
})
(In addition, don't use some dots (.) in the names of the shiny elements.)
Related
Sorry if my question is a bit silly but I can't find a way of making to work a custom function that use reactiveValues as options.
I created several functions to do some "heavy processing" that I have put in global.R. These functions are something like this
estimateDEG <- function(variables = NULL, design = NULL, ...){
# do some processing for example
design <- model.matrix(variables$group[,1]
d <- estimateDisp(d, design))
suppressMessages(fit <- glmQLFit(d, design))
suppressMessages(out <- glmQLFTest(fit, coef = 2))
p <- out$table$PValue
p[is.na(p)] <- 1
variables$stat$p.value <<- p
variables$stat$rank <<- rank(p)
variables$stat$q.value <<- p.adjust(p, method = "BH")
variables$stat$logFC <<- out$table$logFC
... # more coding
}
Then I want to use this function in server.R
server.R
shinyServer(function(input, output, session) {
variables <- reactiveValues(
group = NULL,
stat = list()
)
# for example, I have a button that when it is clicked store some
# information in `variables$group` that I want to use in the function `estimateDEG`.
observeEvent(input$buttonList, {
group <- fread(input$groupSelectViaText, header = FALSE) # a TextAreaInput from ui.R
variables$group <- lapply(unique(group$V2), function(x) {
group[group$V2 == x, ]$V1
})
names(variables$group) <- unique(group$V2)
})
# and now I would like to use the estimateDEG function in another observeEvent
observeEvent(input$runButton, {
deg <- reactive(estimateDE(variables = variables,
test.method = input$testMethod, # another input from ui.R
FDR = input$fdr # another input f
))
})
However, when I run this code the reactiveValues are not updated, i.e, after running estimateDEG the variables$stat value is NULL. Is there any way of using a function inside server.r that use reactiveValues as options and update another values inside these reactiveValues? I would expect variables$stat to be populated with p.value, rank, q.value and so on
Many thanks in advance
Any time you're assigning to global in a shiny app, especially with <<- you've likely gone astray.
Reactive values are functions, and any argument passed is the new value of the function. To change the value of a reactive, you cannot use assign aka <-. This will just reassign the object from a reactive object to a static object in memory. You instead use the new value as the argument for the reactive function object. See below:
If you have the reactive value x, then want to assign its value to 3, you would use:
x <- reactiveVal(0)
# then
x(3)
print(x())
## 3
In your case, you need to pass the reactive object as a function to be called inside your custom made function. If x is a reactive value equal to 0, and I have a function that updates it:
f <- function(rval, newval) {
rval(newval)
}
f(x, 3)
x()
##3
To see that in action, the below is a quick demo app.
library(shiny)
# function that takes a reactive element as a function
# and returns that element's value plus some
# you can define this in global, under the /R directory
# or even in server.
add_some <- function(r_val, some) {
x <- r_val()
x <- x + some
r_val(x)
}
ui <- fluidPage(
sidebarLayout(
sidebarPanel(
actionButton("button", "Button"),
numericInput("some", "Some", 1)
),
mainPanel(
verbatimTextOutput("console")
)
)
)
server <- function(input, output, session) {
init <- reactiveVal(0)
observeEvent(input$button, ignoreInit = TRUE, {
add_some(init, input$some)
})
output$console <- renderPrint({
init()
})
}
shiny::runApp(list(ui = ui, server = server))
Hope that helps.
I am building a Shiny App that does random simulations of some stuff in three ways and saves the results in a table. I want the table to (1) fill the cell green for the closest value to the correct answer, and (2) include a line on bottom tracking total number of times each test group has been the closest.
what I have:
what I want:
Here's the code I'm using:
By the way, in this example there are ties, but that won't really be possible in the real thing, so probably not necessary to deal with.
#
# This is a Shiny web application. You can run the application by clicking
# the 'Run App' button above.
#
# Find out more about building applications with Shiny here:
#
# http://shiny.rstudio.com/
#
library(shiny)
# Define UI for application that draws a histogram
ui <- fluidPage(
# Application title
titlePanel("test"),
# Sidebar with a slider input for number of bins
sidebarLayout(
sidebarPanel(
actionButton("random_select",
"Generate Random Numbers",
width = 'auto')
),
# Show a plot of the generated distribution
mainPanel(
tableOutput("results_table_output")
)
)
)
# Define server logic required to draw a histogram
server <- function(input, output) {
counter <- reactiveValues(countervalue = 0)
observeEvent(input$random_select,{
counter$countervalue = counter$countervalue + 1
}
)
results <- reactiveValues(
table = list(trial = NA,
answer =NA,
test_1 = NA,
test_2 = NA,
test_3 = NA)
)
observeEvent(counter$countervalue,{
results$table$trial[counter$countervalue] <- as.integer(counter$countervalue)
results$table$answer[counter$countervalue] <- sample(1:10,1)
results$table$test_1[counter$countervalue] <- sample(1:10,1)
results$table$test_2[counter$countervalue] <- sample(1:10,1)
results$table$test_3[counter$countervalue] <- sample(1:10,1)
})
output$results_table_output <- renderTable({
results$table
})
}
# Run the application
shinyApp(ui = ui, server = server)
Disclaimer
I would also fall back to a more advanced table rendering engine like DT. However, in the following I show another solution which works with renderTable from "base" shiny.
renderTable + JS Solution
If you don't mind using some JavaScript you can use the following snippet:
library(shiny)
library(shinyjs)
js <- HTML("function mark_cells() {
$('.mark-cell').parent('td').css('background-color', 'steelblue');
}
function add_totals() {
const ncols = $('table th').length;
const $col_totals = Array(ncols).fill().map(function(el, idx) {
const $cell = $('<td></td>');
if (idx == 1) {
$cell.text('total:');
} else if (idx > 1) {
$cell.text($('table tr td:nth-child(' + (idx + 1) + ') .mark-cell').length);
}
return $cell;
})
$('table tfoot').remove();
$('table > tbody:last-child')
.after($('<tfoot></tfoot>').append($('<tr></tr>').append($col_totals)));
}
function mark_table() {
mark_cells();
add_totals()
}
")
make_run <- function(i, answer, tests = integer(3)) {
cn <- c("trial", "answer", paste0("test_", seq_along(tests)))
if (is.null(i)) {
line <- matrix(integer(0), ncol = length(cn))
colnames(line) <- cn
} else {
line <- matrix(as.integer(c(i, answer, tests)), ncol = length(cn))
colnames(line) <- cn
}
as.data.frame(line)
}
mark_best <- function(row) {
truth <- row[2]
answers <- row[-(1:2)]
dist <- abs(answers - truth)
best <- dist == min(dist)
answers[best] <- paste0("<span class = \"mark-cell\">", answers[best], "</span>")
c(row[1:2], answers)
}
ui <- fluidPage(
useShinyjs(),
tags$head(tags$script(js)),
sidebarLayout(
sidebarPanel(
actionButton("random_select",
"Generate Random Numbers")
),
mainPanel(
tableOutput("results_table_output")
)
)
)
server <- function(input, output, session) {
results <- reactiveVal(make_run(NULL))
observeEvent(input$random_select, {
res <- results()
results(rbind(res, make_run(nrow(res) + 1, sample(10, 1), sample(10, 3, TRUE))))
})
output$results_table_output <- renderTable({
res <- results()
if (nrow(res) > 0) {
res <- as.data.frame(t(apply(res, 1, mark_best)))
session$onFlushed(function() runjs("mark_table()"))
}
res
}, sanitize.text.function = identity)
}
shinyApp(ui = ui, server = server)
Explanation
In the renderTable function, we call mark_best where we surround the "winning" cells with <span class = "mark-cell">. This helps us on the JS side to identify which cells are the winners.
In order to not escape the HTML in it, we use the argument sanitize.text.function which is responsible for, well, sanitizing strings in the cell. Because we want to print them as is, we supply the identity function.
We include 3 JavaScript functions in the <head> of the document, which
color the parent <td> of our marked cells (mark_cells())
add column totals to the table. This is done by counting the .mark-cell marked cells in each column (add_totals)
a convenience wrapper to call both functions (mark_table())
In order to be able to actually call the JS function we rely on shinyjs. This is however, merely syntactic sugar and could be achieved otherwise as well (if you mind the additional library). To make shinyjs work, we need to include a call to useShinyjs in the UI.
All what is left to do is to call mark_table in the renderTable function. To make sure that the table is rendered properly, we do not call the JS function right away but use session$onFlushed to register the call to be run after the next flush happens.
I'm trying to have the user enter a numeric input, then generate a number of input boxes equal to that first numeric input. I would then like to find the sum of the responses to these secondary numeric inputs. However, I am having trouble accessing these variables in a comprehensive way, since their names are created used numeric variables. Right now when I run it I get this error:
Warning: Error in get: object 'inp21' not found
Thanks
library(shiny)
ui <- fluidPage(
# Application title
titlePanel("Test"),
sidebarLayout(
sidebarPanel(
numericInput("inp1",
"Enter num:",1)
),
mainPanel(
uiOutput("more_inp"),
textOutput("num_inps")
)
)
)
server <- function(input, output) {
counter <- reactiveValues(countervalue = 0)
counter2 <- reactiveValues(counter2value = 0)
output$more_inp <- renderUI({
#Generates number of numeric inputs equal to original numeric input
mylist <- lapply(1:input$inp1, function(i) {
inp_identifier <- paste("inp2", i, sep="")
inp_name<- paste("Input2",i,sep=" ")
list(
numericInput(inp_identifier,inp_name, 5)
)
})
do.call(tagList, unlist(mylist, recursive = FALSE))
})
#Display number of secondary inputs
#Count number of secondary inputs
observeEvent(input$inp1, {
counter$countervalue <- counter$countervalue + 1
})
#Find sum of secondary inputs
output$num_inps<-renderText(input$inp1)
observeEvent(input$inp1,{
for (i in 1:counter$countervalue) {
counter2$counter2value <- counter2$counter2value + get(paste("inp2", i, sep=""))
print(counter2$counter2value)
}
})
}
Run the application
shinyApp(ui = ui, server = server)
Additionaly to r2evans suggestion simply "filter" out the case when an input field cannot be found. It seems that this observeEvent is called before the other input fields can be created. As a consequence, you receive an empty vector (numeric(0)) when you try to access one of them.
observeEvent(input$inp1,{
for (i in 1:counter$countervalue) {
if (isTruthy(input[[paste0("inp2", i)]])) {
counter2$counter2value <- counter2$counter2value + input[[paste0("inp2", i)]]
print(counter2$counter2value)
}
}
})
You aren't checking for the presence before adding. The observeEvent block is firing aggressively, so even though counter$countervalue is 1, there are not additional input fields present, so input[[paste("inp2", i, sep="")]] returns NULL. Anything plus null is numeric(0).
How to find this
observeEvent(input$inp1,{
browser()
for (i in 1:counter$countervalue) {
counter2$counter2value <- counter2$counter2value + get(paste("inp2", i, sep=""))
print(counter2$counter2value)
}
})
Run your app. When it hits the debugger and shows you Browse[2]>, then
counter$countervalue
# [1] 1
counter2$counter2value
# [1] 0
i <- 1L
get(paste("inp2", i, sep=""))
# Error in get(paste("inp2", i, sep = "")) : object 'inp21' not found
input[[ paste("inp2", i, sep="") ]]
# NULL
names(input)
# [1] "inp1"
A quick check could be to look for that paste(.) name in names(input).
Tangent
for (i in 1:n) works fine as long as you are 100% certain that n here will always be 1 or greater. If there is the remote possibility that it will be <1, then the results will be rather unintuitive.
That is, if n is 0, then I would expect the for loop to do nothing. As a vector example,
for (nm in c('a','b')) ... # executes twice GOOD
for (nm in c()) ... # does not execute GOOD
for (i in 1:2) ... # executes twice GOOD
for (i in 1:0) ... # executes twice BAD
The reason is that 1:0 resolves to a reverse sequence, so seq(1, 0) and therefore c(1L, 0L).
A safer alternative if you expect a possible zero is seq_len:
seq_len(2)
# [1] 1 2
seq_len(0)
# integer(0)
(seq(1, length.out=n) is equivalent.)
An even safer alternative if you cannot guarantee "positive only", then
seq_len(max(0, n))
(since seq_len(-1) is an error).
Suggested solution
observeEvent(input$inp1,{
for (i in seq_len(counter$countervalue)) { # or max(0, ...)
nm <- paste("inp2", i, sep="")
if (nm %in% names(input)) {
counter2$counter2value <- counter2$counter2value + input[[nm]]
print(counter2$counter2value)
}
}
})
I am in my server.r file and trying to create an output via renderText with a conditional statement. The below code is throwing me the error:
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 have a feeling I have the architecture of this code wrong.
if (A > B)
{
output$sample <- renderText({ do some calculation)})
}
else if(A <= B)
{
output$sample <- renderText({do some other calculation)})
}
I have attempted to reformat to the below but get the same error. I feel I may be fundamentally wrong in my approach here. Any help welcomed.
output$sample <-
if (A > B)
{
renderText({ do some calculation)})
}
else if(A <= B)
{
renderText({do some other calculation)})
}
Server part where the issue was has been resolved here with some reactive objects. Please try this
ab <- reactive({req(input$account_value) - req(input$blocked_funds)})
# free funds
output$free_funds <- renderText({ab()})
# current margin
cm <- reactive({
req(input$account_value,input$blocked_funds)
if (input$account_value > input$blocked_funds){
curmargin <- round(input$account_value/(input$account_value+input$blocked_funds), digits = 2)
}else {
curmargin <- round((.5*(input$account_value))/input$blocked_funds, digits = 2)
}
})
output$current_margin <- renderText({cm()})
rm <- reactive({
req(input$account_value,input$blocked_funds)
round(input$account_value/(input$account_value + input$blocked_funds*2.5)*100,digits = 1)
})
# New margin
output$revised_margin <- renderText({
paste(rm(),"%",sep = "")
})
So I am writing an app that lets the user input some basic operations involving a matrix. At one part, they are asked to "return" the entire matrix, as they would in base R, for which they can either "call" the matrix with rows and columns [1:5,1:5] or simply put in the matrix's name (my.matrix, for instance). I am not able to get the second part working, however, as the app will crash and return the following error: Error in :: NA/NaN argument. I included the segment of code for this particular part in the server:
observeEvent( input$go6, {
sixthinput<- as.numeric(str_extract_all(input$six, "[0-9]+")[[1]])
string6 <- str_extract(input$six, "my.matrix")
sixth.list <- my.matrix[sixthinput[1]:sixthinput[2],sixthinput[3]:sixthinput[4]]
isolate({
buttonValue$go1 = FALSE
buttonValue$go2 = FALSE
buttonValue$go3 = FALSE
buttonValue$go4 = FALSE
buttonValue$go5 = FALSE
buttonValue$go6 = TRUE
buttonValue$go7 = FALSE
})
comparestring <- "my.matrix"
if (isTRUE(identical(sixth.list, my.matrix)) & buttonValue$go6) {
output$display <- renderText({
paste(c("The matrix you extracted contains:"))
})
output$displayMat <- renderTable(
sixth.list
)
output$display2 <- renderText({
print("Correct!")
})
} else if(isTRUE(identical(string6, comparestring)) & buttonValue$go6) {
output$display <- renderText({
paste(c("The matrix you extracted contains:"))
})
output$displayMat <- renderTable(
my.matrix
)
output$display2 <- renderText({
print("Correct!")
})
} else {
output$display <- renderText({
paste(c("The matrix you extracted contains:"))
})
output$displayMat <- renderTable(
sixth.list
)
output$display2 <- renderText({
print("Incorrect")
})
}
})
I am sure it has something to do with the variable "string6," "comparestring," and/or the part where I compare them in the if loop, but I am not sure where/how exactly it is going wrong, other than something is NA. Any clarification is appreciated.
The problem is in these lines:
sixthinput<- as.numeric(str_extract_all(input$six, "[0-9]+")[[1]])
string6 <- str_extract(input$six, "my.matrix")
sixth.list <- my.matrix[sixthinput[1]:sixthinput[2],sixthinput[3]:sixthinput[4]]
When the user inputs my.matrix with no subset operator ([), the value of sixthinput will be numeric(0) because there are no matching numbers. The value of sixthinput[1] will be NA, and you can’t then subset my.matrix by NA. The easiest way to avoid the error would be to check that length(sixthinput) == 4, and if not then avoid subsetting my.matrix.