R - Plot a region described by planes with rgl - r

I want to plot a polyhedron, which is described by the following inequalities:
3*x+5*y+9*z<=500
4*x+5*z<=350
2*y+3*z<=150
x,y,z>=0
It is a linear program. The objective function is:
4*x+3*y+6*z
The polyhedron is the feasible region for this program.
I am able to plot the inequalities as planes, which should describe the polyhedron
(Note that this is my first try with rgl, so the code is kinda messy. if you want to improve it, please feel free to do so):
# setup
x <- seq(0,9,length=20)*seq(0,9,length=20)
y <- x
t <- x
f1 <- function(x,y){y=70-0.8*x}
z1 <- outer(x,y,f1)
f2 <- function(x,y){500/9-x/3-(5*y)/9}
z2 <- outer(x,y,f2)
f3 <- function(x,y){t=50-(2*y)/3}
z3 <- outer(x,y,f3)
# plot planes with rgl
uM = matrix(c(0.72428817, 0.03278469, -0.68134511, 0,
-0.6786808, 0.0555667, -0.7267077, 0,
0.01567543, 0.99948466, 0.05903265, 0,
0, 0, 0, 1),
4, 4)
library(rgl)
open3d(userMatrix = uM, windowRect = c(0, 0, 400, 400))
rgl.pop("lights")
light3d(diffuse='white',theta=0,phi=20)
light3d(diffuse="gray10", specular="gray25")
rgl.light(theta = 0, phi = 0, viewpoint.rel = TRUE, ambient = "#FFFFFF",
diffuse = "#FFFFFF", specular = "#FFFFFF", x=30, y=30, z=40)
rgl.light(theta = 0, phi = 0, viewpoint.rel = TRUE, ambient = "#FFFFFF",
diffuse = "#FFFFFF", specular = "#FFFFFF", x=0, y=0, z=0)
bg3d("white")
material3d(col="white")
persp3d(x,y,z3,
xlim=c(0,100), ylim=c(0,100), zlim=c(0,100),
xlab='x', ylab='y', zlab='z',
col='lightblue',
ltheta=100, shade=0, ticktype = "simple")
surface3d(x, y, z2, col='orange', alpha=1)
surface3d(t, y, z1, col='pink', alpha=1, smooth=TRUE)
Now I want to plot the region that is described by the planes with
x,y,z>=0.
But I don't know how to do it. I tried to do it like this:
x <- seq(0,9,length=20)*seq(0,9,length=20)
y <- x
z <- x
f4 <- function(x,y,t){
cond1 <- 3*x+5*y+9*z<=500
cond2 <- 4*x+5*z<=350
cond3 <- 2*y+3*z<=150
ifelse(cond1, 3*x+5*y+9*z,
ifelse(cond2, 4*x+5*z,
ifelse(cond3, 2*y+3*z,0)))
}
f4(x,y,z)
z4 <- outer(x,y,z,f4) # ERROR
But this is the point where I'm stuck. outer() is defined only for 2 variables, but I have three. How can I move on from here?

You can compute the vertices of the polyhedron by intersecting the planes 3 at a time
(some of the intersections are outside the polyhedron, because of other inequalities:
you have to check those as well).
Once you have the vertices, you can try to connect them.
To identify which are on the boundary, you can take the middle of the segment,
and check if any inequality is satisfied as an equality.
# Write the inequalities as: planes %*% c(x,y,z,1) <= 0
planes <- matrix( c(
3, 5, 9, -500,
4, 0, 5, -350,
0, 2, 3, -150,
-1, 0, 0, 0,
0, -1, 0, 0,
0, 0, -1, 0
), nc = 4, byrow = TRUE )
# Compute the vertices
n <- nrow(planes)
vertices <- NULL
for( i in 1:n )
for( j in 1:n)
for( k in 1:n )
if( i < j && j < k ) try( {
# Intersection of the planes i, j, k
vertex <- solve(planes[c(i,j,k),-4], -planes[c(i,j,k),4] )
# Check that it is indeed in the polyhedron
if( all( planes %*% c(vertex,1) <= 1e-6 ) ) {
print(vertex)
vertices <- rbind( vertices, vertex )
}
} )
# For each pair of points, check if the segment is on the boundary, and draw it
library(rgl)
open3d()
m <- nrow(vertices)
for( i in 1:m )
for( j in 1:m )
if( i < j ) {
# Middle of the segment
p <- .5 * vertices[i,] + .5 * vertices[j,]
# Check if it is at the intersection of two planes
if( sum( abs( planes %*% c(p,1) ) < 1e-6 ) >= 2 )
segments3d(vertices[c(i,j),])
}

Related

How to rotate nodes of a time-calibrated phylogenetic tree to match a particular order in R?

I have a time-calibrated phylogenetic tree from BEAST and I would like to make a figure in which its nodes are rotated to match an arbitrary ordering. The following code works perfectly to plot the tree with the nodes in the order they are in the input file.
library("phytools")
library("phyloch")
library("strap")
library("coda")
t <- read.beast("mcctree.tre") # I couldn't upload the file here
t$root.time <- t$height[1]
num_taxa <- length(t$tip.label)
display_all_node_bars <- TRUE
names_list <-vector()
for (name in t$tip){
v <- strsplit(name, "_")[[1]]
if(display_all_node_bars){
names_list = c(names_list, name)
}
else if(v[length(v)]=="0"){
names_list = c(names_list, name)
}
}
nids <- vector()
pos <- 1
len_nl <- length(names_list)
for(n in names_list){
for(nn in names_list[pos:len_nl]){
if(n != nn){
m <- getMRCA(t,c(n, nn))
if(m %in% nids == FALSE){
nids <- c(nids, m)
}
}
}
pos <- pos+1
}
pdf("tree.pdf", width = 20, height = 20)
geoscalePhylo(tree = t,
x.lim = c(-2,21),
units = c("Epoch"),
tick.scale = "myr",
boxes = FALSE,
width = 1,
cex.tip = 2,
cex.age = 3,
cex.ts = 2,
erotate = 0,
label.offset = 0.1)
lastPP <- get("last_plot.phylo", envir = .PlotPhyloEnv)
for(nv in nids){
bar_xx_a <- c(lastPP$xx[nv]+t$height[nv-num_taxa]-t$"height_95%_HPD_MIN"[nv-num_taxa],
lastPP$xx[nv]-(t$"height_95%_HPD_MAX"[nv-num_taxa]-t$height[nv-num_taxa]))
lines(bar_xx_a, c(lastPP$yy[nv], lastPP$yy[nv]), col = rgb(0, 0, 1, alpha = 0.3), lwd = 12)
}
t$node.label <- t$posterior
p <- character(length(t$node.label))
p[t$node.label >= 0.95] <- "black"
p[t$node.label < 0.95 & t$node.label >= 0.75] <- "gray"
p[t$node.label < 0.75] <- "white"
nodelabels(pch = 21, cex = 1.5, bg = p)
dev.off()
The following code is my attempt to rotate the nodes in the way I want (following this tutorial: http://blog.phytools.org/2015/04/finding-closest-set-of-node-rotations.html). And it works for rotating the nodes. However, the blue bars indicating the confidence intervals of the divergence time estimates get out of their correct place - this is what I would like help to correct. This will be used in much larger files with hundreds of branches - the example here is simplified.
new.order <- c("Sp8","Sp9","Sp10","Sp7","Sp6","Sp5","Sp4","Sp2","Sp3","Ou1","Ou2","Sp1")
t2 <- setNames(1:Ntip(t), new.order)
new.order.tree <- minRotate(t, t2)
new.order.tree$root.time <- t$root.time
new.order.tree$height <- t$height
new.order.tree$"height_95%_HPD_MIN" <- t$"height_95%_HPD_MIN"
new.order.tree$"height_95%_HPD_MAX" <- t$"height_95%_HPD_MAX"
pdf("reordered_tree.pdf", width = 20, height = 20)
geoscalePhylo(tree = new.order.tree,
x.lim = c(-2,21),
units = c("Epoch"),
tick.scale = "myr",
boxes = FALSE,
width = 1,
cex.tip = 2,
cex.age = 3,
cex.ts = 2,
erotate = 0,
label.offset = 0.1)
lastPP <- get("last_plot.phylo", envir = .PlotPhyloEnv)
for(nv in nids){
bar_xx_a <- c(lastPP$xx[nv]+new.order.tree$height[nv-num_taxa]-new.order.tree$"height_95%_HPD_MIN"[nv-num_taxa],
lastPP$xx[nv]-(new.order.tree$"height_95%_HPD_MAX"[nv-num_taxa]-new.order.tree$height[nv-num_taxa]))
lines(bar_xx_a, c(lastPP$yy[nv], lastPP$yy[nv]), col = rgb(0, 0, 1, alpha = 0.3), lwd = 12)
}
new.order.tree$node.label <- t$posterior
p <- character(length(new.order.tree$node.label))
p[new.order.tree$node.label >= 0.95] <- "black"
p[new.order.tree$node.label < 0.95 & new.order.tree$node.label >= 0.75] <- "gray"
p[new.order.tree$node.label < 0.75] <- "white"
nodelabels(pch = 21, cex = 1.5, bg = p)
dev.off()
I've found several similar questions here and in other forums, but none dealing specifically with time-calibrated trees - which is the core of the problem described above.
The short answer is that phyTools::minRotate() doesn't recognize the confidence intervals as associated with nodes. If you contact the phyTools maintainers, they may well be able to add this functionality quite easily.
Meanwhile, you can correct this yourself.
I don't know how read.beast() saves confidence intervals – let's say they're saved in t$conf.int. (Type unclass(t) at the R command line to see the full structure; you should be able to identify the appropriate property.)
If the tree's node labels are unique, then you can infer the new sequence of nodes using match():
library("phytools")
new.order <- c("Sp8","Sp9","Sp10","Sp7","Sp6","Sp5","Sp4","Sp2","Sp3","Ou1","Ou2","Sp1")
# Set up a fake initial tree -- you would load the tree from a file
tree <- rtree(length(new.order))
tree$tip.label <- sort(new.order)
tree$node.label <- seq_len(tree$Nnode)
tree$conf.int <- seq_len(tree$Nnode) * 10
# Plot tree
par(mfrow = c(1, 2), mar = rep(0, 4), cex = 0.9) # Create space
plot(tree, show.node.label = TRUE)
nodelabels(tree$conf.int, adj = 1) # Annotate "correct" intervals
# Re-order nodes with minRotate
noTree <- minRotate(tree, setNames(seq_along(new.order), new.order))
plot(noTree, show.node.label = TRUE)
# Move confidence intervals to correct node
tree$conf.int <- tree$conf.int[match(noTree$node.label, tree$node.label)]
nodelabels(tree$conf.int, adj = 1)
If you can't guarantee that the node labels are unique, you can always overwrite them in a temporary object:
# Find node order
treeCopy <- tree
treeCopy$node.label <- seq_len(tree$Nnode)
nodeOrder <- match(minRotate(treeCopy)$node.label, treeCopy$node.label)
# Apply node order
tree$conf.int <- tree$conf.int[nodeOrder]

How to compute nearest distance between points?

This is a tmp set of points with (x, y) coordinates and 0 or 1 categories.
tmp <- structure(list(cx = c(146.60916, 140.31737, 145.92917, 167.57799,
166.77618, 137.64381, 172.12157, 175.32881, 175.06154, 135.50566,
177.46696, 148.06731), cy = c(186.29814, 180.55231, 210.6084,
210.34111, 185.48505, 218.89375, 219.69554, 180.67421, 188.15775,
209.27205, 209.27203, 178.00151), category = c(1, 0, 1, 1, 1,
0, 0, 0, 0, 0, 0, 0)), class = "data.frame", row.names = c(NA,
-12L))
I need to find the minimum spanning tree for category = 1 points, then to join (add edge) each point with category = 0 to its nearest category = 1 point.
The minimum spanning tree is built on points with the category = 1.
ones <- tmp[tmp$category == 1,]
n <- dim(ones)[1]
d <- matrix(0, n, n)
d <- as.matrix(dist(cbind(ones$cx, ones$cy)))
g1 <- graph.adjacency(d, weighted=TRUE, mode="undirected")
V(g1)$name <- tmp[tmp$category == 1,]$Name
mylayout = as.matrix(cbind(ones$cx, -ones$cy))
mst <- minimum.spanning.tree(g1) # Find a minimum spanning tree
plot(mst, layout=mylayout,
vertex.size = 10,
vertex.label = V(g1)$name,
vertex.label.cex =.75,
edge.label.cex = .7,
)
Expected result is in center of figure.
My current attempt is:
n <- dim(tmp)[1]
d <- matrix(0, n, n)
d <- as.matrix(dist(cbind(tmp$cx, tmp$cy)))
d[tmp$category %*% t(tmp$category) == 1] = Inf
d[!sweep(d, 2, apply(d, 2, min), `==`)] <- 0
g2 <- graph.adjacency(d, weighted=TRUE, mode="undirected")
mylayout = as.matrix(cbind(tmp$cx, -tmp$cy))
V(g2)$name <- tmp$Name
plot(g2, layout=mylayout,
vertex.size = 10,
vertex.label = V(g2)$name,
vertex.label.cex =.75,
edge.label = round(E(g2)$weight, 3),
edge.label.cex = .7,
)
One can see that I have found the minimum dist and add one edge only.
Question. How to define condition for all possible points?
You can try the code below
# two categories of point data frames
pts1 <- subset(tmp, category == 1)
pts0 <- subset(tmp, category == 0)
# generate minimum spanning tree `gmst`
gmst <- mst(graph_from_adjacency_matrix(as.matrix(dist(pts1[1:2])), mode = "undirected", weighted = TRUE))
# distance matrix between `pts0` and `pts1`
pts0_pts1 <- as.matrix(dist(tmp[1:2]))[row.names(pts0), row.names(pts1)]
# minimum distances of `pts0` to `pts1`
idx <- max.col(-pts0_pts1)
df0 <- data.frame(
from = row.names(pts0),
to = row.names(pts1)[idx],
weight = pts0_pts1[cbind(1:nrow(pts0), idx)]
)
# aggregate edges lists and produce final result
g <- graph_from_data_frame(rbind(get.data.frame(gmst), df0), directed = FALSE) %>%
set_vertex_attr(name = "color", value = names(V(.)) %in% names(V(gmst)))
mylayout <- as.matrix(tmp[names(V(g)), 1:2]) %*% diag(c(1, -1))
plot(g, edge.label = round(E(g)$weight, 1), layout = mylayout)
and you will get

R function to plot inequalities with shading

Suppose I have a set of inequalities:
-2x + y <= -3
1.25x + y <= 2.5
y >= -3
And I can summarize the information as follows:
mat <- matrix(c(-2, 1, 1.25, 1, 0, 1), nrow = 3, byrow = TRUE)
dir <- c("<=", "<=", ">=")
rhs <- c(-3, 2.5, -3)
I wrote the following function to plot the inequalities:
plot(0, 0, xlim = c(-1, 5), ylim = c(-4, 1))
plot_ineq <- function(mat, dir, rhs, xlow, xhigh){
line <- list()
for(i in 1:nrow(mat)){
if(mat[i, 2] > 0){
line[[i]] <- sapply(seq(xlow, xhigh, 0.1), function(x) (rhs[i] - mat[i, 1] * x)/mat[i, 2])
}else if(mat[i, 2] < 0){
line[[i]] <- sapply(seq(xlow, xhigh, 0.1), function(x) (rhs[i] - mat[i, 1] * x)/mat[i, 2])
if(dir[i] == ">="){
dir[i] = "<="
}else dir[i] = ">="
}
lines(seq(xlow, xhigh, 0.1), line[[i]])
}
}
plot_ineq(mat = mat, dir = dir, rhs = rhs, xlow = -1, xhigh = 5)
I have two questions: (1) how can I have a blank plot without having the (0, 0) point there? and (2) how can I shade the corresponding region according to dir? Should I try ggplot2?
I'm simply looking to shade the area that is described by the set of inequalities above. Not where (0, 0) lies.
1) Change the last inequality to be the same direction as the others and then use plotPolytope in gMOIP.
library(gMOIP)
mat <- matrix(c(-2, 1, 1.25, 1, 0, -1), nrow = 3, byrow = TRUE)
rhs <- c(-3, 2.5, 3)
argsFaces <- list(argsGeom_polygon = list(fill = "blue"))
plotPolytope(mat, rhs, argsFaces = argsFaces)
giving (continued after image)
2) The above uses ggplot2 graphics but if you prefer classic graphics then using mat and rhs from above:
library(gMOIP)
cp <- cornerPoints(mat, rhs)
cp <- cp[chull(cp), ] # chull gives indices of convex hull in order
plot(cp, type = "n")
polygon(cp, col = "blue")
# not shown but to add lines run this too
for(i in 1:nrow(cp)) {
ix <- if (i < nrow(cp)) i + 0:1 else c(i, 1)
b <- diff(cp[ix, 2]) / (d <- diff(cp[ix, 1]))
if (abs(d) < 1e-5) abline(v = a <- cp[i, 1])
else abline(a = a <- cp[i, 2] - b * cp[i, 1], b = b)
}
giving (continued after image)
3) Note that there is an archived package named intpoint on CRAN and it could be used to draw the boundary of the feasible region and lines. It does have the limitation that it is hard coded to show X and Y axes between -1 and 5 although it might not be hard to generalize it. It is used like this (output not shown) where mat, rhs and cp are from above.
library(intpoint)
intpoint:::show2d(mat, rhs, c = numeric(2))
polygon(cp, col = "blue")

R hexbin: Get count for particular bin

Suppose I create a hexbin (using the hexbin package):
h <- hexbin(df)
where df has x and y fields. For a particular value of x and y, how do I get the count of the corresponding bin?
Assuming you are using the hexbin function from library(hexbin) you can use the bin IDs to achive what you want.
Call the function as hexbin(..., IDs = T) and the result will have a field that tells you in which bin the points fall.
Working example:
library(hexbin)
x <- c(1, 1.2, 1, 3, 5, -2 ,1, 0, 0.8)
y <- c(1, 1, 0, -1, 0, 2, -1, 1, 1)
h <- hexbin(x, y, xbins = 3,IDs = T)
#what is the cell ID of point 1?
ID1 <- h#cID[1]
#how many points fall in that cell?
sum(h#cID == ID1) #answer is 4 in this case
get_count <- function(x, y, h) {
my_dist <- function(x2, y2) {
return(sqrt((x - x2) ^ 2 + (y - y2) ^ 2))
}
distances <- mapply(my_dist, attr(h, 'xcm'), attr(h, 'ycm'))
return(attr(h, 'count')[which.min(distances)])
}

ReacTran 2D Diffusion model with non-conformable arrays error in R, matrix and setup.grid.1D and setup.grid.2D

I am trying to model diffusion in 2D in R with the diffusion rate being dependent on the density, y. I have completed this model in 1D, but trying to change it 2D it keep getting the error code:
Error in -VF.grid$x.int * D.grid$x.int * diff(rbind(C.x.up, C, C.x.down, non-conformable arrays
I have no data, as it is a simulation. My code is as follows;
library(ReacTran)
N <- 50 # number of grid cells
Nx <-50
Ny <-50
XX <- 10 # total size
dy <- dx <- XX/N # grid size
Dy <- Dx <- 0.1 # diffusion coeff, X- and Y-direction
r <- 0.005 # growth rate
ini <- 10 # initial value at x=0
N2 <- ceiling(N/2)
K <- 100 #Carrying Capacity
A0<- 2 #pop ini size
x.grid <- setup.grid.1D(x.up = 0, x.down = 1, N = N)
y.grid <- setup.grid.1D(x.up = 0, x.down = 1, N = N)
grid2D <- setup.grid.2D(x.grid, y.grid)
D.grid <- setup.prop.2D(value = Dx, y.value = Dy, grid = grid2D) #diffusion coefficient on cell interfaces
v.grid <- setup.prop.2D(value = 0, y.value=0, grid = grid2D) #advection velocity
A.grid <- setup.prop.2D(value = 1, y.value=1, grid = grid2D) #interface area
AFDW.grid <- setup.prop.2D(value = 0, y.value=0, grid = grid2D) #advction weight difference
VF.grid <- setup.prop.2D(value = 0, y.value=1, grid = grid2D) #volume fraction
# The model equations - using the grids
Diff2Db <- function (t, y, parms) {
U <- matrix(nrow = N, ncol = N, data = y)
dCONC <- tran.2D(C = y, C.x.up=0, C.x.down=0,
C.y.up=0, C.y.down=0,
grid = grid2D, D.grid = D.grid,
D.x=(y-1)^2 + 1, D.y=(y-1)^2 + 1, dx=dx, dy=dy,
A.grid = A.grid,
VF.grid = VF.grid, AFDW.grid = AFDW.grid, v.grid = v.grid
)$dC
return (list(dCONC))
}
# initial condition: 0 everywhere, except in central point
y <- matrix(nrow = N, ncol = N, data = 0)
y[N2,N2] <- ini # initial concentration in the central point...
times <- 0:8
outb <- ode.2D (y = y, func = Diff2Db, t = times, parms = NULL,
dim = c(49, N), lrw = 160000)
I am out of ideas to try to fix it. Any help would be greatly appreciated.
Thank you in advance

Resources