ART Coverage Performance visualization, Reimagined

The Global Fund tracks performance across hundreds of grants worldwide. This note pulls live data from the API and borrows a trick from psychometrics — the Wright Map — to show not just distribution of performance, but also how much countries contribute to the global target.

The Global Fund Data Service

---

Extract The Global Fund programmatic data

We pull two endpoints: Grants (to link grants to geographies) and AllProgrammaticIndicators (filtered to ART coverage, national-level, most recent reporting period ending in 2023).

library( httr2 )
library( jsonlite )
library( dplyr )

Attaching package: 'dplyr'

The following objects are masked from 'package:stats':

    filter, lag

The following objects are masked from 'package:base':

    intersect, setdiff, setequal, union

library( ggplot2 )
library( patchwork )

df_grants <- 
  request("https://fetch.theglobalfund.org/v4.1/odata/Grants") %>% 
    req_url_query() %>% 
    req_perform() %>% 
    resp_body_string() %>% 
    fromJSON(flatten = TRUE) %>% 
    .[["value"]] %>% 
    select( grantId = id , geographyId , differentiationCategory ) %>% 
    distinct( )

df_geo <- 
  request("https://fetch.theglobalfund.org/v4.1/odata/Geographies") %>% 
  req_url_query() %>% 
  req_perform() %>% 
  resp_body_string() %>% 
  fromJSON(flatten = TRUE) %>% 
  .[["value"]] %>%
  select( geographyId = id , code , name )

df_geo_grant <- 
  df_grants %>% 
  left_join( df_geo , by = c( "geographyId" ))


httr_RnT <- 
  request("https://fetch.theglobalfund.org/v4.2/odata/AllProgrammaticIndicators") %>% 
  req_url_query(
    `$filter` = "programmaticDataSet eq 'IMPLEMENTATION_PERIOD_TARGETS_RESULTS' AND valueType eq 'Coverage / Output indicator' AND performance ne null AND endDate gt 2019-12-31T00:00:00Z" ,
    `$expand` = "implementationPeriod,activityArea"
  ) %>% 
  req_perform()


df_RnT <- 
  httr_RnT %>%
  resp_body_string() %>% 
  fromJSON(flatten = TRUE) %>% 
  .[["value"]]



df_RnT_ <- 
  df_RnT %>% 
    left_join( 
      df_geo_grant , by = c("implementationPeriod.grantId" = "grantId" )
    )  %>%
  filter( !is.na( targetValueNumerator ) ) %>% 
  mutate( endDate = lubridate::ymd_hms( endDate ) ,
          startDate = lubridate::ymd_hms( startDate ) ) %>%
  
  group_by( code ) %>%
  arrange( startDate ) %>%
  mutate( is_last_rp = startDate == max( startDate) ) %>% 
  ungroup() %>% 
  filter(   is_last_rp &
              endDate >= lubridate::ymd( "2023-07-01") & endDate <= lubridate::ymd( "2023-12-31") & 
              geographicCoverage == "National, 100% of national program target" &
              indicatorName == "Percentage of people on ART among all people living with HIV at the end of the reporting period"
            
  ) %>% 
  select( country = name , iso3 = code , endDate , targetValueNumerator , indicatorName , performance ) %>% 
  distinct()

Preprocess for plots

The Wright Map logic: countries are binned by performance, then stacked within each bin. Label size scales with targetValueNumerator — so a large label means a large national target. Bigger text = more people.

h            <- hist(df_RnT_$performance, plot = FALSE)
bin_idx      <- findInterval(df_RnT_$performance, h$breaks, rightmost.closed = TRUE)
bin_idx      <- pmin(bin_idx, length(h$counts))
x            <- h$mids[bin_idx]
y            <- h$counts[bin_idx]


range_min_max <- function(x, minimum, maximum){
  out <- (maximum - minimum) * ( (x - min(x)) / (max(x) - min(x)) ) + minimum
}



df_RnT_00 <- 
  df_RnT_ %>% 
  mutate(x, y) %>%
  group_by( x ) %>%
  mutate( y_pos    = min_rank(desc(targetValueNumerator))) %>% 
  ungroup() %>% 
  mutate( txt_size = range_min_max( targetValueNumerator , 6 , 15 ))

plt_1 <- 
  ggplot() +
  geom_col( aes( h$mids , h$counts , fill = "red" , alpha = 0.5)) +
  geom_text( data = df_RnT_00 , aes( x = x , y = y_pos , size = txt_size , label = iso3) ) +
  scale_radius(range = c(2,6)) +
  scale_x_continuous(limits = c(0, 1.50), labels = scales::label_percent()) +
  ylab( "Count" ) + xlab( "" ) +
  theme_bw() +                          
  theme(
    legend.position = "none",           
    axis.text = element_text(size = 14),
    axis.title = element_text(size = 16)
  )


plt_2 <- 
  df_RnT_00 %>% 
  ggplot() +
  geom_boxplot( aes(performance, fill = "red" )) +
  geom_jitter( aes(performance, 0 ) , size = 2 ) + 
  ylim(c(-0.8, 0.8)) +
  scale_x_continuous(limits = c(0, 1.50), labels = scales::label_percent()) +
  xlab("Performance (%)") +
  ylab("") +
  theme_bw() +                          
  theme(
    legend.position = "none",   
    axis.text.y  = element_blank(),
    axis.ticks.y = element_blank(),
    axis.text = element_text(size = 14),
    axis.title = element_text(size = 16)
  )

Plot

The histogram shows the distribution of performance across countries. The boxplot below anchors the spread. Together they answer three questions at once: Where do countries cluster? Who are the outliers? And how much does each country’s result actually weigh?

plt_1 / plt_2 +
  plot_layout( heights = c(5, 1))