Tyler Morgan-Wall https://www.tylermw.com/ quarto-1.9.35 Mon, 16 Mar 2026 04:00:00 GMT Atmospheric Simulation in R Tyler Morgan-Wall https://www.tylermw.com/posts/rayverse/atmospheric-simulation-in-r.html document.addEventListener("DOMContentLoaded", () => { const intervalMs = 3000; function showTab(tabEl) { if (window.bootstrap && bootstrap.Tab) { bootstrap.Tab.getOrCreateInstance(tabEl).show(); } else { tabEl.click(); } } document.querySelectorAll(".panel-tabset").forEach((tabset) => { if (tabset.classList.contains("no-autorotate")) return; // opt out const tabs = Array.from(tabset.querySelectorAll('[data-bs-toggle="tab"]')); if (tabs.length < 2) return; let idx = tabs.findIndex((t) => t.classList.contains("active") || t.getAttribute("aria-selected") === "true" ); if (idx < 0) idx = 0; let stopped = false; const timer = setInterval(() => { if (stopped) return; idx = (idx + 1) % tabs.length; showTab(tabs[idx]); }, intervalMs); const stop = () => { if (stopped) return; stopped = true; clearInterval(timer); }; tabs.forEach((t) => { t.addEventListener("click", stop, { once: true }); t.addEventListener("keydown", stop, { once: true }); t.addEventListener("pointerdown", stop, { once: true }); }); }); });

One of the hardest details to get right in 3D data visualization is lighting: since 2D screens don’t offer the benefit of stereoscopic vision, we have to rely on subtle cues like occlusion, relative motion (if animated), and shading to be able to interpret the space as 3D. Nowhere is this more clearly demonstrated than on topographic maps, where shadows can make what is otherwise a largely featureless blob of color transform into a landscape. Add direct light with diffuse shading to a model, and voilà:

(a) No lighting, but surface color. Gives a vague impression of a landscape.
(b) Adding basic lighting makes it obvious that it’s a volcano.
Figure 1: Visualizing a 3D surface

A volcano! Adding basic shading like this allows us to interpret the surface as 3D, even though the medium (your screen) is 2D. This is all perfectly fine and dandy until there’s some detail you want to see in that shaded space. In that case, just using a key light can hide important (key!) information.

Figure 2: What lurks in the shadows?

One way to get that information is to use time as a dimension, and animate either the model or the light. For example, if we send a light spinning around the model, we can ensure that everything we want to show is lit at one point, or the viewer can mentally integrate lighting cues over time. A rotating key light (or a slowly orbiting camera) turns shadowing into a transient effect, bringing light to even the darkest of hillsides.

Figure 3: If animation is an option, you can animate either the light or the object to ensure light reaches all regions of the 3D model.

That’s great for exploration and presentations, but it doesn’t help when your deliverable is a single static figure. Thankfully, this issue isn’t unique to dataviz: the problem of how to paint enough light in a scene so the viewer can interpret the space while avoiding overly dark/light areas is also faced by cinematographers and photographers, and we can apply the tools they’ve developed to our domain (3D data visualization).

Their solution is to ensure light reaches those regions in deliberate ways, angled in a way that maintains the overall contrast while allowing the contours of shapes to be understood. This is done by adding a fill light: a lower-intensity light coming in from a direction that illuminates the dark region. This can either be a separate light or a large diffuse surface to reflect a strong light source back at the target.

(a) Diffuse reflector being used during a photo shoot. Cropped from image by Brocken Inaglory, CC BY-SA 3.0, via Wikimedia Commons
(b) Adding a fill light to a rendered scene ensures everything is lit, which can be enough for simple 3D models.
Figure 4: Fill lights, real and virtual.

This is okay for simple landscapes, but it becomes problematic as you introduce features which create long shadows. It’s also a pain to arrange the perfect 3D orientation of lights to capture your scene: you have to position three objects in space (camera, fill light, key light) plus determine the right relative intensity of light. It’s a scene-dependent 10D optimization problem. For an example, let’s look at the Washington Monument lit by both a bright key light and a dimmer fill light.

Code 
#Set location of Washington Monument
washington_monument_location =  st_point(c(-77.035249, 38.889462))
wm_point = washington_monument_location |>
 st_buffer(0.002) |> 
 st_sfc(crs = 4326) |>
 st_transform(st_crs(washington_monument_multipolygonz)) 

elevation_data = elevatr::get_elev_raster(locations = wm_point, z = 14)

scene_bbox = st_bbox(st_buffer(wm_point,2000))
cropped_data = raster::crop(elevation_data, scene_bbox)

#Use rayshader to convert that raster data to a matrix
dc_elevation_matrix = raster_to_matrix(cropped_data)

#Remove negative elevation data
dc_elevation_matrix[dc_elevation_matrix < 0] = 0

#Plot a 3D map of the national mall
dc_elevation_matrix |>
 constant_shade(color="darkgreen") |> 
 add_shadow(lamb_shade(dc_elevation_matrix), 0) |> 
 plot_3d(dc_elevation_matrix, zscale=3.7, shadow=FALSE,
         soliddepth=-50, windowsize = 800)
render_multipolygonz(washington_monument_multipolygonz,
                    extent = raster::extent(cropped_data),
                    zscale = 4, color = "grey80",
                    heightmap = dc_elevation_matrix)
render_camera(238,15.5,0.8, fov = 43.4)
render_highquality(lightdirection = c(0,225), lightintensity = c(1500,500), samples=64, 
                   width = 800, height=400, lightsize = 200,
                   camera_location =c(72.49, 47.14, -0.53), camera_lookat =  c(-19.75, 8.30, -47.12),
                   lightaltitude=20)
rgl::close3d()
Figure 5: The Washington Monument, lit by two “suns”

You can see the two lights now create two separate shadows, on top of the shadows from the terrain. With one building on a relatively flat surface it isn’t too bad, but with many buildings or a more complex landscape, all the overlapping shadows can add a lot of visual clutter and noise to an image. To demonstrate, let’s render a fairly normal town center: Figure 6 shows an intersection surrounded by buildings in Monterey, California.

Code 
osm_bbox = c(-121.9472, 36.6019,  -121.9179, 36.6385)

opq(osm_bbox) |>
  add_osm_feature("building") |>
  osmdata_sf() ->
osm_data

opq(osm_bbox) |>
  add_osm_feature("highway") |>
  osmdata_sf() ->
osm_road

building_polys = osm_data$osm_polygons
osm_dem = elevatr::get_elev_raster(building_polys, z = 11, clip = "bbox")
e = extent(building_polys)

osm_dem |>
  crop(e) |>
  extent() ->
new_e

osm_dem |>
  crop(e) |>
  raster_to_matrix() ->
osm_mat

osm_mat[osm_mat <= 1] = -2

osm_mat |>
  constant_shade(color = "tan") |>
  plot_3d(osm_mat, water = TRUE, windowsize = c(800, 400), watercolor = "dodgerblue",
          zscale = 10, theta=220, phi=22, zoom=0.45, fov=110,
          background = "pink")

render_buildings(building_polys,  flat_shading  = TRUE,
                 angle = 30 , heightmap = osm_mat,
                 material = "white", roof_material = "white",
                 extent = new_e, roof_height = 3, base_height = 0,
                 zscale=10)
render_camera(fov=5, zoom = 0.04)
render_highquality(lightdirection = c(45,225), lightintensity = c(500,250), lightaltitude = 20, 
                   camera_location = c(-1203.09, 756.18, -1433.73), 
                   camera_lookat= c(6.43, -1.13, -32.40))
Figure 6: Buildings in Monterey, California. We render with two lights to avoid dark areas, but this results in lots of visual clutter from the overlapping shadows.

The issue is the sharpness and discreteness of the lights: it’s not aesthetically pleasing to have multiple sharply defined lights, and the marginal additional context the fill light provides is strongly counteracted by the visual mess it creates. Photographers face the same issue when capturing people in sunlight: direct sunlight creates unflattering and distracting sharp shadows across the face. What we need is some sort of gradual variation in light across the sky that provides a soft bright light but without sharp edges, something that provides the same overall directional information without the sharp lines. Thankfully, photographers have long figured out the solution to this, and it’s called… a sunset.

The golden hour… for dataviz?

There are two properties of sunsets that make for great photos, and thus (for our purposes) great 3D renderings. First, the atmosphere greatly attenuates direct sunlight close to sunset, making the difference between the direct and indirect lit areas on the subject much less stark, often described as the lighting ratio in cinematography. This lowers the contrast, softening those sharp lines. Cinematographers often target lighting ratios between 3:1 and 2:1 (in stops, which scale as ; 8:1 to 4:1 in linear terms) for illuminating faces1. Second, the thicker atmosphere at lower solar elevation angles scatters more short-wavelength light from the sun, producing warmer tones at sunrise. This dependence on solar elevation leads us to a fairly common definition of “golden hour:” when the sun is to from the horizon.

The name “golden hour” is rarely accurate, since the duration strongly depends on the latitude and time of year: near the poles, there are times of the year where the “golden hour” lasts all day long!

Figure 7 shows a chart of the CIE xy 1931 chromaticity diagram including the Planckian Locus. The Planckian locus is the path that a black body color will take through the diagram as the temperature changes. The hue of sunlight shifts from the right side of the black line to the left as the sun rises, and the time it spends in the yellow/red region is our “golden hour” lighting.

Somewhat confusingly to those of us who don’t think in terms of blackbody emission, “warmer” tones correspond to lower temperatures (~2,000K), while “cooler” tones correspond to higher temperatures (~5,500K).🤷
(a) CIE xy 1931 chromaticity diagram including the Planckian Locus. Sunlight can start at around 2,000 K shortly after sunrise or before sunset (depending on atmospheric conditions), rise to around 3,500 K during golden hour, and peaks around 5,500 K at midday.
(b) A photo of warm-toned sunset light looking extremely orange when juxtaposed next to the cool-toned light from the interior of the train.
Figure 7: From blackbody-like daylight to sunset color.

This color change results in dramatic color gradation across the sky (from orange hues near the sun to blues opposing it, which are still scattered blue indirect light) that naturally contours objects by color, versus providing that spatial contouring via shadow/light. Cinematographers use this technique all the time: cool/warm lights are often used as proxies for dark/light areas, allowing viewers to pick up on small changes in actors’ faces (for emotions, and whatnot) that might have been lost if half the actor’s face had been bathed in darkness.

Figure 8: From the last season of Stranger Things: Maya Hawke’s face is actually fairly evenly lit (intensity wise), with cold/warm lighting providing contouring instead of shadow.

HDR Environment Maps

There’s one easy way to add a sunset to a scene when pathtracing: an environment image. This is basically a HDR image of the real world that you use to light your scene. And thankfully, there’s a whole community of photographers who have provided these for free online, which you can find at Polyhaven. Environment lights are great because you get complex, natural lighting without micromanaging individual lights. Some of my favorites from Polyhaven are the following (click on a tab to stop cycling):

Code 
render_monterey = function(env_light = "kiara_1_dawn_2k.hdr", iso=100, samples=32,
                           ground_color ="grey20", shadow = TRUE, zoom = 0.45) {
  montereybay |>
    constant_shade(color="grey40") |>
    plot_3d(montereybay, windowsize = c(800,400), zscale=50, shadow = shadow)
  render_camera(zoom=zoom,theta=-90,phi=30)
  rayval = render_highquality(environment_light = env_light, iso = iso, samples = samples,
                     light=FALSE, water_ior = 1.2, 
                     ground_material = diffuse(color=ground_color), preview=FALSE, plot = FALSE)
  rgl::close3d()
  return(rayval)
}

Note that the sunset still gives a relatively bright highlight on the mountaintops, but the shadows otherwise are fairly soft throughout the terrain. And while the highlights are significantly brighter than the shaded regions, the bright and dark regions aren’t too different: we have just the right amount of contrast.

The obvious follow-up is: what happens when we choose a non-sunset? Here are a few examples of other environment lights from Polyhaven, taken either midday or indoors, with some more structured discrete lighting. Let’s see what those look like:

The primary problem we face here is the lack of balance between the shading from the ambient sky lighting and the direct light from the sun. Note the sharp shadow edges interspersed throughout the landscape and the dark shadows: one strong light tends to overwhelm everything around it. There’s too much contrast between the dark areas and the light areas: the light from the key light (here, the sun) dominates the image.

The hillshading surface ambiguity

And this isn’t just an aesthetic preference: direct lighting by itself doesn’t provide enough information to unambiguously reconstruct the 3D surface from a 2D projection. It’s a perceptual shortcoming of the hillshading method. Direct light (like from the sun) does allow you to judge the aspect (directionality) of a slope, but it suffers from one major flaw: it’s ambiguous whether you’re looking at a hill or a valley, unless you have long shadows (which we have seen above can cause other issues).

Mathematically, Lambertian lighting darkens the surface via the dot product between the light and the surface normal

For a height field (z = h(x,y)), a (unit) surface normal can be written as

where

The hill/valley ambiguity is a sign ambiguity: if you invert the terrain (), then (), the normal becomes

Now decompose the light direction into horizontal and vertical components () with (). The Lambertian dot product is

If you also flip the horizontal light direction (equivalently rotate azimuth by ), (), then

So the directed shading field is identical under the paired transformation

i.e., “hill with light from azimuth ()” produces the same Lambertian shading as “valley with light from azimuth ()”).

We can demonstrate this effect by visualizing the same terrain, first visualized normally and then visualized inverted with the sun flipped around:

Code 
montereybay |> 
  lamb_shade(zscale=30, sunangle = 315) |> 
  plot_3d(montereybay, zscale=30, windowsize=600, zoom=0.9)

output1 = render_movie(frames = 120, theta = rep(55,120), type="custom", 
             phi = tweenr::tween_t(c(90,45,90),n=120,ease="cubic-in-out")[[1]],
             zoom=rep(0.9,120),filename="innie.mp4")
rgl::close3d()

-montereybay |> 
  lamb_shade(zscale=30, sunangle = 315+180) |> 
  plot_3d(-montereybay, zscale=30, windowsize=600)

output2 = render_movie(frames = 120, theta = rep(55,120), type="custom", 
             phi = tweenr::tween_t(c(90,45,90),n=120,ease="cubic-in-out")[[1]],
             zoom=rep(0.9,120),filename="outie.mp4")
rgl::close3d()
system("ffmpeg -y -i innie.mp4 -i outie.mp4 -filter_complex hstack -pix_fmt yuv420p ../videos/2026/inner_outie.mp4")
Figure 9: Comparing hillshades computed on terrain and inverted terrain with a mirrored light.

Figure 9 shows that when the camera is directly overhead, the two hillshades are identical. The traditional solution cartographers developed for this problem (and have stuck with for several centuries) is to stick with one convention for the direction of light, for all maps, until the heat death of the universe: Northwest, or . With the idea being that if every terrain map is always lit from the same direction, you’ll never encounter this ambiguity, because you have been subliminally trained your entire life to see light coming from the northwest.

Or, in other words, a cartel of cartographers formed an illumination illuminati to plot an influence campaign so you would understand their plots.

The conspiracy goes all the way to the northwest.

This convention is a little odd, however, because you only encounter light coming from the northwest near the poles. Greater than latitude, to be exact: in effect, all terrain maps are pretending to be Norwegian.

Note

In a post on this very issue, the cartographer Tom Patterson discussed an interesting hypothesis on why northwest ended up becoming the standard in hillshading:

“Because most people are right handed, when we write or draw we tend to place desk lighting above and to the left so as not to cast shadows over our work. Moreover, our work generally progresses from upper left to lower right, minimizing the possibility for smearing. […] When depicting shaded relief and other 3D phenomena on a flat sheet of paper, we naturally take a cue from the lighting within our work place environment and apply shadows to the lower right sides of slopes. Centuries of depicting topography in this manner has ingrained this cartographic convention.”

Adding ambient shading solves this ambiguity by breaking the symmetry: it models how much of the sky is visible at each point, so valleys are darkened while ridges are not. By layering an ambient layer with the direct lighting layer, it becomes clear what is a valley and what is a ridge. But these two terms need to be fairly balanced: if the key light term dominates, it is harder for the ambient term to break the ambiguity.

Code 
montereybay |> 
  constant_shade() |> 
  add_shadow(lamb_shade(montereybay, zscale=100),0) |> 
  plot_map()

montereybay |> 
  constant_shade() |> 
  add_shadow(ambient_shade(montereybay, zscale=5),0) |> 
  plot_map()

montereybay |> 
  constant_shade() |>
  add_shadow(ambient_shade(montereybay,zscale=5),max_darken = 0) |> 
  add_shadow(lamb_shade(montereybay,zscale=100),max_darken = 0) |> 
  plot_map()
Figure 10: Direct lighting (from the sun). Note the ambiguity in depth: you can interpret the terrain as hills or valleys.
Figure 11: Ambient lighting (uniform lighting from the sky).
Figure 12: Combined ambient and direct. Using both terms breaks the symmetry and removes the ambiguity.

Sunset contrast, hues, and lighting ratios

This solution is great for 2D hillshades, but it also gives us a good rule of thumb to help make static 2D projections of 3D visualizations more interpretable: When your lighting results in these two terms being around the same intensity, you’re likely in a good place visually. Sunsets and sunrises offer much more balanced amounts of direct and indirect light than the mid-day sun, so surfaces retain clear directional shading without plunging half the scene into near-black shadow: you get shape cues and visible detail in valleys, crevices, and between structures, with far less harsh edge contrast. In fact, if by some chance we had an accurate model of the indirect and direct lighting from the atmosphere (spoiler alert!), we could compare the hue and brightness from opposite sides of the atmosphere and see how the lighting ratio and color change with solar elevation. We might get something like this:

Code 
hue_diff_oklab_linear_srgb = function(rgb1, rgb2, sat_eps = 0.02) {
  stopifnot(length(rgb1) == 3, length(rgb2) == 3)
  if (!requireNamespace("farver", quietly = TRUE)) {
    stop("Install farver: install.packages('farver')")
  }

  rgb = rbind(as.numeric(rgb1), as.numeric(rgb2))
  rgb = pmax(rgb, 0)

  M = matrix(
    c(0.4124, 0.3576, 0.1805,
      0.2126, 0.7152, 0.0722,
      0.0193, 0.1192, 0.9505),
    nrow = 3, byrow = TRUE
  )
  xyz = rgb %*% t(M)

  oklab = farver::convert_colour(
    xyz, from = "xyz", to = "oklab",
    white_from = "D65", white_to = "D65"
  )

  L = oklab[, 1]
  a = oklab[, 2]
  b = oklab[, 3]
  C = sqrt(a^2 + b^2)
  sat = C / pmax(L, 1e-12)
  if (any(sat < sat_eps) || any(!is.finite(sat))) return(NA_real_)

  h = atan2(b, a) * (180 / pi)
  abs(((h[2] - h[1] + 180) %% 360) - 180)
}

ratio_to_stops = function(ratio) log(ratio, base = 2)

luma_from_rgb = function(rgb) {
  0.2126 * rgb[, 1] + 0.7152 * rgb[, 2] + 0.0722 * rgb[, 3]
}

img_stats = function(rgba) {
  R = rgba[, , 1]
  G = rgba[, , 2]
  B = rgba[, , 3]
  rgb = cbind(R, G, B)
  Y = luma_from_rgb(rgb)

  list(
    luma = stats::median(Y, na.rm = TRUE),
    rgb = c(mean(R, na.rm = TRUE), mean(G, na.rm = TRUE), mean(B, na.rm = TRUE))
  )
}

calculate_values = function(elev_angle = 10, dimval = 1500, dist = 10,
                            ortho_size = 0.05, samples = 256,
                            save_dir = ".", save_renders = TRUE) {

  skyfile = tempfile(fileext = ".exr")
  skymodelr::generate_sky(
    azimuth = 180,
    resolution = dimval,
    elevation = elev_angle,
    number_cores = 8,
    hosek = FALSE,
    render_mode = "all",
    filename = skyfile
  )

  common_args = list(
    sphere(radius = 0.5, material = diffuse()),
    samples = samples, denoise = FALSE, bloom = FALSE, min_adaptive_size = 1,
    fov = 0, # orthographic
    ortho_dimensions = c(ortho_size, ortho_size), # small "metering window"
    preview = FALSE,
    lookat = c(0, 0, 0),
    environment_light = skyfile,
    transparent_background = TRUE
  )

  img_key = do.call(render_scene, c(common_args, list(lookfrom = c(0, 0, -dist))))
  img_fill = do.call(render_scene, c(common_args, list(lookfrom = c(0, 0, dist))))

  s_key = img_stats(img_key)
  s_fill = img_stats(img_fill)

  ratio = s_key$luma / pmax(s_fill$luma, 1e-6)
  stops = ratio_to_stops(ratio)

  hue_diff = hue_diff_oklab_linear_srgb(s_fill$rgb, s_key$rgb, sat_eps = 0.02)

  if (isTRUE(save_renders)) {
    fn_key = file.path(save_dir, sprintf("patch_key_elev_%+03d.png",
                                         as.integer(round(elev_angle))))
    fn_fill = file.path(save_dir, sprintf("patch_fill_elev_%+03d.png",
                                          as.integer(round(elev_angle))))
    rayimage::ray_write_image(img_key, fn_key)
    rayimage::ray_write_image(img_fill, fn_fill)
  }

  data.frame(
    key_level = s_key$luma,
    fill_level = s_fill$luma,
    ratio = ratio,
    stops = stops,
    hue_diff = hue_diff,
    elevation = elev_angle
  )
}

elevation_angles = seq(0, 20, by = 1)
lighting_ratio = lapply(elevation_angles, \(a) calculate_values(a, dimval = 5000))
lighting_ratio_df = do.call(rbind, lighting_ratio)
1
Compute hue separation in OKLab from two linear-sRGB RGB triplets, with a saturation gate to avoid unstable hue near gray.
2
Clamp negative channels before color transforms (defensive against numerical noise).
3
Convert linear sRGB to XYZ (D65) with a standard matrix.
4
Convert XYZ to OKLab with farver.
5
Compute chroma and relative saturation (C/L); return NA if either side is too desaturated.
6
Compute the shortest-path hue angle difference (degrees).
7
Convert a linear key/fill ratio to stops using log2().
8
Compute linear luminance from linear RGB (no transfer curve).
9
Summarize a rendered RGBA patch.
10
Extract RGB samples and compute per-pixel luminance.
11
Use median luminance (robust brightness) and mean RGB (representative color) over the patch.
12
Full measurement for one solar elevation with a small orthographic “metering window”.
13
Allocate a temporary EXR filename for the sky environment map.
14
Generate the sky (Prague) for the given solar elevation.
15
Centralize common render arguments to keep key/fill renders identical except for viewpoint.
16
Use orthographic projection (fov = 0) so the “patch” is a literal fixed-size window in scene units.
17
Set ortho_dimensions to a small size (e.g. 0.05 x 0.05) so the entire render is the sampled region.
18
Render the key-side patch from lookfrom = (0,0,-dist) toward the origin.
19
Render the fill-side patch from the opposite viewpoint lookfrom = (0,0,+dist) (180 degrees opposed).
20
Compute per-side brightness and mean color from the full patch image.
21
Compute key/fill ratio and convert to stops.
22
Compute hue difference between the two patch-average colors in OKLab.
23
Optionally write the two sampled patch renders to disk for inspection.
24
Return a tidy row with brightness, ratio/stops, hue difference, and elevation.
25
Sweep over elevations and row-bind results into a single data frame.
Figure 13: We treat the atmosphere like a cinematography lighting setup. For each solar elevation, we render a diffuse sphere from the sun-facing (key) side (a) and the opposite (fill) side (b). We then (c) compute a key/fill lighting ratio from opposing sides (black dashed line) as well as a color separation as an OKLab hue difference between the key-side and fill-side mean RGB (red dashed line). The solar elevation angles corresponding to lighting ratios of 3:1 to 1:1 are shown.

Figure 13 shows that the lighting ratio reaches the cinematography sweet spot of 3:1 right around , which also happens to be the commonly stated range for when the photographic golden hour begins! We also see that while the lighting ratio decreases, the color (hue) shift stays fairly high across shapes until very low solar elevations. The difference between the red curve and the black is what makes the golden hour so magical: as the contrast between the fill and the key light decreases, the difference in hues between the two sides becomes more apparent. Sunset is thus the period of time when objects are primarily contoured in color, rather than in brightness.

The problem with HDR images as environment lights

So HDR environment images of sunsets provide an easy way to get natural, soft lighting that’s easy to interpret. However, there are downsides to environment lights. Because the image is fixed, there’s not much you can do to customize the light. You can rotate it, but the overall color and light distribution with respect to the horizon can’t be changed. Also, with that beautiful real-world lighting often come pesky real-world people and objects: it might be confusing why someone is behind your scene, staring back at your viewer.

Figure 14: ‘Look, babe: someone reading a blog post.’

This isn’t an issue if you’re always looking down on the map from above, but for oblique views this is a huge drawback. Good data visualization designers know that every element in a visualization should serve a purpose; everything in a dataviz that doesn’t in some way contribute to a reader’s understanding lowers the visualization’s signal-to-noise ratio. And that’s bad.

It would be nice to have a clean, customizable environment map that gives us that pristine golden-hour light without any real-world interlopers. Is this a realistic goal–or is it just a pie in the sky dream?

Generating a synthetic sky

The dumber the joke, the more research it deserves

Thankfully, graphics researchers have developed two atmospheric models within the last 15 years that do just that. These models take atmospheric and positional inputs (such as viewer altitude, visibility, atmospheric turbidity, and sun position) and return radiance values for various angles, altitudes, and light wavelengths. We can calculate what the sky would look like for a given set of inputs by sampling on a sphere and then writing that to an environmental light. I’ve written an R package, skymodelr, that does all of that (and more): it generates HDR environment maps given a desired set of atmospheric inputs.

The most basic function available is generate_sky(): you specify a sun position in the sky (azimuth and angle around the sphere), and it generates a sky model. We can then pass this environmental light to our scene. Note that since we’re using realistic lighting, we need to adjust the exposure for proper display on the web.

library(skymodelr)

generate_sky(resolution = 800, 
             azimuth = 180, 
             elevation = 20, 
             hosek = FALSE,
             filename="demo_sky.exr") |> 
  render_exposure(-6) |>
  plot_image()
Figure 15: We adjusted exposure down six stops (2^6, multiplying it by 1/64) to bring the values into the range of a low dynamic-range format. Note that pathtraced renders should never do this: you want to adjust the exposure of the render instead (via the ISO argument, or with a post-process step). 
library(skymodelr)

generate_sky(resolution = 800, 
             azimuth = 180, 
             elevation = 20, 
             hosek = FALSE,
             filename="demo_sky.exr") |>
  # No exposure adjustment 
  plot_image()
Figure 16: Yes, this “sky” is just a white and black rectangle. The raw output of the atmospheric model uses values greater than one, so those get clipped to white when converting to a JPEG/PNG for the web.

From radiance to RGB

NoteReal talk

Honestly, you can skip this section and proceed onwards unless you’re interested in the nuts and bolts of how the package turns spectral radiance measurements into colors on your screen. I won’t be offended. Truly.

The atmospheric model returns spectral radiance values at a fixed set of wavelengths (in this implementation, the Prague model is evaluated on an 18-band grid from 360 to 700 nm in 20 nm steps). To turn those spectral samples into an RGB image, we approximate the continuous spectral-to-color integral: each wavelength contributes to perceived color in proportion to the CIE 1931 2-degree color matching functions (, , ), which map monochromatic light into CIE XYZ tristimulus space (basically, a vector space designed to match our perception of color).

Figure 17: CIE 1931 2-degree color matching functions with the Prague model’s 20 nm sampling grid. These weights come from classic color-matching experiments: observers viewed a small (2°) patch of monochromatic test light and adjusted the intensities of three fixed primary lights to produce a perceptual match. The recorded primary mixtures, collected across wavelengths and averaged over many observers, define wavelength-by-wavelength “matching” curves; they are then linearly transformed into the CIE XYZ system (with Y chosen to track perceived luminance), yielding the (, , ) functions used to convert a sampled spectrum into tristimulus values. The XYZ columns roughly correspond to red, green, and blue, respectively.

We then map into the linear sRGB space displayed on our monitors with a 3 x 3 linear transform (assuming a D65 white point and the standard sRGB primaries). Written explicitly,

Multiplying this matrix with our XYZ curve gives us our spectrum-to-RGB weights:

Some projected sRGB weights dip below zero because sRGB is a change of basis from XYZ, but the final RGB colors are clamped so rendered pixels never have negative channels.

The triangle region represents the gamut of the sRGB colorspace: you can see there are a lot of colors that we can perceive (the area outside the triangle) that sRGB can’t represent.

From here, each pixel direction in the sky dome yields a spectrum , which we reduce to an RGB triplet via the weighted sum above. Interpreting the result as radiance, we store it in a latitude-longitude environment map. During rendering, the environment map acts as a distant light source: a shading point samples directions on the hemisphere, queries the environment radiance for those directions, and accumulates the resulting light.

Bringing OpenEXR to R

Because the Prague model strives for accuracy and returns realistic radiance values for each wavelength, after we run this mathematical machinery we get extremely high brightness values: even the scattered atmospheric light will blow out a low-dynamic range image format like a PNG (which can only represent 8 stops of dynamic range). If we save the image in a format that preserves the full dynamic range, we can adjust the exposure in a post-processing step. Basically, we need to save our images in the rendering equivalent of a photographic RAW image: the OpenEXR format, which preserves the full dynamic range of images. It does this by saving images in arrays of half (16-bit floats) or optionally full floats. Saving images in EXR in R is possible because I spent a good portion of 2025 getting the OpenEXR infrastructure (libopenexr/libimath/libdeflate) onto the CRAN to bring full EXR support to R. This is all wrapped up in the libopenexr package, which provides the write_exr() and read_exr() functions, as well as static libraries to link into compiled code. EXR images bring a much wider dynamic range than standard web formats, allowing you to losslessly capture and process realistic, high-dynamic range content. So any scene rendered with atmospheric lighting saved in the EXR format will have all the precision preserved and allow for post-render exposure control.

Table 1: Comparison of dynamic ranges.
Format Dynamic range (stops) Approx. ratio (max / min)
JPEG 8-bit 8 28 = 256 : 1
PNG 8-bit 8 28 = 256 : 1
PNG 16-bit 16 216 = 65,536 : 1
Outdoor scene ≈25–35 (scene-dependent) 230 ≈ 1 billion : 1
OpenEXR Half ≈ 30 230 (40 incl. subnormals) ≈ 1 billion : 1
OpenEXR Float ≈ 255 2255 normal (277 incl. subnormals) ≈ 1076 : 1 (effectively unlimited)

skymodelr saves images with full float precision, which is important if you’d want to do something like, let’s say, add realistic star field rendering to the package. Half has plenty of theoretical headroom, but its shadow precision behaves like a low-bit-depth capture once you expose for the highlights; stars are extremely faint and can end up below the effective noise/quantization floor. This is a problem if you want to do something fun like render realistic star trails from a long exposure.

Figure 18: Like this! Summing up small but repeated contributions can lead to visual artifacts if those contributions are subject to quantization error. Non-pixelated rendering of point-like sources like stars requires splatting some of the light to the surrounding pixels, so the source doesn’t “jump” from pixel to pixel. This proportional splatting can result in even smaller values that are lost when your image format doesn’t have enough precision.

In the real world, cranking up ISO to increase the contrast of an underexposed image also boosts noise, as you’re amplifying a signal with a low signal-to-noise ratio. In our artificially rendered world we don’t have to worry about that: we have an idealized camera with no noisy electronics measuring our image, so we can freely scale our image into whatever range we need. In fact, we can render all of our images at whatever ISO we want and rescale them afterwards with rayimage::render_exposure(). I use both methods, because adjusting exposure in stops (which scale as ) is good for when you’re way off, but sometimes you just need a slight linear tweak to capture a highlight, which you can do by adjusting the ISO.2

Although we have to instead contend with Monte Carlo rendering noise.
render_monterey("demo_sky.exr", iso = 5) |>  
  plot_image()

We dial the ISO (here, effectively exposure) between 5 and 100 and find a sweet spot around ISO = 10. At ISO = 30, the RGB values will be greater than 1 and will thus be clipped to white. ISO = 100 gets blown out completely.
render_monterey("demo_sky.exr", iso = 10) |>  
  plot_image()

We dial the ISO (here, effectively exposure) between 5 and 100 and find a sweet spot around ISO = 10. At ISO = 30, the RGB values will be greater than 1 and will thus be clipped to white. ISO = 100 gets blown out completely.
render_monterey("demo_sky.exr", iso = 30) |>   
  plot_image()

We dial the ISO (here, effectively exposure) between 5 and 100 and find a sweet spot around ISO = 10. At ISO = 30, the RGB values will be greater than 1 and will thus be clipped to white. ISO = 100 gets blown out completely.
render_monterey("demo_sky.exr", iso = 100) |>  
  plot_image()

We dial the ISO (here, effectively exposure) between 5 and 100 and find a sweet spot around ISO = 20. At ISO = 30, the RGB values will be greater than 1 and will thus be clipped to white. ISO = 100 gets blown out completely.

Two models: Hosek and Prague

Speaking of multiple options, skymodelr provides both the Hosek (2013) atmosphere model and the newer Prague (2022) model. The Hosek model is less accurate, but useful because it doesn’t require any additional downloads and can live on the CRAN as-is; the Prague model needs to download some coefficient tables to function (107 MB ground-level only, 574 MB ground-level wide spectral range, and 2.4 GB for the full altitude model). Those aren’t included in the package by default but will be downloaded as needed when you first call the function, and are cached so they only need to be downloaded once.

Just a little bit bigger than CRAN’s 5MB limit.
Code 
demo_sky_sunset = generate_sky(
  elevation = 1, azimuth = 270, 
  hosek = TRUE, visibility = 120, albedo = 1,  
  resolution = 800, number_cores = 8,
  filename = "demo_sky_sunset.exr"
)
mb_subset = render_monterey("demo_sky_sunset.exr", iso = 80, samples = 32)
plot_image_grid(list(render_exposure(demo_sky_sunset, -6), 
                     mb_subset), dim = c(1, 2))

Code 
demo_sky_sunset = generate_sky(
  azimuth = 270,   elevation = 1,
  hosek = FALSE, visibility = 120, albedo = 1,
  resolution = 800, number_cores = 8,
  filename = "demo_sky_sunset.exr"
)
mb_subset = render_monterey("demo_sky_sunset.exr", iso = 100, samples = 32)
plot_image_grid(list(render_exposure(demo_sky_sunset, -4), 
                     mb_subset),dim = c(1, 2))

Code 
demo_sky_daytime = generate_sky(
  azimuth = 270, elevation = 45, 
  hosek = TRUE, visibility = 120, albedo = 1,
  resolution = 800, number_cores = 8,
  filename = "demo_sky_daytime.exr"
)
mb_subset_day = render_monterey("demo_sky_daytime.exr", iso = 100, samples = 32)
plot_image_grid(list(render_exposure(demo_sky_daytime, -6), 
                     render_exposure(mb_subset_day,-4)),dim = c(1, 2))

Code 
demo_sky_daytime2 = generate_sky(
  azimuth = 270, elevation = 45,
  hosek = FALSE, visibility = 120, albedo = 0,
  resolution = 800, number_cores = 8,
  filename = "demo_sky_daytime2.exr"
)
mb_subset_day2 = render_monterey("demo_sky_daytime2.exr", iso = 100, samples = 32)
plot_image_grid(list(render_exposure(demo_sky_daytime2, -6), 
                     render_exposure(mb_subset_day2, -4)),dim = c(1, 2))

For sea-level renders, the major difference between the two models is the color accuracy: the Hosek daytime colors are just a little too blue, while the sunset is just a little too yellow.

In addition to accuracy, the Prague model adds in some cool features: most notably that it allows you to simulate the atmosphere up to an altitude of 15,000 meters. At those heights you are actually above the bulk of the atmosphere, and thus most of the scattered blue light of the sky is actually coming from below you. The resulting render feels much more like “space” than sky. The scene at 10,000 meters below will also be familiar if you’ve ever flown (and failed to sleep) on a red-eye: the appearance of the sunrise/sunset at 30,000 ft is distinctively different than at ground level.

It also adds a wide spectral version that supports near UV and near infrared up to 2480nm wavelength
Code 
demo_sky_45_1000 = generate_sky(resolution = 800, azimuth = 225, hosek = FALSE,
                               visibility = 120, altitude = 1000,
                               albedo = 1 , number_cores = 8, 
                               elevation = 45)

render_exposure(demo_sky_45_1000, -7, preview=TRUE)
demo_sky_1_1000 = generate_sky(resolution = 800, azimuth = 225, hosek = FALSE,
                               visibility = 120, altitude = 1000,
                               albedo = 1 , number_cores = 8, 
                               elevation = 1)

render_exposure(demo_sky_1_1000, -5, preview=TRUE)

1,000m, Sun elevation: 45 degrees (midday)

1,000m, Sun elevation: 1 degree (sunset)
Code 
demo_sky_45_5000 = generate_sky(resolution = 800, azimuth = 225, hosek = FALSE,
                               visibility = 120, altitude = 5000,
                               albedo = 1 , number_cores = 8, 
                               elevation = 45)

render_exposure(demo_sky_45_5000, -7, preview=TRUE)
demo_sky_1_5000 = generate_sky(resolution = 800, azimuth = 225, hosek = FALSE,
                               visibility = 120, altitude = 5000,
                               albedo = 1 , number_cores = 8, 
                               elevation = 1)

render_exposure(demo_sky_1_5000, -5, preview=TRUE)

5,000m, Sun azimuth: 45 degrees (midday)

5,000m, Sun azimuth: 1 degree (sunset)
Code 
demo_sky_45_10000 = generate_sky(resolution = 800, azimuth = 225, hosek = FALSE,
                                 visibility = 120, altitude = 10000,
                                 albedo = 1 , number_cores = 8, 
                                 elevation = 45)

render_exposure(demo_sky_45_10000, -7, preview=TRUE)
demo_sky_1_10000 = generate_sky(resolution = 800, azimuth = 225, hosek = FALSE,
                                visibility = 120, altitude = 10000,
                               albedo = 1 , number_cores = 8, 
                               elevation = 1)

render_exposure(demo_sky_1_10000, -5, preview=TRUE)

10,000m, Sun azimuth: 45 degrees (midday)

10,000m, Sun azimuth: 1 degree (sunset)
Code 
demo_sky_45_15000 = generate_sky(resolution = 800, azimuth = 225, hosek = FALSE,
                                 visibility = 120, altitude = 15000,
                                 albedo = 1 , number_cores = 8, 
                                 elevation = 45)

render_exposure(demo_sky_45_15000, -7, preview=TRUE)
demo_sky_1_15000 = generate_sky(resolution = 800, azimuth = 225, hosek = FALSE,
                                visibility = 120, altitude = 15000,
                                albedo = 1 , number_cores = 8, 
                                elevation = 1)

render_exposure(demo_sky_1_15000, -5, preview=TRUE)

15,000m, Sun azimuth: 45 degrees (midday)

15,000m, Sun azimuth: 1 degree (sunset)

Lighting real world places with rayshader

We also get a very practical use from this package elsewhere in the rayverse: we can now generate realistically lit landscapes in rayshader with just a latitude, longitude, and date and time! skymodelr implements this in the function generate_sky_latlong. Instead of manually specifying an azimuth and elevation for our sun, we just pass in a location and time, and skymodelr will use the suncalc package to calculate the sun’s elevation and azimuth in the sky. This allows us to generate accurate depictions of how shadows fall across real-world places, taking into account both direct sunlight as well as indirect atmospheric scattered lighting. The latter is critical for rendering dramatic terrain: for example, visualizing lighting in deep valleys or between skyscrapers.

As an example, let’s look at the difference between the Rio Grande gorge in New Mexico, as seen right after sunrise (specifically, around 6:20 AM in mid-July, since that’s where I found some good reference photographs with a specified date and time). We’ll visualize it three ways: first, with just a simple sphere representing the sun, then with a carefully colored sphere with a blue/white gradient sky, and then with the full atmospheric model:

Code 
center_lon = -105.7334
center_lat = 36.4756
datetime_sunrise = as.POSIXct("2025-07-22 06:15:00", tz="America/Denver")

d = 0.005
aoi = st_as_sfc(st_bbox(c(
  xmin = center_lon - d, ymin = center_lat - d,
  xmax = center_lon + d, ymax = center_lat + d
), crs = 4326))

aoi_sf = st_sf(geometry = aoi)

bbox_ll = st_bbox(aoi)

q_waterway = opq(bbox = bbox_ll, timeout = 240) |>
  add_osm_feature(key = "waterway")
Sys.sleep(1)

osm_waterway = osmdata_sf(q_waterway)
water_lines = osm_waterway$osm_lines

aoi_utm = st_transform(aoi_sf, 32613)
water_lines_utm = st_transform(water_lines, 32613)
dem = get_elev_raster(locations = aoi_sf, z = 14, src = "aws" )
dem_t = rast(dem)

# UTM 13N covers Taos/Rio Grande Gorge area
dem_utm = project(dem_t, "EPSG:32613", method = "bilinear", res = 10)
dem_utm = trim(dem_utm)
dem_r = raster(dem_utm)
elmat = raster_to_matrix(dem_r) |> 
  rayimage::render_resized(mag=5) |> 
    (\(x) {
    x[is.na(x)] = NA
    x
  })()

water_overlay = generate_line_overlay(
  geometry = water_lines_utm,
  extent = raster::extent(dem_r),
  heightmap = elmat,
  color = "deepskyblue2",
  linewidth = 10
)

tex = elmat |>
  sphere_shade(texture = "imhof4") |>
  add_overlay(water_overlay, alphalayer = 0.9)

sunpos = suncalc::getSunlightPosition(
  lat = center_lat, 
  lon = center_lon, 
  date = datetime_sunrise
)[c("altitude","azimuth")]*180/pi


demo_sky_sunset_nm = generate_sky_latlong(
  lat = center_lat, lon = center_lon, 
  datetime = datetime_sunrise,
  resolution = 1600, hosek = FALSE, visibility = 120, altitude = 0, verbose = TRUE,
  albedo = 1, number_cores = 8, filename="demo_sky_sunset_nm.exr"
)

plot_3d(
  hillshade = tex,
  heightmap = elmat,
  zscale = 2,
  solid = TRUE,
  shadow = TRUE,
  windowsize = c(800, 600),
  theta = 315, phi = 40, 
  zoom = 0.75, fov = 70
)

constant_shade(matrix(1,100,100), color = "lightblue") |> 
  rayimage::ray_write_image("lightbluesky.png")

lookfrom = c(-208.69, 58.10, 870.62)
lookat = c(514.54, -80.26, -1624.73)


render_highquality(
  sample_method = "sobol",
  clamp_value = 10000, 
  lightaltitude = sunpos[["altitude"]], 
  lightdirection = 180+sunpos[["azimuth"]],  #suncalc measures from south
  lightsize = 100, 
  lightintensity = 10000, 
  camera_location = lookfrom, camera_lookat = lookat, aperture=0,
  width = 800, height=600, #preview = FALSE, plot = TRUE, 
  cache_scene = TRUE
)
render_highquality(
  sample_method = "sobol",
  clamp_value = 1000, 
  lightaltitude = sunpos[["altitude"]], 
  lightdirection = 180+sunpos[["azimuth"]], 
  lightsize = 100, 
  lightcolor = "#ff7403",
  lightintensity = 20000, 
  ambient_light = TRUE,
  backgroundlow="white", backgroundhigh = "#3C4B6B",
  camera_location = lookfrom, camera_lookat = lookat, aperture=1,
  width = 800, height=600, preview = FALSE, plot = TRUE, cache_scene = TRUE
)
render_highquality(
  sample_method = "sobol",
  clamp_value = 1000,
  light=FALSE,
  environment_light = "demo_sky_sunset_nm.exr", iso = 25,
  camera_location = lookfrom, camera_lookat = lookat, aperture=1,
  width = 800, height=600, preview = FALSE, plot = TRUE, cache_scene = TRUE
)
rgl::close3d()

Rio Grande gorge, no atmosphere, sun modeled as a simple emitting sphere.

Rio Grande gorge, blue-white gradient atmosphere, sun modeled as a yellow/orange emitting sphere.

Rio Grande gorge, Prague atmosphere model with sun.

It’s clear above that the single light version isn’t going to cut it with this type of terrain: we need indirect lighting from the atmosphere to light up dramatic terrain like this. The middle version is passable as an overcast day, but it’s not very visually interesting. The right version? Makes me want to grab a coffee and enjoy a crisp desert morning in a national park.

One nice thing about the newer Prague atmospheric model is that it actually allows us to model the atmosphere when the sun is below the horizon. This allows us to render spaces with the really nice color gradient of a sunset without any harsh direct lighting at all. We can also use the rayimage package to perform some stylistic color transformations on the render (white balance adjustments/saturation tweaks) to make the color contouring more obvious.

Modern smartphones also attempt to automatically adjust the white balance in their image processing pipeline, which can actually end up killing many of the nice colors from a sunset.
Code 
sky_after_sunset = generate_sky_latlong(
  lat         = 38.9072,
  lon         = -77.0369,
  datetime = as.POSIXct("2025-12-29 16:59:00", tz = "EST"),
  resolution = 800, hosek = FALSE, visibility = 120,
  albedo = 1 , number_cores = 8, verbose = TRUE,
  filename="sky_after_sunset.exr"
)

mb_sunset = render_monterey("sky_after_sunset.exr", iso=1000, samples = 32)
mb_custom_style = mb_sunset |> 
  render_white_balance(target_white = "D50") |> 
  render_vibrance(vibrance = 0.25,protect_luminance = 0.10) |> 
  render_exposure(0.3)

However, if we don’t care about adhering to the pesky rules of physics, these models also allow us to cheat: we can generate a sky that has all the scattered skylight, but doesn’t include the direct contribution from the sun’s disk.

Code 
sky_midday = generate_sky_latlong(
  lat      = 38.9072,
  lon      = -77.0369,
  datetime = as.POSIXct("2025-06-21 15:00:00", tz = "EST"),
  resolution = 800, hosek = FALSE, visibility = 120,
  albedo = 0 , number_cores = 8, verbose = TRUE, 
  render_mode = "atmosphere",
  filename="sky_midday.exr"
) |> 
  render_exposure(-5)

mb_midday = render_monterey("sky_midday.exr", iso=40, samples = 32)

plot_image_grid(list(sky_midday, mb_midday), dim=c(1,2))

My opinion? It’s okay. Not as good as the sunset, due to the overbearing blueness. But you’ll notice the same thing in real life if you carefully look at objects in shadow under the midday sun: everything has a slight blue cast to it that your eyes do a good job “color correcting” away.

Most of the time. Remember 2015’s #dressgate? Black and gold? Blue and white? Ah, the halcyon days when social media wasn’t a cesspool and we spent our time arguing about color perception and white points.

Now that we can generate our artificial skies, we can move on to the next challenge: how do we properly integrate them into our 3D scenes to represent real places? We have a 3D model that represents a real location and we have to ensure that the sky coordinate system and the geospatial coordinate system align. Basically, we need the XZ axis in our 3D model to align with our environment map orientation. How do we do that? Well, one way to solve it is to just tell people to stick with one convention for the direction of North, for all maps, until the heat death of the universe. North is +Z and East is +X.3

There, wasn’t that easy? I take it back–the cartographer Illuminati had the right idea. So much easier (for me).4

Examples

That’s enough about how it works. Let’s see the package in action: lighting actual 3D scenes.

Manhattanhenge

To stress test the package, let’s choose a rather difficult example that requires a precise alignment between geospatial data and the sun to observe: Manhattanhenge! Also called the “Manhattan Solstice,” it’s a cosmic alignment between the east–west grid of New York City and the setting sun that occurs a few times a year.

Figure 19: Picture cropped from an image provided by Flickr user felstone, CC BY-NC 2.0

This is a particularly challenging problem because not only do the terrain and sky need to be aligned, but so do the building footprints: we’re trying to seamlessly combine three separate datasets: sky, ground, and polygon. It’s a good integrated test of rayshader’s render_polygons()/render_buildings() logic. Let’s fly through the streets of Manhattan and see how well it lines up:

Code 
planar_crs = "EPSG:32118" # or 32618

lower_man_bbox = c(
  xmin = -73.958,
  ymin = 40.757,
  xmax = -74.005,
  ymax = 40.77
)

q = opq(
  bbox = c(
    lower_man_bbox["xmin"],
    lower_man_bbox["ymin"],
    lower_man_bbox["xmax"],
    lower_man_bbox["ymax"]
  )
) |>
  add_osm_feature(key = "building")
osm = osmdata_sf(q)

bldg_polys = bind_rows(
  osm$osm_polygons |>
    dplyr::select(any_of(c("building", "height", "building:levels")), geometry),
  osm$osm_multipolygons |>
    dplyr::select(any_of(c("building", "height", "building:levels")), geometry)
) |>
  st_make_valid()

lower_man_poly = st_as_sfc(
  st_bbox(lower_man_bbox, crs = 4326)
)

parse_height_numeric = function(x) {
x_num = gsub("[^0-9\\.]", "", x)
  as.numeric(x_num)
}

bldg_polys = bldg_polys |>
  mutate(
    height_m = parse_height_numeric(height),
    levels = suppressWarnings(as.numeric(`building:levels`)),
    height_m = case_when(
      !is.na(height_m) ~ height_m,
      is.na(height_m) & !is.na(levels) ~ levels * 3,
      TRUE ~ NA_real_
    )
  ) |>
  filter(!is.na(height_m)) |>
  filter(height_m < 1000)

bldg_polys = bldg_polys |>
  mutate(top_height = height_m)


lower_man_poly_planar = st_transform(lower_man_poly, planar_crs)
bldg_polys_planar = bldg_polys |>
  st_make_valid() |>
  st_transform(planar_crs)

ll_proj = "+proj=longlat +datum=WGS84 +no_defs"

bb = st_bbox(lower_man_poly)

loc_df = data.frame(
  x = c(bb["xmin"], bb["xmax"]),
  y = c(bb["ymin"], bb["ymax"])
)
dem_raster = get_elev_raster(
  locations = loc_df,
  z = 13,
  prj = ll_proj,
  clip = "bbox"
)

dem_raster_planar = rast(dem_raster)
crs(dem_raster_planar) = "EPSG:4326"
dem_raster_planar = project(dem_raster_planar, planar_crs, method = "bilinear")

dem_raster_planar = crop(
  dem_raster_planar,
  terra::vect(lower_man_poly_planar)
)
lower_man_vect = terra::vect(lower_man_poly_planar)
dem_raster_planar = terra::crop(dem_raster_planar, lower_man_vect)

bbox_planar = sf::st_bbox(lower_man_poly_planar)
dem_raster_planar = terra::crop(
  dem_raster_planar,
  terra::ext(
    bbox_planar["xmin"],
    bbox_planar["xmax"],
    bbox_planar["ymin"],
    bbox_planar["ymax"]
  )
)

# 4. Convert DEM to matrix for rayshader
elev_mat = raster_to_matrix(dem_raster_planar)

# 5. Build a base shaded relief map
zscale = 10
hillshade = sphere_shade(elev_mat)

# 6. Plot 3D terrain with rayshader
hillshade |>
  plot_3d(
    elev_mat,
    zscale = 10,
    fov = 0,
    theta = -45,
    phi = 45,
    zoom = 0.75,
    background = "black",
    windowsize = c(1200, 900)
  )

# 7. Extrude buildings with render_buildings()
render_polygons(
  polygon = bldg_polys_planar,
  extent = dem_raster_planar,
  heightmap = elev_mat,
  data_column_top = "top_height",
  data_column_bottom = NULL,
  scale_data = 1 / 10,
  color = "grey20",
  clear_previous = TRUE
)
render_camera(fov = 8)

skymodelr::generate_sky_latlong(
  lat = 40.7128,
  lon = -74.0060,
  altitude = 0,
  resolution = 6000,
  hosek = FALSE,
  number_cores=8,
  datetime = as.POSIXct("2022-05-29 20:13:00", tz = "America/New_York"),
  filename = "manhattan_alignment.exr"
)

render_highquality(
  iso = 15,
  preview = TRUE,
  sample_method = "sobol",
  environment_light = "manhattan_alignment.exr",
  light = FALSE,
  width = 800,
  height = 800,
  samples = 256,
  clamp_value = 10000,
  aperture = 0,
  camera_location = c(143.73, -18.01, 24.96),
  camera_lookat = c(-7107.84, -25.85, -3979.55),
  override_material = TRUE,
  material  = rayrender::glossy(color="grey50",gloss = 0.6,reflectance = 0.01)
)
1
Rough extent for Lower Manhattan
2
Get building footprints + height from OSM
3
Combine polygons + multipolygons into a single sf object
4
sf polygon for the bbox (WGS84)
5
Derive/approximate building height in meters
6
Column for rayshader to use as building top height
7
Reproject building polygons
8
Get and prep Manhattan terrain data
9
Plot base rayshader map
10
Plot buildings
11
Generate sky EXR
12
Render single frame of pathtracer scene
Figure 20: Flying through the streets of Manhattan on May 29th, 2022, at 8:13 p.m., that year’s Manhattanhenge

Look at that–it’s aligned! The sun is squarely in the middle of the road and partly under the horizon at May 29th, 2022 at 8:13 p.m., which matches the time listed in the table on the Manhattanhenge Wikipedia page for the half-sun time.

The Staff of Ra(ytracing)

The successful celestial alignment of Manhattanhenge is a nice example suggesting correctness, but it’s just one data point. I’ve run into situations where an algorithm looks correct in an initial test, but that success is just the result of two errors canceling out, and subsequent tests fail. For example, I could imagine some issue with both the building polygon projection and the sky calculation that happens to align. So let’s offer another, more convincing example, inspired by a film series that made precise alignment of the sun and a model into a critical plot point: Indiana Jones.

In Raiders of the Lost Ark, there’s a whole sequence where they have to find the fictional “Staff of Ra” to uncover the location of the Ark. Indiana eventually ends up in the ancient Egyptian equivalent of a model train enthusiast’s basement, where the precise alignment of the sun and the jewel on the rod sends a beam that reveals the location of the Ark.5

Figure 21: Indiana Jones using the Staff of Ra to project a beam of light to reveal the Ark’s hidden location. A similar thing happens to me when the sun aligns with my front door’s peephole a few times a year and shines a rainbow beam of light into my microwave when I need to reheat my coffee. Magical.

This was a lot of work that could be saved if Indy had an accurate atmospheric radiance model, along with a highly accurate digital model of the archaeological site. And would you know it: there are organizations around today with the explicit mission of digitizing historical sites in 3D! The Global Digital Heritage is an organization devoted to documenting the world’s cultural and natural history, and has digitally preserved many historical sites with detailed 3D scans with geospatial accuracy in mind. And one of the places recently scanned (in November 2024) was most famously featured in “Indiana Jones and the Last Crusade” as the entrance to the site that holds the Holy Grail: Al-Khazneh in Petra, Jordan (“The Treasury” in English).

Figure 22: Al-Khazneh (The Treasury). Photo by Vyacheslav Argenberg, CC BY 4.0

One nice trait of such a famous, well-known location is that you can find hundreds (if not thousands) of photos of said location, freely available on Wikimedia Commons, such as the one above. Complete with full metadata. Including the exact date and time that the photo was taken. So we can pick a photo and pull the time it was taken, which along with the lat/long of Al-Khazneh should give us a good golden test of our atmospheric model. We’ll display the render alongside the image and see how the shadows compare.

lat_treasury = 30.328960
long_treasury = 35.444832
skymodelr::generate_sky_latlong(
  lat = lat_treasury,
  lon = long_treasury,
  altitude = 1000,
  resolution = 2000,
  hosek = FALSE,
  number_cores=8,
  datetime = as.POSIXct("2007-06-03 10:17:57", tz = "Asia/Amman"),
  filename = "Al_Khazneh.exr"
)

obj_model("al-khazneh-petra-jordan/source/treasury/Al-Khazneh.obj", 
          angle = c(-90,0,0)) |>
  render_scene(
    lookfrom=c(39.13, 2.23, -16.72),
    lookat= c(2.74, 19.74, 2.19) ,fov=52.4,
    width=2048,height = 3072, samples = 32,
    aperture=0.00, iso=3, 
    filename = "treasury.exr",
    environment_light = "Al_Khazneh.exr"
  )

render_exposure("treasury.exr",1) |>
  render_white_balance(reference_white = "D75",
                       target_white = "D50",
                       bake = TRUE) |>
  ray_write_image("rendered_treasury.exr")
1
Time taken from the EXIF data of the photograph
2
The data uses +Z as the up direction, so we rotate it around the X axis to make +Y up
3
The original photo’s white balance is unknown, so I baked in a manual adjustment to make the photo’s color appear closer
Figure 23: Comparing the shadows between the model and the real world (the one with people). The shadow positions are accurate, with just some differences in the edges due to slight smoothing of the 3D model, likely due to photogrammetry/laser scan meshing inaccuracies. Note that the projective camera and the real world camera did not match exactly, so I manually aligned major features in post so the locations of the shadows would match, but this process did not touch the shape of the shadows themselves. You can see the original version versus the edited version here.

Figure 23 shows that the shadow outlines are pretty spot on, with only minor differences due to the precision of the 3D model. Success!

Abstract dataviz

Now that we’re done probing the package’s ability to generate realistic spatial scenes, let’s see if it provides nice lighting for a purely abstract visualization. We’ll try it out with a 3D ggplot from rayshader, using my favorite 3D ggplot demo: a faceted 3D density plot of the diamonds dataset.

Code 
library(ggplot2)
library(viridis)

ggdiamonds = ggplot(diamonds, aes(x, depth)) +
 stat_density_2d(aes(fill = after_stat(nlevel), color = after_stat(nlevel)),
                 geom = "polygon", 
                 n = 200, bins = 50,contour = TRUE) +
 facet_wrap(clarity~.) +
 scale_fill_viridis_c(option = "A") +
 scale_color_viridis_c(option = "A")

plot_gg(ggdiamonds,width=5,height=5,scale=250,windowsize=c(1200,600),
        raytrace = FALSE, theta = 30, phi = 30, zoom = 0.33, fov = 50)

generate_sky(
  elevation = 2, azimuth=315,
  resolution = 1600, hosek = FALSE, visibility = 120, altitude = 0, verbose = TRUE,
  albedo = 1, number_cores = 8, filename="demo_sky_sunset2.exr"
)

render_highquality(
  sample_method = "sobol",
  clamp_value = 1000,
  light=FALSE,
  environment_light = "demo_sky_sunset2.exr", iso = 50,
  aperture=1,
  width = 1200, height=600, preview = FALSE, plot = TRUE, cache_scene = TRUE,
  rotate_env = 270,camera_lookat=c(0,-100,0)
)
Figure 24: Golden hour, diamond data.

Soft shadows, nice highlights, good color: 8/10! Why not 10/10 on my entirely subjective self-assessment? Well, there are definitely some changes I would make if I were really focused on “perfecting” the lighting here: I’d punch up the key light and increase the solar angle so the shadows weren’t so long. But these are nitpicks, and the raw solar atmospheric simulation of sunset provides a solution that’s good enough for most purposes–and that’s the point! We can get the 80% “good enough” solution and focus our energy on the actual 3D data.

Using it in rayshader

lat/long/datetime in render_highquality()

Since programmatically generating a realistic atmosphere that matches the ideal conditions for a place and time is so obviously such a cool feature, I’ve made it easy to do in R via rayshader: rather than having the user manually generate an EXR file with skymodelr, I added several new arguments to render_highquality() to do it for you: lat, long, datetime, and sky_args. These arguments generate the EXR file for you and add it to the scene (along with turning off the default light), so you don’t have to manually pipe in the environment light.

montereybay |> 
  sphere_shade() |> 
  plot_3d(montereybay, water=TRUE, 
          theta = 0, fov = 0, zoom = 1)
for (i in seq_len(100)) {
  set.seed(1)
  render_highquality(
    long = -121.866,
    lat = 36.679,
    datetime = as.POSIXct("2026-02-01 07:15:00", tz = "America/Los_Angeles") +
      lubridate::duration(6 * i, "minutes"),
    samples = 64,
    sample_method = "sobol",
    iso = 5,
    clamp_value = 100,
    sky_args = list(hosek = FALSE, resolution = 4000, number_cores = 8),
    filename = sprintf("nodenoise_mb%d.exr", i),
    denoise = FALSE
  ) 
}
1
New arguments.
2
Note: We turn off OIDN denoising because it can cause flickering: denoising doesn’t accurately preserve the brightness from frame to frame.
Figure 25: A Monterey Bay Day.

Think of the possibilities: want to visualize the impact of a new skyscraper’s shadow on nearby parks, taking into account the loss of direct sunlight as well as scattered light? Easy. Find great alignments between the terrain and sunsets for awesome photographs? Lat + long + datetime = done. Map the shadiest route through a city during a hot summer day at a particular date and time?6 Don’t sweat it, we’ve got you covered.

It’s skymodelr, not daymodelr

However, after all of these cool features, there’s still a problem: when the sun drops below the horizon (more than below the horizon for the Prague model), our simulated sky is black. Not because the model says so: rather, the model simply isn’t valid. And if you go out and look up at the sky at night, you will notice very clearly that the sky isn’t uniformly black. And the name of the package is skymodelr, and yet we aren’t modeling the sky about 50% of the time.

This is not ideal. Doubly so because passing a uniformly black EXR as a background image can cause computational issues in a pathtracer if you aren’t careful, since trying to normalize the sampling distribution (for importance sampling purposes) fails due to division by zero. Is there a way we can also have an accurate model of the night sky as well?

Although, as far as bugs go, “cannot render past the last light” is pretty poetic

Why, of course!

Figure 26: The waxing crescent Moon lining up with the Washington Monument on March 2nd, 2025.

But this blog post has gone on for long enough: that discussion will have to wait for Part 2 of this blog post, covering realistic rendering of the Moon, the planets, and the stars! In the meantime, you can explore and install the package yourself.

Github

Installation

remotes::install_github("tylermorganwall/skymodelr")

Footnotes

  1. You can read a nice blog post all about lighting ratios here that I found informative here.↩︎

  2. But also because it’s R, and canonically you need at least two ways to perform any one task in the language, so we’re too busy infighting (Tidy vs Base! dplyr vs data.table! Base pipe vs magrittr!) to even consider looking at other languages :)↩︎

  3. Just kidding, when I did this I discovered that I had unwittingly followed the OpenGL left-handed convention when setting up my pathtracer’s coordinate system, which meant that +X was to the left (west) when looking towards +Z, which is a big yuck. But it couldn’t be fixed simply by negating the Z axis, since such a negation would flip the “direction” of the surface so it points inwards. So I had to plumb a fix deep into rayrender’s internals and rewrite half of the examples to match this coordinate choice. Chirality bugs: the worst.↩︎

  4. If you are both 1) smart and technically minded and also 2) annoying, you might be considering writing a comment noting that if the center of your map is aligned with one of the Earth’s poles, this convention runs into a coordinate singularity and will fail. Sadly, the landless oceanic void at the north pole and the featureless expanse of snow and ice at the south pole will have to wait for someone who cares… Just kidding! I do care, Mr. More-of-a-comment-than-a-question: I also added an argument to specify the north direction of the 3D model in rayshader, so you can choose your own convention.↩︎

  5. We are supposed to just accept that Indy just happens to get into the map room at exactly the date where the Earth’s axial tilt lines up with the hole leading to the location of the Ark, yet he could have easily shown up on a different date, producing a different location. I mean, what are we to believe, that this is some sort of a magic crystal rod or something? Boy, I really hope somebody got fired for that blunder…↩︎

  6. This is actually something I imagined doing every day in grad school when walking from my apartment to my lab through the humid, Baltimore summer. Every week or so I’d find a good route that would keep me from being drenched in sweat by the time I got to my lab, and every other week the sun would shift just enough that the old route no longer was ideal.↩︎

]]> Data Visualization R EXR Rayshader Rayrender Rayvertex Rayimage skymodelr Atmospheric Models Package Development https://www.tylermw.com/posts/rayverse/atmospheric-simulation-in-r.html Mon, 16 Mar 2026 04:00:00 GMT Developing C/C++ code for R with Positron: Part 1 Tyler Morgan-Wall https://www.tylermw.com/posts/coding/debugging_cpp_in_positron.html

Positron is a new IDE by the creators of RStudio that’s built on VSCode’s open source core, but layered with extra bells and whistles for R (and Python, if that’s your thing). And those bells and whistles’ music is particularly well tuned for R developers working with compiled code, which was always a rather rough experience in RStudio. As someone who basically uses R as a nice LISP-y scripting language to orchestrate calling low-level compiled code from other languages, this is a very welcome addition to the R ecosystem for the following reasons:

A Decoupled R Session

This was one of Positron’s standout features when it was unveiled at Posit::conf(2024): the R session is no longer tightly bound to the IDE. This means that when R crashes due to an out-of-bounds memory access or something similar, the entire IDE doesn’t go up in flames—just the R session. A much nicer developer experience, particularly if you like to play fast and loose with pointers.

Figure 1: Goodbye, old friend.

VSCode extension: clangd

VSCode has great extensions for C++ code that make development much, much easier. For example, the extension clangd analyzes your C++ code and provides real-time feedback, without having to compile your code. You can use it to catch errors, perform code refactoring, and even check the size of structs (including automatically inserted padding!). Need to fit a struct into a cache line? clangd can help you know exactly how your data is laid out in memory. You just need to install the extension and generate a compilation database using pkgload:::use_compilation_db() to get started.

Figure 2: Inspecting the contents and padding of a struct.

Interactive Debugging with CodeLLDB

The other killer feature is being able to use CodeLLDB: an extension that allows you to debug C++ code and set breakpoints and inspect objects interactively. You could technically do this with R manually before by attaching lldb to an R session launched from the command line, but inspecting complex class structures and setting breakpoints using the command line is much harder than doing so in the GUI.

What’s really cool is the ability to see the full call stack, and interactively jump around and inspect the current state of the program at any point. I’m sure there was a way to do that manually in the command line with lldb, but there’s no way I was going to internalize the full API of lldb to do something that a couple extra breakpoints (or print statements!) could accomplish.

Figure 3: Inspecting the full call stack of the program.

However, there are some sharp edges when working with these extensions, some due to Positron’s early developmental state and other simply from working with R. And there’s not much help out there in the form of tutorials or Positron-specific documentation. So to help you get started, I’m going to use the rest of this post will show you how I’ve managed to de-burr these raw corners with some helpful functions you can add to your R user profile (a script that is run each time R is launched or restarted) to automate some of these pain points away.

Automating Compiler Options

Let’s talk about one of the trickier aspects of debugging C/C++ code: compiler optimization levels. In a perfect world, you’d always run your code with -O2 optimizations for the best performance. But when debugging logic issues, it’s often better to disable optimizations (-O0), so you can trace variable values accurately. It’s hard to debug logic when the written code doesn’t match what’s actually being executed!

Figure 4: The CodeLLDB variable inspector: Note the “value may have been optimized out” and “variable not available” values that appear on some variables when compiled with optimizations.

Changing your compiler options from R

To make switching between optimization levels easier, I wrote the function change_compiler_opt below that you can add to your R user profile. It modifies the Makeconf file that determines the compiler optimization level directly from R, allowing you to change the level without leaving your development environment. It also allows you to select the compiler and whether you want to cache your compilation (using ccache). Here’s the function:

You can edit this file easily from R by calling usethis::edit_r_profile().
.Rprofile
#You will likely want to update the default version and compiler
change_compiler_opt = function(level = 2, version = "4.4-arm64", compiler = "clang", cache = TRUE) {
  if (!compiler %in% c("gcc", "clang")) {
    stop("Invalid compiler specified. Only 'gcc' and 'clang' are supported.")
  }
  
  level = as.integer(level)
  
  #You need to update this path below
  fileversion = sprintf("/Library/Frameworks/R.framework/Versions/%s/Resources/etc/Makeconf", version)
  filename = file(fileversion, "rt")
  makeconf = readLines(filename)
  
  # Adjust optimization level
  newmakeconf = gsub("(-O[0123])", sprintf("-O%d", level), makeconf, perl=TRUE)
  
  update_compiler_entry = function(line, compiler, cache) {
    if (compiler == "gcc") {
      c_compiler = "gcc"
      cpp_compiler = "g++"
    } else if (compiler == "clang") {
      c_compiler = "clang"
      cpp_compiler = "clang++"
    }
    
    line = gsub("(ccache )?(gcc|clang) -arch arm64",
                sprintf("%s %s -arch arm64",
                        if (cache) "ccache" else "", c_compiler), line)
    line = gsub("(ccache )?(g\\+\\+|clang\\+\\+) -arch arm64",
                sprintf("%s %s -arch arm64",
                        if (cache) "ccache" else "", cpp_compiler), line)
    return(line)
  }
  
  newmakeconf = sapply(newmakeconf, update_compiler_entry, compiler = compiler, cache = cache, USE.NAMES = FALSE)
  
  close(filename)
  filenamewrite = file(fileversion, "wt")
  cat(newmakeconf, file=filenamewrite, sep="\n")
  close(filenamewrite)
}
1
Check whether the compiler chosen is valid
2
Convert the value to an integer
3
Add the Makefile location (it may be different on your system) and open the file
4
Find and replace all optimization arguments
5
A function to compare each line in the file and replace the compilation calls with the updated arguments
6
Apply the above function to all lines in the file
7
Write and close the files.

There’s a little bit of customization required: you do need to find the path to your own Makeconf file and update the function accordingly. But this function is now an absolutely critical part of my C++ debugging workflow, as I can now quickly change the optimization, recompile (using ccache for speed), spin up the lldb debugger and set up a breakpoint, confirm the fix, and then reset and recompile without exiting the IDE. And that workflow brings us to the second rough edge I’ve “filed down”, via another function you can add to your R profile.

Updating lldb Launch Configurations Dynamically

Currently, you need to manually update the pid in the .vscode/launch.json file when using lldb for debugging compiled code in Positron. This value allows the lldb debugger to attach itself to the correct R process.

.vscode/launch.json
{
    "version": "0.2.0",
    "configurations": [
    {
      "type": "lldb",
      "request": "attach",
      "name": "Debug",
      "program": "ark",
      "pid": 29750
    }
  ]
}

This value (usually) changes whenever your crash or manually restart your session, so this is annoying to do if you’re constantly re-compiling and restarting R. The solution? Automate it!

The following function runs whenever you start R, updating the pid in your launch.json file to match the current R session:

.Rprofile
# Function to silently update the PID in launch.json
update_launch_json_pid = function() {
  current_dir = getwd()
  launch_json_path = file.path(current_dir, ".vscode", "launch.json")

  if (!file.exists(launch_json_path)) {
    return()
  }
  
  current_pid = Sys.getpid()
  json_content = readLines(launch_json_path, warn = FALSE)
  json_content = gsub('"pid": [0-9]+', paste0('"pid": ', current_pid), json_content)
  writeLines(json_content, launch_json_path)
}

update_launch_json_pid()
1
Get the currect working directory, which in Positron is how projects are defined.
2
The launch.json file we want to edit is stored in the .vscode directory, so we load it.
3
If we aren’t in a project that is using CodeLLDB with a launch.json file, silently do nothing.
4
Get the R processes current PID.
5
Replace the previous entry with the current one.
6
Actually run the function that does all the above.

With this snippet, I can always hit the “run debugger” button in Positron and have it work immediately. Now I just need to wait for Posit to allow us to customize our package build process so I can stop having to paste devtools::install(build = TRUE, args = c("--with-keep.source"),reload = TRUE, quick=TRUE, dependencies = FALSE) manually, which will remove my last “well, that’s slightly annoying” Positron package dev hang-up :)

Note that there is also the option to add "pid": "${command:pickMyProcess}" which will bring up a GUI PID picker in Positron. Also note that this adds an extra manual step that you can avoid by using the above script!

And that’s it for the first post in this series about working with compiled C/C++ code in Positron! In the next post, I’ll talk about using the MacOS Instruments application to profile and optimize your compiled code.

]]> Coding R Positron Package Development C++ C VSCode lldb clangd https://www.tylermw.com/posts/coding/debugging_cpp_in_positron.html Sat, 26 Oct 2024 04:00:00 GMT Roofs, Bevels, and Skeletons: Introducing the Raybevel Package Tyler Morgan-Wall https://www.tylermw.com/posts/rayverse/raybevel-introduction.html

Intro

It all started with a tweet that caught my eye - a slick 3D rendering of beveled polygons by Yi Shen @pissang1.

Before a certain social media site went down the xitter

A couple things nerd-sniped me about this interaction: first, an algorithm I’ve never heard of? Check. One that can be used to create cool 3D meshes? Check again. And (after a few minutes of research) one that had no existing implementation in R? Check++.

The more I read, the more I realized that this would be a great new capability to add to R–and for more than just my rather niche interest in the 3D meshing and fancy beveling aspect. But first: what is a straight skeleton, and why is it useful?

Figure 1: The gold at the end of the rainbow (i.e. R package development process).

What is a straight skeleton?

#Load all libraries used in this plot
library(spData)
library(ggplot2)
library(sf)
library(av)
library(patchwork)
library(rnaturalearth)

#All the rayverse packages
library(rayrender)
library(rayvertex)
library(raybevel)

#Helper function: Center mesh in x/z coordinates
center_mesh_xz = function(x) {
  mesh_bbox = get_mesh_center(x)
  mesh_bbox[2] = 0
  translate_mesh(x,-mesh_bbox)
}

pennsylvania = spData::us_states[spData::us_states$NAME == "Pennsylvania",]
pa_skeleton = skeletonize(pennsylvania)
plot_skeleton(pa_skeleton)
1
Load the non-rayverse packages
2
Load the rayverse packages
3
Create a function used throughout the function to center meshes
4
Extract polygon of Pennsylvania from the us_states dataset
5
Skeletonize the polygon
6
Plot the skeleton (using raybevel, the package introduced in this post)
Figure 2: A straight skeleton of Pennsylvania. Why is this thing useful?

The straight skeleton of a polygon is the geometric object formed by tracing the vertices of a polygon as the edges propagate inwards. You can visualize this as a interior wavefront formed by all the edges of the polygon: vertices occur at places two edge’s wavefronts combine or split.

max_time = max(pa_skeleton$nodes$time)
pa_offsets = seq(0,max_time, length.out = 62)[c(-1,-62)]
for(i in 1:60) {
  ggplot() +
    plot_skeleton(pa_skeleton, return_layers = TRUE) +
    plot_offset_polygon(generate_offset_polygon(pa_skeleton,
                                                pa_offsets[i]), color = "green",
                        return_layers = TRUE) +
    theme_void() +
    theme(legend.position = "none",
          plot.background = element_rect(fill="white", color=NA)) +
    coord_fixed()
  ggsave(sprintf("pa_offset%i.png",i), width=8,height=4)
}
av::av_encode_video(input = sprintf("pa_offset%i.png",1:60), output = "wavefront.mp4")
1
Get the maximum internal distance out of the straight skeleton structure
2
Create offsets for these, except for the first and last values
3
Create frames of animations
4
Create animation mp4 file
Figure 3: Animating the internally propagating wavefront from the polygon edges. See the 3D version of this in Figure 6.

Straight Skeleton Applications

It’s useful for both 3D and 2D applications: one useful thing this algorithm can do create inset polygons that respect the topological and geometric properties of the original shape. These interior polygons preserve sharp corners, in contrast to st_buffer() which generates curved internal polygons (see Figure 4).

new_jersey = spData::us_states[spData::us_states$NAME == "New Jersey",] |>
  st_transform("EPSG:32111")
buffer_dist = seq(10000,40000,by=10000)
gglist = list()
for(i in seq_len(length(buffer_dist))) {
  new_jersey_buffered = st_buffer(new_jersey,-buffer_dist[i])
  gglist[[i]] = geom_sf(data = new_jersey_buffered, fill = NA,
                        linewidth = 1, color="dodgerblue")
}

buffer_inset = ggplot() +
  geom_sf(data = new_jersey, fill = NA, linewidth = 1) +
  gglist +
  theme_void() +
  labs(title = "Buffered Inset Polygon")

skeleton_inset = new_jersey |>
  skeletonize() |>
  generate_offset_polygon(offset = buffer_dist) |>
  plot_offset_polygon(plot_original_polygon = TRUE) +
  labs(title = "Straight Skeleton Inset Polygon")
buffer_inset + skeleton_inset
1
Extract and transform New Jersey polygon
2
Create buffer distances
3
Use {sf} to generate internal buffered polygons
4
Generate {sf}-based internal polygon ggplot
5
Generate {raybevel}-based straight skeleton internal polygon ggplot
6
Plot both with the patchwork package
Figure 4: {sf} buffered internal polygons vs straight skeleton inset polygons

This is a much better option if you’ve ever resorted to negative buffers for manipulating polygons for aesthetic reasons: this package allows you to generate smaller polygons without introducing curves (for example, you can use this to create small gaps between directly-adjacent polygons without resorting to hacks with the border color).

us_plot = spData::us_states |>
  skeletonize() |>
  generate_offset_polygon(offset = 0) |>
  plot_offset_polygon(plot_original_polygon = FALSE,
                      color = "black", fill = "grey80",
                      linewidth = 0.2,
                      background = "white") +
  labs(title = "Adjacent States")

us_plot_gap = spData::us_states |>
  skeletonize() |>
  generate_offset_polygon(offset = 0.1) |>
  plot_offset_polygon(plot_original_polygon = FALSE,
                      color = "black", fill = "grey80",
                      linewidth = 0.2,
                      background = "white") +
  labs(title = "Gapped States")
us_plot / us_plot_gap
1
Generate the unchanged US state polygon ggplot
2
Generate the gapped US state polygon ggplot
3
Plot the two with {patchwork}
Figure 5: Adjacent state polygons versus gapped state polygons

This polygon shrinking process can also be represented continuously in 3D. Here’s where one of the really cool applications comes into play: 3D rooftops!

offset_pct = seq(0,1,length.out=61)[-1]
for(i in seq_len(length(offset_pct))) {
  pa_skeleton |>
    generate_beveled_polygon(base = TRUE,
                             bevel_offsets = generate_bevel(bevel_end = offset_pct[i],
                                                            angle = 45)) |>
    center_mesh_xz() |>
    raymesh_model(material = diffuse(color="purple")) |>
    add_object(xz_rect(xwidth=100,zwidth=100)) |>
    render_scene(lookfrom=c(-3,5,-3),fov=0,ortho_dimensions = c(5.5,5.5), lookat=c(-0.20, 0.67, -0.61),
                 filename = sprintf("generating_roof%i.png",i), width=800,height=800, samples=128,
                 preview=FALSE,
                 environment_light = "kiara_1_dawn_2k.hdr",rotate_env = i*6)
}
1
Generate offset percentages for animation
2
Render the image frames for the below animation.
Figure 6: This process represents the exact same 2D shrinking represented in Figure 3, but now in 3D.

You can also use the straight skeleton to obtain internal polygon distance data and generate arbitrary bevels (the original goal of all this effort!).

Figure 7: Inflating California like a balloon by applying an increasingly narrow smooth bevel.

There have also been other creative uses for the straight skeleton in GIS, such as road network simplification and estimating water drainage paths from height contours.

Developing the {raybevel} package

By itself, generating 3D rooftops was a strong enough motivator for me to add this capability to R and the rayverse: plain flat extruded polygons never had enough “character” to represent something as human and familiar as a house. It also serves as a data visualization cue: it’s nice to have a visual indicator (in this case, a sloping rooftop) that helps differentiate objects representing abstract 3D data from 3D buildings. But primarily, it would help provide a bit of humanity to visualizations of neighborhoods, which are plentiful in mapping.

Figure 8: Comparing a neighborhood rendered with rooftops to one without.

Weighing the costs of complex dependencies

When I approach building a new package, I always start by doing some basic research: did anyone else already solve this in a header library I can wrap? Or is there an existing implementation in another language I can port to R? Straight skeleton generation is indeed available in the CGAL library, which has headers available via the RcppCGAL package. The Computational Geometry Algorithms Library (CGAL) is a robust, open-source software project that provides easy access to efficient and reliable geometric algorithms in the form of a C++ library. It encompasses a wide range of tools for computational geometry tasks, from basic geometric primitives to complex operations like mesh processing and geometry analysis. That power comes at a cost: the library is huge and complex, and due to its size requires a non-CRAN distribution method for the actual header files. And one thing I’ve learned over years of R package development is the danger of depending on another package for compiled code, particularly if it’s a non-standard installation process. The CRAN policies are fairly static, but the CRAN’s tooling is not: packages that are fine for years can suddenly have a two week deadline for removal looming over them because the latest version of GCC the CRAN uses is now throwing warnings.

Note

This just happened recently with the CRAN throwing -Wformat errors for the progress package, which propagated a 2-week removal warning to one of my packages–and by the time the progress package was uploaded and fixed, I only had a few days to issue my change! Additionally, the RcppCGAL package was taken down for several months this past year, and I worked with the maintainer to get it back up on the CRAN.

One of my choices as a solo R developer creating a universe of packages while also raising a kid, maintaining a house (e.g. surprise! your fridge is dead! hope you had no other weekend plans!), and working full time is to prioritize limiting surprise workloads with a deadline. It’s becoming more rare that I can drop everything and figure out a potentially complex workaround for a critical software dependency, so I try to only depend on my own universe of packages.

Don't trust the algorithm! Subscribe to my mailing list to be the first to learn about new blog posts.

* indicates required

Intuit Mailchimp

First attempts at a homegrown implementation

So I wanted to try to forgo the heavy CGAL dependency first, and luckily my research indicated that there were alternatives. Several people had seemed to have successfully created implementations of the Felkel and Obdržálek 1998 straight skeleton algorithm (polyskel and ladybug geometry). In particular, I saw that someone had adapted it for a plug-in for blender for creating 3D bpypolyskel and had done some testing showing robust performance (successful on 99.99% of OpenStreetMap building footprints). This algorithm was an attractive choice due to it’s relative simplicity–it only required implementing a circular linked-list data structure with some processing functions, and otherwise was a fairly small library. I decided to implement it in C++ for both speed and ease of translation, as working with circular reference-based data structures isn’t very natural in R. And after brushing up on my python and diving in, I finally had a working algorithm!

Figure 9: (Mostly) working custom straight skeleton implementation, drawing the straight skeleton of an undulating polygon.

Well, sort of. My data suggested the 99.99% performance number was a bit optimistic . My own numbers indicated that the algorithm failed significantly more frequently.

the nice results from the package testing on OSM buildings was likely due to most buildings having a fairly simple and similar structure
Figure 10: When nodes get close (see the center of the skeleton), the exact ordering of nodes within the straight skeleton graph is critical for correct meshes and internal polygons.

Here, the “correctness” of the straight skeleton structure depends on minute differences between nodes, and even with double precision I ran into issues.

Note

Part of the difficulty comes from the fact that the straight skeleton is inherently a non-local structure: tiny changes to the inputs can lead to wildly different skeleton configurations. Ensuring the resulting nodes are purely hierarchical (e.g. no loops or crossing links) is critical to the meshing process.

Poor results and lessons learned

It turns out the algorithm failed more frequently than I’d liked. I knew it wasn’t perfect going in, but the frequency of the failures (a rate closer to 1%-0.1% than 0.01% in my experience, and made worse as polygon complexity increased) made it pretty unusable for large-scale geographic visualizations. But it was not all wasted time–first of all, I got to brush up on some rusty python skills by translating an entire package with relatively complex data structures to C++! But more importantly, I had a much more intimate understanding of the straight skeleton structure, which was helpful when implementing 3D mesh/bevel generation. And with that understanding came the hard-earned knowledge that the straight skeleton structure was inherently computationally difficult to generate: it needs exact arithmetic for robustness, and thus the CGAL dependency is warranted. 🤷

Creating a CGAL-based straight skeleton package

Adopting CGAL wasn’t an insubstantial amount of work: significant amounts of infrastructure was needed to import R spatial/geometry data, calculate the skeleton, export out what I needed to R, and then actually do something interesting with the skeleton. CGAL outputs the straight skeleton structure as a half-edge data structure, which we will reduce to a simple directed graph. We’re then left with a simple directed graph with heights for each node. Additionally, the straight skeleton was only half the battle: I then needed to transform that data into 2D polygons and 3D meshes suitable for rendering in R. And not just simple 3D rooftops and simple 3D bevels: I wanted to support complex curved bevels, and thus needed a custom mesh generation algorithm.

Note

CGAL actually added the ability to generate meshes and simple 3D bevels halfway through 2023, about 4 months after I started working on this project: strange how these gaps in capability often seem to be noticed and solved in parallel! Thankfully, my implementation was more ambitious so my work was not wasted, but if that’s all I was after I could have just stopped here and written a lightweight wrapper around CGAL!

3D Meshing Algorithms

Roof generation was the easy part: let’s say we have a straight skeleton of a polygon and we want to generate a roof model. The roof height is already present by virtue of the straight skeleton providing a distance to each node from the edge: all we have to do is turn all the closed loops in the straight skeleton into polygons, and use the distance as the height of each vertex. This will give us a sloped roof (which you can scale to get different angles). The algorithm for this is relatively simple:

#Call internal raybevel function
polys = raybevel:::convert_ss_to_polygons(pa_skeleton)
ss = plot_skeleton(pa_skeleton, return_layers = TRUE)

ggpolys = lapply(polys, \(x) geom_polygon(data=pa_skeleton$nodes[x,2:3],
                                          aes(x=x,y=y), fill = "#ffaaaa",color = NA))

cntr = 1
for(i in seq_len(length(polys))) {
  poly = polys[[i]]
  poly = c(poly,poly[1])
  for(j in seq_len(length(poly))) {
    ggplot() +
      ggpolys[seq_len(i-1)] +
      ss +
      geom_path(data = pa_skeleton$nodes[poly[seq_len(j)],2:3],
                aes(x=x,y=y), color="purple", size=2) +
      theme_void() +
      theme(plot.background = element_rect(fill="white",color = NA)
            legend.position = "none") + 
      coord_fixed()
    ggsave(sprintf("demo_polygonization%i.png",cntr), width=8, heig
    cntr = cntr + 1
  }
  ggplot() +  
    ggpolys[seq_len(i)] +
    ss +
    theme_void() + 
    theme(plot.background = element_rect(fill="white",color = NA),
          legend.position = "none") + 
    coord_fixed()
  ggsave(sprintf("demo_polygonization%i.png",cntr), width=8, height
  cntr = cntr + 1
}
1
Call an internal {raybevel} function that converts a straight skeleton structure to polygons indices, pointing to vertices in the skeleton node structure
2
Generate the straight skeleton ggplot2 layers
3
Generate the straight skeleton polygon layers (one for each polygon)
4
Loop generating frames of the animation.
Figure 11: Visualizing the algorithm that turns the straight skeleton graph into polygons. Each one of these is then earcut to triangles.

3D Roof Meshes

Select a link not directly on the edge. Mark it as visited. Loop around the skeleton, taking the left-most turn at each node and recording the indices of the nodes you visit. When you return to the original vertex, those vertices form an interior polygon. Repeat for all non-edge links. When you’ve exhausted all links, de-duplicate the polygons by (in a copy of the list of indices) sorting each polygon’s indices and hashing the resulting vector. Earcut the polygons to triangulate the mesh. See an animated version of this algorithm above in Figure 11.

The straight skeleton structure defines the height of each vertex as the distance from the nearest edge, which means this algorithm works great for constant-slope rooftop generation. Let’s apply this algorithm to a few thousand houses and see how it looks in rayshader, using the new render_buildings() feature:

library(osmdata)
library(raster)

osm_bbox = c(-121.9472, 36.6019, -121.9179, 36.6385)

opq(osm_bbox) |>
  add_osm_feature("building") |>
  osmdata_sf() ->
osm_data

opq(osm_bbox) |>
  add_osm_feature("highway") |>
  osmdata_sf() ->
osm_road

building_polys = osm_data$osm_polygons
osm_dem = elevatr::get_elev_raster(building_polys, z = 11, clip = "bbox")
e = extent(building_polys)

osm_dem |>
  crop(e) |>
  extent() ->
new_e

osm_dem |>
  crop(e) |>
  raster_to_matrix() ->
osm_mat

osm_mat[osm_mat <= 1] = -2

osm_mat %>%
  rayimage::render_resized(mag=4) |>
  sphere_shade(texture = "desert") |>
  add_overlay(generate_polygon_overlay(building_polys, extent = new_e,
                                       heightmap = osm_mat,
                                       linewidth = 6,
                                       resolution_multiply = 50), rescale_original = TRUE) |>
  add_overlay(generate_line_overlay(osm_road$osm_lines, extent = new_e,
                                    heightmap = osm_mat,
                                    linewidth = 6,
                                    resolution_multiply = 50), rescale_original = TRUE) |>
  plot_3d(osm_mat, water = TRUE, windowsize = 800, watercolor = "dodgerblue",
          zscale = 10, theta=220, phi=22, zoom=0.45, fov=110,
          background = "pink")

render_buildings(building_polys,  flat_shading  = TRUE,
                 angle = 30 , heightmap = osm_mat,
                 material = "white", roof_material = "white",
                 extent = new_e, roof_height = 3, base_height = 0,
                 zscale=10)
render_highquality()
1
Load packages.
2
Specify the bounding box for the region we are pulling data from.
3
Get building polygon data road line data from OpenStreetMap
4
Get the actual extent the loaded building polygon data and use that to load elevation data using the elevatr package.
5
Crop DEM, but note that the cropped DEM will have an extent slightly different than what’s specified in e. Save that new extent to new_e.
6
Crop the DEM.
7
Visualize areas less than one meter as water (approximate tidal range)
8
Render the 3D rayshader scene
9
Generate and render the 3D building meshes from the polygon data
10
Render the scene with rayrender’s interactive pathtracer
Figure 12: Visualizing thousands of houses with rayshader’s new render_buildings() function.

3D Arbitrary Bevel Meshes

However, if we want to generate an arbitrary bevel instead of a simple roof, it gets a lot more complex: we need to insert new nodes at each distance defined in the bevel and link those horizontally nodes so they form constant height contours around the polygon. We then split the existing links at those bevel points and traverse the straight skeleton to link the new nodes together to form our contours. This latter step is trickier: as the interior polygon “shrinks” at higher interior distances, regions of the polygon can become disconnected from each other.

maryland = spData::us_states[spData::us_states$NAME == "Maryland",]
md_skeleton = skeletonize(maryland)
md_max_time = max(md_skeleton$nodes$time)
md_offsets = seq(0,md_max_time, length.out = 62)[c(-1,-62)]
for(i in 1:60) {
  ggplot() +
    plot_skeleton(md_skeleton, return_layers = TRUE,
                  size=0.5, arrow_size = 0.025) +
    plot_offset_polygon(generate_offset_polygon(md_skeleton,
                                                md_offsets[i]),
                        color = "dodgerblue",
                        return_layers = TRUE, linewidth = 1) +
    theme_void() +
    theme(legend.position = "none",
          plot.background = element_rect(fill="white", color=NA)) +
    coord_fixed()
  ggsave(sprintf("md_offset%i.png",i), width=8,height=4)
}
av_encode_video(input = sprintf("md_offset%i.png",1:60),
                output = "wavefront_md.mp4")
1
Extract the Maryland polygon
2
Skeletonize the polygon
3
Get the maximum internal distance out of the straight skeleton structure
4
Create offsets for these, except for the first and last values
5
Loop generating different offsets, showing the polygon breaking into several
6
Animate using {av}
Figure 13: You can see the polygon split multiple times into sub-polygons as the interior distance increases.

This complicates the meshing process significantly. There can be multiple polygons for a single interior polygon, and you need to be careful when traveling through the straight skeleton structure to only access areas that aren’t cut off yet. We ensure we do by scanning the entire straight skeleton network for local maxima: the peaks on the roof correspond to interior polygons that were topologically cut-off at one point.

md_skeleton |>
  generate_roof(base = TRUE) |>
  center_mesh_xz() |>
  raymesh_model(material = diffuse(color="purple")) |>
  add_object(xz_rect(xwidth=100,zwidth=100)) ->
rayscene

for(i in seq_len(180)) {
  render_scene(rayscene, lookfrom=c(7.07*sinpi(i*2/180),2,7.07*cospi(i*2/180))*2,
               fov=8,ortho_dimensions = c(5,5),
               filename = sprintf("md_peaks%i.png",i),
               width=800,height=300, samples=128,
               preview=FALSE,
               environment_light = "~/Desktop/hdr/kiara_1_dawn_2k.hdr")
}
1
Generate centered 3D rooftop mesh of Maryland
2
Render frames rotating around mesh.
Figure 14: Starting searches for offset polygons at the peaks (seen above in the 3D model) above the desired offset curve guarantees they will be found and ensures disconnected loops won’t be inadvertently connected.

We then always start our search from these maxima (when our contour is below that height) and only search the areas of the skeleton reachable from that point by always turning around when we insert a new node. This ensures we won’t connect nodes to other nodes that aren’t actually in the same interior polygon.

After modifying our straight skeleton structure with new links, we just apply the same polygonization algorithm as in the simple rooftop case! To apply our custom bevel, we just take each node’s distance from the edge and interpolate its height to the height specified in the input bevel. This transforms the interior of our polygon into any 3D profile we want! Here’s some that are build into {raybevel}:

par(mfrow = c(4, 3), mai = c(0.2, 0.2, 0.5, 0.2))
types = rep(c("circular", "exp", "bump", "step", "block", "angled"),2)
reverses = c(rep(FALSE,6),rep(TRUE,6))
for(i in seq_len(length(types))) {
  coords = generate_bevel(types[i], 0.2, 0.8, 1, flip = TRUE,
                          angle = 45, reverse = reverses[i], plot_bevel = TRUE)
}
1
Set up base R plot
2
Visualize each of the built-in bevels in raybevel
3
Also include the reversed bevels
4
Plot them all

raybevel also includes helper functions to help you create complex bevels, although you can also just manually pass a list with x/y coordinates with your own bevel.

complex_coords = generate_complex_bevel(
  bevel_type  = c("circular", "bump", "step", "block", "angled"),
  bevel_start = c(0,   0.2, 0.6, 0.7, 0.9),
  bevel_end   = c(0.2, 0.5, 0.7, 0.8, 1.0),
  segment_height  = c(0.1, 0.2, 0.2, 0.2, 0.4),
  angle = 45,
  curve_points = c(50, 50, 50, 1, 1),
  reverse = c(FALSE, TRUE, FALSE, FALSE, FALSE),
  plot_bevel = TRUE
)

Examples of visualizations made with {raybevel}

What visual effects we do with this algorithm? Lots! We can add nice simple bevels to polygons:

ca_skeleton =  skeletonize(spData::us_states[spData::us_states$NAME == "California",])
ca_skeleton |>
  generate_beveled_polygon(base = TRUE,
                           bevel_offsets = generate_bevel(angle=45)) |>
  center_mesh_xz() |>
  raymesh_model(material = diffuse(color="dodgerblue4")) |>
    add_object(xz_rect(xwidth=100,zwidth=100)) |>
    render_scene(lookfrom=c(-2.39, 3.50, -5.00),fov=0,ortho_dimensions = c(8,8),
                 width=800,height=800, samples=128, preview=FALSE,
                 environment_light = "~/Desktop/hdr/kiara_1_dawn_2k.hdr")
1
Generate straight skeleton of California
2
Render 3D beveled California mesh using rayrender
Figure 15: California with a chamfered edge

Create smooth edges:

smooth_bevel = generate_bevel("circular",
                              bevel_end = 0.3, max_height = 0.3)

ca_skeleton |>
  generate_beveled_polygon(base = TRUE,
                           bevel_offsets = smooth_bevel) |>
  center_mesh_xz() |>
  raymesh_model(material = diffuse(color="dodgerblue4")) |>
    add_object(xz_rect(xwidth=100,zwidth=100)) |>
    render_scene(lookfrom=c(-2.39, 3.50, -5.00),fov=0,ortho_dimensions = c(8,8),
                 width=800,height=800, samples=128, preview=FALSE,
                 environment_light = "~/Desktop/hdr/kiara_1_dawn_2k.hdr")
1
Generate a bevel with {raybevel}’s generate_bevel() function.
2
Render 3D beveled California mesh using rayrender
Figure 16: California with a smooth, beveled corner

Or complex transformations like turn a polygon into a ziggarat:

ziggarat_bevel = generate_complex_bevel("step",
                                        segment_height = 0.1,
                                        bevel_start = seq(0,0.9,by=0.1),
                                        bevel_end = seq(0.1,1,by=0.1))

ca_skeleton |>
  generate_beveled_polygon(base = TRUE,
                           bevel_offsets = ziggarat_bevel) |>
  center_mesh_xz() |>
  raymesh_model(material = diffuse(color="dodgerblue4")) |>
    add_object(xz_rect(xwidth=100,zwidth=100)) |>
    render_scene(lookfrom=c(-2.39, 3.50, -5.00),fov=0,ortho_dimensions = c(8,8),
                 width=800,height=800, samples=128, preview=FALSE,
                 environment_light = "~/Desktop/hdr/kiara_1_dawn_2k.hdr")
1
Generate a complex, multi-segment bevel with {raybevel}’s generate_complex_bevel() function.
2
Render 3D beveled California mesh using rayrender
Figure 17: California as a ziggarat

Or use negative bevels to form a labyrinth-like pattern:

labyrinth_bevel = generate_complex_bevel("step",
                                         segment_height = 0.1,
                                         bevel_start = seq(0,0.95,by=0.05),
                                         bevel_end = seq(0.05,1,by=0.05),
                                         reverse = c(FALSE, TRUE))

ca_skeleton |>
  generate_beveled_polygon(base = TRUE,
                           offset=0.1,
                           bevel_offsets = labyrinth_bevel) |>
  center_mesh_xz() |>
  raymesh_model(material = diffuse(color="dodgerblue4")) |>
    add_object(xz_rect(xwidth=100,zwidth=100)) |>
    render_scene(lookfrom=c(-2.39, 3.50, -5.00),fov=0,ortho_dimensions = c(8,8),
                 width=800,height=800, samples=128, preview=FALSE,
                 environment_light = "~/Desktop/hdr/kiara_1_dawn_2k.hdr")
1
Generate a labyrinth-style bevel by reversing the bevel every other segment
2
Render 3D beveled California mesh using rayrender
Figure 18: California with a maze-like interior

Or a create a California bowl:

labyrinth_bowl = generate_complex_bevel(c("step","exp"),
                                         segment_height = 0.25,
                                         bevel_start = c(0,0.1),
                                         bevel_end = c(0.1,0.5),
                                         reverse = c(FALSE, TRUE))

ca_skeleton |>
  generate_beveled_polygon(base = TRUE,
                           offset=0.1,
                           bevel_offsets = labyrinth_bowl) |>
  center_mesh_xz() |>
  raymesh_model(material = diffuse(color="dodgerblue4")) |>
    add_object(xz_rect(xwidth=100,zwidth=100)) |>
    render_scene(lookfrom=c(-2.39, 3.50, -5.00),fov=0,ortho_dimensions = c(8,8),
                 width=800,height=800, samples=128, preview=FALSE,
                 environment_light = "~/Desktop/hdr/kiara_1_dawn_2k.hdr")
1
Generate a bowl by reversing the second bevel after stepping up some distance
2
Render 3D beveled California mesh using rayrender
Figure 19: California as a bowl

Or even more complex things, like a bump around the edges with a bigger interior bevel (this is the basis behind the animation shown in Figure 1):

bevel_bump = generate_complex_bevel(c("bump", "exp"),
                               bevel_start = c(0,0.3),
                               bevel_end = c(0.1,0.6),
                               segment_height = c(0.05,0.2))

ca_skeleton |>
  generate_beveled_polygon(base = TRUE,
                           bevel_offsets = bevel_bump,
                           offset = 0.2) |>
  center_mesh_xz() |>
  raymesh_model(material = diffuse(color="dodgerblue4")) |>
    add_object(xz_rect(xwidth=100,zwidth=100)) |>
    render_scene(lookfrom=c(-2.39, 3.50, -5.00),fov=0,ortho_dimensions = c(8,8),
                 width=800,height=800, samples=128, preview=FALSE,
                 environment_light = "~/Desktop/hdr/kiara_1_dawn_2k.hdr")
1
Generate a multi-segment bevel by specifying multiple bevel types
2
Render 3D beveled California mesh using rayrender
Figure 20: California with a bumped edge and raised interior

We can even just specify our own bevels directly with mathematical functions:

ca_skeleton |> 
  generate_beveled_polygon(base = TRUE, 
                           bevel_offsets = seq(0,3,by=0.1)/3,
                           bevel_heights = abs(exp(seq(0,3,by=0.1)))/20 +
                             sinpi(seq(0,3,by=0.1))/10,
                           offset=0.2) |> 
  center_mesh_xz() |>
  raymesh_model(material = diffuse(color="dodgerblue4")) |>
    add_object(xz_rect(xwidth=100,zwidth=100)) |>
    render_scene(lookfrom=c(-2.39, 3.50, -5.00),fov=0,ortho_dimensions = c(8,8),
                 width=800,height=800, samples=128, preview=FALSE,
                 environment_light = "~/Desktop/hdr/kiara_1_dawn_2k.hdr")
1
Generate the bevel manually using mathematical functions
2
Render 3D beveled California mesh using rayrender
Figure 21: California with a custom bevel defined by math functions

Or crazy things like make SVG fonts into double-sided bubble letters by applying a circular edge contour:

Figure 22: This did require writing an entirely new package for importing SVG as polygons, but that’s a yak that’s not yet completely shorn!

I’ve packaged up all these functions into the new package raybevel: simply input polygons or sf objects and transform them to 3D, or create 2D inset polygons! I’ve used it throughout this post, I’ve also included interfaces built-in to rayshader (render_buildings()) and render_beveled_polygons()).

]]> Data Visualization R CGAL Mesh Processing GIS Rayshader Rayrender Rayvertex Straight Skeletons Package Development https://www.tylermw.com/posts/rayverse/raybevel-introduction.html Mon, 17 Jun 2024 04:00:00 GMT Sculpting the Moon in R: Subdivision Surfaces and Displacement Mapping Tyler Morgan-Wall https://www.tylermw.com/posts/rayverse/displacement-mapping.html

We like the moon
The moon is very useful, everyone
Everybody like the moon
Because it light up the sky at night
and it lovely and it makes the tides go
and we like it
But not as much as cheese
We really like cheese

— The Spongmonkies, 2002

Introduction

TipTL;DR

In this post, we explore subdivision surfaces and displacement mapping within the rayverse, using the rayvertex, rayimage, and rayrender packages. We demonstrate how to create detailed and smooth 3D models by subdividing meshes and applying displacement textures. These techniques enhance both artistic and data visualization projects by providing realistic and intricate surface details.

Bumpy objects and smooth objects. These are the two demons you must slay if you want to be successful in 3D rendering.

Just kidding! There are thousands of demons you must slay. The princess is always in another castle.

Triangles, the primary building blocks of computer graphics, don’t directly lend themselves to either extremely smooth or realistically bumpy objects. Since triangles are flat primitives, borders between non-coplanar adjacent triangles will always have sharp edges. You can introduce approximations to work around this (such as per-vertex normals), but approximations always have failure modes, particularly with certain rendering algorithms. Bumpy objects suffer from the same issue: approximating a rough surface using a bump map or a normal map (which change the underlying surface normal without actually changing the geometry) can lead to non-physically accurate results.

There’s also NURBS, quadratic surfaces, curves, and more exotic objects

Historically, renderers worked around this by subdividing meshes into “micropolygons”: polygons smaller than a single pixel. This means triangle edges were not visible, as they only existed a on sub-pixel scale. This subdivision enabled the rendering of smooth objects and the rendered image no longer had visible discontinuities in the surface normal due to geometry. This subdivision process allowed for bumpy surfaces as well: by displacing the vertices of these micropolygons, you could easily generate highly detailed surfaces given a basic low-resolution mesh and a displacement texture. It can be significantly easier to work with displacement information in 2D form and use it to displace a low-resolution 3D mesh, rather than try to construct a fully-detailed 3D mesh directly.

The Reyes rendering algorithm–which brought us Toy Story and Star Trek II: Wrath of Khan–actually works off of quadrilaterals, not triangles, but the idea is the sameRayshader has always performed a basic version of displacement mapping when generating meshes, but it’s been limited to displacing a flat surface.

This brings us to why I implemented subdivision surfaces and displacement mapping in the rayverse: there’s plenty of 2D data out there and not all of it lives on a flat, Cartesian plane. If you’re plotting data that spans the entire planet (or moon!), there’s always a struggle to pick the right projection, knowing that there’s no ideal way to transform a sphere to 2D without warping the data in some way. Expressing the data in its native curved space avoids those issues entirely.

While 3D plotting has its own set of issues, it also has many advantages–see this blog post for more information

So let’s dive into subdivision surfaces and displacement mapping! What is it, how it was implemented, things to keep in mind when using it, and what you can do with it in the rayverse.

Subdivision

We’ll start by loading three useful rayverse packages: rayvertex to construct raymesh objects and manipulate them directly, rayimage to manipulate displacement textures and load a variety of image files, and rayrender to visualize these meshes in a high-quality pathtracer.

library(rayvertex)
library(rayimage)
library(rayrender)

Now, let’s render an image of some shapes with Loop subdivision. We’ll be using rayvertex because it renders faster and has more fine-grained control over the meshing process. Note here the new (as of rayvertex v0.11.0) print output showing a command-line preview of the materials, as well as a preview of the scene information.

Fun fact: Loop subdivision is not named after some cyclical mesh property or iterative process that the name might suggest: it’s actually named after the graphics researcher Charles Loop.
base_material = material_list(diffuse="red", ambient = "red",
                              type = "phong", shininess = 5,
                              diffuse_intensity = 0.8, ambient_intensity = 0.2)
base_material
1
Create and print the red cube material 
• rayvertex_material
• type: phong
• diffuse: #ff0000   | intensity: 0.8
• ambient: #ff0000   | intensity: 0.2
• shininess: 5

base_material2 = material_list(diffuse="purple", ambient = "purple",
                               type = "phong", shininess = 5,
                               diffuse_intensity = 0.8, ambient_intensity = 0.2)
base_material2
1
Create and print the purple sphere material 
• rayvertex_material
• type: phong
• diffuse: #a020f0   | intensity: 0.8
• ambient: #a020f0   | intensity: 0.2
• shininess: 5

Note how the materials print a preview of the actual colors and relevant (i.e. non-default) material settings. This is due to rayvertex’s new integration with the cli package and a whole collection of new pretty-print functions.

scene = cube_mesh(material = base_material, scale = 0.8) |>
  add_shape(sphere_mesh(radius=0.5,position = c(-1.2,0,0), low_poly = TRUE,
                        normals = TRUE,
                        material = base_material2)) |>
  add_shape(obj_mesh(r_obj(), position=c(1.2,0,0)))
scene
1
Create the 3D scene
2
Print the scene information 
── Scene Description ───────────────────────────────────────────────────────────
• Summary - Meshes: 3 | Unique Materials: 4
ℹ XYZ Bounds - Min: c(-1.69, -0.51, -0.49) | Max: c(1.70, 0.49, 0.51)
             shapes  vertices texcoords   normals materials
          <ray_shp> <ray_dat> <ray_dat> <ray_dat> <ray_mat>
1   <T:12|UV|N|M:1>     <8x3>     <4x2>     <6x3>   <phong>
2   <T:48|UV|N|M:1>    <26x3>    <34x2>    <26x3>   <phong>
3 <T:2280|UV|N|M:6>  <1520x3>  <1520x2>    <none>      <6x>

The rayvertex scene information now also includes a dense, readable tabular summary of each individual mesh that makes up the scene. Rather than looking at a verbose print-out of lists of vertex data and material information, now you can get a sense of the scene at a glance.

rasterize_scene(scene, lookfrom = c(-4,3,10), lookat=c(-0.05,0,0),
                fov=9, height = 550, width=1100,
                light_info = directional_light(c(1,1,2)))
1
Render the scene

We’ve now rendered some basic low-polygon shapes. Low-polygon here means that you can clearly see lighting artifacts from the chunky triangles that make up the mesh: there are discontinuities on the sphere from the vertex normal interpolation, resulting in unphysical “lines” of light that run along the edges of the triangles.

Let’s subdivide the meshes with the new subdivide_mesh() function and determine how many subdivisions renders any individual triangle too small to see. Each subdivision level increases the number of triangles by a factor of four. We won’t initially add vertex normals so we can see exactly what’s going on with the geometry.

scene |> 
  subdivide_mesh(subdivision_levels = 2, normals = FALSE) |>
  rasterize_scene(lookfrom = c(-4,3,10), lookat=c(-0.05,0,0),
                  fov=9, height = 550, width=1100,
                  light_info = directional_light(c(0.2,1,2)))
1
Subdivide the scene

Note how the cube has shrunk considerably and the sharp edges of the letter R have collapsed in on themselves. This phenomenon occurs because subdivision algorithms, like Loop subdivision, work by averaging the positions of vertices to create a smoother surface. Sharp edges consisting of large triangles will be much more affected by this process. To fix this, we can turn off vertex interpolation and first apply a non-interpolated simple subdivision step and then follow it up with regular Loop subdivision step to more accurately maintain the initial shape of the object.

scene |> 
  subdivide_mesh(normals = FALSE, simple = TRUE) |>
  subdivide_mesh(subdivision_levels = 2, normals = FALSE) |>
  rasterize_scene(lookfrom = c(-4,3,10), lookat=c(-0.05,0,0),
                  fov=9, height = 550, width=1100,
                  light_info = directional_light(c(0.2,1,2)))
1
Subdivide the scene but don’t smooth the mesh
2
Subdivide the scene normally, but don’t calculate normals to better show the triangle faces

Note how the cube is still cube-ish, but with nicely curved edges! The R logo looks nicer here too, as the large corner that makes up the R didn’t collapse. The only problem is the low-poly sphere is now more like a 20-sided D&D die, which isn’t great if you’d like the limit of the subdivision process to result in an identical (but smoothed) version of the original mesh. But it’s nice to have a workflow for adding rounded bevels to models, which adding a simple subdivision step provides. Let’s get back to trying to trying to subdivide until we can’t tell the mesh is made of individual triangles anymore. How about three subdivisions?

scene |> 
  subdivide_mesh(subdivision_levels = 3, normals = FALSE) |>
  rasterize_scene(lookfrom = c(-4,3,10), lookat=c(-0.05,0,0),
                  fov=9, height = 550, width=1100,
                  light_info = directional_light(c(0.2,1,2)))
1
Subdivide the objects three times

Not yet. Still visible. Let’s subdivide again.

scene |> 
  subdivide_mesh(subdivision_levels = 4, normals = FALSE) |>
  rasterize_scene(lookfrom = c(-4,3,10), lookat=c(-0.05,0,0),
                  fov=9, height = 550, width=1100,
                  light_info = directional_light(c(0.2,1,2)))
1
Subdivide the objects four times

Almost! But no cigar.

scene |>
  subdivide_mesh(subdivision_levels = 5, normals = FALSE) ->
scene_5x

rasterize_scene(scene_5x, lookfrom = c(-4,3,10), lookat=c(-0.05,0,0),
                fov=9, height = 550, width=1100,
                light_info = directional_light(c(0.2,1,2)))
1
Render the scene
2
Subdivide the mesh five times and save it to an object

There we go. We can compare the before and after mesh sizes to see how mary more triangles this required to reach continuity. Note the number of vertices and the T: field in the shapes column indicating the number of triangles.

print(scene)
1
Printing the scene information before subdivision 
── Scene Description ───────────────────────────────────────────────────────────
• Summary - Meshes: 3 | Unique Materials: 4
ℹ XYZ Bounds - Min: c(-1.69, -0.51, -0.49) | Max: c(1.70, 0.49, 0.51)
             shapes  vertices texcoords   normals materials
          <ray_shp> <ray_dat> <ray_dat> <ray_dat> <ray_mat>
1   <T:12|UV|N|M:1>     <8x3>     <4x2>     <6x3>   <phong>
2   <T:48|UV|N|M:1>    <26x3>    <34x2>    <26x3>   <phong>
3 <T:2280|UV|N|M:6>  <1520x3>  <1520x2>    <none>      <6x>

print(scene_5x)
1
Printing the scene information after subdivision 
── Scene Description ───────────────────────────────────────────────────────────
• Summary - Meshes: 3 | Unique Materials: 4
ℹ XYZ Bounds - Min: c(-1.63, -0.45, -0.45) | Max: c(1.70, 0.46, 0.45)
                shapes    vertices   texcoords   normals materials
             <ray_shp>   <ray_dat>   <ray_dat> <ray_dat> <ray_mat>
1   <T:12288|UV|N|M:1>    <6146x3>    <6146x2>    <none>   <phong>
2   <T:49152|UV|N|M:1>   <24578x3>   <24578x2>    <none>   <phong>
3 <T:2334720|UV|N|M:6> <1167360x3> <1167360x2>    <none>      <6x>

Yikes! We can see it grew by a lot: Five subdivision levels resulted in a x increase in the mesh size. Of course, we can turn the normals option back on, which then calculates smoothed vertex normals. With vertex normals, we only need three subdivision levels to achieve the same visual fidelity as the 5x subdivided mesh. Since the triangles are relatively small compared to the low-poly original, we won’t see the same sort of lighting discontinuities noted in the first render.

translate_mesh(subdivide_mesh(scene, subdivision_levels = 3) ,position=c(0,1.1,0)) |> 
  add_shape(scene_5x) |> 
  add_shape(translate_mesh(scene,position=c(0,2.2,0))) |> 
  rasterize_scene(lookfrom = c(-4,3,10), lookat=c(-0.05,1.1,0),
                  fov=18, height = 1100, width=1100,
                  light_info = directional_light(c(0.2,1,2)))
Figure 1: Top Row: Original low-poly meshes. Middle Row: Highly subdivided (1024x triangles) scene without vertex normals. Bottom Row: 3x subdivided scene (64x triangles) with vertex normals.

And that’s it for subdivision surfaces, at least for now!

Displacement Mapping

We just subdivided a low-red mesh to make it smooth–how do we make it bumpy? We can do that by applying a displacement texture, which offsets each vertex via its vertex normal. Here’s an example of a displacement texture of the moon:

If there aren’t any vertex normals in the mesh, it first calculates them by averaging the directions of all the faces connected to a single vertex. This interface also supports vector displacement, but I’m not going to get into that in this post
disp_moon = ray_read_image("../images/2024/ldem_3_8bit.jpg") 
plot_image(disp_moon)

Higher regions are lighter, and depressions are darker. If you’ve used worked in GIS software or with rayshader before, you might ask: isn’t this just a digital elevation model (DEM)? Sure is! Let’s check out the Monterey Bay data included in rayshader to see:

library(rayshader) 

montereybay |>
  height_shade(texture = colorRampPalette(c("black","white"))(100)) |>
  plot_map()
1
Use rayshader to plot the black to white color mapping of the Monterey Bay DEM

What displacement mapping does is allow this type of transformation to be applied to any 3D surface, rather than just a 2D plane (as in rayshader). So displacement mapping allows us to apply these displacements to a sphere. In a universe full of spheres and ellipsoids, this capability can be quite useful. Our image data ranges from 0-1 in this case, and the difference (from the mean elevation) between the highest point on the moon (6.7 miles) and the lowest (-5.4 miles) is 12.1 miles, which when compared to the moon’s radius (1,079.6 miles) is about a 1.1 percent variation. So with a unit sphere representing the moon, our displacement scale is 0.011.

Let’s visualize the displacement on a basic small sphere mesh. :

I have to call smooth_normals_mesh() and add_sphere_uv_mesh() because the displacement algorithm here requires one UV coordinate/normal per vertex
lights = directional_light(c(1,0,0)) |>
  add_light(directional_light(c(-1,0,0),
                              color="dodgerblue",
                              intensity=1))

white_material = material_list(diffuse = "white",
                               ambient = "white",
                               diffuse_intensity = 0.9,
                               ambient_intensity = 0.1)

sphere_mesh(material = white_material) |>
  smooth_normals_mesh() |>
  add_sphere_uv_mesh(override_existing = TRUE) ->
basic_sphere_uv

basic_sphere_uv |>
  displace_mesh(disp_moon, displacement_scale = 0.011) |>
  rasterize_scene(light_info = lights, width = 1100, height = 550, fov=13)
1
Generate the lighting for the scene
2
Generate the basic white material for the sphere
3
Create a smooth sphere and add unique normals and UV coordinates for each vertex
4
Displace the sphere with the moon data, scaled by 0.011, and render it 
Displacing mesh with 512x1024 texture
Setting `lookat` to: c(-0.00, -0.00, 0.00)

Wait–nothing happened? What went wrong? Well, let’s look at the mesh info and compare the number of vertices in the mesh to the resolution of the image:

basic_sphere_uv
── Scene Description ───────────────────────────────────────────────────────────
• Summary - Meshes: 1 | Unique Materials: 1
ℹ XYZ Bounds - Min: c(-1.00, -1.00, -1.00) | Max: c(1.00, 1.00, 1.00)
            shapes  vertices texcoords   normals materials
         <ray_shp> <ray_dat> <ray_dat> <ray_dat> <ray_mat>
1 <T:960|UV|N|M:1>   <482x3>   <482x2>   <482x3> <diffuse>

dim(disp_moon)
prod(dim(disp_moon)[1:2])
1
Multiply the dimensions of the texture together to get the number of pixels 
[1]  512 1024    3
[1] 524288

So there’s half a million points, but only about 500 total vertices. Let’s write a function to show ourselves exactly where and how much of the displacement map we’re sampling. The green pixels are the places in the elevation model we are actually using to displace out mesh.

get_displacement_access_info = function(mesh, image) {
  image_coords = round(matrix(dim(image)[2:1]-1,ncol=2,
                         nrow=nrow(mesh$texcoords[[1]]),
                         byrow=TRUE) * mesh$texcoords[[1]])

  for(i in seq_len(nrow(image_coords))) {
    image[1+image_coords[i,2],1+image_coords[i,1],1:3] = c(0,1,0)
  }
  total_pixels = as.integer(prod(dim(image)[1:2]))
  total_pixels_sampled = as.integer(sum(image[,,1] == 0 & image[,,2] == 1 & image[,,3] == 0))
  message(sprintf("Total pixels sampled: %i/%i (%0.5f%%)",
                  total_pixels_sampled, total_pixels, total_pixels_sampled/total_pixels*100))
  plot_image(image)
}
get_displacement_access_info(basic_sphere_uv, disp_moon )
1
Take the UV coordinates (which range from 0-1) and map them to the pixel coordinates by multiplying the number of rows and columns by each UV pair.
2
Loop over the image and set each accessed pixel to green.
3
Calculate the total number of pixels.
4
Calculate the total number of accessed (green) pixels.
5
Print the access information.
6
Plot the image with green pixels marking data used to displace the mesh. 
Total pixels sampled: 482/524288 (0.09193%)

So, we’re sampling 0.092% of the pixels in the image–no wonder it’s such a poor approximation! Let’s use subdivision to increase the size of our mesh, which should sample more of the underlying displacement texture and thus give us a better approximation.

generate_moon_mesh = function(subdivision_levels, displacement_texture, displacement_scale) {
  sphere_mesh(material = white_material) |> 
    smooth_normals_mesh() |> 
    subdivide_mesh(subdivision_levels = subdivision_levels) |>
    add_sphere_uv_mesh(override_existing = TRUE) |>
    displace_mesh(displacement_texture, displacement_scale) |>
    rotate_mesh(c(0,90,0))
}
moon_subdivided_2 = generate_moon_mesh(2, disp_moon, 0.011)
1
Subdivide the moon
2
Add new UV coords with a spherical mapping
3
Displace with the displacement texture
4
Rotate the mesh to orient it at the camera 
Displacing mesh with 512x1024 texture
rasterize_scene(moon_subdivided_2, light_info = lights,
                width = 1100, height = 550, fov=13)
Setting `lookat` to: c(-0.00, -0.00, -0.00)

Still looks nothing like the moon. Let’s check out the displacement texture access pattern.

get_displacement_access_info(moon_subdivided_2, disp_moon )
Total pixels sampled: 7682/524288 (1.46523%)

Better, but still extremely sparse. What about three subdivision levels?

moon_subdivided_3 = generate_moon_mesh(3, disp_moon, 0.011)
Displacing mesh with 512x1024 texture
rasterize_scene(moon_subdivided_3, light_info = lights,
                width = 1100, height = 550, fov=13)
Setting `lookat` to: c(-0.00, -0.00, -0.00)

Maybe some hints of craters? If you squint. Time to check the UV coords.

get_displacement_access_info(moon_subdivided_3 , disp_moon )
Total pixels sampled: 30722/524288 (5.85976%)

Alright, so we’re sampling the big craters with a decent density of points. I’ll note here that at a resolution of 512x1024 and about 500 vertices in our original mesh, we’ll need about a factor of 1000x more vertices to densely sample from our UV texture. Let’s march on and see if that’s the case.

moon_subdivided_4 = generate_moon_mesh(4, disp_moon, 0.011)
Displacing mesh with 512x1024 texture
rasterize_scene(moon_subdivided_4, light_info = lights,
                width = 1100, height = 550, fov=13)
Setting `lookat` to: c(-0.00, -0.00, -0.00)

Okay, so we’re definitely starting to see distinct craters.

get_displacement_access_info(moon_subdivided_4 , disp_moon )
Total pixels sampled: 122840/524288 (23.42987%)

Much denser, but not connected. So indeed, we shall proceed to five subdivision levels.

moon_subdivided_5 = generate_moon_mesh(5, disp_moon, 0.011)
Displacing mesh with 512x1024 texture
rasterize_scene(moon_subdivided_5, light_info = lights,
                width = 1100, height = 550, fov=13)
Setting `lookat` to: c(-0.00, -0.00, -0.00)

Look at that! Definite improvement over four. And the UV texcoord access?

get_displacement_access_info(moon_subdivided_5, disp_moon )
Total pixels sampled: 467649/524288 (89.19697%)

Definitely lots of densely interconnected green, along with some interesting patterns from what I can only assume are interpolation and sampling artifacts related to the original mesh structure. We’ll do six levels and see if there’s any difference.

moon_subdivided_6 = generate_moon_mesh(6, disp_moon, 0.011)
Displacing mesh with 512x1024 texture
rasterize_scene(moon_subdivided_6, light_info = lights,
                width = 1100, height = 550, fov=13)
Setting `lookat` to: c(-0.00, -0.00, -0.00)

Everything’s a little sharper! But up close you can start to make out the individual pixels from the displacement mesh. Five is probably good enough.

moon_subdivided_6
── Scene Description ───────────────────────────────────────────────────────────
• Summary - Meshes: 1 | Unique Materials: 1
ℹ XYZ Bounds - Min: c(-0.99, -1.00, -0.99) | Max: c(0.99, 1.00, 0.99)
                shapes    vertices   texcoords     normals materials
             <ray_shp>   <ray_dat>   <ray_dat>   <ray_dat> <ray_mat>
1 <T:3932160|UV|N|M:1> <1966082x3> <1966082x2> <1966082x3> <diffuse>

get_displacement_access_info(moon_subdivided_6, disp_moon )
Total pixels sampled: 504426/524288 (96.21162%)

However, 2 million vertices is a lot of wasted memory to sample our half million pixel image. Let’s use the new displacement_sphere() function to generate a sphere that has exactly one vertex per pixel in our texture. That way we aren’t under or oversampling our image.

moon_displacement_sphere = displacement_sphere(disp_moon, displacement_scale = 0.011) |> 
  set_material(material = white_material) |> 
  rotate_mesh(c(0,90,0))
Displacing mesh with 512x1024 texture
rasterize_scene(moon_displacement_sphere, light_info = lights,
                lookat=c(0,0,0), lookfrom=c(0,0,10),
                width = 1100, height = 550, fov=13)

Great! Let’s check out how much of the displacement texture was used to generate this mesh.

moon_displacement_sphere
── Scene Description ───────────────────────────────────────────────────────────
• Summary - Meshes: 1 | Unique Materials: 1
ℹ XYZ Bounds - Min: c(-1.01, -1.01, -1.01) | Max: c(1.00, 1.01, 1.00)
                shapes   vertices  texcoords    normals materials
             <ray_shp>  <ray_dat>  <ray_dat>  <ray_dat> <ray_mat>
1 <T:1045506|UV|N|M:1> <524288x3> <524288x2> <524288x3> <diffuse>

get_displacement_access_info(moon_displacement_sphere, disp_moon)
Total pixels sampled: 524288/524288 (100.00000%)

All green! Exactly as many vertices as pixels in the image, by construction. While this might sound good, this type of mesh can actually lead to visual artifacts. Let’s say we really cared about accurately visualizing the north and south poles. We’ll zoom in and see what they look like with this perfectly mapped mesh.

rasterize_scene(moon_displacement_sphere, 
                light_info = directional_light(c(0,1,-1)),
                lookat=c(0,1,0), lookfrom=c(5,5,5),
                width = 1100, height = 550, fov=2)

Pucker up! We see here what’s referred to as “texture pinching” at the poles, which happens due to the convergence of the longitudinal lines and the corresponding increasing density of vertices. Not great for texturing if you have any interesting phenomena at the poles you want to accurately display. But there’s a better way to represent displaced data on a sphere: let’s take a cube object and subdivide it.

cube_mesh(material = white_material) |>
  subdivide_mesh(subdivision_levels = 4) ->
cube_low_res

rasterize_scene(cube_low_res, light_info = lights,
                lookat=c(0,0,0), lookfrom=c(0,0,10),
                width = 1100, height = 550, fov=6)
1
Subdivide a basic 8 vertex sphere
2
Render the subdivided sphere.

This obviously isn’t a sphere, but we can fix that. Let’s project the vertices to a sphere centered at the origin. We’ll also remap the UV coordinates using the add_sphere_uv_mesh() function, and recalculate the normals post-projection using smooth_normals_mesh().

map_cube_to_sphere = function(mesh) {
  project_vertex_to_sphere = function(x) {
    x/sqrt(sum(x*x))
  }

  mesh$vertices[[1]] = t(apply(mesh$vertices[[1]],1,project_vertex_to_sphere))
  add_sphere_uv_mesh(mesh, override_existing = TRUE) |>
    smooth_normals_mesh()
}

cube_mesh(material = white_material) |>
  subdivide_mesh(subdivision_levels = 9) |>
  map_cube_to_sphere()  ->
spherized_cube
spherized_cube
1
Define a function to transform a mesh to a sphere
2
Define helper function to map vertices (centered at zero) to a sphere by dividing by their length, measured from the origin.
3
Apply the helper function to all the vertices in the mesh
4
Add UV coords and normals
5
Subdivide the cube nine times to get approximately half a million vertices (to match the resolution of the displacement texture)
6
Print the new subdivided cube-to-sphere mesh info 
── Scene Description ───────────────────────────────────────────────────────────
• Summary - Meshes: 1 | Unique Materials: 1
ℹ XYZ Bounds - Min: c(-1.00, -1.00, -1.00) | Max: c(1.00, 1.00, 1.00)
                shapes    vertices   texcoords     normals materials
             <ray_shp>   <ray_dat>   <ray_dat>   <ray_dat> <ray_mat>
1 <T:3145728|UV|N|M:1> <1572866x3> <1572866x2> <1572866x3> <diffuse>

rasterize_scene(spherized_cube, light_info = lights,
                lookat=c(0,0,0), lookfrom=c(0,0,10),
                width = 1100, height = 550, fov=13)
1
Render the scene

Looks like… a sphere. There’s nothing indicating this used to be a cube! And the nice thing about this mesh is it has no extreme convergence at the poles. Let’s displace the subdivided mesh and see how the moon looks.

“On the internet, no one knows you’re a cube.”
spherized_cube |>
  displace_mesh(disp_moon, 0.011) |>
  rotate_mesh(c(0,90,0)) ->
cube_moon
1
Displace the spherized cube 
Displacing mesh with 512x1024 texture
rasterize_scene(cube_moon, light_info = lights,
                lookat=c(0,0,0), lookfrom=c(0,0,10),
                width = 1100, height = 550, fov=13)
1
Render the displaced mesh

Looks good to me. Let’s compare the two polar meshes. Note that the initial poor rectangle-to-sphere mapping we did above is referred to as a “UV sphere” in 3D graphics.

moon_displacement_sphere |>
  rasterize_scene(light_info = directional_light(c(0,1,-1)),
                  lookat=c(0,1,0), lookfrom=c(5,5,5),
                  width = 550, height = 550, fov=2, plot = FALSE) ->
polar_image

cube_moon |>
  rasterize_scene(light_info =  directional_light(c(0,1,-1)),
                lookat=c(0,1,0), lookfrom=c(5,5,5),
                width = 550, height = 550, fov=2, plot = FALSE) ->
polar_image_cube

plot_image_grid(list(polar_image,polar_image_cube),dim = c(1,2))
1
Render and save the UV sphere displacement map to an image array
2
Render and save the spherized cube displacement map to an image array
3
Plot the images side by side using rayimage.

Left: UV sphere. Right: Spherized cube.

No celestial b-hole! This option is included in the displacement_sphere() function by setting use_cube = TRUE.

And that’s it for the new features in rayvertex and rayrender! rayrender has both of these features, but they aren’t standalone functions: they are built-in to the mesh functions that support textures (e.g. mesh3d_model(), obj_model(), and raymesh_model(). You can install the latest development versions of both packages from r-universe or github via the following:

install.packages(c("rayvertex","rayrender"), repos = "https://tylermorganwall.r-universe.dev")
#or
remotes::install_github("tylermorganwall/rayvertex")
remotes::install_github("tylermorganwall/rayrender")

Summary

In this post, we’ve explored the concepts of subdivision surfaces and displacement mapping. We began by discussing the fundamental challenges in 3D rendering, such as the difficulty of representing smooth and bumpy objects using flat, planar triangles. We then delved into historical solutions, like the use of micropolygons, and how modern techniques, including Loop subdivision, allow for the creation of detailed and smooth 3D models.

I demonstrated how to implement these techniques using the rayvertex, rayimage, and rayrender packages. I showed you how subdividing a mesh can significantly increase its resolution, allowing for smoother and more detailed surfaces. Additionally, we examined how displacement mapping can be used to add realistic texture to 3D models by manipulating vertex positions based on a 2D texture map.

]]> Data Visualization R Mesh Processing Rayshader Rayrender Rayvertex Rayimage Package Development Displacement Mapping https://www.tylermw.com/posts/rayverse/displacement-mapping.html Thu, 11 Jan 2024 05:00:00 GMT Roadtripping America in R: Turning Spatial Data into Animations with Rayshader Tyler Morgan-Wall https://www.tylermw.com/posts/data_visualization/roadtripping-america-in-r-turning-spatial-data-into-animations-with-rayshader.html

Roadtripping America in R

What’s cooler than spinning 3D animations of geospatial data? Flying spinning 3D animations of geospatial data! And that’s what this blog post is going to teach you how to make, using new features in rayshader that make the process simple and straightforward. Normally, I’d also try to give you a little more background about the motivation for making this feature, and why (and when) you should consider using it. But now I have an active one year old and about 30-45 minutes free time each night, so here’s the abridged version:

  1. There’s lots of data about travel over 3D landscapes, and traveling along the path in 3D can be interesting, e.g. strava run/cycling data, animal GPS tracks, trails and hiking paths
  2. Spinning makes the visualization more cinematic (more drone footage, less Playstation 1 fixed camera)
  3. It’s fun (isn’t that way really matters?) and makes even the most boring data interesting and dynamic

And what’s one of the most boring data sets available? The US interstate system! Apologies to all Federal Highway Administration employees reading this blog post. The interstates have (basically) been finished for half a century—there’s nothing new or dynamic about them. But taking a road trip across the country is an American pasttime, so why not do it in R?

Let’s start by loading all the packages we’ll need. We’ll also need to install the developmental version of rayshader from github: 

# remotes::install_github("tylermorganwall/rayshader")
library(sf)
library(terra)
library(raster)
library(dplyr)
library(ggplot2)
library(rayshader)
library(rgl)
library(spData)
sf_use_s2(FALSE)

Now we’ll load our data. The elevation data is from GEBCO, which combines topographic with bathymetric data in a single global dataset, which makes for easy plotting. We’ll load it with the {terra} package, using terra::rast(). The highway data is from data.gov (get it here: https://catalog.data.gov/dataset/tiger-line-shapefile-2016-nation-u-s-primary-roads-national-shapefile), which we’ll load with sf::st_read(). We’ll also rename the spData::us_state dataset to mainland_us, purely for convenience. 

all_earth = rast("~/Desktop/spatial_data/gebco_2022_sub_ice_topo/GEBCO_2022_sub_ice_topo.nc")
highwaydata = st_read("~/Desktop/spatial_data/tl_2016_us_primaryroads/tl_2016_us_primaryroads.shp")
## Reading layer `tl_2016_us_primaryroads' from data source 
##   `/Users/tyler/Desktop/spatial_data/tl_2016_us_primaryroads/tl_2016_us_primaryroads.shp' 
##   using driver `ESRI Shapefile'
## Simple feature collection with 12509 features and 4 fields
## Geometry type: LINESTRING
## Dimension:     XY
## Bounding box:  xmin: -170.8313 ymin: -14.3129 xmax: -65.64866 ymax: 49.00209
## Geodetic CRS:  NAD83
water_bodies = st_read("~/Desktop/spatial_data/USA_Detailed_Water_Bodies/USA_Detailed_Water_Bodies.shp")
## Reading layer `USA_Detailed_Water_Bodies' from data source 
##   `/Users/tyler/Desktop/spatial_data/USA_Detailed_Water_Bodies/USA_Detailed_Water_Bodies.shp' 
##   using driver `ESRI Shapefile'
## Simple feature collection with 463591 features and 7 fields
## Geometry type: MULTIPOLYGON
## Dimension:     XY
## Bounding box:  xmin: -160.2311 ymin: 19.204 xmax: -66.99787 ymax: 49.38433
## Geodetic CRS:  WGS 84
mainland_us = spData::us_state

The highway data includes all interstates in the country: let’s only pull out I-80, which stretches from the San Francisco, CA to Teaneck, NJ (both equally famous cities). 

head(highwaydata)
## Simple feature collection with 6 features and 4 fields
## Geometry type: LINESTRING
## Dimension:     XY
## Bounding box:  xmin: -122.6895 ymin: 38.34893 xmax: -75.61068 ymax: 45.54082
## Geodetic CRS:  NAD83
##        LINEARID         FULLNAME RTTYP MTFCC                       geometry
## 1 1105647111403 Morgan Branch Dr     M S1100 LINESTRING (-75.61562 38.62...
## 2 1103662626368      Biddle Pike     M S1100 LINESTRING (-84.56702 38.36...
## 3 1103662626717  Cincinnati Pike     M S1100 LINESTRING (-84.56805 38.34...
## 4 1105056901124           I- 405     I S1100 LINESTRING (-122.6796 45.54...
## 5 1105056901128           I- 405     I S1100 LINESTRING (-122.671 45.506...
## 6 1105056901162            I- 70     I S1100 LINESTRING (-85.2209 39.853...
i80data = highwaydata |> 
  filter(FULLNAME == "I- 80")

Now let’s use our polygon data to compute a bounding box (using sf::st_bbox()) for the USA, which we’ll then use to crop (using terra::crop()) our global elevation data. We’ll also reduce the resolution by a factor of 8 using terra::aggregate() so our 3D model isn’t gigantic, and create an elevation matrix out of it using rayshader’s raster_to_matrix() function. We’ll also shave off the last and first rows, as for some reason they come back as NA values. 

bbox = st_bbox(mainland_us)

just_usa = crop(all_earth, bbox) |> 
  aggregate(8)

usa_mat = raster_to_matrix(just_usa)
usa_mat_nan1 = usa_mat[,-ncol(usa_mat)]
usa_mat_nan2 = usa_mat_nan1[-nrow(usa_mat),]

Let’s make sure all the spatial data is in the same coordinate system by using sf::st_transform() and sf::st_crs(). We’ll transform all the other spatial objects to the {terra} object’s coordinate system: 

crs_us = mainland_us |> 
  st_transform(st_crs(just_usa))

usa_water_bodies = water_bodies |> 
  st_transform(st_crs(just_usa))

Now let’s filter out the water bodies to only include the large ones (this is so we don’t have to wait around while we process a bunch of small ponds and lakes that aren’t big enough to appear on our map): 

big_water_bodies = usa_water_bodies |> 
  filter(FTYPE == "Lake/Pond" & SQMI > 100)

And let’s create a color palette we’ll use for the bathymetry data and generate an overlay to apply to all elevations below sea level. This will help distinguish land from the ocean, as we are working with a dataset with combined topographic/bathymetric data. We’ll generate the land data using the default height_shade() palette, and set the minimum altitude to 0. We’ll then plot this map with plot_map(). 

water_palette = colorRampPalette(c("darkblue", "dodgerblue", "lightblue"))(200)
bathy_hs = height_shade(usa_mat_nan2, texture = water_palette)

usa_mat_nan2 |>
  height_shade(range = c(0,max(usa_mat_nan2))) |>
  add_overlay(generate_altitude_overlay(bathy_hs, heightmap = usa_mat_nan2, 
                                        start_transition = 0, lower = TRUE)) |>
  plot_map()

Hillshade of the United States, created with rayshader

Now let’s render our 3D map! This involves taking our hillshade generated above and adding our overlays for state polygons and large non-oceanic bodies of water in the USA, and then plotting it all in 3D. 

usa_mat_nan2 |>
  height_shade(range = c(0,max(usa_mat_nan2))) |>
  add_overlay(generate_altitude_overlay(bathy_hs, heightmap = usa_mat_nan2, 
                                        start_transition = 0, lower = TRUE)) |>
  add_overlay(generate_polygon_overlay(big_water_bodies, extent = just_usa, linecolor = NA,
                                       width = nrow(usa_mat_nan2) * 4,height = ncol(usa_mat_nan2) * 4,
                                       heightmap = usa_mat_nan2, palette = "dodgerblue2"),
              rescale_original = TRUE) |>
  add_overlay(generate_polygon_overlay(crs_us, extent = just_usa, linewidth = 16,linecolor ="white",
                                       width = nrow(usa_mat_nan2) * 8,
                                       height = ncol(usa_mat_nan2) * 8, palette = NA),
              rescale_original = TRUE) |>
  plot_3d(usa_mat_nan2,water=FALSE,zscale=200)

render_resize_window(width=1000, height=800)
render_camera(theta = 45, phi = 45, zoom = 0.7)
render_snapshot(software_render = TRUE, fsaa = 2)

3D map of the United States (with state barriers), created in R with rayshader

Now we plot our road data using render_path(). We’ll offset this slightly off the ground (using the offset argument) so the actual highway is floating and not half-buried in the ground. 

render_path(i80data, extent = just_usa, heightmap = usa_mat_nan2, color="red",
            linewidth = 2, zscale=200, offset = 50)
render_snapshot(software_render = TRUE, fsaa = 2, line_radius = 1)

Adding I-80 in red, crossing the USA

Now to generate our animation: rayshader has a convenient function called convert_path_to_animation_coords() that, unsurprisingly, converts geospatial paths to the coordinate system used by rayshader to create an animation. It takes the path (as defined by a spatial object with “LINESTRING” or “MULTILINESTRING” geometry) and moves the camera at a constant step-size along that path. Here’s where we run into our first problem: if we assume our spatial data is nice and clean and all ready to convert to an animation as-is, we will be sorely disappointed. Let’s visualize what the problem is. The {sf} object here is made up of a series of line objects: let’s plot them in the order they are given in the object. We’ll plot each line segment 1000 units higher than the previous: ideally, the data from rise from one side of the county to the other, indicating the data is arranged sequentially. Is that what we see? 

for(i in seq_len(nrow(i80data))) {
  render_path(i80data[i,], extent = just_usa, heightmap = usa_mat_nan2, color="black",
              linewidth = 2, zscale=200, offset = 1000*i)
}
render_camera(theta = 0, phi = 30, zoom = 0.7)
render_resize_window(1200,1000)
render_snapshot(software_render = TRUE, fsaa = 2, line_radius = 1)

Visualizing how the {sf} object does not come pre-sorted by using the segment order as the altitude: the slices of highway aren’t arranged end-to-end, and many (but not all!) of the segments of the highway have both eastbound and westbound segments present.

Oh no. Not at all. And even worse, it appears we have duplicates: some (but confusingly, not all!) segments of the highway include both east and west-bound lanes. So we need to remove duplicates and reorder the data so each segment lines up end-to-end. I wrote a nice little helper utility to merge and clean paths in render_path() and convert_path_to_animation_coords() that you can turn on by setting reorder = TRUE. This algorithm first starts by comparing each segment’s end and start points to every other segment’s end and start points (and checking them reversed, in case the line orientation is flipped) and throws away segments where both ends fall within reorder_duplicate_tolerance distance to another segment. It then starts with the segment at row reorder_first_index and then searches for another segment with a start/end point within reorder_merge_tolerance distance and reorders the sf object to make them sequential. Once it can’t find any segments within reorder_merge_tolerance (and if reorder_first_index is greater than 1), it will then do the process in reverse, starting with first segment’s starting point. The algorithm isn’t perfect and needs to be fine-tuned for each dataset with the tolerance values, but as you’ll see: it does the job! (you can also look into sf::st_line_merge() which does something similar, but it didn’t work on this dataset, although it got close).

Let’s now visualize the order of the path segments with reorder = TRUE. We’ll call the internal function that does the reordering so we can show the sequential ordering of the path (represented in the altitude). 

i80data_reordered = rayshader:::ray_merge_reorder(i80data, 
                                                  merge_tolerance = 0.45, 
                                                  duplicate_tolerance = 0.20)

render_path(i80data, extent = just_usa, heightmap = usa_mat_nan2, color="red",
            reorder = TRUE, resample_evenly = TRUE, resample_n = 1000,
            linewidth = 2, zscale=200, offset = 50, clear_previous = TRUE)

for(i in seq_len(nrow(i80data_reordered))) {
  render_path(i80data_reordered[i,], extent = just_usa, heightmap = usa_mat_nan2, color="black",
              linewidth = 2, zscale=200, offset = 1000*i)
}
render_camera(theta = 0, phi = 30, zoom = 0.45)
render_resize_window(1200,600)
render_snapshot(software_render = TRUE, fsaa = 2, line_radius = 1)

Sorting the {sf} object using rayshader’s new line reordering capabilities.

Nice and ordered! Now all the hard work is done. We just need to call convert_path_to_animation_coords() with the proper arguments to get the flyover we want. By default, this function will produce a visualization looking along the path (like a rollercoaster) but I want to make an overhead 3rd person view, so we set follow_camera = TRUE. I’ll also fix the camera’s distance by setting follow_fixed = TRUE and set the offset vector to follow_fixed_offset = c(25,25,25). I’ll damp the motion a bit by setting damp_motion = TRUE and setting damp_magnitude to a value between one and zero. This option smooths the camera motion when it jumps and jerks around too fast.

We can visualize the camera path in black by calling rgl::points3d() in the scene. 

camera_coords = convert_path_to_animation_coords(
  i80data,
  extent = just_usa, 
  offset_lookat = 1,
  heightmap = usa_mat_nan2, 
  zscale = 200,
  offset = 0, 
  reorder = TRUE,
  reorder_merge_tolerance = 0.45, 
  reorder_duplicate_tolerance = 0.20,
  resample_path_evenly = TRUE,
  frames = 1080, 
  follow_camera = TRUE,
  follow_fixed = TRUE,
  follow_fixed_offset = c(25,25,25),
  damp_motion = TRUE, 
  damp_magnitude = 0.5
)
render_path(i80data, extent = just_usa, heightmap = usa_mat_nan2, color="red",
            reorder = TRUE, 
            linewidth = 2, zscale=200, offset = 50, clear_previous = TRUE)

render_camera(theta = 0, phi = 30, zoom = 0.85)
render_resize_window(1200,1200)
rgl::lines3d(camera_coords[,1:3], color="black", tag = "path3d")
render_snapshot(software_render = TRUE, fsaa = 2, line_radius = 1)

Visualizing a basic follow camera path that directly follows the path.

This camera path just directly follows the road. We can use rayshader’s render_highquality(animation_camera_coords = …) interface to pass these coordinates and render all the frames of an animation, and then convert these frames to an video file using ffmpeg (or the {av} package, if you want to work entirely in R). 

camera_coords$fov = 80
render_highquality(animation_camera_coords = camera_coords,
                   cache_filename = "cache_america", load_normals = FALSE,
                   samples=128, line_radius=0.10, sample_method = "sobol_blue", 
                   filename="roadtrip_frames_fixed")
Visualizing a basic follow camera path that directly follows the path.

This animation isn’t bad, but the fixed view is fairly basic and not that interesting. To make the camera view more dynamic and cinematic (following the ideas laid out in this Mapbox blog post), I can tell rayshader to rotate the fixed view around the focal point by setting the follow_rotation argument. I’ll have it execute three full rotations from one side of the county to the other.

Let’s plot the camera motion now to see what that looks like: 

rgl::pop3d()
camera_coords = convert_path_to_animation_coords(
  i80data,
  extent = just_usa, 
  offset_lookat = 1,
  heightmap = usa_mat_nan2, 
  zscale = 200,
  offset = 0, 
  reorder = TRUE,
  reorder_merge_tolerance = 0.45, 
  reorder_duplicate_tolerance = 0.20,
  resample_path_evenly = TRUE,
  frames = 1080, 
  follow_camera = TRUE,
  follow_fixed = TRUE,
  follow_fixed_offset = c(25,25,25),
  follow_rotations = 3,
  damp_motion = TRUE, 
  damp_magnitude = 0.5
)
render_camera(theta = 90, phi = 45, zoom = 0.65)
rgl::lines3d(camera_coords[,1:3], color="black", tag = "path3d")

Visualizing a follow camera path that includes rotation.

Great! You can see the path orbits around the path, which when combined with the movement along the path results in a cycloid-like movement pattern when viewed from above. Now let’s generate our final, high-quality pathtraced animation. We can pass these coords to animation_camera_coords in render_highquality() to render all the frames for our animation. I’ll also reverse the video to run in the opposite direction, so we end the animation traversing the exciting mountain west rather than the comparatively flat (and boring) northeast. You might think pathtracing 1080 frames would take an outrageously long time (especially since R is “only good at statistics”😉), but by setting the sample method to “sobol_blue”, the adaptive pathtracing in rayrender will speed through the frames fairly quickly (in just a few hours!). In less time than the equivilent cross-country flight, at least :). 

render_highquality(animation_camera_coords = camera_coords[nrow(camera_coords):1,], width=800, height=800,
                   samples=128, line_radius=0.10, sample_method = "sobol_blue", 
                   filename="roadtrip_frames")

Now we go to the terminal to turn this frames into a movie with ffmpeg. You can also do this with the {av} package in R, but I’m going to be doing something a little more advanced in a second that will require the command line version of ffmpeg. 

> ffmpeg -framerate 24 -i roadtrip_frames%d.png -pix_fmt yuv420p roadtrip_frames_better.mp4
Initial (fast) render of video

Now, this final animation is a little fast. We can slow down the video to a reasonable speed by rendering in ffmpeg at half the framerate, from 24 to 12 frames per second. 

> ffmpeg -framerate 12 -i roadtrip_frames%d.png -pix_fmt yuv420p roadtrip_frames_slow.mp4
Second slower but choppier render of video

You might note that this does make the video unwatchably choppy, but we can pull a little ffmpeg magic out of our hat and fix that without requiring us to do any more expensive pathtracing. Since the camera movement in our animation is fairly smooth, we can actually use motion interpolation to fill in the missing frames. Yes, motion interpolation: the weird soap opera effect that completely ruins the aesthetic of movies at your relative’s house during the holidays. We call ffmpeg with the following script to add motion interpolation to get our smooth road trip across America. 

>  ffmpeg -i roadtrip_frames_slow.mp4 -filter:v "minterpolate=fps=24:mi_mode=mci:mc_mode=aobmc:me_mode=bidir:vsbmc=1" roadtrip_frames_interpolated.mp4
Previous video, but now with motion interpolation filling in the gaps

Great! The only downside of motion interpolation here are slight visual artifacts at the edge of the frame, but here it’s not that noticeable most of the time. In just a few lines of code (and a few hours of render time), we’ve created an animation traveling across all of America, entirely in R. You can imagine all the different types of data you might use this for: trips, hikes, animal tracks, bike rides, Twitter CEO flights—the list is endless. Try it on your own data—you might be surprised how you can bring life to an otherwise unassuming spatial dataset by adding a little cinematic 3D magic!

]]> 3D Cartography GIS Data Data Visualization Maps R Rayrender Rayshader Pathtracing Animation https://www.tylermw.com/posts/data_visualization/roadtripping-america-in-r-turning-spatial-data-into-animations-with-rayshader.html Fri, 27 Jan 2023 06:45:01 GMT Tutorial: Visualizing Saturn’s Changing Appearance from Earth in R Tyler Morgan-Wall https://www.tylermw.com/posts/data_visualization/tutorial-visualizing-saturns-appearance-from-earth-in-r.html

Saturn! The sixth planet from the Sun and the second-largest in the Solar System, named after the Roman god of wealth and agriculture. A planet the universe liked so much it put a ring on it (many rings, in fact). Unlike the rest of the planets, which are just glorified spheres spinning through space, Saturn has a uniquely 3D appearance thanks to its extensive ring system and its 26.7 degree axial tilt. You can have years where the rings are prominently on display when viewed from Earth followed by periods where it almost completely disappears. Question: Can we accurately simulate its appearance from Earth, given a specified date in the future or the past?

Answer: With a little work, yes! Using R and the rayverse, of course. Let me walk you through generating a 3D version of a planet and rendering it from Earth’s perspective, using rayrender (a pathtracer in R).

Generating a 3D planet model itself is relatively simple, as there are many resources for planet textures out there (here’s a link to the Saturn texture from solarsystemscope.com). The planet itself is unique in our solar system due to its extreme oblate-ness: Saturn doesn’t look correct unless you accurately represent its big equatorial bulge (which arises from its rapid 10 hour rotational period). And the ellipsoid object is directly implemented in rayrender, so the planet itself can be represented in a single line of code without any further processing. 

ellipsoid(a=0.82,c=0.82,b=0.74, material=diffuse(color="white",image_texture = "2k_saturn.jpg"))) %>%
  group_objects(translate = c(10,0,0), angle=c(26.73,270,0)) %>%
  add_object(sphere(x=0,z=0,y=0,radius=0.125/2,material=light(intensity = 4800*4, invisible = T))) %>% 
  render_scene(fov=12,min_variance = 1e-6, clamp_value = 10, lookfrom=c(1,0,0), lookat=c(10,0,0),
               camera_up = c(0,1,0),
               sample_method = "sobol_blue",samples = 256, 
               width=1000, height=600, aperture = 0)

An unbetrothed Saturn.

The first real challenge was generating an accurate (size, color, and transparency) representation Saturn’s rings: I needed a texture that I could apply to a flat surface that was centered at Saturn and started and ended exactly where the rings do in space. One google search later, I found the next best thing: a side profile of the ring structure with alpha transparency embedded in the image, with the different ring distances annotated. How to turn this into a full ring texture?

Saturn ring profile with transparency.

First, let’s load the image into R. We’ll resize it to half its size to ease our memory use when generating the full-sized texture. We’ll also figure out how much padding we need to add to the inner ring based on the start and end of the rings in the texture: the rings start at 66,900 km and end at 139,826 km, and our re-scaled image is 1963 pixels wide. This means the resized image has 37.15 km/pixel, so we need to ensure there are 66,900/37.15 = 1800 pixels of padding in the center of our ring texture before the inner radius of the ring begins. 

library(rayrender)
library(lubridate)
## 
## Attaching package: 'lubridate'
## The following objects are masked from 'package:base':
## 
##     date, intersect, setdiff, unio
library(rayimage)
library(rayvertex)
## 
## Attaching package: 'rayvertex'
## The following object is masked from 'package:rayrender':
## 
##     r_obj
full_ring_slice = png::readPNG("saturn_ring_texture.png")
half_ring_slice = render_resized(full_ring_slice, dims = c(125,3926/2))

inc = (139826-66900)/(3926/2)
padding = 66900/inc
full_width = ncol(half_ring_slice)

Now we’ll write a function that calculates a distance based on the image texture pixel to determine what color/opacity the ring should be at that radius. We calculate a radial distance from the center of the image and rescale it based on the padding value we calculated before. We then calculate the weighted value of the two nearest entries in the side-profile texture and return that value. 

return_texture = function(i,j,k) {
  distanceval = (sqrt((i-full_width-1)^2 + (j-full_width-1)^2) + 1 ) * (padding + full_width)/full_width
  
  frac = distanceval - floor(distanceval)
  if(distanceval <= padding+full_width-1 && distanceval > padding+1) {
    half_ring_slice[64,distanceval-padding,k] * (1-frac) + 
      half_ring_slice[64,distanceval+1-padding,k] * frac
  } else {
    0
  }
}

We’ll then generate our target image, a 4 layer RGB + alpha array. We then loop through all the pixels in the target image to calculate their color and opacity, and make it 5x smaller to speed up the final render (the lower fidelity won’t matter at the resolution we’re going to render at). 

texture_mat = array(0,c(2*(full_width),2*(full_width),4))
for(i in 1:nrow(texture_mat)) {
  for(j in 1:ncol(texture_mat)) {
    texture_mat[i,j,1] = return_texture(i,j,1)
    texture_mat[i,j,2] = return_texture(i,j,2)
    texture_mat[i,j,3] = return_texture(i,j,3)
    texture_mat[i,j,4] = return_texture(i,j,4)
  }
}
texture_mat_small = render_resized(texture_mat,mag=0.2)

Which gives us our texture:

Saturn ring texture with transparency.

After scaling all the dimensions of the ellipsoid properly, texturing a disk object with the texture we just generated, and rotating it with the proper axial tilt we get a nice accurate representation of Saturn: 

disk(radius = 2, inner_radius = 0.9,
     material=diffuse(color="white", sigma = 90,
                      image_texture = texture_mat_small)) %>% 
  add_object(ellipsoid(a=0.82,c=0.82,b=0.74, 
                       material=diffuse(color="white",
                                        image_texture = "2k_saturn.jpg"))) %>%
  group_objects(angle=c(26.73,11,0), order_rotation = c(1,2,3)) ->
saturn_model

saturn_model %>% 
  add_object(sphere(z=12,material=light(intensity = 100))) %>% 
  render_scene(fov=18,samples=160,lookfrom=c(10,0,5),width=1000,height=800,
               clamp_value = 10, sample_method = "sobol_blue")

Saturn, rendered in R.

Now: how to render this correctly from the perspective of Earth? That requires calculating the positions of both Earth and Saturn as a function of time. My first instinct was to calculate the positions using Kepler’s laws. There’s a reference coordinate frame (epoch) that starts in the year 2000 (known as J2000) that has reference values that you can use to solve for the approximate positions of the planets (more information available here: https://ssd.jpl.nasa.gov/planets/approx_pos.html#tables). Here’s a function that takes those values and returns the position of the planet (in astronomical units). 

earth = list(a  = 1.00000018,
             a_dot = -0.00000003,
             e = 0.01673163,
             e_dot = -0.00003661,
             I = -0.00054346,
             I_dot = -0.01337178,
             L = 100.46691572,
             L_dot = 35999.37306329,
             omega = 102.93005885,
             omega_dot = 0.31795260,
             Omega = -5.11260389,
             Omega_dot = -0.24123856,
             b = 0,
             c = 0,
             s = 0,
             f = 0)

saturn = list(a  = 9.54149883,
             a_dot = -0.00003065,
             e = 0.05550825,
             e_dot = -0.00032044,
             I = 2.49424102,
             I_dot = 0.00451969,
             L = 50.07571329,
             L_dot = 1222.11494724,
             omega = 92.86136063,
             omega_dot = 0.54179478,
             Omega = 113.63998702,
             Omega_dot = -0.25015002,
             b = 0.00025899,
             c = -0.13434469,
             s = 0.87320147,
             f = 38.35125000)


calculate_position = function(date, planet_list) {
  TT = as.numeric(date - ymd("2000-01-01"))/36525
  a0  = planet_list$a
  a_dot = planet_list$a_dot
  e0 = planet_list$e
  e_dot = planet_list$e_dot
  I0 = planet_list$I
  I_dot = planet_list$I_dot
  L0 = planet_list$L
  L_dot = planet_list$L_dot
  peri_long0 = planet_list$omega
  peri_long_dot = planet_list$omega_dot
  Omega0 = planet_list$Omega
  Omega_dot = planet_list$Omega_dot
  b = planet_list$b
  c = planet_list$c
  s = planet_list$s
  f = planet_list$f
  
  a = a0 + a_dot * TT
  eccentricity = e0 + e_dot * TT
  L = L0 + L_dot * TT
  peri_long = peri_long0 + peri_long_dot * TT 
  Omega = Omega0 + Omega_dot * TT
  Ival = I0 + I_dot * TT
  
  e_star = 180/pi  * eccentricity
  
  omega = peri_long - Omega
  M = L - peri_long + b * TT^2 + c * cos(f*TT) + s * sin(f * TT)
  while(M < -180) {
    M = M + 360
  }
  while(M > 180) {
    M = M - 360
  }
  tol = 1e-6
  delta_E = 1
  ecc0 = M - e_star * sinpi(M/180)
  eN = ecc0
  #Solve using Newton's method
  while(abs(delta_E) >= tol) {
    delta_M = M - eN - e_star * sinpi(eN/180)
    delta_E = delta_M/(1-eccentricity * cospi(eN/180))
    eN = eN + delta_E
  }
  E = eN
  x_prime = a * (cospi(E/180)-eccentricity)
  y_prime = a * sqrt(1-eccentricity^2) * sinpi(E/180)
  
  x = (cospi(omega/180)*cospi(Omega/180)  - sinpi(omega/180) * sinpi(Omega/180) * cospi(Ival/180)) * x_prime +
    (-sinpi(omega/180)* cospi(Omega/180) - cospi(omega/180) * sinpi(Omega/180) * cospi(Ival/180)) * y_prime
  y = (cospi(omega/180)*sinpi(Omega/180)  + sinpi(omega/180) * cospi(Omega/180) * cospi(Ival/180)) * x_prime +
    (-sinpi(omega/180)* sinpi(Omega/180) + cospi(omega/180) * cospi(Omega/180) * cospi(Ival/180)) * y_prime
  z = sinpi(omega/180) * sinpi(Ival/180) * x_prime + 
    cospi(omega/180) * sinpi(Ival/180) * y_prime
  return(c(x,y,z))
}

I wrote this and rendered the full animation and it appeared to work well initially, but as I looked a little closer things weren’t exactly right. To check if it was correct, I decided to calculate the appearance of Saturn on a few very specific days in the future when the Earth experiences what’s called a ring plane crossing. These are events where the Earth’s viewpoint is exactly aligned with Saturn’s rings, so the rings appear to completely disappear. When I rendered using this method, the ring plane crossings were all a few months off. It turns out this first-order approximate method doesn’t provide enough fidelity to render these events accurately, so I needed to find a better way to get the planet’s positions.

And luckily, I didn’t have to search far! JPL provides a nice, free web interface that you can use to calculate the positions of the planets for a specified range of dates. These positions are much more accurate: It is typically the same data used at JPL for radar astronomy, mission planning, and spacecraft navigation. Selecting Earth and Saturn and exporting daily data from 2020-2050, I generated these datasets:

Location of Earth, 2020-2050

Location of Saturn, 2020-2050

And loaded them into R using the readr package (with some additional data cleaning steps, which might change depending on the dataset): 

library(readr)
horizons_results_earth = read_table2("horizons_results_earth.txt", 
                                      col_names = FALSE, 
                                     col_types = cols(X9 = col_skip(), X8 = col_skip(), 
                                                      X1 = col_skip(), X2 = col_skip(), 
                                                      X4 = col_skip(), X10 = col_skip()), 
                                     skip = 50)
## Warning: 44 parsing failures.
##   row col   expected    actual                                                 file
##     2  -- 10 columns 1 columns 'horizons_results_earth.txt'
##     3  -- 10 columns 1 columns 'horizons_results_earth.txt'
## 18268  -- 10 columns 1 columns 'horizons_results_earth.txt'
## 18269  -- 10 columns 1 columns 'horizons_results_earth.txt'
## 18270  -- 10 columns 1 columns 'horizons_results_earth.txt'
## ..... ... .......... ......... ....................................................
## See problems(...) for more details.
horizons_results_earth_t = horizons_results_earth[-(1:3),]
horizons_results_earth_trim = horizons_results_earth_t[-(18265:nrow(horizons_results_earth)),]
colnames(horizons_results_earth_trim) = c("date","x","y","z")
horizons_results_earth_trim$x = as.numeric(gsub(",",x=horizons_results_earth_trim$x,
                                                replacement="",fixed = T))
horizons_results_earth_trim$y = as.numeric(gsub(",",x=horizons_results_earth_trim$y,
                                                replacement="",fixed = T))
horizons_results_earth_trim$z = as.numeric(gsub(",",x=horizons_results_earth_trim$z,
                                                replacement="",fixed = T))
horizons_results_earth_trim$date = ymd(horizons_results_earth_trim$date)

horizons_results_saturn = read_table2("horizons_results_saturn.txt", 
                                       col_names = FALSE, 
                                      col_types = cols(X9 = col_skip(), X8 = col_skip(), 
                                                       X1 = col_skip(), X2 = col_skip(), 
                                                       X4 = col_skip(), X10 = col_skip()), 
                                      skip = 47)
## Warning: 42 parsing failures.
##   row col   expected    actual                                                  file
## 18265  -- 10 columns 1 columns 'horizons_results_saturn.txt'
## 18266  -- 10 columns 1 columns 'horizons_results_saturn.txt'
## 18267  -- 10 columns 1 columns 'horizons_results_saturn.txt'
## 18268  -- 10 columns 1 columns 'horizons_results_saturn.txt'
## 18270  -- 10 columns 9 columns 'horizons_results_saturn.txt'
## ..... ... .......... ......... .....................................................
## See problems(...) for more details.
horizons_results_saturn_t = horizons_results_saturn
horizons_results_saturn_trim = horizons_results_saturn_t[-(18262:nrow(horizons_results_saturn)),]
colnames(horizons_results_saturn_trim) = c("date","x","y","z")
horizons_results_saturn_trim$x = as.numeric(gsub(",",x=horizons_results_saturn_trim$x,
                                                 replacement="",fixed = T))
horizons_results_saturn_trim$y = as.numeric(gsub(",",x=horizons_results_saturn_trim$y,
                                                 replacement="",fixed = T))
horizons_results_saturn_trim$z = as.numeric(gsub(",",x=horizons_results_saturn_trim$z,
                                                 replacement="",fixed = T))
horizons_results_saturn_trim$date = ymd(horizons_results_saturn_trim$date)

The function to extract planetary positions from this data is much simpler than solving Kepler’s equation: we just index into the data set and extract the desired day (the negative sign is to correct the orientation of the data in our coordinate system). 

calculate_saturn_position = function(date) {
  val = as.numeric(horizons_results_saturn_trim[horizons_results_saturn_trim$date == date,c(2,4,3)])
  val * c(-1,1,1)
}

calculate_earth_position = function(date) {
  val = as.numeric(horizons_results_earth_trim[horizons_results_earth_trim$date == date,c(2,4,3)])
  val * c(-1,1,1)
}

Now we use the lubridate package to loop through each week from 2020 through 2050 and render the 3D scene from Earth’s viewpoint (specified via the lookfrom argument in render_scene()). I set the sun as the only light source at the origin, and make it invisible so we can see how Saturn appears without worrying about the Sun occluding our render every other second. We then use ffmpeg to turn these frames into a video. 

temp = ymd("2020-Jan-01")
end_date = ymd("2050-Jan-01")
counter = 1

while(temp < end_date) {
  saturn_pos = calculate_saturn_position(temp)
  earth_pos = calculate_earth_position(temp)
  
  saturn_model %>% 
    group_objects(translate = saturn_pos) %>% 
    add_object(sphere(x=0,z=0,y=0,radius=0.125,
                      material=light(intensity = 4800, invisible = T))) %>% 
    render_scene(fov=25,min_variance = 1e-6, clamp_value = 10, 
                 lookfrom=earth_pos, lookat=saturn_pos,
                 sample_method = "sobol_blue",samples = 256, width=1000, height=1000,
                 filename=sprintf("saturn_earth_%d.png",counter),
                 verbose = T,
                 aperture = 0) 
  counter = counter + 1
  temp = temp + period("1 week")
}

system("ffmpeg -framerate 24 -i saturn_earth_%d.png -pix_fmt yuv420p saturn.mp4")

I also want to generate a diagram of the solar system showing an overview of Earth and Saturn’s locations (which better shows when they’re in opposition). I do that using the rayvertex package, which is a useful tool for producing more diagrammatic 2D/3D visualizations. I first generate a series of line segments that show the orbits through a full 30/1 year period for Saturn/Earth (respectively): 

#Generate Solar System diagram with rayvertex
temp = lubridate::ymd("2000 Jan 01")
end = lubridate::ymd("2030 Jan 01")

saturn_positions = list()
counter = 1
while(temp < end) {
  saturn_positions[[counter]] = calculate_saturn_position(temp)
  temp = temp + period("1 month")
  counter = counter + 1
}

temp = lubridate::ymd("2000 Jan 01")
end = lubridate::ymd("2001 Jan 02")

earth_positions = list()
counter = 1
while(temp < end) {
  earth_positions[[counter]] = calculate_earth_position(temp)
  temp = temp + period("1 week")
  counter = counter + 1
}

scene = segment_mesh(start=saturn_positions[[1]], 
                     end=saturn_positions[[2]],radius = 0.1,
                     material = material_list(ambient=c(1,1,1), 
                                              diffuse_intensity = 0))

for(i in 2:(length(saturn_positions)-1)) {
  scene = add_shape(scene, segment_mesh(start=saturn_positions[[i]], 
                                        end=saturn_positions[[i+1]],
                                        radius = 0.1,
                           material = material_list(ambient=c(1,1,1), 
                                                    diffuse_intensity = 0)))
}

for(i in 1:(length(earth_positions)-1)) {
  scene = add_shape(scene, segment_mesh(start=earth_positions[[i]], 
                                        end=earth_positions[[i+1]],
                                        radius = 0.1,
                                        material = material_list(ambient=c(1,1,1), 
                                                                 diffuse_intensity = 0)))
}

I then add the sun and the planets, and render a cone representing the camera viewpoint from Earth to Saturn. I look through all the days I created views for in the main rendering. 

scene = add_shape(scene,sphere_mesh(radius=0.3, 
                                    material = material_list(ambient=c(1,1,1), 
                                                             diffuse_intensity = 0)))

rasterize_scene(scene, lookfrom=c(0,20,0), lookat=c(0,0,0),camera_up = c(0,0,1), 
                fov = 0, ortho_dimensions = c(22,22),
                width=200,height=200, fsaa=4)

temp = ymd("2020-Jan-01")
end_date = ymd("2050-Jan-01")
counter = 1

while(temp < end_date) {
  saturn_pos = calculate_saturn_position(temp)
  earth_pos = calculate_earth_position(temp)
  
  dir = (saturn_pos - earth_pos)
  dir = dir/sqrt(sum(dir*dir))
  scene %>% 
    add_shape(sphere_mesh(radius = 0.45,position=c(0,2,0),
                          material=material_list(ambient="white",
                                                 diffuse="black", dissolve = 1))) %>% 
    add_shape(sphere_mesh(radius = 0.4,position=earth_pos + c(0,8,0),
                          material=material_list(ambient="#53a0da",diffuse="black" ))) %>% 
    add_shape(sphere_mesh(radius = 0.6,position=saturn_pos+c(0,8,0),
                          material=material_list(ambient="black",diffuse="black" ))) %>% 
    add_shape(sphere_mesh(radius = 0.4,position=saturn_pos+c(0,9,0),
                          material=material_list(ambient="white",diffuse="black" ))) %>% 
    add_shape(sphere_mesh(radius = 0.8,position=saturn_pos+c(0,7,0),
                          material=material_list(ambient="white",diffuse="black" ))) %>% 
    add_shape(cone_mesh(end = earth_pos + c(0,4,0), start = earth_pos + 22 * dir + c(0,4,0), radius=3, material = material_list(ambient="purple", diffuse_intensity = 0,type= "toon",
                         toon_levels = 10, toon_outline_color = "white",
                         toon_outline_width = 0.8))) %>% 
    rasterize_scene(lookfrom=c(0,20,0), lookat=c(0,0,0),camera_up = c(0,0,1), fov = 0, ortho_dimensions = c(22,22),
                    width=200,height=200, fsaa=4,
                    filename = sprintf("saturn_diagram%d.png",counter))
  counter = counter + 1
  temp = temp + period("1 week")
}

system("ffmpeg -framerate 24 -i saturn_diagram%d.png -pix_fmt yuv420p saturn_diagram.mp4")
Solar system diagram

I also render a series of images that label each date (using the rayimage package), and turn that into a movie as well. 

temp = ymd("2020-Jan-01")
end_date = ymd("2050-Jan-01")
counter = 1
while(temp < end_date) {
  date_title = format(temp, "%b %Y")
  add_title(matrix(0,ncol = nchar(date_title)*40, nrow=60*1.2), 
                      title_size  = 60,
                      title_offset = c(10,0),title_text = date_title, 
                      title_color = "white",
                      title_position = "east", 
                      filename = sprintf("saturn_date%d.png",counter))
  temp = temp + duration("1 week")
  counter = counter + 1
}

system("ffmpeg -framerate 24 -i saturn_date%d.png -pix_fmt yuv420p saturn_dates.mp4")
Animating the dates via lubridate and rayimage

Finally, I also want to include the data on ring crossings, which I got from this website. I used ggplot2 to generate a nice visualization and series of frames to accompany the rendering. 

#ring crossings
crossings = c(dmy("23 March 2025"),
              dmy("15 October 2038"),
              dmy("1 April 2039"),
              dmy("9 July 2039"))
crossing_df = data.frame(dates=crossings)

library(ggplot2)
library(ggfx)
library(extrafont)

font_import(paths = "/System/Library/Fonts/",prompt = F)

temp = ymd("2020-Jan-01")
end_date = ymd("2050-Jan-01")
counter = 1

while(temp < end_date) {
  rpc = ggplot() +
    with_bloom(geom_vline(xintercept = crossing_df$dates,color="#22ff22",lwd=0.6), 
               threshold_lower=10,strength = 30, sigma = 5)+
    with_bloom(geom_vline(xintercept = temp,color="#ff2222", lwd=0.6 ),
               threshold_lower=10,strength = 30, sigma = 5)+
    scale_x_date("Year", 
                 limits=c(ymd("2020-01-01"),ymd("2050-01-01")), 
                 date_breaks="2 years", date_labels = "%Y", 
                 date_minor_breaks = "1 year") +
    theme_void() +
    labs(title = "    2020-2050 Ring Plane Crossings") +
    theme(panel.background = element_rect(fill="black"),
          plot.background = element_rect(fill="black"),
          panel.grid.major = element_line(color="grey40"),
          panel.grid.minor = element_line(color="grey30"),
          axis.text.y = element_blank(),
          panel.grid.major.y = element_blank(),
          panel.grid.minor.y = element_blank(),
          plot.title = element_text(color="white", size=15,margin=margin(0,0,5,0),
                                    family = "Avenir", face="plain"),
          axis.text = element_text(color="white", size=10, margin=margin(10,0,0,0),
                                   family = "Avenir"),
          plot.margin = margin(10,-10,10,-10, "pt"),
          text = element_text(color="white"))
  ggsave(sprintf("ringplane%d.png",counter),plot=rpc, dpi=100, width=7.6, height=1.8)
  counter = counter + 1
  temp = temp + period("1 week")
}

system("ffmpeg -framerate 24 -i ringplane%d.png -pix_fmt yuv420p ring_plane_plot.mp4")
Creating and animating a series of ggplots.

Including this information is useful in two ways: first, ring crossings are the most dramatic change in Saturn’s appearance from Earth over any several-decade long period. If there’s a useful point to this visualization, it’s to know when these events occur. Secondly, from a “data viz engagement” point-of-view, this plot provides the viewer with actual “events” to drive them to continue watching the visualization. The red line moving provides an indication of progress and the green lines indicate that there’s something to look forward to. Otherwise, a viewer might click out after a few seconds of Saturn wobbling over and over again, thinking there’s nothing more to the story.

To complete the visualization, we use ffmpeg to combine all these animations together and add some text: 

ffmpeg -i saturn.mp4 -vf "drawbox=x=789:y=789:w=210:h=210:color=white@1.0:t=fill"  saturn_box.mp4

ffmpeg -i saturn_box.mp4 -i saturn_diagram.mp4 -filter_complex "[0][1]overlay=W-204.5:H-204.5" combined_saturn.mp4

ffmpeg -i combined_saturn.mp4 -y -vf drawtext="fontfile=/System/Library/Fonts/Avenir.ttc: text='View of Saturn from Earth, 2020-2050': fontcolor=white: fontsize=32: box=1: boxcolor=black@0: boxborderw=10: x=20: y=20" -codec:a copy combined_saturn_title.mp4

ffmpeg -i combined_saturn_title.mp4 -y -vf drawtext="fontfile=/System/Library/Fonts/Avenir.ttc: text='Solar System View': fontcolor=white: fontsize=22: box=1: boxcolor=black@0: boxborderw=0: x=805: y=765" -codec:a copy combined_saturn_title_diagram.mp4

ffmpeg -i combined_saturn_title_diagram.mp4 -vf drawtext="fontfile=/System/Library/Fonts/Avenir.ttc: text='Created with rayrender (www.rayrender.net)': fontcolor=white: fontsize=24: box=1: boxcolor=black@0: boxborderw=10: x=20: y=960" -codec:a copy combined_saturn_title_diagram_rr.mp4

ffmpeg -i combined_saturn_title_diagram_rr.mp4 -vf drawtext="fontfile='/System/Library/Fonts/Avenir.ttc: text='Twitter \@tylermorganwall': fontcolor='white': fontsize=24: box=1: boxcolor=black@0: boxborderw=10: x=20: y=930" -codec:a copy combined_saturn_title_diagram_rr_twit.mp4

ffmpeg -i combined_saturn_title_diagram_rr_twit.mp4 -y -vf drawtext="fontfile=/System/Library/Fonts/Avenir.ttc: text='From orbital plane, without sun occlusion': fontcolor='#aaaaaa': fontsize=24: box=1: boxcolor=black@0: boxborderw=10: x=20: y=57" -codec:a copy combined_saturn_title_diagram_rr_twit_for_pedants.mp4

ffmpeg -i combined_saturn_title_diagram_rr_twit_for_pedants.mp4 -i saturn_dates.mp4 -filter_complex "[0][1]overlay=W-325:15" final_saturn.mp4

ffmpeg -i final_saturn.mp4 -i ring_plane_plot.mp4 -filter_complex "[0][1]overlay=20:H-200" final_saturn_for_real_final.mp4

And that’s it! I hope you enjoyed this deep-dive into rendering planets from Earth’s perspective. Feel free to render other astronomical objects using this code, and be sure to post about it using the #rayrender and #RStats hashtags.

]]> 3D Data Analysis R Rayrender Pathtracing Data Visualization Space https://www.tylermw.com/posts/data_visualization/tutorial-visualizing-saturns-appearance-from-earth-in-r.html Thu, 11 Nov 2021 14:47:00 GMT Dataviz Nanopost: 360° VR Videos in R Tyler Morgan-Wall https://www.tylermw.com/posts/data_visualization/vr-videos-in-r.html Dataviz Nanopost: 360° VR Videos in R

When you create a traditional 3D visualization, one problem you inevitably have to tackle is “Where do I point the camera?” A poor choice of camera angle can obscure important information and confuse your viewer. And while you might want to direct your viewer to one area of your visualization, they might be interested in a different region altogether.

The solution? Render every camera angle and let your viewer choose! That’s the idea behind rayrender’s new 360° camera option. Rather than worry about animating the perfect camera path, you can just render everything and create a video that can be either viewed in VR or as a 360° video in your browser/on your phone that lets the viewer choose where to look. The only downside is increased render time—rather than rendering a small view into the world, you’re rendering the entire thing.

To create the above rollercoaster animation, I took the code from this post and made a few changes, listed in the single chunk below. If you want to recreate this animation, just run everything up to the last chunk and then run the chunk below. Not much is different: I just removed the custom lookat points and set fov = 360: everything else is the same! Check it out:

Code Snippet (see previous post for context): 

lookat_animated = generate_camera_motion(selected_points_offset, selected_points_offset,
                                          closed=TRUE, fovs = 360, constant_step = FALSE,
                                          curvature_adjust = "none",
                                          type = "bezier",
                                          frames=900,
                                          offset_lookat = 0)

render_animation(scene,lookat_animated, samples=128, width=1920,height=1080,
                 debug="preview",filename="animatelookat",
                 environment_light = "quarry_03_4k.hdr")
system("ffmpeg -framerate 30 -i animatelookat%d.png -pix_fmt yuv420p animated_video.mp4")

Additionally, if you want to upload the video to youtube, you’ll need to add additional spatial metadata to the mp4 file. You can do this using the free Google Spatial Media Metadata Injector python application.

Figure 1: Google Spatial Media Metadata Injector interface.

Just open the GUI, select the video (the left-most button, which was blank on my Apple device), check “My video is spherical (360)”, and then hit inject metadata. You’re ready to upload!

]]> 3D Data Data Visualization Maps R Rayrender Rayshader VR Fun Youtube Videos https://www.tylermw.com/posts/data_visualization/vr-videos-in-r.html Fri, 02 Apr 2021 01:36:12 GMT Dataviz Nanopost: Slices of the World Tyler Morgan-Wall https://www.tylermw.com/posts/data_visualization/dataviz-nanopost-slices-of-the-world.html Dataviz Nanopost: 3D Slices of the Earth

This is the first in a series of tiny posts where I show a data visualization along with the code used to generate it. I’ve always been annoyed at the lack of discoverability in Github Gists, so I’ve never really felt motivated to post code snippets there. Unlike github repos, gists tend to disappear into the void and never be seen again, unless linked by a blog post. And unlike Twitter, I can actually post the full code in a human (and text reader) friendly format. So I’m going to be posting my small “gists” here instead.

In this code snippet, I show how to use rayrender and rayshader to generate an animation of 3D slices of the earth’s bathymetry and topography. It’s basically a continuation of this blog post I released back in 2018, but now using the power of rayrender to make it prettier! Rendered in under 40 lines of code, too. Text/image overlay was applied post-processing using ffmpeg, which is the only step not included.

Here’s a link to the full-quality video if you’re interested (2000x1000).

Data source: NOAA (link)

Code: 

library(rayshader)
library(rayrender)

#Generate world map from topographic/bathymetric data
matval = raster_to_matrix(raster::raster("ETOPO1_Ice_g_geotiff.tif"))
smallmat = resize_matrix(matval,0.25)
water_palette = colorRampPalette(c("darkblue", "dodgerblue", "lightblue"))(200)
bathysmall = height_shade(smallmat,range = c(min(smallmat),0), texture = water_palette) 
smallmat %>% 
  height_shade(range = c(0,max(smallmat))) %>% 
  add_overlay(generate_altitude_overlay(bathysmall,smallmat,start_transition = 0)) %>% 
  save_png("worldmap.png")

#Dimension of raster data is now 5400x2700
slices = c(seq(1,2700,by=3),2700)

for(i in 1:(length(slices)-1)) {
  smallmat[,slices[i]:slices[i+1]] -> temp
  
  #Generate 3D model
  temp %>% 
    height_shade(range=range(smallmat)) %>% 
    plot_3d(temp,zscale=50,water=TRUE,shadow=FALSE,soliddepth = -11000/50,
            watercolor="dodgerblue4",solidcolor = "#D2691E")
  save_obj("tempobj")
  rgl::rgl.clear()
  
  #Render image with rayrender
  xz_rect(xwidth=10000,zwidth=10000,y=-250) %>%
    add_object(xz_rect(xwidth=5400, zwidth=2700, y=-220,
                       material=diffuse(image_texture="worldmap.png"),angle=c(0,180,0))) %>%
    add_object(cube(xwidth=5400, zwidth=2700, ywidth = 200, y=-325,
                    material = diffuse(color="grey20"))) %>% 
    add_object(sphere(radius=800,y=5000,z=-5000,material=light(intensity=70))) %>% 
    add_object(sphere(radius=800,y=5000,z=5000,material=light(intensity=20))) %>% 
    add_object(obj_model(z=mean(c(slices[i],slices[i+1]))-1350, "tempobj.obj",texture=TRUE)) %>% 
    render_scene(lookfrom=c(-1000,3500,4500),fov=0,lookat=c(0,-220,0),
                 ortho_dimensions = c(6000,3000),samples=256,
                 filename=sprintf("slices%g.png",i),
                 width=2000,height=1000,clamp_value = 10, min_variance = 1e-5)
}
]]> 3D Cartography Data Maps GIS R Rayrender Rayshader Pathtracing Data Visualization https://www.tylermw.com/posts/data_visualization/dataviz-nanopost-slices-of-the-world.html Thu, 25 Mar 2021 16:00:41 GMT DataCoaster Tycoon: Building 3D Rollercoaster Tours of Your Data in R Tyler Morgan-Wall https://www.tylermw.com/posts/data_visualization/datacoaster-tycoon.html DataCoaster Tycoon: Building 3D Rollercoaster Tours of Your Data in R with rayrender

3D data visualization presents unique challenges for the data viz practitioner. In 2D, you have to tackle problems like “How do I adjust the inner margins?” or “How can I nudge these overlapping labels away from each other?” or “Uhh… how do I do remove the legend again?” Formidable mainly because you need to know the correct code incantations to get the spacing/style you want, but conceptually not that dissimilar from fighting with Microsoft Word to properly layout a document or cutting and pasting together a tri-fold science fair project.

3D data visualizations, on the other hand, require an entirely different set of skills: rather than laying out points and lines on a flat 2D surface, you’re now required to embed your data in an abstract 3D space, set up camera angles and focal points, generate proper lighting, deal with data physically obscuring other data, set up your axes in 3D space, and more. The extra dimension provides additional freedoms but makes creating even simple plots fairly complex. And this complexity only increases when you actually want to generate an animation that travels through the space: suddenly, you now have to deal with animating your camera orientation AND position, and do it in a way that doesn’t make your audience nauseous. And most people aren’t great with navigating a 3D space to begin with (which is why we don’t all navigate our computers like we’re hacking Unix in Jurassic Park), much less setting up complex animations in that space via code.

This never became a thing.

What does any of this have to do with rollercoasters? Well, for a while I’ve been working on an animation interface for my R rendering package, rayrender. This interface takes a series of user-provided key frames of camera positions and orientations in 3D space and generates a smooth continuous camera track between them. However, many people have a hard enough time conceptualizing tweening between key frames in 2D: How do I create an easy-to-understand example of transitioning between 6D states (3D position + 3D orientation)? What’s a relatable example of smoothly moving through a 3D space along a well-defined track?

… Rollercoasters!

So this post isn’t about of a new type of 3D visualizations (Coasterplots!), but is rather a tech demonstration showing how to create animations through 3D space with R and rayrender’s new camera animation API. The rollercoaster part is because it’s a fun example, but slow down the coaster and add some narration and you have a guided monorail tour through your data—a concept that I think has real value. But for now, let’s just stick with the thrill rides to have some fun and show off what rayrender can do. Let’s get started!

The key new features in rayrender are the generate_camera_motion() and render_animation() functions, which work together to generate frames of an animation. generate_camera_motion() takes your key positions and number of frames, and generates the steps between those frames for a smooth camera transition. The default is to connect the key frames with cubic Bézier curves, and the implementation ensures continuity of the camera’s motion position and derivative. Rather than specifying an orientation with Euler angles (which have issues of gimble lock and aren’t very user-friendly), the orientation is animated via a lookat position. There are other camera properties you can animate (field of view, focal length, orientation, aperture), but we’re just going to stick with the basics for this demo. You can also specify different tween types instead of Bézier curves: linear, quadratic, cubic, and exponential transitions are also supported. Here’s an example from my twitter page of animating between key frames with cubic transitions:

render_animation() takes your rayrender scene along with the data frame of camera data provided by generate_camera_motion() and generates the frames of your animation. This is far more efficient than repeated calls to render_scene(), as the acceleration structure used by rayrender for ray intersection doesn’t need to be rebuilt for every frame. For large scenes, this can be a non-trivial amount of time saved per frame—sometimes equal to the rendering time itself. The images are saved to disk and you can restart the animation from any frame, which allows you to interrupt the process without losing all your work.

We’ll start by using rayshader to generate a 3D ggplot of the diamonds dataset. Make sure you have the latest version of rayrender installed. 

library(ggplot2)
remotes::install_github("tylermorganwall/rayrender")
library(rayrender)
library(rayshader)

ggdiamonds = ggplot(diamonds, aes(x, depth)) +
  stat_density_2d(aes(fill = stat(nlevel)), geom = "polygon", n = 200, bins = 100,contour = TRUE) +
  facet_wrap(clarity~.) +
  scale_fill_viridis_c(option = "A")
ggdiamond

Figure 1: ggplot2 density plot of the diamonds dataset.

If you’ve never used rayshader, making this density plot 3D is an incredibly easy process (see this blog post for more examples). 

plot_gg(ggdiamonds,width=7,height=7,scale=250,windowsize=c(1100,700),
        raytrace=FALSE, zoom = 0.55, phi = 30, triangulate = TRUE, max_error = 0)
render_snapshot()

Figure 2: ggplot2 extruded to 3D using one line of code with rayshader.

We’ll save an OBJ file to disk so we can load the model into rayrender: 

save_obj("ggplot.obj")
rgl::rgl.close()

Let’s see what this looks like in rayrender in an orthographic view (scaled down by a factor of 100 purely for visualization purposes): 

disk(radius=1000,y=-1, 
     material=diffuse(checkerperiod = 6,checkercolor="#0d401b", color="#496651")) %>% 
  add_object(obj_model("ggplot.obj", y=-0.02, texture=TRUE, scale_obj = 1/100)) %>%
  add_object(sphere(y=30,z=10,radius=5,material = light(intensity=40))) %>% 
  render_scene(lookfrom=c(20,20,20),fov=0,ortho_dimensions=c(30,30), width=800,height=800)

Figure 3: Basic rayrender plot of the data, with the 3D model scaled down for convenience.

Now, we want to specify a series of points we want to visit around this plot in our rollercoaster. How do we do that in a reasonably user-friendly way? It would be nice to be able to simply click on the areas of the plot we want to visit in order, rather than trying to figure out where they are in our 3D plot. And that’s actually entirely possible in R using the locator() function, which allows you to click on the plot and returns the coordinates of the selected points. Let’s plot the surface texture (saved as raysurface.png during the save_obj() call) in our R device using the rayimage package. We’ll then call the locator() function with our number of desired key frames, and click on the points (in order) we want our rollercoaster to travel through. We then need to scale this from viewpoint coordinates (which are specified in pixels) into our 3D plot, centered at the origin (and flipping the z-coordinates to account for some R-isms). 

library(rayimage)
library(raster)
plot_image("raysurface.png")
vals = locator(n=20)
vals$z = vals$y
vals$y = rep(5,length(vals$y))
selected_points = do.call(cbind,vals)
selected_point
##                x y         z
##  [1,] 1923.03521 5  137.8239
##  [2,] 1931.48592 5  843.4577
##  [3,] 1923.03521 5 1227.9648
##  [4,] 1551.20423 5 1363.1761
##  [5,] 1289.23239 5 1515.2887
##  [6,] 1276.55634 5 1916.6972
##  [7,]  799.09155 5 1967.4014
##  [8,]  655.42958 5 1380.0775
##  [9,]  258.24648 5 1418.1056
## [10,]  215.99296 5 1992.7535
## [11,]  659.65493 5 2018.1056
## [12,]  744.16197 5 1435.0070
## [13,]  625.85211 5  737.8239
## [14,]  279.37324 5  750.5000
## [15,]   85.00704 5 1105.4296
## [16,]  718.80986 5 1265.9930
## [17,] 1234.30282 5 1232.1901
## [18,] 1213.17606 5  708.2465
## [19,]  663.88028 5  615.2887
## [20,]  676.55634 5  108.2465
loaded_texture = png::readPNG("raysurface.png")
dim(loaded_texture)
## [1] 2100 2100    4
#Center at origin, flip, and scale by 1/100 to match our rayrender model
selected_points[,1] = (selected_points[,1] - 2100/2)/100
selected_points[,3] = -(selected_points[,3] - 2100/2)/100

Now let’s plot it on top of the rayrender model to see what it looks like. We ensure the path is closed by setting closed = TRUE in the path() function. We’ll also generate some spheres to place at the key frames to mark their positions. 

keylist = list()
for(i in 1:nrow(selected_points)) {
  keylist[[i]] = sphere(x=selected_points[i,1],
                        y=selected_points[i,2],
                        z=selected_points[i,3],radius=0.3,
                        material=diffuse(color="purple"))
}
keyscene = do.call(rbind,keylist)

disk(radius=1000,y=-1, 
     material=diffuse(checkerperiod = 6,checkercolor="#0d401b", color="#496651")) %>% 
  add_object(obj_model("ggplot.obj", y=-0.02, texture=TRUE, scale_obj = 1/100)) %>%
  add_object(sphere(y=30,z=-10,radius=5,material = light(intensity=40))) %>% 
  add_object(path(points=selected_points,width=0.1, closed = TRUE, 
                  material=diffuse(color="red"))) %>% 
  add_object(keyscene) %>% 
  render_scene(lookfrom = c(0, 10, 0), fov = 0, ortho_dimensions = c(30, 30), camera_up = c(0, 0, -1),
               width = 800, height = 800, samples = 256)

Figure 4: Plotting an overhead view of the camera path with clicked points in purple in rayrender, using the path() primitive.

Now comes the only bit of iterative manual work: we’re going to play with the y-coordinates to make this more “rollercoaster” and less “monorail”. I just adjusted each point’s y-coordinate and repeatedly rendered the result until I got what I wanted. We’ll also nudge one of the points to avoid running into the data. 

selected_points_new = selected_points
selected_points_new[,2] = c(0.3, 0.8, 4, 0.8, 0.5,
                            2.5, 1, 0.2, 1, 3,
                            2, 0.3, 2, 0.5, 2,
                            1.5, 0.9, 0.7, 0.3, 0.2)

selected_points_new[17,1] = 1.5

keylist_adjusted = list()
for(i in 1:nrow(selected_points_new)) {
  keylist_adjusted[[i]] = sphere(x=selected_points_new[i,1],
                                 y=selected_points_new[i,2],
                                 z=selected_points_new[i,3],
                                 radius=0.3, material=diffuse(color="purple"))
}
keyscene_adj = do.call(rbind,keylist_adjusted)

disk(radius=1000,y=-1, 
     material=diffuse(checkerperiod = 6,checkercolor="#0d401b", color="#496651")) %>% 
  add_object(obj_model("ggplot.obj", y=-0.02, texture=TRUE, scale_obj = 1/100)) %>%
  add_object(sphere(y=30,z=10,radius=5,material = light(intensity=40))) %>% 
  add_object(path(points=selected_points_new,width=0.1, closed = TRUE, 
                  material=diffuse(color="red"))) %>% 
  add_object(keyscene_adj) %>%
  render_scene(lookfrom = c(20, 20, 20),fov = 0,ortho_dimensions = c(30, 30), 
               width = 800, height = 800, samples = 256)

Figure 5: We’ve nudged the points on the vertical axis to make our rollercoaster to make experience more rollercoaster and less public transit. Note that this lead to some significant differences in the layout of the path—the end now has a loop.

A real rollercoaster will have struts, and we can actually use the new animation function to generate these for us! Generating the camera motion is as simple as passing the above matrix of key frames to the generate_camera_motion() function. By default, the function places the camera at equally spaced intervals. Each row in the resulting data frame describes a camera position, orientation, and other properties. We can extract the camera position and use it to draw struts with cylinders. 

camera_motion = generate_camera_motion(selected_points_new, closed=TRUE, 
                                       frames = 360, constant_step = TRUE)
head(camera_motion)
##           x         y        z dx dy dz aperture fov    focal orthox orthoy upx
## 1  8.730352 0.3000000 9.121761  0  0  0        0  40 12.62995      1      1   0
## 4  8.724527 0.2680017 8.778475  0  0  0        0  40 12.37945      1      1   0
## 6  8.718827 0.2367145 8.435121  0  0  0        0  40 12.13364      1      1   0
## 8  8.713348 0.2066769 8.091653  0  0  0        0  40 11.89285      1      1   0
## 10 8.708196 0.1784969 7.748022  0  0  0        0  40 11.65746      1      1   0
## 13 8.703379 0.1522170 7.404231  0  0  0        0  40 11.42780      1      1   0
##    upy upz
## 1    1   0
## 4    1   0
## 6    1   0
## 8    1   0
## 10   1   0
## 13   1   0
strutlist = list()
for(i in 1:nrow(camera_motion)) {
  strutlist[[i]] = segment(start = as.numeric(camera_motion[i,1:3])-c(0,0.05,0),
                           end =as.numeric(camera_motion[i,1:3])-c(0,20,0),
                           radius=0.02, material=diffuse(color="grey10"))

}
strutscene = do.call(rbind,strutlist)

disk(radius=1000,y=-1, 
     material=diffuse(checkerperiod = 6,checkercolor="#0d401b", color="#496651")) %>% 
  add_object(obj_model("ggplot.obj", y=-0.02, texture=TRUE, scale_obj = 1/100)) %>%
  add_object(sphere(y=30,z=10,radius=5,material = light(intensity=40))) %>% 
  add_object(path(points=selected_points_new,width = 0.1, closed = TRUE, 
                  material=diffuse(color = "red"))) %>% 
  add_object(keyscene_adj) %>%
  add_object(strutscene) %>%
  render_scene(lookfrom = c(20, 20, 20), fov = 0, ortho_dimensions = c(30, 30), 
               width = 800, height = 800, samples = 256)

Figure 6: Making generate_camera_motion() do double duty and generate the coaster struts as well.

Now let’s generate our camera motion. By default, generate_camera_motion() looks at the origin—in order to look along our curve, we need to pass lookat positions as well as lookfrom. We actually want to look along the same path as our camera position, but just slightly in front of the current position. Rayrender provides a helper argument in generate_camera_motion() to do just that: set offset_lookat = 1 and the function will look ahead that distance on the Bézier curve. So we just need to pass two copies of selected_points_ne to the function. We can then pass this and our scene to render_animation() with debug = “preview” to quickly (in a few minutes) render a low-quality draft preview of the animation. I’ll also add an environment image to better orient us as we travel through the scene. 

#Offset above track
selected_points_offset = selected_points_new
selected_points_offset[,2] = selected_points_offset[,2] + 0.15

camera_motion_real = generate_camera_motion(selected_points_offset, selected_points_offset,
                                            closed=TRUE, fovs = 90, constant_step = TRUE,
                                            frames=480,
                                            offset_lookat = 1)

disk(radius=1000,y=-1, 
     material=diffuse(checkerperiod = 6,checkercolor="#0d401b", color="#496651")) %>% 
  add_object(obj_model("ggplot.obj", y=-0.02, texture=TRUE, scale_obj = 1/100)) %>%
  add_object(path(points=selected_points_new,width=0.1, closed = TRUE, 
                  material=diffuse(color="red"))) %>% 
  add_object(strutscene) ->
  scene

render_animation(scene, camera_motion_real, environment_light = "quarry_03_4k.hdr",
                 debug="preview", filename="testroller", width=800,height=800)
Figure 7: Preview render of the animation, with an environment image added (from hdrihaven.com)

Great! Except there’s a few spots where we’d end up with whiplash if we rode this in real life, as the viewpoint quickly changes direction at areas of high curvature. These quick transitions can be disorienting, so generate_camera_motion() includes an option to adjust for local curvature: setting curvature_adjust = “both” will adjust both the lookat and lookfrom positions so that the camera slows down in areas of high curvature, while maintaining the desired number of frames. Here’s a plot of each camera position showing the difference: 

curvature_adjusted =  generate_camera_motion(selected_points_offset, selected_points_offset,
                                             closed=TRUE, fovs = 90, constant_step=FALSE,
                                             curvature_adjust = TRUE,curvature_scale = 60,
                                             frames=480,
                                             offset_lookat = 1)
curvature_adjusted$type = "Curvature Adjusted"
camera_motion_real$type = "Constant Step"
bothparts = rbind(camera_motion_real,curvature_adjusted)
ggplot(bothparts) +
  geom_point(aes(x=x,y=-z,color=y),alpha=0.7) +
  facet_wrap(~type) +
  coord_fixed() +
  scale_color_gradient("Height",low="#44ffff", high="purple") +
  theme(panel.background = element_rect(fill="grey20"),
        panel.grid = element_line(color = "grey30"))

Figure 8: Comparing constant speed camera paths with speed adjusted for local path curvature.

When we plot this version, we’ll see that the movement will slow down significantly when the underlying path changes quickly, which will prevent the nauseating quick movement we encountered before. The trade-off here is the path then moves more quickly through low curvature regions. Note that this option does not preserve key frame position and best works when the lookat and lookfrom positions are identical and you’re using using an offset, as otherwise the two paths can diverge.

Here’s a more extreme example using rayshader’s built-in montereybay dataset that includes a highly curved section. I’ve included the constant step version as well, so you can see how the two differ.

Figure 9: Comparing constant speed (left) with curvature-adjusted speed (right). This was rendered with render_animation(…, debug=“preview”), which allows for quick low-quality renders of your final animation.

Another difference is the behavior of offset_lookat: when constant_step = TRUE, the function looks ahead a set distance along the curve. When constant_step = FALSE, however, the function uses the derivative of the Bézier curve to determine the offset position (I might change the behavior to be consistent across all versions later, but for now they behave slightly differently). Let’s generate an animation showing the difference. We’ll use the arrow primitive to show where the camera points at each interval (note the positions of the tip of the arrows). The animation interface currently only supports camera movement in a static scene, so we’ll have to animate this one the old fashioned way: generate each frame ourselves. 

curvature_adjusted_arrow =  generate_camera_motion(selected_points_offset, selected_points_offset,
                                             closed=TRUE, fovs = 90, constant_step=FALSE,
                                             curvature_adjust = TRUE,
                                             frames=480,
                                             offset_lookat = 3)

curvature_constant_arrow =  generate_camera_motion(selected_points_offset, selected_points_offset,
                                             closed=TRUE, fovs = 90, constant_step=TRUE,
                                             frames=480,
                                             offset_lookat = 3)

lookatlist_adj = list()
lookatlist_con = list()

for(i in 1:nrow(curvature_constant_arrow)) {
  lookatlist_adj[[i]] = arrow(start = as.numeric(curvature_adjusted_arrow[i,1:3])+c(0,0.15,0),
                              tail_proportion = 0.7, radius_top = 0.4, radius_tail = 0.2,
                              end =as.numeric(curvature_adjusted_arrow[i,4:6]), material=glossy(color="#FFD700"))
  lookatlist_con[[i]] = arrow(start = as.numeric(curvature_constant_arrow[i,1:3])+c(0,0.15,0),
                              tail_proportion = 0.7, radius_top = 0.4, radius_tail = 0.2,
                              end =as.numeric(curvature_constant_arrow[i,4:6]), material=glossy(color="purple"))
}

for(i in 1:nrow(curvature_constant_arrow)) {
  disk(radius=1000,y=-1, 
       material=diffuse(checkerperiod = 6,checkercolor="#0d401b", color="#496651")) %>%
    add_object(sphere(y=30,z=10,radius=5,material = light(intensity=80))) %>%
    add_object(path(points=selected_points_new,width=0.1, closed = TRUE, 
                    material=diffuse(color="red"))) %>%
    add_object(lookatlist_adj[[i]]) %>%
    add_object(lookatlist_con[[i]]) %>%
    render_scene(lookfrom=c(20,20,20),fov=0,ortho_dimensions=c(22,22), width=800,height=800,
                    filename=sprintf("arrow_lookat_combined%i.png",i),clamp_value=10)
}
Figure 10: The purple arrow is the behavior of offset_lookat = TRUE for constant_step = TRUE (which looks ahead on the curve) while the purple arrow represents the offset behavior with offset_lookat = TRUE (using local derivatives to determine the lookat position).

Now, let’s look at animating the lookat parameter separately. We’ll use the non-curvature adjusted path due to the aforementioned issues with the two paths diverging when curvature_adjust = TRUE. We’ll start with the lookat positions we already calculated, but now we’re going to change a couple parts: When we circle around the data, we’re going to change the focal point to look at the data (instead of straight ahead). This process is generally what you’d use when planning a 3D “tour” of your data: set a path for the camera to move along, and then direct the camera at points of interest as you move through the space. We’ll again use our clicking method to get the exact coordinates on the plot we want to focus on. 

plot_image("raysurface.png")
vals2 = locator(n=2)
vals2$z = vals2$y
vals2$y = rep(2,length(vals2$y))
selected_focal_points = do.call(cbind,vals2)
selected_focal_point
##             x y        z
## [1,] 439.9366 2 1692.754
## [2,] 270.9225 2 1020.923
#Center at origin, flip, and scale by 1/100 to match our rayrender model
selected_focal_points[,1] = (selected_focal_points[,1] - 2100/2)/100
selected_focal_points[,3] = -(selected_focal_points[,3] - 2100/2)/100

The new focal points are plotted below in green. 

disk(radius=1000,y=-1, 
     material=diffuse(checkerperiod = 6,checkercolor="#0d401b", color="#496651")) %>% 
  add_object(obj_model("ggplot.obj", y=-0.02, texture=TRUE, scale_obj = 1/100)) %>%
  add_object(sphere(y=30,z=-10,radius=5,material = light(intensity=40))) %>% 
  add_object(path(points=selected_points,width=0.1, closed = TRUE, material=diffuse(color="red"))) %>% 
  add_object(keyscene) %>% 
  add_object(sphere(x=selected_focal_points[1,1],
                    y=selected_focal_points[1,2] + 3,
                    z=selected_focal_points[1,3],
                    radius=0.5, material=diffuse(color="green"))) %>% 
  add_object(sphere(x=selected_focal_points[2,1],
                    y=selected_focal_points[2,2] + 3,
                    z=selected_focal_points[2,3],
                    radius=0.5, material=diffuse(color="green"))) %>% 
  render_scene(lookfrom = c(0, 10, 0), fov = 0, ortho_dimensions = c(30, 30), camera_up = c(0,0,-1),
               width = 800, height = 800, samples = 256)

Figure 11: Green dots represent the new focal points for that portion of the coaster.

Let’s make the first peak the focal point from keyframes 8-11, and the second from keyframes 13-16. We’ll also have to manually offset the look position by playing around with matrix indices, since the offset argument doesn’t work when the point is stationary, as the derivative is undefined. 

new_lookat_positions = selected_points_offset
new_lookat_positions[7:10,] = rbind(selected_focal_points[1,],selected_focal_points[1,],
                                    selected_focal_points[1,],selected_focal_points[1,])
new_lookat_positions[13:15,] = rbind(selected_focal_points[2,],selected_focal_points[2,],
                                     selected_focal_points[2,])

lookat_animated =  generate_camera_motion(selected_points_offset, new_lookat_positions,
                                          closed=TRUE, fovs = 90, constant_step = FALSE,
                                          curvature_adjust = "none",
                                          type = "bezier",
                                          frames=480,
                                          offset_lookat = 0)

#Offset by 5 steps along the path and recalculate the focal distance
lookat_animated2 = lookat_animated
lookat_animated2[,4:6] = rbind(lookat_animated[-(1:5),4:6],lookat_animated[(1:5),4:6])
lookat_animated2$focal = sqrt(apply(((lookat_animated2[,4:6]-lookat_animated2[,1:3])^2),1,sum))

render_animation(scene,lookat_animated2, width=1100,height=700,debug="preview",filename="animatelookat",
                  environment_light = "quarry_03_4k.hdr",)
Figure 12: The final animation. Note that this version doesn’t have the curvature adjustment feature enabled, so there are still areas where the viewpoint changes fairly quickly and might be a little nauseating. If you turn on the curvature adjustment feature, this will be much less of a problem.

Cool! You now know how to create thrilling rides with your datasets in R. Use this power wisely (and don’t show Tufte).

And there’s your introduction to animation in R with rayrender! While animation is still a complex subject (and there are still pitfalls—Bézier curves can act pretty strangely at times!), rayrender now has a reasonably efficient and user-friendly method to create complex animations that don’t make you want to lose your lunch.

As a final note, this update also brings some pretty major improvements to rayrender’s underlying integrator: rayrender now has a high-quality Owen-scrambled Sobol sampler that converges far more quickly than any of the built-in samplers included thus far. This makes generating complex animations far less painful: rather than 500 samples per frame to get a clean image, now you might only need 1/4th of that amount! This is powered by the spacefillr package, a package that generates high-quality spacefilling sequences/sets that I submitted to the CRAN last month. Enjoy the time savings!

]]> 3D Data Maps R Data Visualization Rayrender Rayshader Pathtracing https://www.tylermw.com/posts/data_visualization/datacoaster-tycoon.html Sat, 13 Mar 2021 03:47:11 GMT Tutorial: Adding Open Street Map Data to Rayshader Maps in R Tyler Morgan-Wall https://www.tylermw.com/posts/data_visualization/adding-open-street-map-data-to-rayshader-maps-in-r.html osm

This post is a tutorial on how to add Open Street Map data to maps made with rayshader in R. Rayshader is a package for 2D and 3D visualization in R, specializing in generating beautiful maps using many various hillshading techniques (see these posts [1] [2] [3]) directly from elevation data. It does this by providing the user with a wide variety of techniques: traditional lambertian shading, raytracing, ambient occlusion, hypsometric tinting (cartography-speak for mapping color to elevation), texture shading, and spherical aspect color shading.

Figure 1: Different hillshading methods. Left to right: Lambertian shading, raytracing, ambient occlusion, height shading, texture shading, sphere shading.

These techniques can be combined to create stunning maps in a few lines of R code, but that’s only half the story: a beautiful map is just a vehicle to deliver other information. Roads, trails, parking lots, water fountains, restrooms, the nearest Arbys: a map is a tool to build your mental model for a region. These features can be added to rayshader maps via data overlays: we first generate our base map using some combination of the above hillshading techniques, and then we layer our data on top. Rayshader provides you with functions to easily add polygons, lines, and points that represent your data directly onto your map.

Figure 2: Adding polygon and line overlays to a map in 2D in rayshader.

You also need a source of data, and luckily we live in a universe where Open Street Map (OSM) exists: a free, open, user-generated map of pretty much everything in the world. If you have some highly specialized dataset, you might not be able to find it on OSM, but for the basics (trails, roads, rivers, streams, landmarks and buildings) it’s fairly comprehensive.

Knowing the data exists is only half the battle: you also need a way to load the data into R. And thankfully, Mark Padgham (along with many others and the rOpenSci project) have given us the osmdata package, a package that allows you to easily query and pull data from OSM in a few lines of code directly from R. You provide it with a lat/long bounding box and a specific feature you want to pull, and it will return an object containing everything that matches your query in that area.

Let’s jump into an example. We’ll use elevation data from Bryce Canyon in Utah (courtesy of Tom Patterson via shadedrelief.com), since National Parks tend to have a nice mix of interesting topography, trails, streams, and other features.

Figure 3: A picture from a post-PhD defense trip I took to Bryce Canyon National Park in 2015. Remember travel?

Let’s start by loading the data and required packages. We’ll transform the spatial data structure extracted by raster into a regular R matrix using rayshader’s raster_to_matrix() function. 

install.packages("remotes")
remotes::install_github("tylermorganwall/rayshader")
remotes::install_github("tylermorganwall/rayimage")

library(rayshader)
library(raster)
library(osmdata)
library(sf)
library(dplyr)
library(ggplot2)

bryce = raster("Bryce_Canyon.tif")
bryce_mat = raster_to_matrix(bryce)

We can also create a smaller version of this matrix for quick prototyping with the rayshader resize_matrix() function. This test matrix will be 1/4th the size of the full matrix. 

bryce_small = resize_matrix(bryce_mat,0.25)

Now, let’s build our base map with rayshader. Let’s see what this data looks like with a basic color to elevation mapping. 

bryce_small %>% 
  height_shade() %>% 
  plot_map()

We’ll mix this layer with a spherical aspect shading color layer to enhance it using sphere_shade(). 

bryce_small %>% 
  height_shade() %>% 
  add_overlay(sphere_shade(bryce_small, texture = "desert", 
                           zscale=4, colorintensity = 5), alphalayer=0.5) %>%
  plot_map()

We can also overlay a standard hillshade to better define the terrain. We’ll get this by using the lamb_shade() function, which adds Lambertian (cosine) shading. The zscale parameter in lamb_shade() controls the amount of vertical exaggeration and thus the intensity of the hillshade. 

bryce_small %>% 
  height_shade() %>% 
  add_overlay(sphere_shade(bryce_small, texture = "desert", 
                           zscale=4, colorintensity = 5), alphalayer=0.5) %>%
  add_shadow(lamb_shade(bryce_small,zscale = 6),0) %>%
  plot_map()

Now we’ll add a layer using the texture_shade() function, which adds shadows calculated by Leland Brown’s “texture shading” method. This better defines ridges and drainage networks, which aren’t well-captured by Lambertian shading. 

bryce_small %>% 
  height_shade() %>% 
  add_overlay(sphere_shade(bryce_small, texture = "desert", 
                           zscale=4, colorintensity = 5), alphalayer=0.5) %>%
  add_shadow(lamb_shade(bryce_small,zscale=6), 0) %>%
  add_shadow(texture_shade(bryce_small,detail=8/10,contrast=9,brightness = 11), 0.1) %>%
  plot_map()

Finally, we’ll add an ambient occlusion layer to our base map. This will darken valleys to account for less scattered atmospheric light reaching the valley floor. This adds a nice texture to our map, particularly to the valleys between the steep ridges. 

bryce_small %>% 
  height_shade() %>% 
  add_overlay(sphere_shade(bryce_small, texture = "desert", 
                           zscale=4, colorintensity = 5), alphalayer=0.5) %>%
  add_shadow(lamb_shade(bryce_small,zscale=6), 0) %>%
  add_shadow(ambient_shade(bryce_small), 0) %>%
  add_shadow(texture_shade(bryce_small,detail=8/10,contrast=9,brightness = 11), 0.1) %>%
  plot_map()

Now we have our base map! We’ll zoom into our area of interest by creating a lat/long bounding box. To get these coordinates, I just went to Google Maps and picked the bottom left and top right corners, and pulled out the lat/long values. I wrote a short function that takes these values and transforms them into the coordinate system used in the original bryce object, which we then crop, convert to a matrix, and then plot. We’ll also save this map to a variable to use later, so we don’t have to recompute the base layer each time. 

lat_range   = c(37.614998, 37.629084)
long_range = c(-112.174228, -112.156230)

convert_coords = function(lat,long, from = CRS("+init=epsg:4326"), to) {
  data = data.frame(long=long, lat=lat)
  coordinates(data) <- ~ long+lat
  proj4string(data) = from
  #Convert to coordinate system specified by EPSG code
  xy = data.frame(sp::spTransform(data, to))
  colnames(xy) = c("x","y")
  return(unlist(xy))
}

crs(bryce)
## CRS arguments:
##  +proj=utm +zone=12 +ellps=GRS80 +towgs84=0,0,0,0,0,0,0 +units=m
## +no_def
utm_bbox = convert_coords(lat = lat_range, long=long_range, to = crs(bryce))
utm_bbox
##        x1        x2        y1        y2 
##  396367.4  397975.2 4163747.9 4165291.0
extent(bryce)
## class      : Extent 
## xmin       : 395998.5 
## xmax       : 399998.5 
## ymin       : 4161774 
## ymax       : 4165574
extent_zoomed = extent(utm_bbox[1], utm_bbox[2], utm_bbox[3], utm_bbox[4])
bryce_zoom = crop(bryce, extent_zoomed)
bryce_zoom_mat = raster_to_matrix(bryce_zoom)

base_map = bryce_zoom_mat %>% 
  height_shade() %>%
  add_overlay(sphere_shade(bryce_zoom_mat, texture = "desert", colorintensity = 5), alphalayer=0.5) %>%
  add_shadow(lamb_shade(bryce_zoom_mat), 0) %>%
  add_shadow(ambient_shade(bryce_zoom_mat),0) %>% 
  add_shadow(texture_shade(bryce_zoom_mat,detail=8/10,contrast=9,brightness = 11), 0.1)

plot_map(base_map)

Great! We now have our zoomed-in base map. Let’s start adding OSM features to it.

You can see what features are available in OSM by calling the available_features() function. We’re first going to pull the highway feature in our region. Despite the name, highway represents more than major roads: it’s a feature that represents all types of roads and footpaths. We’ll build a query to the OSM Overpass API by passing in our lat/long bounding box (with a slight order change required for that API) to opq(), adding a feature with add_osm_feature(), and then convert the object to a simple features (sf) object with osmdata_sf(). 

osm_bbox = c(long_range[1],lat_range[1], long_range[2],lat_range[2])

bryce_highway = opq(osm_bbox) %>% 
  add_osm_feature("highway") %>% 
  osmdata_sf() 
bryce_highway
## Object of class 'osmdata' with:
##                  $bbox : 37.614998,-112.174228,37.629084,-112.15623
##         $overpass_call : The call submitted to the overpass API
##                  $meta : metadata including timestamp and version numbers
##            $osm_points : 'sf' Simple Features Collection with 2140 points
##             $osm_lines : 'sf' Simple Features Collection with 94 linestrings
##          $osm_polygons : 'sf' Simple Features Collection with 5 polygons
##        $osm_multilines : NULL
##     $osm_multipolygons : NULL

This returns a list with several sf objects contained within: points, lines, and polygons. The data comes in lat/long coordinates, so we need to convert it to bryce’s coordinate system. Let’s plot the lines in ggplot to preview what data we have. 

bryce_lines = st_transform(bryce_highway$osm_lines, crs=crs(bryce))

ggplot(bryce_lines,aes(color=osm_id)) + 
  geom_sf() +
  theme(legend.position = "none") +
  labs(title = "Open Street Map `highway` attribute in Bryce Canyon National Park")

Now, let’s add it to our map using rayshader’s generate_line_overlay() function, which takes an sf object with LINESTRING geometry and creates a semi-transparent overlay (which we then overlay with add_overlay()). You might notice that the above geometry extends far beyond the bounds of our scene, but that won’t matter—the generate_*_overlay() functions will crop the data down the region specified in extent. 

base_map %>% 
  add_overlay(generate_line_overlay(bryce_lines,extent = extent_zoomed,
                                    heightmap = bryce_zoom_mat)) %>% 
  plot_map()

Great! We have road and trails. Let’s make the lines white and a bit thicker. 

base_map %>% 
  add_overlay(generate_line_overlay(bryce_lines,extent = extent_zoomed,
                                    linewidth = 3, color="white",
                                    heightmap = bryce_zoom_mat)) %>% 
  plot_map()

Now, let’s filter them into several different categories. We’ll first separate out roads, footpaths, and trails using dplyr’s filter() function. 

bryce_trails = bryce_lines %>% 
  filter(highway %in% c("path","bridleway"))

bryce_footpaths = bryce_lines %>% 
  filter(highway %in% c("footway"))

bryce_roads = bryce_lines %>% 
  filter(highway %in% c("unclassified", "secondary", "tertiary", "residential", "service"))

Let’s plot them all together. We’ll vary the color, line width, and line type (argument lty) to differentiate the different paths. We’ll use thick dark lines for roads, solid white lines for paved paths, and dotted white lines for trails. 

base_map %>% 
  add_overlay(generate_line_overlay(bryce_footpaths,extent = extent_zoomed,
                                    linewidth = 6, color="white", 
                                    heightmap = bryce_zoom_mat)) %>% 
  add_overlay(generate_line_overlay(bryce_trails,extent = extent_zoomed,
                                    linewidth = 3, color="white", lty=3,
                                    heightmap = bryce_zoom_mat)) %>% 
  add_overlay(generate_line_overlay(bryce_roads,extent = extent_zoomed,
                                    linewidth = 8, color="black",
                                    heightmap = bryce_zoom_mat)) %>% 
  plot_map()

One problem with light colored lines on light backgrounds is lack of contrast: it can be harder to see the white lines in areas where the base map is also light. This particular issue can be fixed by adding a slight outline to our light lines. We can create an outline by plotting the same data twice, changing the color and decreasing the line width for the second layer.

We’ll try this with the foot paths. 

base_map %>% 
  add_overlay(generate_line_overlay(bryce_footpaths,extent = extent_zoomed,
                                    linewidth = 10, color="black", 
                                    heightmap = bryce_zoom_mat)) %>% 
  add_overlay(generate_line_overlay(bryce_footpaths,extent = extent_zoomed,
                                    linewidth = 6, color="white",
                                    heightmap = bryce_zoom_mat)) %>% 
  add_overlay(generate_line_overlay(bryce_trails,extent = extent_zoomed,
                                    linewidth = 3, color="white", lty=3,
                                    heightmap = bryce_zoom_mat)) %>% 
  add_overlay(generate_line_overlay(bryce_roads,extent = extent_zoomed,
                                    linewidth = 8, color="black",
                                    heightmap = bryce_zoom_mat)) %>% 
  plot_map()

Similarly, we can add a slight shadow effect by plotting the same data twice, but with an offset for the shadow. This offset argument shifts data in the geographic coordinates (not pixels), which here is in meters. Let’s add shadows to the dotted trails to make them pop from the background a bit better. 

base_map %>% 
  add_overlay(generate_line_overlay(bryce_footpaths,extent = extent_zoomed,
                                    linewidth = 10, color="black", 
                                    heightmap = bryce_zoom_mat)) %>% 
  add_overlay(generate_line_overlay(bryce_footpaths,extent = extent_zoomed,
                                    linewidth = 6, color="white",
                                    heightmap = bryce_zoom_mat)) %>% 
  add_overlay(generate_line_overlay(bryce_trails,extent = extent_zoomed,
                                    linewidth = 3, color="black", lty=3, offset = c(2,-2),
                                    heightmap = bryce_zoom_mat)) %>% 
  add_overlay(generate_line_overlay(bryce_trails,extent = extent_zoomed,
                                    linewidth = 3, color="white", lty=3,
                                    heightmap = bryce_zoom_mat)) %>% 
  add_overlay(generate_line_overlay(bryce_roads,extent = extent_zoomed,
                                    linewidth = 8, color="black",
                                    heightmap = bryce_zoom_mat)) %>% 
  plot_map()

Cool! Let’s save these overlays into their own layer, so we can adjust the base map separately later (if we want to). 

trails_layer = generate_line_overlay(bryce_footpaths,extent = extent_zoomed,
                                    linewidth = 10, color="black", 
                                    heightmap = bryce_zoom_mat) %>% 
  add_overlay(generate_line_overlay(bryce_footpaths,extent = extent_zoomed,
                                    linewidth = 6, color="white",
                                    heightmap = bryce_zoom_mat)) %>%
  add_overlay(generate_line_overlay(bryce_trails,extent = extent_zoomed,
                                    linewidth = 3, color="black", lty=3, offset = c(2,-2),
                                    heightmap = bryce_zoom_mat)) %>%
  add_overlay(generate_line_overlay(bryce_trails,extent = extent_zoomed,
                                    linewidth = 3, color="white", lty=3,
                                    heightmap = bryce_zoom_mat)) %>%
  add_overlay(generate_line_overlay(bryce_roads,extent = extent_zoomed,
                                    linewidth = 8, color="grey30",
                                    heightmap = bryce_zoom_mat))

Now, let’s add some other features. We’ll pull waterways by requesting the waterway feature from OSM. We’ll load the object, reproject it to match our coordinate system, and overlay it in blue underneath our trail layer. There’s not actually many active streams in Bryce—these are intermittent streams, as we see when we print the object below—but it’s a good demonstration on how to add them to our map. 

bryce_water_lines = opq(osm_bbox) %>% 
  add_osm_feature("waterway") %>% 
  osmdata_sf() 
bryce_water_line
## Object of class 'osmdata' with:
##                  $bbox : 37.614998,-112.174228,37.629084,-112.15623
##         $overpass_call : The call submitted to the overpass API
##                  $meta : metadata including timestamp and version numbers
##            $osm_points : 'sf' Simple Features Collection with 493 points
##             $osm_lines : 'sf' Simple Features Collection with 13 linestrings
##          $osm_polygons : 'sf' Simple Features Collection with 0 polygons
##        $osm_multilines : NULL
##     $osm_multipolygons : NULL
bryce_water_lines$osm_line
## Simple feature collection with 13 features and 4 fields
## geometry type:  LINESTRING
## dimension:      XY
## bbox:           xmin: -112.1677 ymin: 37.61215 xmax: -112.1374 ymax: 37.63255
## CRS:            EPSG:4326
## First 10 features:
##              osm_id        name intermittent waterway
## 451498495 451498495 Bryce Creek          yes   stream
## 451498514 451498514        <NA>          yes   stream
## 451498531 451498531        <NA>          yes   stream
## 451498543 451498543        <NA>          yes   stream
## 650406551 650406551        <NA>          yes   stream
## 650406552 650406552        <NA>          yes   stream
## 650406554 650406554        <NA>          yes   stream
## 650406555 650406555        <NA>          yes   stream
## 650406556 650406556        <NA>          yes   stream
## 650522440 650522440        <NA>          yes   stream
##                                 geometry
## 451498495 LINESTRING (-112.1672 37.62...
## 451498514 LINESTRING (-112.1656 37.61...
## 451498531 LINESTRING (-112.1623 37.62...
## 451498543 LINESTRING (-112.16 37.6283...
## 650406551 LINESTRING (-112.1672 37.61...
## 650406552 LINESTRING (-112.1636 37.62...
## 650406554 LINESTRING (-112.1589 37.61...
## 650406555 LINESTRING (-112.1642 37.62...
## 650406556 LINESTRING (-112.1611 37.62...
## 650522440 LINESTRING (-112.1584 37.62...
bryce_streams = st_transform(bryce_water_lines$osm_lines,crs=crs(bryce)) 

stream_layer = generate_line_overlay(bryce_streams,extent = extent_zoomed,
                                    linewidth = 4, color="skyblue2", 
                                    heightmap = bryce_zoom_mat)

base_map %>% 
  add_overlay(stream_layer, alphalayer = 0.8) %>% 
  add_overlay(trails_layer) %>%
  plot_map()

Now let’s add some polygon features. We can pull those out of the parking feature from OSM to get parking lots, building to get buildings, and tourism to get camp grounds and picnic areas. We’ll add these layers before the trails so it doesn’t obscure the trail information. 

bryce_parking = opq(osm_bbox) %>% 
  add_osm_feature("parking") %>% 
  osmdata_sf() 

bryce_building = opq(osm_bbox) %>% 
  add_osm_feature("building") %>% 
  osmdata_sf() 

bryce_tourism = opq(osm_bbox) %>% 
  add_osm_feature("tourism") %>% 
  osmdata_sf() 

bryce_parking_poly = st_transform(bryce_parking$osm_polygons,crs=crs(bryce))
bryce_building_poly = st_transform(bryce_building$osm_polygons,crs=crs(bryce))
bryce_tourism_poly = st_transform(bryce_tourism$osm_polygons,crs=crs(bryce))

bryce_sites_poly = bryce_tourism_poly %>% 
  filter(tourism %in% c("picnic_site", "camp_site"))

polygon_layer = generate_polygon_overlay(bryce_parking_poly, extent = extent_zoomed,
                                    heightmap = bryce_zoom_mat, palette="grey30") %>%
  add_overlay(generate_polygon_overlay(bryce_building_poly, extent = extent_zoomed,
                                    heightmap = bryce_zoom_mat, palette="darkred")) %>% 
  add_overlay(generate_polygon_overlay(bryce_sites_poly, extent = extent_zoomed,
                                    heightmap = bryce_zoom_mat, palette="darkgreen"), alphalayer = 0.6)

base_map %>% 
  add_overlay(polygon_layer) %>%
  add_overlay(stream_layer, alphalayer = 0.8) %>% 
  add_overlay(trails_layer) %>%
  plot_map()

This is pretty, but we need context! Let’s add some of the natural features in the landscape as labels, using generate_label_overlay(). 

bryce_tourism_points = st_transform(bryce_tourism$osm_points,crs=crs(bryce))

bryce_attractions = bryce_tourism_points %>% 
  filter(tourism == "attraction")

base_map %>% 
  add_overlay(polygon_layer) %>%
  add_overlay(stream_layer, alphalayer = 0.8) %>% 
  add_overlay(trails_layer) %>%
  add_overlay(generate_label_overlay(bryce_attractions, extent = extent_zoomed,
                                     text_size = 2, point_size = 1,
                                     seed=1,
                                     heightmap = bryce_zoom_mat, data_label_column = "name")) %>% 
  plot_map()

Wait—where are the labels? They’re there, if you look hard enough. One of the difficulties you encounter adding labels to maps is obtaining sufficient contrast between the text and underlying map: dark labels on a dark, changing background are hard to read. Light labels on light areas present the same problem. A fairly standard solution to this problem is to add a “halo” of a different color to your text—it ensures your text will always be readable, regardless of the background. Let’s do that using the built-in halo arguments: setting halo_color to a color activates the halo. 

base_map %>% 
  add_overlay(polygon_layer) %>%
  add_overlay(stream_layer, alphalayer = 0.8) %>% 
  add_overlay(trails_layer) %>%
  add_overlay(generate_label_overlay(bryce_attractions, extent = extent_zoomed,
                                     text_size = 2, point_size = 1, 
                                     halo_color = "white",halo_expand = 5, 
                                     seed=1,
                                     heightmap = bryce_zoom_mat, data_label_column = "name")) %>% 
  plot_map()

If you don’t like the solid border, you can blur the halo layer a bit for a softer outline. We’ll also make the halo slightly transparent all the way through by setting the halo_alpha argument. 

base_map %>% 
  add_overlay(polygon_layer) %>%
  add_overlay(stream_layer, alphalayer = 0.8) %>% 
  add_overlay(trails_layer) %>%
  add_overlay(generate_label_overlay(bryce_attractions, extent = extent_zoomed,
                                     text_size = 2, point_size = 1, color = "black",
                                     halo_color = "white", halo_expand = 10, 
                                     halo_blur = 20, halo_alpha = 0.8,
                                     seed=1,
                                     heightmap = bryce_zoom_mat, data_label_column = "name")) %>% 
  plot_map()

The appearance of the halo is a bit jarring over the dark background—let’s swap the color palette so the halo isn’t so noticeable. 

base_map %>% 
  add_overlay(polygon_layer) %>%
  add_overlay(stream_layer, alphalayer = 0.8) %>% 
  add_overlay(trails_layer) %>%
  add_overlay(generate_label_overlay(bryce_attractions, extent = extent_zoomed,
                                     text_size = 2, point_size = 2, color = "white", 
                                     halo_color = "black", halo_expand = 10, 
                                     halo_blur = 20, halo_alpha = 0.8,
                                     seed=1,
                                     heightmap = bryce_zoom_mat, data_label_column = "name")) %>% 
  plot_map()

Looks good! Our text now seamlessly blends into our map, but the background doesn’t interfere with the text’s legibility. Now, to finish the map: let’s add a title. 

base_map %>% 
  add_overlay(polygon_layer) %>%
  add_overlay(stream_layer, alphalayer = 0.8) %>% 
  add_overlay(trails_layer) %>%
  add_overlay(generate_label_overlay(bryce_attractions, extent = extent_zoomed,
                                     text_size = 2, point_size = 2, color = "white", 
                                     halo_color = "black", halo_expand = 10, 
                                     halo_blur = 20, halo_alpha = 0.8,
                                     seed=1, heightmap = bryce_zoom_mat, data_label_column = "name")) %>% 
  plot_map(title_text = "Bryce Canyon National Park, Utah", title_offset = c(15,15),
           title_bar_color = "grey5", title_color = "white", title_bar_alpha = 1)

Rayshader also makes it easy to visualize this map in 3D. 

base_map %>% 
  add_overlay(polygon_layer) %>%
  add_overlay(stream_layer, alphalayer = 0.8) %>% 
  add_overlay(trails_layer) %>%
  plot_3d(bryce_zoom_mat, windowsize=c(1200,800))
render_camera(theta=240,  phi=30, zoom=0.3,  fov=60)
render_snapshot()

Figure 4: There are some things that look fine on a 2D map that I’d change for 3D: e.g. extremely dark colors on steep slopes look fine in 2D but will be too dark in 3D.

And now you know how to add Open Street Map data to your map in R! Feed free to copy this code and try it yourself. Of course, you might not want to copy this map exactly for your region—it sure would be nice to know how easy it is to restyle your map to your tastes!

😁👇

Restyling Your Map

The great thing about working in a programming language is how easy it is to completely revamp the appearance with the map just by changing a few lines of code—no manual work required! Here are a few examples of re-styling this map in rayshader:

Let’s generate a new base map with a better shading method for a 3D map (lamb_shade() darkens the steep slopes too much in 3D). An ambient_shade() layer will provide much softer shadows in those regions, as it models diffuse light (rather than direct lighting). 

#Exaggerate surface 5x for darker ambient occlusion shadows
amb_layer = ambient_shade(bryce_zoom_mat,zscale=1/5)

bryce_zoom_mat %>% 
  height_shade() %>%
  add_shadow(texture_shade(bryce_zoom_mat,detail=8/10,contrast=9,brightness = 11), 0) %>%
  add_shadow(amb_layer,0) %>%
  add_overlay(polygon_layer) %>%
  add_overlay(stream_layer, alphalayer = 0.8) %>% 
  add_overlay(trails_layer) %>%
  plot_3d(bryce_zoom_mat, windowsize = c(1200,1200), theta=40,  phi=50, zoom=0.4,  fov=90)

render_snapshot()
rgl::rgl.close()

Compare the edges of the steep valleys in this 3D version to the rotating map at the top of this post—unlike that one, these slopes aren’t black.

Now, let’s create a faux National Park Service map. Here’s an example of the style:

Figure 5: National Park Service map.

Here, I change up the height_shade() color ramp and water color, add a pure white overlay to lighten the entire map (which makes the trails pop from the background), change to black labels with a soft white outline, add dense semi-transparent light-brown contours at 5 meter intervals, and add a black title bar (which is standard for NPS maps). The only thing missing here is NPS symbology. 

watercolor = "#2a89b3"
maxcolor = "#e6dbc8"
mincolor = "#b6bba5"
contour_color = "#7d4911"

bryce_zoom_mat %>% 
  height_shade(texture = grDevices::colorRampPalette(c(mincolor,maxcolor))(256)) %>%
  add_shadow(lamb_shade(bryce_zoom_mat),0.2) %>% 
  add_overlay(generate_contour_overlay(bryce_zoom_mat, color = contour_color, 
                                       linewidth = 2, levels=seq(min(bryce_zoom_mat), max(bryce_zoom_mat), by=5)),alphalayer = 0.5) %>% 
  add_overlay(polygon_layer) %>% 
  add_overlay(height_shade(bryce_zoom_mat,texture = "white"), alphalayer=0.2) %>% 
  add_overlay(generate_line_overlay(bryce_streams,extent = extent_zoomed,
                                    linewidth = 4, color=watercolor, 
                                    heightmap = bryce_zoom_mat)) %>% 
  add_overlay(generate_line_overlay(bryce_footpaths,extent = extent_zoomed,
                                    linewidth = 4, color="black", 
                                    heightmap = bryce_zoom_mat)) %>% 
  add_overlay(generate_line_overlay(bryce_trails,extent = extent_zoomed,
                                    linewidth = 4, color="black", lty=2,
                                    heightmap = bryce_zoom_mat)) %>% 
  add_overlay(generate_line_overlay(bryce_roads,extent = extent_zoomed,
                                    linewidth = 12, color="black",
                                    heightmap = bryce_zoom_mat)) %>% 
  add_overlay(generate_line_overlay(bryce_roads,extent = extent_zoomed,
                                    linewidth = 8, color="white",
                                    heightmap = bryce_zoom_mat)) %>% 
  add_overlay(generate_label_overlay(bryce_attractions, extent = extent_zoomed,
                                     text_size = 2, point_size = 2, color = "black", 
                                     halo_color = "#e6e1db", halo_expand = 5, 
                                     halo_blur = 2, halo_alpha = 0.8,
                                     seed=1, heightmap = bryce_zoom_mat, 
                                     data_label_column = "name")) %>% 
  plot_map(title_text="Bryce Canyon National Park, Utah", title_color = "white",
           title_bar_alpha = 1, title_bar_color = "black")

Let’s look at an animated version of what that looks like, built-up layer-by-layer.

Figure 6: A flipbook showing each layer added onto the map, running through the code above.

What if we want a map that’s more informational? Let’s create a trail map for the area. We’ll extract the individual trails to color them separately, and place labels down adjacent to a point along the trail. We’ll also remove all other color from the map and lighten the underlying map to make the trails the focal point. To further differentiate the trail labels from the location labels, we’ll make the trail font bold by setting font = 2 and giving them a white outline. 

navajo_trail = bryce_trails %>% 
  filter(name == "Navajo Loop Trail")

rim_trail = bryce_trails %>% 
  filter(name == "Rim Trail")

queen_trail = bryce_trails %>% 
  filter(name %in% c("Queen's Garden", "Queen's Garden Trail"))

navajo_coords = st_coordinates(navajo_trail)
rim_coords = st_coordinates(rim_trail)
queen_coords = st_coordinates(queen_trail)

label_navajo_coord = navajo_coords[34,1:2]
label_rim_coord = rim_coords[50,1:2]
label_queen_coord = queen_coords[35,1:2]


bryce_zoom_mat %>% 
  height_shade(texture = "white") %>%
  add_shadow(lamb_shade(bryce_zoom_mat),0.6) %>% 
  add_overlay(generate_contour_overlay(bryce_zoom_mat, color = "black", 
                                       linewidth = 2, levels=seq(min(bryce_zoom_mat), 
                                       max(bryce_zoom_mat), by=5)),alphalayer = 0.2) %>% 
  add_overlay(generate_polygon_overlay(bryce_building_poly, extent = extent_zoomed,
                                    heightmap = bryce_zoom_mat, palette="black")) %>%
  add_overlay(generate_polygon_overlay(bryce_parking_poly, extent = extent_zoomed,
                                    heightmap = bryce_zoom_mat, palette="grey30")) %>%
  add_overlay(generate_line_overlay(bryce_footpaths,extent = extent_zoomed,
                                    linewidth = 4, color="grey30",
                                    heightmap = bryce_zoom_mat)) %>%
  add_overlay(generate_line_overlay(bryce_roads,extent = extent_zoomed,
                                    linewidth = 8, color="grey30",
                                    heightmap = bryce_zoom_mat)) %>%
  add_overlay(generate_line_overlay(navajo_trail,extent = extent_zoomed,
                                    linewidth = 6, color="red",
                                    heightmap = bryce_zoom_mat)) %>%
  add_overlay(generate_line_overlay(queen_trail,extent = extent_zoomed,
                                    linewidth = 6, color="orange",
                                    heightmap = bryce_zoom_mat)) %>%
  add_overlay(generate_line_overlay(rim_trail,extent = extent_zoomed,
                                    linewidth = 6, color="purple",
                                    heightmap = bryce_zoom_mat)) %>%
  add_overlay(generate_label_overlay(bryce_attractions, extent = extent_zoomed,
                                     text_size = 2, point_size = 2, color = "black", 
                                     seed=1, heightmap = bryce_zoom_mat, 
                                     data_label_column = "name")) %>% 
  add_overlay(generate_label_overlay(label = "Navajo Loop Trail", 
                                     x=label_navajo_coord[1]-30, y=label_navajo_coord[2], 
                                     extent = extent_zoomed, text_size = 3, color = "red", font=2,
                                     halo_color = "white", halo_expand = 4, point_size = 0,
                                     seed=1, heightmap = bryce_zoom_mat)) %>% 
  add_overlay(generate_label_overlay(label = "Rim Trail", 
                                     x=label_rim_coord[1]+200, y=label_rim_coord[2], 
                                     extent = extent_zoomed, text_size = 3, color = "purple", font=2,
                                     halo_color = "white", halo_expand = 4, point_size = 0,
                                     seed=1, heightmap = bryce_zoom_mat)) %>% 
  add_overlay(generate_label_overlay(label = "Queen's Garden Trail", 
                                     x=label_queen_coord[1], y=label_queen_coord[2], 
                                     extent = extent_zoomed, text_size = 3, color = "orange", font=2,
                                     halo_color = "white", halo_expand = 4, point_size = 0,
                                     seed=1, heightmap = bryce_zoom_mat)) %>% 
  plot_map(title_text="Bryce Canyon National Park Trails, Sunset Point", title_color = "white",
           title_bar_alpha = 1, title_bar_color = "black")

Finally, let’s create a map in the style of the great Swiss cartographer, Eduard Imhof. He had a particular style well-represented by the sphere_shade() function (see this blog post for examples). Here’s an example of his style:

Figure 6: Map snippet by Eduard Imhof.

We can switch up our color palette in sphere_shade() to create a facsimile of Eduard’s work. We’ll also remove the contours and use the generate_altitude_overlay() function to create an atmospheric scattering effect by generating a bluish tint at lower elevations. This is a technique cartographers use to help you distinguish between high elevations and lower elevations without resorting to contours or 3D. 

bryce_zoom_mat %>% 
  sphere_shade(texture = create_texture("#f5dfca","#63372c","#dfa283","#195f67","#c2d1cf",
                                        cornercolors = c("#ffc500", "#387642", "#d27441","#296176")),
               sunangle = 0, colorintensity = 5) %>%
  add_shadow(lamb_shade(bryce_zoom_mat),0.2) %>%
  add_overlay(generate_altitude_overlay(height_shade(bryce_zoom_mat, texture = "#91aaba"),
                                        bryce_zoom_mat,
                                        start_transition = min(bryce_zoom_mat)-200,
                                        end_transition = max(bryce_zoom_mat))) %>% 
  add_overlay(generate_line_overlay(bryce_footpaths,extent = extent_zoomed,
                                    linewidth = 7, color="black",
                                    heightmap = bryce_zoom_mat),alphalayer = 0.8) %>%
  add_overlay(generate_line_overlay(bryce_trails,extent = extent_zoomed,
                                    linewidth = 6, color="black",
                                    heightmap = bryce_zoom_mat),alphalayer = 0.8) %>%
  add_overlay(generate_line_overlay(bryce_roads,extent = extent_zoomed,
                                    linewidth = 8, color="black",
                                    heightmap = bryce_zoom_mat),alphalayer = 0.8) %>%
  add_overlay(generate_line_overlay(bryce_footpaths,extent = extent_zoomed,
                                    linewidth = 4, color="white",
                                    heightmap = bryce_zoom_mat),alphalayer = 0.8) %>%
  add_overlay(generate_line_overlay(bryce_trails,extent = extent_zoomed,
                                    linewidth = 3, color="white",
                                    heightmap = bryce_zoom_mat),alphalayer = 0.8) %>%
  add_overlay(generate_line_overlay(bryce_roads,extent = extent_zoomed,
                                    linewidth = 5, color="white",
                                    heightmap = bryce_zoom_mat),alphalayer = 0.8) %>%
  add_overlay(generate_polygon_overlay(bryce_building_poly, extent = extent_zoomed,
                                    heightmap = bryce_zoom_mat, palette="#292b26"), 
              alphalayer = 0.8) %>%
  plot_map()

And here’s an animated flipbook building this map:

Figure 7: A flipbook showing each layer added onto the Imhof map.

And that ends my tutorial! I hope it’s now clear how easy it is to add Open Street Map data to your rayshader maps, and how simple it is to customize the style and appearance of your map using nothing but code. If you create a fun or interesting visualization with rayshader, be sure to post it to Twitter with the hashtags #rstats and #rayshader. Happy mapping!

]]> 3D Cartography Data GIS Maps OpenStreetMap R Rayshader https://www.tylermw.com/posts/data_visualization/adding-open-street-map-data-to-rayshader-maps-in-r.html Sun, 03 Jan 2021 04:50:40 GMT How to: Download and Animate Polar Ice Data in R with Rayrender Tyler Morgan-Wall https://www.tylermw.com/posts/data_visualization/polar-ice-data-in-r-with-rayrender.html

This post will serve as a guide on making the above visualization entirely in R (using rayrender), directly from the data source! I wanted to create an example of how your could create a complex, multi-faceted 3D visualization, entirely in R. I’ve provided all the code so you can generate the visualization from scratch—this can hopefully provide you with several strategies and workflows so you can create beautiful 3D visualizations in R yourself.

We need two sources of data for this visualization: the sea ice extent polygons for both the arctic and antarctic along with the daily sea ice global area. We’ll first start with loading the monthly sea ice extent polygon data from the National Snow and Ice Data Center (NSIDC). NSIDC hosts the data on an FTP server, so we’ll pull the list of files and then download each shapefile individually.

First we download the Arctic data using RCurl: 

require(RCurl)

ice_dates = c("01_Jan", "02_Feb", "03_Mar", "04_Apr", "05_May", "06_Jun",
  "07_Jul", "08_Aug", "09_Sep", "10_Oct", "11_Nov", "12_Dec")

#Arctic
sea_url = "ftp://sidads.colorado.edu/DATASETS/NOAA/G02135/north/monthly/shapefiles/shp_extent/"

#Load all years of data, for each month
for(i in 1:12) {
  sea_url_single = glue::glue("{sea_url}{ice_dates[i]}/")
  filenames = getURL(sea_url_single, ftp.use.epsv = FALSE, dirlistonly = TRUE)
  filenames = strsplit(filenames, "\n")
  filenames = unlist(filenames)
  filenames = filenames[!filenames %in% c(".","..")]
  for (filename in filenames) {
    download.file(paste(sea_url_single, filename, sep = ""), 
                  paste(getwd(), "/", filename,sep = ""))
  }
}

And then run the same code, but now for the Antarctic data: 

#Antarctic

sea_url_south = "ftp://sidads.colorado.edu/DATASETS/NOAA/G02135/south/monthly/shapefiles/shp_extent/"
sea_url_single = glue::glue("{sea_url_south}{ice_dates[1]}/")

#Load all years of data, for each month

for(i in 1:12) {
  sea_url_single = glue::glue("{sea_url_south}{ice_dates[i]}/")
  filenames = getURL(sea_url_single, ftp.use.epsv = FALSE, dirlistonly = TRUE)
  filenames = strsplit(filenames, "\n")
  filenames = unlist(filenames)
  filenames = filenames[!filenames %in% c(".","..")]
  for (filename in filenames) {
    download.file(paste(sea_url_single, filename, sep = ""), 
                  paste(getwd(), "/", filename, sep = ""))
  }
}

Now, we’re going to load the polygon data into R, and then plot it in 3D over a world map. This requires a few moving parts: the sf package to read in the data, the anglr/silicate/quadmesh packages to project the polygons onto a 3D sphere, and then the rgl package to write the 3D polygon to an OBJ file (that’s then imported by rayrender).

Let’s first load some of our packages: 

library(sf)
library(maptools)
library(raster)
library(anglr) 
library(silicate)
library(quadmesh)
library(rgl)
library(rayrender)

We’re going to generate two separate visualizations and combine them to create the visualization above. First we’ll generate the polar world map that shows the actual polar ice caps on the right. We’ll render an image for each year and month: when the 3D line graph on the left passes through that month and year, we’ll display the corresponding polar polygon data. This way we only have to generate about 360 (12 months * 30 years) images for the right half of the visualization, versus the full 11924 frames for the left.

Our data is given in monthly intervals: let’s write a function that will take the month and year we want and write our two 3D models to the current directory. This function unzips the polygon to a temporary directory, reads the polygon in using sf, generates a Delaunay triangulation (with a maximum triangle size, which preserves interior points and thus captures the curvature of the earth), creates a mesh out of it, projects that mesh onto a sphere, and then writes the mesh to an OBJ file. It does this for both the arctic (arctic.obj) and antarctic (antarctic.obj). 

generate_sea_obj = function(yearval, mon_val) {
  #South
  temp_ice_dir = tempdir()
  sea_ice_temp = unzip(sprintf("extent_S_%d%02d_polygon_v3.0.zip",yearval,mon_val), 
                       exdir = temp_ice_dir)
  temp_address = sprintf("%s/extent_S_%d%02d_polygon_v3.0.shp",temp_ice_dir,yearval,mon_val)
  ice_layer = sf::st_read(temp_address) 
  
  ice_layer_mesh  =sf::st_read(temp_address) %>% 
    DEL(max_area = 500000000) %>% 
    as.mesh3d(smooth=TRUE, color="red") 
  ice_layer_mesh$vb[1:3,] = t(llh2xyz(
    reproj::reproj(t(ice_layer_mesh$vb[1:3,]),
                   source = crs(ice_layer), 
                   target="+proj=longlat +datum=WGS84"))) 
  plot3d(ice_layer_mesh,box=FALSE,axes=FALSE)
  Sys.sleep(0.2)
  
  rgl::aspect3d("iso")
  Sys.sleep(0.2)
  rgl::writeOBJ("antarctic.obj")
  Sys.sleep(0.2)
  
  rgl::rgl.clear()
  #North
  sea_ice_temp = unzip(sprintf("extent_N_%d%02d_polygon_v3.0.zip", yearval,mon_val), 
                       exdir = temp_ice_dir)
  temp_address = sprintf("%s/extent_N_%d%02d_polygon_v3.0.shp",temp_ice_dir,yearval,mon_val)
  ice_layer  =sf::st_read(temp_address) 
  
  ice_layer_mesh  =sf::st_read(temp_address) %>% 
    DEL(max_area = 500000000) %>% 
    as.mesh3d(smooth=TRUE, color="red") 
  ice_layer_mesh$vb[1:3,] = t(llh2xyz(
    reproj::reproj(t(ice_layer_mesh$vb[1:3,]),
                   source = crs(ice_layer), 
                   target="+proj=longlat +datum=WGS84"))) 
  plot3d(ice_layer_mesh,box=FALSE,axes=FALSE)
  Sys.sleep(0.2)
  
  rgl::aspect3d("iso")
  Sys.sleep(0.2)
  
  rgl::writeOBJ("arctic.obj")
  Sys.sleep(0.2)
  
  rgl::rgl.clear()
}
Figure 1: 3D model of the arctic sea ice.

Now let’s generate the 3D pathtraced polar map on the right. We’ll generate our monthly OBJ file using generate_sea_obj(), place it on top of a sphere with a world map superimposed, load it into a virtual photo studio generated using generate_studio(), and light up the scene with a single sphere light. The data starts in February 1988 and ends in September of 2020, so we’ll skip the first month in 1988 and break out of the loop when it hits October 2020. 

yearvals = 1988:2020
mon_vals = 1:12

for(yearval in yearvals) {
  for(mon_val in mon_vals) {
    if(yearval == 1988 && mon_val == 1) {
      next
    }
    if(yearval == 2020 && mon_val == 10) {
      break
    }
    generate_sea_obj(yearval,mon_val)
    generate_studio() %>% 
      add_object(sphere(x=1,radius=1,angle=c(-90,0,0),material = glossy(gloss=0.2,
        image_texture = "earth.png"))) %>%
      add_object(sphere(x=-1,radius=1,angle=c(-90,180,0),material = glossy(gloss=0.2,
        image_texture = "earth.png"))) %>%
      add_object(obj_model(x=1,"arctic.obj", z=0.0001,scale_obj = 1/6378100 , 
                           material=glossy(),angle=c(0,0,0))) %>%
      add_object(obj_model(x=-1,"antarctic.obj", z=0.0001,scale_obj = 1/6378100 , 
                           material=glossy(), angle=c(0,180,0))) %>%
      add_object(sphere(y=5,z=5,radius=2,material=light(intensity =10))) %>% 
      render_scene(width=800,height=800,aperture=0, fov=25,sample_method = "stratified", 
                   samples=500, clamp_value=10, lookfrom=c(0,1,10), 
                   filename=glue::glue("seaice_{yearval}_{mon_val}.png"))
  }
}

Figure 2: Example render for the monthly sea ice polygon data.

Done! Now, let’s generate the line plot on the left. This is a bit more involved :)

First, we must load and process the daily sea ice data. I’ve included a cleaned up version of the dataset here. We’ll use dplyr and reshape2 to take clean and transform the data into the format we require to plot it in 3D. Specifically, we need to map the date to a point around a circle. Since we’re working with dates, we’ll take advantage of the great lubridate package. 

library(reshape2)
library(dplyr)
library(lubridate)

sea_ice <- read.csv("sea_ice.csv")
gt::gt(head(sea_ice))
Month Day X1978 X1979 X1980 X1981 X1982 X1983 X1984 X1985 X1986 X1987 X1988 X1989 X1990 X1991 X1992 X1993 X1994 X1995 X1996 X1997 X1998 X1999 X2000 X2001 X2002 X2003 X2004 X2005 X2006 X2007 X2008 X2009 X2010 X2011 X2012 X2013 X2014 X2015 X2016 X2017 X2018 X2019 X2020
January 1 NA NA 14.200 14.256 NA 14.253 NA NA 14.036 NA NA 14.261 14.319 13.634 14.069 14.035 14.095 14.145 13.804 13.657 14.025 13.823 13.442 13.479 13.590 13.647 13.502 13.160 13.160 13.110 13.206 13.189 13.205 12.896 13.353 12.959 13.011 13.073 12.721 12.643 12.484 12.934 13.102
January 2 NA 14.997 NA NA 14.479 NA 14.103 14.045 NA 14.305 NA 14.313 14.384 13.831 14.092 14.141 14.110 14.258 13.818 13.801 14.097 13.886 13.539 13.385 13.628 13.698 13.538 13.163 13.210 13.207 13.164 13.180 13.232 12.915 13.421 12.961 13.103 13.125 12.806 12.644 12.600 12.992 13.075
January 3 NA NA 14.302 14.456 NA 14.306 NA NA 14.292 NA NA 14.402 14.283 13.847 14.141 14.250 14.042 14.335 13.786 13.837 14.262 13.884 13.630 13.418 13.598 13.876 13.502 13.293 13.267 13.182 13.190 13.267 13.254 12.926 13.379 13.012 13.116 13.112 12.790 12.713 12.634 12.980 13.176
January 4 NA 14.922 NA NA 14.642 NA 14.237 14.240 NA 14.417 NA 14.417 14.321 13.858 14.072 14.255 14.168 14.288 13.791 13.864 14.277 13.913 13.657 13.510 13.623 13.925 13.590 13.313 13.307 13.252 13.275 13.286 13.236 13.051 13.414 13.045 13.219 13.051 12.829 12.954 12.724 13.045 13.187
January 5 NA NA 14.414 14.435 NA 14.494 NA NA 14.489 NA NA 14.381 14.303 13.872 14.185 14.266 14.231 14.304 13.839 14.016 14.217 13.890 13.678 13.566 13.683 14.036 13.617 13.383 13.314 13.361 13.303 13.352 13.337 13.176 13.417 13.065 13.148 13.115 12.874 12.956 12.834 13.147 13.123
January 6 NA 14.929 NA NA 14.880 NA 14.262 14.406 NA 14.515 NA 14.359 14.407 13.958 14.254 14.220 14.295 14.325 13.877 14.139 14.263 14.044 13.806 13.722 13.645 14.075 13.594 13.324 13.265 13.403 13.325 13.447 13.458 13.169 13.404 13.126 13.142 13.138 13.039 12.839 12.772 13.316 13.196
Table 1: Sample of sea ice data, in wide format.

The data is in a wide format—we need it in a long format. Luckily, that’s easy to do with reshape2::melt() (I use 1989 as an example because there are NA values scattered before then): 

sea_ice %>% 
  melt(id.vars=c("Month","Day")) ->
long_sea_ice 
gt::gt(head(long_sea_ice[long_sea_ice$variable == "X1989",]))
Month Day variable value
January 1 X1989 14.261
January 2 X1989 14.313
January 3 X1989 14.402
January 4 X1989 14.417
January 5 X1989 14.381
January 6 X1989 14.359
Table 2: Sample of sea ice data, in long format.

We now need to convert the daty of the year to an angle around the circle. We’ll do this by using the yday function in lubridate, which gives the number of days into the year. If you multiply this by , this will give you the angle (in radians) the day corresponds to around the circle. We will also use the built-in dataset month.name in R to easily convert month names to their corresponding numerical values. 

long_sea_ice %>% 
  mutate(year = substr(variable,2,5)) %>% 
  select(-variable) %>% 
  mutate(datetime = ymd(paste(year,Month,Day))) %>% 
  mutate(day_of_year = yday(datetime), angle_rad = day_of_year/365*2*pi) %>% 
  filter(!is.na(datetime)) %>% 
  filter(datetime > ymd("1988-02-01")) %>% 
  mutate(x_coord = 4*sin(angle_rad), z_coord = 4*cos(angle_rad), y_coord = value) ->
data_set_ice
## Warning: 32 failed to parse.
data_set_ice$month_vals = match(data_set_ice$Month, 
                                month.name)
gt::gt(head(data_set_ice))
Month Day value year datetime day_of_year angle_rad x_coord z_coord y_coord month_vals
February 2 15.568 1988 1988-02-02 33 0.5680688 2.152021 3.371766 15.568 2
February 3 15.462 1988 1988-02-03 34 0.5852830 2.209741 3.334223 15.462 2
February 4 15.479 1988 1988-02-04 35 0.6024972 2.266807 3.295692 15.479 2
February 5 15.413 1988 1988-02-05 36 0.6197114 2.323201 3.256184 15.413 2
February 6 15.448 1988 1988-02-06 37 0.6369256 2.378907 3.215712 15.448 2
February 7 15.313 1988 1988-02-07 38 0.6541398 2.433907 3.174286 15.313 2
Table 3: Final data frame with circular date positions calculated.

We’ll also extract the minimum values from each year to place our annotations: 

data_set_ice %>% 
  mutate(full_date  = glue::glue("{Month} {Day}, {year}")) %>% 
  group_by(year) %>% 
  mutate(min_ext = min(value, na.rm=TRUE)) %>% 
  filter(value == min_ext) ->
min_date_values

gt::gt(head(min_date_values[,c("full_date","min_ext")]))
full_date min_ext
September 11, 1988 7.048
September 22, 1989 6.888
September 21, 1990 6.011
September 16, 1991 6.259
September 7, 1992 7.159
September 13, 1993 6.161
Table 4: Sample of annual sea ice minimums.

Let’s also extract vectors of the data up until mid-September 2020: 

pointvals = as.matrix(data_set_ice[1:11294,c("x_coord","y_coord","z_coord")])
year_vals = as.character(data_set_ice[1:11294,"year"])
month_vals = as.numeric(data_set_ice[1:11294,"month_vals"])
day_vals = as.numeric(data_set_ice[1:11294,"day_of_year"])

Now, let’s generate the static portions of our scene. This includes the circular month axis and the vertical sea ice extent axis. 

#Light intensity
intval = 2

#Vertical ticks
vert_start = 7
vert_tick_list = list()
for(i in seq(0,17)) {
  vert_tick_list[[i+1]] = segment(start = c(vert_start,i,0), end = c(vert_start+0.2,i,0), radius = 0.01,material=light(intensity = intval,importance_sample = FALSE))
}
vert_ticks = do.call(rbind,vert_tick_list)

#Vertical labels
vert_label_list = list()
for(i in seq(0,17)) {
  vert_label_list[[i+1]] = text3d(label=as.character(i), 
                                  x = vert_start + 1,
                                  y = i,
                                  z = 0, 
                                  text_height = 0.6,
                                  angle = c(0,180,0),
                                  orientation = "xy",
                                  material=light(intensity = intval,importance_sample = FALSE))
}
vert_labels = do.call(rbind,vert_label_list)

#Horizontal ticks
hor_tick_list = list()
angles = seq(0,2*pi,length.out = 13)[-13]
for(i in seq(1,12)) {
  hor_tick_list[[i+1]] = segment(start = c(4*sin(angles[i]),0,4*cos(angles[i])), 
                                 end = c(4.3*sin(angles[i]),0,4.3*cos(angles[i])), radius = 0.01,
                                  material=light(intensity = intval,importance_sample = FALSE))
}
hor_ticks = do.call(rbind,hor_tick_list)

#Horizontal labels
months = c("Jan", "Feb", "Mar", "Apr", "May", "Jun", "Jul","Aug", "Sep", "Oct", "Nov", "Dec")
month_label_list = list()
angles = seq(0,2*pi,length.out = 13)[-13]
for(i in seq(1,12)) {
  month_label_list[[i+1]] = text3d(label=months[i], 
                                   x = 5.7*sin(angles[j]),
                                   y = 0,
                                   z = 5.7*cos(angles[j]),  
                                   text_height = 0.75,
                                   orientation = "xy",
                                   material=light(intensity = intval,importance_sample = FALSE))
}

Figure 3: Render of static scene elements.

We are plotting the path as a series of connected bezier curves, so we need to calculate the control points for each curve (given a series of points we want the curve to travel through). Rayrender has an internal function we can use to do this calculate_control_points(). These are usually calculated by rayrender in the path() function from your desired data points, but this calculation is rather expensive and we don’t want to repeat it every frame, so we’ll pre-compute it and set precomputed_control_points = TRUE in path(). 

pointlist = rayrender:::calculate_control_points(pointvals)

We want to draw two paths: one bright one signifying the last 60 days from the current measurement, and a dim path representing all the measured data points up before then. We can specify this with the parametric u arguments in path(). 

u_min = seq(0,1,length.out = length(year_vals))-60/length(year_vals)
u_min[u_min < 0] = 0
u_max = seq(0,1,length.out = length(year_vals))+1/length(year_vals)
u_max[u_max > 1] = 1

In order to label the current value on the axis, we need to extract the y-coordinate in 3D space from the full bezier path. We can do this by finding the single bezier curve that u parametric coordinate falls into, and then calculating the per-curve u and use the bezier curve function to calculate the value at that point. 

calc_bezier = function(p1,p2,p3,p4, u) {
  (1-u)^3 * p1 + 3*(1-u)^2 * u * p2 + 3*(1-u) * u^2 * p2 + u^3 * p4
}

get_point_along_path = function(pointlist, u) {
  if(u == 0) {
    return(pointlist[[1]][1,])
  }
  if(u == 1) {
    return(pointlist[[length(pointlist)]][4,])
  }
  u_per_point = 1/length(pointlist)
  u_path = length(pointlist) * u +1
  p_index = floor(u_path) 
  
  pointval = pointlist[[p_index]]
  u_remain = u_path - p_index
  calc_bezier(pointval[1,],pointval[2,],pointval[3,],pointval[4,],u=u_remain)
}

We will then vectorize this function and apply it to every u coordinate along the curve. Using the Vectorize() function is how you show people you’re a professional R superuser who knows how to solve problems with finesse and grace :) 

point_vec = Vectorize(get_point_along_path, vectorize.args = c("u"), SIMPLIFY = FALSE)
points_for_curve = point_vec(pointlist, u=u_max[1:11924,])

Now we render the full thing! Since we aren’t including any non-light materials in this scene, the rendering process happens relatively quickly. This is because the the pathtracing will always terminate at the first ray for each pixel: either it hits a light and terminates, or it doesn’t hit anything and also terminates. Since we have adaptive sampling on, the rendering algorithm quickly hones in on rendering just the elements of our scene. We also include a chunk of code to generate a pulsating year value and minimum area annotations—the year size pulse on January 1st makes the year change more apparent, and the annotation helps drive the narrative of the visualization. 

for(i in seq(1,length(year_vals),by=1)) {
  for(j in 1:nrow(min_date_values)) {
    #Generate annotations for lowest values of current year
    if(year_vals[i] == min_date_values$year[j] &&
       day_vals[i] ==  min_date_values$day_of_year[j]) {
      annotation_list[[annotation_counter]] =
        segment(start = c(min_date_values$x_coord[j],
                          min_date_values$y_coord[j],
                          min_date_values$z_coord[j]),
                end = c(min_date_values$x_coord[j]-1.5,
                        min_date_values$y_coord[j],
                        min_date_values$z_coord[j]), radius = 0.01,
                material=light(intensity = 1,importance_sample = FALSE)) %>%
        add_object(text3d(label="Yearly Minimum:",
                          x = min_date_values$x_coord[j]-4,
                          y = min_date_values$y_coord[j]+0.5,
                          z = min_date_values$z_coord[j],
                   text_height = 0.5,
                   angle=c(0,180,0),
                   orientation = "xy",
                   material=light(intensity = intval+20,importance_sample = FALSE))) %>%
        add_object(text3d(label=min_date_values$full_date[j],
                          x = min_date_values$x_coord[j]-4,
                          y = min_date_values$y_coord[j],
                          z = min_date_values$z_coord[j],
                          text_height = 0.5,
                          angle=c(0,180,0),
                          orientation = "xy",
                          material=light(intensity = intval+20,importance_sample = FALSE))) %>%
        add_object(text3d(label=glue::glue("{prettyNum(min_date_values$value[j]*1000000, big.mark=',')} km^2"),
                          x = min_date_values$x_coord[j]-4,
                          y = min_date_values$y_coord[j]-0.5,
                          z = min_date_values$z_coord[j],
                   text_height = 0.5,
                   angle=c(0,180,0),
                   orientation = "xy",
                   material=light(intensity = intval+20,importance_sample = FALSE)))
      #Remove previous year's annotation
      if(length(annotation_list) > 1) {
        is_cylinder = annotation_list[[annotation_counter - 1]]$shape == "cylinder"
        annotation_list[[annotation_counter - 1]] = annotation_list[[annotation_counter - 1]][is_cylinder,]
        annotation_list[[annotation_counter - 1]]$lightintensity = 0.2
      }
      annotation_counter = annotation_counter + 1
    }
  }
  #Fade current annotation
  if(annotation_counter > 1) {
    is_text = annotation_list[[annotation_counter-1]]$shape == "xy_rect"
    intensity_vec = annotation_list[[annotation_counter-1]]$lightintensity[is_text]
    if(intensity_vec[1] > intval) {
      intensity_vec = intensity_vec - 1
      annotation_list[[annotation_counter-1]]$lightintensity[is_text] = intensity_vec
    }
  }
  all_annotations = do.call(rbind,annotation_list)
  
  path(points = pointlist, width=0.03, type = "flat", u_min = u_min[i], u_max=u_max[i], 
       precomputed_control_points = TRUE,
       material=light(color="blue", gradient_color = "red",  
                     importance_sample = FALSE, gradient_type = "rgb",intensity=intval+2,
                     gradient_point_start = c(0,2,0), gradient_point_end = c(0,15,0))) %>% 
    add_object(path(points = pointlist, width=0.02, type = "flat", u_min = 0, u_max=u_min[i], 
                    precomputed_control_points = TRUE,
                    material=light(color="blue", gradient_color = "red",
                                   importance_sample = FALSE, gradient_type = "rgb",intensity=0.25,
                                   gradient_point_start = c(0,2,0), gradient_point_end = c(0,15,0),
                    ))) %>%
    add_object(disk(radius=4.025,inner_radius = 3.975, 
                    material=light(intensity = intval,importance_sample = FALSE))) %>% 
    add_object(segment(start = c(vert_start,0,0), end = c(vert_start,17,0), radius=0.01,
                       material=light(intensity = intval,importance_sample = FALSE))) %>% 
    add_object(vert_ticks) %>% 
    add_object(hor_ticks) %>% 
    add_object(month_ticks) %>% 
    add_object(vert_labels) %>%
    add_object(all_annotations) %>% 
    add_object(sphere(x=vert_start * cospi(camera_angle[counter]/180), 
                      y=points_for_curve[[i]][2],
                      z=vert_start * sinpi(camera_angle[counter]/180), 
                      radius = 0.15,
                       material=light(color="blue", gradient_color = "red",
                                      importance_sample = FALSE, gradient_type = "rgb",
                                      intensity=intval+5,
                                      gradient_point_start = c(0,2,0), 
                                      gradient_point_end = c(0,15,0)))) %>% 
    add_object(sphere(x=points_for_curve[[i]][1], 
                      y=0,
                      z=points_for_curve[[i]][3], 
                      radius = 0.15,
                      material=light(color="white", 
                                     importance_sample = FALSE,intensity=1))) %>% 
    add_object(segment(start=c(points_for_curve[[i]][1], 0,points_for_curve[[i]][3]),
                       end=c(points_for_curve[[i]][1], points_for_curve[[i]][2],points_for_curve[[i]][3]),
                       radius = 0.01,
                       material=light(color="white", importance_sample = FALSE,intensity=1))) %>% 
    add_object(text3d(label="Global sea ice extent", 
                      x = vert_start ,
                      y = 19,
                      z = 0, 
                      text_height = 0.5,
                      angle = c(0,180,0),
                      orientation = "xy",
                      material=light(intensity = intval,importance_sample = FALSE))) %>% 
    add_object(text3d(label="(Millions km^2)", 
                      x = vert_start ,
                      y = 18.4,
                      z = 0, 
                      text_height = 0.5,
                      angle = c(0,180,0),
                      orientation = "xy",
                      material=light(intensity = intval,importance_sample = FALSE))) %>%
    add_object(text3d(label=year_vals[i], 
                      x = 0,
                      y = 0,
                      z = 0, 
                      text_height = 1.5 + 1*exp(-day_vals[i]/15),
                      angle = c(0,180,0),
                      orientation = "xy",
                      material=light(intensity = intval,importance_sample = FALSE))) %>% 
    render_scene(lookfrom=c(30 * sinpi(camera_angle[counter]/180),
                            20,
                            -30 * cospi(camera_angle[counter]/180)),
                 lookat=c(0,8.5,0),
                 width=800,height=800,fov=0,ortho_dimensions = c(22,22),
                 min_variance = 0.00001,
                 samples=100,
                 filename=glue::glue("seaice{counter}"))
  counter = counter + 1
}

Figure 4: Single frame from the render.

Okay, 11924 iterations (and more than a day of rendering!) later, we have all the frames for our visualization! Now let’s add the author information and data source using the magick package. We’ll use the furrr package to easily parallelize the process. 

quick_text = function(i) {
  title_offset = c(10,5)
  title_color = "white"
  magick::image_read(glue::glue("seaice{i}.png")) %>%
    magick::image_annotate("Data Source: NSIDC",
                           location = paste0("+", title_offset[1],"+",title_offset[2]),
                           size = 16, color = title_color, 
                           font = "sans", gravity = "southeast") %>%
    magick::image_annotate("Twitter: @tylermorganwall",
                           location = paste0("+", title_offset[1],"+",title_offset[2]),
                           size = 16, color = title_color, 
                           font = "sans", gravity = "southwest") %>%
    magick::image_write(path = glue::glue("seaiceinfo{i}.png"), format = "png")
}
furrr::future_map(1:11924, quick_text)

Figure 5: Adding a twitter handle and the data source.

Okay, now let’s generate a title. This functionality is built-in to the rayimage package. Our title will span both images, so it should be 1600 pixels wide. 

library(rayimage)
title_mat = matrix(0,70,1600)
title_mat %>% 
  add_title(title_text = "Daily Global Sea Ice Total Area with Monthly Polar Sea Ice Extent, 1988-2020", 
            title_bar_alpha = 1, title_bar_color = "grey30", 
            title_color = "white", filename="title")

Figure 6: Generated title.

Finally: let’s combine all the images together to form our final visualization using magick! We’ll use furrr again to parallelize the process. This function reads the current value for year_val and month_val, and pulls the corresponding render from the world map. 

quick_generate_final = function(i) {
  line_image = magick::image_read(glue::glue("seaiceinfo{i}.png"))
  world_image = magick::image_read(glue::glue("seaice_{year_vals[i]}_{month_vals[i]}.png"))
  
  magick::image_append(c(line_image,world_image)) %>% 
    (function(x) magick::image_append(c(title_image,x), stack=TRUE)) %>% 
    magick::image_write(glue::glue("full_sea_image{i}.png"))
}
furrr::future_map(1:11924,quick_generate_final)

Figure 7: Single frame from the full animation.

Let’s also repeat the final frame for a few seconds so the reader can take it in. 

for(i in 1:180) {
  png::writePNG(png::readPNG("full_sea_image11924.png"),
                glue::glue("full_sea_image{i+11924}.png"))
}

Finally, we’ll use the av package to generate the final video. 

av::av_encode_video(glue::glue("full_sea_image{1:12104}.png"), 
                    output = "full_sea_viz.mp4", framerate = 60)

I hope you enjoyed this walkthrough! If you want to see more about the thought process I went through when generating the visualization, check out this twitter thread:

]]> 3D Analysis Cartography GIS Data Analysis Maps R Rayrender Pathtracing Climate Data Visualization https://www.tylermw.com/posts/data_visualization/polar-ice-data-in-r-with-rayrender.html Tue, 13 Oct 2020 07:32:01 GMT Plinko Statistics: Insights from the Bean Machine Tyler Morgan-Wall https://www.tylermw.com/posts/data_analysis/plinko-statistics-insights-from-the-bean-machine.html

A Galton board (aka a “Bean Machine”) is an interesting mix of chaos and predictability: a single ball’s path is unpredictable, yet the behavior of a mass of balls results in a remarkably consistent result. It’s a toy that cuts right to the core of statistics: one measurement doesn’t tell you much about a system, but many measurements in aggregate do. Combining those concepts with all fun of plinko/pachinko/peggle and you have an excellent little system that can illustrate a great number of statistical concepts. It’s no surprise that it makes an early appearance in most statistics curriculum. However, most instructors only use it as an illustration of the Central Limit Theorem: a series of binary choices results in a normal distribution. This is a shame, since you can illustrate so much more if you look a little deeper–and that’s what this blog post is going to do.

I was inspired to make this post after @coolbutuseless released the chipmunkcore/chipmunkbasic package: an R wrapper around the Chipmunk2D physics library. Wrapping a physics library in R had long been on my “maybe one day” todo list, so I was glad someone beat me to the punch–less work for me! The package allows you to build a fixed scene out of rectangles and then place movable objects (circles, spheres, and polygons) that can interact with each other, the scene, and a gravitational force.

With the package, @coolbutuseless released a slick demo (with code) animating a Galton board with ggplot2. Awesome–but what if we could render a 3D visualization of the same data that gives us something more true-to-life? Still a 2D simulation, but rendered like the real thing. If only there was a package that could render complex 3D scenes directly in R… which of course there is! We will be using the rayrender package to generate our 3D renders. I wrote rayrender to create high quality 3D visualizations in R, without having to export your data to another program. Rayrender allows you to easily craft 3D scenes out of a wide range of primitive objects. It renders scenes using pathtracing to produce a photorealistic result.

Let’s jump right into writing code. First we’ll load the required packages. You have to install the Chipmunk2D library on your computer: easy on macOS if you use homebrew brew install chipmunk and a bit more involved on Ubuntu. You can see additional instructions I provided on the Github repo README, expand the “Click to show instructions for ubuntu - method 1” tab). Once that’s done, install {chipmunkcore} and {chipmunkbasic} from Github). On Windows–sorry, I have no idea! 

emotes::install_github("coolbutuseless/chipmunkcore")
remotes::install_github("coolbutuseless/chipmunkbasic")
library(chipmunkcore)
library(chipmunkbasic)
library(rayrender)

We’ll then copy some of the code @coolbutuseless used to generate the Galton board and extract a rayrender scene. A Galton board consists of three areas: The funnel that ensures the balls fall from approximately the same point: 

# Add funnel segments
generate_funnel_scene = function(color="red") {
  xz_rect(x=-67/2-3,y=125,xwidth=83.60024,angle=c(0,0,36.73283),zwidth=5, 
                   material=diffuse(color=color)) %>% 
    add_object(xz_rect(x=67/2+3,y=125,xwidth=83.60024,angle=c(0,0,-36.73283),zwidth=5, 
                     material=diffuse(color=color))) %>% 
    add_object(yz_rect(x=-3,y=95, ywidth=10,zwidth=5, material=diffuse(color=color))) %>% 
    add_object(yz_rect(x=3,y=95, ywidth=10, zwidth=5,material=diffuse(color=color)))
}

funnelscene = generate_funnel_scene()

generate_studio(width = 1000, height = 1000,depth=-5) %>%
    add_object(funnelscene) %>%
    add_object(sphere(y=200,z=100,radius=20,material=light(intensity = 40))) %>%
    render_scene(lookfrom=c(0,150,100),fov=90,lookat=c(0,50,0),samples=512,
                 clamp_value = 10, sample_method = "stratified", width=800,height=800)

Figure 1: Funnel to guide balls down to the top of the board.

Next comes the pegs that interrupt the flow of the balls. These force the balls left or right. They are actually small rectangles in the simulation, but here we’ll represent them with cylinders (they are small enough that you can’t visually tell the difference): 

#Generate pegs
generate_peg_scene = function(pegs = 15, color="red") {
  cm = Chipmunk$new(time_step = 0.005)
  for (i in 1:pegs) {
    y = 90 - i * 3
    if (i %% 2 == 1) {
      xs = seq(0, 40, 2)
    } else {
      xs = seq(1, 40, 2)
    }
    xs = 1.0 * sort(unique(c(xs, -xs)))
    
    w = 0.05
    xstart = xs - w
    xend   = xs + w
    
    for (xi in seq_along(xs)) {
      cm$add_static_segment(xstart[xi], y+0.01,  xend[xi],  y-0.01)
    }
  }
  
  #Convert chipmunk pegs into a rayrender scene:
  cm$get_static_segments() -> peg_seg
  peglist = list()
  for(i in 1:nrow(peg_seg)) {
    peglist[[i]] = cylinder(x=peg_seg$x1[i]+0.05, y=peg_seg$y1[i],
                            angle=c(90,0,0),radius=0.1, length=5,material=diffuse(color=color))
  }
  do.call(rbind,peglist)
}

pegscene = generate_peg_scene()

generate_studio(width = 1000, height = 1000,depth=-5) %>%
    add_object(funnelscene) %>%
    add_object(pegscene) %>%
    add_object(sphere(y=200,z=100,radius=20,material=light(intensity = 40))) %>%
    render_scene(lookfrom=c(0,130,100),fov=50,lookat=c(0,60,0),samples=512,
                 clamp_value = 10, sample_method = "stratified", width=800,height=800)

Figure 2: Field of pegs.

And finally the buckets that hold the balls: 

generate_slot_scene = function(pegs=15, color="red") {
  cm = Chipmunk$new(time_step = 0.005)
  floor = 85 - pegs*3 - 40
  width = 50
  for (x in seq(-width, width, 5)) {
    cm$add_static_segment(x, floor,  x,  85 - pegs*3)
  }
  
  cm$get_static_segments() -> slots
  
  slotlist = list()
  counter = 1
  for(i in 1:nrow(slots)) {
    slotlist[[counter]] = cube(x=slots$x1[i],y=85 - pegs*3-20, xwidth=0.05, 
                               ywidth=40,zwidth=5,material=diffuse(color=color))
    counter = counter + 1
  }
  #Bottom of the bucket:
  slotlist[[counter]] = cube(y=floor, xwidth=100,zwidth=5,ywidth=0.05, material=diffuse(color=color))
  slotscene = do.call(rbind,slotlist)
  slotscene
}

slotscene = generate_slot_scene()

generate_studio(width = 1000, height = 1000,depth=-5) %>%
  add_object(funnelscene) %>%
  add_object(pegscene) %>%
  add_object(slotscene) %>% 
  add_object(sphere(y=200,z=100,radius=20,material=light(intensity = 40))) %>%
  render_scene(lookfrom=c(0,130,100),fov=50,lookat=c(0,50,0),samples=512,
               clamp_value = 10, sample_method = "stratified", width=800,height=800)

Figure 3: Final Galton board.

Now we have the full Galton board! We just need to throw in some balls. Let’s place 400 balls in the funnel. We scatter them randomly in a rectangular region above the spout. 

cm = Chipmunk$new(time_step = 0.005)

set.seed(1)
for (i in 1:400) {
  yval = runif(1,  120, 150)
  xval = runif(1,  -20,  20)
  cm$add_circle(
    x        = runif(1,  -20,  20),
    y        = runif(1,  120, 150),
    radius   = 0.8,
    friction = 0.01
  )
}

cm$get_circles() -> balls

balllist = list()
for(i in 1:nrow(balls)) {
  balllist[[i]] = sphere(x=balls$x[i],y=balls$y[i], material = glossy(color="purple"))
}
ballscene = do.call(rbind,balllist)

generate_studio(width = 1000, height = 1000,depth=-5) %>%
  add_object(funnelscene) %>%
  add_object(pegscene) %>%
  add_object(slotscene) %>% 
  add_object(ballscene) %>% 
  add_object(sphere(y=150,z=150,radius=20,material=light(intensity = 40))) %>%
  render_scene(lookfrom=c(0,150,100),fov=80,lookat=c(0,80,0),samples=512,
               clamp_value = 10, sample_method = "stratified", width=800,height=800)

Figure 4: Initial configuration.

Let’s wrap all this up into a function to initialize the scene. This is so we don’t have to re-run all the above code every time we alter the board (the extra arguments angle and pout_shift we’ll use later). We’ll also include a function to extract the balls from the scene. 

initialize_galton = function(cm, angle = 0, seed = 1, 
                             spout_shift = 0, pegs = 15) {
  gap = 3
  cm$add_static_segment( -70 + spout_shift, 150, -gap + spout_shift, 100)
  cm$add_static_segment(  70 + spout_shift, 150,  gap + spout_shift, 100)
  cm$add_static_segment(-gap + spout_shift, 100, -gap + spout_shift,  90)
  cm$add_static_segment( gap + spout_shift, 100,  gap + spout_shift,  90)
  
  for (i in 1:pegs) {
    y = 90 - i * 3
    if (i %% 2 == 1) {
      xs = seq(0, 40, 2)
    } else {
      xs = seq(1, 40, 2)
    }
    xs = 1.0 * sort(unique(c(xs, -xs)))
    w = 0.05
    
    for (xi in seq_along(xs)) {
      xstart = xs - w * cospi(angle/180)
      xend   = xs + w * cospi(angle/180)
      cm$add_static_segment(xstart[xi], 
                     y + w * sinpi(angle/180),  
                     xend[xi],  
                     y - w * sinpi(angle/180))
    }
  }
  
  floor = 85 - pegs*3 - 40
  width = 50
  for (x in seq(-width, width, 5)) {
    cm$add_static_segment(x, floor,  x,  85 - pegs * 3)
  }
  
  cm$add_static_segment(-width, floor, width, floor)
  cm$add_static_segment(-width, floor-0.2, width, floor-0.2)
  
  set.seed(seed)
  for (i in 1:400) {
    yval = runif(1,  120, 150)
    xval = runif(1,  -20,  20)
    cm$add_circle(
      x        = runif(1,  -20,  20) + spout_shift,
      y        = runif(1,  120, 150),
      radius   = 0.8,
      friction = 0.01
    )
  }
}

chipmunk_balls_to_rayrender = function(cm, color="purple") {
  cm$get_circles() -> balls
  balllist = list()
  for(i in 1:nrow(balls)) {
    balllist[[i]] = sphere(x=balls$x[i],y=balls$y[i], material = glossy(color=color))
  }
  do.call(rbind,balllist)
}

Let’s start visualizing! Here’s a snapshot at four points in the evolution of the system, where balls later in time are shifted forward in space: 

cm = Chipmunk$new(time_step = 0.005)
initialize_galton(cm, seed = 2)
time1_balls = chipmunk_balls_to_rayrender(cm)
cm$advance(1000)
time2_balls = chipmunk_balls_to_rayrender(cm, color="blue")
cm$advance(1000)
time3_balls = chipmunk_balls_to_rayrender(cm, color="green")
cm$advance(1000)
time4_balls = chipmunk_balls_to_rayrender(cm, color="yellow")

generate_studio(width = 1000, height = 1000,depth=-5) %>%
  add_object(funnelscene) %>%
  add_object(pegscene) %>%
  add_object(slotscene) %>% 
  add_object(group_objects(time1_balls,group_translate = c(0,0,0))) %>% 
  add_object(group_objects(time2_balls,group_translate = c(0,0,20))) %>% 
  add_object(group_objects(time3_balls,group_translate = c(0,0,50))) %>% 
  add_object(group_objects(time4_balls,group_translate = c(0,0,75))) %>% 
  add_object(sphere(y=150,z=150,radius=20,material=light(intensity = 40))) %>%
  render_scene(lookfrom=c(-180,170,200),fov=40,lookat=c(0,60,00),samples=512,
               clamp_value = 10, sample_method = "stratified", width=800,height=800)

Figure 5: Four snapshots in time.

The balls fall, slowly filter through the funnel through the pegs (limited by the width of the funnel), and then finally exit out of the peg field into one of the buckets.

Changing the eed argument randomizes the initial positions, which will give us a new distribution at the bottom. We’ll use rayrender and the {av} package to create an animation visualizing the variation in these ending configurations: 

ball_colors = rainbow(30)
ball_scenes = list()
for(i in 1:30) {
  cm = Chipmunk$new(time_step = 0.005)
  initialize_galton(cm, seed = i)
  cm$advance(3000)
  ball_scenes[[i]] = chipmunk_balls_to_rayrender(cm, color=ball_colors[i])
}

pegblack = generate_slot_scene(color="grey10")
slotblack = generate_slot_scene(color="grey10")
funnelblack = generate_funnel_scene(color="grey10")

#Draw normal distribution path
xvals = seq(-40, 40, length.out = 50)
yvals = dnorm(xvals,sd=15)*1700
norm_path = matrix(0,nrow=50,ncol=3)
norm_path[,1] = xvals
norm_path[,2] = yvals

for(i in 1:30) {
  generate_studio(width = 1000, height = 1000,depth=-5) %>%
    add_object(pegblack) %>%
    add_object(slotblack) %>% 
    add_object(ball_scenes[[i]]) %>% 
    add_object(path(norm_path,z=3,width=1,material=diffuse(color="grey10"))) %>% 
    add_object(sphere(y=150,z=150,radius=50,material=light(intensity = 10))) %>%
    render_scene(lookfrom=c(-0,100,200),fov=20,lookat=c(0,20,00),samples=512,
                 filename = glue::glue("distributions{i}"),
                 clamp_value = 10, sample_method = "stratified", width=800,height=800)
}

av::av_encode_video(glue::glue("distributions{1:30}.png"), 
                    output = "distributions.mp4", framerate = 4)
Figure 6: 30 iterations, 30 distributions. One ball managed to perch itself perfectly on a peg–There’s always a rebel.

We see some minor variation, but otherwise it’s a (normalish) distribution centered around zero. This is where the standard Galton demonstration usually ends: look, it’s a Gaussian distribution! Something something Central Limit Theorem. Everybody clap.

Introducing bias

=

Not here though. Let’s keep on exploring. What happens when we slant each of the pegs in one direction? When a ball hits a flat peg, it’s equally likely to bounce in either direction. However, when we angle it in one direction, the ball is more likely to bounce in that direction (when striking it from above).

Let’s rotate the pegs in a circle (using the angle argument in initialize_galton()) and see what happens to the distribution. Below, I marked the theoretical center of the unbiased distribution with the purple arrow, while the actual measured center is shown with the green arrow. 

angles= seq(10,360,by=10)
standard_deviations = rep(0,length(angles))
means_x = rep(0,length(angles))
arrow = rayrender::arrow

for(i in 1:length(angles)) {
  cm = Chipmunk$new(time_step = 0.005)
  initialize_galton(cm, seed = 1, angle = angles[i])
  cm$advance(3000)
  ball_angled = chipmunk_balls_to_rayrender(cm, color="red")
  
  means_x[i] = mean(ball_angled$x[ball_angled$shape == "sphere"])
  standard_deviations[i] = sd(ball_angled$x[ball_angled$shape == "sphere"])

  generate_studio(width = 1000, height = 1000,depth=-5) %>%
    add_object(pegblack) %>%
    add_object(slotblack) %>%
    add_object(ball_angled) %>%
    add_object(path(norm_path,z=3,width=1,material=diffuse(color="grey10"))) %>%
    add_object(arrow(start=c(means_x[i],-5,5), end = c(means_x[i],5,5),
                     radius_top = 1.5, radius=0.75,
                     material=glossy(color="purple"))) %>%
    add_object(arrow(start=c(0,-5,5), end = c(0,5,5), radius_top = 1.5, radius=0.75,
                     material=glossy(color="green"))) %>%
    add_object(sphere(y=150,z=150,radius=50,material=light(intensity = 10))) %>%
    render_scene(lookfrom=c(-0,100,200),fov=20,lookat=c(0,20,00),samples=512,
                 filename=glue::glue("bias{i}"),
                 clamp_value = 10, sample_method = "stratified", width=1200,height=800)
}

#Inset
for(i in 1:36) {
  generate_studio() %>% 
    add_object(cube(xwidth=0.5,ywidth=0.1,zwidth=0.5, angle = c(0,0,angles[i]),
                    material=glossy(color="grey10"))) %>% 
    add_object(sphere(y=150,z=150,radius=50,material=light(intensity = 10))) %>%
    add_object(xy_rect(z=-0.25)) %>% 
    render_scene(fov=5,clamp_value=10,samples=2048,width=200,height=200,
                 min_variance = 0,
                 sample_method = "stratified",
                 filename=glue::glue("peginset{i}")) 
}

library(rayimage)
for(i in 1:36) {
  temp_array = array(0,dim = c(800,1200,4))
  peg_overlay = add_title(glue::glue("peginset{i}.png"), glue::glue("Angle: {angles[i]}°"), 
            title_bar_color = "black", title_color = "white", 
            title_size = 18, title_position = "north", title_offset = c(0,6))
  temp_array[1:200,1:200,1:3] = peg_overlay
  temp_array[1:200,1:200,4] = 1
  add_image_overlay(glue::glue("bias{i}.png"),temp_array,filename = glue::glue("bias_with_inset{i}.png"))
}

av::av_encode_video(glue::glue("bias{1:36}.png"), 
                    output = "bias.mp4", framerate = 4)
Figure 7: As the pegs rotate, we see a slight offset in the location of the center of the distribution.

We see the average of the distribution shifts as the pegs rotate: rotating the peg introduces bias into our system. The bias disappears when the peg is angled at multiples of 90 degrees. This is because these angles are symmetrical around the y-axis: they do not favor one direction over another. On the other hand, the bias is (approximately) largest at multiples of 45 degrees between these values. An angled peg directs downward momentum sideways, favoring one direction. We’ve now introduced an independent variable (the peg angle) that results in a shift in the mean of the distribution.

t-tests and hypothesis testing

How do we determine if it’s a significant shift? We’re using R–it’s super easy to run a t-test! We’ll use the averages and sample standard deviations we collected during the simulation. Let’s calculate our p-values/effect sizes and visualize them with a donut plot. This is a rare case where a donut plot is actually the natural method to represent the results, since our independent variable is an angle. 

library(ggplot2)
library(patchwork)

pvalues = 2*pnorm(-abs(means_x/(standard_deviations/sqrt(400))))

pval_table = data.frame(angle_max=angles,angle_min=angles-10,pvalues=pvalues, means_x=means_x)

# Make the plot
p1 = ggplot(pval_table, aes(ymax=angle_max, ymin=angle_min, xmax=4, xmin=3, 
                       fill=pvalues < 0.05)) +
  geom_rect() +
  coord_polar(theta="y", start = 5/180*pi, clip = "off") +
  scale_y_continuous("Peg Angle", limits=c(0,360), 
                     breaks = seq(5,355,by=10),labels = c(seq(10,350,by=10),0)) +
  geom_text(aes(y=angles-5, x= 3.5, label = sprintf("%.2g",pvalues), 
                angle = ifelse(angles < 180, 90-angles,-90-angles)), color = "white")+
  scale_x_continuous("",limits = c(1,4),breaks=c(1,4),labels = c("","")) +
  annotate("text",x=1,y=0,label="p-values",size=8) +
  scale_fill_manual("Reject Null\nHypothesis  \n(p < 0.05)",values = c("#bd3f00","#0486b5")) +
  theme_minimal() +
  theme(panel.grid = element_blank(),
        axis.title.x = element_text(size=18),
        axis.text.x = element_text(size=14)) +
  ggtitle("Does the Galton board distribution shift significantly for a given peg angle?")

# Make the effect size plot
p2 = ggplot(pval_table, aes(ymax=angle_max, ymin=angle_min, xmax=4, xmin=3, 
                       fill=means_x)) +
  geom_rect() +
  coord_polar(theta="y", start = 5/180*pi, clip = "off") +
  scale_y_continuous("Peg Angle", limits=c(0,360), 
                     breaks = seq(5,355,by=10),labels = c(seq(10,350,by=10),0)) +
  geom_text(aes(y=angles-5, x= 3.5, label = sprintf("%.2g",means_x), color = -means_x, 
                angle = ifelse(angles < 180, 90-angles,-90-angles)), size=4)+
  scale_x_continuous("",limits = c(1,4),breaks=c(1,4),labels = c("","")) +
  annotate("text",x=1,y=0,label="Effect size",size=8) +
  annotate("text",x=4.5,y=45,label="P-values",size=8,angle=-45) +
  scale_fill_viridis_c("x offset") +
  scale_color_viridis_c() +
  guides(color = FALSE) +
  theme_minimal() +
  theme(panel.grid = element_blank(),
        axis.title.x = element_text(size=18),
        axis.text.x = element_text(size=14)) 

p1 | p2

Figure 8: On the left we have a donut plot showing what angles did and did not introduce significant bias to the distribution. On the right, we show the actual magnitude of the offset.

This plot shows that the distribution shifts significantly at almost every non-90 degree angle. Awesome! Now we’re demonstrating some real statistics with our Galton board. The shift is pretty small, however. Our balls are 1.6 units in diameter and our board is 100 units wide, but we only see a maximum shift of 6 units. Compared to the width of our distribution (50 units), this isn’t that big, but it’s significant.

You might now ask: is this bias introduced only from the first series of pegs, or present throughout the entire board? The top pegs are the only layers hit where the ball is more or less guaranteed to be moving straight down. Do the angled pegs continue to influence the pegs as the balls make their way through?

Bootstrapping confidence intervals + showing bias

We’ll answer these questions by looking more closely at the paths of all the balls, rather than just their final positions. Let’s extract the paths taken by a sub-sample of the balls and examine them. We’ll write a function that performs the simulation and returns the rayrender paths for a particular peg angle. We’ll then run the simulation for each 10 degree increment and show the results. 

library(dplyr)

bootstrap_confidence_int = function(x) {
  boot_samples = replicate(1000, mean(sample(x, size=length(x), replace = TRUE)))
  boot_samples = boot_samples[order(boot_samples)]
  return(c(boot_samples[50],boot_samples[950]))
}

circles_to_path = function(maxtime=3000, step = 20, seed = 1, 
                           angle = 0, n=5, 
                           pegs = 15, spout_shift = 0, calc_mean = FALSE,
                           return_ball_coords = FALSE) {
  #initialize simulation
  cm = Chipmunk$new(time_step = 0.005)
  initialize_galton(cm, seed = seed, angle = angle, spout_shift = spout_shift, pegs = pegs)
  if(return_ball_coords) {
     cm$advance(maxtime)
    return(cm$get_circles()[1:n,])
  }
  time_val = step
  single_paths = list()
  for(i in 1:n) {
    single_paths[[i]] = list()
  }
  #Calculate position of each ball at every timestep
  counter = 1
  while(time_val < maxtime) {
    cm$advance(step)
    ball_instant = cm$get_circles()[1:n,]
    for(i in 1:n) {
      c(as.numeric(ball_instant[i,2:3]),0)
      single_paths[[i]][[counter]] = matrix(c(as.numeric(ball_instant[i,2:3]),0),ncol=3,nrow=1)
    }
    time_val = time_val + step
    counter = counter + 1
  }
  #Generate rayrender scene of all paths
  return_paths = list()
  for(i in 1:n) {
    return_paths[[i]] = path(do.call(rbind, single_paths[[i]]),width = 0.5,
                             material=glossy(color="red"))
  }
  if(calc_mean) {
    #Calculate mean x-coordinate at each y step for a single ball
    mean_paths = list()
    for(i in 1:n) {
      temp_path = as.data.frame(do.call(rbind,single_paths[[i]]))
      colnames(temp_path) = c("x","y","z")
      mean_paths[[i]] = temp_path %>% 
        mutate(y = round(y)) %>% 
        group_by(y) %>% 
        summarise(x = mean(x)) %>% 
        mutate(id = i) 
    }
    all_mean_paths = dplyr::bind_rows(mean_paths)
    
    #Calculate mean offset and bootstrap confidence intervals
    max_y = max(all_mean_paths$y)
    min_y = min(all_mean_paths$y)
    mean_path_line = list()
    lower_ci_list = list()
    upper_ci_list = list()
    counter = 1
    for(yval in min_y:max_y) {
      single_y = all_mean_paths %>% 
        filter(y == yval)
      if(nrow(single_y) > 0) {
        cis = bootstrap_confidence_int(single_y$x)
        mean_path_line[[counter]] = c(mean(unlist(single_y$x)),yval,3)
        lower_ci_list[[counter]] = c(cis[1],yval,3)
        upper_ci_list[[counter]] = c(cis[2],yval,3)
        counter = counter + 1
      }
    }
    #Add to scene
    return_paths[[n+1]] = path(mean_path_line, width=1,material=glossy(color="blue"))
    return_paths[[n+2]] = path(lower_ci_list, width=1,material=glossy(color="purple"))
    return_paths[[n+3]] = path(upper_ci_list, width=1,material=glossy(color="purple"))
  }
  dplyr::bind_rows(return_paths)
}

#Render the frames
angles= seq(10,360,by=10)

for(i in 1:36) {
  path_balls = circles_to_path(maxtime=3000, n=50, angle = angles[i], calc_mean = FALSE)
  generate_studio(width = 1000, height = 1000,depth=-5) %>%
    add_object(funnelblack) %>%
    add_object(pegblack) %>%
    add_object(slotblack) %>% 
    add_object(path_balls) %>% 
    add_object(sphere(y=150,z=150,radius=50,material=light(intensity = 8))) %>%
    render_scene(lookfrom=c(-0,60,200),fov=47,lookat=c(0,70,00),samples=16,
                 filename=glue::glue("ballpaths{i}"),
                 clamp_value = 10, sample_method = "stratified", width=1200,height=800)
}

for(i in 1:36) {
  temp_array = array(0,dim = c(800,1200,4))
  peg_overlay = add_title(glue::glue("peginset{i}.png"), glue::glue("Angle: {angles[i]}°"),
            title_bar_color = "black", title_color = "white",
            title_size = 18, title_position = "north", title_offset = c(0,6))
  temp_array[1:200,1:200,1:3] = peg_overlay
  temp_array[1:200,1:200,4] = 1
  add_image_overlay(glue::glue("ballpaths{i}.png"),temp_array,
                    filename = glue::glue("ballpaths_with_inset{i}.png"))
}
av::av_encode_video(glue::glue("ballpaths_with_inset{1:36}.png"), 
                    output = "ballpaths_with_inset.mp4", framerate = 4)
Figure 9: Horror film, or statistical demo? We’ve extracted the paths from 50 balls in the simulation and plotted them. It looks like bias from the pegs might be present, but it’s not definitive.

There might be a slight pattern in the average bias, but it’s hard to tell if it’s truly shifting left or right all the way down. Let’s set the calc_mea argument in circles_to_path to TRUE to add a mean distance and bootstrapped 95% confidence intervals to our rayrender scene. If the average offset grows as the balls fall through the pegs, we will say the angled pegs do bias each bounce. If the mean shifts suddenly at the top and then travels straight down, we’ll say the angled pegs only bias the first bounce, but then the randomness from the kinetic motion takes over.

I’ve increased the number of tracked balls here to 300 to get a better estimate of the mean offset. The mean is shown in blue and the 95% confidence intervals in purple. We bootstrap our 95% confidence intervals because we aren’t sure what the underlying distribution will look like. The bootstrapping process is as follows: collect all the ball positions at each interval, resample at that interval with replacement and compute the mean 1000 times, order the resulting averages, and then return the 50th and 950th means in the ordered vector of averages. Let’s check it out: 

for(i in 1:36) {
  path_balls = circles_to_path(maxtime=3000, n=300, angle = angles[i], calc_mean = TRUE)
  generate_studio(width = 1000, height = 1000,depth=-5) %>%
    add_object(funnelblack) %>%
    add_object(pegblack) %>%
    add_object(slotblack) %>% 
    add_object(path_balls) %>% 
    add_object(sphere(y=150,z=150,radius=50,material=light(intensity = 8))) %>%
    render_scene(lookfrom=c(-0,60,200),fov=47,lookat=c(0,70,00),samples=512,
                 filename=glue::glue("ball_means{i}"),verbose=TRUE,
                 clamp_value = 10, sample_method = "stratified", width=1200,height=800)
}

for(i in 1:36) {
  temp_array = array(0,dim = c(800,1200,4))
  peg_overlay = add_title(glue::glue("peginset{i}.png"), glue::glue("Angle: {angles[i]}°"),
                          title_bar_color = "black", title_color = "white",
                          title_size = 18, title_position = "north", title_offset = c(0,6))
  temp_array[1:200,1:200,1:3] = peg_overlay
  temp_array[1:200,1:200,4] = 1
  add_image_overlay(glue::glue("ball_means{i}.png"),temp_array,
                    filename = glue::glue("ballmeans_with_inset{i}.png"))
}
av::av_encode_video(glue::glue("ballmeans_with_inset{1:36}.png"), 
                    output = "ballmeans_with_inset.mp4", framerate = 4)
Figure 10: By plotting the mean path of a large number of balls, we see the mean truly is shifting all the way down.

We can see here that the line shifts in one direction as the balls travel through the board–the pegs do continue to influence the direction of each bounce. It’s not just an offset from the first step of pegs. Our bootstrapped confidence intervals show us that the variation in position grows as the balls fall through the board. The blue line shows how the center of the distribution shifts as the balls travel through the angled pegs. The total bias grows with the length of the board. This brings us to our next Galton board lesson: interaction effects!

Interaction effects

What do I mean when I write “interaction effects”? Let’s see the effect of changing the number of pegs at a fixed peg angle. We’ll visualize boards with 1 layer, 15 layers, and 30 layers: 

peg_1_scene = generate_peg_scene(pegs=1, color="grey10")
slot_1_scene = generate_slot_scene(pegs=1, color="grey10")
path_1peg_balls = circles_to_path(maxtime=3000, n=300, 
                             angle = 45, 
                             pegs = 1,
                             calc_mean = TRUE)

peg_15_scene = generate_peg_scene(pegs=15, color="grey10")
slot_15_scene = generate_slot_scene(pegs=15, color="grey10")
path_15peg_balls = circles_to_path(maxtime=3000, n=300, 
                             angle = 45, 
                             pegs = 15,
                             calc_mean = TRUE)

peg_30_scene = generate_peg_scene(pegs=30, color="grey10")
slot_30_scene = generate_slot_scene(pegs=30, color="grey10")
path_30peg_balls = circles_to_path(maxtime=3000, n=300, 
                             angle = 45, 
                             pegs = 30,
                             calc_mean = TRUE)

par(mfrow=c(1,3))
generate_studio(width = 1000, height = 1000,depth=-200) %>%
  add_object(funnelblack) %>%
  add_object(peg_1_scene) %>%
  add_object(slot_1_scene) %>% 
  add_object(path_1peg_balls) %>% 
  add_object(sphere(y=150,z=150,radius=50,material=light(intensity = 8))) %>%
  render_scene(lookfrom=c(-0,60,200),fov=47,lookat=c(0,30,00),samples=512,
               clamp_value = 10, sample_method = "stratified", width=400,height=600)

generate_studio(width = 1000, height = 1000,depth=-200) %>%
  add_object(funnelblack) %>%
  add_object(peg_15_scene) %>%
  add_object(slot_15_scene) %>% 
  add_object(path_15peg_balls) %>% 
  add_object(sphere(y=150,z=150,radius=50,material=light(intensity = 8))) %>%
  render_scene(lookfrom=c(-0,60,200),fov=47,lookat=c(0,30,00),samples=512,
               clamp_value = 10, sample_method = "stratified", width=400,height=600)

generate_studio(width = 1000, height = 1000,depth=-200) %>%
  add_object(funnelblack) %>%
  add_object(peg_30_scene) %>%
  add_object(slot_30_scene) %>% 
  add_object(path_30peg_balls) %>% 
  add_object(sphere(y=150,z=150,radius=50,material=light(intensity = 8))) %>%
  render_scene(lookfrom=c(-0,60,200),fov=47,lookat=c(0,30,00),samples=512,
               clamp_value = 10, sample_method = "stratified", width=400,height=600)

Figure 11: Growing the length of the peg board increases the bias we see at the buckets.

A single layer of angled pegs does not significantly bias the distribution, even though the angle I used (45 degrees) is supposed to result in the largest effect size. When we increase the depth of the board, the bias grows. The peg angle is actually an interaction effect: the effect size depends on both the board length and the angle. Varying just the board length does not bias the distribution, nor does just changing the peg angle by itself. The effect depends on a combination of the two factors.

We can see this explicitly if we fit a model. Let’s extract the ball coordinates for different inputs and fit a linear model to see what terms are significant. We’ll also shift the spout position left and right, which we know will shift the center of the distribution. 

par(mfrow=c(1,1))
board_factors = expand.grid(angles = c(-45,45), 
                            peg_depth = c(1,31),
                            spout = c(-2,2))

ball_coords_model = list()
for(i in 1:nrow(board_factors)) {
  ball_coords_model[[i]] = circles_to_path(maxtime=3000, n=300, 
                  spout_shift = board_factors$spout[i], 
                  angle = board_factors$angles[i], 
                  pegs = board_factors$peg_depth[i],return_ball_coords = TRUE) 
  ball_coords_model[[i]]$angle =  board_factors$angles[i]
  ball_coords_model[[i]]$peg_depth =  board_factors$peg_depth[i]
  ball_coords_model[[i]]$spout =  board_factors$spout[i]
}
all_peg_data = do.call(rbind,ball_coords_model)

fit = lm(data = all_peg_data, x ~ (angle + peg_depth + spout)^3)
summary(fit)
## Call:
## lm(formula = x ~ (angle + peg_depth + spout)^3, data = all_peg_data)
## 
## Residuals:
##      Min       1Q   Median       3Q      Max 
## -247.135   -6.622   -0.013    6.832   39.646 
## 
## Coefficients:
##                         Estimate Std. Error t value Pr(>|t|)    
## (Intercept)           -0.0118719  0.3349737  -0.035    0.972    
## angle                  0.0001362  0.0074439   0.018    0.985    
## peg_depth              0.0136698  0.0152735   0.895    0.371    
## spout                  1.0035564  0.1674868   5.992 2.39e-09 ***
## angle:peg_depth        0.0051148  0.0003394  15.070  < 2e-16 ***
## angle:spout            0.0014254  0.0037219   0.383    0.702    
## peg_depth:spout        0.0079628  0.0076367   1.043    0.297    
## angle:peg_depth:spout -0.0002158  0.0001697  -1.271    0.204    
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
## 
## Residual standard error: 11.22 on 2392 degrees of freedom
## Multiple R-squared:  0.1973, Adjusted R-squared:  0.195 
## F-statistic: 83.99 on 7 and 2392 DF,  p-value: < 2.2e-16

Now it’s official! When the full model is fit, neither the angle nor the depth are significant on their own, but the interaction between the two is significant. Our other significant term is the spout position, which is obvious: move the spout left or right and the resulting distribution will also shift in the same direction. The parameter estimates illustrate this: a one unit shift in spout position results in a 1.00 ± 0.16 unit shift in the distribution, which shows the center of the distribution exactly follows the shift in the spout.

The angle:peg_depth effect is more subtle: a 1 unit increase in depth increases the effect of changing the angle by 0.005 ± 0.0003 units. Interactions are a bit more tricky to interpret than main effects. You aren’t shifting the distribution directly; an interaction instead augments the size of the main effect. To see this more clearly, let’s look at our model (3 main effects + 1 interaction):

We can rearrange this to show how the interaction can be interpreted as changing the main effect term:

Equivalently, we could also say the interaction term is augmenting the term: these interpretations are mathematically equivalent:

All this to say: look, we’ve demonstrated a non-trivial linear regression with a Galton board! Way more interesting than the Central Limit Theorem.

Conclusion

I hope you enjoyed this deeper-than-usual dive into the mechanics of a customizable Galton board. When you have full control of how one is built, a Galton board can be a fruitful toy model to demonstrate different statistical concepts. Here are some other questions you might consider investigating on your own:

  • Is the distribution of balls truly normal? Is there a good way to test this?
  • What happens to the distribution when you decrease/increase the bucket size?
  • What happens to the distribution when you decrease/increase the number of balls?
  • What happens to the distribution when you make the spout gap wider/narrower?
  • Is there a way to change the board to generate other distributions?
  • Does changing the elasticity of the balls affect the variance of the resulting distribution?

Thanks to @coolbutuseless for creating the chipmunkcore/chipmunkbasic packages that made all this possible! If you’re interested in learning more about the package used to render these 3D visualizations, check out the package website:

Rayrender Website

One last question–how did you get the smiley face in the Galton board animation?

It’s deceptively simple: we run the simulation and find the final positions of the balls. Then we record the IDs of the balls that fall into the areas we want to color black. Then we reverse time (by resetting the random seed) and run the simulation over again, but this time color those balls black from the beginning. 

cm = Chipmunk$new(time_step = 0.005)

initialize_galton(cm)
cm$advance(3000)
cm$get_circles() -> balls

#Find ball IDs that end up in the mouth and eyes and save them
smile_balls = list()
for(i in 1:nrow(balls)) {
  if((balls$x[i] * balls$x[i]+60 >  balls$y[i]*10 &
      balls$x[i] * balls$x[i]+20 <  balls$y[i]*10 &
      balls$x[i] < 10 &  balls$x[i] > -10) |
     ((balls$x[i] - 5)*2)^2 +  (balls$y[i] - 20)^2 < 4^2 |
     ((balls$x[i] + 5)*2)^2 +  (balls$y[i] - 20)^2 < 4^2) {
    smile_balls[[i]] = balls$idx[i]
  } 
}

idvals = unlist(smile_balls)

#Re-run simulation and render animation
cm <- Chipmunk$new(time_step = 0.005)
initialize_galton(cm)

fovvec = seq(90,30,length.out = 600)
yvec = (unlist(tweenr::tween(c(50,20),n=600)))

for (j in 1:600) {
  cm$advance(5)
  cm$get_circles() -> balls

  #Color balls
  balllist = list()
  for(i in 1:nrow(balls)) {
    if(balls$idx[i] %in% idvals) {
      balllist[[i]] = sphere(x=balls$x[i],y=balls$y[i], material = glossy(color="black"))
    } else {
      balllist[[i]] = sphere(x=balls$x[i],y=balls$y[i], material = glossy(color="yellow"))
    }
  }
  balls = do.call(rbind,balllist)

  generate_studio(width = 1000, height = 1000,depth=-5) %>%
    add_object(funnelscene) %>%
    add_object(pegscene) %>%
    add_object(slotscene) %>%
    add_object(balls) %>%
    add_object(sphere(y=200,z=100,radius=20,material=light(intensity = 40))) %>%
    render_scene(lookfrom=c(30,100,100),fov=fovvec[j],lookat=c(0,yvec[j],0),samples=128,
                 clamp_value = 10,filename=glue::glue("galtonanim{j}"),
                 sample_method = "stratified", width=800,height=800)
}

av::av_encode_video(glue::glue("galtonanim{1:600}.png"), 
                    output = "galtonanim.mp4", framerate = 60)
]]> 3D Visualization Analysis R Rayrender Raytracing Statistics Regression https://www.tylermw.com/posts/data_analysis/plinko-statistics-insights-from-the-bean-machine.html Tue, 01 Sep 2020 04:34:54 GMT Loading and Visualizing OpenSky Network Flight Data in R (short) Tyler Morgan-Wall https://www.tylermw.com/posts/data_visualization/loading-and-visualizing-opensky-network-data-in-r.html

Tl;dr: I will show you how to query the OpenSky REST API directly from R, load and clean the data, and then finally visualize it in 3D using the rayrender package—entirely in R. The OpenSky Network is a non-profit association that crowdsources flight path data. Volunteers set up sensors to read ADS-B messages sent out by aircraft, which contain the aircraft’s position and velocity. The volunteers then upload this data to the OpenSky network, which anyone can query via a REST API (although you need a free account for most of the functionality). I recently implemented a new path primitive in rayrender (to visualize smooth curves and lines in 3D) and needed some real-life data to test it on—this seemed like a pretty good source. Because I went through all the work to clean and visualize it myself, I figured I would make the process easier for others by showing what I did. Let’s get started!

First, let’s load the packages we’ll need. tidyverse loaded as a catch-all for data munging, httr is used to query the REST API, jsonlite for parsing the JSON data returned by the API, glue for some easy string manipulation, spData for the world map polygon, and rayrender to visualize it in 3D. 

library(tidyverse) 
library(httr) 
library(jsonlite)
library(glue)
library(rayrender)
library(spData)

Here, you’ll need to put in your OpenSky username and password to access the API. You can sign up for a free account on opensky-network.org. 

username = "xxxxxx"
password = "xxxxxx"

Since OpenSky is a EU-based non-profit, the coverage is much better in Europe. We are going to visualize all the departures on a single day from Frankfurt Airport (EDDF) in Germany. This involves interacting with two services in the OpenSky REST API: one that gives us the departures from a specific airport, and one that will give us the flight tracks for those specific flights. We can only read up to 2 hours at a time for the departure API, so we will loop through every hour and collect the departing flights into a list. Then, we’ll pass those flights into the second endpoint to get the actual tracks.

We are going to be using the httr package to interact with the API. It’s pretty straightforward: a key-value pair is specified in a list to the query argument in httr::GET. We’ll pass the airport and the timespan (here, in Unix time) to get a list of departures. After that’s done, we’ll then loop through all those departures to extract the track information, growing a list of our results. 

tracklist = list()
counter_tracks = 1

#This is the string we'll use to access the departures API
path = glue("https://{username}:{password}@opensky-network.org/api/flights/departure?")

#This is the string we'll use to access the tracks API
trackpath = glue("https://{username}:{password}@opensky-network.org/api/tracks/all?")

for(j in 1:23) {
  begintime = as.numeric(as.POSIXct(sprintf("2020-08-10 %0.2d:01:00 EST",j-1)))
  endtime = as.numeric(as.POSIXct(sprintf("2020-08-10 %0.2d:01:00 EST",j)))
  
  #Get the flights departing within that hour
  request = GET(url = path, 
                query = list(
                   airport = "EDDF",
                   begin = begintime,
                   end = endtime))
  response = content(request, as = "text", encoding = "UTF-8")
  df = data.frame(fromJSON(response, flatten = TRUE))

  #Read the actual tracks
  for(i in 1:nrow(df)) {
    request_track = GET(url = trackpath, 
                        query = list(
                          icao24 = df$icao24[i],
                          time = begintime+1800)) #Offset to the middle of the hour
    
    response_track = content(request_track, as = "text", encoding = "UTF-8")
    if(response_track != "") {
      tracklist[[counter_tracks]] = data.frame(fromJSON(response_track, flatten = TRUE))
    }
    counter_tracks = counter_tracks + 1
  }
}

This should take a few minutes to run, but will give us our flight path trajectory data. Some entries will contain only a single row telling us there were no departing flights: let’s filter those out by pulling out only data.frames with more than one row. 

newtracklist = list()
for(i in 1:length(tracklist)) {
  if(!is.null(tracklist[[i]])) {
    if(nrow(tracklist[[i]]) > 1) {
      newtracklist[[i]] = tracklist[[i]]
    }
  }
}

Now, let’s combine all those tracks into a single data.frame and extract the ICAO24 codes for each aircraft. Each ICAO24 code is unique to each aircraft and thus is a good way to track a specific aircraft in the sky. 

fulltracks = do.call(rbind,newtracklist)
unique_codes = unique(fulltracks$icao24)

For fun, let’s load the world polygon data from the spData package and plot our tracks with ggplot2 (just so we have an idea of what the data looks like): 

worldmap = spData::world

ggplot() + 
  geom_sf(data=worldmap) +
  geom_path(data=fulltracks, aes(x=path.3,y=path.2, color=icao24)) + 
  theme(legend.position = "none")

Figure 1: Quick preview.

Cool! Now let’s render our flight track data in 3D using rayrender. We’ll turn the world polygon into an extruded 3D surface, add a glossy blue rectangle to represent the ocean, and then generate our path() objects and pass them into the scene. By setting u_min and u_max in the the path() function, we can draw only a portion of the full aircraft trajectory and animate it over time. 

worldpoly = extruded_polygon(worldmap,material=diffuse(color="darkgreen"))
len_u_min = seq(0,1,length.out = 361)[-1]
len_u_max = len_u_min + 0.03
len_u_max[len_u_max > 1] = 1

for(j in 1:360) {
  path_mat_list = list()
  for(i in 1:length(unique_codes)) {
    path_mat_list[[i]] = filter(fulltracks, icao24 == unique_codes[i]) %>% 
      select(path.2,path.3,path.4) %>% 
      mutate(z=path.2, y=path.4/5000, x=-path.3) %>% #Scale the altitude and flip the x-axis
      select(x,y,z)  %>% 
      as.matrix() %>% 
      path(material = diffuse(color="white"), width=0.025, type="cylinder", 
           u_max = len_u_max[j], u_min = len_u_min[j])
  }
    
  #Combine all the path objects into a single scene
  all_tracks_ray = dplyr::bind_rows(path_mat_list)
  
  xz_rect(y=0.7,xwidth=1000,zwidth=1000,material=glossy(color="#00144a")) %>% 
    add_object(worldpoly) %>% 
    add_object(group_objects(all_tracks_ray, group_translate = c(0,1,0))) %>%  
    render_scene(lookfrom=c(1000,700,-1000),lookat=c(-12,0,50.1),fov=1.4,
                 samples=64,sample_method = "stratified",
                 environment_light = "autumn_park_1k.hdr", #HDR image from hdrihaven.com
                 width = 1200, height=1200, aperture=20,
                 filename=glue::glue("flight_anim{j}"))
}

We can then combine all these images into a movie using the av package: 

av::av_encode_video(glue::glue("flight_anim{1:360}.png"), output = "flight_anim.mp4", framerate = 30)
Figure 2: Video from image frames.

Hope you liked this mini-tutorial! Follow me on Twitter and sign up for my listserv if you want to read more content like this.

]]> 3D Cartography GIS Data Analysis Maps OpenSky R Data Visualization Rayrender Pathtracing REST API https://www.tylermw.com/posts/data_visualization/loading-and-visualizing-opensky-network-data-in-r.html Wed, 19 Aug 2020 05:42:13 GMT Raybonsai: Generate Procedural 3D Trees in R Tyler Morgan-Wall https://www.tylermw.com/posts/rayverse/raybonsai-generate-procedural-3d-trees-in-r.html

One fun aspect of building a 3D renderer in R (and more generally, building anything in a programming language with a REPL) is the lack of friction between your code your results: rather than constructing a 3D scene by hand using a GUI, you can generate your scene directly from data or purely from logic. For traditional 3D rendering, this isn’t particularly useful, but for visualizing data and procedurally-generated systems, this close link allows for fast iteration and reproducibility.

Rayrender was built around this idea: instead of trying to integrate an external renderer into the R ecosystem (which is difficult for many reasons, primarily CRAN requirements), it made sense to build a 3D renderer designed specifically for R. There’s one big hurdle you encounter when writing your own software, however: in the beginning, there is no one but you who knows how to use it! “If you build it, they will come” is not a viable strategy for software. Regardless of how useful you think your package/application is, few people are going to take the time to learn it unless they’re presented with motivating examples. So, with that in mind, I’m always on the lookout for interesting and novel visualization ideas that will give people a better idea of what rayrender is capable of, and hopefully inspire them to experiment with the software.

What does all this have to do with 3D trees? Back in April, Danielle Navarro released an the flametree package, which produces procedural 2D trees using a stochastic L-system, and I thought: I think these would look really cool in 3D! So I dove into her code. It wasn’t too difficult to generalize it to 3D, write a layer that translated the resulting data structure into rayrender’s tibble-based scene format using rayrender primitives, and package it all up for easy installation. And that brings us to…

The raybonsai package! A package that creates and renders procedural 3D trees in R. Installation is easy: just use the remote package to install from Github: 

emotes::install_github("tylermorganwall/raybonsai")

There are currently only two user-facing functions in raybonsai: generate_tree() and render_tree(). generate_tree() generates a tree that follows a certain set of constraints that you set and returns a rayrender scene describing the tree. render_tree() automatically adds ground, sets up lighting, and sets up the camera so the tree is in frame, but is otherwise just a light wrapper around rayrender’s render_scene() function.

Let’s try it out, with the default settings: 

library(raybonsai)

generate_tree() %>% 
  render_tree()
Figure 1: Default tree.

A tree! Let’s customize it. The growth of the tree is controlled primarily using five inputs: the number of branches at each branching point branch_split, the horizontal branching angle branch_angle, the vertical branching angle branch_angle_vert, the scaled length of each subsequent branch branch_scale, and (most appropriately named, given the use case) the random seed seed. Let’s first start by generating a bunch of different plants, each with the same settings but different seeds. 

par(mfrow=c(3,3))
for(i in 1:9) {
  generate_tree(seed = i) %>% 
    render_tree()
}

Figure 2: Collection of different trees, varying the random seed.

Each tree is different, but they all appear to come from the same “species.” And that’s because they’re all generated using the same “DNA”: the branch angles and scaling factors. Let’s change that DNA by specifying a new set of rules. Here, we cut the potential angles the branches can make from -45 and 45 degrees in half: 

par(mfrow=c(3,3))
for(i in 1:9) {
  generate_tree(seed = i, branch_angle_vert = seq(-45,45,by=5)/2, leaf_color = "pink") %>% 
    render_tree()
}
Figure 3: Varying the vertical branching angle.

These are visually quite distinct from the previous batch and have a similar appearance to each other. But look closely and compare these trees with the first batch: you’ll see that they actually have the exact same branching structure, just with less pronounced branching angles (note the trees than lean left/right in the first batch still lean that way in the second). This is because the random choice whether to branch left or right is controlled by the random seed, which is identical between the two batches. The only variable that’s different is the branching angle itself.

What happens when we add an addition angle into the mix? Here, one directly in the center. Now, each branch can either go left, right, or continue in the same direction as the source branch. We can see this results in some trees developing “trunks” and some longer straight branches: 

par(mfrow=c(2,3))
for(i in 1:6) {
  generate_tree(seed = i, branch_angle_vert = c(-20,0, 20), leaf_color = "red") %>% 
    render_tree()
}
Figure 4: Adding the possibility of growing a branch in the same direction as the previous.

The next variable we can control is increase the branching depth of the tree. By default, we generate 6 branch layers. The number of branches grows exponentially with each layer, so we’ll just increase it to 8. This will increase the visual complexity of our tree. 

par(mfrow=c(2,3))
for(i in 1:6) {
  generate_tree(seed = i+1000, branch_depth = 8, leaf_color = "purple") %>% 
    render_tree()
}
Figure 5: Deeper trees.

By default, raybonsai only adds leaves to the last layer, but we can start growing them on earlier layers to fill in our tree: 

par(mfrow=c(1,2))

generate_tree(seed = 1234, branch_depth = 8, leaf_color = "orange") %>% 
  render_tree()

generate_tree(seed = 1234, branch_depth = 8, leaf_color = "orange", leaf_depth_start = 5) %>%
  render_tree()
Figure 6: Filling in our tree with additional leaves.

Up to this point, we’ve kept the trees symmetric by setting a matching negative angle for every positive angle. We can also make asymmetric trees by increasing the probability that we’ll select one angle over another. Here each branch has a 5x probability of turning one way versus the other, implemented by duplicating one angle 5x in the branching vector. 

par(mfrow=c(1,2))
generate_tree(seed = 2020, branch_angle_vert = c(-10, 10, 10, 10, 10, 10),
              branch_depth = 8, leaf_color = "magenta", leaf_depth_start = 5) %>% 
  render_tree()
generate_tree(seed = 2021, branch_angle_vert = c(10,-10,-10,-10,-10,-10),
              branch_depth = 8, leaf_color = "magenta", leaf_depth_start = 5) %>%
  render_tree()
Figure 7: Tree bending.

We can also create asymmetric trees by ensuring the average angle is negative or positive, without repeating individual angles. This works because on average, the tree favors one direction over the other. 

par(mfrow=c(1,2))
generate_tree(seed = 4321, branch_angle_vert = seq(-10,20,by=1),
              branch_depth = 8, leaf_color = "yellow", leaf_depth_start = 5) %>% 
  render_tree()

generate_tree(seed = 4321, branch_angle_vert = -seq(-10,20,by=1),
              branch_depth = 8, leaf_color = "yellow", leaf_depth_start = 5) %>% 
  render_tree()
Figure 8: More tree bending.

Another variable we can control is the scaling factor branch_scale, which defaults to c(0.8, 0.9) (meaning each branch is either 80% or 90% the length of the previous layer). If we decrease or increase this, the resulting tree will be dramatically different: 

par(mfrow=c(1,3))
generate_tree(seed = 10, branch_angle = c(-30,0, 30), branch_scale = c(0.6,0.7),
              branch_depth = 7, leaf_color = "green", leaf_depth_start = 5) %>% 
  render_tree()

generate_tree(seed = 11, branch_angle = c(-30,0, 30), branch_scale = c(0.9,1),
              branch_depth = 7, leaf_color = "green", leaf_depth_start = 5) %>% 
  render_tree()

generate_tree(seed = 12, branch_angle = c(-30,0, 30), branch_scale = c(1.1,1.2),
              branch_depth = 7, leaf_color = "green", leaf_depth_start = 5) %>% 
  render_tree()
Figure 9: Varying the branch width.

Each tree so far has been grown with the “midpoint” method: rather than growing each branch from the end of the previous branch, the default behavior extends the branch in the previous branches direction until it reaches the halfway point, and only then extends a branch to the endpoint. We can turn off this feature and by setting midpoint = FALSE: This results in a structurally identical tree with a slightly different appearance. And for fun, let’s also play around with the ground color and the branch color: 

par(mfrow=c(1,2))
generate_tree(seed = 20, branch_angle = c(-30,0, 30), branch_scale = c(0.9,1), midpoint = TRUE,
              branch_depth = 7, leaf_color = "chartreuse4", 
              leaf_depth_start = 5, branch_color = "tan") %>% 
  render_tree(ground_color1 = "darkgoldenrod4", ground_color2 = "chocolate4")

generate_tree(seed = 20, branch_angle = c(-30,0, 30), branch_scale = c(0.9,1), midpoint = FALSE,
              branch_depth = 7, leaf_color = "chartreuse4", 
              leaf_depth_start = 5, branch_color = "tan") %>% 
  render_tree(ground_color1 = "darkgoldenrod4", ground_color2 = "chocolate4")
Figure 10: Two different methods of growing branches. Left: midpoint. Right: not midpoint.

The lighting here is automatically set up by render_tree(), but we can turn it off and set up our own lighting using rayrender. We’ll also set branch_split = 3 here for a denser tree with more branches: 

library(rayrender)

par(mfrow=c(1,1))
generate_tree(seed = 222, branch_angle = c(-20, 20), branch_scale = c(0.8,0.9), branch_split = 3,
              branch_depth = 6 , leaf_color = "chartreuse4", 
              leaf_depth_start = 5, branch_color = "tan") %>% 
  add_object(sphere(x=5,y=1,radius=1,material=light(color="magenta",intensity = 30))) %>%
  add_object(sphere(x=-5,y=1,radius=1,material=light(color="dodgerblue",intensity = 30))) %>%
  raybonsai::render_tree(lights = FALSE, ground_color1 = "grey50",ground_color2 = "grey50", width=1200,height=800)
Figure 11: Adding custom lighting to our scene, using rayrender primitives.

We can also load an HDR image (here, obtained for free from hdrihaven.com) to light the scene with realistic lighting: 

generate_tree(seed = 222, branch_angle = c(-20,20), branch_scale = c(0.8,0.9), 
              branch_depth = 10 , leaf_color = "chartreuse4", 
              leaf_depth_start = 5, branch_color = "tan") %>% 
  raybonsai::render_tree(lights = FALSE, environment_light = "kiara_3_morning_2k.hdr", width=1200, height=800)
Figure 12: HDR image lighting (courtesy of hdrihaven.com).

We can even add multiple trees by using rayrender’s group_objects() function to rotate them around the ground (here a sphere centered at y = -10). 

tree1 = generate_tree(seed = 1111, branch_angle_vert = c(-45,0,45), 
              branch_depth = 8 , leaf_color = "green", leaf_depth_start = 5)
tree2 = generate_tree(seed = 2222, branch_angle_vert = seq(-30,30,by=5),
              branch_depth = 8 , leaf_color = "red", leaf_depth_start = 5)
tree3 = generate_tree(seed = 3333, branch_angle_vert = seq(-30,30,by=5),
              branch_depth = 8 , leaf_color = "purple", leaf_depth_start = 5)
tree4 = generate_tree(seed = 4444, branch_angle_vert = c(-45,0,45),
              branch_depth = 8 , leaf_color = "orange", leaf_depth_start = 5)

group_objects(tree1,pivot_point = c(0,-10,0), group_angle = c(0,0,10)) %>% 
  add_object(group_objects(tree2,pivot_point = c(0,-10,0), group_angle = c(0,0,30))) %>% 
  add_object(group_objects(tree3,pivot_point = c(0,-10,0), group_angle = c(0,0,-10))) %>% 
  add_object(group_objects(tree4,pivot_point = c(0,-10,0), group_angle = c(0,0,-30))) %>% 
  raybonsai::render_tree(lights = FALSE, environment_light = "noon_grass_2k.hdr", 
                         samples=40,
              aperture=0.5, fov=24, lookfrom=c(0,8,30), width=1200, height=800,
              ground_color1 = "darkgreen", ground_color2 = "darkgreen")
Figure 13: Multiple trees on a little planet.

render_tree() allows us to manually change the camera position and direction to focus on certain regions of interest by passing lookat and lookfrom arguments: 

group_objects(tree1,pivot_point = c(0,-10,0), group_angle = c(0,0,10)) %>% 
  add_object(group_objects(tree2,pivot_point = c(0,-10,0), group_angle = c(0,0,30))) %>% 
  add_object(group_objects(tree3,pivot_point = c(0,-10,0), group_angle = c(0,0,-10))) %>% 
  add_object(group_objects(tree4,pivot_point = c(0,-10,0), group_angle = c(0,0,-30))) %>% 
  render_tree(lights = FALSE, environment_light = "noon_grass_2k.hdr", 
              fov=8, lookat=c(-2,3,0),lookfrom=c(20,2,30),
              aperture=1, width=1200, height=800,
              ground_color1 = "darkgreen", ground_color2 = "darkgreen")
Figure 14: Zooming in and moving the camera.

We can also bypass render_tree(), ignore the ground entirely, and just treat the tree like any other rayrender object, placing it anywhere in a scene of our own creation (here we create a nice little bucolic scene in a Cornell box, and render it using rayrender::render_scene()): 

tree_pig = generate_tree(seed=121, x=555/2,z=555/2, branch_depth = 9, leaf_color = "chartreuse4",
                         scale = 80, branch_angle_vert = c(-20,0,20), leaf_depth_start = 5)

generate_cornell(lightwidth = 150, lightdepth = 150, lightintensity = 30) %>%
  add_object(tree_pig) %>%
  add_object(group_objects(
    disk(radius=70, inner_radius = 40, z=10, angle = c(90,0,0),
         material = diffuse(color="grey20"),flipped = TRUE) %>%
    add_object(disk(radius=70, inner_radius = 40, z=-10, angle = c(90,0,0),
                    material = diffuse(color="grey20"))) %>%
    add_object(cylinder(radius=70, length=20, angle = c(90,0,0),
                        material = diffuse(color="grey20"))) %>%
    add_object(cylinder(radius=40, length=20, angle = c(90,0,0),
                        material = diffuse(color="grey20"))),
    group_angle = c(0,30,0), group_translate = c(400,110,555/2))) %>%
  add_object(segment(start = c(400,150,555/2), end =  c(400,310,555/2), radius=3)) %>%
  add_object(ellipsoid(x=400, y=165,z=555/2,a=5,b=20,c=20,angle=c(0,50,0))) %>%
  add_object(ellipsoid(x=405, y=165,z=555/2,a=5,b=20,c=20,angle=c(0,50,0))) %>%
  add_object(ellipsoid(x=399, y=165,z=555/2,a=5,b=20,c=20,angle=c(0,50,0))) %>%
  add_object(pig(x=150,z=300,y=85,angle=c(0,50,0),scale = 50, emotion = "skeptical")) %>%
  add_object(ellipsoid(x=555/2,z=555/2,a=200,b=20,c=200,material=diffuse(color="tan"))) %>%
  render_scene(width=1200, height=1200, clamp_value=10, samples=400, sample_method = "stratified")
## Setting default values for Cornell box: lookfrom `c(278,278,-800)` lookat `c(278,278,0)` fov `40` .
Figure 15: A tire swing in a Cornell box.

And finally, we can create animations like the one featured at the top by varying the inputs and saving each frame to an image. After all the frames have been rendered, we combine with the {av} package (R ffmpeg wrapper) into a movie: 

t_steps = seq(0,360,length.out = 61)[-61]
branch_angle1 = 15 * sinpi(t_steps/180)
branch_angle2 = 10 * sinpi(t_steps/180+30/180)
branch_angle3 = 10 * sinpi(t_steps/180+60/180)


for(i in seq(1,60,by=1)) {
  generate_tree(seed = 2222, branch_angle_vert = c(-20,20) + branch_angle2[i]/2,
                branch_angle = seq(-45,45,by=5),
                branch_depth = 8, leaf_color = "chartreuse4",
                leaf_depth_start = 5, branch_color = "tan") %>%
    add_object(group_objects(generate_tree(seed = 3333, 
                             branch_angle_vert = c(-15,15) + branch_angle1[i]/2,
                             branch_depth = 8 , leaf_color = "dodgerblue4",
                             leaf_depth_start = 5, branch_color = "tan"), 
               pivot_point = c(0,-10,0),group_angle=c(0,0,-15))) %>%
    add_object(group_objects(generate_tree(seed = 4444, 
                             branch_angle_vert = c(-10,10) + branch_angle3[i]/2,
                             branch_depth = 8, leaf_color = "magenta",
                             leaf_depth_start = 5, branch_color = "tan"), 
               pivot_point = c(0,-10,0),group_angle=c(0,0,15))) %>%
    raybonsai::render_tree(lights = FALSE, environment_light = "symmetrical_garden_2k.hdr",
                           width=1200, height=800, aperture=0.5,
                           filename = glue::glue("wave{i}"),
                           fov=25,lookfrom=c(0,5,20), lookat=c(0,2,0), 
                           rotate_env=-90, sample_method="stratified")
}

av::av_encode_video(glue::glue("wave{1:60}.png"), output = "treewave.mp4", framerate = 30)
Figure 16: I am Groot (in R).

Now go forth and digitally garden! Check out the package site/Github for more information

Site: www.raybonsai.com

Github: Github Repo

And if you make something cool, feel free to share it on Twitter with the hashtags #rstats and #rayrender so people can see what you’ve planted.

]]> Raybonsai Fun Generative Art Pathtracing 3D Fractals https://www.tylermw.com/posts/rayverse/raybonsai-generate-procedural-3d-trees-in-r.html Sun, 26 Jul 2020 18:37:52 GMT A Step-by-Step Guide to Making 3D Maps with Satellite Imagery in R Tyler Morgan-Wall https://www.tylermw.com/posts/data_visualization/a-step-by-step-guide-to-making-3d-maps-with-satellite-imagery-in-r.html

Ever since I released rayshader to the public, there’s been one question that comes up time and time again: “How do I use rayshader to overlay satellite imagery onto a 3D surface?” And I can see why: 3D maps with real satellite images are super cool, and there are few detailed tutorials out there on how it’s done in R. Additionally, the process behind making this type of map can be intimidating for non-GIS experts, as it exposes you to all complexities of the GIS field: combining different datasets from separate sources—often each with their own distinct coordinate systems—into a single map. Not only that, but you have to also know where and how to get this data—not obvious to someone who doesn’t do this regularly. So I’m going to walk you through how to obtain the data required to make these types of maps, as well as the R code used to generate them. In my opinion, the hardest part is all the manual work in downloading the data! Once that’s done, the code required is short and straightforward, and rayshader makes visualizing elevation data in 3D a breeze. Let’s get started!

First, we’ll download elevation data. A good place to start for reasonable resolution elevation data is the Shuttle Radar Topography Mission (SRTM) dataset. It’s a global 30 meter resolution dataset (meaning, 30m between each point), and although there are more precise and higher resolution datasets out there, few have the global coverage of the SRTM–and it’s dead easy to get the data. Specifically, there’s simple tile selectors out there to download the data by just clicking on a map, which is a far easier process than many other online data repositories.

We are going to be visualizing Zion National Park, UT, which has beautiful, dramatic topography. I took a trip with my Dad out to Zion after I finished my PhD, and the gorgeous landscape made up of deep valleys and sheer cliffs makes for an excellent 3D visualization. Let’s start by grabbing elevation data from Derek Watkin’s SRTM tile downloader. We’ll zoom into tiles N37W113.hgt and N37W114.hgt, since the park overlaps both of them. To download: click the tiles, click download, and unzip the files (they should have the file type “hgt”).

Hi dad!

Figure 1: SRTM tile selector, grabbing tiles containing Zion National Park

Now, we need to get satellite imagery data. This is a bit more involved. There are plenty of sources for this type of data, both paid and freely available. We are going to be taking data from the Landsat 8 project, which does require registering a free USGS account, but then we get access to up-to-date high-quality satellite imagery, for free. So let me walk you through the the step-by-step process to obtain this data.

We are going to go to the USGS Earth Explorer. Once you register an account, you can download datasets. It takes a few minutes to receive your confirmation email, but it comes. Once you get your confirmation email, you can dive right in.

Figure 2: USGS Earth Explorer interface

Here’s the interface, with Utah in the viewer. We’re going to zoom in closer to the bottom left corner, which is the location of Zion National Park. Let’s do that:

Figure 3: Zooming into Utah and clicking the “Use Map” button to mark the current view as the search area. The website will search for data sets that include the specified area.

Now that we’re zoomed into the region we want, we’re going to hit the “Use Map” button to mark the current map view as the bounding box for the area we want to search for. We’ll then click “Data Sets” in the bottom left corner. This will query the database and return datasets that include the region we have selected. We specifically want Landsat 8 data, so we’ll select the following:

Figure 4: Select this option to get the Landsat 8 data we want.

Now, we’ll click “Results”, giving us a list of data products we can select from. If you click the little image icon (second to the left), it will show you a preview of the data in the window to the right. Bluish areas indicate cloud cover, so we’ll flip through the search results until we get a date with a clear shot of the terrain. The first one I find is “LC08_L1TP_038034_20191101_20191114_01_T1”, taken on November 1st, 2019 (or, about 500 years ago in corona-time). Let’s download the full resolution Level 1 GeoTIFF data product (it’s big, almost a gigabyte) and unzip it.

Figure 5: The full dataset is big, but you can delete most of it after you unzip it: we just need three channels.

And now–we write our script to turn this into a 3D model! Getting the data was the hardest part. That is, unless you can’t install the following packages–if that’s the case, godspeed, it’s a rite of passage to have to fight with your local GDAL install.

First, let’s load the packages we need. We’ll need rayshader (of course) for 3D plotting, raster for loading and manipulating the data, scale to rescale the color channels to adjust image contrast, and sp to transform some point coordinates between coordinate systems. FYI, I’m using the namespace operator :: throughout the code just to be clear what packages I’m calling from, but you don’t need to do that after you’ve loaded the package with library(). 

# install.packages(c("rayshader", "raster", "sp"))
library(rayshader)
library(sp)
library(raster)
library(scales)

Let’s load our data. We’ll start with loading the elevation dataset, since it’s an easier process. We’ll use the raster::raster() function to load our SRTM hgt files. This gives us two raster objects. We then combine the two with the raster::merge() function. Since they’re coming from the same data source, we don’t have to worry about transforming coordinate systems to match–they should just merge together seamlessly. We’ll plot the elevation using rayshader::height_shade() so you can see what it looks like: 

elevation1 = raster::raster("LC08_L1TP_038034_20191117_20191202_01_T1/N37W113.hgt")
elevation2 = raster::raster("~/Desktop/LC08_L1TP_038034_20191117_20191202_01_T1/N37W114.hgt")

zion_elevation = raster::merge(elevation1,elevation2)

height_shade(raster_to_matrix(zion_elevation)) %>%
  plot_map()

Figure 6: Output of the height_shade() function. Zion National Park is in the center.

Great! Now, let’s load our georeferenced satellite imagery. The red, blue, and green bands on Landsat 8 data are bands B4, B3, and B2, respectively. You can delete the rest of the bands if you want to free 600 megabytes of space on your hard drive. Let’s then plot it with raster::plotRGB(). 

zion_r = raster::raster("LC08_L1TP_038034_20191117_20191202_01_T1_B4.TIF")
zion_g = raster::raster("LC08_L1TP_038034_20191117_20191202_01_T1_B3.TIF")
zion_b = raster::raster("LC08_L1TP_038034_20191117_20191202_01_T1_B2.TIF")

zion_rbg = raster::stack(zion_r, zion_g, zion_b)
raster::plotRGB(zion_rbg, scale=255^2)

Figure 7: Raw satellite data–needs further processing.

Why is it so dark? We need to apply a gamma correction to the the imagery, which corrects raw linear intensity data for our non-linear perception of darkness. We do that simply by taking the square root of the data (we can also remove the scale argument). 

zion_rbg_corrected = sqrt(raster::stack(zion_r, zion_g, zion_b))
raster::plotRGB(zion_rbg_corrected)

Figure 8: Gamma-corrected satellite data.

Great! The contrast is muted, but we’ll fix that later. Now, let’s combine the two datasets. Here we encounter our first GIS difficulty: the coordinate reference systems of our elevation data and imagery data don’t match! Oh no. 

raster::crs(zion_r)
## CRS arguments:
##  +proj=utm +zone=12 +datum=WGS84 +units=m +no_defs +ellps=WGS84
## +towgs84=0,0,0
raster::crs(zion_elevation)
## CRS arguments:
##  +proj=longlat +datum=WGS84 +no_defs +ellps=WGS84 +towgs84=0,0,0

Our imagery data is given in UTM coordinates, while our elevation is in long/lat. Thankfully, it’s fairly straightforward to transform the elevation data from long/lat to UTM with the raster::projectRaster() function. We use the “bilinear” method for interpolation since elevation is a continuous variable. 

crs(zion_r)
## CRS arguments:
##  +proj=utm +zone=12 +datum=WGS84 +units=m +no_defs +ellps=WGS84
## +towgs84=0,0,0
zion_elevation_utm = raster::projectRaster(zion_elevation, crs = crs(zion_r), method = "bilinear")
crs(zion_elevation_utm)
## CRS arguments:
##  +proj=utm +zone=12 +datum=WGS84 +units=m +no_defs +ellps=WGS84
## +towgs84=0,0,0

Now, let’s crop the region down to the park itself. To figure out what long/lat values enclosed our area, I went to Google Maps and double clicked on the map to extract the bottom left and top right corners of the bounding box for the final map. We’ll use the sp package to transform these long/lat coords into UTM coordinates. 

bottom_left = c(y=-113.155277, x=37.116253)
top_right   = c(y=-112.832502, x=37.414948)

extent_latlong = sp::SpatialPoints(rbind(bottom_left, top_right), proj4string=sp::CRS("+proj=longlat +ellps=WGS84 +datum=WGS84"))
extent_utm = sp::spTransform(extent_latlong, raster::crs(zion_elevation_utm))

e = raster::extent(extent_utm)
e
## class      : Extent 
## xmin       : 308511.9 
## xmax       : 337834.2 
## ymin       : 4109943 
## ymax       : 4142481

Now we’ll crop our datasets to the same region, and create an 3-layer RGB array of the image intensities. This is what rayshader needs as input to drape over the elevation values. We also need to transpose the array, since rasters and arrays are oriented differently in R, because of course they are🙄. We do that with the aperm() function, which performs a multi-dimensional transpose. We’ll also convert our elevation data to a base R matrix, which is what rayshader expects for elevation data. 

zion_rgb_cropped = raster::crop(zion_rbg_corrected, e)
elevation_cropped = raster::crop(zion_elevation_utm, e)

names(zion_rgb_cropped) = c("r","g","b")

zion_r_cropped = rayshader::raster_to_matrix(zion_rgb_cropped$r)
zion_g_cropped = rayshader::raster_to_matrix(zion_rgb_cropped$g)
zion_b_cropped = rayshader::raster_to_matrix(zion_rgb_cropped$b)

zionel_matrix = rayshader::raster_to_matrix(elevation_cropped)

zion_rgb_array = array(0,dim=c(nrow(zion_r_cropped),ncol(zion_r_cropped),3))

zion_rgb_array[,,1] = zion_r_cropped/255 #Red layer
zion_rgb_array[,,2] = zion_g_cropped/255 #Blue layer
zion_rgb_array[,,3] = zion_b_cropped/255 #Green layer

zion_rgb_array = aperm(zion_rgb_array, c(2,1,3))

plot_map(zion_rgb_array)

Figure 7: Raw satellite data–needs further processing.

We will also now scale our data to improve the contrast and make the image more vibrant. I’m going to use the scales package to rescale the image to use the full range of color. 

zion_rgb_contrast = scales::rescale(zion_rgb_array,to=c(0,1))

plot_map(zion_rgb_contrast)

Figure 8: Fully processed satellite imagery of Zion National Park, Utah.

Excellent. Now we just input this image into plot_3d() along with our elevation data. For a realistic landscape, we should set zscale = 30 (since the elevation data was taken at 30 meter increments), but we’re going to set zscale = 15 to give the landscape 2x exaggeration. If you’re following along, you should now have an rgl window open with a 3D model you can rotate around. 

plot_3d(zion_rgb_contrast, zionel_matrix, windowsize = c(1100,900), zscale = 15, shadowdepth = -50,
        zoom=0.5, phi=45,theta=-45,fov=70, background = "#F2E1D0", shadowcolor = "#523E2B")
render_snapshot(title_text = "Zion National Park, Utah | Imagery: Landsat 8 | DEM: 30m SRTM",
                title_bar_color = "#1f5214", title_color = "white", title_bar_alpha = 1)

Figure 9: Snapshot of the 3D map.

The static snapshot above is nice, but 3D is best seen in motion, so let’s create a movie of us rotating around the scene. We’ll move the camera with render_camera(), and generate 1440 frames with render_snapshot(). At 60 frames per second, this will generate a 24 second video. You can do this via the av package, but I’m going to call ffmpeg directly via a system() call, since the output of av doesn’t seem to play nicely with embeddable web videos (for some reason). 

angles= seq(0,360,length.out = 1441)[-1]
for(i in 1:1440) {
  render_camera(theta=-45+angles[i])
  render_snapshot(filename = sprintf("zionpark%i.png", i), 
                  title_text = "Zion National Park, Utah | Imagery: Landsat 8 | DEM: 30m SRTM",
                  title_bar_color = "#1f5214", title_color = "white", title_bar_alpha = 1)
}
rgl::rgl.close()

#av::av_encode_video(sprintf("zionpark%d.png",seq(1,1440,by=1)), framerate = 30,
                    # output = "zionpark.mp4")

rgl::rgl.close()
system("ffmpeg -framerate 60 -i zionpark%d.png -pix_fmt yuv420p zionpark.mp4")
Figure 10: Rotating around our 3D scene

And we’re done! What to do now? Well, this satellite imagery and elevation data is relatively low resolution–you could now search for higher resolution imagery and elevation data to produce a more detailed figure. The general process is the same for any data source: find the data, transform the data into a common coordinate system, crop the data to the desired region, and then combine the data in plot_3d(). You could also try using the ender_highquality() function in rayshader to make beautiful, pathtraced maps (like in the featured animation at the top of the page). Or you could learn more about using rayshader (include transforming LIDAR point data to extremely hi-res elevation data) in my masterclass: the materials are free and open source. And this blog post is by no means the authoritative source on how to do this: there are lots of packages and free books on remote sensing and GIS. Have fun!

And whatever you end up doing, if you create something cool be sure to tweet it with the hashtags #rstats and #rayshader! We’d all love to see what you’ve created.

]]> 3D Cartography GIS Data Analysis Data Visualization Maps R Rayshader https://www.tylermw.com/posts/data_visualization/a-step-by-step-guide-to-making-3d-maps-with-satellite-imagery-in-r.html Tue, 28 Apr 2020 04:42:17 GMT Pathtracing Neon Landscapes in R Tyler Morgan-Wall https://www.tylermw.com/posts/fun/pathtracing-neon-landscapes-in-r.html

I’ve been having fun the last few months adhering to a relatively rapid open-source development schedule (as much as you can call a one-man project driven by a Mac Stickies window a “schedule”) with constant releases of rayrender, rayshader, and now rayimage. And in that time, I’ve managed to push lots of cool features, like true pathtracing of terrain in rayshader and realistic layered dielectrics in rayrender. And, as the author of the packages, it’s easy for me to sit down and immediately start creating with them. But there’s one downside of that singular focus on development: a complete lack of tutorials for other people on how to use the software. And, as the point of a package is to share code with other people, this is a problem.

Don’t get me wrong—I make sure to update the documentation and add examples to the package, and I have pkgdown websites that turn those examples into easily referenceable HTML. But documentation examples are bound by simplicity: you need remove all the delightful complexity of real world examples so you can show off the building blocks of the API. Not great for flexing to show off what your package can do. So this is the first in a series of blog posts where I do just that: show (with all the code) how to use these packages to craft something awesome!

So let’s get started! One feature I added to rayrender last year was a new object: line segments. Line segments are thick 3D cylinders, specified with a start point, end point, and radius. That parameterization is super-useful, as lots of data are specified in terms of line segments: e.g. polygon edges, time series, contours lines. Contour lines in particular are well-suited for a 3D representation, because they’re actually representing 3D data: lines of constant elevation on an underlying 3D surface. So when I saw this tweet, I saw an opportunity to use them:

Let’s recreate a neon wireframe scene similar to this, but entirely in R! Not with rayshader though (it’s meant to work with raster data), but with rayrender. We’ll need a couple things to make this work:

  1. An underlying landscape to transform into retro VR neon lines.
  2. Code to generate line segments representing the contour lines for said surface.
  3. Software to construct the 3D scene and render it.

We’ll use the built-in R dataset volcano for the landscape, Claus Wilke’s isoband package to generate the contours, and rayrender to build the scene and render it entirely in R.

First, let’s start by building the contour lines. We’ll first start by plotting the 3D map with rayshader and creating a 3D video, so you know what the surface looks like: 

library(rayshader)
volcano %>%
  sphere_shade() %>%
  add_shadow(ray_shade(volcano,zscale=3),0.3) %>%
  plot_3d(volcano, zscale=3, fov=30)
render_movie("basic_video.mp4", title_text = "Basic rayshader plot",
             title_bar_color = "red", title_bar_alpha = 0.3)
rgl::rgl.close()

Let’s create a contour plot of this data, using isoband::isolines(). We’ll then plot the data using ggplot2 + sf. 

library(ggplot2)

volcano_contours = isoband::isolines(x = 1:ncol(volcano), 
                                     y = 1:nrow(volcano), 
                                     z = volcano, 
                                     levels=seq(120,190,by=10))

contours = isoband::iso_to_sfg(volcano_contours)
sf_contours = sf::st_sf(level = names(contours), geometry = sf::st_sfc(contours))

ggplot(sf_contours) + geom_sf(aes(color = level))

Cool! Let’s pull each line out of the original volcano_contour object. Each contour level consists of x and y coordinates labeling the path , and an ID coordinate that separates different paths on the same altitude (the path doesn’t have to be continuous–the ID specifies each contiguous “chunk” at a certain level). The name of the level is the altitude.

We’ll loop through each altitude layer, extract the x and y-coordinates for the path of the lines, and then add the resulting line segments to a list collecting all the elements of the scene. The volcano dataset starts at 94m, so we’ll subtract off some elevation to get it closer to the ground, compress it by a factor of 5 so it fits in our screen, and add an x/z offset to center the model. Since each element is a row in a data.frame, we’ll bind all the rows together in the list to get the resulting scene to pass to rayrender. 

library(rayrender)

scenelist = list() 
counter = 1

for(i in 1:length(volcano_contours)) {
  heightval = as.numeric(names(volcano_contours)[i])
  uniquevals = table(volcano_contours[[i]]$id)
  for(k in 1:length(uniquevals)) {
    tempvals = volcano_contours[[i]]
    tempvals$x = tempvals$x[tempvals$id == k]
    tempvals$y = tempvals$y[tempvals$id == k]
    for(j in 1:(length(tempvals$x)-1)) {
      scenelist[[counter]] = segment(start = c(tempvals$x[j]-30,
                                               (heightval-80)/5-3,
                                               tempvals$y[j]-44), 
                                     end   = c(tempvals$x[j+1]-30,
                                               (heightval-80)/5-3,
                                               tempvals$y[j+1]-44), 
                                     radius = 0.3,
                                     material = diffuse(color=heat.colors(9)[i]))
      counter = counter + 1
    }
  }
}

fullscene = do.call(rbind, scenelist)

generate_ground(material = diffuse(color="grey20")) %>%
  add_object(fullscene) %>%
  render_scene(lookfrom = c(0,80,150), lookat = c(0,-1,-10), samples = 200, 
               aperture = 0, fov = 25, width = 800, height = 800)

Since the lines don’t have end caps, we can see small breaks between each segment in a layer. We will add spheres with the same radius as our lines at each start point to cover up these breaks. We’ll also change the surface to a dark metallic rough mirror (roughness specified by the non-zero fuzz argument in metal()), and change the line material to a glowing light with the light() material. Adding a light will also automatically turn off the ambient lighting in the scene, so the only light source will be the glowing contour lines. 

scenelist = list() 
counter = 1

for(i in 1:length(volcano_contours)) {
  heightval = as.numeric(names(volcano_contours)[i])
  uniquevals = table(volcano_contours[[i]]$id)
  for(k in 1:length(uniquevals)) {
    tempvals = volcano_contours[[i]]
    tempvals$x = tempvals$x[tempvals$id == k]
    tempvals$y = tempvals$y[tempvals$id == k]
    for(j in 1:(length(tempvals$x)-1)) {
      scenelist[[counter]] = segment(start = c(tempvals$x[j]-30,
                                               (heightval-80)/5-3,
                                               tempvals$y[j]-44), 
                                     end   = c(tempvals$x[j+1]-30,
                                               (heightval-80)/5-3,
                                               tempvals$y[j+1]-44), 
                                     radius = 0.3,
                                     material = light(intensity = 3,
                                                      color=heat.colors(9)[i]))
      counter = counter + 1
      
      #Add a sphere at each corner
      scenelist[[counter]] = sphere(x = tempvals$x[j]-30,
                                    y = (heightval-80)/5-3,
                                    z = tempvals$y[j]-44, 
                                    radius = 0.3,
                                    material = light(intensity = 3,
                                                     color=heat.colors(9)[i]))
      counter = counter + 1
    }
  }
}

fullscene2 = do.call(rbind, scenelist)

generate_ground(material = metal(color="grey20", fuzz=0.05)) %>%
  add_object(fullscene2) %>%
  render_scene(lookfrom = c(0,80,150), lookat = c(0,-1,-10), samples = 200, 
               aperture = 0, fov=25, tonemap = "reinhold", 
               width = 800, height = 800)

The only problem is the lines, while lit, aren’t glowing like neon. A very slight bloom effect is added by default in render_scene() to anti-alias lights (which is difficult to do in pathtracing, especially when tone mapping), but we can ramp up that effect to get a intense glowing aura surrounding our lines. Let’s set bloom = 5 in render_scene() to improve this effect. 

generate_ground(material = metal(color="grey20", fuzz=0.05)) %>%
  add_object(fullscene2) %>%
  render_scene(lookfrom = c(0,80,150), lookat=c(0,-1,-10), samples = 200, 
               aperture = 0, fov = 25, bloom = 5, tonemap = "reinhold", 
               width = 800, height = 800)

Nice. Now, in the style of the original image by @mjmurdoc, let’s add a green circular grid in the background. We’ll first start by generating the vertical bars in 10 degree increments subtending an arc of a circle, and then add the circular horizontal stripes by rendering a truncated cylinder in the same arc. We’ll have to render the cylinder twice, slightly offset and normals flipped, because light in rayrender is only emitted from the “outward” face of objects, and we’re going to see both sides when we orbit around the scene. I’m also going to add a glowing purple circle below everything (by adding a flat disk with a large inner radius). 

green_light = light(color="green", intensity = 3)

grid = list()
counter = 1
for(i in seq(110,250,by=10)) {
  grid[[counter]] = segment(start=c(sinpi(i/180)*40,
                                    -0.5,
                                    cospi(i/180)*40-20), 
                            end = c(sinpi(i/180)*40,
                                    18.5,
                                    cospi(i/180)*40-20),
                            radius=0.25,
                            material = green_light)
  counter = counter + 1
}

green_grid_vertical = do.call(rbind, grid)

generate_ground(material = metal(color="grey20",fuzz=0.05)) %>%
  add_object(green_grid_vertical) %>%
  add_object(fullscene2) %>%
  render_scene(lookfrom = c(0,80,150),lookat = c(0,-1,-10), samples = 40, 
               aperture = 0, fov = 25, bloom = 5, tonemap="reinhold", 
               width=800,height=800)

#Generate the horizontal grid stripes
cylinder(radius=40, z=-20,material = green_light, 
         phi_min = 200, phi_max = 340, flipped = FALSE) %>%
  add_object(cylinder(radius=40, y=6,z=-20,material = green_light, 
                      phi_min = 200, phi_max = 340, flipped = FALSE)) %>%
  add_object(cylinder(radius=40, y=12,z=-20,material = green_light, 
                      phi_min = 200, phi_max = 340, flipped = FALSE)) %>%
  add_object(cylinder(radius=40, y=18,z=-20,material = green_light, 
                      phi_min = 200, phi_max = 340, flipped = FALSE)) %>%
  add_object(cylinder(radius=40, z=-20.01,material = green_light, 
                      phi_min = 200, phi_max = 340)) %>%
  add_object(cylinder(radius=40, y=6,z=-20.01,material = green_light, 
                      phi_min = 200, phi_max = 340)) %>%
  add_object(cylinder(radius=40, y=12,z=-20.01,material = green_light, 
                      phi_min = 200, phi_max = 340)) %>%
  add_object(cylinder(radius=40, y=18,z=-20.01,material = green_light, 
                      phi_min = 200, phi_max = 340)) ->
green_grid_horizontal

#Purple base disk
base_disk = disk(inner_radius = 60, radius=61, z=-10,
                 material = light(intensity = 3, color="purple")) %>%
  add_object(disk(inner_radius = 60, radius=61, y=-0.1, z=-10,
                  material = light(intensity = 3, color="purple"), flipped=TRUE))

generate_ground(material = metal(color="grey20",fuzz=0.05)) %>%
  add_object(green_grid_vertical) %>%
  add_object(green_grid_horizontal) %>%
  add_object(base_disk) %>%
  add_object(fullscene2) %>%
  render_scene(lookfrom = c(0,80,150), lookat=c(0,-1,-10), samples = 200, 
               aperture = 0, fov = 25, bloom = 5, tonemap = "reinhold", 
               width = 800, height = 800)

Now let’s orbit around the scene! We’ll rotate the camera lookfrom position in a circle around the volcano and save each image to a frame, and then combine them all into a video. We’ll also double the distance and change the field of view (fov) slightly, so the entire scene stays in frame as we circle around it. And let’s duplicate and animate the base disk in a sine wave with slight offsets, for a fun effect (and to show off the group_objects() function in rayrender). 

xpos = 300 * sinpi(1:360/180)
zpos = 300 * cospi(1:360/180)

disk_height  = 6+6*sinpi(1:360/180*2)
disk_height2 = 6+6*sinpi(1:360/180*2+15/180)
disk_height3 = 6+6*sinpi(1:360/180*2-15/180)
disk_height4 = 6+6*sinpi(1:360/180*2+30/180)
disk_height5 = 6+6*sinpi(1:360/180*2-30/180)


for(i in seq(1,360,by=1)) {
  generate_ground(material = metal(color="grey20",fuzz=0.05)) %>%
    add_object(green_grid_vertical) %>%
    add_object(green_grid_horizontal) %>%
    add_object(group_objects(base_disk, group_translate = c(0,disk_height[i],0))) %>%
    add_object(group_objects(base_disk, group_translate = c(0,disk_height2[i],0))) %>%
    add_object(group_objects(base_disk, group_translate = c(0,disk_height3[i],0))) %>%
    add_object(group_objects(base_disk, group_translate = c(0,disk_height4[i],0))) %>%
    add_object(group_objects(base_disk, group_translate = c(0,disk_height5[i],0))) %>%
    add_object(fullscene2) %>%
    render_scene(lookfrom = c(xpos[i],160,zpos[i]-10),lookat = c(0,-1,-10), samples = 200, 
                 aperture = 0, fov = 22, bloom = 5, tonemap = "reinhold", 
                 width = 800, height = 800, filename = sprintf("neonvolcano%d",i))
}


av::av_encode_video(sprintf("neonvolcano%d.png",seq(1,360,by=1)), framerate = 30,
                    output = "neonvolcano.mp4")

We can also include depth of field to create a “miniature holographic volcano” effect by increasing the aperture setting in render_scene(). This makes only a certain slice of the scene in focus, and as we move away from that distance objects will become progressively more blurry. Depth of field is only of those effects that’s difficult to implement well in a rasterizing 3D renderer, but fairly straightforward in a pathtracer. 

for(i in seq(1,360,by=1)) {
  generate_ground(material = metal(color="grey20",fuzz=0.05)) %>%
    add_object(green_grid_vertical) %>%
    add_object(green_grid_horizontal) %>%
    add_object(group_objects(base_disk, group_translate = c(0,disk_height[i],0))) %>%
    add_object(group_objects(base_disk, group_translate = c(0,disk_height2[i],0))) %>%
    add_object(group_objects(base_disk, group_translate = c(0,disk_height3[i],0))) %>%
    add_object(group_objects(base_disk, group_translate = c(0,disk_height4[i],0))) %>%
    add_object(group_objects(base_disk, group_translate = c(0,disk_height5[i],0))) %>%
    add_object(fullscene2) %>%
    render_scene(lookfrom = c(xpos[i],160,zpos[i]-10), lookat = c(0,-1,-10), samples =200,
                 aperture = 30, fov=22, bloom = 5, tonemap="reinhold",
                 width = 800, height = 800, filename=sprintf("neonvolcanomini%d",i))
}

av::av_encode_video(sprintf("neonvolcanomini%d.png",seq(1,360,by=1)), framerate = 30,
                    output = "neonmini.mp4")

The original image that inspired this also had a slight reddish tint, so we’ll use the rayimage package to add a semi-transparent red overlay to all the images to achieve the same effect. rayimage is a new package in R that allows you to manipulate images in R as arrays, adding titles/image overlays, changing image orientation, and performing image convolutions (like our bloom effect). 

library(rayimage) 

red_overlay = array(1,dim=c(3,3,3))
red_overlay[,,1] = 0.7
red_overlay[,,2] = 0
red_overlay[,,3] = 0

for(i in seq(1,360,by=1)) {
  add_image_overlay(sprintf("neonvolcano%d.png",i), red_overlay, alpha = 0.25, preview=TRUE,
                    filename = sprintf("neonvolcanored%d.png",i))
}
av::av_encode_video(sprintf("neonvolcanored%d.png",seq(1,360,by=1)), framerate = 30,
                    output = "neonminired.mp4")

And that’s it! I hope you enjoyed this little mini-tour on creating and animating a 3D scene entirely in R, and has given you some inspiration for making slick 3D scenes of your own. If you do generate a scene you want to show off, share it on Twitter with the hashtag’s #rstats and #rayrender! There’s a great community of people who would love to see what you came up with.

]]> 3D GIS Maps R Rayrender Raytracing Fun https://www.tylermw.com/posts/fun/pathtracing-neon-landscapes-in-r.html Sat, 18 Apr 2020 23:32:06 GMT The Virtual Tilt Card: Raytracing Lenticular Prints with rayrender Tyler Morgan-Wall https://www.tylermw.com/posts/fun/raytracing-lenticular-gifs.html

Note: This post is also marks the release of rayrender 0.3.0: to see what new features are included (and there are many), head to the bottom of the post.

When I was a kid back in the 1990s, cereal companies used a clever little marketing trick to get their wares in our parents carts: literally just bribing children. With “prizes.” Little plastic submarines, spoons that morphed from Ectocooler green to Wild and Crazy Kids purple when dipped in milk, and most often of all: collectable trading cards. Although these cards were neither collectable nor traded by any child not holding a SAG card, they became a mainstay of the cereal prize economy . And because these corporations knew no kid who had access to 50 whole channels of cable television would ever care about a stupid little card with a picture of Simba on it, they added one critical feature: They made the characters move when you wiggled them back and forth.

Most likely because their cost could be underwritten by whatever movie or TV show was being marketed at the time, and few children have ever choked on a trading cardNon-CGI, as Kimba–I mean Simba–was intended to be

The tilt card. Kid crack.

Figure 1: Before we had animated GIFs, we had these babies.

And truthfully, the 90s were the last time I had put any thought into those real-world animated GIFs. That is, until this past January, when a mashup visualization I made using #plottertwitter and rayshader got this response from Hadley Wickham:

My first thought: “What the heck is lenticular printing?” One wikipedia page later I had my answer: it’s the technology that powered all of the cereal tilt cards of my youth. How they work: you pack a grid of tiny cylindrical lenses on top of interleaved strips of multiple images. The lenses focus the light at certain angles onto a one of those strips, magnifying it to the size of the lens. As you change the angle, the strip at the focal point changes and the image shifts, giving you a little animation.

Figure 2: Animation. Interactive widget that made this animation courtesy of Victor Powell’s blog.

This effect wasn’t possible with rayshader, since it cannot model refractive materials… but a month later, I started work on rayrender, a fully-featured pathtracer in R. And that package WAS capable, in theory, of modelling this effect. Which Hadley (a month later) was quick to pick up on:

Of course, I had to add a couple of features: cylinders, the ability to render only certain subtended arc of those cylinders, and support for textures. And with the latest version (v0.3.0) of rayrender, all those features are now included! So how do you turn a GIF into a virtual lenticular print? Let’s first build a toy example to show how lenticular lenses work.

(For a more basic introduction to rayrender, see this previous blog post.)

First, we’ll interleave strips of three colors: red, green, and blue. We do this by using the xy_rect object, which creates a rectangle in the xy-plane. We’ll use the add_object function to build the scene, and place three groups of them in the middle of the box. 

library(rayshader)
library(rayrender)

strip_width = 50/3
interlaced_rects = list()
offsets = c(-50,0,50)

for(i in 1:3) {
  xy_rect(x = 555/2 + strip_width + offsets[i], y = 200, z = 555/2, 
          ywidth = 400, xwidth = strip_width, 
          material = diffuse(color="red")) %>%
    add_object(xy_rect(x = 555/2 + offsets[i], y = 200, z = 555/2, 
                       ywidth = 400, xwidth = strip_width, 
                       material = diffuse(color="green"))) %>%
    add_object(xy_rect(x = 555/2 - strip_width + offsets[i], y = 200, z = 555/2, 
                       ywidth = 400, xwidth = strip_width, 
                       material = diffuse(color="blue"))) ->
  interlaced_rects[[i]]
}
#the do.call(rbind, ...) function just turns our list into a data frame.
interlaced_rect_scene = do.call(rbind,interlaced_rects)

initial_scene = generate_cornell(lightintensity = 20) %>%
  add_object(interlaced_rect_scene)

render_scene(initial_scene, parallel=TRUE, width = 800, height = 800, samples = 40, 
               ambient_light = FALSE, tonemap = "reinhold", aperture = 0)

Figure 3: Red, green, and blue vertical strips.

Now, we stick a lenticular lens in front of them. This lens will be a quarter of a cylinder, which we will specify with the min_phi and max_phi arguments. The radius will be the width of the three interleaved columns, and the center of the cylinder will be centered one radial unit away from the surface. We will also rotate the lens to face outwards. 

radius = 3*strip_width/sqrt(2)
lenticular_sheet = cylinder(x=555/2+offsets[1], y = 200, z = 555/2-radius, 
                      length = 400, phi_min = 225, phi_max = 315, radius = radius, 
                      material = dielectric(color="white")) %>%
  add_object(cylinder(x=555/2+offsets[2], y = 200, z = 555/2-radius, 
                      length = 400, phi_min = 225, phi_max = 315, radius = radius, 
                      material = dielectric(color="white")))  %>%
  add_object(cylinder(x=555/2+offsets[3], y = 200, z = 555/2-radius, 
                      length = 400, phi_min = 225, phi_max = 315, radius = radius, 
                      material = dielectric(color="white")))

scene_with_lens = initial_scene %>%
  add_object(lenticular_sheet) 

#Create the animation flying around the scene to demonstrate the geometry.
t = 1:360*pi/180
xval = 555/2 + 100 * sin(t)
zval = -300 + 500 * cos(t)
lookaty = 239 - 39 * cos(t)
lookfromy = 278 + 100 + 100 * cos(t)
fovvec = 62.5 + 22.5 * cos(t)

for(i in 1:360) {
   render_scene(scene_with_lens, parallel=TRUE, width = 600, height = 600, 
                samples = 400, ambient_light = FALSE, tonemap = "reinhold", 
                aperture = 0, fov=fovvec[i],
                filename = glue::glue("toyexample{i}"),
                lookfrom = c(xval[i],lookfromy[i],zval[i]), 
                lookat = c(555/2,lookaty[i],555/2-radius/2))
}

system("ffmpeg -framerate 30 -pix_fmt yuv420p -i toyexample%d.png toyexample.mp4")
Figure 4: Demonstrating the geometry of a lenticular lens by flying around the scene.

In raytracing, we generate our image of the scene by shooting rays out of the camera. Imagine shooting rays out of our eyes to sample the colors and lighting of the scene. At certain angles, all of those rays are refracted by the dielectric cylinder onto a single strip, which makes the lens appear that color (ignoring the reflection term). When we are at an angle where some of the rays hit one strip and some hit an adjacent strip, we can see both colors in a cylinder. This is what gives lenticular prints their characteristic gradual transition between frames.

Taking that into consideration, if we tilt the object back and forth, we can selectively focus on just one of the color strips. In Figure 5 below, I rock the toy example back and forth 25 degrees. To do this, we use the group_objects() function to group all of the elements of the tilt card together, and the group_angle argument to rotate them all together (around the group pivot point). Note how the lenses only focus on one of the strips at certain angles. 

tilt_angle = 25 * sin(t)
for(i in 1:360) {
   angled_scene_with_lens = generate_cornell(lightintensity = 20) %>%
     add_object(
       group_objects(interlaced_rect_scene %>%
           add_object(lenticular_sheet), 
           pivot_point = c(555/2,555/2,555/2-radius/2), 
           group_angle = c(0,tilt_angle[i],0)
         )
       )
   
     render_scene(angled_scene_with_lens, parallel=TRUE, 
                  width = 600, height = 600, samples = 400, 
                  ambient_light = FALSE, tonemap = "reinhold", 
                  aperture = 0, fov=40,
                  filename = glue::glue("toyexampletilt{i}"))
}

for(i in 1:360) {
   angled_scene_with_lens = generate_cornell(lightintensity = 20) %>%
     add_object(
       group_objects(interlaced_rect_scene %>%
           add_object(lenticular_sheet), 
           pivot_point = c(555/2,555/2,555/2-radius/2), 
           group_angle = c(0,tilt_angle[i],0)
         )
       )
   
     render_scene(angled_scene_with_lens, parallel=TRUE, 
                  width = 150, height = 150, 
                  samples = 400, ambient_light = FALSE, 
                  tonemap = "reinhold", 
                  aperture = 0, fov=fovvec[1], clamp_value = 10,
                  lookfrom = c(xval[1],lookfromy[1],zval[1]),  
                  lookat = c(555/2,lookaty[1],555/2-radius/2),
                  filename = glue::glue("toyexampletiltabove{i}"))
}

#Create the animation with the overhead inset, using ImageMagick on the command line.
system("for i in {1..360}; do convert toyexampletilt$i.png '(' toyexampletiltabove$i.png -bordercolor '#000000' -border 5 ')' -geometry +400+50 -composite combinedtoy$i.png; done;")
system("ffmpeg -framerate 30 -pix_fmt yuv420p -i combinedtoy%d.png combinedtoy.mp4")
Figure 5: Rocking the toy example back and forth 25 degrees, witha an inset view from above the interleaved color strips. When viewed directly from the front, the cylindrical lenses focus the viewer on just one of the three vertical interleaved columns. As the onlooker changes their viewing angle, different strips become visible.

Now, let’s demonstrate this on a much larger scale: instead of interleaving three colors, we are going to interleave frames of a GIF. The GIF of honor: this dancing banana (which will be familiar to millennials, and probably only known by Gen Z as a Fortnite dance or something):

Figure 6: In 2019, it’s organic single-origin almond spread and raspberry compote time. With a baseball bat.

This involves taking each column of pixels from the full animation and stacking them side-by-side with each subsequent frame. If our GIF has N frames, this means our final image will be N times wider than the original, since all frames are now present in the single (non-moving) output image. Here, I hack together a for loop to do this quickly–there are definitely more elegant ways to interleave matrices and arrays, but this one required zero thought and worked on the first try :) 

bananas = list()
for(i in 1:8) {
  bananas[[i]] = aperm(png::readPNG(glue::glue("~/Desktop/bananatest/banana{i}.png")), c(2, 1, 3))
}
#Dimensions of banana gif is 378x401--create a 4 layer array with space for all 8 frames.
tempbananas = array(0, dim = c(378*8, 401, 4))

#Interleave the frames:
counter = 1
counter2 = 1
for(i in 1:(378*8)) {
  if(counter2 > 8) {
    counter2 = 1
  }
  if(counter2 == 1) {
    tempbananas[i,,] = bananas[[1]][counter,,]
  } else if(counter2 == 2) {
    tempbananas[i,,] = bananas[[2]][counter,,]
  } else if(counter2 == 3) {
    tempbananas[i,,] = bananas[[3]][counter,,]
  } else if(counter2 == 4) {
    tempbananas[i,,] = bananas[[4]][counter,,]
  } else if(counter2 == 5) {
    tempbananas[i,,] = bananas[[5]][counter,,]
  } else if(counter2 == 6) {
    tempbananas[i,,] = bananas[[6]][counter,,]
  } else if(counter2 == 7) {
    tempbananas[i,,] = bananas[[7]][counter,,]
  } else {
    tempbananas[i,,] = bananas[[8]][counter,,]
    counter = counter + 1
  }
  counter2 = counter2 + 1
}
rayshader::plot_map(tempbananas, rotate = 90)
<bananamansquare.png></bananamansquare.png>
Figure 7: Interleaved columns of the dancing banana gif. I’ve also expanded the height by a factor of eight from the original image to keep the original aspect ratio.

Now, we load this image as a texture onto a square in a rayrender scene. I’ll put it inside a Cornell box, because that’s just what you do (when you’re raytracing). 

initial_scene = generate_cornell(lightintensity = 20) %>%
  add_object(yz_rect(x = 555/2, y = 200, z = 555/2, ywidth = 400, zwidth = 400,
                     material = diffuse(image_texture = tempbananas), angle = c(90, 90, 0)))

render_scene(initial_scene, parallel=TRUE, width = 800, height = 800, samples = 400,
               ambient_light = FALSE, tonemap = "reinhold", aperture = 0)
## Setting default values for Cornell box: lookfrom `c(278,278,-800)` lookat `c(278,278,0)` fov `40` .

Figure 8: The texture from Figure 7 applied to a rectangle, and placed in the middle of the Cornell box. There are no lenses here, so the image remains mixed.

Right now there’s nothing special about the above–it’s simply a texture on an square. The magic comes when we slide our array of cylindrical lenses in front of this interlaced image. We’ll use the same spacing as above–one cylindrical lens will be in front of 8 strips, as there are 8 frames in our gif. Since the width of our rectangle is 400 units wide and the original image is 378 pixels across, our pixel width will be units wide. The radius of the cylinder will be , and we will subtend a 90 degree arc in front of the image. Here’s an image looking down the side, showing off the geometry (the lenses are tinted green in order to highlight their geometry): 

pix_width = (1/378) * 400 
radius = pix_width/sqrt(2)

cyllist = list()
for(i in 1:378) {
  cyllist[[i]] = cylinder(x=200-i*radius*sqrt(2),z = -radius , y=0, 
                          length = 400, phi_min = 225, phi_max=315,
                          radius=radius,angle=c(0,0,0),
                          material = dielectric(color="green"))
}

do.call(rbind,cyllist) -> cyldf

look_from_above = generate_cornell(lightintensity = 10) %>%
    add_object(
      group_objects(
        yz_rect(ywidth=400,zwidth=400, 
                material= diffuse(image_texture = tempbananas),
                angle = c(90,90,0)) %>%
               add_object(cyldf), 
        pivot_point = c(0, 0, 0), 
        group_translate = c(555/2,200,555/2), group_angle = c(0,0,0)
        )
      ) %>%
    add_object(xy_rect(x=555/2,y=555/2,z=-1000, 
                       xwidth=1000, ywidth=1000,
                       material = diffuse(lightintensity = 10, implicit_sample = TRUE), 
                       flipped = FALSE))
  
render_scene(look_from_above, parallel=TRUE, width=800, height=800,
             samples = 100, fov = 1,
             lookat = c(555/2,400,555/2-1), tonemap = "reinhold",
             lookfrom = c(555/2+200,410,555/2-20), clamp_value = 10,
             ambient_light = FALSE, aperture = 0.5)

Figure 9: Zoomed in and looking down at the top of the lenticular gif, changing the color of the lenses to green so the lens geometry is actually visible.

Finally, to generate the virtual lenticular print, we simply tilt the card back and forth. This shifts the focal point of each lens onto a single strip (representing a single frame of the gif) and makes the banana dance. You can see the characteristic “blending” of one frame to another inherent to lenticular printing.

Dance, banana, dance! 

t = 1:360
angle = -45 * cos(t*pi/180)
x = 10 * sin(angle*pi/180)
z = 10 * cos(angle*pi/180)
for(i in seq(1, 360,1)) {
  banana_scene = generate_cornell(lightintensity = 10) %>%
    add_object(
      group_objects(
          yz_rect(ywidth=400,zwidth=400, 
                  material= diffuse(image_texture = tempbananas),
                  angle = c(90,90,0)) %>%
          add_object(cyldf), 
        pivot_point = c(0, 0, 0), 
        group_translate = c(555/2,200,555/2), 
        group_angle = c(0,angle[i],0)
        )
      ) %>%
    add_object(xy_rect(x=555/2,y=555/2,z=-1000, xwidth=1000, ywidth=1000,
                       material = light(intensity = 10), 
                       flipped = FALSE))
  
    render_scene(banana_scene, parallel=TRUE, width=600,height=600,
                 samples=100, clamp_value = 15, 
                 lookat = c(555/2,555/2,555/2),
                 filename = glue::glue("bananadance{i}"),
                 ambient_light = FALSE, tonemap = "reinhold",aperture = 0

system("ffmpeg -framerate 30 -pix_fmt yuv420p -i bananadance%d.png bananadance.mp4")
}
Figure 10: Finally, the dancing banana. All that work, and we now have a physically plausible (virtual) animated gif! Not a waste of time at all.

So the next time someone spouts some nonsense about R just being for statisticians and academics, you can correct them: R isn’t just a language for statistical computing, it’s also a language to make bananas dance in the most roundabout way possible. I expect they might not have a response.

Like what you read? Sign up for my listserve to get piping-hot fresh content into your inbox!

Package update: rayrender 0.3.0!

This post also marks the 0.3.0 release of rayrender! This is a fairly substantial release, and includes the following:

  • Added .obj file support (with diffuse textures). Also included is a 3D model of the letter “R”, which can be loaded by calling the function r_obj() into obj_model().
  • Added multicore progress bars using RcppThread.
  • Added triangle primitive. Supports per-vertex color and normals.
  • Added disk primitive. Supports an inner radius term.
  • Added cylinder primitive. Supports rendering only a subtended arc of the cylinder.
  • Added segment primitive (cylinder defined by a start and end point).
  • Added ellipsoid primitive.
  • Added pig() function, which returns a model built out of primitives. Oink.
  • Added spherical background images.
  • Added bounding box intersection algorithm from “A Ray-Box Intersection Algorithm and Efficient Dynamic Voxel Rendering” for more consistent BVH intersections.
  • Added transformation to scale primitives (or grouped primitives) in any (or multiple) axes.
  • Added HDR tonemapping options in render_scene()
  • Added option to set Cornell box colors.
  • Bug fixes (of course)

For more information, usage examples, and documentation, check out the package website: rayrender.net.

www.rayrender.net

r check out the Github page directly:

rayrender on Github
]]> 3D R Rayrender Pathtracing Fun https://www.tylermw.com/posts/fun/raytracing-lenticular-gifs.html Wed, 11 Sep 2019 06:45:59 GMT Introducing 3D ggplots with rayshader Tyler Morgan-Wall https://www.tylermw.com/posts/data_visualization/3d-ggplots-with-rayshader.html

As rayshader gracefully rotates into its second year, I’m happy to announce the release of a feature I’ve been teasing for a while: 3D ggplots! It’s been a long time coming, but the wait was worth it–I promise. Creating this feature was a logical extension of rayshader’s core competency–using elevation matrices to generate raytraced 3D maps of topographic data. Specifically, this tool generates 3D visualizations by transforming the color or fill aesthetics already defined in a ggplot2 object into the third dimension, and then maps the original plot onto that 3D surface.

How does one go about creating a 3D ggplot? Do I have to learn a completely new interface to create 3D plots? And wait, isn’t 3D plotting bad? Continue reading to find out!

Note: Each visualization in this article is accompanied by the code used to create it (the code for the featured video above is at the end of the article)–once you install the latest version of rayshader from Github, you can run the code below and immediately start playing along with me. Try it out! (note: Mailing list subscribers, the package will be out on Tuesday–come back and try the code then!) 

remotes::install_github("tylermorganwall/rayshader")
library(rayshader)
library(ggplot2)
library(tidyverse)

gg = ggplot(diamonds, aes(x, depth)) +
  stat_density_2d(aes(fill = stat(nlevel)), 
                  geom = "polygon",
                  n = 100,bins = 10,contour = TRUE) +
  facet_wrap(clarity~.) +
  scale_fill_viridis_c(option = "A")
plot_gg(gg,multicore=TRUE,width=5,height=5,scale=250)
Figure 1: Rayshader’s 3D ggplots work with any plot with a fill or colo, even when facetted. The user can create animations by moving the camera using rayshader’s ender_camera() function. Or, the user can twirl the graph around interactively, and take single snapshots with ender_snapshot(). By default, rayshader provides an isometric view of the graph, but you can add perspective by setting the field of view (argument fov) to a positive value.

My primary goal was not just to provide a hacked-together utility for generating these plots–I wanted to make the interface as user-friendly as possible. I wanted a 3D plotting package that didn’t require teaching users a new workflow or complex 3D modeling software just to produce a 3D plot; this feature is immediately accessible to anyone that already knows how to use ggplot2.

And due to this desire for simplicity and ease of use, this implementation of 3D graphing is not a new 3D grammar of graphics. All of the graphing is still driven by ggplot2–rayshader just takes those objects and maps them to 3D.

To transform an existing ggplot2 object into 3D, you simply drop the object into the plot_gg() function–rayshader handles the dirty work of stripping out all non-data elements, remapping the data, ray tracing shadows, and plotting it in 3D[footnote]Utilizing the gl package[/footnote]. And this works with any ggplot that includes a color or fill aesthetic, no matter the complexity[footnote]Intended to work–if you find examples where it doesn’t, leave an issue on the Github issues page[/footnote]. 

#Data from Social Security administration
death = read_csv("https://www.tylermw.com/data/death.csv", skip = 1)
meltdeath = reshape2::melt(death, id.vars = "Year")

meltdeath$age = as.numeric(meltdeath$variable)

deathgg = ggplot(meltdeath) +
  geom_raster(aes(x=Year,y=age,fill=value)) +
  scale_x_continuous("Year",expand=c(0,0),breaks=seq(1900,2010,10)) +
  scale_y_continuous("Age",expand=c(0,0),breaks=seq(0,100,10),limits=c(0,100)) +
  scale_fill_viridis("Death\nProbability\nPer Year",trans = "log10",breaks=c(1,0.1,0.01,0.001,0.0001), labels = c("1","1/10","1/100","1/1000","1/10000")) +
  ggtitle("Death Probability vs Age and Year for the USA") +
  labs(caption = "Data Source: US Dept. of Social Security")

plot_gg(deathgg, multicore=TRUE,height=5,width=6,scale=500)
Figure 2: Rayshader automatically detects that the user has passed the “fill” aesthetic to a ggplot geom, and uses that aesthetic to map to #D. If the user instead passes only the “color” aesthetic, that will be chosen instead. If both are passed, the “fill” aesthetic will be used unless the user specifies heighttype = “color”.

Once open, the plot can be manipulated like any other rayshader plot–you can call ender_camera() to programmatically change the camera position, ender_snapshot() to save or output the current view, or even use ender_depth() to render a slick depth of field effect (I wrote about depth of field and its use in 3D visualization in my previous blog post–check it out at some point). You can also change or even remove the light source, and pass any arguments to plot_gg() that you would plot to plot_3d(). 

library(sf)

nc = st_read(system.file("shape/nc.shp", package="sf"), quiet = TRUE)
gg_nc = ggplot(nc) +
  geom_sf(aes(fill = AREA)) +
  scale_fill_viridis("Area") +
  ggtitle("Area of counties in North Carolina") +
  theme_bw()

plot_gg(gg_nc, multicore = TRUE, width = 6 ,height=2.7, fov = 70)
render_depth(focallength=100,focus=0.72)
Figure 3: You can direct focus in your 3D animations using the ender_depth() function in rayshader. This is more than just visual fluff: photographers and cinematographers solved the problem of “directing attention in a 3D world projected on a 2D screen” a century ago, and that solution is depth of field. However, when you start getting really cinematic, it’s best to also provide a non-Spielbergian version of your plot.

The output produced by rayshader is effectively a 2.5D plot, so sharp transitions will sometimes (not always!) contain unwanted color mixing between the low and high areas. You can get around this in two ways: cover it up, or increase the resolution of your plot. For the fill aesthetic, you can cover up sharp transitions between points by giving the layer a line color–here, I added a black line to the hex plot, which covers all the transition regions. 

a = data.frame(x=rnorm(20000, 10, 1.9), y=rnorm(20000, 10, 1.2) )
b = data.frame(x=rnorm(20000, 14.5, 1.9), y=rnorm(20000, 14.5, 1.9) )
c = data.frame(x=rnorm(20000, 9.5, 1.9), y=rnorm(20000, 15.5, 1.9) )
data = rbind(a,b,c)

#Lines
pp = ggplot(data, aes(x=x, y=y)) +
  geom_hex(bins = 20, size = 0.5, color = "black") +
  scale_fill_viridis_c(option = "C")
plot_gg(pp, width = 4, height = 4, scale = 300, multicore = TRUE)

#No lines
pp_nolines = ggplot(data, aes(x=x, y=y)) +
  geom_hex(bins = 20, size = 0) +
  scale_fill_viridis_c(option = "C")
plot_gg(pp_nolines, width = 4, height = 4, scale = 300, multicore = TRUE)
Figure 5: Adding a line color will cover up transition regions during sharp changes in height.

For the colo aesthetic, plot_gg() has a built-in option to shrink the size of the points slightly when mapping points to 3D. Play with this value if you’re using geom_point() and have unwanted color mixing at the transition regions. 

mtcars_gg = ggplot(mtcars) + 
  geom_point(aes(x=mpg,color=cyl,y=disp),size=2) +
  scale_color_continuous(limits=c(0,8)) +
  ggtitle("mtcars: Displacement vs mpg vs # of cylinders") +
  theme(title = element_text(size=8),
        text = element_text(size=12)) 

plot_gg(mtcars_gg, height=3, width=3.5, multicore=TRUE, pointcontract = 0.7, soliddepth=-200)
Figure 6: 3D plot of the mtca dataset using geom_point(). plot_gg() includes the option to slightly shrink points around their center with the pointcontract argument. This covers up the transition region between the plot background color and the point color by shrinking the 3D data within the color bounds.

You can also just increase the resolution of the plot (by increasing the idth and height arguments), which will help smooth out all these issues.

If the defaults in plot_gg() don’t appeal you to you, there are ways to customize the 3D output. You can change the 3D scaling, adjust the light position or intensity, or manipulate the underlying shadow and background color the same way you would in rayshader’s ay_shade() function. If the built-in ggplot-to-3D conversion isn’t to your liking, you can pass in a list of two ggplots–the first will be the displayed plot, and the second will be used to generate the 3D surface (also, file an issue on the rayshader Github if it’s not working–there are way too many corner cases in ggplot2 for me to have figured all of them out on my own). 

#Generate the ggplot2 objects for both the 3D depth 
#information (ggplot_potential) and 
#for the plot painted on that surface (ggplot_objects). 
#Combine these into a list and pass into plot_gg() 
#instead of a single plot, and you can "paint"
#the 3D surface generated by one plot with the texture of another.
ggplot_potential = generate_ggplot_potential()
ggplot_objects = generate_ggplot_orbiting_objects()

plot_gg(list(ggplot_objects, ggplot_potential), height=5, width=4.5)
Figure 7: Plot created using two ggplot2 objects–one to create the 3D “spacetime” surface that the objects travel through, and another that plots the objects in orbit. This example was a little too involved to include in this post (it involves some complex-looking simulation code), so it will be the subject of it’s own post! But like the others, it was just a single line of rayshader::plot_gg(). Subscribe to my mailing list and you’ll be the first to see how these figures were generated!

The ability to specify the 3D surface separately from the plot itself is more than for bug workarounds. You can also use this feature to plot a visualization where where depth serves as it’s own variable, separate from color. Want to show a hillclimbing algorithm getting stuck in a local maxima? Or the locations of watersheds visualized with real geographic features? How about a toy model of how the curvature of spacetime results in moving objects orbiting? All this is not only possible, but incredibly simple with rayshader’s plot_gg() function.

But wait–aren’t 3D plots bad?

“But wait!” you ask. “I thought 3D plotting was bad. Do you really want to open Pandora’s 3D box chart?”

3D has a poor reputation in the data visualization community, and I’ll point to a great new resource that describes why: Claus Wilke’s book “Fundamentals of Data Visualization” has a great chapter titled “Don’t go 3D.” His advice is less black and white than the chapter title implies, but he brings up two good points an analyst/researcher should consider before using a 3D plot. I have not included those points verbatim: here’s my takeaway of the main points from that chapter, and what rayshader does to help avoid those pitfalls.

  1. Don’t use gratuitous 3D: Does your data have three variables, each with a continuous numeric mapping? If the answer is “no”, then you shouldn’t use 3D. This is by far the biggest offender in poor use of 3D[footnote]Thanks Excel[/footnote].

Rayshader’s implementation of 3D plots explicitly avoids this: in order to generate a 3D plot, you must have an existing continuous color mapping in the original plot (if you attempt to use a discrete data point mapped to a color, plot_gg() will throw an error). Any gratuitous 3D must then be hard coded by the user. And if someone just needs to have their 3D pie chart, who am I to question their intentions? They may have their reasons (most likely bad, but who knows), and if they put in the work to hack together an objectively “bad” visualization: well, bless their heart.

And not all 3D is gratuitous–the spacetime plot above shows that depth can be a more effective tool than any other (color, contours, vector lines) in telling a specific kind of story.

  1. It’s difficult to interpret static 3D visualizations, as the display is an inherently 2D medium and the reader can’t accurately reconstruct the depth information of 3D data. Any 3D visualization that has “floating” objects, such as 3D scatter plots or 3D line plots, suffers from this problem. And even if 3D objects are well-grounded, adding perspective makes it difficult to compare different data points.

Rayshader addresses these problems in a few ways: first, rayshader defaults to an isometric 3D projection, which preserves areas, relative lengths, and angles. This means that the 3D does not distort the data–isometric projection the same technique used in 3D CAD software when there is a need to accurately represent 3D objects in 2D. Secondly, all the data is “grounded” in rayshader; Since the plots rayshader produces are effectively 2.5D rather than fully 3D (each x/y point is only associated with a single z point, and those points are all connected), the continuous underlying substrate provides perceptual context for the missing depth information. The issue of “small box close, or big box far away?” doesn’t occur with a 2.5D plot, since those points can always be located in 3D space by referencing the surrounding data.

Depth can be a more effective tool than any other (color, contours, vector lines) in telling a specific kind of story.

In my opinion, 3D visualization mostly gets a bad rap because the available tooling has never properly supported it. Excel exclusively produces 3D visualizations of the “gratuitous” variety. Engineering-focused programs like MATLAB tend to generate plots that are functional but aesthetically… well, made by an engineer (apologies to all the artistic engineers out there). Python and other languages (R included!) mostly treats 3D plotting as a toy–offering some basic utilities to support it, but not (again, in my opinion) enough to support serious work. And a good portion of academic 3D plotting utilities aren’t focused around data–they are more built around displaying mathematical surfaces that can be defined by equations.

This lack of support forces those who want a beautiful 3D plot to exit the world of programming and enter the completely skill-orthogonal world of 3D modeling. Learning about programming, data science, and data visualization is hard enough: we don’t need to add Blender to the list.

Figure 8: Each point on the map is only mapped to a single value on the vertical axis. The guarantee of connected-ness in the underlying plot provides additional depth cues to the viewer.

I know there’s someone thinking right now: “If the color data is already there, why bother with a 3D mapping? Isn’t this mapping by definition gratuitous if the color is already present?” If you thought that, here are your brownie points[footnote]Spoiler: There are no brownie points. [/footnote]. However, 3D mappings have some advantages over traditional color plots. The advice to always use a color plot is not nearly that simple: There are physiological aspects of color perception that might need to be taken into account when presenting a color mapping. There’s the obvious issues, like color blindness. Then there are more subtle issues, like how linear some palettes are perceived, or how some colors have specific meanings in certain areas of the world which may change the visualization’s context.

Learning about programming, data science, and data visualization is hard enough: we don’t need to add Blender to the list.

There’s also the issue of interpretability: researchers know how to interpret a color plot, but how should a layperson know that green is half of yellow, both of which are higher than purple? Professionals know to look to the color bar to provide the needed context, but not all laypeople immediately know how to interpret a heatmap. And even if you do, often it’s best to bin continuous variables into large discrete intervals because it’s hard for our brains to map those colors back to their numeric values with any degree of fidelity. If your story is “high concentration of X variable here, and low concentration elsewhere” do you need the precision offered by a color plot? Not always.

A 3D plot is a just another tool that enables the reader to compare relative magnitudes across space. In an interactive or rotating 3D plot, a user can compare relative magnitudes as easily as they would two objects if placed in front of them. Yes, the reader loses the ability to exactly map the presented data back to its numeric value. But the point of a good data visualization isn’t the ability to re-construct the original data set based on the figure’s RGB values–it’s to tell a story. And in some cases, a 3D plot is a better and more engaging tool to do just that.

Ready to get started? Check out the links below! The website contains documentation and examples of all of rayshader’s functionality, and you can find the actual repository on the Github page.

And if you liked this post, be sure to follow me on Twitter and sign up for my newsletter!

Code for featured figure at the top of the page 

library(tidyverse)
measles = read_csv("https://tylermw.com/data/measles_country_2011_2019.csv")
melt_measles = reshape2::melt(measles, id.vars = c("Year", "Country", "Region", "ISO3"))
melt_measles$Month = melt_measles$variable
melt_measles$cases = melt_measles$value
melt_measles %>% 
  group_by(Year, Month) %>%
  summarize(totalcases = sum(cases,na.rm = TRUE)) %>% 
  mutate(totalcases = ifelse(Year == 2019 & !(Month %in% c("January","February","March")), NA, totalcases)) %>%
  ggplot() + 
  geom_tile(aes(x=Year, y=Month, fill=totalcases,color=totalcases),size=1,color="black") + 
  scale_x_continuous("Year", expand=c(0,0), breaks = seq(2011,2019,1)) +
  scale_y_discrete("Month", expand=c(0,0)) +
  scale_fill_viridis("Total\nCases") +
  ggtitle("Reported Worldwide Measles Cases") +
  labs(caption = "Data Source: WHO") +
  theme(axis.text = element_text(size = 12),
        title = element_text(size = 12,face="bold"),
        panel.border= element_rect(size=2,color="black",fill=NA)) -> 
measles_gg

plot_gg(measles_gg, multicore = TRUE, width = 6, height = 5.5, scale = 300, 
background = "#afceff",shadowcolor = "#3a4f70")
]]> https://www.tylermw.com/posts/data_visualization/3d-ggplots-with-rayshader.html Tue, 11 Jun 2019 03:54:55 GMT Getting Started with Rayrender: Forging the R Sword Tyler Morgan-Wall https://www.tylermw.com/posts/rayverse/getting-started-with-rayrender.html

In mid-February, I found myself staring at the computer screen with a weekend free and a choice to make. After three months working on rayshader to put together and practice a presentation for RStudio::conf(2019), build the package a website, and bring life to an interactive rayshading Twitterbot–I found myself feeling the smallest tinge of “burn out”. Not enough to say ik ben op, as the Dutch so poetically put it–but I had been working on the same project for a while and needed something new and exciting in my life . I wanted to take a little break and tackle a new problem–one that might not provide me with any immediate benefit, but might help rayshader in the long run.

i.e. an open source mid-lifecycle crisis

So I decided to build a raytracer.

Figure 1: When you raytrace your own universe, ALL the hits can be corner hits.

Although “rayshader” has “ray” in the name, it only uses “ray tracing” in the most basic sense: it traces rays from points on an elevation matrix to bake a shadow map onto the surface of an object. The simplicity of the method means implementing techniques like ambient occlusion is trivial, and baking the shadow map into the texture is great for fast, interactive plotting–but you would never confuse the output of rayshader for a pathtracer . So I had been meaning to dive deeper into real raytracing in order to one day bring a higher quality renderer to rayshader.

Definition: calculate ahead of time and apply as a textureAlthough I think rayshader’s render_depth() function certainly helps narrow that divide

And luckily for me, there’s never been a better time to learn about raytracing!

Last year, two resources were released free-of-charge that made learning about raytracing immensely easier: Matt Pharr’s Physically Based Rendering: From Theory To Implementation textbook, and Peter Shirley’s Ray Tracing in One Weekend three book series. The former was great as a reference, but a bit unwieldy as a way to introduce yourself to the subject. Peter Shirley’s books, however, hit the pedagogical sweet spot (in my opinion): easily understandable and concise code, plain English explanations of what the code is doing, and a built-in system of student feedback by immediately diving into producing cool output. But more importantly, I could see right away how I could use what he taught to build a raytracer in R.

And luckily for me, there’s never been a better time to learn about raytracing!

Enter: rayrender.

Rayrender is an R package that uses raytracing to render scenes consisting of spheres, cubes, and 2D planes. The “scene” is just a tibble where each row contains all the information required to draw on object, and the collection of such objects is passed to the render_scene() function to draw an image (or save an image to file). Similarly to how you build a map in rayshader, you build the scene in layers and compose them all together with the add_object() function. Here, we generate a large sphere as the “ground” and then place a grey sphere on top of it. 

#Install the package if you haven't already
#remotes::install_github("tylermorganwall/rayrender")
library(rayrender)

scene = sphere(y=-1001,radius=1000,material = lambertian(color = "#ccff00")) %>%
  add_object(sphere(material=lambertian(color="grey50")))
render_scene(scene)

Figure 2: A single sphere (well, technically, two spheres).

Not very exciting? Okay, let’s replace the ground with something a little more interesting. How about a checker pattern? And let’s make the ball a light reddish color. The API is designed so that each object accepts a material argument, to which you pass the output of one of the material functions: lambertian, metal, or dielectric. 

scene = sphere(y=-1001,radius=1000,
               material = lambertian(color = "#ccff00",checkercolor="grey50")) %>%
  add_object(sphere(material=lambertian(color="#dd4444")))
render_scene(scene, width=500, height=500, samples=500)

Figure 3: Checkers as far as the eye can see.

You might be thinking: “Wait. This scene doesn’t look like anything special. 🤔Aren’t raytracers supposed to have floating metallic spheres and glass balls everywhere?” 

scene = sphere(y=-1001,radius=1000,
               material = lambertian(color = "#ccff00",
                                     checkercolor="grey50")) %>%
  add_object(sphere(material=lambertian(color="#dd4444"))) %>%
  add_object(sphere(z=-2,material=metal())) %>%
  add_object(sphere(z=2,material=dielectric()))
render_scene(scene,width=500, height=500, samples=500, 
             fov=40,lookfrom=c(12,4,0))

Figure 4: Glass and metal balls: The raytracing “Hello World”

You need not worry. Glass to the left, and metal to the right. Here, I changed the sphere from the default diffuse material to glass and metal by specifying a different material argument in the object function.

🤔 “Aren’t raytracers supposed to have floating metallic spheres and glass balls everywhere?”

Now, one of the coolest thing about raytracers is how easy it is to add realistic lighting to the scene–and we can do that simply by setting the lightintensity argument in a lambertian material to a positive number. The greater the intensity, the brighter the light. Adding an emissive object turns off the ambient lighting, although the user can override this by setting ambient_light = TRUE in render_scene(). Here, the scene is plotted twice: once far away to show the overhead position of the light, and once up close to show its effect on the spheres. 

scene = sphere(y=-1001,radius=1000,
               material = lambertian(color = "#ccff00",
                                     checkercolor="grey50")) %>%
  add_object(sphere(material=lambertian(color="#dd4444"))) %>%
  add_object(sphere(z=-2,material=metal())) %>%
  add_object(sphere(z=2,material=dielectric())) %>%
  add_object(sphere(x=-20,y=30,radius=20,material=lambertian(lightintensity = 3)))

par(mfrow=c(1,2))

render_scene(scene,fov=40, width=500, height=500, samples=500,
             lookfrom=c(50,10,0),parallel=TRUE)
render_scene(scene,fov=30, width=500, height=500, samples=500,
             lookfrom=c(12,4,0),parallel=TRUE)

Figure 5: The light is also implicitly sampled, which improves noise convergence (most of the time).

rayrender also supports motion blur for spheres. Let’s give each sphere a velocity (each sphere here is traveling in a different direction): 

scene = sphere(y=-1001,radius=1000,
               material = lambertian(color = "#ccff00",
                                     checkercolor="grey50")) %>%
  add_object(sphere(material=lambertian(color="#dd4444"),
                    velocity=c(-2,0,0))) %>%
  add_object(sphere(z=-2,material=metal(),
                    velocity=c(0,1,0))) %>%
  add_object(sphere(z=2,material=dielectric(),
                    velocity=c(0,0,0.5))) %>%
  add_object(sphere(x=-20,y=30,radius=20,
                    material=lambertian(lightintensity = 3)))

par(mfrow=c(1,1))

render_scene(scene,fov=40, width=500, height=500, samples=500,
             lookfrom=c(12,4,0),parallel=TRUE)

Figure 6: Motion blur improves the perception of continuous motion at lower frame rates when objects are moving quickly. Check it out here: https://twitter.com/tylermorganwall/status/1110880693897302016

Okay, spheres are nice–how about cubes? Let’s turn the glass object green and lift all the objects off the ground to highlight the light transmission. 

scene = sphere(y=-1001,radius=1000,
               material = lambertian(color = "#ccff00",
                                     checkercolor="grey50")) %>%
  add_object(cube(width=2,y=0.1,
                  material=lambertian(color="#dd4444"))) %>%
  add_object(cube(z=-2.2,y=0.1,width=2,
                  material=metal())) %>%
  add_object(cube(z=2.2,y=0.1,width=2,
                  material=dielectric(color="green"))) %>%
  add_object(sphere(x=-20,y=30,radius=20,
                  material=lambertian(lightintensity = 5)))

render_scene(scene,fov=40, width=500, height=500, samples=500,
             parallel=TRUE,lookfrom=c(12,4,0))

Figure 7: Cubes.

Now let’s build something more substantial: how about a pyramid, with a golden block on top? We’ll also change the ground to be a procedurally generated dirt pattern, using the generate_ground() function (which just wraps the sphere function in a nice interface). We’ll view the pyramid from all four cardinal angles and create a grid of images. 

scene = generate_ground(depth=-0.5,spheresize=1000, 
                        material=lambertian(color="#000000",noise=1/10,
                                            noisecolor = "#654321")) %>%
  add_object(sphere(x=-20,y=30,radius=20,
                    material=lambertian(lightintensity = 3)))
firstlayer = c(-1.5,-0.5,0.5,1.5)
secondlayer = c(-1,0,1)
thirdlayer = c(-0.5,0.5)

firstlayerdf = expand.grid(x=firstlayer,z=firstlayer,y=0)
secondlayerdf = expand.grid(x=secondlayer,z=secondlayer,y=1)
thirdlayerdf = expand.grid(x=thirdlayer,z=thirdlayer,y=2)

pyramid_positions = rbind(firstlayerdf,secondlayerdf,thirdlayerdf)

for(i in 1:nrow(pyramid_positions)) {
  scene = add_object(scene,cube(x=pyramid_positions$x[i],
                                y=pyramid_positions$y[i],
                                z=pyramid_positions$z[i],
                                material = lambertian(color="tan")))
}

scene = scene %>% add_object(cube(y=3,material = metal(color="gold",fuzz=0.2)))

par(mfrow=c(2,2))
render_scene(scene,fov=40, width=500, height=500, samples=500, 
             parallel=TRUE, lookfrom=c(-12,6,0),lookat = c(0,1,0))
render_scene(scene,fov=40, width=500, height=500, samples=500, 
             parallel=TRUE, lookfrom=c(0,6,12),lookat = c(0,1,0))
render_scene(scene,fov=40, width=500, height=500, samples=500, 
             parallel=TRUE, lookfrom=c(12,6,0),lookat = c(0,1,0))
render_scene(scene,fov=40, width=500, height=500, samples=500, 
             parallel=TRUE, lookfrom=c(0,6,-12),lookat = c(0,1,0))

Figure 8: If the ancient Egyptians gave up after a few hours work.

Finally, now that we know how to compose a scene: Let’s forge the R sword, modeled after Link’s wooden sword in the original NES Zelda. We’ll start by creating a matrix that uses a number to represent each separate material/color on the sword. There will be three different materials: a bronze metal for the blade, a green lambertian material for the guard and hilt, and a yellow lambertian for the stripes on the hilt. We will then loop through the matrix and add the appropriate material to the scene when there is a non-zero entry in the matrix. 

scene = generate_ground(depth=0,spheresize=1000, 
                        material=lambertian(color="#000000",
                                            noise=1/10,
                                            noisecolor = "#654321")) %>%
  add_object(sphere(x=-60,y=55,radius=40,
                    material=lambertian(lightintensity = 8)))

sword = matrix(
c(0,0,0,1,0,0,0,
  0,0,1,1,1,0,0,
  0,0,1,1,1,0,0,
  0,0,1,1,1,0,0,
  0,0,1,1,1,0,0,
  0,0,1,1,1,0,0,
  0,0,1,1,1,0,0,
  0,0,1,1,1,0,0,
  0,0,1,1,1,0,0,
  0,0,1,1,1,0,0,
  0,0,1,1,1,0,0,
  2,2,2,2,2,2,2,
  2,0,3,3,3,0,2,
  0,0,2,2,2,0,0,
  0,0,3,3,3,0,0,
  0,0,2,2,2,0,0),
ncol = 7,byrow=TRUE)

metalcolor = "#be2e1b"
hilt1 = "#7bc043"
hilt2 = "#f68f1e"

for(i in 1:ncol(sword)) {
  for(j in 1:nrow(sword)) {
    if(sword[j,i] != 0) {
      if(sword[j,i] == 1) {
        colorval = metalcolor
        material = metal(color=colorval,fuzz=0.1)
      } else if (sword[j,i] == 2) {
        colorval = hilt1
        material = lambertian(color=colorval)
      } else {
        colorval = hilt2
        material = lambertian(color=colorval)
      }
      scene = add_object(scene,cube(y=16-j,z=i-4, material=material))
    }
  }
}

par(mfrow=c(1,1))
render_scene(scene,fov=30, width=500, height=500, samples=500,
             parallel=TRUE, lookfrom=c(-25,25,0), lookat = c(0,9,0))

Figure 9: A sword created with voxels.

Now we add the R to the blade, using the same process but offseting it slightly towards the front of the blade. 

scene2 = scene
rlogo = matrix(
c(1,1,1,0,
  1,0,0,1,
  1,1,1,0,
  1,0,1,0,
  1,0,0,1),
ncol = 4,byrow=TRUE)

material = metal(color="#be8d1b")

for(i in 1:ncol(rlogo)) {
  for(j in 1:nrow(rlogo)) {
    if(rlogo[j,i] != 0) {
      scene2 = add_object(scene2,cube(x=-0.4,y=8-j/2, z=-1.25+i/2,width=0.5, material=material))
    }
  }
}

render_scene(scene2,fov=30,width=500, height=500, samples=500,
             parallel=TRUE,lookfrom=c(-25,25,0),lookat = c(0,9,0))

Figure 10: Now show me a Python trident and we can make the next R vs Python debate really interesting.

Finally, we rotate the camera around the sword and then turn all the images into a movie. To do this, we just specify the lookfrom coordinate to move in a circle centered around the lookat point. The odd subsetting I have included with the frame variable ensures you have a perfect loop, for extra Twitter points: 

frames = 360

camerax=-25*cos(seq(0,360,length.out = frames+1)[-frames-1]*pi/180)
cameraz=25*sin(seq(0,360,length.out = frames+1)[-frames-1]*pi/180)

for(i in 1:frames) {
  render_scene(scene2, width=500, height=500, fov=35,
               lookfrom = c(camerax[i],25,cameraz[i]),
               lookat = c(0,9,0), samples = 1000, parallel = TRUE,
               filename=glue::glue("swordtest{i}"))
}

av::av_encode_video(glue::glue("swordtest{1:(frames-1)}.png"), framerate=60, output = "rswordfast.mp4")
file.remove(glue::glue("swordtestfast{1:(frames-1)}.png"))

Alternatively, you could just capture the plots directly using the av package and avoid saving any images to disk. I prefer to write the images to disk because you can then interrupt the process and not lose your progress, but for short animations this can be convenient: 

av::av_capture_graphics(expr = {
  for(i in 1:frames) {
    render_scene(scene2, width=500, height=500, fov=35,
                 lookfrom = c(camerax[i], 25, cameraz[i]),
                 lookat = c(0,9,0),samples = 1000, parallel = TRUE)
  }
}, width=500,height=500, framerate = 60, output = "rsword2.mp4")
Figure 11: It’s not safe to analyze data alone. Take this.

It’s that easy! I hope you enjoyed this short introduction to the (very nascent) rayrender package. Support for more complex objects, materials, and rendering options are in the works. I’m going to push out a series of tutorials on more advanced topics as time goes on (implicit sampling, grouping of objects, animating). Be sure to sign up for my email list to learn more! You can also see the code and see more examples at the Github page below, as well as the package website:

rayrender on Github

Or just check out the examples and the documentation on the package’s website:

www.rayrender.net

If you liked this post, be sure to sign up for my newsletter so you don’t miss future developments!

]]> R Rayrender Pathtracing https://www.tylermw.com/posts/rayverse/getting-started-with-rayrender.html Tue, 02 Apr 2019 03:10:35 GMT 2018 Year in Review Tyler Morgan-Wall https://www.tylermw.com/posts/other/2018-year-in-review.html

What a year.

In my adult life, I can look back and classify my years into two categories: “cultivating” years, and “fruit-bearing” years. Cultivating years were those spent learning and laying the groundwork for future things to come: doing research and learning (or, in the modern forehead slapping vernacular, “upskilling” 🤦‍♂️), getting into the deep and dirty details of building R packages, or writing for the sake of improving my writing. Fruit-bearing years were functionally the same, but punctuated by significant accomplishments: finishing my PhD, getting a job, publishing papers, or building something cool.

Figure 1: One package, one year, many features.

2018 has been a fruit-bearing year.

(Hashtag rayshader hashtag rstats, basically my signature on twitter now)

Although I first started developing rayshader in February, the seed for rayshader’s formation began slightly earlier: in San Diego during RStudio::conf(2018). When I say “began” I don’t mean in the sense of “lines of code written,” but rather in a subtle internal transformation I experienced during the conference. At the conference, I was lucky enough to present a poster on a package I had developed for work (skpr) and take the “intermediate Shiny” course. Up until that point, I had been developing and working in R in a vacuum–no real interaction with the larger R and open source community. And at the conference, I had the opportunity to ask some of the foremost developers in R about questions and problems I was working through. And almost universally, each person I asked would answer with some variation of:

“That’s a good question! Let me know if you figure out a solution.”

2018 has been a fruit-bearing year.

The conference brought me to the realization that I was there alongside them on the edge of the R development world[footnote]#flateaRth theory[/footnote]. This realization was at once both intimidating as well as freeing: if I had a problem no one else had solved, there was nothing stopping me from tackling it myself, and my solution would likely be as good as anyone else’s. So in February, when I realized that no one had built a user-friendly mapping package focusing on aesthetics and producing beautiful topographic maps, I thought:

“Okay. I’ll do it myself.”

And when I released rayshader in May , I was pretty happy with where it stood–but interactions with the R community made me realize how much potential it had as a mapping package. So I starting learning more about mapping (as I would in any “cultivating” year!) and adding on features, which brought more community interest and kickstarted a virtuous cycle of feedback and development. Some features were requested by the community, and some began with the thought “You know, it would be cool if rayshader could < insert cool feature here > ,” usually followed by a week or two of “Oh god what did I just get myself into” which then transitioned into “Okay, this is doable.” Going from idea to implementation to release and then seeing other people start using the feature has been incredibly satisfying.

Figure 2: A small sampling of some of the fantastic creations and stories people used rayshader to help create. Twitter handles: @ClausWilke @davidawaldron @TimSalabim3 @DashWieland @JoachimGassen @iarynam @silentcarto @Reyfenberg @kestert @KaranKanishk @mdsumner @ozjimbob @thomasp85 @emilbp

What’s also been fun is interacting with new communities around the web with each additional feature in rayshader. I had no former interaction with the GIS world, but seeing GIS practitioners respond positively to a complete outsider’s mapping tool made me realize I was on the right track. Similarly, I posted it on the 3D printing subreddit /r/3Dprinting when I introduced the 3D printing functionality. Having multiple people in a completely R-agnostic community say “Wow! That looks really cool! I need to learn R now!” told me I had developed something special in the R ecosystem.

“That’s a good question! Let me know if you figure out a solution.”

And finally, it has been a joy interacting with people in the real world who are discovering rayshader. I gave a talk in December at the satRday DC conference, and seeing people’s reactions and interest in the package was incredibly exciting. I’m really looking forward to RStudio::conf(2019) this year in Austin, where I will be privileged to give a talk on rayshader and show what you can do with the package (and maybe reveal some upcoming features as well 😃). And hopefully get a few good questions that I don’t know the answer to–so someone else can be inspired to start their own journey.

So here’s to 2019! 🍾🍾

]]> Review R Community Rayshader https://www.tylermw.com/posts/other/2018-year-in-review.html Mon, 31 Dec 2018 08:37:04 GMT