software.qmd

---
title: "Software"
description: |
  R packages and other software developed by the group
---

Reusable tools and packages developed by the group. See also our [ongoing projects](projects.qmd) and [publications](pubs.qmd).

Most packages are on CRAN. The rest can be installed from our
[r-universe](https://epiforecasts.r-universe.dev):

```r
install.packages(
  "packagename",
  repos = c("https://epiforecasts.r-universe.dev", getOption("repos"))
)
```

```{r setup, include=FALSE}
knitr::opts_chunk$set(echo = FALSE, message = FALSE, warning = FALSE)
library(magrittr)

# Hide software not updated in this many months (set to NULL to disable)
stale_months <- 24
```

```{r load-stats}
# Weekly download figures, collected by .github/workflows/update-stats.yaml.
# Absent until that job has run at least once, so treat it as optional.
downloads_by_package <- list()

## The weekly job records to the stats-data branch. Read from there, falling
## back to a local file so the page still renders before the branch exists or
## if the fetch fails.
stats_url <- paste0(
  "https://raw.githubusercontent.com/epiforecasts/epiforecasts.github.io/",
  "stats-data/_data/package-stats.csv"
)
stats <- tryCatch(
  read.csv(stats_url, stringsAsFactors = FALSE),
  error = function(err) NULL
)
if (is.null(stats) && file.exists("_data/package-stats.csv")) {
  stats <- read.csv("_data/package-stats.csv", stringsAsFactors = FALSE)
}

if (!is.null(stats) && nrow(stats) > 0) {
  # Each repository's most recent figure: a week where cranlogs is
  # unreachable writes NAs for everything, and the previous week's figures
  # are still usable. Bounded so a long outage shows nothing rather than
  # something months out of date.
  stats <- stats[!is.na(stats$downloads_last_month), ]
  stats <- stats[as.Date(stats$date) > Sys.Date() - 35, ]
  stats <- stats[order(stats$date, decreasing = TRUE), ]
  stats <- stats[!duplicated(tolower(stats$repo)), ]
  # keyed by repository, not package name: the two can differ and the
  # repository is what both sides can agree on
  downloads_by_package <- split(stats$downloads_last_month, tolower(stats$repo))
}
```

```{r load-team}
# Load team members and create lookup by GitHub username
team <- fs::dir_ls("_data/team", regexp = "\\w+\\-\\w+\\.yml") |>
  purrr::map(yaml::read_yaml)

team_by_github <- team %>%
  purrr::keep(~ !is.null(.x$github) && .x$github != "") %>%
  purrr::set_names(purrr::map_chr(., "github"))
```

```{r, results='asis'}
# Helper function to fetch package info from GitHub
fetch_package_info <- function(repo, team_by_github) {
  repo_info <- tryCatch(
    gh::gh("/repos/{repo}", repo = repo),
    error = function(err) list(
      name = basename(repo),
      description = "No description available",
      html_url = paste0("https://github.com/", repo),
      stargazers_count = 0,
      language = NA,
      pushed_at = NA
    )
  )

  contributors <- tryCatch(
    gh::gh("/repos/{repo}/contributors", repo = repo, per_page = 100),
    error = function(err) list()
  )

  team_contributors <- contributors %>%
    purrr::keep(~ .x$login %in% names(team_by_github)) %>%
    purrr::map(function(c) {
      tm <- team_by_github[[c$login]]
      list(
        name = tm$name,
        github = c$login,
        avatar_url = c$avatar_url
      )
    })

  logo_url <- NA_character_
  for (f in c("logo.png", "logo.svg")) {
    hit <- tryCatch(
      gh::gh("/repos/{repo}/contents/man/figures/{f}", repo = repo, f = f),
      error = function(err) NULL
    )
    if (!is.null(hit$download_url)) {
      logo_url <- hit$download_url
      break
    }
  }

  list(
    Package = repo_info$name,
    logo_url = logo_url,
    description = repo_info$description %||% "No description available",
    github_url = repo_info$html_url,
    stars = repo_info$stargazers_count %||% 0,
    language = repo_info$language,
    updated = if (!is.null(repo_info$pushed_at)) substr(repo_info$pushed_at, 1, 10) else NA,
    team_contributors = team_contributors
  )
}

# Get packages from r-universe
pkg_descriptions <- jsonlite::fromJSON("https://epiforecasts.r-universe.dev/api/packages")
extra_metadata <- jsonlite::read_json("https://github.com/epiforecasts/universe/raw/main/packages.json") %>%
  dplyr::bind_rows() %>%
  dplyr::mutate(
    Package = package,
    display_website = display_website & !is.na(display_website),
    .keep = "unused"
  )

universe_packages <- pkg_descriptions %>%
  dplyr::left_join(extra_metadata, by = "Package") %>%
  dplyr::filter(display_website) %>%
  split(rownames(.)) %>%
  purrr::map(unlist) %>%
  purrr::map(function(e) {
    repo <- paste0(e[["_owner"]], "/", e[["Package"]])
    fetch_package_info(repo, team_by_github)
  })

# Get extra packages from YAML
extras <- yaml::read_yaml("_data/software-extras.yml")
extra_packages <- purrr::map(extras, function(e) {
  info <- fetch_package_info(e$repo, team_by_github)
  # marks a package belonging to a separate community project
  info$part_of <- e$part_of
  # listed here rather than in the registry, so it is not in our universe
  info$from_extras <- TRUE
  info
})

# Combine, filter stale, and sort by stars
all_packages <- c(universe_packages, extra_packages) %>%
  purrr::keep(~ !is.null(.x)) %>%
  purrr::keep(~ {
    if (is.null(stale_months) || is.na(.x$updated)) return(TRUE)
    as.Date(.x$updated) > Sys.Date() - (stale_months * 30)
  }) %>%
  { .[order(purrr::map_dbl(., "stars"), decreasing = TRUE)] }

# Honeycomb index: every package with a logo, in offset rows so the hexes
# tessellate. Rows alternate between `per_row` and one fewer, which is what
# produces the half-width stagger without any positioning maths.
with_logo <- purrr::keep(all_packages, ~ !is.na(.x$logo_url))

if (length(with_logo) > 0) {
  # Adjacent rows must differ by exactly one hex, which is what offsets them by
  # half a width and makes the shapes interlock. Enumerate the row patterns
  # that satisfy that and sum exactly, preferring a symmetric one so the widest
  # row sits in the middle.
  patterns <- function(total, rows) {
    out <- list()
    for (first in 7:3) {
      steps <- as.matrix(expand.grid(rep(list(c(-1, 1)), rows - 1)))
      for (k in seq_len(nrow(steps))) {
        widths <- cumsum(c(first, steps[k, ]))
        if (sum(widths) == total && min(widths) >= 3) {
          out[[length(out) + 1]] <- as.integer(widths)
        }
      }
    }
    out
  }

  n <- length(with_logo)
  options <- c(patterns(n, 3), patterns(n, 4), patterns(n, 2))
  palindromic <- purrr::keep(options, ~ identical(.x, rev(.x)))

  sizes <- if (length(palindromic) > 0) {
    palindromic[[1]]
  } else if (length(options) > 0) {
    options[[1]]
  } else {
    # nothing interlocks exactly, so fill rows greedily and accept the shape
    widths <- integer(0)
    left <- n
    wide <- FALSE
    while (left > 0) {
      take <- min(if (wide) 6 else 5, left)
      widths <- c(widths, take)
      left <- left - take
      wide <- !wide
    }
    widths
  }

  idx <- 0
  rows <- character(0)
  for (n in sizes) {
    cells <- character(0)
    for (i in seq_len(n)) {
      idx <- idx + 1
      e <- with_logo[[idx]]
      cells <- c(cells, sprintf(
        '<a href="%s" title="%s"><img src="%s" alt="%s"></a>',
        e$github_url, e$Package, e$logo_url, paste(e$Package, "hex logo")
      ))
    }
    rows <- c(rows, paste0(
      '<div class="hex-row">', paste(cells, collapse = ""), '</div>'
    ))
  }

  cat(paste0(
    '<div class="hex-wall">',
    paste(rows, collapse = ""), '</div>\n\n'
  ))
}

# Render each package
all_packages %>%
  purrr::map_chr(function(e) {
    contributors_section <- ""
    if (length(e$team_contributors) > 0) {
      contributor_items <- purrr::map_chr(e$team_contributors, function(c) {
        sprintf(
          '<a href="https://github.com/%s" title="%s"><img src="%s" alt="%s" width="32" height="32"></a>',
          c$github, c$name, c$avatar_url, c$name
        )
      })
      contributors_section <- paste(contributor_items, collapse = " ")
    }

    logo_html <- ""
    if (!is.na(e$logo_url)) {
      logo_html <- sprintf(
        '<div class="pkg-logo"><img src="%s" alt="%s hex logo" loading="lazy"></div>',
        e$logo_url, e$Package
      )
    }

    part_of_html <- ""
    if (!is.null(e$part_of)) {
      part_of_html <- sprintf(
        '<div class="pkg-part-of">Part of <a href="%s">%s</a></div>',
        e$part_of$url, e$part_of$name
      )
    }

    slug <- sub("^https://github.com/", "", e$github_url)
    downloads <- downloads_by_package[[tolower(slug)]]
    # Naming the source matters: a package with no CRAN figure is
    # distributed elsewhere, not unused.
    downloads_text <- if (!is.null(downloads)) {
      paste(
        formatC(downloads, big.mark = ",", format = "d"),
        "CRAN downloads/month"
      )
    } else {
      # Only link where the registry is known. A registry package is served
      # by the epiforecasts universe whatever repo it lives in, so epimixr at
      # sbfnk/epimixr still resolves there. An extras entry could be in any
      # universe or none, and it carries a "Part of" link to its own project
      # already.
      if (isTRUE(e$from_extras)) {
        ""
      } else {
        # single-quoted attribute: substituted into R source
        sprintf(
          "<a href='https://epiforecasts.r-universe.dev/%s'>On r-universe</a>",
          e$Package
        )
      }
    }

    knitr::knit_expand(
      "_software-item.Rmd",
      Package = e$Package,
      downloads_text = downloads_text,
      logo_html = logo_html,
      part_of_html = part_of_html,
      description = e$description,
      github_url = e$github_url,
      language = e$language %||% "",
      updated = e$updated %||% "",
      contributors_section = contributors_section
    )
  }) %>%
  { knitr::knit_child(text = unlist(.), quiet = TRUE) } %>%
  cat(sep = "\n")
```