I'm creating a plot using ggplotly() and I'd like the Spearman's rank correlation [I'm storing here as the reactive value rho] to appear when hovering over the line created with geom_smooth. I found an article on the plotly website for doing this in python (https://plot.ly/python/linear-fits/) but I'm unsure how to achieve this in R. Any help or leads appreciated!!
library(shiny)
library(plotly)
ui <- fluidPage(
mainPanel(plotlyOutput("line_plot"),
verbatimTextOutput("rho"))
)
# Define server logic required to draw a histogram
server <- function(input, output) {
# calculate rho to be printed over line
rho <- reactive({ cor.test(x = iris$Sepal.Length, y = iris$Sepal.Width, method='spearman')[[4]] })
output$rho <- renderText(paste0("rho: ", rho()))
output$line_plot <- renderPlotly({
p <- ggplotly(
ggplot(iris, aes(x = Sepal.Length, y = Sepal.Width)) +
geom_point() +
# would I add the tooltip text here?
# I know I need it to be:
# "<b> rho: </b>", rho(), "<br/>",
geom_smooth(method=lm, se=FALSE, color = "red") +
theme_minimal()
)
})
}
# Run the application
shinyApp(ui = ui, server = server)
You can add the unoffical aesthetics text:
library(shiny)
library(plotly)
ui <- fluidPage(
mainPanel(plotlyOutput("line_plot"),
verbatimTextOutput("rho"))
)
# Define server logic required to draw a histogram
server <- function(input, output) {
# calculate rho to be printed over line
rho <- reactive({ cor.test(x = iris$Sepal.Length, y = iris$Sepal.Width, method='spearman')[[4]] })
output$rho <- renderText(paste0("rho: ", rho()))
output$line_plot <- renderPlotly({
p <- ggplotly(
ggplot(iris, aes(x = Sepal.Length, y = Sepal.Width)) +
geom_point() +
geom_smooth(method=lm, se=FALSE, color = "red", aes(text = paste0("<b> rho: </b>", rho()))) +
theme_minimal()
)
})
}
# Run the application
shinyApp(ui = ui, server = server)
Related
I have a trivial question after playing with this code
library(gapminder)
ui <- fluidPage(
sidebarLayout(
sidebarPanel(
checkboxInput("fit", "Add line of best fit", FALSE),
selectInput("continents", "Continents",
choices = levels(gapminder$continent),
multiple = TRUE,
selected = 'Europe')
),
mainPanel(
plotOutput("plot")
)
)
)
server <- function(input, output) {
output$plot <- renderPlot({
data <- subset(gapminder,
continent %in% input$continents)
p <- ggplot(data, aes(gdpPercap, lifeExp)) +
geom_point() +
scale_x_log10()
if (input$fit) {
p <- p + geom_smooth(method = "lm")
}
p
})
}
shinyApp(ui = ui, server = server)
If I change part of the code above to this
if (input$fit) {
p + geom_smooth(method = "lm")
}
# p
})
}
The plot won't be displayed. Why do we have to be too verbose, that is, passing p + geom_smooth() to p, then calling p for it to work? Why can't we be more succinct by simply calling p + geom_smooth()? Is it because the code is wrapped inside renderPlot()?
Thankyou.
Based on your if statement, the plot is returned and then rendered in case input$fit is TRUE. If input$fit is FALSE, the if statement returns NULL and therefore no plot is rendered. This is the default behaviour of if() in R.
You can solve your problem by simply add else p to your if statement like
if (input$fit) p + geom_smooth(method = "lm") else p
My file is one set of game data and PitchNo tells the pitch of the game. I am trying to generate plots of each batter's pitches seen in a game and I have labeled the PitchNo in the ggplot function. I want my plot for each batter to label the pitches seen, say 1-10, but instead it is still labeling them as the PitchNo of the game.
I added Batter$PitchNo <- 1:nrow(Batter) in my reactive filter. That line of code works in normal R but I cannot seem to find a way to make in work in a Shiny app.
library(shiny)
library(tidyverse)
GameDataFile <- read_csv("GameDataFile.csv")
GameDataFile %>% group_by(PitchNo)
playerlist <- sort(unique(GameDataFile$Batter))
ui = fluidPage(
titlePanel("Title"),
sidebarLayout(
sidebarPanel(
selectInput(
inputId="Batter1",
label="Player:",
choices = playerlist)
),
mainPanel(
plotOutput("myZone")
)))
server = function(input, output){
output$myZone <- renderPlot({
GameDataFile$PlateLocSide <- (GameDataFile$PlateLocSide * -1)
newdata <- reactive({
GameDataFile %>% filter(
Batter %in% c(input$Batter1),
Batter$PitchNo <- 1:nrow(Batter)) # Error is here
})
ggplot(data = newdata(), aes(x = PlateLocSide, y = PlateLocHeight)) +
xlim(-2.5,2.5) + ylim(0,5) + scale_fill_viridis_c() + geom_point() +
labs(x = "", y = "") + facet_wrap(~ Batter, ncol = 2) +
geom_text(aes(label = PitchNo), vjust = -0.5) + theme_bw() +
theme(strip.text = element_text(size=20, face="bold"))
}, width=400, height=500)
}
shinyApp(ui = ui, server = server)
How would you implement something like this in R?
Selection histogram
Utilizing the scatterplot selection is the hard part. I haven't seen anything similar in Shiny or plotly.
In case anybody needs it in the future.
ui.R
library(shiny)
library(ggplot2)
shinyUI(basicPage(
titlePanel("Number of forward gears of selected cars"),
plotOutput("plot",brush = "plot_brush"),
plotOutput("histo",height="200px")
))
server.R
library(shiny)
library(ggplot2)
shinyServer(function(input, output) {
output$plot <- renderPlot({
ggplot(mtcars, aes(x=wt, y=mpg,color=as.factor(gear))) + geom_point() + labs(y= 'Miles per gallon',x = 'Weight (1000 lbs)')
})
output$histo <- renderPlot({
selected_points<-brushedPoints(mtcars, input$plot_brush, xvar = "wt", yvar = "mpg")
ggplot(data=selected_points, aes(selected_points$gear,fill = as.factor(gear))) + geom_bar() + labs(x="Forward Gears", y="Count") + coord_flip() +theme_minimal()
})
})
I'm trying to create an app that displays an animation of sampling means using Shiny. Something similar to the example shown here.
Here's some minimal code showing just the section I'm having trouble with. This is not the data I'm using, but a reproducible example data set.
library(shiny)
library(ggplot2)
data <- data.frame(ID=1:60,
x=sort(runif(n = 60)),
y=sort(runif(n = 60)+rnorm(60)))
ui <- fluidPage(
sidebarPanel(
sliderInput("n",
"Number of samples:",
min = 10,
max = 100,
value = 20),
sliderInput("surveys",
"Number of surveys:",
min = 10,
max = 100,
value = 20),
checkboxInput("replacement",
"Sample with replacement?"),
actionButton("button", "Go!")
),
# Show the plot
mainPanel(
plotOutput("plot1")
)
)
server <- function(input, output) {
output$plot1 <- renderPlot({
plot1 <- ggplot(data, aes(x=x, y=y)) + geom_point(colour="red") + theme_bw()
plot1 <- plot1 + geom_vline(xintercept = mean(data$x), size=1.1, colour="red")
plot1
for(i in 1:20){
data$sampled <- "red"
sample.rows <- sample(data$ID, 20, replace = F)
data$sampled[sample.rows] <- "green"
plot1 <- plot1 + geom_point(x=data$x, y=data$y, colour=data$sampled, size=2)
sample.mean.x <- mean(data$x[sample.rows])
plot1 <- plot1 + geom_vline(xintercept = sample.mean.x, colour="green")
print(plot1)
Sys.sleep(1.5)
}
})
}
# Run the application
shinyApp(ui = ui, server = server)
The part within renderPlot({ ... }) does exactly what I want when pasted into the console, but how do I get this to happen in Shiny? Ideally, I would also like the plot to appear first, and then the animation (green bars) to start when the actionButton is clicked.
Thanks!
You can use reactiveTimer to do that. I have modified the server part of your code. In the code below I have set the timer for two seconds so that the plot updates every two seconds.
server <- function(input, output) {
autoInvalidate <- reactiveTimer(2000)
plot1 <- NULL
output$plot1 <- renderPlot({
plot1 <<- ggplot(data, aes(x=x, y=y)) + geom_point(colour="red") + theme_bw()
plot1 <<- plot1 + geom_vline(xintercept = mean(data$x), size=1.1, colour="red")
plot1
})
observeEvent(input$button,{
output$plot1 <- renderPlot({
autoInvalidate()
data$sampled <- "red"
sample.rows <- sample(data$ID, 20, replace = F)
data$sampled[sample.rows] <- "green"
plot1 <<- plot1 + geom_point(x=data$x, y=data$y, colour=data$sampled, size=2)
sample.mean.x <- mean(data$x[sample.rows])
plot1 <<- plot1 + geom_vline(xintercept = sample.mean.x, colour="green")
plot1
})
})
}
[EDIT]:
As you wanted the loop to be run only 20 times I have modified the code with the help of the answer in this link so that the reactive timer is run only till the count is 20. Here is the code that you need to add from the link:
invalidateLaterNew <- function (millis, session = getDefaultReactiveDomain(), update = TRUE)
{
if(update){
ctx <- shiny:::.getReactiveEnvironment()$currentContext()
shiny:::timerCallbacks$schedule(millis, function() {
if (!is.null(session) && session$isClosed()) {
return(invisible())
}
ctx$invalidate()
})
invisible()
}
}
unlockBinding("invalidateLater", as.environment("package:shiny"))
assign("invalidateLater", invalidateLaterNew, "package:shiny")
Here is the server code for it:
server <- function(input, output, session) {
count = 0
plot1 <- NULL
output$plot1 <- renderPlot({
plot1 <<- ggplot(data, aes(x=x, y=y)) + geom_point(colour="red") + theme_bw()
plot1 <<- plot1 + geom_vline(xintercept = mean(data$x), size=1.1, colour="red")
plot1
})
observeEvent(input$button,{
count <<- 0
output$plot1 <- renderPlot({
count <<- count+1
invalidateLater(1500, session, count < 20)
data$sampled <- "red"
sample.rows <- sample(data$ID, 20, replace = F)
data$sampled[sample.rows] <- "green"
plot1 <<- plot1 + geom_point(x=data$x, y=data$y, colour=data$sampled, size=2)
sample.mean.x <- mean(data$x[sample.rows])
plot1 <<- plot1 + geom_vline(xintercept = sample.mean.x, colour="green")
plot1
})
})
}
Just discovering shiny apps but this is driving me insane.......I have looked at numerous examples of server.R and ui.R code and cannot figure out what I am doing wrong. Apologies in advance if it's something very basic..........
Taking the iris dataset as an example, I want to plot one column against another, something simple using qplot or preferably ggplot
However, using qplot I get this:
and using ggplot2, I get the error:
I don't think I need the reactive function as I'm not subsetting the dataset, just extracting columns to plot.
server.R code
library(shiny)
library(shinyapps)
library(ggplot2)
shinyServer(function(input, output, session) {
output$text1 <- renderText({input$id1})
output$text2 <- renderText({input$select1})
output$plot1 <- renderPlot({
g <- qplot(Sepal.Length, input$select1, data = iris)
print(g)
})
})
or using ggplot function to replace the qplot call
g <- ggplot(iris, aes(x = Sepal.Length, y = input$select1))
g <- g + geom_line(col = "green", lwd =1) +
labs(x = "Date", y = "Ranking") +
theme_bw() + scale_y_reverse()
ui.R code
library(shiny)
library(shinyapps)
data(iris)
opts <- unique(colnames(iris))
opts <- opts[-1] ## want to keep Sepal.Length as the x values
shinyUI(pageWithSidebar(
headerPanel('test with iris database'),
sidebarPanel(
selectInput(inputId = "select1", label = "select",
choices = opts),
textInput(inputId = "id1", label = "Input Text", "")
),
mainPanel(
p('Output text1'),
textOutput('text1'),
textOutput('text2'),
plotOutput('plot1')
)
))
Change your aes statement to aes_string and make x a string. This should fix the problem.
g <- ggplot(iris, aes_string(x = "Sepal.Length", y = input$select1))
g <- g + geom_line(col = "green", lwd =1) +
labs(x = "Date", y = "Ranking") +
theme_bw() + scale_y_reverse()