dashboard.Rmd

---
output:
  flexdashboard::flex_dashboard:
    orientation: rows
    vertical_layout: fill
    theme: yeti
    css: "style.css"
    source_code: "https://github.com/easystats/dashboard"
params:
  title:
    label: Title of report
    value: Easystats dashboard
    input: text
  dashboard_start: 
    label: Start date of report
    value: !r lubridate::today() - lubridate::ddays(90)
    input: date
  orgs:
    label: GitHub organizations
    value: easystats
    input: text
  privacy:
    label: Repository Privacy
    value: PUBLIC
    choices: [PUBLIC, PRIVATE, BOTH]
title: "`r params$title`"	
date: "Last updated: `r as.character(format(Sys.time()))`"
---

```{r setup, include=FALSE, message=FALSE, warning=FALSE}
library(cranlogs)
library(htmltools)
library(httr2)
library(flexdashboard)
library(emo)
library(gh)
library(tidyverse)
# remotes::install_github("ThinkR-open/tidyversedashboard", ref = "zero-issues")
library(reactable)
library(fontawesome)
library(tidyversedashboard)
library(xml2)

options(repos = c(CRAN = "https://cloud.r-project.org"))

gh_colors <- list(
  green = "#2cbe4e",
  red = "#CB2434",
  purple = "#6f42c1"
)
dashboard_start <- params$dashboard_start
dashboard_duration <- format(today() - dashboard_start, format = "%d")
orgs <- scan(text = params$orgs, what = "character", sep = ",", strip.white = TRUE, quiet = TRUE)
privacy <- normalize_privacy(params$privacy)

main_repos <- c(
  "bayestestR", "correlation", "datawizard", "easystats", "effectsize", "insight",
  "modelbased", "parameters", "performance", "report", "see"
)
```

```{r remaining, message=FALSE}
#' Wait if required rate is above remaining one
#'
#' @param required Required amount of points you need for the next step
#' When using the built-in GITHUB_TOKEN in GitHub Actions, the rate limit is 1,000 requests per hour per repository
wait_for_rate <- function(required = 100) {
  # Rate limit ----
  ratelimit <- "query {
  viewer {
    login
  }
  rateLimit {
    limit
    cost
    remaining
    resetAt
  }
}"

  rate_value <- gh::gh_gql(ratelimit)

  message("Rate value:", rate_value)

  if (rate_value[[1]]$rateLimit$remaining < required) {
    # remaining seconds
    remaining <- round(as.numeric(as.duration(as_datetime(rate_value[[1]]$rateLimit$resetAt) - now())))

    message(paste("Let's wait a little", round(remaining / 60), "minutes"))
    Sys.sleep(remaining)
  } else {
    message("Rate's good")
  }
}
```



Overview
========

```{r repo_stats, echo = FALSE, message=FALSE}
# Requires ~700 points for rate limitation
wait_for_rate(650)

# Function to obtain details about each package (version, deps...)
row_details <- function(index) {
  pkg <- packageDescription(main_repos[index])
  urls <- unlist(strsplit(gsub(",", " , ", pkg$URL[1], perl = TRUE), "[ \n]"))
  pkg$Author <- gsub("\\s*\\([^\\)]+\\)", "", pkg$Author)

  pkg_field <- function(name, ...) {
    if (any(is.na(...))) {
      NULL
    } else {
      tagList(div(class = "detail-label", name), ...)
    }
  }

  detail <- div(
    class = "package-detail",
    div(class = "detail-header", pkg$Package, span(class = "detail-title", pkg$Title)),
    div(class = "detail-description", pkg$Description),
    pkg_field("Version", pkg$Version),
    pkg_field("Depends", pkg$Depends),
    pkg_field("Imports", pkg$Imports),
    pkg_field("Suggests", pkg$Suggests),
    pkg_field("Author", pkg$Author),
    pkg_field("License", pkg$License),
    pkg_field("URL", lapply(urls, function(url) {
      if (grepl("https?://", url)) {
        tags$a(href = url, url)
      } else if (identical(url, ",")) {
        ", "
      } else {
        url
      }
    }))
  )

  detail
}

# Function to get info on notes, warnings and errors from CRAN checks
cran_checks <- function(pkg) {
  url <- sprintf("https://cloud.r-project.org/web/checks/check_results_%s.html", pkg)
  html_page <- xml2::read_html(url)
  html_table <- rvest::html_table(html_page)
  check_status <- html_table[[1]]$Status

  if (all(check_status == "OK")) {
    return("<span style=\"color: #00b300\">OK</span>")
  }

  n_notes <- length(which(check_status == "NOTE"))
  n_warnings <- length(which(check_status %in% c("WARN", "WARNING")))
  n_errors <- length(which(check_status == "ERROR"))

  if (n_notes > 0) {
    note <- paste0("<span style=\"color: blue\">", n_notes, " Note", if (n_notes > 1) "s" else "", "</span>")
  } else {
    note <- NULL
  }

  if (n_warnings > 0) {
    warning <- paste0("<span style=\"color: orange\">", n_warnings, " Warning", if (n_warnings > 1) "s" else "", "</span>")
  } else {
    warning <- NULL
  }

  if (n_errors > 0) {
    error <- paste0("<span style=\"color: red\">", n_errors, " Error", if (n_errors > 1) "s" else "", "</span>")
  } else {
    error <- NULL
  }

  out <- paste0(
    "<a href=\"", url, "\" target=\"_blank\">",
    datawizard::text_concatenate(c(note, warning, error), last = ", "),
    "</a></em><br>"
  )

  out
}

# Get data on each repo
repo_data <- map(orgs, org_data, privacy)

repo_summary <- map_dfr(repo_data, "summary") %>%
  distinct(owner, repo, .keep_all = TRUE) %>%
  filter(tolower(owner) %in% tolower(orgs), repo %in% main_repos) %>%
  select(-owner, -description, -p1, -features, -bugs, -unlabeled)

### Find last published date on CRAN for each repo
last_published_cran <- data.frame(
  repo = repo_summary$repo
)

for (i in seq_along(repo_summary$repo)) {
  cran_page <- readLines(paste0("https://cran.r-project.org/web/packages/", repo_summary$repo[i], "/index.html"))
  date <- cran_page[which(startsWith(cran_page, "<td>Published")) + 1]
  date <- gsub("<td>", "", date)
  date <- gsub("</td>", "", date)
  last_published_cran[i, "last_published_cran"] <- date
  n_weeks <- round(as.vector(difftime(as.POSIXct(Sys.Date()), as.POSIXct(date), units = "weeks")), 1)
  if (n_weeks <= 4) {
    color <- "#00b300"
  } else if (n_weeks > 4 && n_weeks <= 8) {
    color <- "orange"
  } else {
    color <- "red"
  }
  n_weeks <- paste("<span style=\"color:", color, "\">", n_weeks, "</span>")
  last_published_cran[i, "n_weeks"] <- n_weeks
  last_published_cran[i, "checks"] <- cran_checks(repo_summary$repo[i])
}

### Get number of downloads in last 7 days
# downloads <- cran_downloads(when = "last-week", packages = unique(repo_summary$repo)) %>%
#   group_by(package) %>%
#   mutate(downloads_last_week = sum(count)) %>%
#   ungroup() %>%
#   select(package, downloads_last_week) %>%
#   distinct()
downloads <- data.frame(
  package = repo_summary$repo,
  `Number of downloads` = paste0(
    '<a rel="noopener" target="_blank" href="https://cranlogs.r-pkg.org/badges/grand-total/', repo_summary$repo, '"><img src="https://cranlogs.r-pkg.org/badges/grand-total/', repo_summary$repo, '"></a>'
  ),
  check.names = FALSE
)


### Get coverage info
coverage <- data.frame(
  repo = repo_summary$repo,
  coverage_badge = coverage_status_badge("easystats", repo_summary$repo),
  check_badge = github_status_badge("easystats", repo_summary$repo)
)


### Clean data and make table
repo_summary <- left_join(repo_summary, downloads, by = c("repo" = "package")) %>%
  left_join(last_published_cran, by = "repo") %>%
  left_join(coverage, by = "repo") %>%
  select(repo, last_published_cran, watchers, open_issues, prs, everything()) %>%
  select(-default_branch) %>%
  relocate(n_weeks, checks, .after = last_published_cran) %>%
  rename(
    Repository = repo,
    "Last published on CRAN" = last_published_cran,
    "Weeks since last CRAN update" = n_weeks,
    "CRAN checks" = checks,
    "Open PRs" = prs,
    Stars = watchers,
    "Open issues" = open_issues,
    # "Downloads last week" = downloads_last_week,
    Coverage = coverage_badge,
    `R CMD check` = check_badge
  ) %>%
  arrange(Repository)

if ("topics" %in% colnames(repo_summary)) {
  repo_summary <- select(repo_summary, -topics)
}

reactable(
  repo_summary,
  defaultPageSize = nrow(repo_summary),
  defaultColDef = colDef(
    align = "center",
    minWidth = 70
  ),
  columns = list(
    `Downloads last week` = colDef(
      format = colFormat(separators = TRUE)
    ),
    `Weeks since last CRAN update` = colDef(
      html = TRUE
    ),
    `Number of downloads` = colDef(
      html = TRUE
    ),
    `CRAN checks` = colDef(
      html = TRUE
    ),
    Coverage = colDef(
      html = TRUE,
      cell = JS("(cellInfo) => cellInfo.value")
    ),
    `R CMD check` = colDef(
      minWidth = 100,
      html = TRUE,
      cell = JS("(cellInfo) => cellInfo.value")
    )
  ),
  details = row_details,
  theme = reactableTheme(
    headerStyle = list(
      "&:hover[aria-sort]" = list(background = "hsl(0, 0%, 96%)"),
      "&[aria-sort='ascending'], &[aria-sort='descending']" = list(background = "hsl(0, 0%, 96%)"),
      borderColor = "#555"
    ),
    style = list(
      fontFamily = "Work Sans, Helvetica Neue, Helvetica, Arial, sans-serif",
      fontSize = "1.25rem",
      "a" = list(
        color = "#000000",
        textDecoration = "none",
        "&:hover, &:focus" = list(
          textDecoration = "underline",
          textDecorationThickness = "1px"
        )
      ),
      ".number" = list(
        color = "#666666",
        fontFamily = "Source Code Pro, Consolas, Monaco, monospace"
      ),
      ".tag" = list(
        padding = "0.125rem 0.25rem",
        color = "hsl(0, 0%, 40%)",
        fontSize = "1.25rem",
        border = "1px solid hsl(0, 0%, 24%)",
        borderRadius = "2px",
        textTransform = "uppercase"
      )
    )
  ),
  class = "packages-table"
)
```

<!-- Workflow status -->
<!-- =========== -->

```{r workflow_status_helpers, include = FALSE, eval=FALSE}
workflow_status <- readRDS("badge_url_data.rds") %>% as_tibble()

extract_workflow_status <- function(url) {
  response <- httr::GET(url)

  # check response status
  if (httr::http_status(response)$category != "Success") {
    stop("Failed to fetch workflow status badge. Check your credentials and URL.")
  }

  content <- httr::content(response, as = "text")

  if (grepl("passing", content)) {
    return("✅")
  } else if (grepl("failing", content)) {
    return("❌")
  } else {
    return("❔")
  }
}

update_url_string_with_status <- function(html_string) {
  # Parse the HTML string
  parsed_html <- xml2::read_html(html_string)

  # Extract the href attribute value
  href_value <- xml2::xml_attr(xml2::xml_find_first(parsed_html, "//img"), "src")

  replacement_text <- extract_workflow_status(href_value)

  # Regex to match the image HTML element
  img_regex <- "<img[^>]*>"

  modified_string <- gsub(img_regex, replacement_text, html_string)

  return(modified_string)
}

workflow_status <-
  workflow_status %>%
  dplyr::rowwise() %>%
  dplyr::mutate(dplyr::across(.cols = -dplyr::matches("workflow"), update_url_string_with_status))
```

```{r workflow_status, eval=FALSE}
reactable(
  workflow_status,
  defaultColDef = colDef(
    align = "center",
    html = TRUE
  ),
  highlight = TRUE,
  defaultPageSize = 25L,
  resizable = TRUE
)
```


Open issues
===========

```{r issue_summary}
substitute_emoji <- function(x) {
  m <- gregexpr(":[^[:space:]]+:", x)
  regmatches(x, m) <- lapply(
    regmatches(x, m),
    function(xx) map_chr(gsub(":", "", xx), purrr::possibly(emo::ji, ""))
  )
  x
}

issues <- map_dfr(repo_data, "issues") %>%
  distinct(owner, repo, issue, .keep_all = TRUE) %>%
  filter(tolower(owner) %in% tolower(orgs)) %>%
  select(-updated)

issues_2 <- list()
for (i in main_repos) {
  issues_2[[i]] <- gh::gh("/repos/:repo/issues?state=open", repo = paste0("easystats/", i)) %>%
    tibble(
      repo = i,
      author = map(., "user") %>% map_chr(., "login"),
      created = map_chr(., "created_at"),
      updated = map_chr(., "updated_at"),
      issue = map_int(., "number")
    ) %>%
    select(-1)
}
issues_2 <- do.call(rbind, issues_2)

# linkify the titles, and replace emoji
issue_table <- issues %>%
  left_join(issues_2, by = c("repo", "issue")) %>%
  mutate(
    title = glue::glue('<a rel="noopener" target="_blank" href="https://github.com/{owner}/{repo}/issues/{issue}">{title}</a>'),
    # Modify issue after title
    issue = glue::glue('<a rel="noopener" target="_blank" href="https://github.com/{owner}/{repo}/issues/{issue}">{issue}</a>'),
    labels = substitute_emoji(map_chr(labels, paste, collapse = ", "))
  ) %>%
  select(repo, issue, title, author, created, updated, labels) %>%
  rename(
    Repository = repo,
    Issue = issue,
    Author = author,
    Title = title,
    Created = created,
    Updated = updated,
    Labels = labels
  )

issue_table <- issue_table[order(issue_table$Updated, decreasing = TRUE), ]

reactable(
  issue_table,
  searchable = TRUE,
  pagination = FALSE,
  highlight = TRUE,
  filterable = TRUE,
  columns = list(
    Issue = colDef(html = TRUE),
    Title = colDef(html = TRUE)
  ),
  theme = reactableTheme(
    headerStyle = list(
      "&:hover[aria-sort]" = list(background = "hsl(0, 0%, 96%)"),
      "&[aria-sort='ascending'], &[aria-sort='descending']" = list(background = "hsl(0, 0%, 96%)"),
      borderColor = "#555"
    ),
    style = list(
      fontFamily = "Work Sans, Helvetica Neue, Helvetica, Arial, sans-serif",
      fontSize = "1.25rem",
      "a" = list(
        color = "#000000",
        textDecoration = "none",
        "&:hover, &:focus" = list(
          textDecoration = "underline",
          textDecorationThickness = "1px"
        )
      ),
      ".number" = list(
        color = "#666666",
        fontFamily = "Source Code Pro, Consolas, Monaco, monospace"
      ),
      ".tag" = list(
        padding = "0.125rem 0.25rem",
        color = "hsl(0, 0%, 40%)",
        fontSize = "1.25rem",
        border = "1px solid hsl(0, 0%, 24%)",
        borderRadius = "2px",
        textTransform = "uppercase"
      )
    )
  )
)
```


Open PRs
===========

```{r pr_summary}
prs <- list()
for (i in main_repos) {
  tmp <- gh::gh("/repos/:repo/pulls?state=OPEN", repo = paste0("easystats/", i))
  if (length(tmp) == 0) next

  for (j in seq_along(tmp)) {
    prs[[paste0(i, "_", j)]] <- tibble(
      repo = i,
      issue = tmp[[j]]$number,
      title = tmp[[j]]$title,
      url = tmp[[j]]$html_url,
      author = tmp[[j]]$user$login,
      created = tmp[[j]]$created_at,
      updated = tmp[[j]]$updated_at,
      draft = as.logical(tmp[[j]]$draft),
      review_requested = as.logical(length(tmp[[j]]$requested_reviewers) > 0)
    )
  }
}
prs <- do.call(rbind, prs)


pr_table <- prs %>%
  mutate(
    title = paste0("<a href='", url, "' target = '_blank'>", title, "</a>"),
    draft = ifelse(draft, "Yes", "No"),
    review_requested = ifelse(review_requested, "Yes", "No")
  ) %>%
  select(repo, issue, title, author, created, updated, draft, review_requested) %>%
  rename(
    Repository = repo,
    PR = issue,
    Title = title,
    Author = author,
    Created = created,
    Updated = updated,
    Draft = draft,
    "Review requested" = review_requested
  )

pr_table <- pr_table[order(pr_table$Updated, decreasing = TRUE), ]

reactable(
  pr_table,
  searchable = TRUE,
  pagination = FALSE,
  highlight = TRUE,
  filterable = TRUE,
  columns = list(
    Title = colDef(html = TRUE)
  ),
  theme = reactableTheme(
    headerStyle = list(
      "&:hover[aria-sort]" = list(background = "hsl(0, 0%, 96%)"),
      "&[aria-sort='ascending'], &[aria-sort='descending']" = list(background = "hsl(0, 0%, 96%)"),
      borderColor = "#555"
    ),
    style = list(
      fontFamily = "Work Sans, Helvetica Neue, Helvetica, Arial, sans-serif",
      fontSize = "1.25rem",
      "a" = list(
        color = "#000000",
        textDecoration = "none",
        "&:hover, &:focus" = list(
          textDecoration = "underline",
          textDecorationThickness = "1px"
        )
      ),
      ".number" = list(
        color = "#666666",
        fontFamily = "Source Code Pro, Consolas, Monaco, monospace"
      ),
      ".tag" = list(
        padding = "0.125rem 0.25rem",
        color = "hsl(0, 0%, 40%)",
        fontSize = "1.25rem",
        border = "1px solid hsl(0, 0%, 24%)",
        borderRadius = "2px",
        textTransform = "uppercase"
      )
    )
  )
)
```