Bar switching positions in interactive geom_bar - r

Pb: when I click on the geom_bar bar, the bars switch positions even though I properly set the levels in the aes call.
Please try below the simplest example I could come up with.
All it does is add alpha to the bars below the clicked one.
Problem: click bars and see them switching position.
The alpha is added with the 'type' variable that is updated in dat() on click event.
If I deactivate the aes call in geom_bar the problem doesn't occur. Nor does it happen if I place the alpha in the main aes() rather than geom_bar's one.
The reactiveVal dat()'s type is unchanged, so even though the bars switch position, for the click logic they do not (you can test this by clicking on the same spot twice: on the first bar will switch position, not in the second).
library(shiny); library(tidyverse)
ui <- function() {
plotOutput(outputId = "bar",click = "click")
}
server <- function(input, output, session) {
dat <- reactiveVal(
tibble(value = 1:4,
name = c("a", "b", "a", "b"),
type = c("small", "small", "big", "big"),
cut_off = TRUE )
)
last_click <- reactiveVal(NULL)
observeEvent(input$click, {
if (!is.null(input$click)) last_click(input$click)
})
clicked_sample <- eventReactive(last_click(), {
if (is.null(last_click())) return(NULL)
click_x <- last_click()$x
splits <- seq(1/4, 1 - 1/4, 1/2)
sample_lvls <- dat()$name %>%
as_factor() %>%
levels()
clicked_sample_name <- sample_lvls[round(click_x)]
types <- dat()$type %>% unique() %>% sort()
x <- click_x - round(click_x) + 1/2
clicked_type <- types[which.min(abs(splits - x))]
dat() %>%
filter(type == clicked_type & name == clicked_sample_name)
}, ignoreNULL = FALSE)
observeEvent(clicked_sample(), {
dat(
dat() %>%
mutate(cut_off = if_else(
value >= clicked_sample()$value,
TRUE,
FALSE,
missing = FALSE)
)
)
})
output$bar <- renderPlot({
g <- ggplot(dat()) +
aes(x = name, y = value,
fill = factor(type,
levels = type %>%
as.character() %>%
unique() %>%
sort())) +
geom_bar(
aes(alpha = cut_off %>% factor(levels = c(FALSE, TRUE))),
position = "dodge",
stat = "identity"
) +
scale_alpha_discrete(guide = "none", drop = FALSE)
if (!is.null(clicked_sample()$value)) {
g + geom_hline(yintercept = clicked_sample()$value)
} else {
g
}
})
}
shinyApp(ui, server)

The issues appears to be that as it is the bars start off being ordered by value within the groups a and b, however as you click the bars the values of your cutoff variable change from all TRUE to being a mixture of TRUE and FALSE. This then causes the plot to try to sort the bars within the groups by the cutoff value since it is a factor (the bars with a TRUE value are always switched to the right of any bar with a FALSE, while the FALSE bars go back to being sorted by value, all within the groups a and b). To avoid this from happening, you can include all of your aes within the geom_bar, so your plot function would be like this:
g <- ggplot(dat()) +
geom_bar(
aes(x = name, y = value,
fill = factor(type,
levels = type %>%
as.character() %>%
unique() %>%
sort()),
alpha = cut_off %>% factor(levels = c(FALSE, TRUE))),
position = "dodge",
stat = "identity"
) +
scale_alpha_discrete(guide = "none", drop = FALSE)

Related

r shiny and ggplot2::facet_wrap how can I add categories to facet_wrap without having the original plot resize?

I have a shiny app that lets the user add categories to the facet_wrap. When I start with one category the plot fills the entire box but when I add a second category, the initial plot adjusts to half the initial size. Is there any way I can set the size, such that the first facet fits half the box and doesn't adjust in size when I add a second category?
Here's what I happens when I choose a second facet category:
Current behavior
Here's what I want to happen:
desired behavior
Here is a simple reprex--when you add a second feature from select feature, it adjusts the size of the first plot.
I found a decent solution and added it to this example using the ggh4x::facet_manual. However, this solution does not work with ggplotly and in a bs4dash box, it starts to look crammed in my app where there are upwards of 40 plots. Ideally, I'd like the box to be scrollable. Thanks in advance for any suggestions!
library(shiny)
library(tidyverse)
library(glue)
library(ggh4x)
library(plotly)
library(janitor)
library(bs4Dash)
iris_df <- iris %>%
clean_names() %>%
mutate(extra_feature1 = sepal_length,
extra_feature2 = sepal_width,
extra_feature3 = petal_length,
extra_feature4 = petal_width,
extra_feature5 = sepal_length,
extra_feature6 = sepal_width,
extra_feature7 = petal_length,
extra_feature8 = petal_width) %>%
select(species, everything()) %>%
pivot_longer(-species) %>%
mutate(feature = glue("{name}_{species}"))
iris_species <- iris_df %>%
clean_names() %>%
distinct(species) %>%
pull()
iris_features <- iris_df %>%
clean_names() %>%
distinct(feature) %>%
pull()
# Define UI for application that draws a histogram
ui <- dashboardPage(dark = FALSE,
# Application title
dashboardHeader("Reprex"),
# Sidebar with a slider input for number of bins
dashboardSidebar(skin = "light",
selectInput("species",
"Select species:",
choices = iris_species,
selectize = FALSE,
multiple = TRUE,
selected = iris_species[1]
),
selectInput("features",
"Select feature:",
choices = iris_features,
selectize = TRUE,
multiple = TRUE,
selected = iris_features[1]
),
radioButtons("facets", label = "View all features:",
choices = list("On" = "facet_wrap", "Off" = ""),
selected = "", inline = FALSE)),
# Show a plot of the generated distribution
dashboardBody(
fluidRow(box(
plotOutput("densityPlot"),
width=12,
headerBorder = FALSE,
collapsible = FALSE))
))
# Define server logic required to draw a histogram
server <- function(input, output, session) {
observeEvent(input$species,
{updateSelectInput(session,
"features",
choices = unique(iris_df$feature[iris_df$species == input$species]),
selected = iris_df$feature[1])
})
design <- matrix(c(1:12), 2, 6, byrow = FALSE)
output$densityPlot <- renderPlot({
if (input$facets == '') {
p1 <- iris_df %>%
filter(species %in% input$species) %>%
filter(feature %in% input$features) %>%
ggplot(aes(value, fill = species)) +
geom_density(alpha = .5) +
theme_light() +
facet_manual(~name, scales = "free", design = t(design), respect = FALSE)
#facet_wrap(~name, scales = "free")
p1
}
else {
iris_df %>%
filter(species %in% input$species) %>%
ggplot(aes(value, fill = species)) +
geom_density(alpha = .5) +
theme_light() +
facet_wrap(~name, ncol = 2, scales = "free")
}
})
}
# Run the application
shinyApp(ui = ui, server = server)

How to select a column from a dynamic input variable?

I'm using flexdashboard and shiny to choose which variable to plot:
varSelectInput("button_var_fir"
, "Select first num variable"
, data = df_scat,
multiple = FALSE
)
ggplot(df_scat, aes(x = !!input$button_var_fir, y = Gen_type, fill = stat(x))) +
geom_point(size= 3, alpha = .075)
it works fine, so far. My problem is, that I would like to subset the data e.g via
df$variable > 0
ggplot(df_scat, aes(x = df$!!input$button_var_fir > 0, y = Gen_type, fill = stat(x))) +
geom_point(size= 3, alpha = .075)
but this doesn't work due to the $!!. How can I solve this?
In {ggplot2}, which uses tidy evaluation, you can use the .data pronoun to dynamically select variables. It's nicely explained outside the {shiny} context in this answer too. This doesn't apply in {plotly} so you can either select with x = data[[input$column]] or x = get(input$column). This is also explained in this question.
Here's a small example to demonstrate how to do this for each plotting function.
library(plotly)
library(tidyverse)
library(shiny)
nbins <- 10
ui <- fluidPage(titlePanel("Dynamic Variable Selection"),
sidebarLayout(sidebarPanel(
selectInput(
inputId = "y1",
label = "Select variable",
choices = names(mtcars))),
mainPanel(plotOutput(outputId = "ggplot"),
plotlyOutput(outputId = "plotly"))))
server <- function(input, output) {
# dynamically pull variable in ggplot
output$ggplot <- renderPlot({
mtcars %>%
ggplot(aes(x = .data[[input$y1]])) +
geom_histogram(bins = nbins) +
ggtitle("ggplot")})
# dynamically pull variable in plotly
output$plotly <- renderPlotly({
mtcars %>%
plot_ly(x = .[[input$y1]], type = "histogram", nbinsx = nbins) %>%
layout(title = list(text = "Plotly"),
xaxis = list(title = input$y1))
})
}
shinyApp(ui = ui, server = server)
Maybe what you want is
df[[input$button_var_fir]] > 0
instead of df$!!input$button_var_fir > 0.
Addition:
You want to subset the data that goes into the plot, right? What I would actually do is subsetting the dataframe itself before it goes into the plot function. When you use the tidyverse this could be what you want:
df_scat %>%
filter(!!input$button_var_fir > 0) %>%
ggplot(aes(x = !!input$button_var_fir, y = Gen_type, fill = stat(x))) +
geom_point(size= 3, alpha = .075)

Looping through R Plotly with subplot and hiding all legend except one

I need to loop through i iteration of factors, and each factor needs to be plotted as one plot in a subplot. What I would like to do is hiding the legend for every iteration bar the first one, and use legendgroup to tie all the legends together. This is what I have done so far:
library(plotly)
library(dplyr)
mtcars %>%
mutate(vs = as.factor(vs)) %>%
group_split(cyl) %>%
lapply(function(i) {
#show.legend <- ifelse(i == 1, TRUE, FALSE)
show.legend <- if(i == 1) {TRUE} else {FALSE}
plot_ly(
data = i
,x = ~gear
,y = ~mpg
,color = ~vs
,type = "bar"
,legendgroup = ~vs
) %>%
layout(
barmode = "stack"
,showlegend = show.legend
)
}) %>%
subplot(
nrows = NROW(.)
,shareX = TRUE
,shareY = TRUE
,titleX = TRUE
,titleY = TRUE
,margin = 0.05
)
However this produces an error and no legend:
Warning messages:
1: In if (i == 1) { :
the condition has length > 1 and only the first element will be used
If I use show.legend <- ifelse(i == 1, TRUE, FALSE) (commented out above), I get multiple legends instead of just once.
I am aware I could do the below, but I need to this in a loop.
p1 <- plot_ly(blah, showlegend = TRUE)
p2 <- plot_ly(blah, showlegend = FALSE)
P3 <- plot_ly(blah, showlegend = FALSE)
subplot(p1,p2,p3)
I believe I am not calling the i iteration properly. As another option I tried case_when:
show.legend <- case_when(
i == 1 ~ TRUE
,i != 1 ~ FALSE
)
However this produces the same result as ifelse.
There are two issues in your code:
i is not 1:3 but your current tibble you are iterating through via lapply (see seq_along below).
That is why you get the warning:
In if (i == 1) { : the condition has length > 1 and only the first
element will be used
showlegend needs to be an argument to plot_ly not to layout because subplot always adopts the layout from one of its plots. see ?subplot and its argument which_layout.
layout options found later in the sequence of plots will override
options found earlier in the sequence
Here is what I think you are after:
library(plotly)
library(dplyr)
tibble_list <- mtcars %>%
mutate(vs = as.factor(vs)) %>%
group_split(cyl)
lapply(seq_along(tibble_list), function(i) {
show_legend <- if (i == 1) {TRUE} else {FALSE}
plot_ly(
data = tibble_list[[i]],
x = ~ gear,
y = ~ mpg,
color = ~ vs,
type = "bar",
legendgroup = ~ vs,
showlegend = show_legend
) %>% layout(barmode = "stack")
}) %>% subplot(
nrows = NROW(.),
shareX = TRUE,
shareY = TRUE,
titleX = TRUE,
titleY = TRUE,
margin = 0.05,
which_layout = 1
)
Please find an offical example here.
library(plotly)
library(dplyr)
## store plot as variable p
p <- mtcars %>%
mutate(vs = as.factor(vs)) %>%
group_split(cyl) %>%
lapply(function(i) {
plot_ly(
data = i
,x = ~gear
,y = ~mpg
,color = ~vs
,type = "bar"
,showlegend = TRUE ## include all legends in stored variable
) %>%
layout(
barmode = "stack"
)
}) %>%
subplot(
nrows = NROW(.)
,shareX = TRUE
,shareY = TRUE
,titleX = TRUE
,titleY = TRUE
,margin = 0.05
)
## remove unwanted legends from plot
for (i in seq(3, length(p[["x"]][["data"]]))) {
p[["x"]][["data"]][[i]][["showlegend"]] <- FALSE
}
## show plot
p

R: How to change plot background color for a specific range in ggvis shiny app

I have a simple shiny app like below and you can run it. The plots are created by ggvis and user can choose student name from inputSelect. In the plots, I want to change the color of background in specific score range. For example, in each plot, the color of plot background for the score higher than 80 or lower than 50 are highlighted with blue(See picture attached). I was trying to add layers and draw rectangles onto plot using layer_rects(), but the problem is the values of x-axis are changed if different students are chosen.Anyone did this before or any ideas? And is it possible if I want only the points in that score range pop up? Thanks a lot!
library(shiny)
library(ggvis)
df <- data.frame(Student = c("a","a","a","a","a","b","b","b","b","b","c","c","c","c"),
year = c(seq(2001,2005,1),seq(2010,2014,1),seq(2012,2015,1)),
score = runif(14,min = 50,max = 100), stringsAsFactors=F)
ui = (fluidPage(
sidebarLayout(
sidebarPanel(
selectInput("stu","Choose Student",
choice = unique(df$Student))
),
mainPanel(ggvisOutput("plot"))
)
)
)
server = function(input,output,session){
dataInput = reactive({
gg = df[which(df$Student == input$stu),]
})
vis = reactive({
data = dataInput()
data %>%
ggvis(x = ~year, y = ~score) %>%
scale_numeric("y",domain = c(40,120))%>%
layer_lines()
})
vis %>% bind_shiny("plot")
}
runApp(list(ui = ui, server = server))
To have the width of the rectangles to change with the x-axis variable, you can use x = ~min(year) and x2 = ~max(year). I'm not sure how to make the variables dependent on the current scale limits, which seems like it would be a nicer solution. But, this should work. For example, the lower rectangle would be
layer_rects(x = ~min(year), x2 =~max(year),
y = 40-3.5, y2 = 50, opacity := 0.05, fill := "blue")
It isn't vectorized for different limits (at least it didn't look to be), so you can write a function to simplify having multiple rectangles. The whole server would look like
shinyServer(function(input,output,session){
dataInput = reactive({
gg = df[which(df$Student == input$stu),]
})
buffer <- 3.5 # set to make the rectangle reach the scale boundaries
rectLims <- list(lower=c(40-buffer, 80), upper=c(50, 120+buffer))
make_rect <- function(vis, lims, buffer=buffer) {
for (i in seq_along(lims$lower))
vis <- layer_rects(vis, x = ~min(year), x2 =~max(year),
y = rectLims$lower[i], y2 = rectLims$upper[i],
opacity := 0.05, fill := "blue")
vis
}
vis = reactive({
data = dataInput()
data %>%
ggvis(x = ~year, y = ~score) %>%
scale_numeric("y",domain = c(40,120)) %>%
layer_points()%>%
layer_lines() %>%
make_rect(lims=rectLims)
})
vis %>% bind_shiny("plot")
})
For your second question, if you only want points to show up in that range, you can make a subset of the data to use for the layer_points or a logical vector (converted to numeric with +) and use that as the opacity argument,
vis = reactive({
data = dataInput()
## Option 1: and use layer_points(data=inrange)
## inrange <- with(dataInput(), dataInput()[score >=80 | score <= 50,])
## Options 2, with opacity=~inrange
inrange = +with(data, score >=80 | score <= 50)
data %>%
ggvis(x = ~year, y = ~score) %>%
scale_numeric("y",domain = c(40,120)) %>%
layer_points(opacity = ~inrange) %>%
layer_lines() %>%
make_rect(lims=rectLims)
})

R ggvis linked_brush is not reactive

I have the following code on my Server. R
data_agg_plot1<- reactive({
brush1 <- linked_brush(keys = data_agg()$id, "navy" )
data_agg <- data_agg()
plot1<-data_agg%>%
ggvis(x = ~dates_all) %>%
group_by(factor(dates_all.1)) %>%
layer_points(y = ~ value, fill =~dates_all.1, shape =~dates_all.1) %>%
layer_paths(y = ~ value, stroke = ~dates_all.1 , strokeOpacity := 0.5) %>%
scale_ordinal("fill", range = c("green", "red", "blue"))%>%
scale_ordinal("shape", range = c("triangle-up","triangle-down","circle")) %>%
scale_ordinal("stroke",range=c("green","red","blue")) %>%
brush1$input() %>%
hide_legend(c('stroke','fill'))%>%
add_legend(c('shape','fill'),
title = "Symbol", orient = "left",
values = c("New hires", "Attrition" , "Net Growth"),
properties = legend_props(
title = list(fontSize = 16))) %>%
add_axis("x",properties= axis_props(labels = list(angle=60,align = "left")),
tick_padding =0,
title = "") %>%
add_axis("y", title = "Total Count") %>%
set_options(width = "auto",height = 400) %>%
scale_numeric('y',clamp = TRUE)
return(list(plot1,brush1))
})
so this is a reactive function that returns me a list of 2 functions, a plot and my brush object.
the purpose of doing so is so that I can make my keys reactive - this is so that I can make an additional plot based on my user's selection. think of it as the second plot depends on what the first user highlights in the first plot.
this is my following code:
plot1_data<-reactive({
data_agg_plot1()[[1]]
})
plot1_data%>%bind_shiny("plot1")
selected_plot1 <- reactive({
data_agg_plot1()[[2]]
})
output$test <- renderPrint({
temp <- selected_plot1()$selected()
print(temp)
})
however, when I print out the selection, it is all false,
please refer to the image below:
can anybody explain to me how to overcome this?
I highly suspect I have to re-write my linkedbrush function,
I have tried both solutions from:
linked_brush in ggvis cannot work in Shiny when data change
but it does not work.

Resources