Code used to test rayrender polygon extrusion patches

extruded-polygon-tests.R

mk_name <- function(name=NULL) {
  v <- as.character(packageVersion('rayrender'))
  dir <- file.path('~', 'Downloads', 'rr-tests')
  if(is.null(name)) {
    name <- sprintf( 'a_%s.png', format(Sys.time(), "%Y-%m-%d_%H%M%S"))
  } else {
    name <- sprintf('%s.png', name)
  }
  file.path(dir, v, name)
}
library(rayrender)
smp_base <- 50

# - Examples -------------------------------------------------------------------

#We can also directly pass in sf polygons (try this first; c-stack error
#otherwise?):

if("spData" %in% rownames(utils::installed.packages())) {
  us_states = spData::us_states
  texas = us_states[us_states$NAME == "Texas",]
  #Fix no sfc class in us_states geometry data
  class(texas$geometry) = c("list","sfc")
}
#This uses the raw coordinates, unless `center = TRUE`, which centers the bounding box
#of the polygon at the origin.

generate_ground(depth=-0.01,
                material = diffuse(color="grey50",checkercolor="grey20")) %>%
  add_object(extruded_polygon(texas, center = TRUE,
                              material=diffuse(color="#ff2222",sigma=90))) %>%
  add_object(sphere(y=30,x=-30,radius=10,
                    material=light(color="lightblue",intensity=40))) %>%
  render_scene(
    parallel=TRUE,lookfrom = c(0,10,-10),samples=smp_base * 2,fov=60,
    filename=mk_name('ex-texas')
  )

# NC data

library(sf)
nc <- st_read(system.file("shape/nc.shp", package="sf"))
ncep <- extruded_polygon(nc, data_column_top = "AREA",
                              scale_data = 1/max(nc$AREA)*5,
                              material=diffuse(color="#ff2222",sigma=90), center=TRUE)
  # sphere(y=90,x=40,z=-30,radius=7, material=light(color="orange",intensity=350))
  # sphere(y=30,x=-100,z=60,radius=10, material=light(color="lightblue",intensity=250)),
  # sphere(y=30,x=100,z=-60,radius=10, material=light(color="orange",intensity=250))

l_a <- sphere(y=80,x=-40,z=30,radius=10, material=light(intensity=350))
l_b <- sphere(y=80,x=40,z=-30,radius=10, material=light(intensity=350))
g <- generate_ground(depth=0, material = diffuse(color="grey50",checkercolor="grey20",sigma=90))

ncscn_a <- dplyr::bind_rows(ncep, l_a, g)
ncscn_b <- dplyr::bind_rows(ncep, l_b, g)
render_scene(
  ncscn_a,parallel=TRUE,
  width=450, height=300, smp_base * 2,
  lookfrom = c(-10,50,-15),lookat=c(0,0.75,0),fov=7,
  filename=mk_name('ex-nc-a'), clamp_value=5
)
render_scene(
  ncscn_b,parallel=TRUE,
  width=450, height=300, smp_base * 2,
  lookfrom = c(-10,50,-15),lookat=c(0,0.75,0),fov=7,
  filename=mk_name('ex-nc-b'), clamp_value=5
)
ncm <- nc[lengths(st_geometry(nc)) > 1, ]
ncsn_c <- dplyr::bind_rows(
  extruded_polygon(ncm, top=1, material=diffuse(color="#ff2222",sigma=90), center=TRUE),
  l_a, g
)
render_scene(
  ncsn_c,parallel=TRUE,
  width=450, height=300, smp_base * 2,
  lookfrom = c(-10,50,-15),lookat=c(0,0.75,0),fov=3,
  filename=mk_name('ex-nc-multi'), clamp_value=5
)

# THIS FAILS WITH Error: C stack usage  7969776 is too close to the limit

# generate_ground(depth=0,
#                 material = diffuse(color="grey50",checkercolor="grey20",sigma=90)) %>%
#   add_object(extruded_polygon(us_states, x=-96,z=-45, data_column_top = "total_pop_15",
#                               scale_data = 1/max(us_states$total_pop_15)*5,
#                               material=diffuse(color="#ff2222",sigma=90))) %>%
#   add_object(sphere(y=30,x=-100,z=60,radius=10,
#                     material=light(color="lightblue",intensity=250))) %>%
#   add_object(sphere(y=30,x=100,z=-60,radius=10,
#                     material=light(color="orange",intensity=250))) %>%
#   render_scene(
#     parallel=TRUE,lookfrom = c(-60,50,-40),lookat=c(0,-5,0),samples=smp_base *2,fov=30,
#     filename=mk_name('ex-texas-2')
#   )

#Now, let's add a hole to the center of the polygon. We'll make the polygon
#hollow by shrinking it, combining it with the normal size polygon,
#and specify with the `hole` argument that everything after `nrow(star_polygon)`
#in the following should be used to draw a hole:
#
#Manually create a polygon object, here a star:

angles = seq(0,360,by=36)
xx = rev(c(rep(c(1,0.5),5),1) * sinpi(angles/180))
yy = rev(c(rep(c(1,0.5),5),1) * cospi(angles/180))
star_polygon = data.frame(x=xx,y=yy)

hollow_star = rbind(star_polygon,0.8*star_polygon)

# Now add the zy plane:

generate_ground(depth=-0.01,
                material = diffuse(color="grey50",checkercolor="grey20")) %>%
  add_object(extruded_polygon(hollow_star,top=0.25,bottom=0, holes = nrow(star_polygon),
                              material=diffuse(color="red",sigma=90))) %>%
  add_object(extruded_polygon(hollow_star,top=0.25,bottom=0, y=1.2, z=-1.2,
                              holes = nrow(star_polygon), plane = "yx",
                              material=diffuse(color="green",sigma=90))) %>%
  add_object(extruded_polygon(hollow_star,top=0.25,bottom=0, y=1.2, x=1.2,
                              holes = nrow(star_polygon), plane = "zy",
                              material=diffuse(color="blue",sigma=90))) %>%
  add_object(sphere(y=4,x=-3,material=light(intensity=30))) %>%
  render_scene(
    parallel=TRUE,lookfrom = c(-4,2,4),samples=smp_base * 2,lookat=c(0,0.9,0),fov=40,
    filename=mk_name('ex-hollow-star')
  )

# - Cube vs Poly ---------------------------------------------------------------

# These compare an extruded cube (right) against a cube made directly from
# cube object(s)

lights <- dplyr::bind_rows(
  sphere(z=10, y=10, material=light(intensity=5*30)),
  sphere(z=-10, y=10, material=light(intensity=5*5)),
  sphere(x=-5, z=-5, y=-10, material=light(intensity=5*5))
)
# open cube, clockwise

mat <- diffuse(color='#CCCCCC')
x <- c(-1, -1, 1, 1)
y <- c(-1, 1, 1, -1)
xy <- xy.coords(x/2, y/2)
scene1 <- dplyr::bind_rows(
  cube(x=-.75, material=mat),
  extruded_polygon(xy, top=.5, bottom=-.5, x=.75, material=mat),
  lights
)
render_scene(
  scene1, width=400, height=200, samples=smp_base,
  lookfrom=c(0, 3, -10), fov=10,
  filename=mk_name('01_cube-open-cw')
)
# close cube, clockwise

x <- c(-1, -1, 1, 1, -1)
y <- c(-1, 1, 1, -1, -1)
xy <- xy.coords(x/2, y/2)
scene1 <- dplyr::bind_rows(
  cube(x=-.75, material=mat),
  extruded_polygon(xy, top=.5, bottom=-.5, x=.75, material=mat),
  lights
)
render_scene(
  scene1, width=400, height=200, samples=smp_base,
  lookfrom=c(0, 3, 10), fov=10,
  filename=mk_name('02_cube-cw')
)
# - Material ID ----------------------------------------------------------------

m1 <- diffuse(color='green')
m2 <- diffuse(color='blue')
scene <- dplyr::bind_rows(
  extruded_polygon(xy, top=.5, bottom=-.5, x=-.75, material=m2, material_id=2),
  extruded_polygon(xy, top=.5, bottom=-.5, x=.75, material=m1, material_id=1),
  lights
)
render_scene(
  scene, width=400, height=200, samples=smp_base,
  lookfrom=c(0, 3, 10), fov=10,
  filename=mk_name('02_material-id')
)

# - Holes ----------------------------------------------------------------------

# One hole

xy <- xy.coords(c(x / 2, x / 4), c(y / 2, y / 4))
cubes <- dplyr::bind_rows(
  cube(x=-.75 - .25 * 3/2, material=mat, xwidth=.25),
  cube(x=-.75 + .25 * 3/2, material=mat, xwidth=.25),
  cube(x=-.75, z=.25 * 3/2, material=mat, xwidth=.5, zwidth=.25),
  cube(x=-.75, z=-.25 * 3/2, material=mat, xwidth=.5, zwidth=.25),
  extruded_polygon(
    xy, top=.5, bottom=-.5, x=.75, material=mat,
    holes=5
  ),
  lights
)
render_scene(
  cubes, width=400, height=200, samples=smp_base,
  lookfrom=c(0, 12, 3), fov=8,
  filename=mk_name('03_cube-hole')
)
# One hole, multiple angles
mat_chk <- diffuse(color='red', checkercolor='white', checkerperiod=1/10)
cubes <- dplyr::bind_rows(
  extruded_polygon(
    xy, top=.5, bottom=-.5, x=1.25, y=.75, material=mat_chk, holes=6,
    angle=c(75, 10, 0)
  ),
  extruded_polygon(
    xy, top=.5, bottom=-.5, x=.5, y=-.75, material=mat_chk, holes=6,
    angle=c(-20, -40, 0)
  ),
  extruded_polygon(
    xy, top=.5, bottom=-.5, x=-.5, y=.75, material=mat_chk, holes=6,
    angle=c(0, 70, 135)
  ),
  extruded_polygon(
    xy, top=.5, bottom=-.5, x=-1.25, y=-.75, material=mat_chk, holes=6,
    angle=c(-70, -15, -100)
  ),
  lights
)
render_scene(
  cubes, width=600, height=400, samples=smp_base,
  lookfrom=c(0, 0, 12), fov=15,
  filename=mk_name('04_cube-hole-angles')
)

# multiple holes, in different directions

off <- .2
xy <- xy.coords(
  c(rev(x / 2), rev(x / 6) + off, x/6 - off),
  c(rev(y / 2), rev(y / 6) + off, y/6 - off)
)
try({
  ep2 <- extruded_polygon(
    xy, top=.51, bottom=-.5,
    material=mat_chk,
    holes=c(6, 11)
  )
  render_scene(
    add_object(ep2, lights), width=200, height=200, samples=smp_base,
    lookfrom=c(0, 12, 3), fov=8,
    filename=mk_name('04_cube-holes-two')
  )
})
# put a hole outside of the polygona just to see; this seems to mess with
# the rendering

xy <- xy.coords(
  c(rev(x / 2), rev(x / 6) + off, x/6 - off + -.25),
  c(rev(y / 2), rev(y / 6) + off, y/6 - off + -.25)
)
try({
  ep3 <- extruded_polygon(
    xy, top=.51, bottom=-.5,
    material=diffuse(color='red', checkercolor='white', checkerperiod=1/10),
    holes=c(6, 11)
  )
  render_scene(
    add_object(ep3, lights), width=200, height=200, samples=smp_base,
    lookfrom=c(0, 12, -3), fov=8,
    filename=mk_name('05_cube-hole-outside')
  )
})
# Try two holes with sf




# - Flipping, etc. -------------------------------------------------------------

# Make an arrow so we can see orientation changes

arrow_polygon =
  rbind(star_polygon[c(3,7,8,9,3), 1:2],star_polygon[c(3,7,8,9,3), 1:2] * .8)
arrow_polygon <- transform(arrow_polygon, x=x+1, y=y-.5)

make_arrow <- function(
  material, fh=FALSE, fv=FALSE, center=FALSE, x=0, y=0, z=0, plane=xz
) {
  extruded_polygon(
    arrow_polygon, top=0.26, bottom=0,
    holes = nrow(arrow_polygon)/2 + 1L,
    material=material,
    flip_horizontal=fh, flip_vertical=fv, center=center,
    material_id=sample(1e9, 1), x=x, y=y, z=z, plane=plane
) }
make_arrows <- function(
  mat_fun=diffuse, center=FALSE, plane='xz', x=0, y=0, z=0
) {
  dplyr::bind_rows(
    make_arrow(material=mat_fun(color="#CCCCCC"), center=center, plane=plane, x=x, y=y, z=z),
    make_arrow(material=mat_fun(color="#DD9999"), center=center, plane=plane, x=x, y=y, z=z, fh=TRUE),
    make_arrow(material=mat_fun(color="#99DD99"), center=center, plane=plane, x=x, y=y, z=z, fv=TRUE),
    make_arrow(material=mat_fun(color="#9999DD"), center=center, plane=plane, x=x, y=y, z=z, fh=TRUE, fv=TRUE)
  )
}
scene2 <- dplyr::bind_rows(
  make_arrows(dielectric),
  generate_ground(
    depth=-0.01,
    material = diffuse(color="grey50",checkercolor="grey20", checkerperiod=1)
  ),
  sphere(y=4,x=-3,z=-3,material=light(intensity=30))
)
render_scene(
  scene2, parallel=TRUE,
  width=500, height=350, samples=smp_base*20,
  lookfrom = c(0,5,2), lookat=c(0,0,0), fov=30, aperture=0, clamp_value=8,
  filename=mk_name('06_arrows-flip')
)
# Try different planes

arrow2 <- dplyr::bind_rows(
  make_arrow(dielectric(color='#DD9999'), plane='xy'),
  make_arrow(dielectric(color='#999977'), plane='yx'),
  make_arrow(dielectric(color='#9999DD'), plane='zy'),
  make_arrow(dielectric(color='#997799'), plane='yz'),
  make_arrow(dielectric(color='#777777'), plane='xz'),
  make_arrow(dielectric(color='#AAAAAA'), plane='zx'),
)
scene4a <- dplyr::bind_rows(
  arrow2,
  sphere(radius=3, x=10, z=20, material=light(intensity=7)),
  sphere(radius=30, material=diffuse(checkercolor='grey70'), flipped=TRUE),
)
render_scene(
  scene4a,
  parallel=TRUE,
  width=500, height=500, samples=smp_base*5,
  lookfrom = c(-3,2,-8), lookat=c(.5,.5,0), fov=30, aperture=0, clamp_value=8,
  filename=mk_name('07_arrow-plane')
)
# Centering work?

arrow3 <- dplyr::bind_rows(
  make_arrow(dielectric(color='#DD9999'), plane='xy', center=TRUE),
  make_arrow(dielectric(color='#999977'), plane='yx', center=TRUE),
  make_arrow(dielectric(color='#9999DD'), plane='zy', center=TRUE),
  make_arrow(dielectric(color='#997799'), plane='yz', center=TRUE),
  make_arrow(dielectric(color='#777777'), plane='xz', center=TRUE),
  make_arrow(dielectric(color='#AAAAAA'), plane='zx', center=TRUE),
)
scene4b <- dplyr::bind_rows(
  arrow3,
  sphere(radius=3, x=10, z=20, material=light(intensity=7)),
  sphere(radius=30, material=diffuse(checkercolor='grey70'), flipped=TRUE),
)
render_scene(
  scene4b,
  parallel=TRUE,
  width=500, height=500, samples=smp_base*5,
  lookfrom = c(-3,2,-8), lookat=c(0,0,0), fov=15, aperture=0, clamp_value=8,
  filename=mk_name('08_arrow-center')
)
# - SF tests -------------------------------------------------------------------

# messing with sf; sf x coordinates are flipped because the default floor
# axis

library(sf)

p1 <- rbind(c(0,0), c(1,0), c(3,2), c(2,4), c(1,4), c(0,0))
p2 <- rbind(c(1,1), c(1,2), c(2,2), c(1,1))
p3 <- rbind(c(1, 2.5), c(1.5, 3.5), c(2,2.5), c(1, 2.5))

ps <- lapply(list(p1,p2,p3), function(x) {x[,2] <- x[,2]*.25 + .125; x})
psm <- list(ps, lapply(ps, function(x) {x[,2]<--x[,2]; x}))
mpol <- st_multipolygon(psm)
sfmp  <- st_as_sf(st_sfc(mpol))

pol1 <- st_polygon(psm[[1]])
pol2 <- st_polygon(psm[[2]])
sf <- st_as_sf(st_sfc(pol1, pol2))

lights <- dplyr::bind_rows(
  sphere(z=10, y=10, material=light(intensity=4*30)),
  sphere(z=-10, y=10, material=light(intensity=4*5)),
  generate_ground(
    depth=-0.01,
    material = diffuse(color="grey50",checkercolor="grey20", checkerperiod=1)
  )
)
ep <- dplyr::bind_rows(
  extruded_polygon(sf, material=diffuse('#CCCCCC'), top=1, center=TRUE),
  lights
)
render_scene(
  ep,
  lookfrom=c(0, 10, -4),
  samples=smp_base,
  filename=mk_name('09a_sf-multi-holes-angle-1')
)
render_scene(
  ep,
  lookfrom=c(0, 10, 4),
  samples=smp_base,
  filename=mk_name('09a_sf-multi-holes-angle-2')
)
# check multi-polygon the same

epm <- dplyr::bind_rows(
  extruded_polygon(sfmp, material=diffuse('#CCCCCC'), top=1, center=TRUE),
  lights
)
render_scene(
  epm,
  lookfrom=c(0, 10, 4),
  samples=smp_base,
  filename=mk_name('09a_sf-multi-holes-mp')
)
# match sf manually to make sure result is the same

psmr <- psm
psmr[[1]][[3]] <- psmr[[1]][[3]][4:1,]
xy1 <- do.call(rbind, psmr[[1]])
# xy1 <- do.call(rbind, psm[[1]])
xy2 <- do.call(rbind, psm[[2]])

xy1[,1] <- (-xy1[,1] + 1.5)
xy2[,1] <- (-xy2[,1] + 1.5)
ep2 <- dplyr::bind_rows(
  extruded_polygon(
    xy.coords(xy1), material=diffuse('#CCCCCC'), top=1,
    holes=c(nrow(p1), nrow(p1) + nrow(p2)) + 1
  ),
  extruded_polygon(
    xy.coords(xy2), material=diffuse('#CCCCCC'), top=1,
    holes=c(nrow(p1), nrow(p1) + nrow(p2)) + 1
  ),
  lights,
)
render_scene(
  ep2,
  lookfrom=c(0, 10, 4),
  samples=smp_base,
  filename=mk_name('09b_base-multi-holes')
)
# combine multipolygons and polygons

psm2 <- lapply(psm, lapply, function(y) {y[, 1] <- y[, 1] + 3; y})
mpol <- st_multipolygon(psm)
pol1 <- st_polygon(psm2[[1]])
pol2 <- st_polygon(psm2[[2]])
sfmp2  <- st_as_sf(st_sfc(mpol, pol1, pol2))

epm <- dplyr::bind_rows(
  extruded_polygon(sfmp2, material=diffuse('#BBCCAA'), top=1, center=TRUE),
  lights
)
render_scene(
  epm,
  lookfrom=c(0, 10, 4),
  lookat=c(0, .5, 0),
  width=700,
  height=350,
  samples=smp_base,
  filename=mk_name('09a_sf-multi-holes-p-and-mp')
)
# This is to show the inside connection between holes, but needs to be run
# with the "lid taken off" in the code

# render_scene(
#   extruded_polygon(
#     st_as_sf(st_sfc(pol1)), material=diffuse('#BBCCAA'), top=1, center=TRUE,
#     material_id=1
#   ),
#   # lookfrom=c(0, 10, 4),
#   lookfrom=c(6, 10, 0),
#   lookat=c(0, .5, 0),
#   samples=50,
#   clamp_value=8,
#   fov=10
# )

This hole masquerading thing used to confuse me so much, sometimes you got what you wanted from ggplot2 polygons and sometimes not and I remember so well first seeing that bridge from the outer ring to the inner. I haven't seen it explained elsewhere. @brodieG you might be interested in this if you haven't seen it before https://github.com/hypertidy/polyggon