How to union 2 intersecting polygons receiving 2 single polygons - r

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)

Related

Interactively identify 3D object in rgl plot

I want to identify 3d cylinders in an rgl plot to obtain one attribute of the nearest / selected cylinder. I tried using labels to simply spell out the attribute, but I work on data with more than 10.000 cylinders. Therefore, it gets so crowded that the labels are unreadable and it takes ages to render.
I tried to understand the documentation of rgl and I guess the solution to my issue is selecting the cylinder in the plot manually. I believe the function selectpoints3d() is probably the way to go. I believe it returns all vertices within the drawn rectangle, but I don't know how to go back to the cylinder data? I could calculate which cylinder is closest to the mean of the selected vertices, but this seems like a "quick & dirty" way to do the job.
Is there a better way to go? I noticed the argument value=FALSE to get the indices only, but I don't know how to go back to the cylinders.
Here is some dummy data and my code:
# dummy data
cylinder <- data.frame(
start_X = rep(1:3, 2)*2,
start_Y = rep(1:2, each = 3)*2,
start_Z = 0,
end_X = rep(1:3, 2)*2 + round(runif(6, -1, 1), 2),
end_Y = rep(1:2, each = 3)*2 + round(runif(6, -1, 1), 2),
end_Z = 0.5,
radius = 0.25,
attribute = sample(letters[1:6], 6)
)
# calculate centers
cylinder$center_X <- rowMeans(cylinder[,c("start_X", "end_X")])
cylinder$center_Y <- rowMeans(cylinder[,c("start_Y", "end_Y")])
cylinder$center_Z <- rowMeans(cylinder[,c("start_Z", "end_Z")])
# create cylinders
cylinder_list <- list()
for (i in 1:nrow(cylinder)) {
cylinder_list[[i]] <- cylinder3d(
center = cbind(
c(cylinder$start_X[i], cylinder$end_X[i]),
c(cylinder$start_Y[i], cylinder$end_Y[i]),
c(cylinder$start_Z[i], cylinder$end_Z[i])),
radius = cylinder$radius[i],
closed = -2)
}
# plot cylinders
open3d()
par3d()
shade3d(shapelist3d(cylinder_list, plot = FALSE), col = "blue")
text3d(cylinder$center_X+0.5, cylinder$center_Y+0.5, cylinder$center_Z+0.5, cylinder$attribute, color="red")
# get attribute
nearby <- selectpoints3d(value=TRUE, button = "right")
nearby <- colMeans(nearby)
cylinder$dist <- sqrt(
(nearby["x"]-cylinder$center_X)**2 +
(nearby["y"]-cylinder$center_Y)**2 +
(nearby["z"]-cylinder$center_Z)**2)
cylinder$attribute[which.min(cylinder$dist)]
If you call selectpoints3d(value = FALSE), you get two columns. The first column is the id of the object that was found. Your cylinders get two ids each. One way to mark the cylinders is to use "tags". For example, this modification of your code:
# dummy data
cylinder <- data.frame(
start_X = rep(1:3, 2)*2,
start_Y = rep(1:2, each = 3)*2,
start_Z = 0,
end_X = rep(1:3, 2)*2 + round(runif(6, -1, 1), 2),
end_Y = rep(1:2, each = 3)*2 + round(runif(6, -1, 1), 2),
end_Z = 0.5,
radius = 0.25,
attribute = sample(letters[1:6], 6)
)
# calculate centers
cylinder$center_X <- rowMeans(cylinder[,c("start_X", "end_X")])
cylinder$center_Y <- rowMeans(cylinder[,c("start_Y", "end_Y")])
cylinder$center_Z <- rowMeans(cylinder[,c("start_Z", "end_Z")])
# create cylinders
cylinder_list <- list()
for (i in 1:nrow(cylinder)) {
cylinder_list[[i]] <- cylinder3d(
center = cbind(
c(cylinder$start_X[i], cylinder$end_X[i]),
c(cylinder$start_Y[i], cylinder$end_Y[i]),
c(cylinder$start_Z[i], cylinder$end_Z[i])),
radius = cylinder$radius[i],
closed = -2)
# Add tag here:
cylinder_list[[i]]$material$tag <- cylinder$attribute[i]
}
# plot cylinders
open3d()
par3d()
shade3d(shapelist3d(cylinder_list, plot = FALSE), col = "blue")
text3d(cylinder$center_X+0.5, cylinder$center_Y+0.5, cylinder$center_Z+0.5, cylinder$attribute, color="red")
# Don't get values, get the ids
nearby <- selectpoints3d(value=FALSE, button = "right", closest = FALSE)
ids <- nearby[, "id"]
# Convert them to tags. If you select one of the labels, you'll get
# a blank in the list of tags, because we didn't tag the text.
unique(tagged3d(id = ids))
When I was trying this, I found that using closest = TRUE in selectpoints3d seemed to get too many ids; there may be a bug there.

How to shorten code for "visRemoveNodes" using loop in rstudio

I have constructed multiple protein - protein networks for diseases in shiny app and I ploted them using visnetwork. I found the articulation points for each network and I want to remove them.
My code for a disease looks like this:
output$plot54 <- renderVisNetwork({
alsex <- as.matrix(alsex)
sel1 <- alsex[,1]
sel2 <- alsex[,2]
n10 <- unique(c(sel1,sel2))
n10 <- as.data.frame(n10)
colnames(n10) <- "id"
ed10 <- as.data.frame(alsex)
colnames(ed10) <- c("from", "to", "width")
n10
g <- graph_from_data_frame(ed10)
articulation.points(g)
nodes4 <- data.frame(n10, color = ifelse(n10$id=="CLEC4E"|n10$id=="ACE2"|n10$id=="MYO7A"|n10$id=="HSPB4"
|n10$id=="EXOSC3"|n10$id=="RBM45"|n10$id=="SPAST"|n10$id=="ALMS1"|n10$id=="PIGQ"
|n10$id=="CDC27"|n10$id=="GFM1"|n10$id=="UTRN"|n10$id=="RAB7B"|n10$id=="GSN"|n10$id=="VAPA"|n10$id=="GLE1"
|n10$id=="FA2H"|n10$id=="HSPA4"|n10$id=="SNCA"|n10$id=="RAB5A"|n10$id=="SETX","red","blue"))
visNetwork(nodes4, ed10, main = "Articulation Points") %>%
visNodes (color = list(highlight = "pink"))%>%
visIgraphLayout()%>%
visOptions(highlightNearest = list(enabled = T, hover = T),
nodesIdSelection = T)%>%
visInteraction(keyboard = TRUE)
})
observe({
input$delete54
visNetworkProxy("plot54") %>%
visRemoveNodes(id="CLEC4E")%>%visRemoveEdges(id = "CLEC4E")%>%
visRemoveNodes(id="ACE2")%>%visRemoveEdges(id = "ACE2")%>%
visRemoveNodes(id="MYO7A")%>%visRemoveEdges(id = "MYO7A")%>%
visRemoveNodes(id="HSPB4")%>%visRemoveEdges(id = "HSPB4")%>%
visRemoveNodes(id="EXOSC3")%>%visRemoveEdges(id = "EXOSC3")%>%
visRemoveNodes(id="RBM45")%>%visRemoveEdges(id = "RBM45")%>%
visRemoveNodes(id="SPAST")%>%visRemoveEdges(id = "SPAST")%>%
visRemoveNodes(id="ALMS1")%>%visRemoveEdges(id = "ALMS1")%>%
visRemoveNodes(id="PIGQ")%>%visRemoveEdges(id = "PIGQ")%>%
visRemoveNodes(id="CDC27")%>%visRemoveEdges(id = "CDC27")%>%
visRemoveNodes(id="GFM1")%>%visRemoveEdges(id = "GFM1")%>%
visRemoveNodes(id="UTRN")%>%visRemoveEdges(id = "UTRN")%>%
visRemoveNodes(id="RAB7B")%>%visRemoveEdges(id = "RAB7B")%>%
visRemoveNodes(id="GSN")%>%visRemoveEdges(id = "GSN")%>%
visRemoveNodes(id="VAPA")%>%visRemoveEdges(id = "VAPA")%>%
visRemoveNodes(id="GLE1")%>%visRemoveEdges(id = "GLE1")%>%
visRemoveNodes(id="FA2H")%>%visRemoveEdges(id = "FA2H")%>%
visRemoveNodes(id="HSPA4")%>%visRemoveEdges(id = "HSPA4")%>%
visRemoveNodes(id="SNCA")%>%visRemoveEdges(id = "SNCA")%>%
visRemoveNodes(id="RAB5A")%>%visRemoveEdges(id = "RAB5A")%>%
visRemoveNodes(id="SETX")%>%visRemoveEdges(id = "SETX")
})
Using
g <- graph_from_data_frame(ed10)
articulation.points(g)
I found the articulation points, and I marked them with red color using ifelse as you can see in nodes4 vector.
My questions:
How to shorten my code in ifelse using loop, so I don't have to write the articullation points one by one manually.
How to shorten my code in visRemoveNodes and visRemoveEdges using loop, so I don't have to write them one by one manually as well.
Crossed posted at:
https://community.rstudio.com/t/how-to-shorten-code-for-visremovenodes-using-loop/72506
The answer for the second question is:
observe({
l <- c("CLEC4E","ACE2", "MYO7A", "HSPB4", "EXOSC3", "RBM45","SPAST","ALMS1",
"PIGQ","CDC27","GFM1","UTRN",
"RAB7B", "GSN", "VAPA", "GLE1","FA2H","HSPA4",
"SNCA","RAB5A","SETX") #we put all genes that we want to delete in a vector
for (i in l){
input$delete54
visNetworkProxy("plot54")%>%
visRemoveNodes(id= i)%>%visRemoveEdges(id = i)
}
})

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

Outputting a list of the intersecting genes/Values when making a VennDiagram in R with the VennDiagram package

I made a VennDiagram with five intersecting vectors, each containing a set of gene names.
Does anyone know whether I can somehow export the list of genes, which overlap in the different intersections?
I know I can do that with several online tools, such as Venny or InteractiVenn, but it would be much more convenient in R.
This is the code I use:
venn.diagram(
x = list(set1, set2, set3, set4, set5),
category.names = c("set1", "set2", "set3", "set4", "set5"),
filename= "my_path/venn.png",
output=NULL,
# # Output features
imagetype="png" ,
height = 2000 ,
width = 2000 ,
units = "px",
na = 'stop',
resolution = 300,
compression = "lzw",
lwd = 2,
col = c("#1ABC9C", "#85C1E9", "#CD6155", "#5B2C6F", "#F8C471"),
cat.col = c("#1ABC9C", "#85C1E9", "#CD6155", "#5B2C6F", "#F8C471"),
fill = c(alpha("#1ABC9C",0.3), alpha("#85C1E9",0.3), alpha("#CD6155",0.3), alpha("#5B2C6F",0.3), alpha("#F8C471",0.3)),
cex = 1.5,
fontfamily = "sans",
cat.cex = 1.15,
cat.default.pos = "text",
cat.fontfamily = "sans",
cat.dist= c(0.055),
cat.pos= c(1)
)
Thanks!
I suspect the OP has moved on, but I had the same question.
Here's what I came up with for a five set example- NB this uses a different package:
require(nVennR)
require(dplyr)
# wrangle input
Venn <- plotVenn(list("set1"=set1, "set2"=set2, "set3"=set3, "set4"=set4,
"set5"=set5), outFile = "DataSourceVenn.svg") # produces associated diagram
# generate lists of each intersect
intersects <- listVennRegions(Venn)
# pull lists together
intersects <- plyr::ldply(intersects, cbind)
# insert own appropriate col name for V1
colnames(intersects)<-c('Intersect','V1')
# transpose data into columns for each intersect
intersects <- dcast(setDT(intersects), rowid(Intersect) ~ Intersect, value.var =
"V1")[,Intersect:=NULL]

How to add an additional single column heatmap at the side of main heatmap in R

I have the following scripts:
library("gplots")
mydata <- mtcars
mydata.nr <- nrow(mydata)
mydata.newval <- data.frame(row.names=rownames(mydata),new.val=-log(runif(mydata.nr)))
# Functions
hclustfunc <- function(x) hclust(x, method="complete")
distfunc <- function(x) dist(x,method="euclidean")
# Set colors
hmcols <- rev(redgreen(256));
# Plot the scaled data
heatmap.2(as.matrix(mydata),dendrogram="row",scale="row",col=hmcols,trace="none", margin=c(8,9), hclust=hclustfunc,distfun=distfunc);
Which generate the following heatmap:
Now given a new data.frame which contain new values for each cars:
mydata.nr <- nrow(mydata)
mydata.newval <- data.frame(row.names=rownames(mydata),new.val=-log(runif(mydata.nr)))
I want to create a single column heatmap with gradient gray positioned next to row names.
How can I achieve that in R heatmap.2?
Does this do what you want? You can use the RowSideColors option to add a column to the side of the heatmap.
new.vals = mydata.newval[,1]
mydata.newval$scaled = ( new.vals - min(new.vals) ) /
( max(new.vals) - min(new.vals) )
mydata.newval$gray = gray( mydata.newval$scaled )
heatmap.2( as.matrix(mydata),
dendrogram = "row", scale = "row",
col = hmcols, trace = "none",
margin = c(8,9),
hclust = hclustfunc, distfun = distfunc,
RowSideColors=mydata.newval$gray )
If you want the gray column in between the heatmap and the labels, there isn't a simple
way to do that with heatmap.2; I don't think it was designed for
such purposes. One way to hack it together would be to make the gray values
go from 10 to 11 (or something out of the range of the rest of the data). Then
you would change the colors mapped to the breaks (see here). However, this
would make your key look pretty funky.
# heatmap.2 does the clustering BEFORE the scaling.
# Clustering after scaling might give different results
# heatmap.2 also reorders the dendrogram according to rowMeans.
# (Code copied directly from the heatmap.2 function)
x = as.matrix(mydata)
Rowv = rowMeans(x, na.rm = TRUE)
hcr = hclustfunc(distfunc(x))
ddr = as.dendrogram(hcr)
ddr = reorder(ddr, Rowv) # the row dendrogram
# Scale the data as heatmap.2 does
rm = rowMeans(x, na.rm = TRUE)
x = sweep(x, 1, rm)
sx = apply(x, 1, sd, na.rm = TRUE)
x = sweep(x, 1, sx, "/")
# add the new data as a column
new.vals = mydata.newval[,1]
new.vals.scaled = ( new.vals - min(new.vals) ) /
( max(new.vals) - min(new.vals) ) # scaled from 0 to 1
x = cbind( x, gray = max(x) + new.vals.scaled + 0.1 )
# make the custom breaks and colors
edge = max(abs(x-1.1))
breaks = seq(-edge,edge+1.1,length.out=1000)
gradient1 = greenred( sum( breaks[-length(breaks)] <= edge ) )
gradient2 = colorpanel( sum( breaks[-length(breaks)] > edge ), "white", "black" )
hm.colors = c(gradient1,gradient2)
hm = heatmap.2( x, col=hm.colors, breaks=breaks,
scale="none",
dendrogram="row", Rowv=ddr,
trace="none", margins=c(8,9) )
Although this hack works, I would look for a more robust solution using more flexible packages that play with different viewports using the grid package.

Resources