I'm trying to combine a list of R plotly plots - vertically, but since the y-axis title of each of the individual plots is horizontal the combined plot comes out messy.
Here's my example:
data:
set.seed(1)
df <- data.frame(cluster=unlist(lapply(letters[1:10],function(i) rep(paste0("cluster:",i),200))),
group=rep(c(rep("A",100),rep("B",100)),10),val=rnorm(2000))
df$group <- factor(df$group,levels=c("A","B"))
plotting a list of density plots, one per df$cluster:
library(plotly)
plot.list <- lapply(unique(df$cluster),function(i){
density.df <- do.call(rbind,lapply(c("A","B"),function(b){
dens <- density(dplyr::filter(df,cluster == i,group == b)$val,adjust=1)
return(data.frame(x=dens$x,y=dens$y,group=b,stringsAsFactors=F))
}))
density.df$group <- factor(density.df$group,levels=c("A","B"))
if(i == unique(df$cluster)[1]){
cluster.plot <- plot_ly(x=~density.df$x,y=~density.df$y,type='scatter',mode='lines',color=~density.df$group,line=list(width=3),showlegend=T) %>%
layout(xaxis=list(title="Val",zeroline=F),yaxis=list(title=i,zeroline=F,showticklabels=F),legend=list(orientation="h",xanchor="center",x=0,y=1))
} else{
cluster.plot <- plot_ly(x=~density.df$x,y=~density.df$y,type='scatter',mode='lines',color=~density.df$group,line=list(width=3),showlegend=F) %>%
layout(xaxis=list(title="Val",zeroline=F),yaxis=list(title=i,zeroline=F,showticklabels=F))
}
return(cluster.plot)
})
Then, combining them using:
subplot(plot.list,nrows=length(plot.list),shareX=T,shareY=T,titleX=T,titleY=T)
Gives:
How can I rotate the y-axis title of each plot in plot.list to be horizontal rather than vertical?
This cannot be achieved natively, if I understand correctly, as per this.
However, as the link suggests, try using annotations.
Here is how one might go about it -
set.seed(1)
df <- data.frame(cluster=unlist(lapply(letters[1:10],function(i) rep(paste0("cluster:",i),200))),
group=rep(c(rep("A",100),rep("B",100)),10),val=rnorm(2000))
df$group <- factor(df$group,levels=c("A","B"))
library(plotly)
plot.list <- lapply(unique(df$cluster),function(i){
density.df <- do.call(rbind,lapply(c("A","B"),function(b){
dens <- density(dplyr::filter(df,cluster == i,group == b)$val,adjust=1)
return(data.frame(x=dens$x,y=dens$y,group=b,stringsAsFactors=F))
}))
density.df$group <- factor(density.df$group,levels=c("A","B"))
if(i == unique(df$cluster)[1]){
cluster.plot <- plot_ly(x=~density.df$x,y=~density.df$y,type='scatter',mode='lines',color=~density.df$group,line=list(width=3),showlegend=T) %>%
layout(xaxis=list(title="Val",zeroline=F),yaxis=list(title = '', zeroline=F,showticklabels=F),legend=list(orientation="h",xanchor="center",x=0,y=1)) %>%
add_annotations(text = i, x = -0.1, xref = 'paper', y = 0.5, yref = 'paper', showarrow = FALSE)
} else {
cluster.plot <- plot_ly(x=~density.df$x,y=~density.df$y,type='scatter',mode='lines',color=~density.df$group,line=list(width=3),showlegend=F) %>%
layout(xaxis=list(title="Val",zeroline=F),yaxis=list(title = '', zeroline=F,showticklabels=F)) %>%
add_annotations(text = i, x = -0.1, xref = 'paper', y = 0.5, yref = 'paper', showarrow = FALSE)
}
return(cluster.plot)
})
subplot(plot.list,nrows=length(plot.list),shareX=T,shareY=T,titleX=T,titleY=T)
This results in -
Related
Using the code snippet from the help page here, I'm trying to create a unique main label for each subplot but am not entirely successful. Any suggestions on how to do this?
library(plotly)
vars <- setdiff(names(economics), "date")
plots <- lapply(vars, function(var) {
plot_ly(economics, x = ~date, y = as.formula(paste0("~", var))) %>%
add_lines(name = var) %>% layout(title = paste("Title for", var, sep=' ') )
})
subplot(plots, nrows = length(plots), shareX = TRUE, titleX = FALSE)
I wish I had noticed this question sooner! Here is one way that you can make this happen.
I took the titles out of the plot build. Otherwise, you'll get an error.
library(plotly)
vars <- setdiff(names(economics), "date")
plots <- lapply(vars, function(var) {
plot_ly(economics, x = ~date, y = as.formula(paste0("~", var))) %>%
add_lines(name = var) #%>% layout(title = paste("Title for", var, sep=' '))
})
Then I created a vector of the titles.
nms <- invisible(lapply(vars, function(v){paste0("Title for ", v)}) %>% unlist())
Here I used annotations to create title objects to add to the subplot.
annots = lapply(
1:length(plots),
function(j){
list(x = .5,
y = 1 - (j - 1) * .205,
xanchor = "center",
yanchor = "center",
xref = "paper",
yref = "paper",
showarrow = F,
text = nms[j])
}
)
subplot(plots, nrows = length(plots), shareX = TRUE, titleX = FALSE) %>%
layout(annotations = annots)
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 want to create an interactive plotly 3d scatter with markers and lines in R. The graphic should be able to highlight individual traces, which is working. It should also be able to change the color according to other variables.
Here is an example of what I want to do, the highlighting works fine, changing the color does not work:
library(plotly)
irs <- data.table(iris)
setkey(irs, `Species`)
p <- plot_ly(type = "scatter3d", mode = "lines+markers")
for (i in levels(irs$Species)) {
xx <- irs[i]$Sepal.Length
yy <- irs[i]$Sepal.Width
zz <- irs[i]$Petal.Length
cc <- irs[i]$Petal.Width
p <- p %>% add_trace(x = xx, y = yy, z = zz, color = cc)
}
p <- p %>%
layout(
updatemenus = list(
## set opacity per trace to highlight a single trace
list(y = 0.6,
buttons = lapply(
levels(irs$Species),
function (x) {
list(method = "restyle",
args = list("opacity",
ifelse(levels(irs$Species) == x,
1, 0.1)),
label = x)
})),
## try to set different colors for points inside traces
## NOT WORKING
list(y = 0.4,
buttons = lapply(
names(irs),
function(x) {
list(
method = "restyle",
args = list(
"color",
split(irs[[x]], irs$Species)
),
label = x
)
}))
)
)
p
The following code solves only a small part of your problem: how to change colors of markers and lines for a single series.
I did not find a solution for the case with multiple series.
In addition, I did not find a way for an automatic rescaling of the color map after changing the color variable from the menu. Hence, I rescaled "by hand" all variables between 1 and 3.
I realise that this is a small contribution to the solution of the problem. Anyway, I hope it can help you.
library(plotly)
library(scales)
irs <- iris
irs[,1:4] <- apply(irs[,1:4],2, rescale, to=c(1,3))
p <- plot_ly(data = irs, type = "scatter3d", mode = "lines+markers")
p <- p %>% add_trace(x=~Sepal.Length, y=~Sepal.Width,
z=~Petal.Length, color=~Petal.Width)
p <- p %>%
layout(
updatemenus = list(
list(y = 0.4,
buttons = lapply(
names(irs),
function(x) {
cols <- as.numeric(irs[,x])
list(
method = "restyle",
label = x,
args = list(
list(marker.color=list(cols),
line.color=list(cols), autocolorscale=TRUE)
)
)
}))
)
)
p
I have a data.frame I'd like to scatter plot using R's plotly with two factors which I'd like to color and shape by.
Here's my data:
set.seed(1)
df <- data.frame(x=rnorm(12),y=rnorm(12),
group=c(rep(1,3),rep(2,3),rep(3,3),rep(4,3)),
treatment=c(rep("A",6),rep("B",6)),
stringsAsFactors=F)
df$group <- factor(df$group,levels=1:4)
df$treatment <- factor(df$treatment,levels=c("A","B"))
Here's how I'm trying to plot:
require(plotly)
plot_ly(marker=list(size=10),type='scatter',mode="markers",x=~df$x,y=~df$y,color=~df$group,symbol=~df$treatment) %>%
add_annotations(text="group,treatment",xref="paper",yref="paper",x=1.02, xanchor="left",y=1.02,yanchor="top",legendtitle=TRUE,showarrow=FALSE) %>%
layout(xaxis=list(title="x"),yaxis=list(title="y"))
which gives me:
Is it possible to get the text of group and treatment in the legend be separated by comma instead of the new line as it is now?
This means that instead of:
1
A
2
A
3
B
4
B
I'll have:
1,A
2,A
3,B
4,B
Sounds trivial but it's one of the cases where Plotly decides whats good for you.
The legend labels are composed of the categories of color and symbol which are all passed in one command. In order to get control over the output, let's add each trace separately.
for (grou in groups) {
for (treat in treatments) {
trace_data <- subset(df, group == grou & treatment == treat)
if (nrow(trace_data) > 0) {
p <- add_trace(p,
x = trace_data$x,
y = trace_data$y,
marker = list(size = 10,
color = group,
symbol = as.integer(charToRaw(treat)) - 65),
type = 'scatter',
mode = "markers",
name = paste(grou, treat, sep = ",")
)
}
}
}
We pass the color (not strictly necessary) via marker and symbol also via marker (both can be passed in the add_trace command as well but then again Plotly decides for you what do to do with it).
The legend label is passed via name.
Note: You need to convert your treatment explicitly because symbol expects either a named symbol or a number (unless your treatments are named diamond or circle)
Complete code
library(utils)
library(plotly)
set.seed(1)
df <- data.frame(x = rnorm(12),
y = rnorm(12),
group = c(rep(1, 3),
rep(2, 3),
rep(3, 3),
rep(4, 3)
),
treatment=c(rep("A", 6),
rep("B", 6)
),
stringsAsFactors = FALSE
)
groups <- unique(df$group)
treatments <- unique(df$treatment)
p <- plot_ly()
for (grou in groups) {
for (treat in treatments) {
trace_data <- subset(df, group == grou & treatment == treat)
if (nrow(trace_data) > 0) {
p <- add_trace(p,
x = trace_data$x,
y = trace_data$y,
marker = list(size = 10,
color = group,
symbol = as.integer(charToRaw(treat)) - 65),
type = 'scatter',
mode = "markers",
name = paste(grou, treat, sep = ",")
)
}
}
}
p <- add_annotations(p,
text = "group,treatment",
xref = "paper",
yref = "paper",
x = 0.96,
xanchor = "left",
y = 1.03,
yanchor = "top",
legendtitle = TRUE,
showarrow = FALSE) %>%
layout(xaxis = list(title = "x"),
yaxis = list(title = "y"))
p
I am trying to reverse the value display of my leaflet legend in R. This post covers categorical data, but I am working with continuous data. Here's a toy example:
map <- leaflet() %>% addProviderTiles('Esri.WorldTopoMap')
x <- 1:100
pal <- colorNumeric(c("#d7191c","#fdae61","#ffffbf","#abd9e9", "#2c7bb6"), x)
map %>% addLegend('topright', pal=pal, values=x)
I'd like the legend to read 100 at the top and 1 on the bottom with the colors reversed. I can certainly reverse the colors in colorNumeric(), but reversing the order of the labels is harder. I have tried reversing the order of the values in x, and I even fiddled with the labelFormat() parameter for addLegend() to reference a lookup table of reversed values... nothing seems to work. Is there an easy way to do this?
Unfortunately the accepted answer to this will get the numbers out of alignment (in fact exactly reversed) from the colours they represent.
Here's the original proposed solution, which I say is incorrect:
map <- leaflet() %>% addProviderTiles('Esri.WorldTopoMap')
x <- 1:100
pal <- colorNumeric(c("#d7191c","#fdae61","#ffffbf","#abd9e9", "#2c7bb6"), x)
map %>% addLegend('topright', pal=pal, values=x)
# This solution shows 100 as red
map %>% addLegend('topright',
pal = pal,
values = x,
labFormat = labelFormat(transform = function(x) sort(x, decreasing = TRUE)))
But if you've been using the pal() function to draw anything on your map, you now have it exactly wrong.
# But 100 is blue, not red
plot(1, 1, pch = 19, cex = 3, col = pal(100))
I think the solution is to define to functions that allocate colours to numbers, one in reverse for the legend, and one for actually drawing things:
pal_rev <- colorNumeric(c("#d7191c","#fdae61","#ffffbf","#abd9e9", "#2c7bb6"), x, reverse = TRUE)
map %>% addLegend('topright',
pal = pal_rev,
values = x,
labFormat = labelFormat(transform = function(x) sort(x, decreasing = TRUE)))
This gives us a legend that matches anything we will have drawn ie 100 is now correctly shown to be blue:
Although the accepted answer does flip the legend's colors and labels, the map's colors do not adress to the legend. Here is a (stolen from here) solution. Basically mpriem89 created a new function called addLegend_decreasing which works exactly like addLegend with an extra argument: decreasing = FALSE that reverses the legend's colors and labels, correctly adressing to the map's colors. Here is the function code:
addLegend_decreasing <- function (map, position = c("topright", "bottomright", "bottomleft","topleft"),
pal, values, na.label = "NA", bins = 7, colors,
opacity = 0.5, labels = NULL, labFormat = labelFormat(),
title = NULL, className = "info legend", layerId = NULL,
group = NULL, data = getMapData(map), decreasing = FALSE) {
position <- match.arg(position)
type <- "unknown"
na.color <- NULL
extra <- NULL
if (!missing(pal)) {
if (!missing(colors))
stop("You must provide either 'pal' or 'colors' (not both)")
if (missing(title) && inherits(values, "formula"))
title <- deparse(values[[2]])
values <- evalFormula(values, data)
type <- attr(pal, "colorType", exact = TRUE)
args <- attr(pal, "colorArgs", exact = TRUE)
na.color <- args$na.color
if (!is.null(na.color) && col2rgb(na.color, alpha = TRUE)[[4]] ==
0) {
na.color <- NULL
}
if (type != "numeric" && !missing(bins))
warning("'bins' is ignored because the palette type is not numeric")
if (type == "numeric") {
cuts <- if (length(bins) == 1)
pretty(values, bins)
else bins
if (length(bins) > 2)
if (!all(abs(diff(bins, differences = 2)) <=
sqrt(.Machine$double.eps)))
stop("The vector of breaks 'bins' must be equally spaced")
n <- length(cuts)
r <- range(values, na.rm = TRUE)
cuts <- cuts[cuts >= r[1] & cuts <= r[2]]
n <- length(cuts)
p <- (cuts - r[1])/(r[2] - r[1])
extra <- list(p_1 = p[1], p_n = p[n])
p <- c("", paste0(100 * p, "%"), "")
if (decreasing == TRUE){
colors <- pal(rev(c(r[1], cuts, r[2])))
labels <- rev(labFormat(type = "numeric", cuts))
}else{
colors <- pal(c(r[1], cuts, r[2]))
labels <- rev(labFormat(type = "numeric", cuts))
}
colors <- paste(colors, p, sep = " ", collapse = ", ")
}
else if (type == "bin") {
cuts <- args$bins
n <- length(cuts)
mids <- (cuts[-1] + cuts[-n])/2
if (decreasing == TRUE){
colors <- pal(rev(mids))
labels <- rev(labFormat(type = "bin", cuts))
}else{
colors <- pal(mids)
labels <- labFormat(type = "bin", cuts)
}
}
else if (type == "quantile") {
p <- args$probs
n <- length(p)
cuts <- quantile(values, probs = p, na.rm = TRUE)
mids <- quantile(values, probs = (p[-1] + p[-n])/2, na.rm = TRUE)
if (decreasing == TRUE){
colors <- pal(rev(mids))
labels <- rev(labFormat(type = "quantile", cuts, p))
}else{
colors <- pal(mids)
labels <- labFormat(type = "quantile", cuts, p)
}
}
else if (type == "factor") {
v <- sort(unique(na.omit(values)))
colors <- pal(v)
labels <- labFormat(type = "factor", v)
if (decreasing == TRUE){
colors <- pal(rev(v))
labels <- rev(labFormat(type = "factor", v))
}else{
colors <- pal(v)
labels <- labFormat(type = "factor", v)
}
}
else stop("Palette function not supported")
if (!any(is.na(values)))
na.color <- NULL
}
else {
if (length(colors) != length(labels))
stop("'colors' and 'labels' must be of the same length")
}
legend <- list(colors = I(unname(colors)), labels = I(unname(labels)),
na_color = na.color, na_label = na.label, opacity = opacity,
position = position, type = type, title = title, extra = extra,
layerId = layerId, className = className, group = group)
invokeMethod(map, data, "addLegend", legend)
}
Once you've run it, you should replace addLegend with addLegend_decreasing and set decreasing = TRUE. Then, your code changes to:
#Default map:
map <- leaflet() %>% addProviderTiles('Esri.WorldTopoMap')
x <- 1:100
pal <- colorNumeric(c("#d7191c","#fdae61","#ffffbf","#abd9e9", "#2c7bb6"), x)
map %>% addLegend_decreasing('topright', pal = pal, values = x, decreasing = TRUE)
Here is an example for a real leaflet map:
df <- local({
n <- 300; x <- rnorm(n); y <- rnorm(n)
z <- sqrt(x ^ 2 + y ^ 2); z[sample(n, 10)] <- NA
data.frame(x, y, z)
})
pal <- colorNumeric("OrRd", df$z)
leaflet(df) %>%
addTiles() %>%
addCircleMarkers(~x, ~y, color = ~pal(z), group = "circles") %>%
addLegend(pal = pal, values = ~z, group = "circles", position = "bottomleft") %>%
addLayersControl(overlayGroups = c("circles"))
Map with default addLegend:
Same map with addLegend_decreasing and decreasing = TRUE
leaflet(df) %>%
addTiles() %>%
addCircleMarkers(~x, ~y, color = ~pal(z), group = "circles") %>%
addLegend_decreasing(pal = pal, values = ~z, group = "circles", position = "bottomleft", decreasing = TRUE) %>%
addLayersControl(overlayGroups = c("circles"))
Map with custom addLegend_decreasing:
Hope this helps, it certainly helped me.
I just found that the built-in labelFormat function has a transform parameter that takes a function. So I passed the sort function in there.
To use the same example,
map %>% addLegend('topright',
pal = pal,
values = x,
labFormat = labelFormat(transform = function(x) sort(x, decreasing = TRUE)))