I am trying to use the ComplexHeatmap R package to generate heatmaps and also print the values.
NES_final is a list of list containing expt at first level and scenario at second level. Within each expt I need to create a combined heatmap of all scenario.
The heatmap is created as expected, but while printing only the last value of scenario in each expt gets printed for all heatmaps within that expt.
Test data:
NES_final = list("expt1" = list("scenario1" = matrix(rnorm(36), nrow=3, ncol=3),
"scenario2" = matrix(rnorm(36), nrow=3, ncol=3),
"scenario3" = matrix(rnorm(36), nrow=3, ncol=3)),
"expt2" = list("scenario1" = matrix(rnorm(36), nrow=3, ncol=3),
"scenario2" = matrix(rnorm(36), nrow=3, ncol=3),
"scenario3" = matrix(rnorm(36), nrow=3, ncol=3)),
"expt3" = list("scenario1" = matrix(rnorm(36), nrow=3, ncol=3),
"scenario2" = matrix(rnorm(36), nrow=3, ncol=3),
"scenario3" = matrix(rnorm(36), nrow=3, ncol=3)))
Code:
for(expt in names(NES_final)){
NES <- NES_final[[expt]]
heatMap <- NULL
for(scenario in names(NES)){
heatMap <- heatMap + Heatmap(NES[[scenario]],
cluster_rows = FALSE,
cluster_columns = FALSE,
name = scenario,
column_title = scenario,
show_heatmap_legend = TRUE,
cell_fun = function(j, i, x, y, width, height, fill){
grid.text(scenario, x, y, gp = gpar(fontsize = 2))
}
)
}
svglite(paste0("/Analysis_1/Heatmap_", expt, ".svg"), width = length(NES) * 25, height = 6)
draw(heatMap, column_title = expt)
dev.off()
}
I was able to find a solution using the lapply function instead of the for loop for scenario.
heatMap <- lapply(names(NES), function(scenario){
Heatmap(NES[[scenario]],
cluster_rows = TRUE,
cluster_columns = FALSE,
name = scenario,
column_title = scenario,
show_heatmap_legend = FALSE,
cell_fun = function(j, i, x, y, width, height, fill){
grid.text(scenario, x, y, gp = gpar(fontsize = 5))
} ) }) }
heatMap <- Reduce("+", heatMap)
draw(heatMap, column_title = expt, padding = unit(c(0.5, 0.5, 0.5, 15), "cm"))
Related
I am plotting an image with this code but I am having some trouble when I Try to save it.
library(markovchain)
library(expm)
library(diagram)
library(pracma)
stateNames <- c("Fischer", "Lewis", "Medium")
q0 <- new("markovchain", states = stateNames,
transitionMatrix =matrix(c(0.08,0.15,0.77,
0.25,0.13,0.62,
0.16,0.18,0.66),
byrow = TRUE, nrow = 3), name = "state t0")
q0_p <- matrix(c(0.08,0.15,0.77,
0.25,0.13,0.62,
0.16,0.18,0.66),
byrow = TRUE, nrow = 3)
row.names(q0_p) <- stateNames; colnames(q0_p) <- stateNames
plotmat(q0_p,pos = c(1,2),
lwd = 1, box.lwd = 1,
cex.txt = 0.8,
box.size = 0.1,
box.type = "circle",
box.prop = 0.7,
box.col = c("#F8766D", "#00BA38","#619CFF"),
shadow.size = 0,
arr.length=.2,
arr.width=.1,
self.cex =.4,
self.shifty = -.01,
self.shiftx = .13,
main = "")
tiff(file="plotq0_3.tiff",width=15,height=10,units="cm",res=300)
but when I go to the file, it weight 6128 kb but I can't see the image. Here is a copy.
How to label edges in ggplot's geom_net library?
library(geomnet)
library(ggplot2)
x <- structure(list(from = c("a", "b", "d", "f", "g", "e", "c", "i",
"e", "h", "i", "i", "j", "j"), to = c("", "", "", "", "", "a",
"b", "c", "d", "e", "f", "g", "h", "i"), edge_val = c(NA, NA,
NA, NA, NA, 1.6, 2.25, 1.75, 0.95, 1.8, 3.2, 2.6, 2.95, 2.45)), .Names = c("from",
"to", "edge_val"), class = "data.frame", row.names = c(NA, -14L
))
ggplot(x, aes(from_id = from, to_id = to, linewidth = edge_val)) +
geom_net(layout.alg = "fruchtermanreingold", labelgeom = "text",repel = TRUE,
size = 4, labelon = TRUE, vjust = -1, ecolour = "grey80",
directed = FALSE, fontsize = 4, ealpha = 0.5) +
theme_net()
The idea would be to plot the edge value on the edges as:
I made some modifications to the code used for geom_net() (found here). It can be used like this:
# similar code as question, with linelabel = edge_val added to aes() & geom_net2
ggplot(x,
aes(from_id = from, to_id = to, linewidth = edge_val, linelabel = edge_val)) +
geom_net2(layout.alg = "fruchtermanreingold", labelgeom = "text", repel = TRUE,
size = 4, labelon = TRUE, vjust = -1, ecolour = "grey80",
directed = FALSE, fontsize = 4, ealpha = 0.5) +
theme_net()
To create geom_net2():
Step 1: Create a modified version of the draw_panel function used by geomnet::GeomNet, with line labels if aes(...) includes a mapping for linelabel.
old.draw_panel <- environment(GeomNet$draw_panel)$f
new.draw_panel <- old.draw_panel
# convert function body to a list, for easier code chunk insertions
body(new.draw_panel) <- as.list(body(new.draw_panel))
# geomnet code includes usage of %||%, which is an unexported function
# (it is identical to the exported version in rlang / purrr, so you can skip
# this step if you have one of those packages loaded)
body(new.draw_panel) <-
append(body(new.draw_panel),
substitute(
"%||%" <- function(a, b) {if (!is.null(a)) a else b}
), after = 1)
# remove the last chunk of code, which returns a grobTree for the geom layer
# (we'll add on a new grobTree later)
body(new.draw_panel) <-
body(new.draw_panel)[-length(body(new.draw_panel))]
# define label_line as NULL
body(new.draw_panel) <-
append(body(new.draw_panel),
substitute(
label_line <- NULL
))
# if aes(...) includes a mapping for linelabel, use it for label_line, positioned at the
# midpoint of each line
body(new.draw_panel) <-
append(body(new.draw_panel),
substitute(
if (!is.null(data$linelabel)){
label_line.df <- subset(data, to != "")
label_line.df$x <- (label_line.df$x + label_line.df$xend) / 2
label_line.df$y <- (label_line.df$y + label_line.df$yend) / 2
label_line.df$label <- label_line.df$linelabel
label_line <- ggplot2::GeomText$draw_panel(label_line.df,
panel_scales, coord)
}
))
# return a grobTree, with label_line added
body(new.draw_panel) <-
append(body(new.draw_panel),
substitute(
ggplot2:::ggname("geom_net2",
grid::grobTree(edges_draw, selfies_draw, selfies_arrows,
GeomPoint$draw_panel(vertices, panel_scales, coord),
label_grob, label_line))
))
body(new.draw_panel) <- as.call(body(new.draw_panel))
rm(old.draw_panel)
Step 2: Create GeomNet2 ggproto, which inherits from geomnet::GeomNet, but uses the modified draw_panel function.
GeomNet2 <- ggproto(`_class` = "GeomNet2",
`_inherit` = geomnet::GeomNet,
draw_panel = new.draw_panel)
Step 3: Create geom_net2 function, which is similar to geomnet::geom_net, except that it uses GeomNet2 as its geom.
geom_net2 <- function (
mapping = NULL, data = NULL, stat = "net", position = "identity", show.legend = NA,
na.rm = FALSE, inherit.aes = TRUE, layout.alg="kamadakawai", layout.par=list(),
directed = FALSE, fiteach=FALSE, selfloops = FALSE, singletons = TRUE, alpha = 0.25,
ecolour=NULL, ealpha=NULL, arrow=NULL, arrowgap=0.01, arrowsize=1, labelon=FALSE,
labelcolour=NULL, labelgeom = 'text', repel = FALSE,
vertices=NULL, ...) {
ggplot2::layer(
geom = GeomNet2, mapping = mapping, data = data, stat = stat,
position = position, show.legend = show.legend, inherit.aes = inherit.aes,
params = list(na.rm = na.rm, layout.alg=layout.alg, layout.par=layout.par,
fiteach=fiteach, labelon=labelon, labelgeom=labelgeom, ecolour = ecolour,
ealpha=ealpha, arrow=arrow, arrowgap=arrowgap, directed=directed, repel=repel,
arrowsize=arrowsize, singletons=singletons, labelcolour=labelcolour,
vertices=vertices, selfloops = selfloops,
...)
)
}
You can use the ggplot_build object to get the positions for the text labels. You need to set the seed so that the plot is not redrawn with a new layout.
library(geomnet)
library(ggplot2)
set.seed(1)
p <- ggplot(x, aes(from_id = from, to_id = to, linewidth = edge_val)) +
geom_net(layout.alg = "fruchtermanreingold", labelgeom = "text",repel = TRUE,
size = 4, labelon = TRUE, vjust = -1, ecolour = "grey80",
directed = FALSE, fontsize = 4, ealpha = 0.5) +
theme_net()
# grab plot data
g <- ggplot_build(p)
edgeData <- subset(g$data[[1]], !is.na(linewidth))
# draw labels
# x and y coords are mid between vertices
set.seed(1) # use the same seed
p + geom_text(data=edgeData,
aes(x=(xend+x)/2, y=(yend+y)/2, label=linewidth),
inherit.aes = FALSE)
If it's not compulsory geomnet package, we can take a look to ggraph package.
Here something to think about:
library(tidyverse)
library(tidytext)
library(tidygraph)
library(ggraph)
library(ggrepel)
# first we have to give to ggraph data as it likes:
edges <- x[-c(1:5),] # edges
colnames(edges) <- c('a','b','edge_val') # colnames
# second the nodes, taking all the nodes in the edges. You can also give them a weight.
nodes <- rbind(data.frame(node = edges$a, n = 1),data.frame(node = edges$b, n = 1)) %>% group_by(node) %>% summarise(n = sum(n))
Now you have to avoid a possible bug in the package, as stated here:
# here the fix
edges$a <- match(edges$a, nodes$node)
edges$b <- match(edges$b, nodes$node)
# you have to give to the graph data in this way
tidy <- tbl_graph(nodes = nodes, edges = edges, directed = T)
tidy <- tidy %>%
activate(nodes)
# lastly, the plot
set.seed(1)
ggraph(tidy, layout = "gem") +
geom_node_point(aes(size=1, color = 1)) +
geom_edge_link(alpha = 0.8,aes(label = edge_val)) +
scale_edge_width(range = c(0.2, 2)) +
geom_text_repel(aes(x = x, y=y , label=node), size = 6) +
# here some warnings about font...
theme_graph()
I tried to run this code and it seems to produce no errors but at the end I don't get the plot for some reason. I had some issues with the variables for the plot but i think that should be fixed now. I can't get the plot in my viewer. Is there an issue with the code or should I reinstall plotly?
library(PortfolioAnalytics)
library(quantmod)
library(PerformanceAnalytics)
library(zoo)
library(plotly)
library(foreach)
library(DEoptim)
library(iterators)
library(fGarch)
library(Rglpk)
library(quadprog)
library(ROI)
library(ROI.plugin.glpk)
library(ROI.plugin.quadprog)
library(ROI.plugin.symphony)
library(pso)
library(GenSA)
library(corpcor)
library(testthat)
library(nloptr)
library(MASS)
library(robustbase)
# Get data
getSymbols(c("MSFT", "SBUX", "IBM", "AAPL", "^GSPC", "AMZN"))
# Assign to dataframe
# Get adjusted prices
prices.data <- merge.zoo(MSFT[,6], SBUX[,6], IBM[,6], AAPL[,6], GSPC[,6], AMZN[,6])
# Calculate returns
returns.data <- CalculateReturns(prices.data)
returns.data <- na.omit(returns.data)
# Set names
colnames(returns.data) <- c("MSFT", "SBUX", "IBM", "AAPL", "^GSPC", "AMZN")
# Save mean return vector and sample covariance matrix
meanReturns <- colMeans(returns.data)
covMat <- cov(returns.data)
# Start with the names of the assets
port <- portfolio.spec(assets = c("MSFT", "SBUX", "IBM", "AAPL", "^GSPC", "AMZN"))
# Box
port <- add.constraint(port, type = "box", min = 0.05, max = 0.8)
# Leverage
port <- add.constraint(portfolio = port, type = "full_investment")
# Generate random portfolios
rportfolios <- random_portfolios(port, permutations = 5000, rp_method = "sample")
# Get minimum variance portfolio
minvar.port <- add.objective(port, type = "Risk", name = "var")
# Optimize
minvar.opt <- optimize.portfolio(returns.data, minvar.port, optimize_method = "random",
rp = rportfolios)
# Generate maximum return portfolio
maxret.port <- add.objective(port, type = "Return", name = "mean")
# Optimize
maxret.opt <- optimize.portfolio(returns.data, maxret.port, optimize_method = "random",
rp = rportfolios)
# Generate vector of returns
minret <- 0.06/100
maxret <- maxret.opt$weights %*% meanReturns
vec <- seq(minret, maxret, length.out = 100)
eff.frontier <- data.frame(Risk = rep(NA, length(vec)),
Return = rep(NA, length(vec)),
SharpeRatio = rep(NA, length(vec)))
frontier.weights <- mat.or.vec(nr = length(vec), nc = ncol(returns.data))
colnames(frontier.weights) <- colnames(returns.data)
for(i in 1:length(vec)){
eff.port <- add.constraint(port, type = "Return", name = "mean", return_target = vec[i])
eff.port <- add.objective(eff.port, type = "Risk", name = "var")
# eff.port <- add.objective(eff.port, type = "weight_concentration", name = "HHI",
# conc_aversion = 0.001)
eff.port <- optimize.portfolio(returns.data, eff.port, optimize_method = "ROI")
eff.frontier$Risk[i] <- sqrt(t(eff.port$weights) %*% covMat %*% eff.port$weights)
eff.frontier$Return[i] <- eff.port$weights %*% meanReturns
eff.frontier$Sharperatio[i] <- eff.port$Return[i] / eff.port$Risk[i]
frontier.weights[i,] = eff.port$weights
print(paste(round(i/length(vec) * 100, 0), "% done..."))
}
feasible.sd <- apply(rportfolios, 1, function(x){
return(sqrt(matrix(x, nrow = 1) %*% covMat %*% matrix(x, ncol = 1)))
})
feasible.means <- apply(rportfolios, 1, function(x){
return(x %*% meanReturns)
})
feasible.sr <- feasible.means / feasible.sd
p <- plot_ly(x = feasible.sd, y = feasible.means, color = feasible.sr,
mode = "markers", type = "scattergl", showlegend = F,
marker = list(size = 3, opacity = 0.5,
colorbar = list(title = "Sharpe Ratio"))) %>%
add_trace(data = eff.frontier, x = 'Risk', y = 'Return', mode = "markers",
type = "scattergl", showlegend = F,
marker = list(color = "#F7C873", size = 5)) %>%
layout(title = "Random Portfolios with Plotly",
yaxis = list(title = "Mean Returns", tickformat = ".2%"),
xaxis = list(title = "Standard Deviation", tickformat = ".2%"),
plot_bgcolor = "#434343",
paper_bgcolor = "#F8F8F8",
annotations = list(
list(x = 0.4, y = 0.75,
ax = -30, ay = -30,
text = "Efficient frontier",
font = list(color = "#F6E7C1", size = 15),
arrowcolor = "white")
))
You have a problem with add_trace() function syntax. If you want markers on the plot you will need to make dimensions of eff.frontier table corresponding to your feasible.sd and feasible.means dimensions, which you set as the first layer of your plot.
Simply, eff.frontier columns length should be the same as for the feasible.sd and feasible.means vectors.
So, if we create an example eff.frontier table with right dimensions we could construct plotly object without any problem:
# create eff.frontier example object
eff.frontier_example <- data.frame(Risk = seq(0.01373, 0.01557, length.out = length(feasible.sd)),
Return = seq(0.0006444, 0.0008915, length.out = length(feasible.sd)))
# create plotly object
p <- plot_ly(x = feasible.sd, y = feasible.means, color = feasible.sr,
mode = "markers", type = "scattergl", showlegend = F,
marker = list(size = 3, opacity = 0.5,
colorbar = list(title = "Sharpe Ratio"))) %>%
add_trace(x = eff.frontier_example$Risk, y = eff.frontier_example$Return, mode = "markers",
type = "scattergl", showlegend = F,
marker = list(color = "#F7C873", size = 5)) %>%
layout(title = "Random Portfolios with Plotly",
yaxis = list(title = "Mean Returns", tickformat = ".2%"),
xaxis = list(title = "Standard Deviation", tickformat = ".2%"),
plot_bgcolor = "#434343",
paper_bgcolor = "#F8F8F8",
annotations = list(
list(x = 0.4, y = 0.75,
ax = -30, ay = -30,
text = "Efficient frontier",
font = list(color = "#F6E7C1", size = 15),
arrowcolor = "white")
))
# show plotly object
p
I'll assume you ran the code exactly as posted. Your last code block assigns the plotly plot to p. Just add the line p to call the plot.
p <- plotly_ly(...)
p
I want to plot 4 of the following plots as an par(mfrow=c(2,2)) type arrangement.
install.packages("wavelets")
require(wavelets)
dat <- rnorm(100)
plot.modwt(modwt(dat)) #4 of these in a 2x2 grid is desired
However, layout and mfrow based attempts have not succeeded.
I will be giving the correct answer a bounty.
As #plannapus commented, the function plot.modwt already calls layout. So you will need to alter the original function.
If you type plot.modwt in you R console, you will get the complete definition.
Copy this function and save it as a new function, say, my.plot.modwt.
Comment out the layout line in this function
Set up your new layout. This worked for me:
nf = layout(matrix(c(3, 1, 4, 2, 7, 5,8, 6), 4, 2, byrow = TRUE),
c(2,2), c(2,1, 2, 1), TRUE)
layout.show(nf)
Call your function (4 times )to create plots:
my.plot.modwt(modwt(dat1))
my.plot.modwt(modwt(dat2))
my.plot.modwt(modwt(dat3))
my.plot.modwt(modwt(dat4))
Note, some other alterations to the layout will probably be needed.
My code:
y.plot.modwt = function (x, levels = NULL, draw.boundary = FALSE, type = "stack",
col.plot = "black", col.boundary = "red", X.xtick.at = NULL,
X.ytick.at = NULL, Stack.xtick.at = NULL, Stack.ytick.at = NULL,
X.xlab = "t", y.rlabs = TRUE, plot.X = TRUE, plot.W = TRUE,
plot.V = TRUE, ...)
{
stackplot.modwt <- function(x, w.range, v.range, col.plot,
col.boundary, draw.boundary, X.xtick.at, X.ytick.at,
Stack.xtick.at, Stack.ytick.at, X.xlab = "t", plot.X = TRUE) {
innerplot <- function(x, y, type = "l", xtick.at, ytick.at) {
if (is.null(xtick.at) == FALSE || is.null(ytick.at) ==
FALSE) {
plot(x, y, type = "l", axes = FALSE, frame.plot = TRUE)
<snip>
if (plot.X) {
#nf <- layout(matrix(c(2, 2, 1, 1), 2, 2, byrow = TRUE),
# c(1, 2), c(2, 1), TRUE)
par(mai = c(0.6, 0.4, 0.1, 0.6))
<snip>
}
When creating a table using tableGrob or grid.table.
Is there way to align the text inside the table? First column to the left, and the other columns to the right? Rather than the default "center".
Thank you!
something like this: where I want column "a" alligned to the left.
a <- c("one","two","thirty five")
b <- c(1, 2, 3)
c <- c(4, 5, 6)
data <- data.frame(a,b,c)
windows()
grid.table(
data,
gpar.coretext=gpar(fontsize = 12),
gpar.coltext = gpar(fontsize = 12),
gpar.rowtext = gpar(fontsize = 12),
gpar.corefill =
gpar(fill = "green", alpha = 0.5, col = NA),
h.even.alpha = 0.5,
equal.width = FALSE,
show.rownames = FALSE,
show.vlines = TRUE,
padding.h = unit(15, "mm"),
padding.v = unit(8, "mm")
)
With gridExtra v>=2.0.0, the parameters are now controlled via nested lists (themes),
library(gridExtra)
library(grid)
n=5
d <- data.frame(x=rnorm(n),y=rnorm(n),z=sample(letters[1:2],n,replace=T))
m <- format(d, digits = 1, scientific=F,big.mark = ",")
mytheme <- ttheme_default(core = list(fg_params = list(hjust=0, x=0.1,
fontsize=8)),
colhead = list(fg_params = list(fontsize=9,
fontface="bold"))
)
g1 <- tableGrob(m, theme = mytheme, rows=NULL)
grid.newpage()
grid.draw(g1)
Is this what you are looking for? There is a core.just parameter of the format() call.
require("gridExtra")
n=5
df<- data.frame(x=rnorm(n),y=rnorm(n),z=sample(letters[1:2],n,replace=T))
g1<-tableGrob(
format(df, digits = 1,
scientific=F,big.mark = ","),
core.just="left",
#core.just="right",
#col.just="right",
gpar.coretext=gpar(fontsize=8),
gpar.coltext=gpar(fontsize=9, fontface='bold'),
show.rownames = F,
h.even.alpha = 0,
gpar.rowtext = gpar(col="black", cex=0.7,
equal.width = TRUE,
show.vlines = TRUE,
show.hlines = TRUE,
separator="grey")
)
grid.draw(g1)
To set a "transparent" background, use the ttheme_minimal with hjust to set text alignment.
theme_1 <- ttheme_minimal(core = list(fg_params = list(hjust = 0,
x = 0.1,
fontsize = 9)),
colhead = list(fg_params = list(fontsize = 12,
fontface = "bold")))
You can then apply the theme to the tableGrob like this:
gridExtra::tableGrob(df_tbl, theme = theme_1, rows=NULL)