Scenario Gallery

boids4R includes named scenarios for common swarm motifs: compact schools, obstacle corridors, predator avoidance, and 3D murmurations. The examples below run each scenario with a fixed seed, then summarize the recorded frames with plain data-frame operations.

library(boids4R)

gallery <- data.frame(
  scenario = c(
    "schooling_2d",
    "obstacle_corridor_2d",
    "predator_avoidance_2d",
    "murmuration_3d",
    "mixed_species_3d"
  ),
  n = c(120L, 120L, 120L, 160L, 150L),
  steps = c(60L, 70L, 70L, 55L, 55L),
  record_every = c(5L, 5L, 5L, 5L, 5L),
  seed = c(111L, 112L, 113L, 114L, 115L),
  stringsAsFactors = FALSE
)

sims <- setNames(
  lapply(seq_len(nrow(gallery)), function(i) {
    boids_scenario(
      gallery$scenario[i],
      n = gallery$n[i],
      steps = gallery$steps[i],
      record_every = gallery$record_every[i],
      seed = gallery$seed[i]
    )
  }),
  gallery$scenario
)

Compare recorded swarms

A simulation stores every recorded boid as one row per frame. This makes it straightforward to compute summaries without any renderer-specific object model.

final_frame <- function(sim) {
  frames <- as.data.frame(sim)
  frames[frames$frame == max(frames$frame), , drop = FALSE]
}

mean_spread <- function(frame) {
  center <- colMeans(frame[, c("x", "y", "z"), drop = FALSE])
  distance <- sqrt(
    (frame$x - center["x"])^2 +
      (frame$y - center["y"])^2 +
      (frame$z - center["z"])^2
  )
  mean(distance)
}

mean_nearest_neighbor <- function(frame) {
  if (nrow(frame) < 2L) return(NA_real_)
  coords <- as.matrix(frame[, c("x", "y", "z"), drop = FALSE])
  distances <- as.matrix(stats::dist(coords))
  diag(distances) <- NA_real_
  mean(apply(distances, 1L, min, na.rm = TRUE), na.rm = TRUE)
}

scenario_summary <- function(sim) {
  frames <- as.data.frame(sim)
  final <- final_frame(sim)
  data.frame(
    scenario = sim$scenario,
    dimension = sim$dimension,
    boids = length(unique(final$id)),
    species = paste(sort(unique(final$species)), collapse = ", "),
    recorded_frames = length(unique(frames$frame)),
    mean_final_speed = round(mean(final$speed), 3),
    mean_final_spread = round(mean_spread(final), 3),
    mean_nearest_neighbor = round(mean_nearest_neighbor(final), 3),
    stringsAsFactors = FALSE
  )
}

do.call(rbind, lapply(sims, scenario_summary))
#>                                    scenario dimension boids           species
#> schooling_2d                   schooling_2d        2d   120              boid
#> obstacle_corridor_2d   obstacle_corridor_2d        2d   120              boid
#> predator_avoidance_2d predator_avoidance_2d        2d   120     school, scout
#> murmuration_3d               murmuration_3d        3d   160              boid
#> mixed_species_3d           mixed_species_3d        3d   150 kite, swift, tern
#>                       recorded_frames mean_final_speed mean_final_spread
#> schooling_2d                       13            1.185             1.413
#> obstacle_corridor_2d               15            0.920             1.468
#> predator_avoidance_2d              15            0.932             1.757
#> murmuration_3d                     12            1.188             1.478
#> mixed_species_3d                   12            1.192             1.700
#>                       mean_nearest_neighbor
#> schooling_2d                          0.174
#> obstacle_corridor_2d                  0.150
#> predator_avoidance_2d                 0.139
#> murmuration_3d                        0.255
#> mixed_species_3d                      0.308

The same summaries can be split by species. This is useful for mixed flocks or cases where scouts and schooling agents are initialized together.

species_speed <- do.call(rbind, lapply(sims, function(sim) {
  final <- final_frame(sim)
  out <- stats::aggregate(speed ~ species, final, mean)
  out$scenario <- sim$scenario
  out$mean_final_speed <- round(out$speed, 3)
  out[, c("scenario", "species", "mean_final_speed")]
}))

species_speed
#>                                      scenario species mean_final_speed
#> schooling_2d                     schooling_2d    boid            1.185
#> obstacle_corridor_2d     obstacle_corridor_2d    boid            0.920
#> predator_avoidance_2d.1 predator_avoidance_2d  school            0.936
#> predator_avoidance_2d.2 predator_avoidance_2d   scout            0.928
#> murmuration_3d                 murmuration_3d    boid            1.188
#> mixed_species_3d.1           mixed_species_3d    kite            1.198
#> mixed_species_3d.2           mixed_species_3d   swift            1.197
#> mixed_species_3d.3           mixed_species_3d    tern            1.181

Snapshot plots

The frame table is also enough for quick base-R diagnostics. The helper below draws a final-frame x/y projection, including obstacles, attractors, and predator influence radii when the scenario defines them. For 3D scenarios this is an overhead projection; point size varies with the z coordinate.

scenario_palette <- function(species) {
  keys <- sort(unique(species))
  stats::setNames(grDevices::hcl.colors(length(keys), "Dark 3"), keys)
}

draw_world_marks <- function(world) {
  if (nrow(world$obstacles)) {
    graphics::symbols(
      world$obstacles$x, world$obstacles$y,
      circles = world$obstacles$radius,
      inches = FALSE,
      add = TRUE,
      fg = "gray45",
      bg = grDevices::adjustcolor("gray70", alpha.f = 0.28)
    )
  }
  if (nrow(world$predators)) {
    graphics::symbols(
      world$predators$x, world$predators$y,
      circles = world$predators$radius,
      inches = FALSE,
      add = TRUE,
      fg = "#B24C63",
      lty = 2
    )
    graphics::points(world$predators$x, world$predators$y, pch = 4, col = "#B24C63", lwd = 2)
  }
  if (nrow(world$attractors)) {
    graphics::points(world$attractors$x, world$attractors$y, pch = 8, col = "#2F7E79", lwd = 2)
  }
}

draw_snapshot <- function(sim) {
  final <- final_frame(sim)
  world <- sim$world
  palette <- scenario_palette(final$species)
  z_span <- diff(range(final$z))
  cex <- if (z_span > 0) 0.45 + 0.85 * (final$z - min(final$z)) / z_span else 0.75

  graphics::plot(
    final$x, final$y,
    xlim = world$bounds["x", ],
    ylim = world$bounds["y", ],
    asp = 1,
    xlab = "x",
    ylab = "y",
    main = sim$scenario,
    col = palette[final$species],
    pch = 16,
    cex = cex
  )
  draw_world_marks(world)
  graphics::legend(
    "topright",
    legend = names(palette),
    col = palette,
    pch = 16,
    bty = "n",
    cex = 0.75
  )
}

old_par <- graphics::par(mfrow = c(2, 2), mar = c(3, 3, 3, 1))
draw_snapshot(sims$schooling_2d)
draw_snapshot(sims$obstacle_corridor_2d)
draw_snapshot(sims$predator_avoidance_2d)
draw_snapshot(sims$murmuration_3d)

graphics::par(old_par)

Hand off to ggWebGL

When ggWebGL 0.4.0 or later is installed, the same simulation object can be converted into a timeline-aware WebGL specification. This step is optional and leaves the core simulation object renderer-neutral.

if (requireNamespace("ggWebGL", quietly = TRUE) &&
    utils::packageVersion("ggWebGL") >= "0.4.0") {
  ggWebGL::ggWebGL(
    as_ggwebgl_spec(sims$mixed_species_3d, vector_every = 12),
    height = 520
  )
}