Drawing manually on a figure - r

I have generated a graph:
library(DiagrammeR)
grViz("
digraph boxes_and_circles {
# a 'graph' statement
graph [layout = neato, overlap = true, fontsize = 10, outputorder = edgesfirst]
# several 'node' statements
node [shape = circle,
fontname = Helvetica]
A [pos = '1,1!'];
B [pos = '0,2!'];
C [pos = '1.5,3!'];
D [pos = '2.5,1!'];
E [pos = '4,1!'];
F [pos = '4,2!'];
G [pos = '5,1!'];
H [pos = '6,2!'];
I [pos = '1.5,-0.1!'];
# several 'edge' statements
A->B B->C
D->E D->F E->F E->G F->G G->H F->H
}
")
Which produces:
Now I would like to draw a box with dotted lines around the nodes A, B, and C.
How can I accomplish this in R? A key requirement of the solution is that it is reproducible, i.e. that I can run the script multiple times and get the same result.

Here's another approach based on igraph. It is inspired by this igraph code sample.
I'm assuming that using igraph instead of DiagrammeR is an option - maybe that is not the case...
We leave positioning of the vertices to a standard layout algorithm and query it for the resulting vertex positions. These positions are then used to draw a dotted rectangle around an arbitrary set of "selected" vertices. No user interaction is needed.
We start with the graph topology.
library(igraph)
set.seed(42)
df <- data.frame(from = c('A', 'B', 'I', 'D', 'D', 'E', 'E', 'F', 'F', 'G'),
to = c('B', 'C', 'I', 'E', 'F', 'G', 'F', 'H', 'G', 'H'))
g <- graph.data.frame(df, directed = TRUE)
The size of the vertices and arrows in the graph can be set freely, according to taste.
vertexsize <- 50
arrowsize <- 0.2
We ask the Fruchterman-Reingold layout engine to calculate the coordinates of the vertices.
coords <- layout_with_fr(g)
Then plot the graph.
plot(g,
layout = coords,
vertex.size = vertexsize,
edge.arrow.size = arrowsize,
rescale = FALSE,
xlim = range(coords[,1]),
ylim = range(coords[,2]))
If we like to see what's going on, we can add coordinate axes and print the vertex coordinates:
axis(1)
axis(2)
V(g) # ordered vertex list
coords # coordinates of the vertices (in the same coordinate system as our dotted rectangle)
We now figure out the bounding box of the vertices that we want a rectangle around.
selectedVertices = c("A", "B", "C")
vertexIndices <- sapply(selectedVertices, FUN = function(x) { return(as.numeric(V(g)[x])) } )
llx <- min(coords[vertexIndices, 1])
lly <- min(coords[vertexIndices, 2])
urx <- max(coords[vertexIndices, 1])
ury <- max(coords[vertexIndices, 2])
Almost there. We already have the coordinates of the vertex centers in coords[], but we also need the size of the vertices in the coordinate system of plot(). From the plot.igraph source code we can see that the vertex.size option for plot() gets divided by 200 and then used as radius for drawing the vertex. We use a 50% bigger value as the margin around the bounding box of the vertex coordinates when drawing the dotted rectangle.
margin <- (vertexsize / 200) * 1.5
rect(llx - margin, lly - margin, urx + margin, ury + margin, lty = 'dotted')
This is the result we get:

You could use #StevenBeaupre's solution for the widget, but there are a few packages for graphing networks using R's graphics. One is igraph if you are open to using other solutions.
This will make the graph
library('igraph')
set.seed(11)
g <- data.frame(from = c('A', 'B', 'I', 'D', 'D', 'E', 'E', 'F', 'F', 'G'),
to = c('B', 'C', 'I', 'E', 'F', 'G', 'F', 'H', 'G', 'H'))
(gg <- graph.data.frame(g, directed = TRUE))
plot(gg, vertex.color = 'white')
And there are many ways to add a box to r graphics; here is one where you can click the plot to add the box without having to calculate anything
rekt <- function(...) {
coords <- c(unlist(locator(1)), unlist(locator(1)))
rect(coords[1], coords[2], coords[3], coords[4], ..., xpd = NA)
}
rekt(border = 'red', lty = 'dotted', lwd = 2)
I get this

An easy solution with DiagrammR would be to use dot rather than neato. You mostly lose the ability to manually position the nodes (attribute pos doesn't work anymore), but you gain the ability to use cluster and subgraph to draw lines around sets of nodes.
library(DiagrammeR)
grViz("
digraph boxes_and_circles {
# a 'graph' statement
graph [ fontsize = 10,rankdir=LR]
# several 'node' statements
node [shape = circle,
fontname = Helvetica]
# several 'edge' statements
subgraph cluster_1 {
style=dotted
A->B->C
}
D->E D->F E->F E->G F->G G->H F->H
I
}
")

Related

R igraph cluster nodes with the same colour (feature)

# example data
library(igraph)
links <- cbind.data.frame(from = rep("A", 6),
to = LETTERS[1:6],
weight = rep((1:3), each =2))
nodes <- nodes <- cbind.data.frame(id = LETTERS[1:6],
feature = rep((1:3), each =2))
net <- graph_from_data_frame(d = links, vertices = nodes, directed = T)
V(net)$color <- V(net)$feature
plot(net, vertex.size=30, edge.arrow.size = 0)
This is what I get:
What I want is to cluster the same colored nodes together, something similar as shown in the figure below. How can I do it?
Maybe the option mark.groups in plot could help
plot(net,mark.groups = split(V(net)$name,V(net)$color))
which gives

Error encountered while plotting right half of facial surface mesh in R by subsetting full face vertices and indices data

I have vertices and indices data for human face here. I have a post one year ago on plotting 3D facial surface mesh based on these data. Now, I want to plot only the right half and mid-facial vertices while ignoring the left side vertices. Based on my earlier plot, I tried the following code:
library(tidyverse)
library(readxl)
library(rgl)
vb <- read_excel("...\\vb.xlsx", sheet = "Sheet1", col_names = F)
it <- read_excel("...\\it.xlsx", sheet = "Sheet1", col_names = F)
# Extract vertices for the right side
lm_right_ind <- which(vb[,1] < 0)
vb_mat_right <- t(vb[lm_right_ind, ])
vb_mat_right <- rbind(vb_mat_right, 1)
rownames(vb_mat_right) <- c("xpts", "ypts", "zpts", "")
vertices1_right <- c(vb_mat_right)
# Extract `it` whose rows do not contain vertices on the left side
# Left-side vertices have vb[,1] greater than 0
lm_left_ind <- which(vb[,1] > 0)
leftContain <- NULL
for (i in 1: dim(it)[1]) {
if (T %in% (it[i,] %in% lm_left_ind)) {
leftContain[i] <- i
} else {leftContain[i] <- NA}
}
leftContain <- leftContain[!is.na(leftContain)]
# Remove indices that involve left-side vertices
it_rightMid <- it[-leftContain,]
it_mat_right <- t(as.matrix(it_rightMid))
rownames(it_mat_right) <- NULL
indices_right <- c(it_mat_right)
# Plot
try1_right <- tmesh3d(vertices = vertices1_right, indices = indices_right, homogeneous = TRUE,
material = NULL, normals = NULL, texcoords = NULL)
# Use addNormals to smooth the plot. See my Stackoverflow question:
# https://stackoverflow.com/questions/53918849/smooth-3d-trangular-mesh-in-r
try12_right <- addNormals(try1_right)
shade3d(try12_right, col="#add9ec", specular = "#202020", alpha = 0.8)
I got an error whing trying to obtain try12_right:
Error in v[, it[3, i]] : subscript out of bounds.
I did exactly as what I did in my earlier plot but why something went wrong here? Thank you.
Here's an example of using a clipping plane to leave off the left hand side of a mesh object:
library(rgl)
open3d()
root <- currentSubscene3d()
newSubscene3d("inherit", "inherit", "inherit", parent = root) # Clipping limited to this subscene
shade3d(addNormals(subdivision3d(icosahedron3d(), 2)), col = "pink")
clipplanes3d(a = 1, b = 0, c = 0, d = 0)
useSubscene3d(root)
decorate3d()
The fiddling with subscenes limits the clipping to just the shaded sphere, not everything else in the picture.
This produces this output:
If there's nothing else there, it's simpler:
library(rgl)
open3d()
shade3d(addNormals(subdivision3d(icosahedron3d(), 2)), col = "pink")
clipplanes3d(a = 1, b = 0, c = 0, d = 0)
which produces

How to union 2 intersecting polygons receiving 2 single polygons

How to union intersecting polygons (perfect circles) like in the following picture:
So far, I used rgeos and sf, but couldnĀ“t identiy a simple way yet.
library(rgeos)
library(sp)
pts <- SpatialPoints(cbind(c(2,3), c(1,1)))
plot(pts)
pol <- gBuffer(pts, width=0.6, byid=TRUE)
plot(pol)
# Ege Rubak provided the hint to create a convex hull around the differences of circles. with rgeos the solution looks like foollowing code.
However, I struggle receiving the solution in a single step.
gSym1 <- gDifference(pol[1,],pol[2,])
gch1 <- gConvexHull(gSym1)
gSym2 <- gDifference(pol[2,],pol[1,])
gch2 <- gConvexHull(gSym2)
plot(gch1)
plot(gch2, add=TRUE)
I must agree with #Spacedman that your question could use a lot more
detail about the problem. Below is a quick approach for two circles
using spatstat. Packages as sf, sp, etc. surely have the same capabilities.
Two overlapping (polygonal appoximations of) discs in a box:
library(spatstat)
A <- disc()
B <- shift(A, vec = c(1.6,0))
box <- boundingbox(union.owin(A,B))
plot(box, main = "")
B <- shift(A, vec = c(1.6,0))
colA <- rgb(1,0,0,.5)
colB <- rgb(0,1,0,.5)
plot(A, col = colA, add = TRUE, border = colA)
plot(B, col = colB, add = TRUE, border = colB)
Set differences:
AnotB <- setminus.owin(A, B)
BnotA <- setminus.owin(B, A)
plot(box, main = "")
plot(AnotB, col = colA, add = TRUE, border = colA)
plot(BnotA, col = colB, add = TRUE, border = colB)
Convex hulls of set differences:
AA <- convexhull(AnotB)
BB <- convexhull(BnotA)
plot(box, main = "")
plot(AA, col = colA, add = TRUE, border = colA)
plot(BB, col = colB, add = TRUE, border = colB)
If you want to find the intersection points:
edgesA <- edges(A)
edgesB <- edges(B)
x <- crossing.psp(edgesA,edgesB)
plot(box, main = "")
plot(A, col = colA, add = TRUE, border = colA)
plot(B, col = colB, add = TRUE, border = colB)
plot(x, add = TRUE, pch = 20, col = "blue", cex = 3)

R visNetwork: create new type of edges

I want to create a PAG(parental ancestral graph) with visNetwork for my shiny app.
In order to do that i have to create edges that have both circles and arrows.
According to the visNetwork package i can convert the arrows to circles like this
visNetwork(nodes, edges) %>%
visEdges(arrows = list(to = list(enabled = TRUE,
scaleFactor = 2, type = 'circle')))
But i want to have both an arrow and a circle, or two circles in one edge like in this picture
PAG
The arrows.from.type and arrows.to.type seem to be working but i now i have this problem.
I want to draw this graph according to an adjacency matrix
So i have this code
i = 1
j = 1
for(i in i:ncol(results))
{
j = i
for(j in j:nrow(results))
{
if(results[j,i]==1)
{
dashBoard = c(dashBoard,TRUE)
colorBoard = c(colorBoard, "green")
if(results[i,j]==1)
{
fromtest <- c(fromtest,Cnames[i])
totest <- c(totest,Rnames[j])
arrfrom <-c(arrfrom,"circle")
arrto<-c(arrto,"circle")
}
else if(results[i,j]==2)
{
fromtest<-c(fromtest,Cnames[i])
totest<-c(totest,Rnames[j])
arrfrom <-c(arrfrom,"circle")
arrto<-c(arrto,"arrow")
}}
That goes on for every possible combination except 1,1 and 1,2
In the end the edges are printed like that
edgesprint <-data.frame(from = fromtest,
to = totest,
arrows.from.type=arrfrom,
arrows.to.type=arrto,
dashes = dashBoard,
physics = FALSE,
smooth = FALSE,
width = 3,
shadow = TRUE,
color = list(color = colorBoard, highlight = "red", hover = "green"),
links = links)
This method works good but sometimes without changing any code i get this error
error in data.frame arguments imply differing number of rows
You can set individual arrow types in the edges data frame by adding columns arrows.to.type and arrows.from.type:
library(visNetwork)
library(magrittr)
nodes <- data.frame(id=c("a","b","c","d"), label=c("a","b","c","d"))
edges <- data.frame(
from = c("a","a","a"),
to = c("b","c","d"),
arrows.from.type = c(NA,"circle","circle"),
arrows.to.type = c("arrow","circle",NA)
)
visNetwork(nodes, edges)
Result:
This approach works for all other attributes you can set through visNodes and visEdges. See here for an example.

Show edge attributes as label with igraph

I am using igraph in R for network analysis. I want to display an edge attribute on each line in the plot. An example is below
df <- data.frame(a = c(0,1,2,3,4),b = c(3,4,5,6,7))
nod <- data.frame(node = c(0:7),wt = c(1:8))
pg <- graph_from_data_frame(d = df, vertices = nod,directed = F)
plot(pg)
I want the value of the "wt" feature to show up between each node on the line, or preferably, in a little gap where the line breaks.
Is it possible to make this happen?
Use the parameter edge.label to assign labels of the edges, I used - probably wrong - nod$wt. Of course, you could assign other labels.
You could use the following code:
# load the package
library(igraph)
# your code
df <- data.frame(a = c(0,1,2,3,4),b = c(3,4,5,6,7))
nod <- data.frame(node = c(0:7),wt = c(1:8))
pg <- graph_from_data_frame(d = df, vertices = nod,directed = F)
# plot function with edge.label added
plot(pg, edge.label = nod$wt)
Please, let me know whether this is what you want.

Resources