I have specific x,y,z coordinates. I want to generate random points within a sphere given x as the center and x2 from another data frame as the edge of the radius (therefore the distance from x to x2 would be the length of the radius of the sphere).
I've seen a lot of discussion about how to do this appropriately mathematically (randomly distribute the points to avoid clustering) and was able to compile the easiest examples here and here for sample R code.
I also found this [R package sphereplot] (https://cran.r-project.org/web/packages/sphereplot/sphereplot.pdf) which might be easier, but am having a hard time understanding how to apply it.
These are all good starting points but using the sample code below I'm unsure how to apply it to specific starting points/spherical coordinates?
set.seed(101)
n <- 50
theta <- runif(n,0,2*pi)
u <- runif(n,-1,1)
x <- sqrt(1-u^2)*cos(theta)
y <- sqrt(1-u^2)*sin(theta)
z <- u
Using just one set/row of x,y,z coordinates from my data frame:
x = -0.0684486861
y= 0.0125857380
z= 0.0201056441
x2= -0.0684486861
y2 = 0.0125857380
z2= -0.0228805516
I want x,y,z to be the center of the sphere and the distance to x2,y2,z2 to be the radius length/edge of the sphere. Then generate random points from within the sphere with x,y,z as the center.
Eventually, I'm trying to do this with 100 spheres to compare if all the points in the second set of coordinates move in similar angles/directions in space.
Thanks for the guidance.
Well, lets split problem in several subproblems.
First, is generating points uniformly distributed on a sphere (either volumetrically, or on surface), with center at (0,0,0), and given radius. Following http://mathworld.wolfram.com/SpherePointPicking.html, and quite close to code you shown,
rsphere <- function(n, r = 1.0, surface_only = FALSE) {
phi <- runif(n, 0.0, 2.0 * pi)
cos_theta <- runif(n, -1.0, 1.0)
sin_theta <- sqrt((1.0-cos_theta)*(1.0+cos_theta))
radius <- r
if (surface_only == FALSE) {
radius <- r * runif(n, 0.0, 1.0)^(1.0/3.0)
}
x <- radius * sin_theta * cos(phi)
y <- radius * sin_theta * sin(phi)
z <- radius * cos_theta
cbind(x, y, z)
}
set.seed(312345)
sphere_points <- rsphere(10000)
Second problem - move those points to the center at point X
rsphere <- function(n, r = 1.0, surface_only = FALSE, center=cbind(Xx, Xy, Xz)) {
....
cbind(x+center[1], y+center[2], z+center[3])
}
Third problem - compute radius given center at (Xx, Xy, Xz) and surface point(Yx, Yy, Yz))
radius <- sqrt((Xx-Yx)**2+(Xy-Yy)**2+(Xz-Yz)**2)
Combine them all together for a full satisfaction. Ok, now that you provided values for center and radius, let's put it all together
rsphere <- function(n, r = 1.0, surface_only = FALSE, center=cbind(0.0, 0.0, 0.0)) {
phi <- runif(n, 0.0, 2.0 * pi)
cos_theta <- runif(n, -1.0, 1.0)
sin_theta <- sqrt((1.0-cos_theta)*(1.0+cos_theta))
radius <- r
if (surface_only == FALSE) {
radius <- r * runif(n, 0.0, 1.0)^(1.0/3.0)
}
x <- radius * sin_theta * cos(phi)
y <- radius * sin_theta * sin(phi)
z <- radius * cos_theta
# if radius is fixed, we could check it
# rr = sqrt(x^2+y^2+z^2)
# print(rr)
cbind(x+center[1], y+center[2], z+center[3])
}
x1 = -0.0684486861
y1 = 0.0125857380
z1 = 0.0201056441
x2 = -0.0684486861
y2 = 0.0125857380
z2 = -0.0228805516
R = sqrt((x2-x1)^2 + (y2-y1)^2 + (z2-z1)^2)
print(R)
set.seed(32345)
sphere_points <- rsphere(100000, R, FALSE, cbind(x1, y1, z1))
How it looks like?
UPDATE
Generated 10 points each on surface and in the volume and printed it, radius=2 looks ok to me
# 10 points uniform on surface, supposed to have fixed radius
sphere_points <- rsphere(10, 2, TRUE, cbind(x1, y1, z1))
for (k in 1:10) {
rr <- sqrt((sphere_points[k,1]-x1)^2+(sphere_points[k,2]-y1)^2+(sphere_points[k,3]-z1)^2)
print(rr)
}
# 10 points uniform in the sphere, supposed to have varying radius
sphere_points <- rsphere(10, 2, FALSE, cbind(x1, y1, z1))
for (k in 1:10) {
rr <- sqrt((sphere_points[k,1]-x1)^2+(sphere_points[k,2]-y1)^2+(sphere_points[k,3]-z1)^2)
print(rr)
}
got
[1] 2
[1] 2
[1] 2
[1] 2
[1] 2
[1] 2
[1] 2
[1] 2
[1] 2
[1] 2
and
[1] 1.32571
[1] 1.505066
[1] 1.255023
[1] 1.82773
[1] 1.219957
[1] 1.641258
[1] 1.881937
[1] 1.083975
[1] 0.4745712
[1] 1.900066
what did you get?
Related
Given the equation: 10 = 2x + 3y + 2z, I want to find all the combination of x, y and z between 2 thresholds (e.g. -100 and 100) that make the equation hold true.
So far, I have tried the following with no success (please see the comments):
set.seed(333)
result = 10
# sample random values from uniform distribution
x = runif(100, -100, 100)
y = runif(100, -100, 100)
z = runif(100, -100, 100)
# store the vectors in a single dataframe
df = data.frame(x, y, z)
# find all the combinations of x, y and z
expanded = expand.grid(df)
# calculation with all the combinations
expanded$result = ((expanded$x * 2) + (expanded$y * 3) + (expanded$z * 2)) == result
# show the data where result is 10
expanded[expanded$result, ]
[1] x y z result
<0 rows> (or 0-length row.names)
How would I achieve this?
A linear equation of three variables can be thought of as a plane in 3D space. Solving your equation for z we have:
z = 5 - x - 1.5 * y
So we can at least see what the solution looks like. Let's examine all the valid integer values of x and y:
df <- expand.grid(x = seq(-100, 100), y = seq(-100, 100))
We can then get the corresponding values of z:
df$z <- 5 - df$x - 1.5 * df$y
But we need to disallow any values of z below -100 or above 100:
df$z[abs(df$z) > 100] <- NA
And we can plot the resultant plane with the z value shown as a fill color:
ggplot(df, aes(x, y, fill = z)) +
geom_raster() +
scale_fill_viridis_c() +
coord_equal()
These at a glance, are all 25,184 integer solutions of your equation with the given constraints (as others have pointed out, there are of course an infinite number of non-integer solutions), and it's a reasonable approximation of the whole system. You can see all these combinations with
df[!is.na(df$z),]
As multiple commenters have noted, your equation 10 = 2x + 3y + 2z forms a plane of possible values.
Consider this:
library(plotly)
myfunc <- \(x,y)5-x-(3/2 * y)
y <- x <- seq(-100,100,1)
z <- outer(x, y, myfunc)
plot_ly(x = x, y = y, z = z) %>%
add_surface()
As you can see, given unlimited precision, there are an infinite number of points on that plane.
I am trying to compute the turning angles of sequential vectors in the complex plane. Please see the code below for a demo data frame and my attempt at calculating the angles.
The sign of the angles seem correct: left turns are positive and right turns are negative. However, the turning angles do not look right when I reference the plot. NOTE: I want the turning angles and not the angles between the vectors. Image for reference:
set.seed(123)
# Generate a random path and plot it
path.short.random <- function(points = 6) {
x <- runif(points, -1, 1)
y <- rnorm(points, 0, 0.25)
i <- order(x, y)
x <- x[i]
y <- y[i]
path <- data.frame(x = x, y = y)
plot(x, y, main = "Random Path", asp = 1)
# draw arrows from point to point
s <- seq(length(x) - 1) # one shorter than data
arrows(x[s], y[s], x[s + 1], y[s + 1], col = 1:points)
path
}
# Save the path as a data frame
df <- path.short.random()
# Compute sequential turning angles
get.angles <- function(df) {
df$polar <- complex(real = df$x, imaginary = df$y)
df$displacement <- c(0, diff(df$polar))
diff(Arg(df$displacement[2:nrow(df)]))
}
get.angles(df)
I have this circle:
library(sf)
p <- st_sfc(st_point(c(0, 1)))
circle <- st_buffer(p, dist = 1)
plot(circle)
How do I partition this circle into 4 equal "slices"? 6 equal slices? 8 equal slices? Etc. The object I need returned would be a MULTIPOLYGON.
Take these two functions, one to create a single wedge given a centre, radius, start angle, width, and number of sections in the arc part, and another to create a number of those with different start angles:
st_wedge <- function(x,y,r,start,width,n=20){
theta = seq(start, start+width, length=n)
xarc = x + r*sin(theta)
yarc = y + r*cos(theta)
xc = c(x, xarc, x)
yc = c(y, yarc, y)
st_polygon(list(cbind(xc,yc)))
}
st_wedges <- function(x, y, r, nsegs){
width = (2*pi)/nsegs
starts = (1:nsegs)*width
polys = lapply(starts, function(s){st_wedge(x,y,r,s,width)})
mpoly = st_cast(do.call(st_sfc, polys), "MULTIPOLYGON")
mpoly
}
Then do something like this to get five wedges centred at 5,1 of radius 10:
> w5 = st_wedges(5,1,10,5)
> plot(w5)
> class(w5)
[1] "sfc_MULTIPOLYGON" "sfc"
> axis(1)
> axis(2)
I am attempting to sample along multiple lines (roads) at regular intervals and am struggling to obtain exact perpendicular angles for each road segment. I have split each road into points giving the node at which each line changes orientation and what I have so far creates a point within a straight segment of each road and appears to be working fine.
This is the code I am using to produce perpendicular angles for each node segment.
# X and Y for 3 points along a line
road_node <- matrix(
c(
381103, 381112, 381117,
370373, 370301, 370290
),
ncol = 2,
)
road_node <- as.data.frame(road_node)
angle_inv <- c()
for (i in 2:nrow(road_node) - 1) {
n1 <- road_node[i, ]
n2 <- road_node[i + 1, ]
x <- as.numeric(n1[1] - n2[1])
y <- as.numeric(n1[2] - n2[2])
ang <- atan2(y, x) + 1 / 2 * pi
if (!is.na(ang) && ang < 0) {
ang <- 2 + ang
}
angle_inv <- rbind(angle_inv, ang)
}
Where road_node gives the coordinates of each node.
From this I take the mid points and the inverse angles to create two points either side of the mid points, to produce a line segment.
# X Y and Angles (angles for one segment are the same
mids <- matrix(
c(
381374.5, 381351.0, 381320.5,
371590.5,371560.0, 371533.590,
2.3, 2.3, 2.3
),
nrow = 3,
)
mids <- as.data.frame(mids)
pts <- c()
for (i in 1:nrow(mids)) {
x1 <- mids[i, 1] + 10 * cos(mids[i, 3])
y1 <- mids[i, 2] + 10 * sin(mids[i, 3])
x2 <- mids[i, 1] - 10 * cos(mids[i, 3])
y2 <- mids[i, 2] - 10 * sin(mids[i, 3])
p1 <- cbind(x1, y1)
p2 <- cbind(x2, y2)
pair <- rbind(p1, p2)
pts <- rbind(pts, pair)
}
Some line segments appear to be correctly perpendicular to the node they are associate with, however some are not. Each appear to correctly share the same length.
I believe the problem lies with either how I am selecting my angles using atan2, or with how I am selecting my points either side of the node segment.
Firstly, there's no need to use trigonometry to solve this. Instead you can use the inverse reciprocal of the slope intercept form of the line segment equation, then calculate points on a perpendicular line passing through a give point.
See Equation from 2 points using Slope Intercept Form
Also your mid points appear incorrect and there are only 2 mid points as 3 points = 2 line segments.
This code appears to work fine
# Function to calculate mid points
mid_point <- function(p1,p2) {
return(c(p1[1] + (p2[1] - p1[1]) / 2,p1[2] + (p2[2] - p1[2]) / 2))
}
# Function to calculate slope of line between 2 points
slope <- function(p1,p2) {
return((p2[2] - p1[2]) / (p2[1] - p1[1]))
}
# Function to calculate intercept of line passing through given point wiht slope m
calc_intercept <- function(p,m) {
return(p[2] - m * p[1])
}
# Function to calculate y for a given x, slope m and intercept b
calc_y <- function(x,m,b) {
return(c(x, m * x + b))
}
# X and Y for 3 points along a line
road_node <- matrix(
c(
381103, 381112, 381117,
370373, 370301, 370290
),
ncol = 2,
)
road_node <- as.data.frame(road_node)
perp_segments <- c()
for (i in 2:nrow(road_node) - 1) {
n1 <- road_node[i, ]
n2 <- road_node[i + 1, ]
# Calculate mid point
mp <- mid_point(n1,n2)
# Calculate slope
m <- slope(n1,n2)
# Calculate intercept subsituting n1
b <- calc_intercept(n1,m)
# Calculate inverse reciprocal of slope
new_m <- -1.0 / m
# Calculate intercept of perpendicular line through mid point
new_b <- calc_intercept(mp,new_m)
# Calculate points 10 units away in x direction at mid_point
p1 <- rbind(calc_y(as.numeric(mp[1])-10,new_m,new_b))
p2 <- rbind(calc_y(as.numeric(mp[1])+10,new_m,new_b))
# Add point pair to output vector
pair <- rbind(p1,p2)
perp_segments <- rbind(perp_segments,pair)
}
This is how it looks geometrically (image)
I hope this helps.
Edit 1:
I thought about this more and came up with this simplified function. If you tink of the problem as a right isosceles triangle (45,45,90), then all you need to do is find the point which is the required distance from the reference point interpolated along the line segment, then invert its x and y distances from the reference points, then add and subtract these from the reference point.
Function calc_perp
Arguments:
p1, p2 - two point vectors defining the end points of the line segment
n - the distance from the line segment
interval - the interval along the line segment of the reference point from the start (default 0.5)
proportion - Boolean defining whether the interval is a proportion of the length or a constant (default TRUE)
# Function to calculate Euclidean distance between 2 points
euclidean_distance <-function(p1,p2) {
return(sqrt((p2[1] - p1[1])**2 + (p2[2] - p1[2])**2))
}
# Function to calculate 2 points on a line perpendicular to another defined by 2 points p,p2
# For point at interval, which can be a proportion of the segment length, or a constant
# At distance n from the source line
calc_perp <-function(p1,p2,n,interval=0.5,proportion=TRUE) {
# Calculate x and y distances
x_len <- p2[1] - p1[1]
y_len <- p2[2] - p1[2]
# If proportion calculate reference point from tot_length
if (proportion) {
point <- c(p1[1]+x_len*interval,p1[2]+y_len*interval)
}
# Else use the constant value
else {
tot_len <- euclidean_distance(p1,p2)
point <- c(p1[1]+x_len/tot_len*interval,p1[2]+y_len/tot_len*interval)
}
# Calculate the x and y distances from reference point to point on line n distance away
ref_len <- euclidean_distance(point,p2)
xn_len <- (n / ref_len) * (p2[1] - point[1])
yn_len <- (n / ref_len) * (p2[2] - point[2])
# Invert the x and y lengths and add/subtract from the refrence point
ref_points <- rbind(point,c(point[1] + yn_len,point[2] - xn_len),c(point[1] - yn_len,point[2] + xn_len))
# Return the reference points
return(ref_points)
}
Examples
> calc_perp(c(0,0),c(1,1),1)
[,1] [,2]
point 0.5000000 0.5000000
1.2071068 -0.2071068
-0.2071068 1.2071068
> calc_perp(c(0,0),c(1,1),sqrt(2)/2,0,proportion=FALSE)
[,1] [,2]
point 0.0 0.0
0.5 -0.5
-0.5 0.5
This is how the revised function looks geometrically with your example and n = 10 for distance from line:
Consider the Togliatti implicit surface. I want to clip it to the ball centered at the origin with radius 4.8. A solution, with the misc3d package, consists in using the mask argument of the computeContour3d function, which allows to use only the points satisfying x^2+y^2+z^2 < 4.8^2:
library(misc3d)
# Togliatti surface equation: f(x,y,z) = 0
f <- function(x,y,z){
w <- 1
64*(x-w)*
(x^4-4*x^3*w-10*x^2*y^2-4*x^2*w^2+16*x*w^3-20*x*y^2*w+5*y^4+16*w^4-20*y^2*w^2) -
5*sqrt(5-sqrt(5))*(2*z-sqrt(5-sqrt(5))*w)*(4*(x^2+y^2-z^2)+(1+3*sqrt(5))*w^2)^2
}
# make grid
nx <- 220; ny <- 220; nz <- 220
x <- seq(-5, 5, length=nx)
y <- seq(-5, 5, length=ny)
z <- seq(-4, 4, length=nz)
g <- expand.grid(x=x, y=y, z=z)
# calculate voxel
voxel <- array(with(g, f(x,y,z)), dim = c(nx,ny,nz))
# mask: keep points satisfying x^2+y^2+z^2 < 4.8^2, in order to
# clip the surface to the ball of radius 4.8
mask <- array(with(g, x^2+y^2+z^2 < 4.8^2), dim = c(nx,ny,nz))
# compute isosurface
surf <- computeContour3d(voxel, maxvol=max(voxel), level=0, mask=mask, x=x, y=y, z=z)
# draw isosurface
drawScene.rgl(makeTriangles(surf, smooth=TRUE))
But the borders of the resulting surface are irregular:
How to get regular, smooth borders?
The solution I found resorts to spherical coordinates. It consists in defining the function f in terms of spherical coordinates (ρ, θ, ϕ), then to compute the isosurface with ρ running from 0 to the desired radius, and then to transform the result to Cartesian coordinates:
# Togliatti surface equation with spherical coordinates
f <- function(ρ, θ, ϕ){
w <- 1
x <- ρ*cos(θ)*sin(ϕ)
y <- ρ*sin(θ)*sin(ϕ)
z <- ρ*cos(ϕ)
64*(x-w)*
(x^4-4*x^3*w-10*x^2*y^2-4*x^2*w^2+16*x*w^3-20*x*y^2*w+5*y^4+16*w^4-20*y^2*w^2) -
5*sqrt(5-sqrt(5))*(2*z-sqrt(5-sqrt(5))*w)*(4*(x^2+y^2-z^2)+(1+3*sqrt(5))*w^2)^2
}
# make grid
nρ <- 300; nθ <- 400; nϕ <- 300
ρ <- seq(0, 4.8, length = nρ) # ρ runs from 0 to the desired radius
θ <- seq(0, 2*pi, length = nθ)
ϕ <- seq(0, pi, length = nϕ)
g <- expand.grid(ρ=ρ, θ=θ, ϕ=ϕ)
# calculate voxel
voxel <- array(with(g, f(ρ,θ,ϕ)), dim = c(nρ,nθ,nϕ))
# calculate isosurface
surf <- computeContour3d(voxel, maxvol=max(voxel), level=0, x=ρ, y=θ, z=ϕ)
# transform to Cartesian coordinates
surf <- t(apply(surf, 1, function(rtp){
ρ <- rtp[1]; θ <- rtp[2]; ϕ <- rtp[3]
c(
ρ*cos(θ)*sin(ϕ),
ρ*sin(θ)*sin(ϕ),
ρ*cos(ϕ)
)
}))
# draw isosurface
drawScene.rgl(makeTriangles(surf, smooth=TRUE, color = "violetred"))
Now the resulting surface has regular, smooth borders:
Your solution is excellent for the problem you stated, because spherical coordinates are so natural for that boundary. However, here is a more general solution that would work for other smooth boundaries.
The idea is to allow input of a boundary function, and cull points when they are too large or too small. In your case it would be the squared distance from the origin, and you would want to cull points where the value is bigger than 4.8^2. But sometimes the triangles being drawn to make the smooth surface should only be partially culled: one point would be kept and two deleted, or two kept and one deleted. If you cull the whole triangle that leads to the jagged edges in your original plot.
To fix this, the points can be modified. If only one is supposed to be kept, then the other two points can be shrunk towards it until they lie on an approximation to the boundary. If two are supposed to be kept you want the shape to be a quadrilateral, so you would build that out of two triangles.
This function does that, assuming the input surf is the output of computeContour3d:
boundSurface <- function(surf, boundFn, bound = 0, greater = TRUE) {
# Surf is n x 3: each row is a point, triplets are triangles
values <- matrix(boundFn(surf) - bound, 3)
# values is (m = n/3) x 3: each row is the boundFn value at one point
# of a triangle
if (!greater)
values <- -values
keep <- values >= 0
# counts is m vector counting number of points to keep in each triangle
counts <- apply(keep, 2, sum)
# result is initialized to an empty array
result <- matrix(nrow = 0, ncol = 3)
# singles is set to all the rows of surf where exactly one
# point in the triangle is kept, say s x 3
singles <- surf[rep(counts == 1, each = 3),]
if (length(singles)) {
# singleValues is a subset of values where only one vertex is kept
singleValues <- values[, counts == 1]
singleIndex <- 3*col(singleValues) + 1:3 - 3
# good is the index of the vertex to keep, bad are those to fix
good <- apply(singleValues, 2, function(col) which(col >= 0))
bad <- apply(singleValues, 2, function(col) which(col < 0))
for (j in 1:ncol(singleValues)) {
goodval <- singleValues[good[j], j]
for (i in 1:2) {
badval <- singleValues[bad[i,j], j]
alpha <- goodval/(goodval - badval)
singles[singleIndex[bad[i,j], j], ] <-
(1-alpha)*singles[singleIndex[good[j], j],] +
alpha *singles[singleIndex[bad[i,j], j],]
}
}
result <- rbind(result, singles)
}
doubles <- surf[rep(counts == 2, each = 3),]
if (length(doubles)) {
# doubleValues is a subset of values where two vertices are kept
doubleValues <- values[, counts == 2]
doubleIndex <- 3*col(doubleValues) + 1:3 - 3
doubles2 <- doubles
# good is the index of the vertex to keep, bad are those to fix
good <- apply(doubleValues, 2, function(col) which(col >= 0))
bad <- apply(doubleValues, 2, function(col) which(col < 0))
newvert <- matrix(NA, 2, 3)
for (j in 1:ncol(doubleValues)) {
badval <- doubleValues[bad[j], j]
for (i in 1:2) {
goodval <- doubleValues[good[i,j], j]
alpha <- goodval/(goodval - badval)
newvert[i,] <-
(1-alpha)*doubles[doubleIndex[good[i,j], j],] +
alpha *doubles[doubleIndex[bad[j], j],]
}
doubles[doubleIndex[bad[j], j],] <- newvert[1,]
doubles2[doubleIndex[good[1,j], j],] <- newvert[1,]
doubles2[doubleIndex[bad[j], j],] <- newvert[2,]
}
result <- rbind(result, doubles, doubles2)
}
# Finally add all the rows of surf where the whole
# triangle is kept
rbind(result, surf[rep(counts == 3, each = 3),])
}
You would use it after computeContour3d and before makeTriangles, e.g.
fn <- function(x) {
apply(x^2, 1, sum)
}
drawScene.rgl(makeTriangles(boundSurface(surf, fn, bound = 4.8^2,
greater = FALSE),
smooth = TRUE))
Here's the output I see:
It's not quite as good as yours, but it would work for many different boundary functions.
Edited to add: Version 0.100.26 of rgl now has a function clipMesh3d which incorporates these ideas.