Using Shiny App to dynamically visualise each iteration of string replacement? - r

I would like to modify the input and display the output of some R code in a more interactive way. I think that this would be an ideal task for a Shiny app, but I am not very familiar with writing them. I have some R code that takes a string of text and iteratively changes it by adding letters or words at random locations:
library(tidyverse)
evolve_sentence <- function(sentence, arg2) {
chars <- str_split(sentence, "") %>% pluck(1)
if (runif(1) > 0.5) {
chars[sample(1:length(chars), 1)] <- sample(chars, 1)
}
sentence <- str_c(chars, collapse = "")
words <- str_split(sentence, " ") %>% pluck(1)
if (runif(1) > 0.9) {
words[sample(1:length(words), 1)] <- sample(words, 1)
}
sentence <- str_c(words, collapse = " ")
sentence
}
tbl_evolve <- tibble(iteration = 1:500, text = "I met a traveller from an antique land")
for (i in 2:500) {
tbl_evolve$text[i] <- evolve_sentence(tbl_evolve$text[i - 1])
}
tbl_evolve %>%
distinct(text, .keep_all = TRUE)
The output look like this:
1 I met a traveller from an antique land
2 I met a tIaveller from an antique land
4 I met a tIaveller from an antique lanr
5 I met a tIaveller from an fntique lanr
6 I met a tIaveller fromnan met lanr
I would love to present this in as a Shiny app where the input text and the probability of different types of changes can be specified by the user. For the latter that would be making the values in (runif(1) > 0.5) and (runif(1) > 0.9) specifiable by the user. I know this is possible in Shiny using insert UI and actionButton.
I am less sure if there is a way to dynamically show the output, so that the user can visually see each iteration of the code (with a defined time delay between each iteration?) rather than seeing all iterations output at once as once does with the existing code. I am open to different ways of dynamically visualising the output but I think ideally the user would see each iteration replaced by the next with a time delay.
I would also like a tab with the current output, each iteration being a row, so the user can go back and review each iteration.
Any advice on whether this is possible in Shiny or if I need a different tool would be much appreciated.

library(shiny)
library(tidyverse)
# Define UI for application that draws a histogram
ui <- fluidPage(
# Application title
titlePanel("Simple Testcase"),
# Sidebar with a slider input for number of bins
sidebarLayout(
sidebarPanel(
textInput("textinput", "Type text here"),
numericInput("p1", "Probability1", value = 0.5),
numericInput("p2", "Probability2", value = 0.9),
sliderInput("iteration", "Iterations", min = 20, max = 1000, step = 10, value = 100),
actionButton("calc", "Run Calculation!")
),
# Show a plot of the generated distribution
mainPanel(
tableOutput("ui")
)
)
)
# Define server logic required to draw a histogram
server <- function(session ,input, output) {
vals <- reactiveValues(counter = 0)
result <- eventReactive(input$calc, {
evolve_sentence <- function(sentence, arg2) {
chars <- str_split(sentence, "") %>% pluck(1)
if (runif(1) > input$p1) { # Value from numericinput p2
chars[sample(1:length(chars), 1)] <- sample(chars, 1)
}
sentence <- str_c(chars, collapse = "")
words <- str_split(sentence, " ") %>% pluck(1)
if (runif(1) > input$p2) { # Value from numericinput p2
words[sample(1:length(words), 1)] <- sample(words, 1)
}
sentence <- str_c(words, collapse = " ")
sentence
}
tbl_evolve <- tibble(iteration = 1:500, text = input$textinput)
for (i in 2:500) {
tbl_evolve$text[i] <- evolve_sentence(tbl_evolve$text[i - 1])
}
output <-tbl_evolve %>%
distinct(text, .keep_all = TRUE)
print(output)
output
})
output$ui <- renderTable({
df <- result()
invalidateLater(millis = 300, session)
vals$counter <- isolate(vals$counter) + 1
while(nrow(df) < vals$counter) {
vals$counter <- isolate(vals$counter) + 1
} #Prevent to add infinite empty columns.
for(i in 1:nrow(df)) {
newdf <- df[1:vals$counter,]
}
newdf
})
}
# Run the application
shinyApp(ui = ui, server = server)
How about this? To render the table we can set a reactiveValue, which gets updated after the invalidateLater function triggers. Take the value of the counter to subset your final dataset.

Related

Loop over data.frame and display result immediately in DT

I have a simple shiny app that holds a dataset as a reactive value.
Once a button is pressed, a function should be applied to each row and the result is added as another variable to that dataset.
The dataset is also shown as a DT.
The result variable should be rendered as soon as the computation for that row is finished.
At the moment, the loop/apply that applies the function to each row finishes and only afterwards the results are displayed.
As the function can run for a long time, I want the DT to be updated as soon as a run is finished, not when all runs finish.
I understand that this means I need to use promises/future so that the main shiny code block spawns new processes which do not block in this case the main thread from updating the values. Correct?
However, I am not able to get it to work.
Here is a small MWE using a simple for loop
library(shiny)
library(DT)
ui <- fluidPage(
actionButton("run", "RUN"),
hr(),
DT::dataTableOutput("table")
)
calc_fun <- function(val) {
Sys.sleep(0.5)
val * 10
}
server <- function(input, output, session) {
set.seed(123)
data_res <- reactiveVal(data.frame(id = 1:10, val = rnorm(10), val10 = NA))
observe({
for (i in seq(nrow(data_res()))) {
print(paste("Looking at row", i))
d <- data_res()
d[i, "val10"] <- calc_fun(val = d[i, "val"])
data_res(d)
}
}) %>% bindEvent(input$run)
# This should be rendered whenever a round in the for-loop has finished
# at the moment it is only run once the loop is finished
output$table <- DT::renderDataTable(data_res())
}
shinyApp(ui, server)
Thanks to #ismirsehregal, I came up with the following solution which uses futures to start the calculation in the background, which in turn write the current status to a file.
Shiny then reactively reads the file and updates the values.
The full MWE looks like this:
library(shiny)
library(DT)
library(future)
library(promises)
library(qs) # for fast file read/write, replace with csv if needed
plan(multisession)
ui <- fluidPage(
actionButton("run", "RUN"),
hr(),
textOutput("prog"),
uiOutput("status"),
hr(),
fluidRow(
column(6,
h2("Current Status"),
DT::dataTableOutput("table")
),
column(6,
h2("Data in File"),
tableOutput("file_data")
)
)
)
calc_fun <- function(val) {
Sys.sleep(runif(1, 0, 2))
val * 10
}
# main function that goes through the rows and starts the calculation
# note that the output is saved to a .qs file to be read in by another reactive
do_something_per_row <- function(df, outfile) {
out <- tibble(id = numeric(0), res = numeric(0))
for (i in seq(nrow(df))) {
v <- df$val[i]
out <- out %>% add_row(id = i, res = calc_fun(v))
qsave(out, outfile)
}
return(out)
}
# create a data frame of tasks
set.seed(123)
N <- 13
tasks_init <- tibble(id = seq(N), val = round(rnorm(N), 2), status = "Open", res = NA)
server <- function(input, output, session) {
# the temporary file to communicate over
outfile <- "temp_progress_watch.qs"
unlink(outfile)
data <- reactiveVal(tasks_init) # holds the current status of the tasks
data_final <- reactiveVal() # holds the results once all tasks are finished
output$prog <- renderText(sprintf("Progress: 0 of %i (0.00%%)", nrow(data())))
output$status <- renderUI(div(style = "color: black;", h3("Not yet started")))
# on the button, start the do_something_per_row function as a future
observeEvent(input$run, {
# if a file exists => the code runs already
if (file.exists(outfile)) return()
print("Starting to Run the code")
output$status <- renderUI(div(style = "color: orange;", h3("Working ...")))
d <- data()
future({do_something_per_row(d, outfile)}, seed = TRUE) %...>% data_final()
print("Done starting the code, runs now in the background! freeing the session for interaction")
# return(NULL) # hide future
})
observe({
req(data_final())
output$status <- renderUI(div(style = "color: green;", h3("Done")))
print("All Done - Results came back from the future!")
})
output$file_data <- renderTable(req(df_done()))
output$table <- DT::renderDataTable({
# no need to fire on every refresh, this is handled automatically later
DT::datatable(isolate(data())) %>%
formatStyle("status", color = styleEqual(c("Open", "Done"), c("white", "black")),
backgroundColor = styleEqual(c("Open", "Done"), c("red", "green")))
})
dt_proxy <- DT::dataTableProxy("table")
# look for changes in the file and load it
df_done <- reactiveFileReader(300, session, outfile, function(f) {
r <- try(qread(f), silent = TRUE)
if (inherits(r, "try-error")) return(NULL)
r
})
observe({
req(df_done())
open_ids <- data() %>% filter(status == "Open") %>% pull(id)
if (!any(df_done()$id %in% open_ids)) return()
print(paste("- new entry found:", paste(intersect(df_done()$id, open_ids), collapse = ", ")))
rr <- data() %>% select(-res) %>% left_join(df_done(), by = "id") %>%
mutate(status = ifelse(is.na(res), "Open", "Done"))
data(rr)
DT::replaceData(dt_proxy, rr)
# replace the progress text
txt <- sprintf("Progress: % 4i of % 4i (%05.2f%%)",
nrow(df_done()), nrow(data()), 100 * (nrow(df_done()) / nrow(data())))
output$prog <- renderText(txt)
})
}
shinyApp(ui, server)
or as a picture:

How can I speed up a reactable with nested graphs?

I am trying to insert additional information into a reactable in R - one which has about 3600 rows. I've tried nesting a plot under each row (similar to this, but with nested plots instead of sub-tables). The only way I could make this work was to use plotly within reactable, like so:
library(reactable)
library(magrittr)
library(plotly)
my_diamonds <- diamonds
my_diamonds$cats <- cut(my_diamonds$price, 850)
my_diamonds <- my_diamonds[ order(my_diamonds$cut, my_diamonds$cats), ]
data <- unique(my_diamonds[, c("cut", "cats")])
reactable(data,
details = function(index) {
diam_data <- my_diamonds[my_diamonds$cut == data$cut[index] & my_diamonds$cats == data$cats[index], ]
plot_ly(diam_data,
x = ~1:nrow(diam_data),
y = ~y,
type = 'scatter',
mode = 'lines') # %>% toWebGL()
}
)
But sadly, for this amount of data, this takes forever to output the table, and anything I've tried to make it faster (such as toWebGL()) changes nothing. All I really care about is the speed, and having some sort of visualisation associated with each row - I don't particularly care if it's plotly or something else.
A second option would be to use an in-line HTML widget for each row (shown here). In my example, this could be done if adding:
data_parcels <- split(my_diamonds, list(my_diamonds$cats, my_diamonds$cut), drop = T)
data$nested_points <- sapply(data_parcels, '[[', 'y')
data$sparkline <- NA
library(sparkline)
reactable(data,
columns = list(
sparkline = colDef(cell = function(value, index) {
sparkline(data$nested_points[[index]])
})
))
This isn't quite as slow as the plotly option, but still very slow in the larger scheme of things. Any ideas on how to speed up either example, anyone?
PaulM and I have worked on a solution together, and managed to speed up one of the options: the one involving in-line sparklines. As it turned out based on some profiling work, what was making the process particularly slow wasn't drawing the sparklines in itself, rather the subsequent work of translating them from R so that they could be incorporated into the HTML reactable table.
So to bypass that slow translation process entirely, we wrote a code template that would get wrapped around the data points to be plotted. This is what we then served directly to reactable, alongside an html = TRUE argument, for the code to be interpreted as such, rather than as regular text.
The final hurdle after that was to ensure that the sparklines (one per row) were still on display even if a user sorted a column or navigated to a different page of results - normally the sparklines would disappear on interacting with the table in this way. For this, we ensured that that the reactable would be redrawn 10ms after any click.
Here is an example wrapped in shiny that shows all this in action, alongside the old (slow) version. For me, the sped up version renders in about 0.5s roughly, whereas the old one - about 13s.
library(reactable)
library(magrittr)
library(plotly)
library(sparkline)
library(shiny)
library(shinycssloaders)
library(shinyWidgets)
if (interactive()) {
# Init objects
t0 <- NULL
t1 <- NULL
my_diamonds <- diamonds
my_diamonds$cats <- cut(my_diamonds$price, 850)
my_diamonds <- my_diamonds[ order(my_diamonds$cut, my_diamonds$cats), ]
data <- unique(my_diamonds[, c("cut", "cats")])
data_parcels <- split(my_diamonds, list(my_diamonds$cats, my_diamonds$cut), drop = T)
data$nested_points <- sapply(data_parcels, '[[', 'y')
data$sparkline <- NA
ui <- shinyUI(
basicPage(
br(),
radioGroupButtons(
inputId = "speedChoice",
label = "Speed",
choices = c("Fast", "Slow"),
status = "danger"
),
br(),
verbatimTextOutput("timeElapsed"),
br(),
shinycssloaders::withSpinner(
reactableOutput("diamonds_table")
),
# Small JS script to re-render a reactable table so that the sparklines show
# after the user has modified the table (sorted a col or navigated to a given page of results)
tags$script('document.getElementById("diamonds_table").addEventListener("click", function(event){
setTimeout(function(){
console.log("rerender")
HTMLWidgets.staticRender()
}, 10);
})
')
)
)
server <- function(input, output, session) {
output$diamonds_table <- renderReactable({
if (input$speedChoice == "Fast") {
t0 <<- Sys.time()
part1 <- '<span id="htmlwidget-spark-' # + ID
part2 <- '" class="sparkline html-widget"></span><script type="application/json" data-for="htmlwidget-spark-' # + ID
part3 <- '">{"x":{"values":[' # + values
part4 <- '],"options":{"height":20,"width":60},"width":60,"height":20},"evals":[],"jsHooks":[]}</script>'
out <- list(length = nrow(data))
for (i in 1:nrow(data)) {
vals <- paste0(data$nested_points[[i]], collapse = ',')
out[[i]] <- paste0(part1, i, part2, i, part3, vals, part4)
}
data$sparkline <- out
tab <- reactable(data,
columns = list(
sparkline = colDef(html = TRUE,
cell = function(value, index) {
return(htmltools::HTML(value))
}
)
)
) %>%
spk_add_deps() %>%
htmlwidgets::onRender(jsCode = "
function(el, x) {
HTMLWidgets.staticRender();
console.log('render happening')
}")
t1 <<- Sys.time()
return(tab)
} else {
# Classic, but slow version:
t0 <<- Sys.time()
tab <- reactable(data,
columns = list(
sparkline = colDef(cell = function(value, index) {
data$nested_points[[index]] %>%
sparkline::sparkline()
}
)
)
)
t1 <<- Sys.time()
return(tab)
}
})
output$timeElapsed <- renderText({
input$speedChoice # Connect to reactable update cycle
return(t1 - t0)
})
}
shinyApp(ui = ui, server = server)
}

How to access secondary inputs with variable names in R Shiny?

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

Read and overwrite data at each click of an actionButton

I am trying to build a shiny app that reads a data frame and at every press of an actionButton returns the value of a specific column, one row at a time until all rows of the data frame have been read. The structure of the dataset is 3 columns, one for IDs, one for a characteristic and an indicator variable for the already read IDs (0/1). Every time the user presses the actionButton, the app reads one row of the dataset, starting from row 1, returns the value of a second variable in that row and changes the value of the third variable to 1. The tricky part for me is that I want to save the "used" ids, in order to continue the reading from the last used id after restarting the app. I have tried loading and saving the data at every step and using reactiveValues, but this does not seem to work well for me - probably I don't know how to use them correctly. I am very new in shiny, so any feedback is more than welcome.
An example of the code I have been using:
project.path <- getwd()
dat <- data.frame(id = c(1:20), gender = sample(c("male", "female"), 20, replace = TRUE), used = 0)
write.csv2(dat, file.path(project.path, "data.csv"), row.names = F)
saveData <- function(x) {
write.csv2(x, file = file.path(project.path, "data.csv"),
row.names = FALSE)
}
loadData <- function() {
dat <- read.csv2(file.path(project.path, "data.csv"))
return(dat)
}
# UI
ui <- fluidPage(
# Application title
titlePanel("Tittle"),
sidebarLayout(
sidebarPanel(
actionButton("counter", "Start")
),
mainPanel(
textOutput("result")
)
)
)
# SERVER
server <- function(input, output, session) {
last <- reactive({
d <- loadData()
last <- min(d$id[d$used == 0]) -1
})
cur <- reactive({
if(last() == 0){
cur <- input$counter
}else{
cur <- last() + input$counter
}
})
# Calculate Result
ResultText <- reactive({
d <-loadData()
if (input$counter == 0 & last() == 0){
paste0("No IDs have been used. Press button to start.")
}else{
if(input$counter > 0 & last() == 0){
d$used[cur()] <- 1
paste0("ID ", cur(), " is a ", as.character(d$gender[cur()]))
}else{
if(input$counter == 0 & last() > 0){
paste0("The last ID was ", d$id[last()], " (", as.character(d$gender[last()]), ") Press the button to continue reading the list.")
}else{
d$used[cur()] <- 1
paste0("ID ", cur(), " is a ", as.character(d$gender[cur()]))
}
}
}
})
output$result <- renderText({
ResultText()
})
observe({
d <- loadData()
if (input$counter > 0 & last() == 0){
cur <- input$counter
d$used[cur] <- 1
saveData(d)
}else{
if(input$counter > 0 & last() > 0){
d$used[cur()] <- 1
saveData(d)
}
}
})
}
# Run
shinyApp(ui = ui, server = server)

R Shiny, working with reactive dataframes - NAs

I'm trying to populate a data.frame/matrix based on some user-defined rules. I managed to create a function in R, but am stuck trying to replicate this as a Shiny app [it's my first time using Shiny, and I'm an idiot to start with this one]
This is the crux of the code in regular r-script -
user-inputs are: size (1~3), changes (1~2) and iterations (10~1000)
school_choice_function<- function(changes, size, iterations )
{
######## 1509
##### List of schools
p<-1
j<-1
k<-1
l<-1
s_list<- rep(0,80)
for (i in 1:80) {
if (i <= 26) {
schl<- paste(LETTERS[p],LETTERS[i],sep = "")
s_list[i]<- schl }
if (i>26 & i<=52) {p<- 2
schl<- paste(LETTERS[p],LETTERS[j],sep = "")
s_list[i]<- schl
j=j+1}
if (i>52 & i<=78) {p<- 3
schl<- paste(LETTERS[p],LETTERS[k],sep = "")
s_list[i]<- schl
k=k+1}
if (i>78 ) {p<- 4
schl<- paste(LETTERS[p],LETTERS[l],sep = "")
s_list[i]<- schl
l=l+1}
}
rm(p,i,j,k,l)
########## Applicant Data
a<- c(2011:2015)
c<- 1:size
d<- 1:changes
y<-0
v<-1
w<-10
mat <- matrix(ncol=5, nrow=(iterations*10))
for(pop in 1:iterations){
for (z in v:w)
{
b<- s_list[(1+y):(8+y)]
e<- rep(0,5)
e[1]<- b[1]
g<- sample(d,1)
h<- sample(2:5,g, replace = FALSE)
f1<- rep(0,length(h))
for(j in 1:g){
for(i in 1:length(h))
{
f<- sample(c, 1)
f1[i]<- paste(sample(b,f,replace = FALSE),collapse = ",")
e[h[i]]<- f1[i]
}
}
for(i in c(which(e %in% 0))){
e[i]<- e[i-1]
}
mat[z,]<- e
y<-y+8
}
v<- w+1
w<- w+10
y<-0
}
df<- data.frame(mat,stringsAsFactors = FALSE)
colnames(df)<- c("2011","2012","2013","2014","2015")
return(df)
}
Ignoring the use of worst-practices in coding (I've just learnt to think in terms of loops), I'm using this is a shiny app like this. "s_list/schools" is a character matrix with 80 elements, created before this code.
Just so you get an intuition of what on earth is this - basically it is applicant data over 5 years, who may or many not get assigned to alternatives over time, (based on the rules which comes through in the loops).
The code works in the current form - except the output table is full of NAs.... Any kind of help would be a step up from where I'm at!
ui<- fluidPage(
numericInput(inputId="Changes", label="Changes", value=1, min = 1, max = 3, step = 1),
numericInput(inputId="Size", label="Size", value=2, min = 1, max = 3, step = 1),
numericInput(inputId="Iterations", label="Iterations", value=10, min = 10, max = 1000, step = 10),
tableOutput("dframe")
)
server<- function(input,output) {
Changes<- reactive({input$Changes})
Size<- reactive({input$Size})
Iterations<- reactive({input$Iterations})
schools<- s_list
########## Applicant Data
a<- c(2011:2015)
cc<- reactive(1:(Size()))
d<- reactive(1:(Changes()))
y<-0
v<-1
w<-10
mat <- reactive(matrix(ncol=5, nrow=((input$Iterations)*10)))
pop<- 0
z<- 0
i<- 0
j<- 0
this<- reactive({
for(pop in 1:(Iterations())){
for (z in v:w)
{
b<- schools[(1+y):(8+y)]
e<- rep(0,5)
e[1]<- b[1]
g<- reactive(sample(d(),1))
h<- reactive(sample(2:5,g(), replace = FALSE))
f1<- reactive(rep(0,length(h())))
for(j in 1:g()){
for(i in 1:length(h()))
{
f<- reactive(sample(cc(), 1))
f1()[i]<- reactive(paste(sample(b,f(),replace = FALSE),collapse = ","))
e[h()[i]]<- f1()[i]
}
}
for(i in cc()(which(e %in% 0))){
e[i]<- e[i-1]
}
mat()[z,]<- e
y<-y+8
}
v<- w+1
w<- w+10
y<-0
}
})
df<- reactive(data.frame(mat(),stringsAsFactors = FALSE))
output$dframe <- renderTable({ df() })
}
shinyApp(ui= ui, server = server)
Instead of writing the whole code of the function school_choice_function inside your server why don't you define the function outside your server and just call it from inside your server. Something like this:
server<- function(input,output) {
Changes<- reactive({input$Changes})
Size<- reactive({input$Size})
Iterations<- reactive({input$Iterations})
df<- reactive({
df <- school_choice_function(Changes(), Size(), Iterations())
return(data.frame(df, stringsAsFactors = FALSE))
})
output$dframe <- renderTable({ df() })
}

Resources