Wykreślanie pewnej liczby nierówności jako płaszczyzn

Question

Chciałbym wykreślić kilka płaszczyzn, każda jest nierównością. Po tym jak mam wszystkie płaszczyzny, chciałbym je połączyć i pokolorować obszar wewnątrz tych linii. Obraz rysuje dużo linii 3d i koloruje obszar wewnątrz - to właśnie próbuję zrobić.

Moje dane wygląda następująco:

df <- structure(list(z = c(0, 0.06518, 0.08429, -0.01659, 0, 0.06808, 
0.12383, -1, -0.01662, 0.28782, 0, -0.09539, 0.04255, 0.09539, 
-0.13361, -0.28782, -0.14468, -0.19239, 0.10642), x = c(1, 0.02197, 
0.03503, -0.02494, 0, 0.04138, 0.17992, 0, -0.02482, 0.1122, 
0, 0.01511, 0.0011, -0.01511, -0.06699, -0.1122, -0.06876, 0.12078, 
0.10201), y = c(0, 0.08735, 0.09927, 0.03876, -1, 0.22114, -0.00152, 
0, 0.03811, -0.07335, 0, -0.03025, 0.07681, 0.03025, -0.23922, 
0.07335, -0.25362, -0.09879, 0.05804), value = c(5801L, 135L, 
162L, 109L, 4250L, 655L, 983L, 4500L, 108L, 1594L, 4400L, 540L, 
147L, 323L, 899L, 1023L, 938L, 1627L, 327L)), .Names = c("z", 
"x", "y", "value"), class = "data.frame", row.names = c(NA, -19L 
)) 

Każdy wiersz reprezentuje równanie w postaci: z + x + y < value. x jest wartością poziomą, y jest pionową, a z jest głębokością. z może być rozwiązane jako: -x - y + wartość> z.

Granice układzie współrzędnych są:

x <- z <- seq(-6000, 6000, by = 1) 
y <- seq(-4000, 4000, by = 1) 

więc z każdego rzędu będą sobie zwrócić samolotu. Następnie chciałbym połączyć wszystkie te płaszczyzny i wypełnić wartości wewnątrz linii. Wynik powinien wyglądać jak nierówne kości wielostronne. Albo brzydko wycięty diament.

Bawiłem się z funkcjami rgl i persp, ale nie jestem pewien, gdzie zacząć. Jestem otwarty na inne zalecenia dotyczące oprogramowania.

Oparty na jednym z przykładów z persp3d:

x <- seq(-6000, 6000, by = 1) 
z <- x 
y <- seq(-4000, 4000, by = 1) 

f <- function(x, y) <- { r <- -x - y + value > z } # stuck here, can you handle an inequality here? 
z <- outer(x, y, f) 
open3d() 
bg3d("white") 
material3d(col = "black") 
persp3d(x, y, z, col = "lightblue", 
     xlab = "X", ylab = "Y", zlab = "z") 

uznaję to jest dość duże ograniczenia. Jeśli pomaga je zmniejszyć, poczuj wolność lub zwiększ liczbę sequence(..., by =).

Answer 1

Możesz zaoszczędzić sporo czasu na obliczeniach, korzystając z mnożenia macierzy.

library(dplyr) 
library(geometry) 
library(rgl) 

# define point grid 
r <- 50 # resolution 
grid <- expand.grid(
    x = seq(-6000, 6000, by = r), 
    y = seq(-4000, 4000, by = r), 
    z = seq(-6000, 6000, by = r)) # data.table::CJ(x,y,z) if speed is a factor 

# get points satisfying every inequality 
toPlot <- df %>% 
    select(x, y, z) %>% 
    data.matrix %>% 
    `%*%`(t(grid)) %>% 
    `<`(df$value) %>% 
    apply(2, all) 

## Alternative way to get points (saves time avoiding apply) 
toPlot2 <- 
    colSums(data.matrix(df[, c('x', 'y', 'z')]) %*% t(grid) < df$value) == nrow(df) 

Ponieważ nie potrzebujesz wnętrza, zmniejsz punkty do ich wypukłego kadłuba i po prostu wykreśl powierzchnię.

# get convex hull, print volume 
gridPoints <- grid[toPlot, ] 
hull <- convhulln(gridPoints, "FA") 
hull$vol 
#> 285767854167 

# plot (option 1: colors as in picture) 
apply(hull$hull, 1, function(i) gridPoints[i, ]) %>% 
    lapply(rgl.triangles, alpha = .8, color = gray.colors(5)) 

## plot (option 2: extract triangles first - much faster avoiding apply) 
triangles <- gridPoints[c(t(hull$hull)), ] 
rgl.triangles(triangles, alpha=0.8, color=gray.colors(3)) 

---

Nadanie to dziwne topniejącego lodu kostki typu rzeczy:

Answer 2

Można utworzyć fabrykę funkcję, która przyjmuje w data.frame nierówności (df) i zwraca funkcję:

1. przyjmuje trzy wartości (x, y, z)
2. zwraca false jeśli któryś z nierównościami załadowanych nie posiadają

fabryczne:

eval_gen <- function(a,b,c,d){ 
    force(a); force(b); force(c); force(d) 
    check <- function(x,y,z){ 
    bool <- T 
    for (i in 1:length(a)){ 
     bool <- bool && (a[i] * x + b[i] * y + c[i] * z < d[i]) 
    } 
    return(bool) 
    } 
} 

Następnie załadować w dataframe nierówności, tworząc funkcję:

ueq_test <- eval_gen(df$x,df$y,df$z,df$value) #load the inequalities 

Teraz wszystko, co musimy zrobić, to stworzyć siatkę i kolor, jeśli wszystkie nierówności przytrzymanie:

library(data.table) 
library(rgl) 

#Note, you can change the resolution by changing the `by` argument here, I've set to 100 to keep computation time and object size manageable 

lx <- lz <- seq(-6000, 6000, by = 100) 
ly <- seq(-4000, 4000, by = 100) 
df_pixels <- data.table(setNames(expand.grid(lx, ly, lz), c("x", "y", "z"))) 
df_pixels[, Ind := 1:.N] 
df_pixels[, Equal := ueq_test(x,y,z), by = Ind] 
df_pixels[Equal == T, colour := "red"] 

Działka na RGL:

with(df_pixels[Equal == T, ], plot3d(x=x, y=y, z=z, col= colour, type="p", size=5, 
            xlim = c(-6000,6000), 
            ylim = c(-4000,4000), 
            zlim = c(-6000,6000) 
            )) 

Co daje: