I'm generating several chorddiag plots in R and would like to combine them together to a single plot. Here's an example list of 3 chorddiag plots:
library(chorddiag)
m <- matrix(c(11975, 5871, 8916, 2868,
1951, 10048, 2060, 6171,
8010, 16145, 8090, 8045,
1013, 990, 940, 6907),
byrow = TRUE,
nrow = 4, ncol = 4)
haircolors <- c("black", "blonde", "brown", "red")
dimnames(m) <- list(haircolors,haircolors)
groupColors <- c("#000000", "#FFDD89", "#957244", "#F26223")
ll <- lapply(1:3,function(i) chorddiag(m, groupColors = groupColors, groupnamePadding = 20))
If these were plotly object I'd use plotly's subplot function. Is there anything equivalent for case of:
> class(ll[[1]])
[1] "chorddiag" "htmlwidget"
I haven't tried the chorddiag package (I don't think it's on CRAN, maybe some other repos?), but the manipulateWidget package may be what you want. example(combineWidgets) has this code:
data(iris)
library(manipulateWidget); library(plotly)
#> Loading required package: ggplot2
#>
#> Attaching package: 'plotly'
#> The following object is masked from 'package:ggplot2':
#>
#> last_plot
#> The following object is masked from 'package:stats':
#>
#> filter
#> The following object is masked from 'package:graphics':
#>
#> layout
combineWidgets(title = "The Iris dataset",
plot_ly(iris, x = ~Sepal.Length, type = "histogram", nbinsx = 20),
plot_ly(iris, x = ~Sepal.Width, type = "histogram", nbinsx = 20),
plot_ly(iris, x = ~Petal.Length, type = "histogram", nbinsx = 20),
plot_ly(iris, x = ~Petal.Width, type = "histogram", nbinsx = 20)
)
Created on 2022-03-24 by the reprex package (v2.0.1)
EDITED to add:
Okay, I found chorddiag on Github: https://github.com/mattflor/chorddiag/ . After running your code, this combines the three diagrams:
manipulateWidgets::combineWidgets(shiny::tagList(ll))
They don't resize nicely; I suspect that's because chorddiag wants to be fullscreen, but maybe it's a problem in manipulateWidgets. You'll probably have to patch one or the other.
Related
The following explain_tidymodels is created, to to display partial dependence plots.
explainer <- explain_tidymodels(rf_vi_fit, data = Data_train, y = Data_train$Lead_week)
Now i'm creating plots by doing the following:
model_profile(explainer, variables = c("Month", "AC")) %>% plot()
It automatically gives me plots in blue. However, how do I change the plot colour to red?
I already tried things like %>% plot(color = "red") and %>% plot(col = "red") but both do not work.
Any suggestions to change the partial dependence plots to a prefered colour? Thanks in advance!
I suggest that you access the underlying data and make your own plot using ggplot2, like I show here:
library(tidymodels)
#> Registered S3 method overwritten by 'tune':
#> method from
#> required_pkgs.model_spec parsnip
library(DALEXtra)
#> Loading required package: DALEX
#> Welcome to DALEX (version: 2.2.0).
#> Find examples and detailed introduction at: http://ema.drwhy.ai/
#> Additional features will be available after installation of: ggpubr.
#> Use 'install_dependencies()' to get all suggested dependencies
#>
#> Attaching package: 'DALEX'
#> The following object is masked from 'package:dplyr':
#>
#> explain
data(ames)
ames_train <- ames %>%
transmute(Sale_Price = log10(Sale_Price),
Gr_Liv_Area = as.numeric(Gr_Liv_Area),
Year_Built, Bldg_Type)
rf_model <-
rand_forest(trees = 1000) %>%
set_engine("ranger") %>%
set_mode("regression")
rf_wflow <-
workflow() %>%
add_formula(
Sale_Price ~ Gr_Liv_Area + Year_Built + Bldg_Type) %>%
add_model(rf_model)
rf_fit <- rf_wflow %>% fit(data = ames_train)
explainer_rf <- explain_tidymodels(
rf_fit,
data = dplyr::select(ames_train, -Sale_Price),
y = ames_train$Sale_Price,
label = "random forest"
)
#> Preparation of a new explainer is initiated
#> -> model label : random forest
#> -> data : 2930 rows 3 cols
#> -> data : tibble converted into a data.frame
#> -> target variable : 2930 values
#> -> predict function : yhat.workflow will be used ( [33m default [39m )
#> -> predicted values : No value for predict function target column. ( [33m default [39m )
#> -> model_info : package tidymodels , ver. 0.1.3 , task regression ( [33m default [39m )
#> -> predicted values : numerical, min = 4.896787 , mean = 5.220582 , max = 5.51655
#> -> residual function : difference between y and yhat ( [33m default [39m )
#> -> residuals : numerical, min = -0.8021289 , mean = 5.872977e-05 , max = 0.3613971
#> [32m A new explainer has been created! [39m
pdp_rf <- model_profile(explainer_rf, N = NULL,
variables = "Gr_Liv_Area", groups = "Bldg_Type")
as_tibble(pdp_rf$agr_profiles) %>%
mutate(`_label_` = stringr::str_remove(`_label_`, "random forest_")) %>%
ggplot(aes(`_x_`, `_yhat_`, color = `_label_`)) +
geom_line(size = 1.2, alpha = 0.8) +
labs(x = "Gross living area",
y = "Sale Price (log)",
color = NULL,
title = "Partial dependence profile for Ames housing sales",
subtitle = "Predictions from a random forest model")
Created on 2021-05-27 by the reprex package (v2.0.0)
You can also access pdp_rf$cp_profiles.
Please see the map I drew below using the tmap package. I did not any find parameters that I can use to customize the font of the histogram legend. From the code below, you can see that I've already set the legend.text.fontface = 'bold'. However, this did not work.
psp1 <- tm_shape(province) +
tm_borders(col = 'black') +
tm_shape(county) +
tm_polygons(col = '+1 °C', title = 'Changes in %', style = 'pretty', aes.palette = 'div', n=5, legend.hist = T) +
tm_compass(north = 0, type = 'arrow', show.labels =0, position = c('right','top')) +
tm_layout(legend.format = list(fun = function(x) formatC(x, digits = 1, format = "f")),
legend.outside = T, legend.outside.position = 'bottom',
legend.hist.width = 1,
legend.hist.height = 0.5,
legend.stack = 'horizontal',
legend.title.fontface = 'bold',
legend.text.fontface = 'bold')
Very interesting question. Indeed, it does not seem possible to change the font of the labels for the histogram using legend.text.fontface = 'bold'
Hopefully, it is possible to change this using the base R library grid on which the tmap library is based on.
So, please find below one possible solution to your request (hoping that this answer does not come too late and that it will still be useful to you)
Preliminary note for other Stackoverflow users: to run the reprex below correctly you will need to first download the data made available by the OP in this post.
Reprex
STEP 1 - BUILDING THE MAP WITH THE LEGEND
library(sf)
library(tmap)
library(RColorBrewer)
setwd("Add the path to your working directory")
# Import data
province <- st_read("province.shp")
county <- st_read("county.shp")
# Split the 'sf' object 'county' into a list of five 'sf' objects
county_warm_list <- split(county , f = county$warming)
# Build the map with the legend
psp1 <- tm_shape(province) +
tm_borders(col = 'black') +
tm_shape(st_sf(county_warm_list[[3]])) + # using the scenario +3°C
tm_polygons(col = 'estimate',
title = 'Changes in %',
style = 'pretty',
aes.palette = 'div',
n=5,
legend.hist = TRUE,
midpoint = 0) +
tm_compass(north = 0,
type = 'arrow',
show.labels =0,
position = c('right','top')) +
tm_layout(legend.show = TRUE,
legend.format = list(fun = function(x) formatC(x, digits = 1, format = "f")),
legend.outside = TRUE,
legend.outside.position = 'bottom',
legend.hist.width = 1,
legend.hist.height = 0.5,
legend.stack = 'horizontal',
legend.title.fontface = 'bold',
legend.text.fontface = 'bold')
STEP 2 - BOLD ALL THE LABELS IN THE LEGEND (i.e. including those in the histogram)
library(grid)
# Convert the 'tmap' object psp1 into a 'grob' object ('grob' = 'grid graphical object')
psp1 <- tmap_grob(psp1)
# Find the name of the element we want to change using 'grid.list()' which
# returns a listing of 'grobs' (including gTree)
grid.ls(psp1)
#> GRID.gTree.41
#> multiple_1
#> BG
#> mapBG
#> mapElements
#> GRID.gTree.11
#> tm_polygons_1_2
#> GRID.gTree.12
#> tm_polygons_1_3
#> GRID.rect.13
#> meta_with_bg
#> meta
#> GRID.gTree.16
#> GRID.gTree.15
#> compass
#> GRID.polygon.14
#> outside_legend !!!! "outside_legend" element !!!!
#> meta_with_bg
#> meta
#> legend
#> GRID.rect.39
#> GRID.gTree.40
#> GRID.gTree.19
#> GRID.gTree.18
#> GRID.text.17
#> GRID.gTree.23
#> GRID.gTree.22
#> GRID.rect.20
#> GRID.text.21
#> GRID.gTree.38
#> GRID.gTree.37
#> GRID.gTree.36
#> GRID.gTree.25
#> GRID.rect.24
#> GRID.gTree.27
#> GRID.polyline.26
#> GRID.gTree.29
#> GRID.text.28
#> GRID.gTree.33
#> GRID.gTree.30
#> GRID.lines.31
#> GRID.polyline.32
#> GRID.gTree.35
#> GRID.text.34
In the listing of grob objects just above, you can see an element named "outside_legend". So, we will modify it to bold the fonts of the legend:
# Edit the 'outside_legend' element of the 'grob' object 'psp1' using
# 'editGrob()' and save it in the new 'grob' object 'my_map'
my_map <- editGrob(psp1, gPath("outside_legend"), gp = gpar(fontface = "bold"))
# Draw the 'grob' object 'my_map'
# !!!! NB: may take a few seconds to be displayed in the graphic device !!!!
grid.draw(my_map)
STEP 3 - SAVING THE MAP EITHER MANUALLY OR PROGRAMMATICALLY
(in the latter case, you need to install the rstudioapi library)
rstudioapi::savePlotAsImage(
"my_map.png", # add the path if different of the working directory
format = "png", # other possible formats: "jpeg", "bmp", "tiff", "emf", "svg", "eps"
width = 670,
height = 710
)
And that's it :-)
Created on 2022-01-30 by the reprex package (v2.0.1)
I'd like to implement a cross-talk functionality between a table and plot in both directions:
select the row in the table which will be reflected in the plot
select a dot in the plot which will be reflected in the table. Same idea as here.
I've managed to implement a script, which works beautifully if I make scatter plot with ggplot() and table (both objects cross-talk!). However, when used EnhancedVolcano() and table I got the following error:
Error in EnhancedVolcano(toptable = data_shared, lab = "disp", x = "qsec", :
qsec is not numeric!
If I replace data_shared variable with df_orig, no error is raised, but there is no cross-talking between objects :(
Does this mean that SharedData$new() doesn't recognize numeric values as numeric? How to fix this error?
Any help is highly appreciated.
Thank you
Toy example:
library(plotly) # '4.9.1'
library(DT) # '0.11'
library(crosstalk) # ‘1.0.0’
library(EnhancedVolcano) # ‘1.4.0’
# Input
data1 = mtcars #dim(data1) # 32 11
data_shared = SharedData$new(data1) #, key = c("qsec", "hp"))
# df_orig = data_shared$origData()
# V-Plot
vp =EnhancedVolcano( toptable = data_shared,
lab = 'disp',
x = 'qsec',
y = 'hp',
xlab ='testX',
ylab = 'testY')
bscols(
ggplotly(vp + aes(x= qsec, y= -log10(hp/1000))),
datatable(data_shared, style="bootstrap", class="compact", width="100%",
options=list(deferRender=FALSE, dom='t')))
Same script, which works with ggplot():
data1 = mtcars #dim(data1) # 32 11
data_shared = SharedData$new(data1)
vp = ggplot(data = data_shared, mapping = aes(qsec, hp)) +
geom_point()
bscols(
ggplotly(vp) ,
datatable(data_shared, style="bootstrap", class="compact", width="100%",
options=list(deferRender=FALSE, dom='t')))
Note: Related (same) question was posted at BioStars, and the package author posted an answer, with author's permission copying an answer here:
Hi,
Thanks - that's very useful code and I may add it to the main package vignette, eventually.
I tried it here on my computer and I was able to get it working in my browser, but some components of the original plot seem to have been lost. I think that you just need to convert your column, 'qsec', to numerical values.
Re-using an example from my Vignette, here is a perfectly reproducible example:
library("pasilla")
pasCts <- system.file("extdata", "pasilla_gene_counts.tsv",
package="pasilla", mustWork=TRUE)
pasAnno <- system.file("extdata", "pasilla_sample_annotation.csv",
package="pasilla", mustWork=TRUE)
cts <- as.matrix(read.csv(pasCts,sep="\t",row.names="gene_id"))
coldata <- read.csv(pasAnno, row.names=1)
coldata <- coldata[,c("condition","type")]
rownames(coldata) <- sub("fb", "", rownames(coldata))
cts <- cts[, rownames(coldata)]
library("DESeq2")
dds <- DESeqDataSetFromMatrix(countData = cts,
colData = coldata,
design = ~ condition)
featureData <- data.frame(gene=rownames(cts))
mcols(dds) <- DataFrame(mcols(dds), featureData)
dds <- DESeq(dds)
res <- results(dds)
library(EnhancedVolcano)
p1 <- EnhancedVolcano(res,
lab = rownames(res),
x = "log2FoldChange",
y = "pvalue",
pCutoff = 10e-4,
FCcutoff = 2,
xlim = c(-5.5, 5.5),
ylim = c(0, -log10(10e-12)),
pointSize = c(ifelse(res$log2FoldChange>2, 8, 1)),
labSize = 4.0,
shape = c(6, 6, 19, 16),
title = "DESeq2 results",
subtitle = "Differential expression",
caption = "FC cutoff, 1.333; p-value cutoff, 10e-4",
legendPosition = "right",
legendLabSize = 14,
col = c("grey30", "forestgreen", "royalblue", "red2"),
colAlpha = 0.9,
drawConnectors = TRUE,
hline = c(10e-8),
widthConnectors = 0.5)
p1 <- p1 +
ggplot2::coord_cartesian(xlim=c(-6, 6)) +
ggplot2::scale_x_continuous(
breaks=seq(-6,6, 1))
library(plotly)
library(DT)
library(crosstalk)
bscols(
ggplotly(p1 + aes(x= log2FoldChange, y= -log10(pvalue))),
datatable(
data.frame(res),
style="bootstrap",
class="compact", width="100%",
options=list(deferRender=FALSE, dom='t')))
Unfortunately, plotly and/or bscols don't like the use of bquote(), so, one cannot have the fancy axes names that I use in EnhancedVolcano:
... + xlab(bquote(~Log[2] ~ "fold change")) + ylab(bquote(~-Log[10] ~ italic(P)))
When i try to add these, it throws an error.
Kevin
tried to modify few things in volcano function, got following error:
Error in as.data.frame.default(toptable) :
cannot coerce class ‘c("SharedData", "R6")’ to a data.frame
not sure yet, how to fix it.
It looks like DiagrammeR has changed their create_nodes and create_edges functions than it looks on the doc.
Also the $dot_code attribute is not there anymore. I can't find the replacement for this.
Here is the example code that they had on the doc, but it is not working.
The following example is found in their official DiagrammeR web.
###
# Create a graph with both nodes and edges
# defined, and, add some default attributes
# for nodes and edges
###
library(DiagrammeR)
# Create a node data frame
nodes <-
create_nodes(nodes = c("a", "b", "c", "d"),
label = FALSE,
type = "lower",
style = "filled",
color = "aqua",
shape = c("circle", "circle",
"rectangle", "rectangle"),
data = c(3.5, 2.6, 9.4, 2.7))
edges <-
create_edges(from = c("a", "b", "c"),
to = c("d", "c", "a"),
rel = "leading_to")
graph <-
create_graph(nodes_df = nodes,
edges_df = edges,
node_attrs = "fontname = Helvetica",
edge_attrs = c("color = blue",
"arrowsize = 2"))
graph
#> $nodes_df
#> nodes label type style color shape data
#> 1 a lower filled aqua circle 3.5
#> 2 b lower filled aqua circle 2.6
#> 3 c lower filled aqua rectangle 9.4
#> 4 d lower filled aqua rectangle 2.7
#>
#> $edges_df
#> from to rel
#> 1 a d leading_to
#> 2 b c leading_to
#> 3 c a leading_to
#>
#> $graph_attrs
#> [1] NULL
#>
#> $node_attrs
#> [1] "fontname = Helvetica"
#>
#> $edge_attrs
#> [1] "color = blue" "arrowsize = 2"
#>
#> $directed
#> [1] TRUE
#>
#> $dot_code
#> [1] "digraph {\n\ngraph [rankdir = LR]\n\nnode [fontnam...
#>
#> attr(,"class")
#> [1] "dgr_graph"
# View the graph in the RStudio Viewer
render_graph(graph)
look into the help of the DiagrammeR package, the website is indeed not up-to-date.
Look at the function create_graph() in the help that shows how the syntax changed.
something like this should do the same:
###
library(DiagrammeR)
# Create a node data frame (ndf) where the labels
# are equivalent to the node ID values (this is not
# recommended); the `label` and `type` node
# attributes will always be a `character` class
# whereas `id` will always be an `integer`
nodes <-
create_node_df(
n = 4,
type = "lower",
label = c("a", "b", "c", "d"),
style = "filled",
fillcolor = "blue",
shape = c("circle", "circle",
"rectangle", "rectangle"),
data = c(3.5, 2.6, 9.4, 2.7))
# Create an edf with additional edge
# attributes (where their classes will
# be inferred from the input vectors)
edges <-
create_edge_df(
from = c(1, 2, 3),
to = c(4, 3, 1),
rel = "leading_to")
# With `create_graph()` we can
# simply create an empty graph (and
# add in nodes and edges later
# with other functions)
graph <-
create_graph(
nodes_df = nodes,
edges_df = edges) %>%
set_edge_attrs(
edge_attr = color,
values = "green") %>%
set_edge_attrs(
edge_attr = arrowsize,
values = 2) %>%
set_node_attrs(
node_attr = fontname,
values = "Helvetica")
graph
render_graph(graph)
The Bad News
For anyone viewing this zombie thread, as of this posting, the information posted on Rich Iannone's documentation page for DiagrammeR is still out of date: http://rich-iannone.github.io/DiagrammeR/graph_creation.html.
The Good News
However, the vignettes for the Diagrammer package contain updated information. As shown in the package vignette named Creating Simple Graphs from NDFs/EDFs, you can view and export GraphViz dot code with a function named generate_dot().
I had produced the following chart, which is created using an xts object.
The code I used was simply
plot(graphTS1$CCLL, type = "l", las = 2, ylab = "(c)\nCC for Investors", xlab = "", main = "Clustering Coefficient at the Investor Level")
I updated my R Studio Package and R version and then by running the same code I got the following chart.
Obviously the two are not the same. Can people help me remove the second Y axis - I do not need that, and remove the automatic heading of 2007-03-01 / 2010-12-01. Numerous attempts of this have failed. I did use zoo.plot but the gridlines and ability and the quarterly marks were removed.
My R version is 3.4.0 (2017-04-21) with the following platform "x86_64-apple-darwin15.6.0". Thanks in advance.
You want to remove the right hand axis. There is an argument in plot.xts(..., yaxis.right = TRUE, ...). So
library('xts')
#> Loading required package: zoo
#>
#> Attaching package: 'zoo'
#> The following objects are masked from 'package:base':
#>
#> as.Date, as.Date.numeric
data(sample_matrix)
sample.xts <- as.xts(sample_matrix, descr='my new xts object')
plot(sample.xts, yaxis.right = FALSE)
does what you want.
I took a stab at solving the second question, removing the label at the top right hand side. Examining the source code for plot.xts() reveals that label is hardcoded into the main title. Even setting main = '' isn't going to remove it. You can work around it by editing plot.xts() and copying it to a new function.
plotxts <- fix("plot.xts")
# In the editor that opens, replace the lines below:
### text.exp <- c(expression(text(xlim[1], 0.5, main, font = 2,
### col = theme$labels, offset = 0, cex = 1.1, pos = 4)),
### expression(text(xlim[2], 0.5, paste(start(xdata[xsubset]),
### end(xdata[xsubset]), sep = " / "), col = theme$labels,
### adj = c(0, 0), pos = 2)))
### cs$add(text.exp, env = cs$Env, expr = TRUE)
# with these lines:
### text.exp <- expression(text(xlim[1], 0.5, main, font = 2,
### col = theme$labels, offset = 0, cex = 1.1, pos = 4))
# Finally, you need to ensure your copy's environment is the xts namespace:
environment(plotxts) <- asNamespace("xts")
plotxts(sample.xts, yaxis.right = FALSE, main = "Main Title")
The second, and perhaps
simpler option is to use a different plot function and modify it to produce the gridlines etc that you want. I will start
with plot.zoo() because it is already handling time series nicely.
zoo::plot.zoo(sample.xts, screens = 1, xlab="", las=2, main="Main Title")
grid() # add the grid
That at least gets the grid on there. I can't test if it will handle the x axis labels the same way without data at the right frequency.
You can now (finally) omit the date range from the plot in xts 0.12.2 on CRAN. Set main.timespan = FALSE.
plot(sample.xts[,1], yaxis.right = FALSE, main = "Main Title", main.timespan = FALSE)