I have a randomly generated data.frame. The user can modify a slider to choose the number of points. Then I plot this data.frame.
I want to add a button than when clicked, it performs a modification in the previous randomly generated data.frame (but without regenerating the data.frame). The modification is a voronoid relaxation, and it should be performed once per each time the button is clicked and the graph generated.
Until now, I have not achieved anything similar...
ui.R
library(shiny)
# Define UI for application that draws a histogram
shinyUI(fluidPage(
# Application title
titlePanel("Map Generator:"),
# Sidebar with a slider input for the number of bins
sidebarLayout(
sidebarPanel(
p("Select the power p to generate 2^p points."),
sliderInput("NumPoints",
"Number of points:",
min = 1,
max = 10,
value = 9),
actionButton("GenPoints", "Generate"),
actionButton("LloydAlg", "Relaxe")
),
# Show a plot of the generated distribution
mainPanel(
plotOutput("distPlot",height = 700, width = "auto")
)
)
))
server.R
library(shiny)
library(deldir)
shinyServer(function(input, output) {
observeEvent(input$NumPoints,{
x = data.frame(X = runif(2^input$NumPoints,1,1E6),
Y = runif(2^input$NumPoints,1,1E6))
observeEvent(input$LloydAlg, {
x = tile.centroids(tile.list(deldir(x)))
})
output$distPlot <- renderPlot({
plot(x,pch = 20,asp=1,xlim=c(0,1E6),ylim = c(0,1E6))
})
})
})
Of course there is something that I must be doing wrong, but I am quite new into shiny I can't figure it out what I am doing wrong...
This should work (even though I am pretty sure this could be improved):
shinyServer(function(input, output) {
library(deldir)
data = data.frame(
X = runif(2^9, 1, 1E6),
Y = runif(2^9, 1, 1E6)
)
rv <- reactiveValues(x = data)
observeEvent(input$GenPoints, {
rv$x <- data.frame(
X = runif(2^input$NumPoints,1,1E6),
Y = runif(2^input$NumPoints,1,1E6)
)
})
observeEvent(input$LloydAlg, {
rv$x = tile.centroids(tile.list(deldir(rv$x)))
})
output$distPlot <- renderPlot({
plot(rv$x,pch = 20,asp=1,xlim=c(0,1E6),ylim = c(0,1E6))
})
})
So first I initialize the points to plot. I use runif(2^9, 1, 1E6) because the starting value of the sliderInput is 9 all the time.
I also removed the observeEvent from the sliderInput and moved it to the GenPoints actionButton.
Related
I prepared rather simple shiny application which resembles the problem in my much more complex application.
The three necessary components of my application are:
The number, i.e. year, can be changed in two different ways: by 1) adding a value in the textInput or 2) by clicking the action button
When the year is changed by the actionButtion, it must automatically change current value in the textInput box
When the year is changed by the textInput, reactive value for the
action button must reset to zero.
I have two observeEvents which both target two reactive values. The problem is, if I click the actionButton several times too quickly, this creates a loop of switching between those two events.
Is there any efficient tool available in Shiny which help in such situations? E.g. to prevent users to click on the button prior the execution of task.
# import libraries
library(shiny)
library(ggplot2)
library(dplyr)
ui <- shinyUI(fluidPage(
sidebarLayout(
sidebarPanel(
uiOutput("ui_year"),
uiOutput("ui_plus")
),
mainPanel(
plotOutput("plot1")
)
)))
server <- shinyServer(function(input, output) {
# Generate random data
data <- data.frame(
year = seq(1900, 2000),
value = runif(n = 101, min = -3, max = 3)
)
# Define two reactive values: add and year
rv <- reactiveValues()
rv$add <- 0
rv$year <- 2000
# render actionButton
output$ui_plus <- renderUI({
actionButton(inputId = "add",
label = paste0(""),
icon = icon("plus"))
})
# render textInput
output$ui_year <- renderUI({
textInput(inputId = "year_1", label = NULL,
value = eval(parse( text = rv$year)),
width = "100%",
placeholder = NULL)
})
# Define two observe events, based on A) action button and B) textInput
observeEvent(input$year_1, {
rv$year <- input$year_1
rv$add <- 0
})
observeEvent(input$add, {
rv$add <- rv$add + 1
rv$year <- as.numeric(rv$year) + 1
})
# Render output
output$plot1 <- renderPlot({
sumValue <- as.numeric(rv$year) + as.numeric(rv$add)
ggplot(data, aes(x = year, y = value)) + geom_line()+ annotate("text", x = -Inf, y = Inf, hjust = -0.2, vjust = 1, label = sumValue )
})
})
shinyApp(ui = ui, server = server)
I want to create a small shiny app to explore a scoring function that I am writing for a set of data observations. This is my first shiny app so bear with me.
What I want to show is the data table where one column is computed by a function (let's say f(x) = x^2 + y) where x is another (numeric) column in the table and y should be adjustable with a slider in the sidebar.
I want to make the table reactive, so that as soon as the slider is adjusted, the content that is displayed will be updated. Does anyone have a link to a tutorial (I could not find a similar problem) or a suggestion how to handle this. If so, please let me know!
This is the code I have so far:
library(shiny)
#### INIT ####
x <- 1
y <- 0.5
z <- 2
df <- data.frame(
a=1:10,
b=10:1
)
df['score'] <- df[,x]^y + z
#### UI ####
ui <- fluidPage(
title = "Examples of DataTables",
sidebarLayout(
sidebarPanel(
sliderInput("x", "x:",
min = 0, max = ncol(df),
value = 1),
sliderInput("y", "y:",
min = 1, max = 10,
value = 1),
sliderInput("z", "z:",
min = 1, max = 100,
value = 20)
),
mainPanel(
tabsetPanel(
id = 'dataset',
tabPanel("df", dataTableOutput("df"))
)
)
)
)
#### SERVER ####
server <- function(input, output) {
sliderValues <- reactive({
df['score'] <- df[,input$x]^input$y + input$z
})
sliderValues()
output$df<- renderDataTable(df)
}
#### RUN ####
shinyApp(ui = ui, server = server)
Just make the data.frame you actually plot reactive. For example
server <- function(input, output) {
calcualtedValues <- reactive({
df['score'] <- df[,input$x]^input$y + input$z
df
})
output$df<- renderDataTable(calcualtedValues())
}
Here the calcualtedValues reactive element returns a new data.frame when the input is updated, and then you actually render that updated data.frame rather than the original data.frame each time.
I've looked through R Shiny tutorials and stackoverflow for answers related to my query. I usually wait for 3-4 days to solve a coding problem before I attempt to post.
I have an animated slider in my UI that loops through time interval in a column (column a) . I'm trying to produce an animated line plot that plots y values of another column (column b), corresponding to the nrow() of that time interval. The slider works perfectly, but I haven't been able to plot the output.
I mightve missed some concepts related to reactivity in Shiny app. Appreciate any guidance I can get related to my query. I'll be happy to post more info if needed.
a <- c(0,1,2,3,4,5,6)
b <- c(50,100,40,30,20,80)
mydata <- cbind(a,b)
mydata <- as.data.frame(mydata())
ui <- fluidPage (
headerPanel("basic app"),
sidebarPanel(
sliderInput("slider",
label = "Time elapsed",
min = 0,
max = nrow(mydata()),
value = 1, step = 1,
animate =
animationOptions(interval = 200, loop = TRUE))
),
mainPanel(
plotlyOutput("plot")
)
)
server <- function(input, output) {
sliderValues <- reactive({
data.frame(
Name = "slider",
Value = input$slider)
})
output$plot <- renderPlot({
x<- as.numeric(input$slider)
y <- as.numeric(b[x])
ggplot(mydata,aes_string(x,y))+ geom_line()
})
}
Just as a demo, I wanted the animated plot to come out like this, but in correspondance to UI slider values :
library(gganimate)
library(ggplot2)
fake <- c(1,10)
goods <- c(11,20)
fakegoods <- cbind(fake,goods)
fakegoods <- data.frame(fakegoods)
ggplot(fakegoods, aes(fake, goods)) + geom_line() + transition_reveal(1, fake)
Does this accomplish what you are looking for? Note that I removed the first element, 0, from vector a as your original example had more elements in a than b, and in order for them to be cbind together they must be the same length.
library(ggplot2)
library(shiny)
a <- c(1,2,3,4,5,6)
b <- c(50,100,40,30,20,80)
mydata <- cbind(a,b)
mydata <- as.data.frame(mydata)
ui <- fluidPage (
headerPanel("basic app"),
sidebarPanel(
sliderInput("slider",
label = "Time elapsed",
min = min(mydata$a),
max = max(mydata$a),
value = min(mydata$a), step = 1,
animate =
animationOptions(interval = 200, loop = TRUE))
),
mainPanel(
plotOutput("plot")
)
)
server <- function(input, output) {
output$plot <- renderPlot({
plotdata <- mydata[1:which(input$slider==mydata$a),]
p <- ggplot(plotdata,aes(x = a,y = b))
if(nrow(plotdata)==1) {
p + geom_point()
} else {
p + geom_line()
}
})
}
I am working on a shiny app where I allow a user to select the plotting criteria and then also allow them to brush the plot and see their selection in a table below. I have some NA values in my data. I have noticed that these NAs end up in my brushed point table as full rows of NA. I can remove these manually with something like this. However, I was wondering if I perhaps was doing something wrong on my brush that was causing this.
Code with a working example is below. I have also included an image of a brush selection demonstrating what I mean.
library(shiny)
library(tidyverse)
# replace some random values in mtcars with NA
set.seed(1)
mtnew <-
as.data.frame(lapply(mtcars, function(m)
m[sample(
c(TRUE, NA),
prob = c(0.8, 0.2),
size = length(m),
replace = TRUE
)]))
# set up UI that allows user to pick x and y variables, see a plot,
# brush the plot, and see a table based on the brush
ui <- fluidPage(
titlePanel("Shiny Test"),
sidebarLayout(
sidebarPanel(
selectInput("xvar",
"pick x",
choices = names(mtnew)),
selectInput("yvar",
"pick y",
choices = names(mtnew))),
mainPanel(
plotOutput("myplot",
brush = brushOpts(id = "plot_brush")),
tableOutput("mytable")
)
)
)
server <- function(input, output) {
output$myplot <- renderPlot({
ggplot(data = mtnew) +
geom_point(aes(x = !!rlang::sym(input$xvar),
y = !!rlang::sym(input$yvar)))
})
output$mytable <- renderTable({
brush_out <- brushedPoints(mtnew, input$plot_brush)
})
}
# Complete app with UI and server components
shinyApp(ui, server)
I guess that you'll have to establish which data you want to represent.
You may want to have only defined record without NAs, in that case I would suggest to use the complete.cases function. Yet this solution will highly reduce your data set (below I've applied to your code).
Another option is to preserve all your records but without the NAs. In that case you should consider using imputation methods to set proper values in replacement. Take a look at this post which provides an example.
library(shiny)
library(tidyverse)
# replace some random values in mtcars with NA
set.seed(1)
mtnew <-
as.data.frame(lapply(mtcars, function(m)
m[sample(
c(TRUE, NA),
prob = c(0.8, 0.2),
size = length(m),
replace = TRUE
)]))
mtnew_complete <- mtnew[complete.cases(mtnew),]
# set up UI that allows user to pick x and y variables, see a plot,
# brush the plot, and see a table based on the brush
ui <- fluidPage(
titlePanel("Shiny Test"),
sidebarLayout(
sidebarPanel(
selectInput("xvar",
"pick x",
choices = names(mtnew)),
selectInput("yvar",
"pick y",
choices = names(mtnew))),
mainPanel(
plotOutput("myplot",
brush = brushOpts(id = "plot_brush")),
tableOutput("mytable")
)
)
)
server <- function(input, output) {
output$myplot <- renderPlot({
#ggplot(data = mtnew) +
ggplot(data = mtnew_complete) +
geom_point(aes(x = !!rlang::sym(input$xvar),
y = !!rlang::sym(input$yvar)))
})
output$mytable <- renderTable({
#brush_out <- brushedPoints(mtnew, input$plot_brush)
brush_out <- brushedPoints(mtnew_complete, input$plot_brush)
})
}
# Complete app with UI and server components
shinyApp(ui, server)
I have a shiny app in which the user selects a bunch of inputs, such as the x range, y range, types of scaling and the selection of a particular subset of the data set through a drop down list.
This is all done through the use of reactives. X and Y range slider inputs react to changes in the selection of the data set because the minimum and maximum have to be found again. This takes maybe about 1-2 seconds while the shiny app is working and the user chooses a different option in the drop down list. During those 1-2 seconds, the plot switches to plotting the selected new subset of data with the old x and y range before quickly switching to the correct plot once the x and y range sliders change.
A fix would be to just refresh the plot on a button by isolating everything else. But would there be a way to keep the plot reactive to changes, but just wait until all the dependent things have finished calculating?
Thanks
This is the plot:
output$plot1 <- rCharts::renderChart2({
if(!is.null(input$date_of_interest) &&
!is.null(input$xrange) &&
!is.null(input$yrange) &&
!is.null(data()) &&
isolate(valid_date_of_interest())) {
filtered_data<- dplyr::filter(isolate(data()), id==input$choice)
p <- tryCatch(plot_high_chart(
data,
first_date_of_interest = input$date_of_interest,
ylim = input$yrange,
xlim = input$xrange),
error = function(e) e,
warning = function(w) w)
if(!inherits(p, "error") && !inherits(p, "warning")) {
return(p)
}
}
return(rCharts::Highcharts$new())
})
and x range(y range is similar):
output$xrange <- renderUI({
if(!is.null(input$date_of_interest) &&
!is.null(input$choice) &&
!is.null(valid_date_of_interest()) &&
isolate(valid_date_of_interest())) {
temp_data <- dplyr::filter(isolate(data()), date == input$date_of_interest)
temp <- data.table::data.table(temp_data, key = "child.id")
the_days <- as.double(as.Date(temp$last.tradeable.dt) - as.Date(temp$date))
min_days <- min(the_days,na.rm=TRUE)
max_days <- max(the_days,na.rm=TRUE)
sliderInput("xrange",
"Days Range (X Axis)",
step = 1,
min = 0,
max = max_days + 10,
value = c(min_days,max_days)
)
}
})
and the input choice:
output$choice<- renderUI({
selectInput("choice",
"Choose:",
unique(data$id),
selected = 1
)
})
Some direction and suggestions to implement would be useful. I've thought about having global variables such as x_range_updated, y_range_updated, that are set to false in the code for output$choice and then set to true in the code for output$xrange, etc. And then have plot1 depend on them being true. Other suggestions to approach this problem would be appreciated.
Edit 2019-02-14
Since Shiny 1.0.0 (released after I originally wrote this answer), there is now a debounce function which adds functionality to help with this kind of task. For the most part, this avoids the need for the code I originally wrote, although under the hood it works in a similar manner. However, as far as I can tell, debounce doesn't offer any way of short-circuiting the delay with a redraw action button along the lines of what I'd done here. I've therefore created a modified version of debounce that offers this functionality:
library(shiny)
library(magrittr)
# Redefined in global namespace since it's not exported from shiny
`%OR%` <- shiny:::`%OR%`
debounce_sc <- function(r, millis, priority = 100, domain = getDefaultReactiveDomain(), short_circuit = NULL)
{
force(r)
force(millis)
if (!is.function(millis)) {
origMillis <- millis
millis <- function() origMillis
}
v <- reactiveValues(trigger = NULL, when = NULL)
firstRun <- TRUE
observe({
r()
if (firstRun) {
firstRun <<- FALSE
return()
}
v$when <- Sys.time() + millis()/1000
}, label = "debounce tracker", domain = domain, priority = priority)
# New code here to short circuit the timer when the short_circuit reactive
# triggers
if (inherits(short_circuit, "reactive")) {
observe({
short_circuit()
v$when <- Sys.time()
}, label = "debounce short circuit", domain = domain, priority = priority)
}
# New code ends
observe({
if (is.null(v$when))
return()
now <- Sys.time()
if (now >= v$when) {
v$trigger <- isolate(v$trigger %OR% 0) %% 999999999 +
1
v$when <- NULL
}
else {
invalidateLater((v$when - now) * 1000)
}
}, label = "debounce timer", domain = domain, priority = priority)
er <- eventReactive(v$trigger, {
r()
}, label = "debounce result", ignoreNULL = FALSE, domain = domain)
primer <- observe({
primer$destroy()
er()
}, label = "debounce primer", domain = domain, priority = priority)
er
}
This then permits a simplified shiny application. I've switched to the single file mode of working, but the UI remains the same as the original one.
ui <- fluidPage(
titlePanel("Old Faithful Geyser Data"),
sidebarLayout(
sidebarPanel(
sliderInput("bins",
"Number of bins:",
min = 1,
max = 50,
value = 30),
selectInput("column", "Column", colnames(faithful), selected = "waiting"),
actionButton("redraw", "Redraw")
),
mainPanel(
plotOutput("distPlot")
)
)
)
server <- function(input, output, session) {
reac <- reactive(list(bins = input$bins, column = input$column)) %>%
debounce_sc(5000, short_circuit = reactive(input$redraw))
# Only triggered by the debounced reactive
output$distPlot <- renderPlot({
x <- faithful[, reac()$column]
bins <- seq(min(x), max(x), length.out = reac()$bins + 1)
hist(x, breaks = bins, col = 'darkgray', border = 'white',
main = sprintf("Histogram of %s", reac()$column))
})
}
shinyApp(ui, server)
Original version (pre Shiny 1.0.0)
You haven't provided a reproducible example, so I've gone with something based on the Shiny faithful example that is the default in RStudio. The solution I've got will always have a (configurable) 5 second delay between an input changing and the graph being redrawn. Each change in input resets the timer. There's also a redraw button for the impatient which redraws the graph immediately. The values of the reactive value 'redraw' and the inputs are shown in the console every time an input changes or the timer ticks. This should be removed for production use. Hopefully this meets your needs!
library(shiny)
shinyUI(fluidPage(
titlePanel("Old Faithful Geyser Data"),
sidebarLayout(
sidebarPanel(
sliderInput("bins",
"Number of bins:",
min = 1,
max = 50,
value = 30),
selectInput("column", "Column", colnames(faithful), selected = "waiting"),
actionButton("redraw", "Redraw")
),
mainPanel(
plotOutput("distPlot")
)
)
))
server.R
library(shiny)
shinyServer(function(input, output, session) {
reac <- reactiveValues(redraw = TRUE, bins = isolate(input$bins), column = isolate(input$column))
# If any inputs are changed, set the redraw parameter to FALSE
observe({
input$bins
input$column
reac$redraw <- FALSE
})
# This event will also fire for any inputs, but will also fire for
# a timer and with the 'redraw now' button.
# The net effect is that when an input is changed, a 5 second timer
# is started. This will be reset any time that a further input is
# changed. If it is allowed to lapse (or if the button is pressed)
# then the inputs are copied into the reactiveValues which in turn
# trigger the plot to be redrawn.
observe({
invalidateLater(5000, session)
input$bins
input$column
input$redraw
isolate(cat(reac$redraw, input$bins, input$column, "\n"))
if (isolate(reac$redraw)) {
reac$bins <- input$bins
reac$column <- input$column
} else {
isolate(reac$redraw <- TRUE)
}
})
# Only triggered when the copies of the inputs in reac are updated
# by the code above
output$distPlot <- renderPlot({
x <- faithful[, reac$column]
bins <- seq(min(x), max(x), length.out = reac$bins + 1)
hist(x, breaks = bins, col = 'darkgray', border = 'white',
main = sprintf("Histogram of %s", reac$column))
})
})