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()
})
})
Related
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)
I want to use the output of ggtern() in a shiny app. However it seems to fail due to some constraints.
This is what it should look like:
This is the actual shiny output:
See here for a reproducible example:
library(shiny)
library(ggtern)
ui <- fluidPage(
mainPanel(
plotOutput("ggtern")
)
)
server <- function(input, output) {
output$ggtern <- renderPlot({
ggtern(data.frame(x=10, y=30, z=60), aes(x, y, z)) + geom_point()
})
}
shinyApp(ui = ui, server = server)
Do I overlook something?
place the plot function within a print command:
output$ggtern <- renderPlot({
print(ggtern(data.frame(x=10, y=30, z=60), aes(x, y, z)) + geom_point())
})
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
})
})
}
I have just learning R shiny package and for one of the exercise in a course, we have to create an app that has two dropdown menus in the sidebar and a ggplot2 plot in the main panel
I almost figured out most of the R code but i am getting error (object 'input' not found) during plotting. Can someone point to me of where i am doing wrong?
ui.R
library(shiny)
shinyUI(fluidPage(
# Application title
titlePanel("Demonstration of 2 dropdown menus"),
# Sidebar with a slider input for number of bins
sidebarLayout(
sidebarPanel(
selectInput("element_id1", "select variable for x-axis", c("mpg", "cyl", "disp", "hp", "wt"), selected = "wt"),
selectInput("element_id2", "select variable for x-axis", c("mpg", "cyl", "disp", "hp", "wt"), selected = "mpg")
),
# Show a plot of the generated distribution
mainPanel(
textOutput("id1"),
textOutput("id2"),
plotOutput("plt")
)
)
))
server.R
library(shiny)
library(ggplot2)
shinyServer(function(input, output) {
output$id1 <- renderText({
sprintf("You have selected %s on the x-axis", input$element_id1)
})
output$id2 <- renderText({
sprintf("You have selected %s on the y-axis", input$element_id2)
})
output$plt <- renderPlot(
ggplot(mtcars, aes(x = input$element_id1, y = input$element_id2)) + geom_point()
)
})
You are providing character variable to mention which are your axis in ggplot. Hence you need to use aes_string when you build your graph:
ggplot(mtcars, aes_string(x = input$element_id1, y = input$element_id2)) + geom_point()
Dummy example:
df = data.frame(x=1:3, y=c(4,5.6,1))
ggplot(df, aes(x=x, y=y)) + geom_line()
ggplot(df, aes_string(x='x', y='y')) + geom_line()
Both provide the same results.
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()