Shiny - runif function inside reactive loop - r

hope someone can help with this one:
My code below was returning a dinamic table as I intend, but when I created the for loop to assign individually random numbers to each [k,p] position in the table all the calculations stop and I see an empty UI.
If instead of
rv$MCProbTable[[k,p]] = round(as.numeric(stats::runif(1,0,100)), 3)
I use for example
rv$MCProbTable[[k,p]] = 2
I see "2" allocated in each position in the table, what is close to what I want and shows that everything is working up to the runif application. So is it an issue with the function? Or most likely it is the reactive for loop that isn't set properly?
Thanks and hope this is an easy one!
## LIBRARIES
library(tidyverse)
library(stats)
library(data.table)
library(triangle)
library(base)
library(matrixStats)
library(ggplot2)
library(ggthemes)
library(readxl)
library(httr)
library(writexl)
library(shiny)
ExcelTemplate <- tempfile(fileext = ".xlsx")
GET(url = "https://www.openmontecarlo.com/SampleS.xlsx",write_disk(ExcelTemplate))
defaultRR <- read_xlsx(ExcelTemplate)
## DEFINE UI
ui <- fluidPage(
numericInput("ISvModels", label = h3("Select how many scenarios to run in the model:"),value=10,min=5,max=10000),
hr(),
mainPanel(
fluidRow(
p("vModels"),
textOutput("vModelsText"),
p("vtModels"),
textOutput("vtModelsText"),
p("Scenarios"),
textOutput("SnScenarios"),
h3(strong("ProbTable")),
br(),
dataTableOutput("SMCProbTable"),
hr()
)
)
)
server <- function(input, output, session) {
## CREATE DEFAULT RR AND REACTIVE VARIABLES
rv <- reactiveValues(
vModels = 10,
nScenarios = 10,
vtModelScenarios = NULL,
RRDT = data.frame(),
nRisks = 1,
MCProbTable = data.frame(),
p = 1,
k = 1
)
## PROCESS MODELS INPUT
observe({rv$vModels <- as.numeric(unlist(input$ISvModels))})
output$vModelsText <- renderPrint({unlist(rv$vModels)})
qtModels <- reactive({length(unlist(rv$vModels))})
output$qtModelsText <- renderPrint({unlist(qtModels())})
vtModels <- reactive({paste0("M",1:qtModels()," n = ",rv$vModels," scenarios")})
output$vtModelsText <- renderPrint({unlist(vtModels())})
## RR TABLE
observe({rv$nRisks <- nrow(defaultRR)})
###############################################################################################################
## CALCULATE SCENARIOS - CREATE DATA TABLES AND TEXT VECTORS FOR EACH SCENARIO
## Vectors for SINGLE scenario
observe({rv$nScenarios <- rv$vModels})
observe({rv$vtModelScenarios <- paste0("Scenario ",1:rv$nScenarios,"/",rv$vModels)})
## CREATE PROBABILITY TABLE AND CALCULATE PROBABILITIES
observe({rv$MCProbTable <- data.frame(matrix(nrow=rv$nRisks,ncol=rv$nScenarios))})
observe({rownames(rv$MCProbTable) <- rv$RRDT$ID})
observe({colnames(rv$MCProbTable) <- rv$vtModelScenarios})
observe({
for (p in 1:rv$nScenarios){
for (k in 1:rv$nRisks){
rv$MCProbTable[[k,p]] = round(as.numeric(stats::runif(1,0,100)), 3)
}
}
})
output$SMCProbTable <- renderDataTable({rv$MCProbTable})
}
# Run the app ----
shinyApp(ui = ui, server = server)

In your for loop, use isolate()
for (p in 1:rv$nScenarios){
for (k in 1:rv$nRisks){
isolate(
rv$MCProbTable[k,p] <- round(as.numeric(stats::runif(1,0,100)), 3)
)
}
}

Related

Pass reactive object as input to function in a shiny app

In the shiny app below I want to pass as input in the initialize_NN() function the layers() which is a reactive object. But when I try to pass it as layers() instead of layers I get an error in my console like unexpected token'layers',expected RPAREN. Any solution to this or any workaround?The initialize_NN() do not expect to give something now but I just want to know how could I pass reactive input into it.
library(shiny)
library(dplyr)
### user inter phase
ui <- fluidPage(
### App title ----
titlePanel(
#title=div(img(src="pics/IRP_NHSc.jpg", width="99%"))
title="Network App"
)
,
# Sidebar layout with input and output definitions ----
sidebarLayout(
# Sidebar panel for inputs ----
sidebarPanel(
sliderInput("lay","Adjust layers",min=2,max = 6,value = 2,step=1),
sliderInput("neu","Adjust Neurons",min=10,max = 60,value = 50,step=1)
),
### Main panel for displaying outputs ----
mainPanel(
)
)
)
#### Server
server <- function(input, output, session) {
layers <- reactive({
l<-c(1, rep(input$neu, input$lay), 1)
})
initialize_NN <- function(layers()){
weights <-c()
biases <- c()
num_layers <- length(layers())-1
for (i in seq(num_layers)){
W <- xavier_init(c(layers()[i], layers()[i+1]))
weights <- c(weights, W)
biases <- c(biases, b)
}
return(list(Weights = weights, Biases = biases))
}
obj <- initialize_NN(layers=layers())
weights <- obj$Weights
biases <- obj$Biases
neural_net <- function(x_, weights, biases){
num_layers <- length(weights) + 1
H <- x_
for (l in seq(num_layers-2)){
W <- weights[[l]]
b <- biases[[l]]
H <- tf$nn$tanh(tf$add(tf$matmul(H, W), b))
}
W <- tail(weights, n=1)[1]
b <- tail(biases, n=1)[1]
Y <- tf$add(tf$matmul(H, W), b)
return(Y)
}
}
shinyApp(ui = ui, server = server)
Define function initialize_NN() with "normal" arguments:
initialize_NN <- function(layers){
weights <-c()
biases <- c()
num_layers <- length(layers)-1
for (i in seq(num_layers)){
W <- xavier_init(c(layers[i], layers[i+1]))
weights <- c(weights, W)
biases <- c(biases, b)
}
return(list(Weights = weights, Biases = biases))
}
Then wherever you call the function pass your reactive as the argument layers:
initialize_NN(layers = layers())
Edit 1:
As #jpdugo17 pointed out in the comments, it needs to be done inside a reactive context: whether a reactive(), observe(), observeEvent() etc.
For example:
r_NN <- reactive({
initialize_NN(layers = layers())
})

Update variable created by eventReactive in another observeEvent

I'm struggling to update a reactive variable, that is created with eventReactive(), in an observeEvent() with new data.
The background is following: I have a data.frame df with some variables (x and y) and number of observations depending on the selected city (created randomly for this example).
x and y are initialized with zeros.
Because I need to further process df, I pass df to city_df in an eventReactive().
So far, so good. Next, I want to add new data to city_df. The computation of this new data is dependent on the "compute" actionButton (input$compute), wherefore I update city_df in an observeEvent(). I manage to read the data stored in city_df, but I am struggling to overwrite its content.
Actually, I am a bit unsure if this is possible at all, but I hope that some of you could give me a hint on how to update the reactive variable city_df with the new data in this observeEvent() and have its output evaluated in the app(?).
library(shiny)
# global variables
cities <- c("Nairobi", "Kansas", "Uppsala", "Sangon", "Auckland", "Temuco")
# ui
ui <- fluidPage(
fluidPage(
fluidRow(
column(2,
selectInput("city", "Select city",
choices = cities,
selected = sample(cities,
size = 1)
),
actionButton("compute",
"Compute")),
column(8,
verbatimTextOutput("the_city"))
))
)
# server
server <- function(input, output, session) {
# create variable
city_df <- eventReactive(input$city, {
len <- round(runif(1, 20, 50), 0)
df <- data.frame(city = rep(input$city, len))
# initialize x and y with zeros
df <- cbind(df,
data.frame(x = rep.int(0, len),
y = rep.int(0, len)))
})
output$the_city <- renderText({
paste(city_df())
})
observeEvent(input$compute, {
# grab data
test <- city_df()
# compute new data
test$x <- runif(dim(test)[1], 11, 12)
test$y <- runif(dim(test)[1], 100, 1000)
# and how to send this values back to city_df?
})
}
# run app
shinyApp(ui, server)
The actual app is far more complex--so forgive me if this MWE app seems a bit overly complicated to achieve this usually simple task (I hope I managed to represent the more complex case in the MWE).
Instead of a data.frame, I am parsing layers of a GeoPackage and append some variables initialized with zeros. The selected layer is displayed in a Leaflet map. On pressing the "compute" button, a function computes new data that I wish to add to the layer to then have it displayed on the map.
The alternative solution I have on mind is to write the new data to the GeoPackage and then, reread the layer. However, I would appreciate if I could avoid this detour as loading the layer takes some time...
Many thanks :)
Rather than using an eventReactive, if you use a proper reactiveVal, then you can change the value whenever you like. Here's what that would look like
server <- function(input, output, session) {
# create variable
city_df <- reactiveVal(NULL)
observeEvent(input$city, {
len <- round(runif(1, 20, 50), 0)
df <- data.frame(city = rep(input$city, len))
# initialize x and y with zeros
df <- cbind(df,
data.frame(x = rep.int(0, len),
y = rep.int(0, len)))
city_df(df)
})
output$the_city <- renderText({
paste(city_df())
})
observeEvent(input$compute, {
# grab data
test <- city_df()
test$x <- runif(dim(test)[1], 11, 12)
test$y <- runif(dim(test)[1], 100, 1000)
city_df(test)
})
}
So calling city_df() get the current value and calling city_df(newval) updates the variable with a new value. We just swap out the eventReactive with observeEvent and do the updating ourselves.

How to make the plot reactive to user input?

In the below super-simple MWE code, I'm trying to make the plot reactive to user slider input 'periods'. I've tried various iterations of observeEvent with no luck. Can someone please help me make this reactive?
The plot is supposed to show endBal on the y-axis and periods on the x-axis.
Also, in the below line of MWE code, res <- Reduce(f,seq(periods),init=beginBal,accumulate=TRUE) is not picking up the value of periods from the slider input. Instead to make the MWE run for demo I have to manually define the periods variable in the "Define vectors" section at the top of the code (periods <- 5 for example). Any idea why this part isn't working?
library(shiny)
### Define vectors ##############################################################
beginBal <- 1000
yield_vector <- c(0.30,0.30,0.30,0.30,0.30,0.28,0.26,0.20,0.18,0.20)
npr_vector <- c(0.30,0.30,0.30,0.30,0.30,0.30,0.30,0.30,0.30,0.30)
mpr_vector <- c(0.20,0.20,0.20,0.20,0.20,0.20,0.20,0.20,0.20,0.20)
default_vector <- c(0.10,0.10,0.10,0.10,0.10,0.09,0.08,0.07,0.06,0.05)
### End define vectors ##########################################################
ui <- fluidPage(
sliderInput(inputId = "periods",
label = "Periods:",
min = 1,
max = 10,
value = 5),
plotOutput(outputId = "balancePlot")
) # close fluid page
server <- function(input,output){
### Generates data for plotting ###############################################
f <- function(x,y){x*(1+npr_vector[y]-mpr_vector[y]-default_vector[y]/12)}
res <- Reduce(f,seq(periods),init=beginBal,accumulate=TRUE)
b <- head(res,-1)
endBal <- res[-1]
### End data for plotting #####################################################
output$balancePlot <- renderPlot({plot(endBal)})
} # close server
shinyApp(ui = ui, server = server)
Try this
output$balancePlot <- renderPlot({
f <- function(x,y){x*(1+npr_vector[y]-mpr_vector[y]-default_vector[y]/12)}
res <- Reduce(f,seq(input$periods),init=beginBal,accumulate=TRUE)
b <- head(res,-1)
endBal <- res[-1]
plot(endBal)
})

How to load down-sampled data while zooming in R dygraph?

I created an R shiny application that has a dygraph based on a data table that is dynamically subsetted by a checkboxGroupInput. My problem is, when I attempt to load large amounts of data (millions of records), it loads very slowly and/or crashes.
After doing some more research, I stumbled upon a "lazy-load" technique from here. Based on my understanding, this technique essentially downsamples the data by only loading the number of data points equal to the width of the dygraph window. As the user zooms in, it will drill down and load more data within the dyRangeSelector max/min dates. I suspect this will solve my problem, because it will load significantly less data at any given dygraph interaction. However, all of the examples provided in this link were in Javascript, and I'm having trouble translating it to R.
I also attempted to treat the GraphDataProvider.js file as a dygraph plugin, but I was unable to get it to work properly.
A couple of quick notes on my implementation:
Each element of data_dict in the server is an xts object.
The do.call.cbind function call in the server is based off of this SO implementation, and it is very fast.
My current setup is essentially like this (I refactored it to make it generic):
Data Setup:
library(shiny)
library(shinydashboard)
library(dygraphs)
library(xts)
library(data.table)
start <- as.POSIXlt("2018-07-09 00:00:00","UTC")
end <- as.POSIXlt("2018-07-11 00:00:00","UTC")
x <- seq(start, end, by=0.5)
data <- data.frame(replicate(4,sample(0:1000,345601,rep=TRUE)))
data$timestamp <- x
data <- data[c("timestamp", "X1", "X2", "X3", "X4")]
data <- as.data.table(data)
filters <- c("X1","X2","X3","X4")
data_dict <- vector(mode="list", length=4)
names(data_dict) <- filters
data_dict[[1]] <- as.xts(data[,c('timestamp','X1')]); data_dict[[2]] <- as.xts(data[,c('timestamp','X2')])
data_dict[[3]] <- as.xts(data[,c('timestamp','X3')]); data_dict[[4]] <- as.xts(data[,c('timestamp','X4')])
# Needed to quickly cbind the xts objects
do.call.cbind <- function(lst){
while(length(lst) > 1) {
idxlst <- seq(from=1, to=length(lst), by=2)
lst <- lapply(idxlst, function(i) {
if(i==length(lst)) { return(lst[[i]]) }
return(cbind(lst[[i]], lst[[i+1]]))})}
lst[[1]]}
UI:
header <- dashboardHeader(title = "App")
body <- dashboardBody(
fluidRow(
column(width = 8,
box(
width = NULL,
solidHeader = TRUE,
dygraphOutput("graph")
)
),
column(width = 4,
box(
width = NULL,
checkboxGroupInput(
"data_selected",
"Filter",
choices = filters,
selected = filters[1]
),
radioButtons(
"data_format",
"Format",
choices=c("Rolling Averages","Raw"),
selected="Rolling Averages",
inline=TRUE
)
)
)
)
)
ui <- dashboardPage(
header,
dashboardSidebar(disable=TRUE),
body
)
Server:
server <- function(input, output) {
# Reactively subsets the dataset based on checkboxGroupInput filters
the_data <- reactive({
data <- do.call.cbind(data_dict[input$data_selected]) # Column bind multiple xts objects
})
output$graph <- renderDygraph({
graph <- dygraph(the_data()) %>%
dyRangeSelector(c("2018-07-10 00:00:00","2018-07-10 02:00:00")) %>%
dyOptions(useDataTimezone = TRUE,connectSeparatedPoints = TRUE)
if(input$data_format == "Rolling Averages") graph <- graph %>% dyRoller(rollPeriod = 100)
graph
})
}
Make App:
shinyApp(ui, server)
I would appreciate any help I can get on this, this has stumbled me for a while now. Thank you!

R Shiny dataTableOutput don't work if using loop of reactive image

I'm using R software and EBImage package to image analysis.
I have an image with several frames that i load locally.
I want to show a dataTable output of features (compute.Features.basic). I want to bind each dataframe (each frame) to a total one. But it doen't work properly. If i do the same with a non reactive image, it works ok. So, it's something about the reactive image.
Here is an example:
## Only run examples in interactive R sessions
if (interactive()) {
shinyApp(
ui = fluidPage(
fileInput('input.image',""),
dataTableOutput("tabledata")
),
server = function(input, output) {
# Load Image
img <- reactive({
if (is.null(input$input.image))
return(NULL)
x <- readImage(input$input.image$datapath)
})
# Modified Image
img_bw <- reactive({
req( img() )
x <- img()
x <- gblur(x, sigma = 5)
x <- thresh(x, w = 15, h = 15, offset = 0.05)
x <- bwlabel(x)
})
# Create empty datagrame
dt <- data.frame()
# Calculate cell features for each frame and rbind frame-dataframe to total
data <- reactive({
for (i in 1:numberOfFrames(img())){
dt <- rbind(dt, computeFeatures.basic(img_bw()[,,i], img()[,,i]))
}
})
# Otuput
output$tabledata <- renderDataTable(data())
}
)
}
Ok, I solved simply introducing the creation of temporal dataframe into the reactive function and calling the dataframe:
## Only run examples in interactive R sessions
if (interactive()) {
shinyApp(
ui = fluidPage(
fileInput('input.image',""),
dataTableOutput("tabledata")
),
server = function(input, output) {
# Load Image
img <- reactive({
if (is.null(input$input.image))
return(NULL)
x <- readImage(input$input.image$datapath)
})
# Modified Image
img_bw <- reactive({
req( img() )
x <- img()
x <- gblur(x, sigma = 5)
x <- thresh(x, w = 15, h = 15, offset = 0.05)
x <- bwlabel(x)
})
# Calculate cell features for each frame and rbind frame-dataframe to total
data <- reactive({
# Create empty datagrame
dt <- data.frame()
# Use dt dataframe
for (i in 1:numberOfFrames(img())){
dt <- rbind(dt, computeFeatures.basic(img_bw()[,,i], img()[,,i]))
}
# Print dt dataframe
dt
})
# Otuput
output$tabledata <- renderDataTable(data())
}
)
}

Resources