CLIWOC Historical Ship Movements Animation in R

GitHub Gist by Neil Southall for rendering an animation of logged ship movements from the Climatological Database of the World's Oceans (CLIWOC) on a 3D globe in R: submarine_cable_map.R

Files required for tutorial: - CLIWOC database ship logs from 1750 to 1850 via Historical Climatology: https://www.historicalclimatology.com/cliwoc.html - 2k Earth Daymap via SolarSystemScope: https://www.solarsystemscope.com/textures/

library(tidyverse) # 1.3.1
library(rayrender) # 0.23.6
library(sf) # 1.0-4
library(magrittr) 

# Earth daymap from https://www.solarsystemscope.com/textures/download/2k_earth_daymap.jpg
image_texture_path <- "/path/to/2k_earth_daymap.jpg"

# CLIWOC Data source: https://www.historicalclimatology.com/cliwoc.html
f_cliwoc <- ("/path/to/cliwoc21.gpkg")
cliwoc_data <- sf::st_read(f_cliwoc)

# output path for frames of animation
output_path <- "/path/to/output/cliwoc/"

tracks <- cliwoc_data %>%
  sf::st_set_geometry(NULL) %>% # remove geometry, coerce to data.frame
  dplyr::select(c('ShipName', 'Nationality', 'VoyageIni', 'VoyageFrom', 'VoyageTo', 'YR', 'MO', 'DY', 'HR', 'latitude', 'longitude')) %>%
  dplyr::filter(!(is.na(latitude))) %>%
  dplyr::filter(!(is.na(longitude)))

# build up a date field, remove double-reported positions
tracks <- tracks %>%
  dplyr::mutate(my_date = lubridate::as_date(paste0(YR, '-', MO, '-', DY))) %>%
  dplyr::distinct(ShipName, my_date, .keep_all = TRUE)

# colour mapping
Nationality <- c("SPANISH", "DUTCH", "BRITISH", "FRENCH")
colour <- c("#ff0000", "#FF8000", "white", "blue")
df_colour <- data.frame(Nationality, colour)

# 1778 was the year with the most voyages
df <- tracks %>%
  dplyr::filter(YR == 1778) %>%
  dplyr::arrange(my_date) %>%
  dplyr::left_join(df_colour, by = "Nationality")

# set up the days in that year
date_start <- lubridate::as_date('1778-01-02') # start on day 2 so we have some trails
date_end <- lubridate::as_date('1778-12-31')
my_dates <- seq(date_start, date_end, by = 'days')

unique_codes <- unique(df$ShipName)

for (ts in seq_along(my_dates)) { 
  cutoff_date <- my_dates[ts]

  # the track behind each vessel
  df_tracks <- df %>%
    dplyr::filter(my_date <= cutoff_date) %>%
    dplyr::arrange(my_date)

  # the current position of each vessel
  df_current_positions <- df %>%
    dplyr::group_by(ShipName) %>%
    dplyr::arrange(my_date, .by_group = TRUE) %>%
    dplyr::filter(my_date <= cutoff_date) %>%
    dplyr::slice_tail(n = 1)

  tracks_list <- list()

  for (i in 1:length(unique_codes)) {
    track <- df_tracks %>%
      dplyr::filter(ShipName == unique_codes[i]) %>%
      mutate(
        x = sinpi(longitude / 180) * cospi(latitude / 180),
        y = sinpi(latitude / 180),
        z = cospi(longitude / 180) * cospi(latitude / 180)
      )

    if (nrow(track) > 1) {
      print(track$colour)
      my_colour = track$colour[1]
      tracks_list[[i]] = track %>%
        dplyr::select(x, y, z)  %>%
        raster::as.matrix() %>%
        rayrender::path(
          material = diffuse(color = my_colour),
          width = 0.001,
          type = "flat",
          straight = FALSE
        )
    } else {
      tracks_list[[i]] = NULL
    }
  }

  all_tracks_ray = do.call(rbind, tracks_list)

  initial_objects <-
    rayrender::group_objects(all_tracks_ray, scale = c(1, 1, 1) * 1.0002) %>%
    rayrender::add_object(rayrender::sphere(
      radius = 1,
      material = rayrender::diffuse(image_texture = image_texture_path),
      angle = c(0, -90, 0)
    ))

  for (row in 1:nrow(df_current_positions)) {
    initial_objects <- initial_objects %>%
      rayrender::add_object(
        rayrender::sphere(
          x = sinpi(df_current_positions[row, ]$longitude / 180) * cospi(df_current_positions[row, ]$latitude / 180),
          y = sinpi(df_current_positions[row, ]$latitude / 180),
          z = cospi(df_current_positions[row, ]$longitude / 180) * cospi(df_current_positions[row, ]$latitude / 180),
          radius = 0.005,
          material = rayrender::diffuse(color = df_current_positions[row, ]$colour)
        )
      )
  }

  initial_objects %>%
    rayrender::group_objects(angle = c(0, 30, 0)) %>%
    rayrender::add_object(sphere(
      y = 2.5,
      z = 8,
      x = 2.5,
      material = rayrender::light(intensity = 80, color = "lightblue")
    )) %>%
    rayrender::add_object(sphere(
      y = 5,
      z = 5,
      x = -5,
      material = rayrender::light(intensity = 10, color = "orange")
    )) %>%
    rayrender::add_object(sphere(
      y = -10,
      material = rayrender::light(intensity = 3, color = "white")
    )) %>%
    rayrender::render_scene(
      samples = 200,
      width = 1200,
      height = 1200,
      fov = 0,
      aperture = 0,
      ortho_dimensions = c(2.3, 2.3),
      sample_method = "sobol_blue",
      verbose = TRUE,
      filename = sprintf(glue::glue(output_path,"frame%d.png"),
        ts
      )
    )
}

# Add whatever annotations you want to each frame, then magick into mp4
output_mp4 = 'cliwoc.mp4'
img_frames <- paste0(output_path, "frame", seq_along(my_dates), ".png")
magick::image_write_video(magick::image_read(img_frames), path = output_mp4, framerate = 20)