Plot heatmaps of multiple data frames using a slider in R - r

I have multiple data.frames and each one of them represent the pairwise interactions of individuals at different time points.
Here is an example of how my data.frames look.
df1 <- matrix(data = rexp(9, rate = 10), nrow = 3, ncol = 3)
df2 <- matrix(data = rexp(16, rate = 10), nrow = 4, ncol = 4)
df3 <- matrix(data = rexp(4, rate = 10), nrow = 2, ncol = 2)
I would like to plot them as it is pointed in this page (https://plotly.com/r/sliders/)
where with a slider I can move from one heatmap to the other.
I have tried so far with plotly but I have not succeeded. Any help is highly appreciated.
I am struggling for long with this issue. I might be a bit blind at this point so please forgive me if the question is stupid.

Following the Sine Wave Slider example on https://plotly.com/r/sliders/ this can be achieved like so. The first step of my approach involves converting the matrices to dataframes with columns x, y, z. Second instead of lines we plot heatmaps.
df1 <- matrix(data = rexp(9, rate = 10), nrow = 3, ncol = 3)
df2 <- matrix(data = rexp(16, rate = 10), nrow = 4, ncol = 4)
df3 <- matrix(data = rexp(4, rate = 10), nrow = 2, ncol = 2)
library(tibble)
library(tidyr)
library(plotly)
# Make dataframes
d <- lapply(list(df1, df2, df3), function(d) {
d %>%
as_tibble(.colnames = seq(ncol(.))) %>%
rowid_to_column("x") %>%
pivot_longer(-x, names_to = "y", values_to = "z") %>%
mutate(y = stringr::str_extract(y, "\\d"),
y = as.numeric(y))
})
aval <- list()
for(step in seq_along(d)){
aval[[step]] <-list(visible = FALSE,
name = paste0('v = ', step),
x = d[[step]]$x,
y = d[[step]]$y,
z = d[[step]]$z)
}
aval[1][[1]]$visible = TRUE
steps <- list()
fig <- plot_ly()
for (i in seq_along(aval)) {
fig <- add_trace(fig, x = aval[i][[1]]$x, y = aval[i][[1]]$y, z = aval[i][[1]]$z, visible = aval[i][[1]]$visible,
name = aval[i][[1]]$name, type = "heatmap")
fig
step <- list(args = list('visible', rep(FALSE, length(aval))), method = 'restyle')
step$args[[2]][i] = TRUE
steps[[i]] = step
}
fig <- fig %>%
layout(sliders = list(list(active = 0,
currentvalue = list(prefix = "Heatmap: "),
steps = steps)))
fig

Related

Mahalanobis difference by group with dplyr

I want to get a Mahalanobis difference for each set of two scores, after being grouped by another variable. In this case, it would be a Mahalanobis difference for each Attribute (across each set of 2 scores). The output should be 3 Mahalanobis distances (one for A, B and C).
Currently I am working with (in my original dataframe, there are some NAs, hence I include one in the reprex):
library(tidyverse)
library(purrr)
df <- tibble(Attribute = unlist(map(LETTERS[1:3], rep, 5)),
Score1 = c(runif(7), NA, runif(7)),
Score2 = runif(15))
mah_db <- df %>%
dplyr::group_by(Attribute) %>%
dplyr::summarise(MAH = mahalanobis(Score1:Score2,
center = base::colMeans(Score1:Score2),
cov(Score1:Score2, use = "pairwise.complete.obs")))
This raises the error:
Caused by error in base::colMeans(): ! 'x' must be an array of at
least two dimensions
But as far as I can tell, I am giving colMeans two columns.
So what's going wrong here? And I wonder if even fixing this gives a complete solution?
It seems your question is more about the statistics than dplyr. So I just give a small example based on your data and an adapted example from ?mahalanobis. Perhaps also have a look here or here.
df <- subset(x = df0, Attribute == "A", select = c("Score1", "Score2"))
df$mahalanobis <- mahalanobis(x = df, center = colMeans(df), cov = cov(df))
df$p <- pchisq(q = df$mahalanobis, df = 2, lower.tail = FALSE)
plot(density(df$mahalanobis, bw = 0.3), ylim = c(0, 0.8),
main="Squared Mahalanobis distances");
grid()
rug(df$mahalanobis)
df <- subset(x = df0, Attribute == "B", select = c("Score1", "Score2"))
df <- df[complete.cases(df), ]
df$mahalanobis <- mahalanobis(x = df, center = colMeans(df), cov = cov(df))
df$p <- pchisq(q = df$mahalanobis, df = 2, lower.tail = FALSE)
lines(density(df$mahalanobis, bw = 0.3), col = "red",
main="Squared Mahalanobis distances");
rug(df$mahalanobis, col = "red")
df <- subset(x = df0, Attribute == "C", select = c("Score1", "Score2"))
df$mahalanobis <- mahalanobis(x = df, center = colMeans(df), cov = cov(df))
df$p <- pchisq(q = df$mahalanobis, df = 2, lower.tail = FALSE)
lines(density(df$mahalanobis, bw = 0.3), col = "green",
main="Squared Mahalanobis distances");
rug(df$mahalanobis, col = "green")
Hope, that helps (and too long for a comment).
(Of course you can make to code much shorter, but it shows in each step what happens.)

Strahler stream order using igraph or sfnetwork in R

I cannot fathom how to derive strahler order in R. Here's an example in postgres and neo4j. An attempt in R
There are three rules (from the GRASS 7.8 Manual):
if the node has no children, it's Strahler order is 1.
if the node has one and only one tributary with Strahler greatest order i, and all other tributaries have order less than i, then the order remains
i.
if the node has two or more tributaries with greatest order i, then the Strahler order of the node is i + 1.
Here's what I would expect
library(sfnetworks)
library(igraph)
library(sf)
library(dplyr)
library(tidygraph)
library(RColorBrewer)
# Create an example network.
n01 = st_sfc(st_point(c(0, 0)))
n02 = st_sfc(st_point(c(1, 2)))
n03 = st_sfc(st_point(c(1, 3)))
n04 = st_sfc(st_point(c(1, 4)))
n05 = st_sfc(st_point(c(2, 1)))
n06 = st_sfc(st_point(c(2, 3)))
n07 = st_sfc(st_point(c(2, 4)))
n08 = st_sfc(st_point(c(3, 2)))
n09 = st_sfc(st_point(c(3, 3)))
n10 = st_sfc(st_point(c(3, 4)))
n11 = st_sfc(st_point(c(4, 2)))
n12 = st_sfc(st_point(c(4, 4)))
from = c(1, 2, 2, 3, 3, 5, 5, 8, 8, 9, 9)
to = c(5, 3, 6, 4, 7, 2, 8, 9, 11, 10, 12)
nodes = st_as_sf(c(n01, n02, n03, n04, n05, n06, n07, n08, n09, n10, n11, n12))
edges = data.frame(from = from, to = to)
G = sfnetwork(nodes, edges) %>%
convert(to_spatial_explicit, .clean = TRUE)
nodes = st_as_sf(G, "nodes")
edges = st_as_sf(G, "edges")
# expected order
edges$expected_order = c(4,2,1,1,1,3,3,2,1,1,1)
cols = brewer.pal(4, "Blues")
pal = colorRampPalette(cols)
plot(st_geometry(edges))
plot(edges["expected_order"],
lwd = 4, ,
add = TRUE,
col = pal(4)[edges$expected_order])
legend(x = "topright",
legend = c("4","3","2","1"),
lwd = 4,
col = pal(4)[edges$expected_order],
title = "strahler order")
plot(nodes, pch = 20, add = TRUE)
Here's what I tried curtesy of jsta/streamnet/stream_order.R, which I can't load due to missing packages
stream_order_igraph <- function(tree){
tree <- as.igraph(tree)
leaf_nodes <- which(degree(tree,
v = igraph::V(tree),
mode = "in") == 0,
useNames = TRUE)
base_order <- 1
edgelist <- data.frame(as_edgelist(tree))
edgelist$order <- NA
names(edgelist)[c(1,2)] <- c("from", "to")
edgelist$order[edgelist$from %in% leaf_nodes] <- base_order
tree <- igraph::delete.vertices(tree, leaf_nodes)
while(igraph::vcount(tree) >= 1){
base_order <- max(edgelist$order, na.rm = TRUE) + 1
leaf_nodes <- which(degree(tree, v = igraph::V(tree),
mode = "in") == 0,
useNames = TRUE)
raised_nodes <- sapply(leaf_nodes,
function(x) all(edgelist$order[edgelist$to == x] == base_order - 1))
raised_nodes <- which(raised_nodes)
flat_nodes <- leaf_nodes[!(leaf_nodes %in% raised_nodes)]
edgelist$order[edgelist$from %in% raised_nodes] <- base_order
edgelist$order[edgelist$from %in% flat_nodes] <- base_order - 1
tree <- igraph::delete.vertices(tree, leaf_nodes)
}
edgelist$order
}
stream_order_igraph(G)
> stream_order_igraph(G)
[1] 4 3 3 3 3 2 2 NA NA NA NA
I have found a solution that converts class igraph to class phylo then uses phytools::StrahlerNumber. I had to modify phytools::igraph_to_phylo and reverse the order of my edges to get it to work.
library(phytools)
library(igraph)
library(sfnetworks)
library(sf)
library(dplyr)
library(RColorBrewer)
# reverse the edge direction
transposeGraph <- function(g) {
g %>% get.edgelist %>%
{cbind(.[, 2], .[, 1])} %>%
graph.edgelist
}
# convert igraph class to phylo class
# and calculate strahler number
igraphStrahler <- function(g){
if (!igraph::is_simple(g) |
!igraph::is_connected(g) |
!igraph::is_dag(g)) {
stop("Taxon graph is not a simple, connected, directed acylic graph")
}
root = which(sapply(V(g),
function(x) length(neighbors(g, x, mode = "in"))) == 0)
leaves = which(sapply(V(g),
function(x) length(neighbors(g, x, mode = "out"))) == 0)
g <- g %>%
set_vertex_attr("leaf", index = leaves, TRUE) %>%
set_vertex_attr("root", index = root, TRUE)
traverse <- igraph::dfs(g, root)
is_leaf <- igraph::vertex_attr(g, "leaf", traverse$order)
is_leaf[which(is.na(is_leaf))] <- FALSE
n_leaf <- sum(is_leaf)
n_node <- sum(!is_leaf)
node_id <- ifelse(is_leaf, cumsum(is_leaf), cumsum(!is_leaf) + n_leaf)
# Store the node ids on the graph
g <- igraph::set_vertex_attr(g, "node_id", index = traverse$order,
value = node_id)
# Extract the edge and vertex data
vertex_data <- igraph::as_data_frame(g, "vertices") %>%
mutate(name = row_number())
edge_data <- igraph::as_data_frame(g, "edges")
edge_data$geom <- NULL
# Substitute the node id numbers into the edge list
edge_data <- unlist(edge_data)
edge_data <- vertex_data$node_id[match(edge_data, vertex_data$name)]
edge_data <- matrix(edge_data, ncol = 2)
# lookup the tip and node labels
tip_labels <- 1:n_leaf
tip_labels <- vertex_data$name[match(tip_labels, vertex_data$node_id)]
node_labels <- (n_leaf + 1):(n_node + n_leaf)
node_labels <- vertex_data$name[match(node_labels, vertex_data$node_id)]
# Build the phylogeny
phy <- structure(list(edge = edge_data,
edge.length = rep(1, nrow(edge_data)),
tip.labels = tip_labels,
node.labels = node_labels,
Nnode = n_node),
class = "phylo")
stra <- as.data.frame(strahlerNumber(phy)) %>%
rename(strahler_order = `strahlerNumber(phy)`) %>%
mutate(node_id = row_number()) %>%
left_join(vertex_data, by = "node_id") %>%
rename(to = name)
return(stra)
}
ln <- st_read("streams.gpkg") %>%
st_cast("LINESTRING")
net <- as_sfnetwork(ln)
g <- net %>%
transposeGraph()
stra <- igraphStrahler(g)
edges = st_as_sf(net, "edges") %>%
left_join(stra, by = c("from" = "to"))
cols = brewer.pal(3, "Blues")
pal = colorRampPalette(cols)
plot(st_geometry(edges))
plot(edges["strahler_order"],
lwd = 3, ,
add = TRUE,
col = pal(3)[edges$strahler_order])
legend(x = "topright",
legend = c("1","2","3"),
lwd = 3,
col = cols,
title = "Strahler order")

Creating subplot (facets) with custom x,y position of the subplots in ggplot2

How can we custom the position of the panels/subplot in ggplot2?
Concretely I have a grouped times series and I want to produce 1 subplot per time series with custom positions of the subplot, not necessarily in a grid.
The facet_grid() or facet_wrap() functions do not provide a full customization of the position of the panel as it uses grid.
library(tidyverse)
df = data.frame(group = LETTERS[1:5],
x = c(1,2,3,1.5,2.5),
y =c(2,1,2,3,3),
stringsAsFactors = F)%>%
group_by(group)%>%
expand_grid(time = 1:20)%>%
ungroup()%>%
mutate(dv = rnorm(n()))%>%
arrange(group,time)
## plot in grid
df%>%
ggplot()+
geom_line(aes(x=time,y=dv))+
facet_grid(~group)
## plot with custom x, y position
## Is there an equivalent of facet_custom()?
df%>%
ggplot()+
geom_line(aes(x=time,y=dv))+
facet_custom(~group, x.subplot = x, y.subplot = y)
FYI: This dataset is only an example. My data are EEG data where each group represents an electrode (up to 64) and I want to plot the EEG signals of each electrode accordingly to the position of the electrode on the head.
Well, I guess this would not really be a 'facet plot' any more. I therefore don't think there is a specific function out there.
But you can use the fantastic patchwork package for that, in particular the layout option in wrap_plots.
As the main package author Thomas describes in the vignette, the below option using area() may be a bit verbose, but it would give you full programmatic options about positioning all your plots.
library(tidyverse)
library(patchwork)
mydf <- data.frame(
group = LETTERS[1:5],
x = c(1, 2, 3, 1.5, 2.5),
y = c(2, 1, 2, 3, 3),
stringsAsFactors = F
) %>%
group_by(group) %>%
expand_grid(time = 1:20) %>%
ungroup() %>%
mutate(dv = rnorm(n())) %>%
arrange(group, time)
## plot in grid
mylist <-
mydf %>%
split(., .$group)
p_list <-
map(1:length(mylist), function(i){
ggplot(mylist[[i]]) +
geom_line(aes(x = time, y = dv)) +
ggtitle(names(mylist)[i])
}
)
layout <- c(
area(t = 1, l = 1, b = 2, r = 2),
area(t = 2, l = 3, b = 3, r = 4),
area(t = 3, l = 5, b = 4, r = 6),
area(t = 4, l = 3, b = 5, r = 4),
area(t = 5, l = 1, b = 6, r = 2)
)
wrap_plots(p_list, design = layout)
#> result not shown, it's the same as below
For a more programmatic approach, one option is to create the required "patch_area" object manually.
t = 1:5
b = t+1
l = c(1,3,5,3,1)
r = l+1
list_area <- list(t = t, b = b, l = l, r = r)
class(list_area) <- "patch_area"
wrap_plots(p_list, design = list_area)
Created on 2020-04-22 by the reprex package (v0.3.0)

Creating a multi-plot figure with layout() in R

I am having difficulty finding a way to produce a multi-plot figure in R that has two rows but on the second row, I want the plot to be in the middle of the two plots that are side by side on the first row... Attached is my code and the graph I'm getting vs. the graph that I want. Any suggestions would be greatly appreciated! Thanks!
pie_chart <- function(parameter, title=parameter) {
parameter_df <- parameter_results %>%
select(results = parameter) %>%
filter(results != "Not Applicable") %>%
count(results) %>% #
mutate(prop = prop.table(n), perc = paste0(round(prop * 100),"%"))
color_code <- c("Attaining" = "#99FF99", "Insufficient Information" = "#FFFF99", "Non Attaining" = "#FF9999")
parameter_df <- parameter_results %>%
select(results = parameter) %>% #keep only column for the parameter you want to plot
filter(results != "Not Applicable") %>%
count(results) %>% #
mutate(prop = prop.table(n), perc = paste0(round(prop * 100),"%"))
values <- vector(mode = "numeric", length = nrow(parameter_df))
labs <- vector(mode = "character", length = nrow(parameter_df))
colors <- vector(mode = "character", length = nrow(parameter_df))
for (i in seq_along(1:nrow(parameter_df))) {
values[[i]] <- parameter_df$prop[[i]] * 100
labs[[i]] <- parameter_df$perc[i]
colors[[i]] <- color_code[[parameter_df$results[[i]]]]
}
pie(x = values, labels = labs, col = colors, main = title,font=2,font.main=2)
CairoPDF(file = "Recreation Use", width = 10, height = 7)
m <- matrix(c(1,2,
3,4
), nrow = 2, ncol = 2, byrow = TRUE)
layout(mat = m, heights = c(0.4, 0.4, 0.1))
par(oma = c(4, 0, 4, 0))
par(mar = c(2,2,2,2))
pie_chart('e.Coli', "E.coli(freshwater\n217 AUs")
pie_chart('Enterococcus',"Enterococcus(marine water)\n132 AUs")
pie_chart('Beach Closing (Enterococcus)', "Enterococcus(beach closings)\n45AUs")
legend(x=1,y=-1,inset = 0, text.width=c(1.4,.5,.9),legend = c("Attaining","Insufficient Information","Non Attaining"), fill = c("#99FF99", "#FFFF99", "#FF9999"),border="#000000",cex=1.2,bty="n",xpd = NA,horiz=TRUE)
plot.new()
title("Figure 2.8:Assessment Results for Key Parameters Associated with Recreation Use,\nPercent(%) of AUs",line = 1, outer = TRUE,font=2)
dev.off()
Graph I have:
Graph I want:

Axes labels in plotly in R

Hi I the have following code in R plotly.
I want to provide axes ticks for e.g. 0:10 for X-axis and seq(from=1000, to=4000, length.out=11) for Y-axis. Can you please help me with this ?
set.seed(0)
#Sample matrix
bitmap<-matrix(rnorm(150000,mean=1:500),nrow = 300, ncol = 500)
plot_ly(z=bitmap) %>% add_heatmap()
Are you looking for tickvals and ticktext?
library(plotly)
library(magrittr)
set.seed(0)
#Sample matrix
nrows <- 300
ncols <- 500
bitmap<-matrix(rnorm(150000 ,mean = 1:500),nrow = nrows, ncol = ncols)
plot_ly(z=bitmap) %>%
add_heatmap() %>%
layout(xaxis=list(tickvals = seq(from = 0,
to = ncols,
length.out = 10),
ticktext = c(0:9)),
yaxis=list(tickvals = seq(from = 0,
to = nrows,
length.out = 11),
ticktext = seq(from = 1000,
to = 4000,
length.out = 11)
)
)

Resources