Creating a shiny app with baseball data. When I run the following, everything appears fine except the second plot (line graph). I'm sure I'm missing something small but I haven't been able to solve it.
ui <- fluidPage(
selectInput(inputId = "num1",
label = "Select Pitcher",
choices = levels(PitcherName),
selected = NULL
),
fluidRow(plotOutput("PitchLoc"), width = 5,
plotOutput("PitchVol"), width = 5)
)
server <- function(input, output) {
output$PitchLoc <-renderPlot({
bp <- GameData %>% filter(PitcherName == input$num1,
)
ggplot(bp, aes(x=PlateLocSide, y=PlateLocHeight)) +
geom_point(aes(color = TaggedPitchType)) +
scale_color_manual(values = c('black','blue','red','purple','yellow')) +
geom_path(data = sz, aes(x=x, y=z)) +
xlim(-3,3) +
ylim(0,6) +
ggtitle("Pitch Location by Pitch Type")
})
output$PitchVol <-renderPlot({
vol <- GameData %>% filter(PitchSelect %in% c("Fastball", "Curveball", "Slider", "ChangeUp"),
Pitcher == input$num1
) %>%
ggplot(aes(x=PitchNo, y=RelSpeed,)) +
geom_line(aes(group=TaggedPitchType, color=TaggedPitchType)) +
ggtitle("Pitch Velocity")
})
}
shinyApp(ui = ui, server = server)
Your plotOutput width is outside the parentheses, i.e.
fluidRow(plotOutput("PitchLoc", width = 5),
plotOutput("PitchVol", width = 5))
Related
I would like click-select points and group them based on color.
I can save selected points with color information into a new data frame and plot it, however I would like to keep track and see what was already selected on the interactive plot.
How can I show/label already selected points or make it permanent after "Add selection"?
library(shiny)
library(tidyverse)
library(DT)
library(colourpicker)
ui = fluidPage(
colourInput("col", "Select colour", "purple"),
actionButton("addToDT", "Add selection", icon = icon("plus")), hr(),
plotOutput("plot", click = "plot_click", dblclick = "plot_reset"),
DT::dataTableOutput('plot_DT'), hr(),
textOutput("clickcoord"),
DT::dataTableOutput('final_DT'),
plotOutput("plotSelected")
)
server = function(input, output, session) {
selectedPoint = reactiveVal(rep(FALSE, nrow(mtcars)))
output$clickcoord <- renderPrint({
print(input$plot_click)
})
observeEvent(input$plot_click, {
clicked = nearPoints(mtcars, input$plot_click, allRows = TRUE)$selected_
selectedPoint(clicked | selectedPoint())
})
observeEvent(input$plot_reset, {
selectedPoint(rep(FALSE, nrow(mtcars)))
})
output$plot_DT = DT::renderDataTable({
mtcars$sel = selectedPoint()
mtcars = dplyr::filter(mtcars, sel == TRUE) %>% mutate(group_color = input$col)
})
final_DT = reactiveValues()
final_DT$df = data.frame()
FinalData = eventReactive(input$addToDT, {
mtcars$sel = selectedPoint()
mtcars = dplyr::filter(mtcars, sel == TRUE) %>% mutate(group_color = input$col)
final_DT$df = bind_rows(final_DT$df, mtcars)
})
output$final_DT = renderDataTable({FinalData()})
output$plot = renderPlot({
mtcars$sel = selectedPoint()
ggplot(mtcars, aes(wt, mpg, color = mtcars$sel, fill=mpg)) +
geom_point(shape = 21, size = 6, stroke = 2) +
scale_color_manual(values = c("#ffffff00", input$col)) +
scale_fill_viridis_c() +
theme_bw()
})
output$plotSelected = renderPlot({
sel_df = FinalData()
ggplot(sel_df, aes(wt, mpg, fill = group_color, colour = group_color)) +
geom_point(shape = 21, size = 6, stroke = 2) +
scale_color_manual(values = unique(sel_df$group_color)) +
scale_fill_manual(values = unique(sel_df$group_color)) +
theme_bw()
})
observeEvent(input$addToDT, {
selectedPoint(rep(FALSE, nrow(mtcars)))
})
}
shinyApp(ui, server)
I think this is the "crux" of what your are looking for. I used a very similar example that I found in the help for entitled:
A demonstration of clicking, hovering, and brushing
(https://shiny.rstudio.com/reference/shiny/0.13.1/plotoutput)
It is very similar to your example.
I create a matrix of T/F elements where the rows are the observations and the columns are in which batch the observation is selected. So when you launch the whole matrix is False, but as you click on observations the switch to positive in the first column. Then if you click addSelection and continue you start switching the observations in the next column.
Could you confirm that this what you are looking for?
Below is the code.
shinyApp(
ui = basicPage(
fluidRow(
column(
width = 4,
plotOutput("plot",
height = 300,
click = "plot_click", # Equiv, to click=clickOpts(id='plot_click')
),
actionButton("addToDT", "Add selection", icon = icon("plus")), hr(),
h4("Clicked points"),
tableOutput("plot_clickedpoints"),
),
column(
width = 4,
verbatimTextOutput("counter"),
),
)
),
server = function(input, output, session) {
data <- reactive({
input$newplot
# Add a little noise to the cars data so the points move
cars + rnorm(nrow(cars))
})
output$plot <- renderPlot({
d <- data()
plot(d$speed, d$dist, main = paste("No of Sets Chosen", input$addToDT))
})
output$plot_clickinfo <- renderPrint({
cat("Click:
")
str(input$plot_click)
})
selectedPoints <- reactiveVal(rep(FALSE, nrow(cars)))
selectionMatrix <- reactiveVal(matrix(data = F, nrow = nrow(cars), ncol = 7))
observeEvent(input$plot_click, {
clicked <- nearPoints(data(), input$plot_click, "speed", "dist", allRows = TRUE)$selected
selectedPoints(clicked | selectedPoints())
tmp <- unlist(selectionMatrix())
tmp[, (input$addToDT + 1)] <- selectedPoints()
selectionMatrix(tmp)
})
observeEvent(input$addToDT, {
selectedPoints(rep(FALSE, nrow(cars)))
})
output$plot_clickedpoints <- renderTable({
# if (input$addToDT==0) {
res <- selectionMatrix()
return(res)
})
}
)
I am trying to create a shiny app bar plot with dataframe columns (x variables) as input selections. One solution has been posted online already, but it has not worked for me.
My code is the following:
ui <- fluidPage(
sidebarLayout(position = "left",
sidebarPanel(
selectInput('x', "Funding:", choices = c('source_location',
'source_organizationtype','destination_purpose','destination_organizationtype'),
selected = NULL),
theme = shinytheme("cerulean")),
mainPanel(plotOutput("outplot"))
))
server <- function(input, output) {
output$outplot <- renderPlot( {
selected_data <- graph_funds_data %>% select(input$x, funding)
ggplot(selected_data, aes(x= reorder( !! input$x, funding), y = funding,
fill = !! input$x,
color = !! input$x)) +
geom_bar(position="stack", stat= 'identity') +
theme_minimal() + labs(x = as.name(input$x), y = 'Funding in Billions (USD)',
title = 'Total Incoming Ukraine Crisis Funding',
subtitle = 'January-April 2022') +
theme(legend.position="bottom", legend.title=element_blank(),
legend.direction="horizontal", legend.box="vertical")
} )
}
shinyApp(ui = ui, server = server, options = list(height=1000))
And I get 'Error: arguments must have same length'
I have also tried:
ui <- fluidPage(
sidebarLayout(position = "left",
sidebarPanel(
selectInput('x', "Funding:", choices = c('source_location',
'source_organizationtype','destination_purpose','destination_organizationtype'),
selected = NULL),
theme = shinytheme("cerulean")),
mainPanel(plotOutput("outplot"))
))
server <- function(input, output) {
output$outplot <- renderPlot( {
selected_data <- graph_funds_data %>% select(input$x, funding)
ggplot(selected_data(), aes(x= reorder(selected_data()[[input$x]], funding), y = funding,
fill = selected_data()[[input$x]],
color = selected_data()[[input$x]])) +
geom_bar(position="stack", stat= 'identity') +
theme_minimal() + labs(x = as.name(input$x), y = 'Funding in Billions (USD)',
title = 'Total Incoming Ukraine Crisis Funding',
subtitle = 'January-April 2022') +
theme(legend.position="bottom", legend.title=element_blank(),
legend.direction="horizontal", legend.box="vertical")
} )
}
shinyApp(ui = ui, server = server, options = list(height=1000))
And I get 'Error: Could not find function "selected_data"'
Does anyone know how to fix this?
I'm trying to create an app that allows 1) a user to hover over scatter plot points, which displays a label associated with the point, and 2) search for a specific point by label.
Currently, to highlight a point, I re-plot the graph each time the user submits a search term, adding that single point on top of rest of the points that have been plotted.
In order to avoid the server re-plotting before the user finishes typing the label, I require that the "search" button be pressed. However, I'm struggling to get the plot to display BEFORE the user has searched for any labels.
Here's what I have so far:
library(shiny)
library(ggplot2)
library(ggiraph)
df <- data.frame(x = rnorm(100), y = rnorm(100), label = paste("gene", seq(100)))
head(df)
x y label
1 -0.3383215 0.91212341 gene 1
2 -0.5318215 -0.63273778 gene 2
3 1.1281345 -0.01296204 gene 3
4 -1.2964345 -2.21689946 gene 4
5 1.5877938 -0.24993362 gene 5
6 0.6385419 0.07849135 gene 6
gg_scatter <- ggplot(data = df, aes(x, y)) +
geom_point_interactive(aes(tooltip = label, data_id = label))
ui <- fluidPage(
textInput(inputId = "gene_symbol",
label = "Search for a gene",
placeholder = "gene 1"),
actionButton(inputId = "go",
label = "Search"),
girafeOutput("scatterplot"),
textOutput("message")
)
server <- function(input, output) {
gene_search <- eventReactive(input$go, {
input$gene_symbol
})
output$scatterplot <-
renderGirafe({
gg_scatter_highlight <- gg_scatter +
geom_point_interactive(data = subset(df, label == gene_search()),
tooltip = gene_search(),
size = 3,
color = "red")
girafe(code = print(gg_scatter_highlight),
options = list(opts_selection(type = "single")))
})
output$message <- renderText({
if(sum(is.element(df$label, req(gene_search()))) == 0) {
paste("Gene not found")
}
})
}
shinyApp(ui = ui, server = server)
I'm trying to add something like this to output$scatterplot:
output$scatterplot <-
renderGirafe({
## If the user has not searched for anything, plot without any points highlighted
if(!isTruthy(gene_search)) {
girafe(code = print(gg_scatter),
options = list(opts_selection(type = "single")))
}
## Highlight the point that the user searched for
else {
gg_scatter_highlight <- gg_scatter +
geom_point_interactive(data = subset(df, label == gene_search()),
tooltip = gene_search(),
size = 3,
color = "red")
girafe(code = print(gg_scatter_highlight),
options = list(opts_selection(type = "single")))
}
})
... Unfortunately this still results in no plot being displayed until a label is searched.
Any help would be much appreciated.
Set ignoreNULL = FALSE in eventReactive to have a default value at the beginning.
library(shiny)
library(ggplot2)
library(ggiraph)
gg_scatter <- ggplot(data = df, aes(x, y)) +
geom_point_interactive(aes(tooltip = label, data_id = label))
ui <- fluidPage(
textInput(inputId = "gene_symbol",
label = "Search for a gene",
placeholder = "gene 1"),
actionButton(inputId = "go",
label = "Search"),
girafeOutput("scatterplot"),
textOutput("message")
)
server <- function(input, output) {
gene_search <- eventReactive(input$go, {
input$gene_symbol
}, ignoreNULL = FALSE)
output$scatterplot <-
renderGirafe({
gg_scatter_highlight <- gg_scatter +
geom_point_interactive(data = subset(df, label == gene_search()),
tooltip = gene_search(),
size = 3,
color = "red")
girafe(code = print(gg_scatter_highlight),
options = list(opts_selection(type = "single")))
})
output$message <- renderText({
if(sum(is.element(df$label, req(gene_search()))) == 0) {
paste("Gene not found")
}
})
}
shinyApp(ui = ui, server = server)
I create a barplot shiny app.
The biggest problem I met now is when I click the acitonbutton to get a new picture ,
the barplot appear delay and when I choose another input and click actionbutton again, the last barplot will appear but instantly disappear and the second picture appear.
But the input first and second time is different. Why the first picture will appear twice?
Here is my sample code,it is normal because it's a small sample.
library(shiny)
library(dplyr)
library(tidyr)
library(ggplot2)
library(gridExtra)
mean_data <- data.frame(
Name = c(paste0("Group_", LETTERS[1:20])),
matx <- matrix(sample(1:1000, 1000, replace = T), nrow = 20)
)
names(mean_data)[-1] <- c(paste0("Gene_", 1:50))
sd_data <- data.frame(
Name = c(paste0("Group_", LETTERS[1:20])),
matx <- matrix(runif(1000, 5, 10), nrow = 20)
)
names(sd_data)[-1] <- c(paste0("Gene_", 1:50))
###
ui <- fluidPage(
pageWithSidebar(
headerPanel("123"),
sidebarPanel(
selectInput(
"selectGeneSymbol",
"123:",
choices = colnames(mean_data)[-1],
multiple =F,
width = 400,
selected = 1
),
actionButton(inputId = "plot1", label = "FPKM"),
tags$h6(tags$a(href="https://www.ncbi.nlm.nih.gov/", "link",target = "_top"))
),
mainPanel(
plotOutput("plot")
#uiOutput("all")
)
)
)
server <- function(input, output, session) {
## put sd into mean_data
plotdata <- eventReactive(input$plot1, {
df <- mean_data %>% mutate(sd = sd_data[,input$selectGeneSymbol])
})
p1 <- eventReactive(input$plot1, {
ggplot(data = plotdata(), aes(x = Name, y = .data[[input$selectGeneSymbol]], fill=Name,
ymin = .data[[input$selectGeneSymbol]] - sd, ymax = .data[[input$selectGeneSymbol]] + sd )) +
geom_bar(stat = "identity", position = position_dodge(0.9), width = 0.9) +
# geom_errorbar(aes(ymin = plotdata()[,input$selectGeneSymbol] - sddata()[,input$selectGeneSymbol], ymax = plotdata()[,input$selectGeneSymbol] + sddata()[,input$selectGeneSymbol]), width = .2, position = position_dodge(0.9)) +
geom_errorbar(width = .2, position = position_dodge(0.9)) +
theme_classic2() +
rotate_x_text(angle = 45) +
theme(legend.position = "none") +
labs(title = input$selectGeneSymbol, x = NULL, y = "123_value")
})
output$plot <- renderPlot({
p1()
})
}
# Create Shiny app ----
shinyApp(ui = ui, server = server)
My real data is huge and I don't know if it is the main reason.
Or I should change the reactive() and EventReactive() or adjust the parameters ??
My sample data here is simple. You may not meet what the problem I met in my code.
I will show you some details, just like this:
That's ok.Though it may appeare slowly.
But when I choose another gene as input,
the first "Gene_1" result will appear again and then the "Gene_2" result will appear.
I hope somebody could help me or met this problem before.
Vary thankful.
As your data is large, there is a delay in generating the plot p1(). Hence, the previous plot is shown in renderPlot. The following update will show blank until a new plot is generated whenever user selects a new gene. Perhaps this will solve your issue. I cannot verify as I don't have large dataframe.
ui <- fluidPage(
pageWithSidebar(
headerPanel("123"),
sidebarPanel(
selectInput(
"selectGeneSymbol",
"123:",
choices = colnames(mean_data)[-1],
multiple =F,
width = 400,
selected = 1
),
actionButton(inputId = "plot1", label = "FPKM"),
tags$h6(tags$a(href="https://www.ncbi.nlm.nih.gov/", "link",target = "_top"))
),
mainPanel(
plotOutput("plot")
#,verbatimTextOutput("all")
)
)
)
server <- function(input, output, session) {
rv <- reactiveVal(0)
observeEvent(input$selectGeneSymbol, {rv(0)})
## put sd into mean_data
plotdata <- eventReactive(input$plot1, {
rv(0)
df <- mean_data %>% mutate(sd = sd_data[,input$selectGeneSymbol])
})
p1 <- eventReactive(input$plot1, {
req(plotdata())
p <- ggplot(data = plotdata(), aes(x = Name, y = .data[[input$selectGeneSymbol]], fill=Name,
ymin = .data[[input$selectGeneSymbol]] - sd, ymax = .data[[input$selectGeneSymbol]] + sd )) +
geom_bar(stat = "identity", position = position_dodge(0.9), width = 0.9) +
geom_errorbar(width = .2, position = position_dodge(0.9)) +
theme_classic2() +
rotate_x_text(angle = 45) +
theme(legend.position = "none") +
labs(title = input$selectGeneSymbol, x = NULL, y = "123_value")
rv(1)
p
})
observeEvent(input$plot1, {rv(1)})
output$plot <- renderPlot({
if (rv()) {
p1()
}
})
#output$all <- renderPrint(rv())
}
# Create Shiny app ----
shinyApp(ui = ui, server = server)
I'm creating a Shiny app to display survey results. I want to display the results in a plot with the question text as labels down the y-axis. (The plot is more complicated than the demo version below). I want to use plotly so that the data labels will appear with the mouse hover.
The problem is that the long y-axis labels cause the plot shape to be completely distorted: everything is pushed off to the right, leaving a lot of white space on the left.
I tried adding line breaks manually (using <br> or \n), but the plot is still pushed to the right. I also specified the "width" in the ggplotly call; this makes it wider, but still pushes it to the right.
Is it possible to control these things, either within plotly or within ggplot2?
UPDATE EDIT: Here is the solution I discovered, in case it helps anyone else. It has two parts:
1) Set the margins manually in the layout() call after ggplotly(): https://plot.ly/r/setting-graph-size/ (You can also adjust the overall plot width in the UI inside the plotlyOutput() call.)
layout(autosize = TRUE, margin = list(l = 300, r = 0, b = 0, t = 0, pad = 4))
2) Use a string wrapping function to split the labels, as suggested by Rushabh in his answer. I like the tidyverse version:
scale_x_discrete(labels = function(x) str_wrap(x, width = 40))
This is a demo where you can view both the problem and solution:
library(shiny)
library(plotly)
library(tidyverse)
ui <- fluidPage(
titlePanel("Problems with Plotly"),
sidebarLayout(
sidebarPanel(
radioButtons("view", "View", choices = c("Problem", "Solution")),
width = 3
),
mainPanel(
fluidRow(
column(6, HTML("Other content fills up this column")),
column(6, plotlyOutput("plot", width = "600px"))
)
)
)
)
server <- function(input, output) {
output$plot <- renderPlotly({
df <- tibble(
Label = paste0(
"Very long survey question that has to be spelled out completely ",
1:5
),
Value = sample(5:10, 5, replace = TRUE)
)
if (input$view == "Problem") {
p <- ggplot(df, aes(Label, Value)) +
geom_col() +
coord_flip() +
labs(x = "")
ggplotly(p) %>%
config(displayModeBar = FALSE)
} else { # input$view == "Solution"
p <- ggplot(df, aes(Label, Value)) +
geom_col() +
coord_flip() +
labs(x = "") +
scale_x_discrete(labels = function(x) str_wrap(x, width = 40))
ggplotly(p) %>%
config(displayModeBar = FALSE) %>%
layout(autosize = TRUE, margin = list(
l = 300, r = 0, b = 0, t = 0, pad = 4
))
}
})
}
shinyApp(ui = ui, server = server)
Here's the original sample showing my attempts that didn't work:
library(shiny)
library(plotly)
library(tidyverse)
label <- "Very long survey question that has to be spelled out completely "
label_break <- "Very long survey question that<br>has to be spelled out completely "
ui <- fluidPage(
titlePanel("Problems with Plotly"),
sidebarLayout(
sidebarPanel(
radioButtons("tried", "Things I've tried",
c("Adding line breaks" = "breaks",
"Adding 'width' to ggplotly call" = "width",
"Both",
"Neither"),
selected = "Neither")
),
mainPanel(
fluidRow(
column(6, HTML("Some content goes on this side")),
column(6, plotlyOutput("plot"))
)
)
)
)
server <- function(input, output) {
output$plot <- renderPlotly({
df <- tibble(
Label = paste0(ifelse(input$tried %in% c("breaks", "Both"),
label_break, label), 1:5),
Value = sample(5:10, 5, replace = TRUE)
)
p <- ggplot(df, aes(Label, Value)) +
geom_col() +
coord_flip() +
labs(x = "")
if (input$tried %in% c("width", "Both")) {
ggplotly(p, width = 1000)
} else {
ggplotly(p)
}
})
}
shinyApp(ui = ui, server = server)
Try Below Code -
library(shiny)
library(plotly)
library(tidyverse)
label <- "Very long survey question that has to be spelled out completely "
ui <- fluidPage(
titlePanel("Problems with Plotly"),
sidebarLayout(
sidebarPanel(
fluidRow(
radioButtons("tried", "Things I've tried",
c("Adding line breaks" = "breaks",
"Adding 'width' to ggplotly call" = "width",
"Both",
"Neither"),
selected = "Neither")
),
mainPanel(
fluidRow(
column(2,HTML("Some content goes on this side"),plotlyOutput("plot"))
)
)
)
)
)
server <- function(input, output) {
output$plot <- renderPlotly({
df <- tibble(
Label = paste0(label, 1:5),
Value = sample(5:10, 5, replace = TRUE)
)
p <- ggplot(df, aes(Label, Value)) +
geom_col() +
coord_flip() +
labs(x = "") +
scale_x_discrete(labels = function(x) lapply(strwrap(x, width = 20, simplify = FALSE), paste, collapse="\n"))
ggplotly(p,width = 1000)
})
}
shinyApp(ui = ui, server = server)
Note: You can adjust ggplot's tick lables using below code chunk-
scale_x_discrete(labels = function(x) lapply(strwrap(x, width = 20, simplify = FALSE), paste, collapse="\n"))