Skip to contents

Generate IVR/SLF risk tables and other figures

Samuel M. Owens1

2025-08-08

Source: vignettes/160_generate_format_figures.Rmd
160_generate_format_figures.Rmd

Overview

I will create the risk tables to accompany the main risk plots in this vignette. These tables summarize the number of globally important viticultural regions (IVRs) and spotted lanternfly (SLF) populations that fall into each risk category (extreme, high, moderate, low) for both the present (1981-2010) and future (2041-2070) time periods. I will also calculate the proportion of IVRs and SLF populations that experience an increase, decrease, or no change in risk due to climate change by 2055 (the mean year of the future time period).

Setup 

# general tools
library(tidyverse)  #data manipulation
library(here) #making directory pathways easier on different instances
# here() starts at the root folder of this package.
library(devtools)

# spatial data handling
library(terra)
library(tidygeocoder)

# table aesthetics
library(scales)
library(grid)
library(patchwork)
library(formattable)
library(kableExtra)
library(webshot)
library(webshot2)

Note: I will be setting the global options of this document so that only certain code chunks are rendered in the final .html file. I will set the eval = FALSE so that none of the code is re-run (preventing files from being overwritten during knitting) and will simply overwrite this in chunks with plots.

IVR risk table 

IVR_risk_table <- read.csv(file = file.path(here::here(), "vignette-outputs", "data-tables", "IVR_risk_table.csv"), row.names = 1) %>%
  dplyr::rename(
    "extreme_future" = "extreme",
    "high_future" = "high",
    "moderate_future" = "moderate",
    "low_future" = "low"
  )

# change rownames
rownames(IVR_risk_table) <- c("extreme_present", "high_present", "moderate_present", "low_present", "total_future")

I will calculate the percentage of IVRs that increase and decrease risk overall and will report this in the paper.

total_IVR <- sum(IVR_risk_table[1:4, 1:4])

IVR_shift_prop_table <- tibble(
  risk_shift = c("no_shift", "risk_increase", "risk_decrease"),
  prop_change = c(
    sum(IVR_risk_table[1, 1], IVR_risk_table[2, 2], IVR_risk_table[3, 3], IVR_risk_table[4, 4]) / total_IVR,
    sum(IVR_risk_table[2:4, 1], IVR_risk_table[3:4, 2], IVR_risk_table[4, 3]) / total_IVR,
    sum(IVR_risk_table[1, 2], IVR_risk_table[1:2, 3], IVR_risk_table[1:3, 4]) / total_IVR
  )
) %>%
  # make % format
  dplyr::mutate(prop_change = scales::label_percent(accuracy = 0.01) (prop_change))

For reporting purposes, we see that about 69.7% of the 1063 IVRs experience no change in risk of SLF establishment due to climate change by 2055. Meanwhile, about 1.7% actually experience an increase in risk due to climate change and the remaining 28.6% move down one or more levels of risk by 2055.

# make kable
IVR_shift_prop_table <- knitr::kable(IVR_shift_prop_table, "html", escape = FALSE) %>% 
  kableExtra::kable_styling(bootstrap_options = "striped", full_width = FALSE) %>%
  # standardize col width
  kableExtra::column_spec(1:2, width_min = '4cm') %>%
  kableExtra::add_header_above(., header = c("IVR risk table shift proportions" = 2), bold = TRUE)

Now I will format and export the table. I will add colored proportion bars to the columns, which indicate the category distribution of IVRs entering that risk category. In other words, the columns represent the risk category in 2055, so the proportion bars represent the distribution of which current risk category those points move from by 2055. I will also add positive and negative signs to indicate a risk increase or decrease. The diagonal (top L to bottom R) will have no signs because this represents no shift in risk by 2055. All points experiencing a decline in risk sit above the diagonal, and points experiencing an increase in risk sit below the diagonal.

# convert top half (above diagonal) to negative numbers
IVR_risk_table[1, 2] <- -(IVR_risk_table[1, 2])
IVR_risk_table[1:2, 3] <- -(IVR_risk_table[1:2, 3])
IVR_risk_table[1:3, 4] <- -(IVR_risk_table[1:3, 4])

# add positive sign to bottom half
IVR_risk_table[2:4, 1] <- sprintf("%+.0f", IVR_risk_table[2:4, 1])
IVR_risk_table[3:4, 2] <- sprintf("%+.0f", IVR_risk_table[3:4, 2])
IVR_risk_table[4, 3] <- sprintf("%+.0f", IVR_risk_table[4, 3])

# add color formatting to totals
# extreme risk
IVR_risk_table[1, 5] <- cell_spec(IVR_risk_table[1, 5], format = "html", bold = TRUE, escape = FALSE, color = "darkred")
IVR_risk_table[5, 1] <- cell_spec(IVR_risk_table[5, 1], format = "html", bold = TRUE, escape = FALSE, color = "darkred")
# high risk
IVR_risk_table[2, 5] <- cell_spec(IVR_risk_table[2, 5], format = "html", bold = TRUE, escape = FALSE, color = "darkorange")
IVR_risk_table[5, 2] <- cell_spec(IVR_risk_table[5, 2], format = "html", bold = TRUE, escape = FALSE, color = "darkorange")
# moderate risk
IVR_risk_table[3, 5] <- cell_spec(IVR_risk_table[3, 5], format = "html", bold = TRUE, escape = FALSE, color = "gold")
IVR_risk_table[5, 3] <- cell_spec(IVR_risk_table[5, 3], format = "html", bold = TRUE, escape = FALSE, color = "gold")
# low risk
IVR_risk_table[4, 5] <- cell_spec(IVR_risk_table[4, 5], format = "html", bold = TRUE, escape = FALSE, color = "darkgrey")
IVR_risk_table[5, 4] <- cell_spec(IVR_risk_table[5, 4], format = "html", bold = TRUE, escape = FALSE, color = "darkgrey")

# bold total
IVR_risk_table[5, 5] <- cell_spec(IVR_risk_table[5, 5], format = "html", bold = TRUE, escape = FALSE)

# print table, e.g., in html format
IVR_risk_table <- kable(IVR_risk_table, format = "html", escape = FALSE) %>% 
  kableExtra::kable_styling(bootstrap_options = "striped", full_width = FALSE) %>%
  # standardize col width
  kableExtra::column_spec(1:5, width_min = '4cm') %>%
  # add footnotes
  kableExtra::add_footnote("number signs indicate whether climate change is increasing (+) or decreasing (-) risk", notation = "alphabet") %>%
  kableExtra::add_footnote("future risk calculated for period 2041-2070", notation = "alphabet") %>%
  kableExtra::add_footnote("present risk calculated for period 1981-2010", notation = "alphabet") %>%
  kableExtra::add_footnote("20000m buffer used for suitability of viticultural areas", notation = "alphabet") %>%
  # add header
  kableExtra::add_header_above(., header = c("Risk of L delicatula establishment in globally important viticultural regions" = 6), bold = TRUE)  

IVR_risk_table
Risk of L delicatula establishment in globally important viticultural regions
extreme_future high_future moderate_future low_future total_present
extreme_present 460 -131 -1 -7 599
high_present +12 229 -1 -58 300
moderate_present +0 +0 0 0 0
low_present +1 +7 +2 163 173
total_future 473 367 4 228 1072
a 20000m buffer used for suitability of viticultural areas
a present risk calculated for period 1981-2010
a future risk calculated for period 2041-2070
a number signs indicate whether climate change is increasing (+) or decreasing (-) risk

Let’s interpret this table.

The rows and their totals represent the number of viticultural regions presently at risk. The columns and their totals represent the number that will be at risk in the future (by a mean of 2055, in this case.)

There are three general sections to it: - The diagonal, which stretches from the top left to the bottom right, where the rows match the columns (for example, row 2, col 2, which is high_present and high_future). This represents the viticultural regions which will not change risk due to climate change (there are no number signs to indicate this). - The upper-right triangle of this diagonal. This represents viticultural regions which will lose risk due to climate change (they have a negative sign to reflect this). These were at a higher risk level and decreased by at least 1 level. - The lower-right triangle. This represents viticultural regions which will gain risk due to climate change (they have a positive sign to reflect this).

You can see that generally, most IVRs will lose risk or remain the same. Only a small number of IVRs will gain risk in the future. We cannot say that climate change will increase risk to IVRs, but we can still see interesting trends in how it will affect those which decrease. Of those that decrease, the highest number of IVRs will shift from ‘extreme’ to ‘high’ (-131), which means that they will lose risk in only the global-scale model (not the regional-scale model). This is alarming, because we would not have detected these IVRs as potentially being at risk without having created an ensemble of regional-scale models. We can see that our regional-scale model is in fact detecting risk that the global-scale mean model does not pick up.

SLF risk table

I will do the same for the SLF populations.

slf_risk_table <- read.csv(file = file.path(here::here(), "vignette-outputs", "data-tables", "slf_risk_table.csv"), row.names = 1) %>%
  dplyr::rename(
    "extreme_future" = "extreme",
    "high_future" = "high",
    "moderate_future" = "moderate",
    "low_future" = "low"
  )

# change rownames
rownames(slf_risk_table) <- c("extreme_present", "high_present", "moderate_present", "low_present", "total_future")
total_slf <- sum(slf_risk_table[1:4, 1:4])

slf_shift_prop_table <- tibble(
  risk_shift = c("no_shift", "risk_increase", "risk_decrease"),
  prop_change = c(
    sum(slf_risk_table[1, 1], slf_risk_table[2, 2], slf_risk_table[3, 3], slf_risk_table[4, 4]) / total_slf,
    sum(slf_risk_table[2:4, 1], slf_risk_table[3:4, 2], slf_risk_table[4, 3]) / total_slf,
    sum(slf_risk_table[1, 2], slf_risk_table[1:2, 3], slf_risk_table[1:3, 4]) / total_slf
  )
) %>%
  # make % format
  dplyr::mutate(prop_change = scales::label_percent(accuracy = 0.01) (prop_change))

For reporting purposes, we see that about 86.2% of the 769 slf populations experience no change in risk of persistence due to climate change by 2055. Meanwhile, about 2.7% actually experience an increase in risk due to climate change and the remaining 11% move down one or more levels of risk by 2055.

# make kable
slf_shift_prop_table <- kable(slf_shift_prop_table, "html", escape = FALSE) %>% 
  kableExtra::kable_styling(bootstrap_options = "striped", full_width = FALSE) %>%
  # standardize col width
  kableExtra::column_spec(1:2, width_min = '4cm') %>%
  kableExtra::add_header_above(., header = c("SLF risk table shift proportions" = 2), bold = TRUE)
# convert top half (above diagonal) to negative numbers
slf_risk_table[1, 2] <- -(slf_risk_table[1, 2])
slf_risk_table[1:2, 3] <- -(slf_risk_table[1:2, 3])
slf_risk_table[1:3, 4] <- -(slf_risk_table[1:3, 4])

# add positive sign to bottom half
slf_risk_table[2:4, 1] <- sprintf("%+.0f", slf_risk_table[2:4, 1])
slf_risk_table[3:4, 2] <- sprintf("%+.0f", slf_risk_table[3:4, 2])
slf_risk_table[4, 3] <- sprintf("%+.0f", slf_risk_table[4, 3])

# add color formatting to totals
# extreme risk
slf_risk_table[1, 5] <- cell_spec(slf_risk_table[1, 5], format = "html", bold = TRUE, escape = FALSE, color = "darkred")
slf_risk_table[5, 1] <- cell_spec(slf_risk_table[5, 1], format = "html", bold = TRUE, escape = FALSE, color = "darkred")
# high risk
slf_risk_table[2, 5] <- cell_spec(slf_risk_table[2, 5], format = "html", bold = TRUE, escape = FALSE, color = "darkorange")
slf_risk_table[5, 2] <- cell_spec(slf_risk_table[5, 2], format = "html", bold = TRUE, escape = FALSE, color = "darkorange")
# moderate risk
slf_risk_table[3, 5] <- cell_spec(slf_risk_table[3, 5], format = "html", bold = TRUE, escape = FALSE, color = "gold")
slf_risk_table[5, 3] <- cell_spec(slf_risk_table[5, 3], format = "html", bold = TRUE, escape = FALSE, color = "gold")
# low risk
slf_risk_table[4, 5] <- cell_spec(slf_risk_table[4, 5], format = "html", bold = TRUE, escape = FALSE, color = "darkgrey")
slf_risk_table[5, 4] <- cell_spec(slf_risk_table[5, 4], format = "html", bold = TRUE, escape = FALSE, color = "darkgrey")

# bold total
slf_risk_table[5, 5] <- cell_spec(slf_risk_table[5, 5], format = "html", bold = TRUE, escape = FALSE)

# print table, e.g., in html format
slf_risk_table <- kable(slf_risk_table, "html", escape = FALSE) %>% 
  kable_styling(bootstrap_options = "striped", full_width = FALSE) %>%
  # standardize col width
  kableExtra::column_spec(1:5, width_min = '4cm') %>%
  # add footnotes
  kableExtra::add_footnote("number signs indicate whether climate change is increasing (+) or decreasing (-) risk", notation = "alphabet") %>%
  kableExtra::add_footnote("future risk calculated for period 2041-2070", notation = "alphabet") %>%
  kableExtra::add_footnote("present risk calculated for period 1981-2010", notation = "alphabet") %>%
  # add header
  add_header_above(., header = c("Risk of persistence for known L delicatula populations" = 6), bold = TRUE)

slf_risk_table
Risk of persistence for known L delicatula populations
extreme_future high_future moderate_future low_future total_present
extreme_present 1153 -19 -11 -30 1213
high_present +10 20 0 -6 36
moderate_present +5 +0 0 -3 8
low_present +4 +3 +0 13 20
total_future 1172 42 11 52 1277
a present risk calculated for period 1981-2010
a future risk calculated for period 2041-2070
a number signs indicate whether climate change is increasing (+) or decreasing (-) risk