I am having problem with the following example ggvis code which is meant to make a plot that highlights an entire group of points when you hover over any member of that group. I would then like the highlighting to vanish as soon as you hover off. What is happening is that the highlighting initially works but then when you hover off, the highlighting stays, and only vanishes when you hover over another set of points and then hover off them again.
library(magrittr)
library(dplyr)
library(ggvis)
library(shiny)
dat <- iris %>% select(-Species) %>% dist %>% cmdscale %>% data.frame %>% tbl_df %>% mutate(Species = iris$Species) %>%
data.frame
Props <- reactiveValues(Size = rep(50, length.out = nrow(dat)), Stroke = rep("white", length.out = nrow(dat)))
hoveron <- function(data, ...) {
Props$Size[dat$Species == data$Species] <- 150
print("hoveron!")
Props$Stroke[dat$Species == data$Species] <- "black"
}
hoveroff <- function(...) {
Props$Size <- rep(50, length.out = nrow(dat))
print("hoveroff!")
Props$Stroke <- rep("white", length.out = nrow(dat))
}
dat %>%
ggvis(~X1, ~X2, fill = ~Species) %>% layer_points(size = reactive(Props$Size), stroke = reactive(Props$Stroke)) %>%
scale_numeric("size", range = c(80, 180)) %>% scale_numeric("x", label = "MDS Axis 1") %>%
scale_numeric("y", label = "MDS Axis 2") %>% scale_ordinal("stroke", sort = TRUE, domain = c("black", "white"), range = c("black", "white")) %>%
add_legend(scales = "size", properties = legend_props(title = list(fontSize = 0), labels = list(fontSize = 0), symbols = list(size = 0))) %>%
add_legend(scales = "stroke", properties = legend_props(title = list(fontSize = 0), labels = list(fontSize = 0), symbols = list(size = 0))) %>%
set_options(duration = 0) %>% handle_hover(hoveron, hoveroff)
You can view the results as a shinyapp here: https://ecologician.shinyapps.io/ggvis_grouping_wrong/. Note: The print statements are for debugging. hoveroff seems to fire when you mover off the first set of points but then hoveron fires immediately afterwards, with data$Species equal to what was just hovered off. I can't quite explain why. I am hoping it is just a simple mistake which I just can't see at the moment. Can anyone here see what is wrong?
More Details:
The above code was an attempt to make a less verbose / simpler version of the code below, which does work as I expect it to:
library(magrittr)
library(dplyr)
library(ggvis)
library(shiny)
hoverset <- reactiveValues(setosa = 0, versicolor = 0, virginica = 0)
hoveron <- function(data, ...) {
hoverset[[data$Species]] <- 1
}
hoveroff <- function(data, ...) {
hoverset$setosa <- 0
hoverset$versicolor <- 0
hoverset$virginica <- 0
}
dat <- iris %>% select(-Species) %>% dist %>% cmdscale %>% data.frame %>% tbl_df %>% mutate(Species = iris$Species) %>%
mutate(Size = 50, Stroke = "white") %>% data.frame
dat2 <- reactive({
if (hoverset$setosa == 1){
dat[dat[,"Species"] == "setosa","Size"] <<- 150
dat[dat[,"Species"] == "setosa","Stroke"] <<- "black"
} else {
dat[dat[,"Species"] == "setosa","Size"] <<- 50
dat[dat[,"Species"] == "setosa","Stroke"] <<- "white"
}
if (hoverset$versicolor == 1){
dat[dat[,"Species"] == "versicolor","Size"] <<- 150
dat[dat[,"Species"] == "versicolor","Stroke"] <<- "black"
} else {
dat[dat[,"Species"] == "versicolor","Size"] <<- 50
dat[dat[,"Species"] == "versicolor","Stroke"] <<- "white"
}
if (hoverset$virginica == 1){
dat[dat[,"Species"] == "virginica","Size"] <<- 150
dat[dat[,"Species"] == "virginica","Stroke"] <<- "black"
} else {
dat[dat[,"Species"] == "virginica","Size"] <<- 50
dat[dat[,"Species"] == "virginica","Stroke"] <<- "white"
}
dat
})
dat2 %>%
ggvis(~X1, ~X2, fill = ~Species) %>% layer_points(size = ~Size, stroke = ~Stroke) %>%
scale_numeric("size", range = c(80, 180)) %>% scale_numeric("x", label = "MDS Axis 1") %>%
scale_numeric("y", label = "MDS Axis 2") %>% scale_ordinal("stroke", sort = TRUE, domain = c("black", "white"), range = c("black", "white")) %>%
add_legend(scales = "size", properties = legend_props(title = list(fontSize = 0), labels = list(fontSize = 0), symbols = list(size = 0))) %>%
add_legend(scales = "stroke", properties = legend_props(title = list(fontSize = 0), labels = list(fontSize = 0), symbols = list(size = 0))) %>%
set_options(duration = 0) %>% handle_hover(hoveron, hoveroff)
See this app here: https://ecologician.shinyapps.io/ggvis_grouping/
Thanks!
Related
I am trying to develop a Business Cycle Clock similar to https://kosis.kr/visual/bcc/index/index.do?language=eng.
I've already achieved most of the things I wanted to replicate, but I can't figure it out how to add these traces (for example, in the link above set speed to 10 and trace length to 5 and then click on 'Apply' to understand what I mean).
Does anyone have any idea how to implement it? It would make the "clock" much easier to read. Thanks in advance.
Reprocible example:
library(plotly)
library(dplyr)
library(magrittr)
variable <- rep('A',10)
above_trend <- rnorm(10)
mom_increase <- rnorm(10)
ref_date <- seq.Date('2010-01-01' %>% as.Date,
length.out = 10,by='m')
full_clock_db <- cbind.data.frame(variable, above_trend, mom_increase, ref_date)
freq_aux = 'm'
ct = 'Brazil'
main_title = paste0('Business Cycle Clock para: ', ct)
m <- list(l=60, r=170, b=50, t=70, pad=4)
y_max_abs = 2
x_max_abs = 5
fig = plot_ly(
data = full_clock_db,
x = ~mom_increase,
y = ~above_trend,
color = ~variable,
frame = ~ref_date,
text = ~variable,
hoverinfo = "text",
type = 'scatter',
mode = 'markers'
) %>%
animation_opts( frame = 800,
transition = 500,
easing = "circle",
redraw = TRUE,
mode = "immediate") %>%
animation_slider(
currentvalue = list(prefix = "PerĂodo", font = list(color="red"))
)
fig
Another more elegant solution would be to rely on ggplot2 + gganimate:
library(ggplot2)
library(gganimate)
ggplot(full_clock_db, aes(x = mom_increase, y = above_trend)) +
geom_point(aes(group = 1L)) +
transition_time(ref_date) +
shadow_wake(wake_length = 0.1, alpha = .6)
You cna play with different shadow_* functions to find the one to your liking.
One way would be to use a line plot and repeat points as necessary. Here's an example as POC:
library(dplyr)
library(plotly)
e <- tibble(x = seq(-3, 3, 0.01)) %>%
mutate(y = dnorm(x)) %>%
mutate(iter = 1:n())
accumulate <- function(data, by, trace_length = 5L) {
data_traf <- data %>%
arrange({{ by }}) %>%
mutate(pos_end = 1:n(),
pos_start = pmax(pos_end - trace_length + 1L, 1L))
data_traf %>%
rowwise() %>%
group_map(~ data_traf %>% slice(seq(.x$pos_start, .x$pos_end, 1L)) %>%
mutate("..{{by}}.new" := .x %>% pull({{by}}))) %>%
bind_rows()
}
enew <- e %>%
accumulate(iter, 100)
plot_ly(x = ~ x, y = ~ y) %>%
add_trace(data = e, type = "scatter", mode = "lines",
line = list(color = "lightgray", width = 10)) %>%
add_trace(data = enew, frame = ~ ..iter.new,
type = "scatter", mode = "lines") %>%
animation_opts(frame = 20, 10)
The idea is that for each step, you keep the trace_length previous steps and assign them to the same frame counter (here ..iter.new). Then you plot lines instead of points and you have a sort of trace..
I'm trying to create a scatterplot matrix using ggplot2 and patchwork.
My function for this is
library(tidyverse)
library(patchwork)
library(grid)
ggscatter <- function(df, ...) {
plots <- df %>%
mutate(
across(.fns = as.character),
.id = 1:n(),
) %>%
pivot_longer(-.id, names_to = ".var", values_to = ".val") %>%
full_join(., ., by = ".id") %>%
nest(data = -c(.var.x, .var.y)) %>%
mutate(
data = pmap(., function(data, .var.x, .var.y) {
data %>%
mutate(
.val.x = switch(class(df[[.var.x]]),
"factor" = factor(.val.x),
"numeric" = as.numeric(.val.x),
"character" = .val.x
),
.val.y = switch(class(df[[.var.y]]),
"factor" = factor(.val.y),
"numeric" = as.numeric(.val.y),
"character" = .val.y
)
)
})
) %>%
mutate(
plot = pmap(., function(data, .var.x, .var.y) {
if(.var.x == .var.y) {
p <- grid::textGrob(.var.x, gp = gpar(fontsize = 15))
} else {
p <- data %>%
ggplot(aes(x = .val.x, y = .val.y)) +
geom_point(
position = position_jitter(
width = {if(class(data$.val.x) == "factor") .2 else 0},
height = {if(class(data$.val.y) == "factor") .2 else 0}
)
) +
labs(
x = .var.x,
y = .var.y
) +
theme(
axis.title = element_blank(),
axis.text.x = {if(.var.y == names(df)[length(df)] || (.var.x == names(df)[length(df)] & .var.y == names(df)[length(df) -1])) element_text() else element_blank()},
axis.text.y = {if(.var.x == names(df)[1] || (.var.y == names(df)[1] & .var.x == names(df)[2])) element_text() else element_blank()},
axis.ticks.x = {if(.var.y == names(df)[length(df)] || (.var.x == names(df)[length(df)] & .var.y == names(df)[length(df) -1])) element_line() else element_blank()},
axis.ticks.y = {if(.var.x == names(df)[1] || (.var.y == names(df)[1] & .var.x == names(df)[2])) element_line() else element_blank()},
plot.margin = margin(0, 0, 0, 0)
)
}
p
})
)
wrap_plots(plots$plot,
guides = "collect",
byrow = FALSE
)
}
ggscatter(iris)
This works beautifully... except for the spacing between the 1st and 2nd column and the 2nd-to-last and last rows, due to the x- and y-axis labels. Obviously, because the diagonals are textGrobs, the "simple" solution is to ignore the space the labels take up for the purpose of positioning the plots (since overflowing into this area should be okay). Changing plot.margin in theme does not help - it looks outside the space utilized by the axis text. I don't know that this is possible in patchwork, and I don't know enough about grid (or gridExtra) to see how this would be implemented. Any ideas or pointers towards a good solution?
I have several series which I would like to animate with plotly R. After following the example here (https://plot.ly/r/cumulative-animations/), I have the animation working. I figured out how to change the colors for the groups, however, I need specific colors for the groups (RGB custom colors).
I have two questions:
How do I assign RGB colors to groups in R Plotly...what am I missing here?
Is there an easier way to do this? I have several more "cities" than just two, and want to be able to dynamically assign the specific color. I was able to pull the colors in as a column in the data frame, and would like to be able to assign them that way...got it working for the regular colors, but need to get it for the RGB...
library(plotly)
# Helper function to create frames
accumulate_by <- function(dat, var) {
var <- lazyeval::f_eval(var, dat)
lvls <- plotly:::getLevels(var)
dats <- lapply(seq_along(lvls), function(x) {
cbind(dat[var %in% lvls[seq(1, x)], ], frame = lvls[[x]])
})
dplyr::bind_rows(dats)
}
# Pull in data and also create color columns
d <-
txhousing %>%
filter(year > 2005, city %in% c("Abilene", "Bay Area")) %>%
accumulate_by(~date) %>%
mutate(regular_color = if_else(city == "Abilene", 'red', 'black'),
RGB_color = if_else(city == "Abilene", 'rgb(229,18,18)', 'rgb(13,9,9)'))
# color vectors
reg_color_vector <-
d %>%
arrange(city) %>%
select(regular_color) %>%
distinct() %>%
pull()
RGB_color_vector <-
d %>%
arrange(city) %>%
select(RGB_color) %>%
distinct() %>%
pull()
p <- d %>%
plot_ly(
x = ~date,
y = ~median,
split = ~city,
frame = ~frame,
type = 'scatter',
mode = 'lines',
line = list(simplyfy = F),
color = ~city,
# colors = c('red', 'black')
colors = c('rgb(229, 18, 18)', 'rgb(13, 9, 9)')
# colors = reg_color_vector
# colors = RGB_color_vector
) %>%
layout(
xaxis = list(
title = "Date",
zeroline = F
),
yaxis = list(
title = "Median",
zeroline = F
)
) %>%
animation_opts(
frame = 100,
transition = 0,
redraw = FALSE
) %>%
animation_slider(
hide = T
) %>%
animation_button(
x = 1, xanchor = "right", y = 0, yanchor = "bottom"
)
p
rgb() is a function which outputs a hexadecimal value of the color you want. That is what you need to store. Remove the ' and it should be fine. And you need to add maxColorValue = 255 to the rgb() function.
d <-
txhousing %>%
filter(year > 2005, city %in% c("Abilene", "Bay Area")) %>%
accumulate_by(~date) %>%
mutate(regular_color = if_else(city == "Abilene", 'red', 'black'),
RGB_color = if_else(city == "Abilene",
rgb(229, 18, 18, maxColorValue = 255),
rgb(13, 9, 9, maxColorValue = 255)))
You can use in plot_ly than the RGB_color_vector to define the colors.
plot_ly(
x = ~date,
y = ~median,
split = ~city,
frame = ~frame,
type = 'scatter',
mode = 'lines',
line = list(simplyfy = F),
color = ~city,
colors = RGB_color_vector
)
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
I have an reactive ggvis scatterplot (layer_points) in shiny.
Now i want to add an horizontal line and vertical line in the plot to resemble the median of the x/y axis.
i know how to calculate it, but not how to display it in same plot.
my code so far:
vis <- reactive({
# Lables for axes
xvar_name <- names(axis_vars)[axis_vars == input$xvar]
yvar_name <- names(axis_vars)[axis_vars == input$yvar]
xvar <- prop("x", as.symbol(input$xvar))
yvar <- prop("y", as.symbol(input$yvar))
gegevens %>%
ggvis(x = xvar, y = yvar) %>%
layer_points(size := 50, size.hover := 200,
fillOpacity := 0.2, fillOpacity.hover := 0.5,
stroke = ~bron, key := ~Project.ID) %>%
add_tooltip(gegevens_tooltip, "hover") %>%
add_axis("x", title = xvar_name, format='d', grid = FALSE) %>%
add_axis("y", title = yvar_name, format='d', grid = FALSE) %>%
add_legend("stroke", title = "Gegevens van:", values = c("A", "B")) %>%
scale_numeric("x", trans = "log", expand=0) %>%
scale_numeric("y", trans = "log", expand=0) %>%
scale_nominal("stroke", domain = c("A", "B"),
range = c("blue", "#aaa")) %>%
set_options(width = 600, height = 600)
})
vis %>% bind_shiny("plot1")
to calculate the median i use:
output$defects <- renderText ({
d <- median(gegevens()$Total.Defects.Delivered)
paste("de mediaan voor totaal aantal Defects is:", d)
})
Lots of thanks for helping.
Seems i misunderstood your example, but i got it working, just after i posted i couldn't. Well here is the solution:
vis <- reactive({
# Lables for axes
xvar_name <- names(axis_vars)[axis_vars == input$xvar]
yvar_name <- names(axis_vars)[axis_vars == input$yvar]
xvar <- prop("x", as.symbol(input$xvar))
yvar <- prop("y", as.symbol(input$yvar))
gegevens %>%
ggvis(x = xvar, y = yvar) %>%
layer_points(size := 50, size.hover := 200,
fillOpacity := 0.2, fillOpacity.hover := 0.5,
stroke = ~bron, key := ~Project.ID) %>%
add_tooltip(gegevens_tooltip, "hover") %>%
add_axis("x", title = xvar_name, format='d', grid = FALSE, properties = axis_props(labels = list(angle = 90, align = "left"))) %>%
add_axis("y", title = yvar_name, format='d', grid = FALSE) %>%
add_legend("stroke", title = "Gegevens van:", values = c("A", "B")) %>%
scale_numeric("x", trans = "log", expand=0) %>%
scale_numeric("y", trans = "log", expand=0) %>%
scale_nominal("stroke", domain = c("A", "B"),
range = c("blue", "#aaa")) %>%
set_options(width = 600, height = 600) %>%
layer_paths(data = gegevens, x = median(gegevens()$kolomname.i.want.the.median.from)), y = yvar ) %>%
layer_paths(data = gegevens, x = xvar, y = median(gegevens()$kolomname.i.want.the.median.from))
})
this gives me an cross in my plot by calculating the median of x and y, even if the user changes the original input. of course i need to find out how to get "kolomname.i.want.the.median.from" to be the x-/ or y-value.
but i now know how to get the lines in, and that was the question.
So thank you aosmith for the right direction.