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:
Related
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")
I'm not an R expert, and I'm having a little troubles plotting my data
Some context: An experiment using 2 coagulants, at 3 different velocities with 3 different solids concentrations was conducted to see the behavior of 3 parameters. The experiment results was recorded in the following data frame:
Coagulant <- c(rep("Chem_1", times = 9),
rep("Chem_2", times = 9))
Velocity <- rep(c(rep("low", times = 3),
rep("mid", times = 3),
rep("high", times = 3)),
times = 2)
Solids <- rep(c(0,50,100), times = 6)
Parameter_1 <- runif(n = 18,
min = 70,
max = 100)
Parameter_2 <- runif(n = 18,
min = 90,
max = 100)
Parameter_3 <- runif(n = 18,
min = 0,
max = 100)
Ex.data.frame <- data.frame(Coagulant,
Velocity,
Solids,
Parameter_1,
Parameter_2,
Parameter_3)
Ex.data.frame$Coagulant <- factor(Ex.data.frame$Coagulant,
levels = c("Chem_1", "Chem_2"),
labels = c("Chem_1", "Chem_2"))
Ex.data.frame$Velocity <- factor(Ex.data.frame$Velocity,
levels = c("low", "mid", "high"),
labels = c("low", "mid", "high"))
Ex.data.frame$Solids <- factor(Ex.data.frame$Solids,
levels = c(0, 50, 100),
labels = c(0, 50, 100))
I'd like to plot this data following this panel separation:
I tried a lot, but only can provide this code to make the plot:
require(ggpubr)
ggbarplot(data = Ex.data.frame,
y = "Parameter_1", #I'd like to use for all parameters (same units)
fill = "Solids",
position = position_dodge2(),
facet.by = c("Coagulant", "??")) #Facet by the parameters columns from the data frame
Here is a potential way towards your goal (you just have to switch in the facet to have the same columns and lines as in your graph) :
library(dplyr)
library(magrittr)
d <-rbind(Ex.data.frame[1:4] %>% rename(Parameter = Parameter_1) %>% mutate(param = "Parameter_1"),
Ex.data.frame[c(1:3,5)] %>% rename(Parameter = Parameter_2) %>% mutate(param = "Parameter_2"),
Ex.data.frame[c(1:3,6)] %>% rename(Parameter = Parameter_3) %>% mutate(param = "Parameter_3")
)
ggbarplot(data = d,
y = c("Parameter" ),
fill = "Solids",
position = position_dodge2(),
facet.by = c( "param", "Coagulant" ))
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
I needed to include in the code below, a vertical line,
for example, in position x = 5 and that all points smaller than 5 have another color,
for example blue.
The values of a variable can be read from the x-axis, and the y-axis shows the order of the observations in the variable (from bottom to top). Isolated points as the far ends, and on either side in a plot, suggest potentional outliers
Thanks
library(dplyr)
library(lattice)
n = 1000
df <- tibble(
xx1 = runif(n, min = 3, max = 10),
xx2 = runif(n, min = 3, max = 10),
xx3 = runif(n, min = 3, max = 10)
)
MyVar <- c("xx1","xx2","xx3")
MydotplotBR <- function(DataSelected){
P <- dotplot(as.matrix(as.matrix(DataSelected)),
groups=FALSE,
strip = strip.custom(bg = 'white',
par.strip.text = list(cex = 1.2)),
scales = list(x = list(relation = "same",tck = 1,
draw = TRUE, at=seq(0,10,1)),x=list(at=seq),
y = list(relation = "free", draw = FALSE),
auto.key = list(x =1)),
col=10,
axes = FALSE,
cex = 0.4, pch = 5,
xlim=c(0,10),
xlab = list(label = "Variable Value", cex = 1.5),
ylab = list(label = "Order of data in the file", cex = 1.5))
print(P)
}
(tempoi <- Sys.time())
Vertemp <- MydotplotBR(df[,MyVar])
(tempof <- Sys.time()-tempoi)
I find it weird that you want a color dependent only on the x-axis when values are also used on the y-axis of other plots.
Nevertheless, here's a homemade pairs_cutoff() function doing what you want.
pairs_cutoff <- function(data, cutoff, cols = c("red", "blue"),
only.lower = F, ...){
data <- as.data.frame(data)
cns <- colnames(data)
nc <- ncol(data)
layout(matrix(seq_len(nc^2), ncol = nc))
invisible(
sapply(seq_len(nc), function(i){
sapply(seq_len(nc), function(j){
if(i == j){
plot.new()
legend("center", bty = "n", title = cns[i], cex = 1.5, text.font = 2, legend = "")
} else {
if(j < i & only.lower)
plot.new()
else{
if(is.null(cutoff))
cols <- cols[1]
plot(data[,i], data[,j], col = cols[(data[,i] < cutoff) + 1],
xlab = cns[i], ylab = cns[j], ...)
}
}
})
})
)
}
Using your suggested data :
n = 1000
dat <- tibble(
xx1 = runif(n, min = 3, max = 10),
xx2 = runif(n, min = 3, max = 10),
xx3 = runif(n, min = 3, max = 10)
)
pairs_cutoff(dat, cutoff = 5, only.lower = T)
outputs the following plot :
You can specify extra parameters to the plot function (eg. pch) directly to pairs_cutoff.
Also, if you want the full symmetric grid of plots, set only.lower = F.
I am using the rugarch package and I fitted a model. Now I want to look at the output and use the plot function. My problem is, that the 5th plot contains some subplots, which are plotted in one device, but I want to plot each in a single device. How can I do this? As an example I give you a code example, which uses the sp500ret data of the package:
The code:
library(rugarch)
data(sp500ret)
somemodel<-ugarchspec(variance.model = list(model = "sGARCH", garchOrder = c(2, 2)),
mean.model = list(armaOrder = c(1, 1), include.mean = TRUE),
distribution.model = "ged")
somefit<-ugarchfit(spec=somemodel,data=sp500ret)
rollingesti = ugarchroll(somemodel, sp500ret, n.start=500,
refit.every = 100, refit.window = 'moving', window.size = 500,
calculate.VaR = FALSE, keep.coef = TRUE)
plot(rollingesti,which=5)
the plot(rollingesti,which=5) plots several plots into one device, I want to isolate them.
So I want to have them as single plots and bigger, now, they are too small, since they are all put into one output.
Your example does not work (at least for me), i.e. it does not converge. However, this one works:
library(rugarch)
data(sp500ret)
spec <- ugarchspec(distribution.model = "std")
mod <- ugarchroll(spec, data = sp500ret[1:2000,], n.ahead = 1,
n.start = 1000, refit.every = 100, refit.window = "moving",
solver = "hybrid", fit.control = list(),
calculate.VaR = TRUE, VaR.alpha = c(0.01, 0.025, 0.05),
keep.coef = TRUE)
First, we find a method that is used in plot(mod, which = 5). It can be obtained by
getMethod("plot", c(x = "uGARCHroll", y = "missing"))
You are interested in the following lines
.intergarchrollPlot(x, choices = choices, plotFUN = paste(".plot.garchroll",
1:5, sep = "."), which = which, VaR.alpha = VaR.alpha,
density.support = density.support, ...)
where choices is "Fit Coefficients (with s.e. bands)". By inspecting rugarch:::.intergarchrollPlot we finally arrive to rugarch:::.plot.garchroll.5. These plots are not returned in any list or similar, hence I provide a bit modified version so that you could use them separately. Here I changed the first two and the last one line:
library(xts)
x <- mod
vmodel = x#model$spec#model$modeldesc$vmodel
if (!x#model$keep.coef)
stop("\n\nplot-->error: keep.coef set to FALSE in estimation\n")
coefs = x#model$coef
m = dim(coefs[[1]]$coef)[1]
N = length(coefs)
Z = matrix(NA, ncol = m, nrow = N)
Zup = matrix(NA, ncol = m, nrow = N)
Zdn = matrix(NA, ncol = m, nrow = N)
for (i in 1:m) {
Z[, i] = sapply(coefs, FUN = function(y) y$coef[i, 1])
Zup[, i] = Z[, i] + sapply(coefs, FUN = function(y) y$coef[i,
2])
Zdn[, i] = Z[, i] - sapply(coefs, FUN = function(y) y$coef[i,
2])
}
dt = sapply(coefs, FUN = function(y) as.character(y$index))
cnames = rownames(coefs[[1]]$coef)
np = rugarch:::.divisortable(m) # added rugarch:::
This is a function for each plot separately, i is a number of the graph, e.g. from 1 to 7 in this case:
plotFun <- function(i){
plot(xts(Z[, i], as.POSIXct(dt)), type = "l",
ylim = c(min(Zdn[, i]), max(Zup[, i])), ylab = "value", xlab = "", main = "",
minor.ticks = FALSE, ann = FALSE, auto.grid = FALSE)
lines(xts(Zdn[, i], as.POSIXct(dt)), col = 2)
lines(xts(Zup[, i], as.POSIXct(dt)), col = 2)
title(cnames[i], line = 0.4, cex = 0.9)
grid()
}
For example:
plotFun(1)
plotFun(2)