Ways to make shiny faster when using rhandsontable and reactiveValues - r

My shiny code has an rhandstontable that the user can edit. This leads to an update of the rightmost columns, based on a custom function. the code also plots values from the table on two ggplots, which also get updated when the table values change. All of this works except that there is a funny double refresh that makes Shiny slow; my table isn't big, about 50rows by 23 columns where only 4 columns are used in the plots but about 12 columns go into my custom function.
Is there a way to make shiny faster using observe(), reactiveValues, or other related functions?
I'm new at reactive expressions and I've been reading that it might be possible to make the app faster by caching data properly.
library(shiny)
library(rhandsontable)
library(tidyverse)
library(ggthemes)
library(ggrepel)
## Create the dataset
DF <- readRDS("data/DF2.Rds")
numberofrows <- nrow(DF)
# weighting variables
w1 = (c(4,3,1))
w2 = (c(1,1,1,1))
w3 = (c(2,2,1,2,1,1,2))
# Function to calculate scores
ScoresTbl <- function(data, w1, w2, w3){
Description <- data[,1:9]
Potential <- crossprod(t(data[,10:12]), w1)/sum(w1)
Setting <- crossprod(t(data[,13:16]), w2)/sum(w2)
Risk <- crossprod(t(data[,17:23]),w3)/sum(w3)
data.frame(data[1:23],Potential,Setting,Risk) %>%
mutate(
SOP = rowMeans(data.frame(Potential,Setting,Risk)))
}
ui = fluidPage(
fluidRow(column(12,
rHandsontableOutput('hotable1', width = "100%", height = "25%")#,
# actionButton("go", "Plot Update")
)),
fluidRow(column(6, plotOutput("plot1")),
column(6, plotOutput("plot2")))
)
server <- shinyServer(function(input, output) {
indat <- reactiveValues(data=ScoresTbl(DF,w1, w2, w3))
observe({
if(!is.null(input$hotable1))
indat$data <- hot_to_r(input$hotable1)
})
output$hotable1 <- renderRHandsontable({
rhandsontable(ScoresTbl(indat$data,w1, w2, w3))
})
output$plot1 <- renderPlot({
ggplot(data = indat$data,
aes(x=Potential,
y=Setting, label = Project)) +
geom_point(alpha = 0.5) +
scale_size(range = c(2,15)) +
geom_text_repel(colour = "black",size = 2.5) +
theme_minimal()
})
output$plot2 <- renderPlot({
ggplot(data = indat$data,
aes(x=Potential,
y=Setting, label = Project)) +
geom_point(alpha = 0.5) +
scale_size(range = c(2,15)) +
geom_text_repel(colour = "black",size = 2.5) +
theme_minimal()
})
})
shinyApp(ui, server)

Related

Interactive Bar Chart Using Shiny - Graph changes based on selected columns

I am teaching myself r and shiny and trying to make an interactive bar chart where the user can change the chart based on columns. I keep getting errors with this code. Any help would be appreciated! My data has four columns: v, one, two, three. The first column is characters and the last three are numbers. I want to change the bar chart based on the y axis (columns: one, two and three). Right now, the error I am getting is: missing value where TRUE/FALSE needed.
library(shiny)
library(readr)
library(ggplot2)
data <- read.csv('scoring.csv')
data$v <- as.character(data$v)
ui <- fluidPage(
titlePanel("Scoring"),
sidebarPanel(
selectInput(inputId = "scoring", label = "Select a score:", c("Scoring Method 1", "Scoring Method 2", "Scoring Method 3"))),
mainPanel(
plotOutput(outputId = "bar")
)
)
#browser()
server <- function(input, output) {
new_data <- reactive({
selected_score = as.numeric(input$"scoring")
if (selected_score == "Scoring Method 1"){(data[data$one])}
if (selected_score == "Scoring Method 2"){(data[data$two])}
if (selected_score == "Scoring Method 3"){(data[data$three])}
})
#browser()
output$bar <- renderPlot({
newdata <- new_data()
p <- ggplot(newdata, aes(x=reorder(v, -selected_score), selected_score, y = selected_score, fill=v)) +
geom_bar(stat = 'identity', fill="darkblue") +
theme_minimal() +
ggtitle("Sports")
barplot(p, height = 400, width = 200)
})
}
Run the application
shinyApp(ui = ui, server = server)
You have a few errors in your code. In the server part, please use input$scoring, instead of input$"scoring".
First, in ui selectInput could be defined as
selectInput(inputId = "scoring", label = "Select a score:", c("Scoring Method 1"="one",
"Scoring Method 2"="two",
"Scoring Method 3"="three")))
Second, your reactive dataframe new_data() could be defined as shown below:
new_data <- reactive({
d <- data %>% mutate(selected_score = input$scoring)
d
})
Third, ggplot could be defined as
output$bar <- renderPlot({
newdata <- new_data()
p <- ggplot(newdata, aes(x=v, y = newdata[[as.name(selected_score)]], fill=v)) +
geom_bar(stat = 'identity', position = "dodge", fill="blue") +
theme_bw() +
#scale_fill_manual(values=c("blue", "green", "red")) +
scale_y_continuous(limits=c(0,10)) +
ggtitle("Sports")
p
})
Please note that you had an extra selected_score variable within aes. My suggestion would be to play with it to reorder x, and review some online or youtube videos on R Shiny.

R/Shiny: Change plot ONLY after action button has been clicked

I am setting up a small shiny app where I do not want the plot to change unless the action button is clicked. In the example below, when I first run the app, there is no plot until I click the action button. However, if I then change my menu option in the drop-down from Histogram to Scatter, the scatter plot is automatically displayed even though the value for input$show_plot has not changed because the action button has not been clicked.
Is there a way that I can change my menu selection from Histogram to Scatter, but NOT have the plot change until I click the action button? I've read through several different posts and articles and can't seem to get this worked out.
Thanks for any input!
ui.R
library(shiny)
fluidPage(
tabsetPanel(
tabPanel("Main",
headerPanel(""),
sidebarPanel(
selectInput('plot_type', 'Select plot type', c('Histogram','Scatter'), width = "250px"),
actionButton('show_plot',"Plot", width = "125px"),
width = 2
),
mainPanel(
conditionalPanel(
"input.plot_type == 'Histogram'",
plotOutput('plot_histogram')
),
conditionalPanel(
"input.plot_type == 'Scatter'",
plotOutput('plot_scatter')
)
))
)
)
server.R
library(shiny)
library(ggplot2)
set.seed(10)
function(input, output, session) {
### GENERATE SOME DATA ###
source_data <- reactive({
mydata1 = as.data.frame(rnorm(n = 100))
mydata2 = as.data.frame(rnorm(n = 100))
mydata = cbind(mydata1, mydata2)
colnames(mydata) <- c("value1","value2")
return(mydata)
})
# get a subset of the data for the histogram
hist_data <- reactive({
data_sub = as.data.frame(source_data()[sample(1:nrow(source_data()), 75), "value1"])
colnames(data_sub) <- "value1"
return(data_sub)
})
# get a subset of the data for the scatter plot
scatter_data <- reactive({
data_sub = as.data.frame(source_data()[sample(1:nrow(source_data()), 75),])
return(data_sub)
})
### MAKE SOME PLOTS ###
observeEvent(input$show_plot,{
output$plot_histogram <- renderPlot({
isolate({
plot_data = hist_data()
print(head(plot_data))
p = ggplot(plot_data, aes(x = value1, y = ..count..)) + geom_histogram()
return(p)
})
})
})
observeEvent(input$show_plot,{
output$plot_scatter <- renderPlot({
isolate({
plot_data = scatter_data()
print(head(plot_data))
p = ggplot(plot_data, aes(x = value1, y = value2)) + geom_point()
return(p)
})
})
})
}
Based on your desired behavior I don't see a need for actionButton() at all. If you want to change plots based on user input then the combo of selectinput() and conditionPanel() already does that for you.
On another note, it is not good practice to have output bindings inside any reactives. Here's an improved version of your server code. I think you are good enough to see notice the changes but comment if you have any questions. -
function(input, output, session) {
### GENERATE SOME DATA ###
source_data <- data.frame(value1 = rnorm(n = 100), value2 = rnorm(n = 100))
# get a subset of the data for the histogram
hist_data <- reactive({
# reactive is not needed if no user input is used for creating this data
source_data[sample(1:nrow(source_data), 75), "value1", drop = F]
})
# get a subset of the data for the histogram
scatter_data <- reactive({
# reactive is not needed if no user input is used for creating this data
source_data[sample(1:nrow(source_data), 75), , drop = F]
})
### MAKE SOME PLOTS ###
output$plot_histogram <- renderPlot({
req(hist_data())
print(head(hist_data()))
p = ggplot(hist_data(), aes(x = value1, y = ..count..)) + geom_histogram()
return(p)
})
output$plot_scatter <- renderPlot({
req(scatter_data())
print(head(scatter_data()))
p = ggplot(scatter_data(), aes(x = value1, y = value2)) + geom_point()
return(p)
})
}

bars missing when using shiny to create ggplot bar chart

I used shiny and created a app.R file to hope to build a bar chart with ggplot. I also used checkboxGroupInput to create a 2 check boxes to control the condition. While the total number of bars should be 28 after all boxes are checked, but the maximum seemed to allow only 17 bars for some reason. So some bars (row of data) are missing. The missing bars don't seems to have a pattern. Can someone please help ?
dataset:https://drive.google.com/open?id=1fUQk_vMJWPwWnIMbXvyd5ro_HBk-DBfc
my code:
midterm <- read.csv('midterm-results.csv')
library(dplyr)
library(tidyr)
# get column number for response time
k <- c(33:88)
v <- c()
for (i in k){
if (i%%2 == 1){
v <- c(v,i)
}
}
#average response time by question
time <- midterm[ , v]
new.col.name <- gsub('_.*', "", colnames(time))
colnames(time) <- new.col.name
avg.time <- data.frame(apply(time, 2, mean))
avg.time$question <- rownames(avg.time)
colnames(avg.time) <- c('response_time', 'question')
rownames(avg.time) <- NULL
avg.time$question <- factor(avg.time$question,
levels = c('Q1','Q2','Q3','Q4','Q5','Q6','Q7','Q8.9',
'Q10','Q11','Q12.13','Q14','Q15','Q16','Q17',
'Q18','Q19','Q20','Q21','Q22','Q23','Q24','Q25',
'Q26','Q27','Q28','Q29','Q30'))
avg.time$question_type <- c(1,0,1,0,1,0,1,1,1,1,1,0,1,1,1,1,0,1,1,1,0,0,0,0,1,1,0,0)
# I did this manually because the there when data was imported into the midterm.csv,
# q8 & 9, q12 &13 were accidentally merged (28 v.s 30 question)
avg.time$question_type <- ifelse(avg.time$question_type == 1,
'googleable', 'not googleable')
avg.time$question_type <- factor(avg.time$question_type,
levels = c('googleable', 'not googleable'))
library(shiny)
library(ggplot2)
ui <- fluidPage(
checkboxGroupInput(inputId = "type",
label = "select question type",
choices = levels(avg.time$question_type),
selected = TRUE),
plotOutput('bar')
)
server <- function(input, output) {
output$bar <- renderPlot({
ggplot(avg.time[avg.time$question_type==input$type, ],
aes(x=question, response_time)) +
geom_bar(aes(fill = question_type), stat='identity', width = 0.5)
}, height =500, width = 1000)
}
shinyApp(ui = ui, server = server)
library(shiny)
library(ggplot2)
ui <- fluidPage(
checkboxGroupInput(inputId = "type", label = "select question type",
choices = levels(avg.time$question_type), selected = TRUE),
plotOutput('bar')
)
server <- function(input, output) {
data <- reactive(avg.time[avg.time$question_type %in% input$type, ])
output$bar <- renderPlot({
ggplot(data(),
aes(x=question, response_time)) + geom_bar(stat='identity', width = 0.5,
aes(fill = question_type))
}, height =500, width = 1000)
}
shinyApp(ui = ui, server = server)
of course you can use avg.time[avg.time$question_type %in% input$type, ] inside ggplot2 but reactivity is better.

Interactive plot in Shiny with rhandsontable and reactiveValues

I would really appreciate some help with the following code:
library(shiny)
library(rhandsontable)
library(tidyr)
dataa <- as.data.frame(cbind(rnorm(100, sd=2), rchisq(100, df = 0, ncp = 2.), rnorm(100)))
ldataa <- gather(dataa, key="variable", value = "value")
thresholds <- as.data.frame(cbind(1,1,1))
ui <- fluidPage(fluidRow(
plotOutput(outputId = "plot", click="plot_click")),
fluidRow(rHandsontableOutput("hot"))
)
server <- function(input, output) {
values <- reactiveValues(
df=thresholds
)
observeEvent(input$plot_click, {
values$trsh <- input$plot_click$x
})
observeEvent(input$hot_select, {
values$trsh <- 1
})
output$hot = renderRHandsontable({
rhandsontable(values$df, readOnly = F, selectCallback = TRUE)
})
output$plot <- renderPlot({
if (!is.null(input$hot_select)) {
x_val = colnames(dataa)[input$hot_select$select$c]
dens.plot <- ggplot(ldataa) +
geom_density(data=subset(ldataa,variable==x_val), aes(x=value), adjust=0.8) +
geom_rug(data=subset(ldataa,variable==x_val), aes(x=value)) +
geom_vline(xintercept = 1, linetype="longdash", alpha=0.3) +
geom_vline(xintercept = values$trsh)
dens.plot
}
})
}
shinyApp(ui = ui, server = server)
I have a plot and a handsontable object in the app.
Clicking on whichever cell loads a corresponding plot, with a threshold value. Clicking the plot changes the position of one of the vertical lines.
I would like to get the x value from clicking the plot into the corresponding cell, and I would like to be able to set the position of the vertical line by typing in a value in the cell too.
I'm currently a bit stuck with how I should feed back values into a reactiveValue dataframe.
Many thanks in advance.
This works as I imagined:
(The trick was to fill right columns of "df" with input$plot_click$x by indexing them with values$df[,input$hot_select$select$c].)
library(shiny)
library(rhandsontable)
library(tidyr)
dataa <- as.data.frame(cbind(rnorm(100, sd=2), rchisq(100, df = 0, ncp = 2.), rnorm(100)))
ldataa <- gather(dataa, key="variable", value = "value")
thresholds <- as.data.frame(cbind(1,1,1))
ui <- fluidPage(fluidRow(
plotOutput(outputId = "plot", click="plot_click")),
fluidRow(rHandsontableOutput("hot"))
)
server <- function(input, output) {
values <- reactiveValues(
df=thresholds
)
observeEvent(input$plot_click, {
values$df[,input$hot_select$select$c] <- input$plot_click$x
})
output$hot = renderRHandsontable({
rhandsontable(values$df, readOnly = F, selectCallback = TRUE)
})
output$plot <- renderPlot({
if (!is.null(input$hot_select)) {
x_val = colnames(dataa)[input$hot_select$select$c]
dens.plot <- ggplot(ldataa) +
geom_density(data=subset(ldataa,variable==x_val), aes(x=value), adjust=0.8) +
geom_rug(data=subset(ldataa,variable==x_val), aes(x=value)) +
geom_vline(xintercept = 1, linetype="longdash", alpha=0.3) +
geom_vline(xintercept = values$df[,input$hot_select$select$c])
dens.plot
}
})
}
shinyApp(ui = ui, server = server)
Update your reactiveValue dataframe from inside of an observeEvent, where you are watching for whichever event is useful, i.e. a click or something.
observeEvent(input$someInput{
values$df <- SOMECODE})

R Shiny, how to stop ggplot boxplots from updating themselves as in a group of linked boxplots

When I create a group of linked boxplots( selecting points in one boxplot highlights the corresponding points in all boxplots), the boxplots keep updating themselves for a uncertain amount of times (sometimes only once but sometimes up to 20 times).
Please run the following sample code.
I believe the source of problem is the geom_jitter(). Is there any way to stop the boxplots from updating themselves? Thanks.
library(shiny)
library(ggplot2)
server <- function(input, session, output) {
X = data.frame(x1 = rnorm(1000),
x2 = rnorm(1000),
week = sample(LETTERS[1:10],1000,replace = TRUE)
)
D = reactive({
brushedPoints(X,input$brush_1, allRows = TRUE)
})
output$p1 = renderPlot({
set.seed(123)
ggplot(D(),aes(x=week,y=x1))+
geom_boxplot() +
geom_jitter(aes(color=selected_))+
scale_color_manual(values = c("black","red"),guide=FALSE)
})
output$p2 = renderPlot({
set.seed(123)
ggplot(D(),aes(x=week,y=x2))+
geom_boxplot() +
geom_jitter(aes(color=selected_))+
scale_color_manual(values = c("black","red"),guide=FALSE)
})
}
ui <- fluidPage(
splitLayout(
plotOutput("p1",brush = "brush_1"),
plotOutput("p2",brush = "brush_1")
)
)
shinyApp(ui = ui, server = server)
Update: 2016-9-16
I tried replacing geom_jitter with geom_point, but the charts still keep updating themselves.
So geom_jitter may not be the suspect.
So what is the source of problem on earth?
library(shiny)
library(ggplot2)
server <- function(input, session, output) {
X = data.frame(x1 = rnorm(1000),
x2 = rnorm(1000),
week = sample(LETTERS[1:10],1000,replace = TRUE)
)
vals <- reactiveValues(
keeprows = rep(TRUE,nrow(X))
)
D = reactive({
R=cbind(X,vals$keeprows)
#print(sum(R[,"vals$keeprows"]==TRUE))
R
})
output$p1 = renderPlot({
set.seed(123)
ggplot(D(),aes(x=week,y=x1))+
geom_boxplot() +
geom_jitter(aes(colour=vals$keeprows))+
scale_color_manual(values = c("black","red"),guide=FALSE)
})
output$p2 = renderPlot({
set.seed(123)
ggplot(D(),aes(x=week,y=x2))+
geom_boxplot() +
geom_jitter(aes(color=vals$keeprows))+
scale_color_manual(values = c("black","red"),guide=FALSE)
})
observeEvent(input$brush_1,{
Res=brushedPoints(X,input$brush_1,allRows = TRUE)
vals$keeprows = Res$selected_
})
observeEvent(input$brush_2,{
Res=brushedPoints(X,input$brush_2,allRows = TRUE)
vals$keeprows = Res$selected_
})
observeEvent(input$exclude_reset,{
vals$keeprows = rep(TRUE,nrow(X))
})
}
ui <- fluidPage(
actionButton("exclude_reset","Reset"),
splitLayout(
plotOutput("p1",brush = brushOpts("brush_1",resetOnNew = TRUE)),
plotOutput("p2",brush = brushOpts("brush_2",resetOnNew = TRUE))
)
)
shinyApp(ui = ui, server = server)
guess the reason is source table always keep updating when you brush one of plots. cause all of your plots use the same brush id, can not identify which input$brush_1 is the real "brush" action. One chart has been brushed,input$brush_1 changed and reactive table D will be updated as well. Another plot based on the new reactive table plot again and make the input$brush_1 changed again...
From above thinking, based on your code, made a new one to distinguish the input brush action from different plots. the problem that boxplots keep updating themselves for a uncertain amount of times seems be solved. pls try below code:

Resources