evaluating-prediction-accuracy.qmd

{{< include _chunk-timing.qmd >}}

# Evaluation of Prediction/Forecasting Accuracy {#sec-predictionAccuracy}

::: {.content-visible when-format="html:js"}

> "*Nothing ruins fantasy more than reality.*" – [Renee Miller, Ph.D.](#fig-fantasy-vs-reality) [@Yahoo2024]

::: {#fig-fantasy-vs-reality}

{{< video https://www.youtube.com/watch?v=gmpLFWs5ae0 start="1430" >}}

:::

:::

::: {.content-visible unless-format="html:js"}

> "*Nothing ruins fantasy more than reality.*" – [Renee Miller, Ph.D.](https://www.youtube.com/watch?v=gmpLFWs5ae0&t=1430) [@Yahoo2024]

:::

This chapter provides an overview of ways to evaluate the accuracy of predictions.
In addition, we evaluate the accuracy of fantasy football projections.

## Getting Started {#sec-predictionAccuracyGettingStarted}

### Load Packages {#sec-predictionAccuracyLoadPackages}

```{r}
library("petersenlab")
library("pROC")
library("magrittr")
library("viridis")
library("viridisLite")
library("msir")
library("tidymodels")
library("tidyverse")
```

### Load Data {#sec-predictionAccuracyLoadData}

```{r}
#| eval: false
#| include: false

load(file = file.path(path, "/OneDrive - University of Iowa/Teaching/Courses/Fantasy Football/Data/player_stats_weekly.RData", fsep = ""))
load(file = file.path(path, "/OneDrive - University of Iowa/Teaching/Courses/Fantasy Football/Data/player_stats_seasonal.RData", fsep = ""))
load(file = file.path(path, "/OneDrive - University of Iowa/Teaching/Courses/Fantasy Football/Data/players_projections_weekly.RData", fsep = ""))
load(file = file.path(path, "/OneDrive - University of Iowa/Teaching/Courses/Fantasy Football/Data/players_projections_seasonal.RData", fsep = ""))
load(file = file.path(path, "/OneDrive - University of Iowa/Teaching/Courses/Fantasy Football/Data/nfl_playerIDs.RData", fsep = ""))
```

```{r}
load(file = "./data/player_stats_weekly.RData")
load(file = "./data/player_stats_seasonal.RData")
load(file = "./data/players_projections_weekly.RData")
load(file = "./data/players_projections_seasonal.RData")
load(file = "./data/nfl_playerIDs.RData")
```

We created the `player_stats_weekly.RData` and `player_stats_seasonal.RData` objects in @sec-calculatePlayerAge.
The `players_projections_weekly` and `players_projections_seasonal` objects were derived from projected points objects that were created in @sec-fantasyFootballProjections.

### Specify Options {#predictionAccuracySpecifyOptions}

```{r}
options(scipen = 999) # prevent scientific notation
```

### Prepare Data {#sec-predictionAccuracyPrepareData}

#### Seasonal Projections {#sec-predictionAccuracyPrepareDataSeasonal}

To evaluate the accuracy of projections, we must first merge projections with actual performance.
Below, we merge seasonal projections with actual performance.

```{r}
player_stats_seasonal_subset <- player_stats_seasonal %>% 
  filter(!is.na(player_id))

nfl_playerIDs_subset <- nfl_playerIDs %>% 
  filter(!is.na(gsis_id)) %>% 
  distinct(gsis_id, .keep_all = TRUE) %>% # keep only rows that do not have duplicate values of gsis_id
  select(-all_of(c("team", "position", "height", "weight", "age")))

players_projectedPoints_seasonal_combined$season <- as.integer(players_projectedPoints_seasonal_combined$season)
players_projections_seasonal_average_merged$season <- as.integer(players_projections_seasonal_average_merged$season)

player_stats_seasonal_subset_IDs <- left_join(
  player_stats_seasonal_subset,
  nfl_playerIDs_subset,
  by = c("player_id" = "gsis_id")
) %>% 
  filter(!is.na(mfl_id))

projectionsWithActuals_seasonal <- full_join(
  player_stats_seasonal_subset_IDs,
  players_projectedPoints_seasonal_combined,
  by = c("mfl_id" = "id", "season"),
  suffix = c("", "_proj"),
)

crowdAveragedProjectionsWithActuals_seasonal <- full_join(
  player_stats_seasonal_subset_IDs,
  players_projections_seasonal_average_merged %>% filter(avg_type == "average"),
  by = c("mfl_id" = "id", "season"),
  suffix = c("", "_proj"),
)

projectionsWithActuals_seasonal <- projectionsWithActuals_seasonal %>% 
  unite(
    "player_id_season",
    player_id,
    season,
    remove = FALSE
  )

crowdAveragedProjectionsWithActuals_seasonal <- crowdAveragedProjectionsWithActuals_seasonal %>% 
  unite(
    "player_id_season",
    player_id,
    season,
    remove = FALSE
  )
```

Players in the `projectionsWithActuals_seasonal` object are (supposed to be) uniquely identified by `player_id`-`season`-`data_src`:

```{r}
projectionsWithActuals_seasonal %>% 
  filter(!is.na(player_id)) %>% 
  group_by(player_id, season, data_src) %>% 
  filter(n() > 1) %>% 
  head()
```

Players in the `crowdAveragedProjectionsWithActuals_seasonal` object are (supposed to be) uniquely identified by `player_id`-`season`-`avg_type`:

```{r}
crowdAveragedProjectionsWithActuals_seasonal %>% 
  filter(!is.na(player_id)) %>% 
  group_by(player_id, season, avg_type) %>% 
  filter(n() > 1) %>% 
  head()
```

We save the data object for use in other chapters:

```{r}
save(
  projectionsWithActuals_seasonal, crowdAveragedProjectionsWithActuals_seasonal,
  file = "./data/projectionsWithActuals_seasonal.RData"
)
```

```{r}
playersWithHighProjectedOrActualPoints <- projectionsWithActuals_seasonal %>% 
  filter(raw_points > 100 | fantasyPoints > 100) %>% 
  select(player_id_season) %>% 
  pull()

projectionsWithActuals_seasonal_qb <- projectionsWithActuals_seasonal %>% 
  filter(position_group == "QB")

projectionsWithActuals_seasonal_rb <- projectionsWithActuals_seasonal %>% 
  filter(position_group == "RB")

projectionsWithActuals_seasonal_wr <- projectionsWithActuals_seasonal %>% 
  filter(position_group == "WR")

projectionsWithActuals_seasonal_te <- projectionsWithActuals_seasonal %>% 
  filter(position_group == "TE")

projectionsWithActuals_seasonal_k <- projectionsWithActuals_seasonal %>% 
  filter(position == "K")

projectionsWithActuals_seasonal_dl <- projectionsWithActuals_seasonal %>% 
  filter(position_group == "DL")

projectionsWithActuals_seasonal_lb <- projectionsWithActuals_seasonal %>% 
  filter(position_group == "LB")

projectionsWithActuals_seasonal_db <- projectionsWithActuals_seasonal %>% 
  filter(position_group == "DB")

crowdAveragedProjectionsWithActuals_seasonal_qb <- crowdAveragedProjectionsWithActuals_seasonal %>% 
  filter(position_group == "QB")

crowdAveragedProjectionsWithActuals_seasonal_rb <- crowdAveragedProjectionsWithActuals_seasonal %>% 
  filter(position_group == "RB")

crowdAveragedProjectionsWithActuals_seasonal_wr <- crowdAveragedProjectionsWithActuals_seasonal %>% 
  filter(position_group == "WR")

crowdAveragedProjectionsWithActuals_seasonal_te <- crowdAveragedProjectionsWithActuals_seasonal %>% 
  filter(position_group == "TE")

crowdAveragedProjectionsWithActuals_seasonal_k <- crowdAveragedProjectionsWithActuals_seasonal %>% 
  filter(position == "K")

crowdAveragedProjectionsWithActuals_seasonal_dl <- crowdAveragedProjectionsWithActuals_seasonal %>% 
  filter(position_group == "DL")

crowdAveragedProjectionsWithActuals_seasonal_lb <- crowdAveragedProjectionsWithActuals_seasonal %>% 
  filter(position_group == "LB")

crowdAveragedProjectionsWithActuals_seasonal_db <- crowdAveragedProjectionsWithActuals_seasonal %>% 
  filter(position_group == "DB")
```

#### Weekly Projections {#sec-predictionAccuracyPrepareDataWeekly}

Below, we merge weekly projections with actual performance.

```{r}
player_stats_weekly_subset <- player_stats_weekly %>% 
  filter(!is.na(player_id))

nfl_playerIDs_subset <- nfl_playerIDs %>% 
  filter(!is.na(gsis_id)) %>% 
  distinct(gsis_id, .keep_all = TRUE) %>% # keep only rows that do not have duplicate values of gsis_id
  select(-all_of(c("team", "position", "height", "weight", "age")))

players_projectedPoints_weekly_combined$season <- as.integer(players_projectedPoints_weekly_combined$season)
players_projections_weekly_average_merged$season <- as.integer(players_projections_weekly_average_merged$season)

player_stats_weekly_subset_IDs <- left_join(
  player_stats_weekly_subset,
  nfl_playerIDs_subset,
  by = c("player_id" = "gsis_id")
) %>% 
  filter(!is.na(mfl_id))

projectionsWithActuals_weekly <- full_join(
  player_stats_weekly_subset_IDs,
  players_projectedPoints_weekly_combined,
  by = c("mfl_id" = "id", "season", "week"),
  suffix = c("", "_proj"),
)

crowdAveragedProjectionsWithActuals_weekly <- full_join(
  player_stats_weekly_subset_IDs,
  players_projections_weekly_average_merged,
  by = c("mfl_id" = "id", "season", "week"),
  suffix = c("", "_proj"),
)

projectionsWithActuals_weekly <- projectionsWithActuals_weekly %>% 
  unite(
    "player_id_season_week",
    player_id,
    season,
    week,
    remove = FALSE
  )

crowdAveragedProjectionsWithActuals_weekly <- crowdAveragedProjectionsWithActuals_weekly %>% 
  unite(
    "player_id_season_week",
    player_id,
    season,
    week,
    remove = FALSE
  )
```

Players in the `projectionsWithActuals_weekly` object are (supposed to be) uniquely identified by `player_id`-`season`-`week`-`data_src`:

```{r}
projectionsWithActuals_weekly %>% 
  filter(!is.na(player_id)) %>% 
  group_by(player_id, season, week, data_src) %>% 
  filter(n() > 1) %>% 
  head()
```

Players in the `crowdAveragedProjectionsWithActuals_weekly` object are (supposed to be) uniquely identified by `player_id`-`season`-`week`-`avg_type`:

```{r}
crowdAveragedProjectionsWithActuals_weekly %>% 
  filter(!is.na(player_id)) %>% 
  group_by(player_id, season, week, avg_type) %>% 
  filter(n() > 1) %>% 
  head()
```

We save the data object for use in other chapters:

```{r}
save(
  projectionsWithActuals_weekly, crowdAveragedProjectionsWithActuals_weekly,
  file = "./data/projectionsWithActuals_weekly.RData"
)
```

```{r}
playersWithHighProjectedOrActualPoints_weekly <- projectionsWithActuals_weekly %>% 
  filter(raw_points > 6 | fantasyPoints > 6) %>% 
  select(player_id_season_week) %>% 
  pull()

projectionsWithActuals_weekly_qb <- projectionsWithActuals_weekly %>% 
  filter(position_group == "QB")

projectionsWithActuals_weekly_rb <- projectionsWithActuals_weekly %>% 
  filter(position_group == "RB")

projectionsWithActuals_weekly_wr <- projectionsWithActuals_weekly %>% 
  filter(position_group == "WR")

projectionsWithActuals_weekly_te <- projectionsWithActuals_weekly %>% 
  filter(position_group == "TE")

projectionsWithActuals_weekly_k <- projectionsWithActuals_weekly %>% 
  filter(position == "K")

projectionsWithActuals_weekly_dl <- projectionsWithActuals_weekly %>% 
  filter(position_group == "DL")

projectionsWithActuals_weekly_lb <- projectionsWithActuals_weekly %>% 
  filter(position_group == "LB")

projectionsWithActuals_weekly_db <- projectionsWithActuals_weekly %>% 
  filter(position_group == "DB")

crowdAveragedProjectionsWithActuals_weekly_qb <- crowdAveragedProjectionsWithActuals_weekly %>% 
  filter(position_group == "QB")

crowdAveragedProjectionsWithActuals_weekly_rb <- crowdAveragedProjectionsWithActuals_weekly %>% 
  filter(position_group == "RB")

crowdAveragedProjectionsWithActuals_weekly_wr <- crowdAveragedProjectionsWithActuals_weekly %>% 
  filter(position_group == "WR")

crowdAveragedProjectionsWithActuals_weekly_te <- crowdAveragedProjectionsWithActuals_weekly %>% 
  filter(position_group == "TE")

crowdAveragedProjectionsWithActuals_weekly_k <- crowdAveragedProjectionsWithActuals_weekly %>% 
  filter(position == "K")

crowdAveragedProjectionsWithActuals_weekly_dl <- crowdAveragedProjectionsWithActuals_weekly %>% 
  filter(position_group == "DL")

crowdAveragedProjectionsWithActuals_weekly_lb <- crowdAveragedProjectionsWithActuals_weekly %>% 
  filter(position_group == "LB")

crowdAveragedProjectionsWithActuals_weekly_db <- crowdAveragedProjectionsWithActuals_weekly %>% 
  filter(position_group == "DB")
```

## Overview {#sec-predictionAccuracyOverview}

Predictions can come in different types.
Some predictions involve categorical data, whereas other predictions involve continuous data.
When dealing with a dichotomous ([nominal data](#sec-nominal) that are binary) [predictor](#sec-correlationalStudy) and [outcome](#sec-correlationalStudy) variable (or continuous data that have been dichotomized using a cutoff), we can evaluate predictions using a 2x2 table known as a [confusion matrix](#sec-confusionMatrix) (see @fig-confusionMatrix), or with logistic regression models.
When dealing with a continuous [outcome variable](#sec-correlationalStudy) (e.g., [ordinal](#sec-ordinal), [interval](#sec-interval), or [ratio](#sec-ratio) data), we can evaluate predictions using [multiple regression](#sec-multipleRegression) or similar variants such as structural equation modeling and mixed models.

In fantasy football, we most commonly predict continuous [outcome variables](#sec-correlationalStudy) (e.g., fantasy points, rushing yards).
Nevertheless, it is also important to understand principles in the prediction of categorical [outcomes variables](#sec-correlationalStudy).

In any domain, it is important to evaluate the accuracy of predictions, so we can know how (in)accurate we are, and we can strive to continually improve our predictions.
Fantasy performance—and human behavior more general—is incredibly challenging to predict.
Indeed, many things in the world, in particular long-term trends, are unpredictable [@Kahneman2011].
In fantasy football, there is considerable luck/chance/randomness.
There are relatively few (i.e. 17) games, and there is a sizeable injury risk for each player in a given game.
These and other factors combine to render fantasy football predictions not highly accurate.
Domains with high uncertainty and unpredictability are considered "low-validity environments" [@Kahneman2011, p. 223].
But, first, let's learn about the various ways we can evaluate the accuracy of predictions.

## Types of Accuracy {#sec-accuracyTypes}

There are two primary dimensions of accuracy: (1) [discrimination](#sec-discrimination) and (2) [calibration](#sec-calibration).
[Discrimination](#sec-discrimination) and [calibration](#sec-calibration) are distinct forms of accuracy.
Just because predictions are high in one form of accuracy does not mean that they will be high in the other form of accuracy.
As described by @Lindhiem2020, predictions can follow any of the following configurations (and anywhere in between):

- high [discrimination](#sec-discrimination), high [calibration](#sec-calibration)
- high [discrimination](#sec-discrimination), low [calibration](#sec-calibration)
- low [discrimination](#sec-discrimination), high [calibration](#sec-calibration)
- low [discrimination](#sec-discrimination), low [calibration](#sec-calibration)

Some general indexes of accuracy combine discrimination and calibration, as described in @sec-generalAccuracy.

In addition, accuracy indices can be [threshold-dependent](#sec-thresholdDependentAccuracy) or [-independent](#sec-thresholdIndependentAccuracy) and can be scale-dependent or -independent.
[Threshold-dependent accuracy indices](#sec-thresholdDependentAccuracy) differ based on the cutoff (i.e., threshold), whereas [threshold-independent accuracy indices](#sec-thresholdIndependentAccuracy) do not.
Thus, raising or lowering the cutoff will change [threshold-dependent](#sec-thresholdDependentAccuracy) accuracy indices.
Scale-dependent accuracy indices depend on the metric/scale of the data, whereas scale-independent accuracy indices do not.
Thus, scale-dependent accuracy indices cannot be directly compared when using measures of differing scales, whereas scale-independent accuracy indices can be compared across data of differing scales.

### Discrimination {#sec-discrimination}

When dealing with a categorical outcome, discrimination is the ability to separate events from non-events.
When dealing with a continuous outcome, discrimination is the strength of the association between the predictor and the outcome.
Aspects of discrimination at a particular cutoff (e.g., sensitivity, specificity, area under the ROC curve) are described in @sec-thresholdDependentAccuracy.

### Calibration {#sec-calibration}

When dealing with a categorical outcome, calibration is the degree to which a probabilistic estimate of an event reflects the true underlying probability of the event.
When dealing with a continuous outcome, calibration is the degree to which the predicted values are close in value to the outcome values.
The importance of examining calibration (in addition to discrimination) is described by @Lindhiem2020.

Calibration is relevant to all kinds of predictions, including weather forecasts.
For instance, on the days that the meteorologist says there is a 60% chance of rain, it should rain about 60% of the time.
Calibration is also important for fantasy football predictions.
When projections state that a group of players is each expected to score 200 points, their projections would be miscalibrated if those players scored only 150 points on average.

There are four general patterns of miscalibration: overextremity, underextremity, overprediction, and underprediction (see @fig-miscalibration).
*Overextremity* exists when the predicted probabilities are too close to the extremes (zero or one).
*Underextremity* exists when the predicted probabilities are too far away from the extremes.
*Overprediction* exists when the predicted probabilities are consistently greater than the observed probabilities.
*Underprediction* exists when the predicted probabilities are consistently less than the observed probabilities.
For a more thorough description of these types of miscalibration, see @Lindhiem2020.

Indices for evaluating calibration are described in @sec-calibrationIndices.

### General Accuracy {#sec-generalAccuracy}

General accuracy indices combine estimates of [discrimination](#sec-discrimination) and [calibration](#sec-calibration).

## Prediction of Categorical Outcomes {#sec-predictionCategorical}

To evaluate the accuracy of our predictions for categorical outcome variables (e.g., binary, dichotomous, or [nominal](#sec-nominal) data), we can use either [threshold-dependent](#sec-thresholdDependentAccuracy) or [threshold-independent](#sec-thresholdIndependentAccuracy) accuracy indices.

## Prediction of Continuous Outcomes {#sec-predictionContinuous}

To evaluate the accuracy of our predictions for continuous outcome variables (e.g., [ordinal](#sec-ordinal), [interval](#sec-interval), or [ratio](#sec-ratio) data), the outcome variable does not have cutoffs, so we would use [threshold-independent accuracy indices](#sec-thresholdIndependentAccuracy).

## Threshold-Dependent Accuracy Indices {#sec-thresholdDependentAccuracy}

### Decision Outcomes {#sec-decisionOutcomes}

To consider how we can evaluate the accuracy of predictions for a categorical outcome, consider an example adapted from @Meehl1955.
The military conducts a test of its prospective members to screen out applicants who would likely fail basic training.
To evaluate the accuracy of our predictions using the test, we can examine a [confusion matrix](#sec-confusionMatrix).
A [confusion matrix](#sec-confusionMatrix) is a matrix that presents the predicted outcome on one dimension and the actual outcome (truth) on the other dimension.
If the predictions and outcomes are dichotomous, the [confusion matrix](#sec-confusionMatrix) is a 2x2 matrix with two rows and two columns that represent four possible predicted-actual combinations (decision outcomes), as in @fig-confusionMatrix: true positives (TP), true negatives (TN), false positives (FP), and false negatives (FN).

::: {#fig-confusionMatrix}
![](images/confusionMatrix.png){fig-alt="A Two-by-Two Confusion Matrix. From @Petersen2024a and @PetersenPrinciplesPsychAssessment."}

A Two-by-Two Confusion Matrix. From @Petersen2024a and @PetersenPrinciplesPsychAssessment.
:::

When discussing the four decision outcomes, "true" means an accurate judgment, whereas "false" means an inaccurate judgment.
"Positive" means that the judgment was that the person has the characteristic of interest, whereas "negative" means that the judgment was that the person does not have the characteristic of interest.
A *true positive* is a correct judgment (or prediction) where the judgment was that the person has (or will have) the characteristic of interest, and, in truth, they actually have (or will have) the characteristic.
A *true negative* is a correct judgment (or prediction) where the judgment was that the person does not have (or will not have) the characteristic of interest, and, in truth, they actually do not have (or will not have) the characteristic.
A *false positive* is an incorrect judgment (or prediction) where the judgment was that the person has (or will have) the characteristic of interest, and, in truth, they actually do not have (or will not have) the characteristic.
A *false negative* is an incorrect judgment (or prediction) where the judgment was that the person does not have (or will not have) the characteristic of interest, and, in truth, they actually do have (or will have) the characteristic.

An example of a [confusion matrix](#sec-confusionMatrix) is in @fig-confusionMatrix1.

::: {#fig-confusionMatrix1}
![](images/confusionMatrix1.png){fig-alt="Example of a Two-by-Two Confusion Matrix. TP = true positives; TN = true negatives; FP = false positives; FN = false negatives. From @Petersen2024a and @PetersenPrinciplesPsychAssessment."}

Example of a Two-by-Two Confusion Matrix. TP = true positives; TN = true negatives; FP = false positives; FN = false negatives. From @Petersen2024a and @PetersenPrinciplesPsychAssessment.
:::

With the information in the [confusion matrix](#sec-confusionMatrix), we can calculate the marginal sums and the proportion of people in each cell (in parentheses), as depicted in @fig-confusionMatrix2.

::: {#fig-confusionMatrix2}
![](images/confusionMatrix2.png){fig-alt="Example of a Two-by-Two Confusion Matrix With Marginal Sums. TP = true positives; TN = true negatives; FP = false positives; FN = false negatives. From @Petersen2024a and @PetersenPrinciplesPsychAssessment."}

Example of a Two-by-Two Confusion Matrix With Marginal Sums. TP = true positives; TN = true negatives; FP = false positives; FN = false negatives. From @Petersen2024a and @PetersenPrinciplesPsychAssessment.
:::

That is, we can sum across the rows and columns to identify how many people actually showed poor adjustment ($n = 100$) versus good adjustment ($n = 1,900$), and how many people were selected to reject ($n = 508$) versus retain ($n = 1,492$).
If we sum the column of predicted marginal sums ($508 + 1,492$) or the row of actual marginal sums ($100 + 1,900$), we get the total number of people ($N = 2,000$).

Based on the marginal sums, we can compute the [marginal probabilities](#sec-baseRate), as depicted in @fig-confusionMatrix3.

::: {#fig-confusionMatrix3}
![](images/confusionMatrix3.png){fig-alt="Example of a Two-by-Two Confusion Matrix With Marginal Sums and Marginal Probabilities. TP = true positives; TN = true negatives; FP = false positives; FN = false negatives; BR = base rate; SR = selection ratio. From @Petersen2024a and @PetersenPrinciplesPsychAssessment."}

Example of a Two-by-Two Confusion Matrix With Marginal Sums and Marginal Probabilities. TP = true positives; TN = true negatives; FP = false positives; FN = false negatives; BR = base rate; SR = selection ratio. From @Petersen2024a and @PetersenPrinciplesPsychAssessment.
:::

The [marginal probability](#sec-baseRate) of the person having the characteristic of interest (i.e., showing poor adjustment) is called the [*base rate*](#baseRate) (BR).
That is, the [base rate](#baseRate) is the proportion of people who have the characteristic.
It is calculated by dividing the number of people with poor adjustment ($n = 100$) by the total number of people ($N = 2,000$): $BR = \frac{FN + TP}{N}$.
Here, the [base rate](#baseRate) reflects the prevalence of poor adjustment.
In this case, the [base rate](#baseRate) is .05, so there is a 5% chance that an applicant will be poorly adjusted.
The [marginal probability](#baseRate) of good adjustment is equal to 1 minus the [base rate](#baseRate) of poor adjustment.

The [marginal probability](#baseRate) of predicting that a person has the characteristic (i.e., rejecting a person) is called the *selection ratio* (SR).
The selection ratio is the proportion of people who will be selected (in this case, rejected rather than retained); i.e., the proportion of people who are identified as having the characteristic.
The selection ratio is calculated by dividing the number of people selected to reject ($n = 508$) by the total number of people ($N = 2,000$): $SR = \frac{TP + FP}{N}$.
In this case, the selection ratio is .25, so 25% of people are rejected.
The [marginal probability](#baseRate) of not selecting someone to reject (i.e., the [marginal probability](#baseRate) of retaining) is equal to 1 minus the selection ratio.

The selection ratio might be something that the test dictates according to its cutoff score.
Or, the selection ratio might be imposed by external factors that place limits on how many people you can assign a positive test value.
For instance, when deciding whether to treat a client, the selection ratio may depend on how many therapists are available and how many cases can be treated.

### Percent Accuracy {#sec-percentAccuracyOverview}

Based on the [confusion matrix](#sec-confusionMatrix), we can calculate the prediction accuracy based on the percent accuracy of the predictions.
The percent accuracy is the number of correct predictions divided by the total number of predictions, and multiplied by 100.
In the context of a [confusion matrix](#sec-confusionMatrix), this is calculated as: $100\% \times \frac{\text{TP} + \text{TN}}{N}$.
In this case, our percent accuracy was 78%—that is, 78% of our predictions were accurate, and 22% of our predictions were inaccurate.

### Percent Accuracy by Chance {#sec-accuracyByChance}

78% sounds pretty accurate.
And it is much higher than 50%, so we are doing a pretty good job, right?
Well, it is important to compare our accuracy to what accuracy we would expect to get by chance alone, if predictions were made by a random process rather than using a test's scores.
Our selection ratio was 25.4%.
How accurate would we be if we randomly selected 25.4% of people to reject?
To determine what accuracy we could get by chance alone given the selection ratio and the base rate, we can calculate the chance probability of true positives and the chance probability of true negatives.
The probability of a given cell in the [confusion matrix](#sec-confusionMatrix) is a [joint probability](#sec-jointProbability)—the probability of two events occurring simultaneously.
To calculate a [joint probability](#sec-jointProbability), we multiply the probability of each event.

So, to get the chance expectancies of true positives, we would multiply the respective [marginal probabilities](#baseRate), as in @eq-truePositivesByChanceExample:

$$
\begin{aligned}
  P(TP) &= P(\text{Poor adjustment}) \times P(\text{Reject})\\
   &= BR \times SR \\
  &= .05 \times .254 \\
  &= .0127
\end{aligned}
$$ {#eq-truePositivesByChanceExample}

To get the chance expectancies of true negatives, we would multiply the respective [marginal probabilities](#sec-baseRate), as in @eq-trueNegativesByChanceExample:

$$
\begin{aligned}
  P(TN) &= P(\text{Good adjustment}) \times P(\text{Retain})\\
   &= (1 - BR) \times (1 - SR) \\
  &= .95 \times .746 \\
  &= .7087
\end{aligned}
$$ {#eq-trueNegativesByChanceExample}

To get the percent accuracy by chance, we sum the chance expectancies for the correct predictions (TP and TN): $.0127 + .7087 = .7214$.
Thus, the percent accuracy you can get by chance alone is 72%.
This is because most of our predictions are to retain people, and the [base rate](#sec-baseRate) of poor adjustment is quite low (.05).
Our measure with 78% accuracy provides only a 6% increment in correct predictions.
Thus, you cannot judge how good your judgment or prediction is until you know how you would do by random chance.

The chance expectancies for each cell of the [confusion matrix](#sec-confusionMatrix) are in @fig-confusionMatrix4.

::: {#fig-confusionMatrix4}
![](images/confusionMatrix4.png){fig-alt="Chance Expectancies in Two-by-Two Confusion Matrix. BR = base rate; SR = selection ratio. From @Petersen2024a and @PetersenPrinciplesPsychAssessment."}

Chance Expectancies in Two-by-Two Confusion Matrix. BR = base rate; SR = selection ratio. From @Petersen2024a and @PetersenPrinciplesPsychAssessment.
:::

### Predicting from the Base Rate {#sec-predictingFromBaseRate}

Now, let us consider how well you would do if you were to predict from the [base rate](#sec-baseRate).
Predicting from the [base rate](#sec-baseRate) is also called "betting from the [base rate](#sec-baseRate)", and it involves setting the selection ratio by taking advantage of the [base rate](#sec-baseRate) so that you go with the most likely outcome in every prediction.
Because the [base rate](#sec-baseRate) is quite low (.05), we could predict from the [base rate](#sec-baseRate) by selecting no one to reject (i.e., setting the selection ratio at zero).
Our percent accuracy by chance if we predict from the [base rate](#sec-baseRate) would be calculated by multiplying the [marginal probabilities](#sec-baseRate), as we did above, but with a new selection ratio, as in @eq-predictingFromBaseRateExample:

$$
\begin{aligned}
  P(TP) &= P(\text{Poor adjustment}) \times P(\text{Reject})\\
   &= BR \times SR \\
  &= .05 \times 0 \\
  &= 0 \\ \\
  P(TN) &= P(\text{Good adjustment}) \times P(\text{Retain})\\
   &= (1 - BR) \times (1 - SR) \\
  &= .95 \times 1 \\
  &= .95
\end{aligned}
$$ {#eq-predictingFromBaseRateExample}

We sum the chance expectancies for the correct predictions (TP and TN): $0 + .95 = .95$.
Thus, our percent accuracy by predicting from the [base rate](#sec-baseRate) is 95%.
This is damning to our measure because it is a much higher accuracy than the accuracy of our measure.
That is, we can be much more accurate than our measure simply by predicting from the [base rate](#sec-baseRate) and selecting no one to reject.

Going with the most likely outcome in every prediction (predicting from the [base rate](#sec-baseRate)) can be highly accurate (in terms of percent accuracy) as noted by @Meehl1955, especially when the [base rate](#sec-baseRate) is very low or very high.
This should serve as an important reminder that we need to compare the accuracy of our measures to the accuracy by (1) random chance and (2) predicting from the [base rate](#sec-baseRate).
There are several important implications of the impact of [base rates](#sec-baseRate) on prediction accuracy.
One implication is that using the same test in different settings with different [base rates](#sec-baseRate) will markedly change the accuracy of the test.
Oftentimes, using a test will actually *decrease* the predictive accuracy when the [base rate](#sec-baseRate) deviates greatly from .50.
But percent accuracy is not everything.
Percent accuracy treats different kinds of errors as if they are equally important.
However, the value we place on different kinds of errors may be different, as described next.

### Different Kinds of Errors Have Different Costs {#sec-differentErrorsDifferentCosts}

Some errors have a high cost, and some errors have a low cost.
Among the four decision outcomes, there are two types of errors: false positives and false negatives.
The extent to which false positives and false negatives are costly depends on the prediction problem.
So, even though you can often be most accurate by going with the [base rate](#sec-baseRate), it may be advantageous to use a screening instrument despite lower overall accuracy because of the huge difference in costs of false positives versus false negatives in some cases.

Consider the example of a screening instrument for HIV.
False positives would be cases where we said that someone is at high risk of HIV when they are not, whereas false negatives are cases where we said that someone is not at high risk when they actually are.
The costs of false positives include a shortage of blood, some follow-up testing, and potentially some anxiety, but that is about it.
The costs of false negatives may be people getting HIV.
In this case, the costs of false negatives greatly outweigh the costs of false positives, so we use a screening instrument to try to identify the cases at high risk for HIV because of the important consequences of failing to do so, even though using the screening instrument will lower our overall accuracy level.

Another example is when the Central Intelligence Agency (CIA) used a screen for protective typists during wartime to try to detect spies.
False positives would be cases where the CIA believes that a person is a spy when they are not, and the CIA does not hire them.
False negatives would be cases where the CIA believes that a person is not a spy when they actually are, and the CIA hires them.
In this case, a false positive would be fine, but a false negative would be really bad.

How you weigh the costs of different errors depends considerably on the domain and context.
Possible costs of false positives to society include: unnecessary and costly treatment with side effects and sending an innocent person to jail (despite our presumption of innocence in the United States criminal justice system that a person is innocent until proven guilty).
Possible costs of false negatives to society include: setting a guilty person free, failing to detect a bomb or tumor, and preventing someone from getting treatment who needs it.

The differential costs of different errors also depend on how much flexibility you have in the selection ratio in being able to set a stringent versus loose selection ratio.
Consider if there is a high cost of getting rid of people during the selection process.
For example, if you must hire 100 people and only 100 people apply for the position, you cannot lose people, so you need to hire even high-risk people.
However, if you do not need to hire many people, then you can hire more conservatively.

Any time the selection ratio differs from the [base rate](#sec-baseRate), you will make errors.
For example, if you reject 25% of applicants, and the [base rate](#sec-baseRate) of poor adjustment is 5%, then you are making errors of over-rejecting (false positives).
By contrast, if you reject 1% of applicants and the [base rate](#sec-baseRate) of poor adjustment is 5%, then you are making errors of under-rejecting or over-accepting (false negatives).

### Difficulty Predicting Low Base Rate Events {#sec-difficultyPredictingLowBRevents}

A low [base rate](#sec-baseRate) makes it harder to make predictions, and tends to lead to less accurate predictions.
For instance, it is very challenging to predict low [base rate](#sec-baseRate) behaviors, including suicide [@Kessler2020].
For this reason, it is likely much more challenging to predict touchdowns—which happen relatively less often—than it is to predict passing/rushing/receiving yards—which are more frequent and continuously distributed.

Here is the accuracy of the prediction of passing touchdowns versus passing yards among Quarterbacks:

```{r}
petersenlab::accuracyOverall(
  predicted = projectionsWithActuals_weekly_qb$pass_tds,
  actual = projectionsWithActuals_weekly_qb$passing_tds,
  dropUndefined = TRUE
)

petersenlab::accuracyOverall(
  predicted = projectionsWithActuals_weekly_qb$pass_yds,
  actual = projectionsWithActuals_weekly_qb$passing_yards,
  dropUndefined = TRUE
)
```

```{r}
#| include: false

rSquared_passTds <- petersenlab::accuracyOverall(
  predicted = projectionsWithActuals_weekly_qb$pass_tds,
  actual = projectionsWithActuals_weekly_qb$passing_tds,
  dropUndefined = TRUE
)$rsquared

rSquared_passYds <- petersenlab::accuracyOverall(
  predicted = projectionsWithActuals_weekly_qb$pass_yds,
  actual = projectionsWithActuals_weekly_qb$passing_yards,
  dropUndefined = TRUE
)$rsquared
```

The accuracy for predicting passing yards ($R^2 = `r petersenlab::apa(rSquared_passYds, decimals = 2, leading = FALSE)`$) is higher than the accuracy for predicting passing touchdowns ($R^2 = `r petersenlab::apa(rSquared_passTds, decimals = 2, leading = FALSE)`$).

Here is the accuracy of the prediction of rushing touchdowns versus rushing yards among Running Backs:

```{r}
petersenlab::accuracyOverall(
  predicted = projectionsWithActuals_weekly_rb$rush_tds,
  actual = projectionsWithActuals_weekly_rb$rushing_tds,
  dropUndefined = TRUE
)

petersenlab::accuracyOverall(
  predicted = projectionsWithActuals_weekly_rb$rush_yds,
  actual = projectionsWithActuals_weekly_rb$rushing_yards,
  dropUndefined = TRUE
)
```

```{r}
#| include: false

rSquared_rushTds <- petersenlab::accuracyOverall(
  predicted = projectionsWithActuals_weekly_rb$rush_tds,
  actual = projectionsWithActuals_weekly_rb$rushing_tds,
  dropUndefined = TRUE
)$rsquared

rSquared_rushYds <- petersenlab::accuracyOverall(
  predicted = projectionsWithActuals_weekly_rb$rush_yds,
  actual = projectionsWithActuals_weekly_rb$rushing_yards,
  dropUndefined = TRUE
)$rsquared
```

The accuracy for predicting rushing yards ($R^2 = `r petersenlab::apa(rSquared_rushYds, decimals = 2, leading = FALSE)`$) is higher than the accuracy for predicting rushing touchdowns ($R^2 = `r petersenlab::apa(rSquared_rushTds, decimals = 2, leading = FALSE)`$).

Here is the accuracy of the prediction of receiving touchdowns versus receiving yards among Wide Receivers:

```{r}
petersenlab::accuracyOverall(
  predicted = projectionsWithActuals_weekly_wr$rec_tds,
  actual = projectionsWithActuals_weekly_wr$receiving_tds,
  dropUndefined = TRUE
)

petersenlab::accuracyOverall(
  predicted = projectionsWithActuals_weekly_wr$rec_yds,
  actual = projectionsWithActuals_weekly_wr$receiving_yards,
  dropUndefined = TRUE
)
```

```{r}
#| include: false

rSquared_recTds <- petersenlab::accuracyOverall(
  predicted = projectionsWithActuals_weekly_wr$rec_tds,
  actual = projectionsWithActuals_weekly_wr$receiving_tds,
  dropUndefined = TRUE
)$rsquared

rSquared_recYds <- petersenlab::accuracyOverall(
  predicted = projectionsWithActuals_weekly_wr$rec_yds,
  actual = projectionsWithActuals_weekly_wr$receiving_yards,
  dropUndefined = TRUE
)$rsquared
```

The accuracy for predicting receiving yards ($R^2 = `r petersenlab::apa(rSquared_recYds, decimals = 2, leading = FALSE)`$) is higher than the accuracy for predicting rushing touchdowns ($R^2 = `r petersenlab::apa(rSquared_recTds, decimals = 2, leading = FALSE)`$) among Wide Receivers.

Here is the accuracy of the prediction of receiving touchdowns versus receiving yards among Tight Ends:

```{r}
petersenlab::accuracyOverall(
  predicted = projectionsWithActuals_weekly_te$rec_tds,
  actual = projectionsWithActuals_weekly_te$receiving_tds,
  dropUndefined = TRUE
)

petersenlab::accuracyOverall(
  predicted = projectionsWithActuals_weekly_te$rec_yds,
  actual = projectionsWithActuals_weekly_te$receiving_yards,
  dropUndefined = TRUE
)
```

```{r}
#| include: false

rSquared_recTds_te <- petersenlab::accuracyOverall(
  predicted = projectionsWithActuals_weekly_te$rec_tds,
  actual = projectionsWithActuals_weekly_te$receiving_tds,
  dropUndefined = TRUE
)$rsquared

rSquared_recYds_te <- petersenlab::accuracyOverall(
  predicted = projectionsWithActuals_weekly_te$rec_yds,
  actual = projectionsWithActuals_weekly_te$receiving_yards,
  dropUndefined = TRUE
)$rsquared
```

The accuracy for predicting receiving yards ($R^2 = `r petersenlab::apa(rSquared_recYds_te, decimals = 2, leading = FALSE)`$) is higher than the accuracy for predicting rushing touchdowns ($R^2 = `r petersenlab::apa(rSquared_recTds_te, decimals = 2, leading = FALSE)`$) among Tight Ends.

In sum, the proportion of variance explained by the prediction (i.e., $R^2$) is much higher for passing/rushing/receiving yards than it is for touchdowns.
This is consistent with the notion that prediction accuracy tends to be lower for lower [base rate](#sec-baseRate) events (like touchdowns) compared to higher [base rate](#sec-baseRate) events.

### Sensitivity, Specificity, PPV, and NPV {#sec-sensitivitySpecificityPPVnpv}

As described earlier, percent accuracy is not the only important aspect of accuracy.
Percent accuracy can be misleading because it is highly influenced by [base rates](#sec-baseRate).
You can have a high percent accuracy by predicting from the base rate and saying that no one has the condition (if the [base rate](#sec-baseRate) is low) or that everyone has the condition (if the [base rate](#sec-baseRate) is high).
Thus, it is also important to consider other aspects of accuracy, including sensitivity (SN), specificity (SP), positive predictive value (PPV), and negative predictive value (NPV).
We want our predictions to be sensitive to be able to detect the characteristic but also to be specific so that we classify only people actually with the characteristic as having the characteristic.

Let us return to the [confusion matrix](#sec-confusionMatrix) in @fig-confusionMatrix3.
If we know the frequency of each of the four predicted-actual combinations of the [confusion matrix](#sec-confusionMatrix) (TP, TN, FP, FN), we can calculate sensitivity, specificity, PPV, and NPV.

Sensitivity is the proportion of those with the characteristic ($\text{TP} + \text{FN}$) that we identified with our measure ($\text{TP}$): $\frac{\text{TP}}{\text{TP} + \text{FN}} = \frac{86}{86 + 14} = .86$.
Specificity is the proportion of those who do not have the characteristic ($\text{TN} + \text{FP}$) that we correctly classify as not having the characteristic ($\text{TN}$): $\frac{\text{TN}}{\text{TN} + \text{FP}} = \frac{1,478}{1,478 + 422} = .78$.
PPV is the proportion of those who we classify as having the characteristic ($\text{TP} + \text{FP}$) who actually have the characteristic ($\text{TP}$): $\frac{\text{TP}}{\text{TP} + \text{FP}} = \frac{86}{86 + 422} = .17$.
NPV is the proportion of those we classify as not having the characteristic ($\text{TN} + \text{FN}$) who actually do not have the characteristic ($\text{TN}$): $\frac{\text{TN}}{\text{TN} + \text{FN}} = \frac{1,478}{1,478 + 14} = .99$.

Sensitivity, specificity, PPV, and NPV are proportions, and their values therefore range from 0 to 1, where higher values reflect greater accuracy.
With sensitivity, specificity, PPV, and NPV, we have a good snapshot of how accurate the measure is at a given cutoff.
In our case, our measure is good at finding whom to reject (high sensitivity), but it is rejecting too many people who do not need to be rejected (lower PPV due to many FPs).
Most people whom we classify as having the characteristic do not actually have the characteristic.
However, the fact that we are over-rejecting could be okay depending on our goals, for instance, if we do not care about over-dropping (i.e., the PPV being low).

#### Some Accuracy Estimates Depend on the Cutoff {#sec-accuracyCutoff}

Sensitivity, specificity, PPV, and NPV differ based on the cutoff (i.e., threshold) for classification.
Consider the following example.
Aliens visit Earth, and they develop a test to determine whether a berry is edible or inedible.

@fig-classificationDistributions depicts the distributions of scores by berry type.
Note how there are clearly two distinct distributions.
However, the distributions overlap to some degree.
Thus, any cutoff will have at least some inaccurate classifications.
The extent of overlap of the distributions reflects the amount of measurement error of the measure with respect to the characteristic of interest.

```{r}
#| label: fig-classificationDistributions
#| fig-cap: "Distribution of Test Scores by Berry Type."
#| fig-alt: "Distribution of Test Scores by Berry Type."
#| code-fold: true

#No Cutoff
sampleSize <- 1000

edibleScores <- rnorm(sampleSize, 50, 15)
inedibleScores <- rnorm(sampleSize, 100, 15)

edibleData <- data.frame(
  score = c(
    edibleScores,
    inedibleScores),
  type = c(
    rep("edible", sampleSize),
    rep("inedible", sampleSize)))

cutoff <- 75

hist_edible <- density(
  edibleScores,
  from = 0,
  to = 150) %$% # exposition pipe magrittr::`%$%`
  data.frame(
    x = x,
    y = y) %>%
  mutate(area = x >= cutoff)

hist_edible$type[hist_edible$area == TRUE] <- "edible_FP"
hist_edible$type[hist_edible$area == FALSE] <- "edible_TN"

hist_inedible <- density(
  inedibleScores,
  from = 0,
  to = 150) %$% # exposition pipe magrittr::`%$%`
  data.frame(
    x = x,
    y = y) %>%
  mutate(area = x < cutoff)

hist_inedible$type[hist_inedible$area == TRUE] <- "inedible_FN"
hist_inedible$type[hist_inedible$area == FALSE] <- "inedible_TP"

density_data <- bind_rows(
  hist_edible,
  hist_inedible)

density_data$type <- factor(
  density_data$type,
  levels = c(
    "edible_TN",
    "inedible_TP",
    "edible_FP",
    "inedible_FN"))

ggplot(
  data = edibleData,
  aes(
    x = score,
    ymin = 0,
    fill = type)) +
  geom_density(alpha = .5) +
  scale_fill_manual(
    name = "Berry Type",
    values = c(
      viridis::viridis(2)[1],
      viridis::viridis(2)[2])) +
  scale_y_continuous(name = "Frequency") +
  theme_bw() +
  theme(
    axis.text.y = element_blank(),
    axis.ticks.y = element_blank())
```

@fig-classificationStandardCutoff depicts the distributions of scores by berry type with a cutoff.
The red line indicates the cutoff—the level above which berries are classified by the test as inedible.
There are errors on each side of the cutoff.
Below the cutoff, there are some false negatives (blue): inedible berries that are inaccurately classified as edible.
Above the cutoff, there are some false positives (green): edible berries that are inaccurately classified as inedible.
Costs of false negatives could include sickness or death from eating the inedible berries.
Costs of false positives could include taking longer to find food, finding insufficient food, and starvation.

```{r}
#| label: fig-classificationStandardCutoff
#| fig-cap: "Classifications Based on a Cutoff. Note that some true negatives and true positives are hidden behind the false positives and false negatives."
#| fig-alt: "Classifications Based on a Cutoff. Note that some true negatives and true positives are hidden behind the false positives and false negatives."
#| code-fold: true

#Standard Cutoff
ggplot(
  data = density_data,
  aes(
    x = x,
    ymin = 0,
    ymax = y,
    fill = type)) +
  geom_ribbon(alpha = 1) +
  scale_fill_manual(
    name = "Berry Type",
    values = c(
      viridis::viridis(4)[4],
      viridis::viridis(4)[1],
      viridis::viridis(4)[3],
      viridis::viridis(4)[2]),
    breaks = c("edible_TN","inedible_TP","edible_FP","inedible_FN"),
    labels = c("Edible: TN","Inedible: TP","Edible: FP","Inedible: FN")) +
  geom_line(aes(y = y)) +
  geom_vline(
    xintercept = cutoff,
    color = "red",
    linewidth = 2) +
  scale_x_continuous(name = "score") +
  scale_y_continuous(name = "Frequency") +
  theme_bw() +
  theme(
    axis.text.y = element_blank(),
    axis.ticks.y = element_blank())
```

Based on our assessment goals, we might use a different selection ratio by changing the cutoff.
@fig-classificationRaiseCutoff depicts the distributions of scores by berry type when we raise the cutoff.
There are now more false negatives (blue) and fewer false positives (green).
If we raise the cutoff (to be more conservative), the number of false negatives increases and the number of false positives decreases.
Consequently, as the cutoff increases, sensitivity and NPV decrease (because we have more false negatives), whereas specificity and PPV increase (because we have fewer false positives).
A higher cutoff could be optimal if the costs of false positives are considered greater than the costs of false negatives.
For instance, if the aliens cannot risk eating the inedible berries because the berries are fatal, and there are sufficient edible berries that can be found to feed the alien colony.

```{r}
#| label: fig-classificationRaiseCutoff
#| fig-cap: "Classifications Based on Raising the Cutoff. Note that some true negatives and true positives are hidden behind the false positives and false negatives."
#| fig-alt: "Classifications Based on Raising the Cutoff. Note that some true negatives and true positives are hidden behind the false positives and false negatives."
#| code-fold: true

#Raise the cutoff
cutoff <- 85

hist_edible <- density(
  edibleScores,
  from = 0,
  to = 150) %$% # exposition pipe magrittr::`%$%`
  data.frame(
    x = x,
    y = y) %>%
  mutate(area = x >= cutoff)

hist_edible$type[hist_edible$area == TRUE] <- "edible_FP"
hist_edible$type[hist_edible$area == FALSE] <- "edible_TN"

hist_inedible <- density(
  inedibleScores,
  from = 0,
  to = 150) %$% # exposition pipe magrittr::`%$%`
  data.frame(
    x = x,
    y = y) %>%
  mutate(area = x < cutoff)

hist_inedible$type[hist_inedible$area == TRUE] <- "inedible_FN"
hist_inedible$type[hist_inedible$area == FALSE] <- "inedible_TP"

density_data <- bind_rows(
  hist_edible,
  hist_inedible)

density_data$type <- factor(
  density_data$type,
  levels = c(
    "edible_TN",
    "inedible_TP",
    "edible_FP",
    "inedible_FN"))

ggplot(
  data = density_data,
  aes(
    x = x,
    ymin = 0,
    ymax = y,
    fill = type)) +
  geom_ribbon(alpha = 1) +
  scale_fill_manual(
    name = "Berry Type",
    values = c(
      viridis::viridis(4)[4],
      viridis::viridis(4)[1],
      viridis::viridis(4)[3],
      viridis::viridis(4)[2]),
    breaks = c("edible_TN","inedible_TP","edible_FP","inedible_FN"),
    labels = c("Edible: TN","Inedible: TP","Edible: FP","Inedible: FN")) +
  geom_line(aes(y = y)) +
  geom_vline(
    xintercept = cutoff,
    color = "red",
    linewidth = 2) +
  scale_x_continuous(name = "score") +
  scale_y_continuous(name = "Frequency") +
  theme_bw() +
  theme(
    axis.text.y = element_blank(),
    axis.ticks.y = element_blank())
```

@fig-classificationLowerCutoff depicts the distributions of scores by berry type when we lower the cutoff.
There are now fewer false negatives (blue) and more false positives (green).
If we lower the cutoff (to be more liberal), the number of false negatives decreases and the number of false positives increases.
Consequently, as the cutoff decreases, sensitivity and NPV increase (because we have fewer false negatives), whereas specificity and PPV decrease (because we have more false positives).
A lower cutoff could be optimal if the costs of false negatives are considered greater than the costs of false positives.
For instance, if the aliens cannot risk missing edible berries because they are in short supply relative to the size of the alien colony, and eating the inedible berries would, at worst, lead to minor, temporary discomfort.

```{r}
#| label: fig-classificationLowerCutoff
#| fig-cap: "Classifications Based on Lowering the Cutoff. Note that some true negatives and true positives are hidden behind the false positives and false negatives."
#| fig-alt: "Classifications Based on Lowering the Cutoff. Note that some true negatives and true positives are hidden behind the false positives and false negatives."
#| code-fold: true

#Lower the cutoff
cutoff <- 65

hist_edible <- density(
  edibleScores,
  from = 0,
  to = 150) %$% # exposition pipe magrittr::`%$%`
  data.frame(
    x = x,
    y = y) %>%
  mutate(area = x >= cutoff)

hist_edible$type[hist_edible$area == TRUE] <- "edible_FP"
hist_edible$type[hist_edible$area == FALSE] <- "edible_TN"

hist_inedible <- density(
  inedibleScores,
  from = 0,
  to = 150) %$% # exposition pipe magrittr::`%$%`
  data.frame(
    x = x,
    y = y) %>%
  mutate(area = x < cutoff)

hist_inedible$type[hist_inedible$area == TRUE] <- "inedible_FN"
hist_inedible$type[hist_inedible$area == FALSE] <- "inedible_TP"

density_data <- bind_rows(
  hist_edible,
  hist_inedible)

density_data$type <- factor(
  density_data$type,
  levels = c(
    "edible_TN",
    "inedible_TP",
    "edible_FP",
    "inedible_FN"))

ggplot(
  data = density_data,
  aes(
    x = x,
    ymin = 0,
    ymax = y,
    fill = type)) +
  geom_ribbon(alpha = 1) +
  scale_fill_manual(
    name = "Berry Type",
    values = c(
      viridis::viridis(4)[4],
      viridis::viridis(4)[1],
      viridis::viridis(4)[3],
      viridis::viridis(4)[2]),
    breaks = c("edible_TN","inedible_TP","edible_FP","inedible_FN"),
    labels = c("Edible: TN","Inedible: TP","Edible: FP","Inedible: FN")) +
  geom_line(aes(y = y)) +
  geom_vline(
    xintercept = cutoff,
    color = "red",
    linewidth = 2) +
  scale_x_continuous(name = "score") +
  scale_y_continuous(name = "Frequency") +
  theme_bw() +
  theme(
    axis.text.y = element_blank(),
    axis.ticks.y = element_blank())
```

In sum, sensitivity and specificity differ based on the cutoff for classification.
If we raise the cutoff, sensitivity and PPV increase (due to fewer false positives), whereas sensitivity and NPV decrease (due to more false negatives).
If we lower the cutoff, sensitivity and NPV increase (due to fewer false negatives), whereas specificity and PPV decrease (due to more false positives).
Thus, the optimal cutoff depends on how costly each type of error is: false negatives and false positives.
If false negatives are more costly than false positives, we would set a low cutoff.
If false positives are more costly than false negatives, we would set a high cutoff.

### Set a Cutoff/Threshold {#sec-setCutoff}

For evaluating sensitivity, specificity, positive predictive value, negative predictive value, and the [receiver operating characteristic (ROC) curve](#sec-roc), we need to make a dichotomous decision/prediction.
For this example, our goal is to predict which Running Backs or Wide Receivers will score 300 or more fantasy points.
We will predict a player as scoring 300 or more fantasy points for a given projection source if that projection source projected the player to score 300 or more fantasy points.
Thus, our cutoff or threshold is 300 or more projected points.
The same player has multiple rows in the data file—one for each projection source.

```{r}
projectionsWithActuals_seasonal_subset <- projectionsWithActuals_seasonal %>% 
  filter(position_group %in% c("RB","WR")) %>% 
  filter(season == 2024)

projectionsWithActuals_seasonal_subset$prediction <- ifelse(projectionsWithActuals_seasonal_subset$raw_points >= 300, 1, 0)
projectionsWithActuals_seasonal_subset$truth <- ifelse(projectionsWithActuals_seasonal_subset$fantasyPoints >= 300, 1, 0)

projectionsWithActuals_seasonal_subset$predictionFactor <- factor(
  projectionsWithActuals_seasonal_subset$prediction,
  levels = c(1,0),
  labels = c("Prediction: Will Score 300+ Points", "Prediction: Will Not Score 300+ Points"))

projectionsWithActuals_seasonal_subset$truthFactor <- factor(
  projectionsWithActuals_seasonal_subset$truth,
  levels = c(1,0),
  labels = c("Truth: Scored 300+ Points", "Truth: Did Not Score 300+ Points")
)

table(projectionsWithActuals_seasonal_subset$predictionFactor)

table(projectionsWithActuals_seasonal_subset$truthFactor)
```

### Signal Detection Theory {#sec-sdt}

Signal detection theory (SDT) is a probability-based theory for the detection of a given stimulus (signal) from a stimulus set that includes non-target stimuli (noise).
SDT arose through the development of radar (**RA**dio **D**etection **A**nd **R**anging) and sonar (**SO**und **N**avigation **A**nd **R**anging) in World War II based on research on sensory-perception research.
The military wanted to determine which objects on radar/sonar were enemy aircraft/submarines, and which were noise (e.g., different object in the environment or even just the weather itself).
SDT allowed determining how many errors operators made (how accurate they were) and decomposing errors into different kinds of errors.
SDT distinguishes between sensitivity and bias.
In SDT, *sensitivity* (or discriminability) is how well an assessment distinguishes between a target stimulus and non-target stimuli (i.e., how well the assessment detects the target stimulus amid non-target stimuli).
*Bias* is the extent to which the probability of a selection decision from the assessment is higher or lower than the true rate of the target stimulus.

Some radar/sonar operators were not as sensitive to the differences between signal and noise, due to factors such as age, ability to distinguish gradations of a signal, etc.
People who showed low sensitivity (i.e., who were not as successful at distinguishing between signal and noise) were screened out because the military perceived sensitivity as a skill that was not easily taught.
By contrast, other operators could distinguish signal from noise, but their threshold was too low or high—they could take in information, but their decisions tended to be wrong due to systematic bias or poor calibration.
That is, they systematically over-rejected or under-rejected stimuli.
Over-rejecting leads to many false negatives (i.e., saying that a stimulus is safe when it is not).
Under-rejecting leads to many false positives (i.e., saying that a stimulus is harmful when it is not).
A person who showed good sensitivity but systematic bias was considered more teach-able than a person who showed low sensitivity.
Thus, radar and sonar operators were selected based on their sensitivity to distinguish signal from noise, and then were trained to improve the calibration so they reduce their systematic bias and do not systematically over- or under-reject.

Although SDT was originally developed for use in World War II, it now plays an important role in many areas of science and medicine.
A medical application of SDT is tumor detection in radiology.
Another application of SDT in society is using x-ray to detect bombs or other weapons.
An example of applying SDT to fantasy football could be in the prediction (and evaluation) of whether or not a player scores a touchdown in a game.

SDT metrics of sensitivity include $d'$ ("$d$-prime"), $A$ (or $A'$), and the area under the receiver operating characteristic (ROC) curve.
SDT metrics of bias include $\beta$ (beta), $c$, and $b$.

#### Receiver Operating Characteristic (ROC) Curve {#sec-roc}

The x-axis of the ROC curve is the false alarm rate or false positive rate ($1 -$ specificity).
The y-axis is the hit rate or true positive rate (sensitivity).
We can trace the ROC curve as the combination between sensitivity and specificity at every possible cutoff.
At a cutoff of zero (top right of ROC curve), we calculate sensitivity (1.0) and specificity (0) and plot it.
At a cutoff of zero, the assessment tells us to make an action for every stimulus (i.e., it is the most liberal).
We then gradually increase the cutoff, and plot sensitivity and specificity at each cutoff.
As the cutoff increases, sensitivity decreases and specificity increases.
We end at the highest possible cutoff, where the sensitivity is 0 and the specificity is 1.0 (i.e., we never make an action; i.e., it is the most conservative).
Each point on the ROC curve corresponds to a pair of hit and false alarm rates (sensitivity and specificity) resulting from a specific cutoff value.
Then, we can draw lines or a curve to connect the points.

@fig-aucExampleEmpirical depicts an empirical ROC plot where lines are drawn to connect the hit and false alarm rates, in predicting Running Backs and Wide Receivers who score 300 or more fantasy points.

```{r}
#| label: fig-aucExampleEmpirical
#| fig-cap: "Empirical Receiver Operating Characteristic (ROC) Curve for Predicting Running Backs and Wide Receivers that Score 300 or More Fantasy Points."
#| fig-alt: "Empirical Receiver Operating Characteristic (ROC) Curve for Predicting Running Backs and Wide Receivers that Score 300 or More Fantasy Points."
#| fig-width: 8
#| fig-height: 8

plot(
  pROC::roc(
    truth ~ raw_points,
    projectionsWithActuals_seasonal_subset),
  legacy.axes = TRUE,
  print.auc = TRUE)
```

@fig-aucExample depicts an ROC curve where a smoothed and fitted curve is drawn to connect the hit and false alarm rates, in predicting Running Backs and Wide Receivers who score 300 or more fantasy points.

```{r}
#| label: fig-aucExample
#| fig-cap: "Smoothed Receiver Operating Characteristic (ROC) Curve for Predicting Running Backs and Wide Receivers that Score 300 or More Fantasy Points."
#| fig-alt: "Smoothed Receiver Operating Characteristic (ROC) Curve for Predicting Running Backs and Wide Receivers that Score 300 or More Fantasy Points."
#| fig-width: 8
#| fig-height: 8

plot(
  pROC::roc(
    truth ~ raw_points,
    projectionsWithActuals_seasonal_subset,
    smooth = TRUE),
  legacy.axes = TRUE,
  print.auc = TRUE)
```

##### Area Under the ROC Curve {#sec-auc}

ROC methods can be used to compare and compute the discriminative power of measurement devices free from the influence of selection ratios, base rates, and costs and benefits.
An ROC analysis yields a quantitative index of how well an index predicts a signal of interest or can discriminate between different signals.
ROC analysis can help tell us how often our assessment would be correct.
If we randomly pick two observations, and we were right once and wrong once, we were 50% accurate.
But this would be a useless measure because it reflects chance responding.

The geometrical area under the ROC curve reflects the discriminative accuracy of the measure.
The index is called the **a**rea **u**nder the **c**urve (AUC) of an ROC curve.
AUC quantifies the discriminative power of an assessment.
AUC is the probability that a randomly selected target and a randomly selected non-target is ranked correctly by the assessment method.
AUC values range from 0.0 to 1.0, where chance accuracy is 0.5 as indicated by diagonal line in the ROC curve.
That is, a measure can be useful to the extent that its ROC curve is above the diagonal line (i.e., its discriminative accuracy is above chance).

AUC is a [threshold-independent accuracy index](#sec-thresholdIndependentAccuracy) that applies across all possible cutoff values.

@fig-aucRange depicts ROC curves with a range of AUC values.

```{r}
#| label: fig-aucRange
#| fig-cap: "Receiver Operating Characteristic (ROC) Curves for Various Levels of Area Under The ROC Curve (AUC) for Various Measures."
#| fig-alt: "Receiver Operating Characteristic (ROC) Curves for Various Levels of Area Under The ROC Curve (AUC) for Various Measures."
#| fig-width: 8
#| fig-height: 8
#| code-fold: true

set.seed(52242)

auc60 <- petersenlab::simulateAUC(.60, 50000)
auc70 <- petersenlab::simulateAUC(.70, 50000)
auc80 <- petersenlab::simulateAUC(.80, 50000)
auc90 <- petersenlab::simulateAUC(.90, 50000)
auc95 <- petersenlab::simulateAUC(.95, 50000)
auc99 <- petersenlab::simulateAUC(.99, 50000)

plot(
  pROC::roc(
    y ~ x,
    auc60,
    smooth = TRUE),
  legacy.axes = TRUE,
  print.auc = TRUE,
  print.auc.x = .52,
  print.auc.y = .61,
  print.auc.pattern = "%.2f")

plot(
  pROC::roc(
    y ~ x,
    auc70,
    smooth = TRUE),
  legacy.axes = TRUE,
  print.auc = TRUE,
  print.auc.x = .6,
  print.auc.y = .67,
  print.auc.pattern = "%.2f",
  add = TRUE)

plot(
  pROC::roc(
    y ~ x,
    auc80,
    smooth = TRUE),
  legacy.axes = TRUE,
  print.auc = TRUE,
  print.auc.x = .695,
  print.auc.y = .735,
  print.auc.pattern = "%.2f",
  add = TRUE)

plot(
  pROC::roc(
    y ~ x,
    auc90,
    smooth = TRUE),
  legacy.axes = TRUE,
  print.auc = TRUE,
  print.auc.x = .805,
  print.auc.y = .815,
  print.auc.pattern = "%.2f",
  add = TRUE)

plot(
  pROC::roc(
    y ~ x,
    auc95,
    smooth = TRUE),
  legacy.axes = TRUE,
  print.auc = TRUE,
  print.auc.x = .875,
  print.auc.y = .865,
  print.auc.pattern = "%.2f",
  add = TRUE)

plot(
  pROC::roc(
    y ~ x,
    auc99,
    smooth = TRUE),
  legacy.axes = TRUE,
  print.auc = TRUE,
  print.auc.x = .94,
  print.auc.y = .94,
  print.auc.pattern = "%.2f",
  add = TRUE)
```

As an example, given an AUC of .75, this says that the overall score of an individual who has the characteristic in question will be higher 75% of the time than the overall score of an individual who does not have the characteristic.
In lay terms, AUC provides the probability that we will classify correctly based on our instrument if we were to randomly pick one good and one bad outcome.
AUC is a stronger index of accuracy than percent accuracy, because you can have high percent accuracy just by going with the base rate.
AUC tells us how much better than chance a measure is at discriminating outcomes.
AUC is useful as a measure of general discriminative accuracy, and it tells us how accurate a measure is at all possible cutoffs.
Knowing the accuracy of a measure at all possible cutoffs can be helpful for selecting the optimal cutoff, given the goals of the assessment.
In reality, however, we may not be interested in all cutoffs because not all errors are equal in their costs.

If we lower the base rate, we would need a larger sample to get enough people to classify into each group.
SDT/ROC methods are traditionally about dichotomous decisions (yes/no), not graded judgments.
SDT/ROC methods can get messy with ordinal data that are more graded because you would have an AUC curve for each ordinal grouping.

### Accuracy Indices {#sec-accuracyIndicesCategorical}

There are various accuracy indices we can use to evaluate the accuracy of predictions for categorical outcome variables.
We have already described several accuracy indices, including percent accuracy, sensitivity, specificity, positive predictive value, negative predictive value, and area under the ROC curve.
We describe these and other indices in greater detail below.

The [`petersenlab`](https://cran.r-project.org/web/packages/petersenlab/index.html) package [@R-petersenlab] contains the `petersenlab::accuracyAtCutoff()` function that computes many accuracy indices for the prediction of categorical outcome variables.
In the example below, we compute the accuracy of predictions for which Running Backs or Wide Receivers will score 300 or more fantasy points, using a cutoff for projected fantasy points of 300.

```{r}
petersenlab::accuracyAtCutoff(
  predicted = projectionsWithActuals_seasonal_subset$raw_points,
  actual = projectionsWithActuals_seasonal_subset$truth,
  cutoff = 300
)
```

The [`petersenlab`](https://cran.r-project.org/web/packages/petersenlab/index.html) package [@R-petersenlab] contains the `petersenlab::accuracyAtEachCutoff()` function that computes many accuracy indices for the prediction of categorical outcome variables at each possible cutoff.
In the example below, we compute the accuracy of predictions for which Running Backs or Wide Receivers will score 300 or more fantasy points, at each possible cutoff for projected fantasy points.

```{r}
petersenlab::accuracyAtEachCutoff(
  predicted = projectionsWithActuals_seasonal_subset$raw_points,
  actual = projectionsWithActuals_seasonal_subset$truth
)
```

There are also test calculators available online:

- <http://araw.mede.uic.edu/cgi-bin/testcalc.pl> [@Schwartz2006; archived at <https://perma.cc/X8TF-7YBX>]
- <https://dlrs.shinyapps.io/shinyDLRs> [@Goodman2022]

#### Confusion Matrix aka 2x2 Accuracy Table aka Cross-Tabulation aka Contingency Table {#sec-confusionMatrix}

A confusion matrix (aka 2x2 accuracy table, cross-tabulation table, or contigency table) is a matrix for categorical data that presents the predicted outcome on one dimension and the actual outcome (truth) on the other dimension.
If the predictions and outcomes are dichotomous, the confusion matrix is a 2x2 matrix with two rows and two columns that represent four possible predicted-actual combinations ([decision outcomes](#sec-decisionOutcomes)).
In such a case, the confusion matrix provides a tabular count of each type of accurate cases ([true positives](#sec-truePositive) and [true negatives](#sec-trueNegative)) versus the number of each type of error ([false positives](#sec-falsePositive) and [false negatives](#sec-falseNegative)), as shown in @fig-confusionMatrix.
An example of a confusion matrix is in @fig-confusionMatrix1.

Here is our 2x2 confusion matrix, predicting which Running Backs or Wide Receivers will score 300 or more fantasy points.

```{r}
projectionsWithActuals_seasonal_subset <- projectionsWithActuals_seasonal %>% 
  filter(position_group %in% c("RB","WR")) %>% 
  filter(season == 2024)

projectionsWithActuals_seasonal_subset$prediction <- ifelse(projectionsWithActuals_seasonal_subset$raw_points >= 300, 1, 0)
projectionsWithActuals_seasonal_subset$truth <- ifelse(projectionsWithActuals_seasonal_subset$fantasyPoints >= 300, 1, 0)

projectionsWithActuals_seasonal_subset$predictionFactor <- factor(
  projectionsWithActuals_seasonal_subset$prediction,
  levels = c(1,0),
  labels = c("Prediction: Will Score 300+ Points", "Prediction: Will Not Score 300+ Points"))

projectionsWithActuals_seasonal_subset$truthFactor <- factor(
  projectionsWithActuals_seasonal_subset$truth,
  levels = c(1,0),
  labels = c("Truth: Scored 300+ Points", "Truth: Did Not Score 300+ Points")
)

table(projectionsWithActuals_seasonal_subset$predictionFactor)

table(projectionsWithActuals_seasonal_subset$truthFactor)
```

##### Number {#sec-confusionMatrix-number}

```{r}
table(
  projectionsWithActuals_seasonal_subset$predictionFactor,
  projectionsWithActuals_seasonal_subset$truthFactor)
```

##### Number With Margins Added {#sec-confusionMatrix-numberMargins}

```{r}
addmargins(table(
  projectionsWithActuals_seasonal_subset$predictionFactor,
  projectionsWithActuals_seasonal_subset$truthFactor))
```

##### Proportions {#sec-confusionMatrix-numberMarginsProportions}

```{r}
prop.table(table(
  projectionsWithActuals_seasonal_subset$predictionFactor,
  projectionsWithActuals_seasonal_subset$truthFactor))
```

##### Proportions With Margins Added {#sec-confusionMatrix-numberMarginsProportionsMargins}

```{r}
addmargins(prop.table(table(
  projectionsWithActuals_seasonal_subset$predictionFactor,
  projectionsWithActuals_seasonal_subset$truthFactor)))
```

#### True Positives (TP) {#sec-truePositive}

True positives (TPs) are instances in which a positive classification (e.g., stating that a disease is present for a person) is correct—that is, the test says that a classification is present, and the classification is present.
True positives are also called valid positives (VPs) or hits.
Higher values reflect greater accuracy.
The formula for true positives is in @eq-truePositive:

$$
\begin{aligned}
  \text{TP} &= \text{BR} \times \text{SR} \times N
\end{aligned}
$$ {#eq-truePositive}

#### True Negatives (TN) {#sec-trueNegative}

True negatives (TNs) are instances in which a negative classification (e.g., stating that a disease is absent for a person) is correct—that is, the test says that a classification is not present, and the classification is actually not present.
True negatives are also called valid negatives (VNs) or correct rejections.
Higher values reflect greater accuracy.
The formula for true negatives is in @eq-trueNegative:

$$
\begin{aligned}
  \text{TN} &= (1 - \text{BR}) \times (1 - \text{SR}) \times N
\end{aligned}
$$ {#eq-trueNegative}

#### False Positives (FP) {#sec-falsePositive}

False positives (FPs) are instances in which a positive classification (e.g., stating that a disease is present for a person) is incorrect—that is, the test says that a classification is present, and the classification is not present.
False positives are also called false alarms (FAs).
Lower values reflect greater accuracy.
The formula for false positives is in Equation @eq-falsePositive:

$$
\begin{aligned}
  \text{FP} &= (1 - \text{BR}) \times \text{SR} \times N
\end{aligned}
$$ {#eq-falsePositive}

#### False Negatives (FN) {#sec-falseNegative}

False negatives (FNs) are instances in which a negative classification (e.g., stating that a disease is absent for a person) is incorrect—that is, the test says that a classification is not present, and the classification is present.
False negatives are also called misses.
Lower values reflect greater accuracy.
The formula for false negatives is in @eq-falseNegative:

$$
\begin{aligned}
  \text{FN} &= \text{BR} \times (1 - \text{SR}) \times N
\end{aligned}
$$ {#eq-falseNegative}

#### Selection Ratio (SR) {#sec-selectionRatio}

The selection ratio (SR) is the marginal probability of selection, independent of other things: $P(R_i)$.
It is not an index of accuracy, per se.
In medicine, the selection ratio is the proportion of people who test positive for the disease.
In fantasy football, the selection ratio is the proportion of players who you predict will show a given outcome.
For example, if you are trying to predict the players who will score a touchdown in a game, the selection ratio is the proportion of players who you predict will score a touchdown.
The formula for calculating the selection ratio is in @eq-selectionRatio.

$$
\begin{aligned}
  \text{SR} &= P(R_i) \\
  &= \frac{\text{TP} + \text{FP}}{N}
\end{aligned}
$$ {#eq-selectionRatio}

#### Base Rate (BR) {#sec-pretestProbability}

The [base rate](#sec-baseRate) (BR) of a classification is its [marginal probability](#sec-baseRate), independent of other things: $P(C_i)$.
It is not an index of accuracy, per se.
In medicine, the base rate of a disease is its prevalence in the population, as in @eq-baseRate.
Without additional information, the [base rate](#sec-baseRate) is used as the initial *pretest probability*.
In fantasy football, the [base rate](#sec-baseRate) is the proportion of players who actually show the particular outcome.
For example, if you are trying to predict the players who will score a touchdown in a game, the [base rate](#sec-baseRate) is the proportion of players who actually score a touchdown in the game.
The formula for calculating the selection ratio is in @eq-baseRate.

$$
\begin{aligned}
  \text{BR} &= P(C_i) \\
  &= \frac{\text{TP} + \text{FN}}{N}
\end{aligned}
$$ {#eq-baseRate}

#### Pretest Odds {#sec-pretestOdds}

The pretest odds of a classification can be estimated using the pretest probability (i.e., [base rate](#sec-baseRate)).
To convert a probability to odds, divide the probability by one minus that probability, as in @eq-pretestOdds.

$$
\begin{aligned}
  \text{pretest odds} &= \frac{\text{pretest probability}}{1 - \text{pretest probability}} \\
\end{aligned}
$$ {#eq-pretestOdds}

#### Percent Accuracy {#sec-percentAccuracy}

Percent Accuracy is also called overall accuracy.
Higher values reflect greater accuracy.
The formula for percent accuracy is in @eq-percentAccuracy.
Percent accuracy has several problems.
First, it treats all errors ([FP](#sec-falsePositive) and [FN](#sec-falseNegative)) as equally important.
However, in practice, it is rarely the case that [false positives](#sec-falsePositive) and [false negatives](#sec-falseNegative) are equally important.
Second, percent accuracy can be misleading because it is highly influenced by [base rates](#sec-baseRate).
You can have a high percent accuracy by predicting from the [base rate](#sec-baseRate) and saying that no one has the characteristic (if the [base rate](#sec-baseRate) is low) or that everyone has the characteristic (if the [base rate](#sec-baseRate) is high).
Thus, it is also important to consider other aspects of accuracy.

$$
\text{Percent Accuracy} = 100\% \times \frac{\text{TP} + \text{TN}}{N}
$$ {#eq-percentAccuracy}

#### Percent Accuracy by Chance {#sec-percentAccuracyByChance}

The formula for calculating percent accuracy by chance is in @eq-percentAccuracyByChance.

$$
\begin{aligned}
  \text{Percent Accuracy by Chance} &= 100\% \times [P(\text{TP}) + P(\text{TN})] \\
  &= 100\% \times \{(\text{BR} \times {\text{SR}}) + [(1 - \text{BR}) \times (1 - \text{SR})]\}
\end{aligned}
$$ {#eq-percentAccuracyByChance}

#### Percent Accuracy Predicting from the Base Rate {#sec-percentAccuracyPredictingFromBaseRate}

[*Predicting from the base rate*](#sec-predictingFromBaseRate) is going with the most likely outcome in every prediction.
If the [base rate](#sec-baseRate) is less than .50, it would involve predicting that the condition is absent for every case.
If the [base rate](#sec-baseRate) is .50 or above, it would involve predicting that the condition is present for every case.
[Predicting from the base rate](#sec-predictingFromBaseRate) is a special case of [percent accuracy by chance](#sec-percentAccuracyByChance) when the [selection ratio](#sec-selectionRatio) is set to either one (if the [base rate](#sec-baseRate) $\geq$ .5) or zero (if the [base rate](#sec-baseRate) < .5).

#### Relative Improvement Over Chance (RIOC) {#sec-relativeImprovementOverChance}

Relative improvement over chance (RIOC) is a prediction's improvement over chance as a proportion of the maximum possible improvement over chance, as described by @Farrington1989.
Higher values reflect greater accuracy.
The formula for calculating RIOC is in @eq-relativeImprovementOverChance.

$$
\begin{aligned}
  \text{relative improvement over chance (RIOC)} &= \frac{\text{total correct} - \text{chance correct}}{\text{maximum correct} - \text{chance correct}} \\
\end{aligned}
$$ {#eq-relativeImprovementOverChance}

#### Relative Improvement Over Predicting from the Base Rate {#sec-relativeImprovementOverPredictingFromBaseRate}

Relative improvement over [predicting from the base rate](#sec-predictingFromBaseRate) is a prediction's improvement over [predicting from the base rate](#sec-predictingFromBaseRate) as a proportion of the maximum possible improvement over [predicting from the base rate](#sec-predictingFromBaseRate).
Higher values reflect greater accuracy.
The formula for calculating relative improvement over predicting from the base rate is in @eq-relativeImprovementOverPredictingFromBaseRate.

$$
\scriptsize
\begin{aligned}
  \text{relative improvement over predicting from base rate} &= \frac{\text{total correct} - \text{correct by predicting from base rate}}{\text{maximum correct} - \text{correct by predicting from base rate}} \\
\end{aligned}
$$ {#eq-relativeImprovementOverPredictingFromBaseRate}

#### Sensitivity (SN) {#sec-sensitivity}

Sensitivity (SN) is also called true positive rate (TPR), hit rate (HR), or recall.
Sensitivity is the [conditional probability](#sec-conditionalProbability) of a positive test given that the person has the condition: $P(R|C)$.
Higher values reflect greater accuracy.
The formula for calculating sensitivity is in @eq-sensitivity.
As described in @sec-accuracyCutoff, as the cutoff increases (becomes more conservative), sensitivity decreases.
As the cutoff decreases, sensitivity increases.

$$
\begin{aligned}
  \text{sensitivity (SN)} &= P(R|C) \\
  &= \frac{\text{TP}}{\text{TP} + \text{FN}} = \frac{\text{TP}}{N \times \text{BR}} = 1 - \text{FNR}
\end{aligned}
$$ {#eq-sensitivity}

#### Specificity (SP) {#sec-specificity}

Specificity (SP) is also called true negative rate (TNR) or selectivity.
Specificity is the [conditional probability](#sec-conditionalProbability) of a negative test given that the person does not have the condition: $P(\text{not } R|\text{not } C)$.
Higher values reflect greater accuracy.
The formula for calculating specificity is in @eq-specificity.
As described in @sec-accuracyCutoff, as the cutoff increases (becomes more conservative), specificity increases.
As the cutoff decreases, specificity decreases.

$$
\begin{aligned}
  \text{specificity (SP)} &= P(\text{not } R|\text{not } C) \\
  &= \frac{\text{TN}}{\text{TN} + \text{FP}} = \frac{\text{TN}}{N (1 - \text{BR})} = 1 - \text{FPR}
\end{aligned}
$$ {#eq-specificity}

#### False Negative Rate (FNR) {#sec-falseNegativeRate}

The false negative rate (FNR) is also called the miss rate.
The false negative rate is the [conditional probability](#sec-conditionalProbability) of a negative test given that the person has the condition: $P(\text{not } R|C)$.
Lower values reflect greater accuracy.
The formula for calculating false negative rate is in @eq-falseNegativeRate.

$$
\begin{aligned}
  \text{false negative rate (FNR)} &= P(\text{not } R|C) \\
  &= \frac{\text{FN}}{\text{FN} + \text{TP}} = \frac{\text{FN}}{N \times \text{BR}} = 1 - \text{TPR}
\end{aligned}
$$ {#eq-falseNegativeRate}

#### False Positive Rate (FPR) {#sec-falsePositiveRate}

The false positive rate (FPR) is also called the false alarm rate (FAR) or fall-out.
The false positive rate is the [conditional probability](#sec-conditionalProbability) of a positive test given that the person does not have the condition: $P(R|\text{not } C)$.
Lower values reflect greater accuracy.
The formula for calculating false positive rate is in @eq-falsePositiveRate:

$$
\begin{aligned}
  \text{false positive rate (FPR)} &= P(R|\text{not } C) \\
  &= \frac{\text{FP}}{\text{FP} + \text{TN}} = \frac{\text{FP}}{N (1 - \text{BR})} = 1 - \text{TNR}
\end{aligned}
$$ {#eq-falsePositiveRate}

#### Positive Predictive Value (PPV) {#sec-ppv}

The positive predictive value (PPV) is also called the positive predictive power (PPP) or precision.
Many people confuse [sensitivity](#sec-sensitivity) ($P(R|C)$) with its inverse [conditional probability](#sec-conditionalProbability), PPV ($P(C|R)$).
PPV is the [conditional probability](#sec-conditionalProbability) of having the condition given a positive test: $P(C|R)$.
Higher values reflect greater accuracy.
The formula for calculating positive predictive value is in @eq-positivePredictiveValue.

PPV can be low even when [sensitivity](#sec-sensitivity) is high because it depends not only on [sensitivity](#sec-sensitivity), but also on [specificity](#sec-specificity) and the [base rate](#sec-baseRate).
Because PPV depends on the [base rate](#sec-baseRate), PPV is not an intrinsic property of a measure.
The same measure will have a different PPV in different contexts with different [base rates](#sec-baseRate) [@Treat2023].
As described in @sec-accuracyCutoff, as the [base rate](#sec-baseRate) increases, PPV increases.
As the [base rate](#sec-baseRate) decreases, PPV decreases.
PPV also differs as a function of the cutoff.
As described in @sec-accuracyCutoff, as the cutoff increases (becomes more conservative), PPV increases.
As the cutoff decreases (becomes more liberal), PPV decreases.

$$
\small
\begin{aligned}
  \text{positive predictive value (PPV)} &= P(C|R) \\
  &= \frac{\text{TP}}{\text{TP} + \text{FP}} = \frac{\text{TP}}{N \times \text{SR}}\\
  &= \frac{\text{sensitivity} \times {\text{BR}}}{\text{sensitivity} \times {\text{BR}} + [(1 - \text{specificity}) \times (1 - \text{BR})]}
\end{aligned}
$$ {#eq-positivePredictiveValue}

#### Negative Predictive Value (NPV) {#sec-npv}

The negative predictive value (NPV) is also called the negative predictive power (NPP).
Many people confuse [specificity](#sec-specificity) ($P(\text{not } R|\text{not } C)$) with its inverse [conditional probability](#sec-conditionalProbability), NPV ($P(\text{not } C| \text{not } R)$).
NPV is the [conditional probability](#sec-conditionalProbability) of not having the condition given a negative test: $P(\text{not } C| \text{not } R)$.
Higher values reflect greater accuracy.
The formula for calculating negative predictive value is in @eq-negativePredictiveValue.

NPV can be low even when [specificity](#sec-specificity) is high because it depends not only on [specificity](#sec-specificity), but also on [sensitivity](#sec-sensitivity) and the [base rate](#sec-baseRate).
Because NPV depends on the [base rate](#sec-baseRate), NPV is not an intrinsic property of a measure.
The same measure will have a different NPV in different contexts with different [base rates](#sec-baseRate) [@Treat2023].
As described in @sec-accuracyCutoff, as the [base rate](#sec-baseRate) increases, NPV decreases.
As the [base rate](#sec-baseRate) decreases, NPV increases.
NPV also differs as a function of the cutoff.
As described in @sec-accuracyCutoff, as the cutoff increases (becomes more conservative), NPV decreases.
As the cutoff decreases (becomes more liberal), NPV decreases.

$$
\small
\begin{aligned}
  \text{negative predictive value (NPV)} &= P(\text{not } C|\text{not } R) \\
  &= \frac{\text{TN}}{\text{TN} + \text{FN}} = \frac{\text{TN}}{N(\text{1 - SR})}\\
  &= \frac{\text{specificity} \times (1-{\text{BR}})}{\text{specificity} \times (1-{\text{BR}}) + [(1 - \text{sensitivity}) \times \text{BR})]}
\end{aligned}
$$ {#eq-negativePredictiveValue}

#### False Discovery Rate (FDR) {#sec-falseDiscoveryRate}

Many people confuse the false positive rate ($P(R|\text{not } C)$) with its inverse [conditional probability](#sec-conditionalProbability), the false discovery rate ($P(\text{not } C| R)$).
The false discovery rate (FDR) is the [conditional probability](#sec-conditionalProbability) of not having the condition given a positive test: $P(\text{not } C| R)$.
Lower values reflect greater accuracy.
The formula for calculating false discovery rate is in @eq-falseDiscoveryRate.

$$
\begin{aligned}
  \text{false discovery rate (FDR)} &= P(\text{not } C|R) \\
  &= \frac{\text{FP}}{\text{FP} + \text{TP}} = 1 - \text{PPV}
\end{aligned}
$$ {#eq-falseDiscoveryRate}

#### False Omission Rate (FOR) {#sec-falseOmissionRate}

Many people confuse the false negative rate ($P(\text{not } R|C)$) with its inverse [conditional probability](#sec-conditionalProbability), the false omission rate ($P(C|\text{not } R)$).
The false omission rate (FOR) is the conditional probability of having the condition given a negative test: $P(C|\text{not } R)$.
Lower values reflect greater accuracy.
The formula for calculating false omission rate is in @sec-falseOmissionRate.

$$
\begin{aligned}
  \text{false omission rate (FOR)} &= P(C|\text{not } R) \\
  &= \frac{\text{FN}}{\text{FN} + \text{TN}} = 1 - \text{NPV}
\end{aligned}
$$ {#eq-falseOmissionRate}

#### Youden's J Statistic {#sec-youdenJ-example}

Youden's J statistic is also called Youden's Index or informedness.
Youden's J statistic is the sum of [sensitivity](#sec-sensitivity) and [specificity](#sec-specificity) (and subtracting one).
Higher values reflect greater accuracy.
The formula for calculating Youden's J statistic is in @eq-youdenIndex.

$$
\begin{aligned}
  \text{Youden's J statistic} &= \text{sensitivity} + \text{specificity} - 1
\end{aligned}
$$ {#eq-youdenIndex}

#### Balanced Accuracy {#sec-balancedAccuracy}

Balanced accuracy is the average of [sensitivity](#sec-sensitivity) and [specificity](#sec-specificity).
Higher values reflect greater accuracy.
The formula for calculating balanced accuracy is in @eq-balancedAccuracy.

$$
\begin{aligned}
  \text{balanced accuracy} &= \frac{\text{sensitivity} + \text{specificity}}{2}
\end{aligned}
$$ {#eq-balancedAccuracy}

#### F-Score {#sec-fScore}

The F-score combines [precision](#sec-ppv) ([positive predictive value](#sec-ppv)) and [recall](#sec-sensitivity) ([sensitivity](#sec-sensitivity)), where $\beta$ indicates how many times more important [sensitivity](#sec-sensitivity) is than the [positive predictive value](#sec-ppv).
If [sensitivity](#sec-sensitivity) and the [positive predictive value](#sec-ppv) are equally important, $\beta = 1$, and the F-score is called the $F_1$ score.
Higher values reflect greater accuracy.
The formula for calculating the F-score is in @eq-FScore.

$$
\begin{aligned}
  F_\beta &= (1 + \beta^2) \cdot \frac{\text{positive predictive value} \cdot \text{sensitivity}}{(\beta^2 \cdot \text{positive predictive value}) + \text{sensitivity}} \\
  &= \frac{(1 + \beta^2) \cdot \text{TP}}{(1 + \beta^2) \cdot \text{TP} + \beta^2 \cdot \text{FN} + \text{FP}}
\end{aligned}
$$ {#eq-FScore}

The formula for calculating the $F_1$ score is in @eq-F1Score.

$$
\begin{aligned}
  F_1 &= \frac{2 \cdot \text{positive predictive value} \cdot \text{sensitivity}}{(\text{positive predictive value}) + \text{sensitivity}} \\
  &= \frac{2 \cdot \text{TP}}{2 \cdot \text{TP} + \text{FN} + \text{FP}}
\end{aligned}
$$ {#eq-F1Score}

#### Matthews Correlation Coefficient (MCC) {#sec-matthewsCorrelationCoefficient}

The Matthews correlation coefficient (MCC) is also called the phi coefficient.
It is a correlation coefficient between predicted and observed values from a binary classification.
Higher values reflect greater accuracy.
The formula for calculating the MCC is in @eq-matthewsCorrelationCoefficient.

$$
\begin{aligned}
  \text{MCC} &= \frac{\text{TP} \times \text{TN} - \text{FP} \times \text{FN}}{\sqrt{(\text{TP} + \text{FP})(\text{TP} + \text{FN})(\text{TN} + \text{FP})(\text{TN} + \text{FN})}}
\end{aligned}
$$ {#eq-matthewsCorrelationCoefficient}

#### Diagnostic Odds Ratio {#sec-diagnosticOddsRatio}

The diagnostic odds ratio is the odds of a positive test among people with the condition relative to the odds of a positive test among people without the condition.
Higher values reflect greater accuracy.
The formula for calculating the diagnostic odds ratio is in @eq-diagnosticOddsRatio.
If the predictor is bad, the diagnostic odds ratio could be less than one, and values can go up from there.
If the diagnostic odds ratio is greater than 2, we take the odds ratio seriously because we are twice as likely to predict accurately than inaccurately.
However, the diagnostic odds ratio ignores/hides [base rates](#sec-baseRate).
When interpreting the diagnostic odds ratio, it is important to keep in mind the [practical significance](#sec-practicalSignificance), because otherwise it is not very meaningful.
Consider a risk factor that has a diagnostic odds ratio of 3 for tuberculosis, i.e., it puts you at 3 times as likely to develop tuberculosis.
The prevalence of tuberculosis is relatively low.
Assuming the prevalence of tuberculosis is less than 1/10th of 1%, your risk of developing tuberculosis is still very low even if the risk factor (with a diagnostic odds ratio of 3) is present.

$$
\begin{aligned}
  \text{diagnostic odds ratio} &= \frac{\text{TP} \times \text{TN}}{\text{FP} \times \text{FN}} \\
  &= \frac{\text{sensitivity} \times \text{specificity}}{(1 - \text{sensitivity}) \times (1 - \text{specificity})} \\
  &= \frac{\text{PPV} \times \text{NPV}}{(1 - \text{PPV}) \times (1 - \text{NPV})} \\
  &= \frac{\text{LR+}}{\text{LR}-}
\end{aligned}
$$ {#eq-diagnosticOddsRatio}

#### Diagnostic Likelihood Ratio {#sec-diagnosticLikelihoodRatio2}

The diagnostic likelihood ratio is described in @sec-diagnosticLikelihoodRatio.
There are two types of diagnostic likelihood ratios: the [positive likelihood ratio](#sec-positiveLikelihoodRatio) and the [negative likelihood ratio](#sec-negativeLikelihoodRatio).

##### Positive Likelihood Ratio (LR+) {#sec-positiveLikelihoodRatio2}

The positive likelihood ratio (LR+) is described in @sec-positiveLikelihoodRatio.
The formula for calculating the positive likelihood ratio is in @eq-positiveLikelihoodRatio.

##### Negative Likelihood Ratio (LR−) {#sec-negativeLikelihoodRatio2}

The negative likelihood ratio (LR−) is described in @sec-negativeLikelihoodRatio.
The formula for calculating the negative likelihood ratio is in @eq-positiveLikelihoodRatio.

#### Posttest Odds {#sec-posttestOdds}

As presented in @eq-bayes5, the posttest (or posterior) odds are equal to the [pretest odds](#sec-pretestOdds) multiplied by the [likelihood ratio](#sec-diagnosticLikelihoodRatio).
The posttest odds and [posttest probability](#sec-posttestProbability) can be useful to calculate when the [pretest probability](#sec-baseRate) is different from the [pretest probability](#sec-baseRate) (or prevalence) of the classification.
For instance, you might use a different [pretest probability](#sec-baseRate) if a test result is already known and you want to know the updated [posttest probability](#sec-posttestProbability) after conducting a second test.
The formula for calculating posttest odds is in @eq-posttestOdds.

$$
\begin{aligned}
  \text{posttest odds} &= \text{pretest odds} \times \text{likelihood ratio} \\
\end{aligned}
$$ {#eq-posttestOdds}

For calculating the posttest odds of a [true positive](#sec-truePositive) compared to a [false positive](#sec-falsePositive), we use the [positive likelihood ratio](#sec-positiveLikelihoodRatio) below.
We would use the [negative likelihood ratio](#sec-negativeLikelihoodRatio) if we wanted to calculate the posttest odds of a [false negative](#sec-falseNegative) compared to a [true negative](#sec-trueNegative).

#### Posttest Probability {#sec-posttestProbability}

The posttest probability is the probability of having the characteristic given a test result.
When the [base rate](#sec-baseRate) is used as the [pretest probability](#sec-baseRate), the posttest probability given a positive test is equal to [positive predictive value](#sec-ppv).
To convert odds to a probability, divide the odds by one plus the odds, as is in @eq-posttestProbability.

$$
\begin{aligned}
  \text{posttest probability} &= \frac{\text{posttest odds}}{1 + \text{posttest odds}}
\end{aligned}
$$ {#eq-posttestProbability}

#### Mean Difference Between Predicted and Observed Values {#sec-miscalibration}

The mean difference between predicted values versus observed values at a given cutoff is an index of [miscalibration](#sec-calibration) of predictions at that cutoff.
It is called "calibration-in-the-small" (as opposed to calibration-in-the-large, which spans all cutoffs).
Values closer to zero reflect greater accuracy.
Values above zero indicate that the predicted values are, on average, greater than the observed values.
Values below zero indicate that the observed values are, on average, greater than the predicted values.

### Optimal Cutoff {#sec-optimalCutoff}

The [`petersenlab`](https://cran.r-project.org/web/packages/petersenlab/index.html) package [@R-petersenlab] contains the `petersenlab::optimalCutoff()` function that identifies the cutoff that optimizes each of various accuracy estimates.

```{r}
#| eval: false

petersenlab::optimalCutoff(
  predicted = projectionsWithActuals_seasonal_subset$raw_points,
  actual = projectionsWithActuals_seasonal_subset$truth)
```

```{r}
#| include: false

optimalCutoff <- petersenlab::optimalCutoff(
  predicted = projectionsWithActuals_seasonal_subset$raw_points,
  actual = projectionsWithActuals_seasonal_subset$truth)
```

```{r}
#| echo: false

for(i in 1:length(optimalCutoff)){
  print(head(optimalCutoff[[i]]))
}
```

## Threshold-Independent Accuracy Indices {#sec-thresholdIndependentAccuracy}

This section describes threshold-independent indexes of accuracy.
That is, each index of accuracy described in this section provides a single numerical index of accuracy that aggregates the accuracy across all possible cutoffs.
The [`petersenlab`](https://cran.r-project.org/web/packages/petersenlab/index.html) package [@R-petersenlab] contains the `petersenlab::accuracyOverall()` function that computes many threshold-independent accuracy indices.

### General Prediction Accuracy {#sec-generalPredictionAccuracy}

There are many metrics of general prediction accuracy.
When thinking about which metric(s) may be best for a given problem, it is important to consider the purpose of the assessment.
The estimates of general prediction accuracy are separated below into [scale-dependent](#sec-scaleDependentAccuracy) and [scale-independent](#sec-scaleIndependentAccuracy) accuracy estimates.

#### Scale-Dependent Accuracy Estimates {#sec-scaleDependentAccuracy}

The estimates of prediction accuracy described in this section are scale-dependent.
These accuracy estimates depend on the unit of measurement and therefore cannot be compared across measures with different scales or across data sets.

##### Mean Error (ME) {#sec-meanError}

Here, "error" ($e$) is the difference between the predicted and observed value for a given individual ($i$).
Mean error (ME; also known as bias) is the mean difference between the predicted and observed values across individuals ($i$), that is, the mean of the errors across individuals ($e_i$).
Values closer to zero reflect greater accuracy.
If mean error is above zero, it indicates that predicted values are, on average, greater than observed values (i.e., overestimating errors).
If mean error is below zero, it indicates that predicted values are, on average, less than observed values (i.e., underestimating errors).
If both over-estimating and under-estimating errors are present, however, they can cancel each other out.
As a result, even with a mean error of zero, there can still be considerable error present.
Thus, although mean error can be helpful for examining whether predictions systematically under- or over-estimate the actual scores, other forms of accuracy are necessary to examine the *extent* of error.
The formula for mean error is in @eq-meanError:

$$
\begin{aligned}
  \text{mean error} &= \frac{\sum\limits_{i = 1}^n(\text{predicted}_i - \text{observed}_i)}{n} \\
  &= \text{mean}(e_i)
\end{aligned}
$$ {#eq-meanError}

##### Mean Absolute Error (MAE) {#sec-meanAbsoluteError}

Mean absolute error (MAE) is the mean of the absolute value of differences between the predicted and observed values across individuals.
That is, MAE is the mean of the absolute value of errors (i.e., the mean distance between predicted and observed values).
Smaller MAE values (closer to zero) reflect greater accuracy.
MAE is preferred over [root mean squared error](#sec-rootMeanSquaredError) (RMSE) when you want to give equal weight to all errors and when the outliers have considerable impact.
The formula for MAE is in @eq-meanAbsoluteError:

$$
\begin{aligned}
  \text{mean absolute error (MAE)} &= \frac{\sum\limits_{i = 1}^n|\text{predicted}_i - \text{observed}_i|}{n} \\
  &= \text{mean}(|e_i|)
\end{aligned}
$$ {#eq-meanAbsoluteError}

##### Median Absolute Error (MdAE) {#sec-medianAbsoluteError}

Median absolute error (MdAE) is the median of the absolute value of differences between the predicted and observed values across individuals.
That is, MdAE is the median of the absolute value of errors (i.e., the median distance between predicted and observed values).
Smaller MdAE values (closer to zero) reflect greater accuracy.
MdAE indicates the accuracy of the "typical" prediction (i.e., the prediction that is at the 50th percentile in terms of accuracy).
The formula for MdAE is in @eq-medianAbsoluteError:

$$
\begin{aligned}
  \text{median absolute error (MdAE)} &= \frac{\text{median}(|\text{predicted}_i - \text{observed}_i|)}{n} \\
  &= \text{median}(|e_i|)
\end{aligned}
$$ {#eq-medianAbsoluteError}

##### Mean Squared Error (MSE) {#sec-meanSquaredError}

Mean squared error (MSE) is the mean of the square of the differences between the predicted and observed values across individuals, that is, the mean of the squared value of errors.
Smaller MSE values (closer to zero) reflect greater accuracy.
MSE penalizes larger errors more heavily than smaller errors (unlike [MAE](#sec-meanAbsoluteError)).
However, MSE is sensitive to outliers and can be impacted if the errors are skewed.
The formula for MSE is in @eq-meanSquaredError:

$$
\begin{aligned}
  \text{mean squared error (MSE)} &= \frac{\sum\limits_{i = 1}^n(\text{predicted}_i - \text{observed}_i)^2}{n} \\
  &= \text{mean}(e_i^2)
\end{aligned}
$$ {#eq-meanSquaredError}

##### Root Mean Squared Error (RMSE) {#sec-rootMeanSquaredError}

Root mean squared error (RMSE) is the square root of the mean of the square of the differences between the predicted and observed values across individuals, that is, the root mean squared value of errors.
Smaller RMSE values (closer to zero) reflect greater accuracy.
RMSE penalizes larger errors more heavily than smaller errors (unlike [MAE](#sec-meanAbsoluteError)).
However, RMSE is sensitive to outliers and can be impacted if the errors are skewed.
The formula for RMSE is in @eq-rootMeanSquaredError:

$$
\begin{aligned}
  \text{root mean squared error (RMSE)} &= \sqrt{\frac{\sum\limits_{i = 1}^n(\text{predicted}_i - \text{observed}_i)^2}{n}} \\
  &= \sqrt{\text{mean}(e_i^2)}
\end{aligned}
$$ {#eq-rootMeanSquaredError}

#### Scale-Independent Accuracy Estimates {#sec-scaleIndependentAccuracy}

The estimates of prediction accuracy described in this section are intended to be scale-*independent* (unit-free) so the accuracy estimates can be compared across measures with different scales or across data sets [@Hyndman2021].

##### Mean Percentage Error (MPE) {#sec-meanPercentageError}

Mean percentage error (MPE) values closer to zero reflect greater accuracy.
The formula for percentage error is in @eq-percentageError:

$$
\begin{aligned}
  \text{percentage error }(p_i) = \frac{100\% \times (\text{observed}_i - \text{predicted}_i)}{\text{observed}_i}
\end{aligned}
$$ {#eq-percentageError}

We then take the mean of the percentage errors to get MPE.
The formula for MPE is in @eq-meanPercentageError:

$$
\begin{aligned}
  \text{mean percentage error (MPE)} &= \frac{100\%}{n} \sum\limits_{i = 1}^n \frac{\text{observed}_i - \text{predicted}_i}{\text{observed}_i} \\
  &= \text{mean(percentage error)} \\
  &= \text{mean}(p_i)
\end{aligned}
$$ {#eq-meanPercentageError}

Note: MPE is undefined when one or more of the observed values equals zero, due to division by zero.
The `petersenlab::accuracyOverall()` function of the [`petersenlab`](https://cran.r-project.org/web/packages/petersenlab/index.html) package [@R-petersenlab] provides the option in the function to drop undefined values so you can still generate an estimate of accuracy despite undefined values.

##### Mean Absolute Percentage Error (MAPE) {#sec-meanAbsolutePercentageError}

Smaller mean absolute percentage error (MAPE) values (closer to zero) reflect greater accuracy.
The formula for MAPE is in @eq-meanAbsolutePercentageError.
MAPE is asymmetric because it overweights underestimates and underweights overestimates.
MAPE can be preferable to [symmetric mean absolute percentage error](#sec-symmetricMeanAbsolutePercentageError) (sMAPE) if there are no observed values of zero and if you want to emphasize the importance of underestimates (relative to overestimates).

$$
\begin{aligned}
  \text{mean absolute percentage error (MAPE)} &= \frac{100\%}{n} \sum\limits_{i = 1}^n \Bigg|\frac{\text{observed}_i - \text{predicted}_i}{\text{observed}_i}\Bigg| \\
  &= \text{mean(|percentage error|)} \\
  &= \text{mean}(|p_i|)
\end{aligned}
$$ {#eq-meanAbsolutePercentageError}

Note: MAPE is undefined when one or more of the observed values equals zero, due to division by zero.
The `petersenlab::accuracyOverall()` function of the [`petersenlab`](https://cran.r-project.org/web/packages/petersenlab/index.html) package [@R-petersenlab] provides the option in the function to drop undefined values so you can still generate an estimate of accuracy despite undefined values.

##### Symmetric Mean Absolute Percentage Error (sMAPE) {#sec-symmetricMeanAbsolutePercentageError}

Unlike MAPE, symmetric mean absolute percentage error (sMAPE) is symmetric because it equally weights underestimates and overestimates.
Smaller sMAPE values (closer to zero) reflect greater accuracy.
The formula for sMAPE is in @eq-symmetricMeanAbsolutePercentageError:

$$
\small
\begin{aligned}
  \text{symmetric mean absolute percentage error (sMAPE)} = \frac{100\%}{n} \sum\limits_{i = 1}^n \frac{|\text{predicted}_i - \text{observed}_i|}{|\text{predicted}_i| + |\text{observed}_i|}
\end{aligned}
$$ {#eq-symmetricMeanAbsolutePercentageError}

Note: sMAPE is undefined when one or more of the individuals has a prediction–observed combination such that the sum of the absolute value of the predicted value and the absolute value of the observed value equals zero ($|\text{predicted}_i| + |\text{observed}_i|$), due to division by zero.
The `petersenlab::accuracyOverall()` function of the [`petersenlab`](https://cran.r-project.org/web/packages/petersenlab/index.html) package [@R-petersenlab] provides the option in the function to drop undefined values so you can still generate an estimate of accuracy despite undefined values.

##### Mean Absolute Scaled Error (MASE) {#sec-meanAbsoluteScaledError}

Mean absolute scaled error (MASE) is described by [@Hyndman2021].
Values closer to zero reflect greater accuracy.

The adapted formula for MASE with non-time series data is described by @Hyndman2014 at the following link: <https://stats.stackexchange.com/a/108963/20338> (archived at <https://perma.cc/G469-8NAJ>).
Scaled errors are calculated using @eq-scaledError:

$$
\begin{aligned}
  \text{scaled error}(q_i) &= \frac{\text{observed}_i - \text{predicted}_i}{\text{scaling factor}} \\
  &= \frac{\text{observed}_i - \text{predicted}_i}{\frac{1}{n} \sum\limits_{i = 1}^n |\text{observed}_i - \overline{\text{observed}}|}
\end{aligned}
$$ {#eq-scaledError}

Then, we calculate the mean of the absolute value of the scaled errors to get MASE, as in @eq-meanAbsoluteScaledError:

$$
\begin{aligned}
  \text{mean absolute scaled error (MASE)} &= \frac{1}{n} \sum\limits_{i = 1}^n |q_i| \\
  &= \text{mean(|scaled error|)} \\
  &= \text{mean}(|q_i|)
\end{aligned}
$$ {#eq-meanAbsoluteScaledError}

Note: MASE is undefined when the scaling factor is zero, due to division by zero.
With non-time series data, the scaling factor is the average of the absolute value of individuals' observed scores minus the average observed score ($\frac{1}{n} \sum\limits_{i = 1}^n |\text{observed}_i - \overline{\text{observed}}|$).

##### Root Mean Squared Log Error (RMSLE) {#sec-rootMeanSquaredLogError}

The squared log of the accuracy ratio is described by @Tofallis2015.
The accuracy ratio is in @eq-accuracyRatio1:

$$
\begin{aligned}
  \text{accuracy ratio} &= \frac{\text{predicted}_i}{\text{observed}_i}
\end{aligned}
$$ {#eq-accuracyRatio1}

However, the accuracy ratio is undefined with observed or predicted values of zero, so it is common to modify it by adding 1 to the predictor and denominator, as in @eq-accuracyRatio2:

$$
\begin{aligned}
  \text{accuracy ratio} &= \frac{\text{predicted}_i + 1}{\text{observed}_i + 1}
\end{aligned}
$$ {#eq-accuracyRatio2}

Squaring the log values keeps the values positive, such that smaller values (values closer to zero) reflect greater accuracy.
Then we take the mean of the squared log values, which keeps the values positive, and calculate the square root of the mean squared log values to put them back on the (pre-squared) log metric.
This is known as the root mean squared log error (RMSLE).
Division inside the log is equal to subtraction outside the log.
So, the formula can be reformulated with the subtraction of two logs, as in @eq-rootMeanSquaredLogError:

$$
\scriptsize
\begin{aligned}
  \text{root mean squared log error (RMSLE)} &= \sqrt{\sum\limits_{i = 1}^n log\bigg(\frac{\text{predicted}_i + 1}{\text{observed}_i + 1}\bigg)^2} \\
  &= \sqrt{\text{mean}\Bigg[log\bigg(\frac{\text{predicted}_i + 1}{\text{observed}_i + 1}\bigg)^2\Bigg]} \\
  &= \sqrt{\text{mean}\big[log(\text{accuracy ratio})^2\big]} = \sqrt{\text{mean}\Big\{\big[log(\text{predicted}_i + 1) - log(\text{actual}_i + 1)\big]^2\Big\}}
\end{aligned}
$$ {#eq-rootMeanSquaredLogError}

RMSLE can be preferable when the scores have a wide range of values and are skewed.
RMSLE can help to reduce the impact of outliers.
RMSLE gives more weight to smaller errors in the prediction of small observed values, while also penalizing larger errors in the prediction of larger observed values.
It overweights underestimates and underweights overestimates.

There are other variations of prediction accuracy metrics that use the log of the accuracy ratio.
One variation makes it similar to median symmetric percentage error [@Morley2018].

Note: Root mean squared log error is undefined when one or more predicted values or actual values equals −1.
When predicted or actual values are -1, this leads to $log(0)$, which is undefined.
The `petersenlab::accuracyOverall()` function of the [`petersenlab`](https://cran.r-project.org/web/packages/petersenlab/index.html) package [@R-petersenlab] provides the option in the function to drop undefined values so you can still generate an estimate of accuracy despite undefined values.

##### Coefficient of Determination ($R^2$) {#sec-coefficientOfDetermination}

The [coefficient of determination](#sec-multipleRegressionRSquared) ($R^2$) is described in @sec-multipleRegressionRSquared.
The [coefficient of determination](#sec-multipleRegressionRSquared) reflects the proportion of variance in the outcome (dependent) variable that is explained by the model predictions: $R^2 = \frac{\text{variance explained in }Y}{\text{total variance in }Y}$.
Larger values indicate greater accuracy.

$R^2$ is commonly estimated in [multiple regression](#sec-multipleRegression), in which multiple predictors are allowed to predict one outcome.

An issue with $R^2$ is that it can be artificially inflated by adding more predictors to the model, even if those predictors do not improve the model fit.
$R^2$ never decreases when adding predictors to a model, even if the predictors do not provide any predictive power.
Thus, to account for the number of predictors in the model, we can use [adjusted $R^2$](#sec-adjustedRsquared).

###### Adjusted $R^2$ ($R^2_{adj}$) {#sec-adjustedRsquared}

Adjusted $R^2$ ($R^2_{adj}$) is described in @sec-multipleRegressionAdjustedRsquared.
Adjusted $R^2$ is similar to the [coefficient of determination](#sec-coefficientOfDetermination), but it accounts for the number of predictors included in the regression model to penalize [overfitting](#sec-overfitting).
Specifically, adjusted $R^2$ penalizes the number of predictors in the model.
Adjusted $R^2$ reflects the proportion of variance in the outcome (dependent) variable that is explained by the model predictions over and above what would be expected to be accounted for by chance, given the number of predictors in the model.
Thus, adjusted $R^2$ will increase only if the new predictor improves the model (i.e., explains additional variance in the outcome variable) more than would be expected by chance.
Larger values indicate greater accuracy.
The formula for adjusted $R^2$ is in @eq-adjustedRSquared.

###### Predictive $R^2$ ($R^2_{\text{pred}}$) {#sec-predictiveRsquared}

Predictive $R^2$ ($R^2_{\text{pred}}$) is described by @Hopper2014 and @Tuzen2025: <https://tomhopper.me/2014/05/16/can-we-do-better-than-r-squared/> (archived at <https://perma.cc/BK8J-HFUK>) and <https://mfatihtuzen.netlify.app/posts/2025-04-30_rsquared/> (archived at <https://perma.cc/EPP8-VG23>).
Predictive $R^2$ penalizes [overfitting](#sec-overfitting), unlike traditional $R^2$.
Larger values indicate greater accuracy.
The formula for predictive $R^2$ is in in @eq-predictiveRSquared:

$$
\begin{aligned}
  R^2_{\text{pred}} &= 1 - \frac{\text{PRESS}}{\text{SS}_\text{total}}
\end{aligned}
$$ {#eq-predictiveRSquared}

where PRESS is the predictive residual sum of squares, and $\text{SS}_\text{total}$ is the total sum of squares.

It is preferable to examine predictive $R^2$ using new data that the model was not trained on—i.e., cross-validation, either in an independent sample (i.e., external cross-validation) or in a hold-out sample (i.e., internal cross-validation on test data).

For example, here is an example of estimating predictive $R^2$ using [10-fold cross-validation](#sec-kFoldCrossValidation) using the `tidymodels` ecosystem of packages [@R-tidymodels; @Kuhn2020_packages].

```{r}
# Set seed for reproducibility
set.seed(52242)

# Set up Cross-Validation
folds_kFold <- rsample::group_vfold_cv(
  projectionsWithActuals_seasonal,
  group = player_id, # ensures all rows for a player are in the training set or all in the validation set for each fold
  v = 10) # 10-fold cross-validation

folds <- folds_kFold

# Define Recipe (Formula)
rec <- recipes::recipe(
  fantasyPoints ~ raw_points, # use all predictors
  data = projectionsWithActuals_seasonal)

# Define Model
lm_spec <- parsnip::linear_reg() %>%
  parsnip::set_engine("lm") %>%
  parsnip::set_mode("regression")

# Workflow
lm_wf <- workflows::workflow() %>%
  workflows::add_recipe(rec) %>%
  workflows::add_model(lm_spec)

# Fit Model with Cross-Validation
cv_results <- tune::fit_resamples(
  lm_wf,
  resamples = folds,
  metrics = yardstick::metric_set(rmse, mae, rsq),
  control = tune::control_resamples(save_pred = TRUE)
)

# View Cross-Validation metrics
tune::collect_metrics(cv_results)

# Fold-level R-squared
tune::collect_metrics(cv_results, summarize = FALSE) %>%
  filter(.metric == "rsq") %>%
  select(id, .estimate)
```

Here is an example of estimating predictive $R^2$ with a training and hold-out (testing) data set:

```{r}
# Set seed for reproducibility
set.seed(52242)

# Create 75/25 split
split <- rsample::group_initial_split(
  projectionsWithActuals_seasonal,
  group = player_id,
  prop = 0.75)

# Fit model on training, evaluate on testing
last_fit_results <- tune::last_fit(
  lm_wf,
  split = split,
  metrics = yardstick::metric_set(rmse, mae, rsq)
)

# View predictive R-squared and other metrics
tune::collect_metrics(last_fit_results)
```

Or, alternatively:

```{r}
#| eval: false

# Set seed for reproducibility
set.seed(52242)

# Create 75/25 split
split <- rsample::group_initial_split(
  projectionsWithActuals_seasonal,
  group = player_id,
  prop = 0.75)

training <- rsample::training(split)
testing  <- rsample::testing(split)

# Fit model on training set
training_model <- parsnip::fit(
  lm_wf,
  data = training)

# Predict on test set
predictions <- predict(
  training_model,
  new_data = testing) %>%
  bind_cols(testing)

# Predictive R-squared
yardstick::rsq(
  predictions,
  truth = fantasyPoints,
  estimate = .pred)
```

### Discrimination {#sec-discriminationIndices}

When dealing with a categorical outcome, discrimination is the ability to separate events from non-events.
When dealing with a continuous outcome, discrimination is the strength of the association between the predictor and the outcome.
[Threshold-dependent](#sec-thresholdDependentAccuracy) aspects of [discrimination](#sec-discrimination) at a particular cutoff (e.g., [sensitivity](#sec-sensitivity), [specificity](#sec-specificity)) are described in @sec-thresholdDependentAccuracy.

#### Area under the ROC curve (AUC) {#sec-aucROC}

The [area under the ROC curve (AUC)](#sec-auc) is a general index of discrimination accuracy for a categorical outcome.
It is also called the concordance ($c$) statistic.
Larger values reflect greater [discrimination accuracy](#sec-discrimination).
[AUC](#auc) was estimated using the `pROC` package [@R-pROC; @Robin2011_packages].

#### Effect Size ($\beta$) of Regression {#sec-standardizedRegressionCoefficient}

The effect size of a predictor, i.e., the standardized regression coefficient is called a beta ($\beta$) coefficient, is a general index of [discrimination accuracy](#sec-discrimination) for a continuous outcome.
Larger values reflect greater accuracy.
We can obtain standardized regression coefficients by standardizing the predictors and outcome using the `base::scale()` function in `R`.

### Calibration {#sec-calibrationIndices}

When dealing with a categorical outcome, calibration is the degree to which a probabilistic estimate of an event reflects the true underlying probability of the event.
When dealing with a continuous outcome, calibration is the degree to which the predicted values are close in value to the outcome values.
The importance of examining calibration (in addition to [discrimination](#sec-discrimination)) is described by @Lindhiem2020.
Calibration can be examined in several ways, including [Spiegelhalter's $z$](#sec-spiegelhalterZ) (see @sec-spiegelhalterZ), and the [mean difference between predicted and observed values](#sec-miscalibration) at different binned thresholds as depicted graphically with a [calibration plot](#sec-calibrationPlot) (see @fig-miscalibration).

#### Calibration Plot {#sec-calibrationPlot}

Calibration plots can be helpful for identifying miscalibration.
A calibration plot depicts the predicted probability of an event on the x-axis, and the actual (observed) probability of the event on the y-axis.
The predictions are binned into a certain number of groups (commonly 10).
The diagonal line reflects predictions that are perfectly calibrated.
To the extent that predictions deviate from the diagonal line, the predictions are miscalibrated.

Well-calibrated predictions are depicted in @fig-calibrationPlot:

```{r}
#| label: fig-calibrationPlot
#| fig-cap: "Predictions that are Well-Calibrated. That is, the predicted values are close to the observed values."
#| fig-alt: "Predictions that are Well-Calibrated. That is, the predicted values are close to the observed values."
#| fig-width: 8
#| fig-height: 8
#| code-fold: true

# Specify data
examplePredictionsWellCalibrated <- seq(from = 0, to = 1, by = .1)
exampleOutcomesWellCalibrated <- seq(from = 0, to = 1, by = .1)

# Plot
plot(
  examplePredictionsWellCalibrated,
  exampleOutcomesWellCalibrated,
  xlim = c(0,1),
  ylim = c(0,1),
  xlab = "Predicted Probability",
  ylab = "Observed Proportion",
  bty = "l",
  type = "n")

lines(
  c(0,1),
  c(0,1),
  lwd = 2,
  col = "#377eb8")

points(
  examplePredictionsWellCalibrated,
  exampleOutcomesWellCalibrated,
  cex = 1.5,
  col = "#e41a1c",
  lwd = 2,
  type = "p")
```

The various types of general miscalibration are depicted in @fig-miscalibration:

```{r}
#| label: fig-miscalibration
#| fig-cap: "Types of Miscalibration. From @Petersen2024a and @PetersenPrinciplesPsychAssessment."
#| fig-alt: "Types of Miscalibration. From @Petersen2024a and @PetersenPrinciplesPsychAssessment."
#| fig-width: 8
#| fig-height: 8
#| code-fold: true

# Specify data
examplePredictions <- seq(from = 0, to = 1, by = .1)
exampleOutcomes <- c(0, .15, .3, .4, .45, .5, .55, .6, .7, .85, 1)

overPrediction <- c(0, .02, .05, .1, .15, .2, .3, .4, .5, .7, 1)
underPrediction <- c(0, .3, .5, .6, .7, .8, .85, .9, .95, .98, 1)
overExtremity <- c(0, .3, .38, .42, .47, .5, .53, .58, .62, .7, 1)
underExtremity <- c(0, .05, .08, .11, .2, .5, .8, .89, .92, .95, 1)

# Plot
par(
  mfrow = c(2,2),
  mar = c(5,4,1,1) + 0.1) #margins: bottom, left, top, right

plot(
  examplePredictions,
  overExtremity,
  xlim = c(0,1),
  ylim = c(0,1),
  main = "Overextremity",
  xlab = "Predicted Probability",
  ylab = "Observed Proportion",
  bty = "l",
  cex = 1.5,
  col = "#e41a1c",
  type = "o")

lines(
  c(0,1),
  c(0,1),
  lwd = 2,
  col = "#377eb8")

plot(
  examplePredictions,
  underExtremity,
  xlim = c(0,1),
  ylim = c(0,1),
  main = "Underextremity",
  xlab = "Predicted Probability",
  ylab = "Observed Proportion",
  bty = "l",
  cex = 1.5,
  col = "#e41a1c",
  type = "o")

lines(
  c(0,1),
  c(0,1),
  lwd = 2,
  col = "#377eb8")

plot(
  examplePredictions,
  overPrediction,
  xlim = c(0,1),
  ylim = c(0,1),
  main = "Overprediction",
  xlab = "Predicted Probability",
  ylab = "Observed Proportion",
  bty = "l",
  cex = 1.5,
  col = "#e41a1c",
  type = "o")

lines(
  c(0,1),
  c(0,1),
  lwd = 2,
  col = "#377eb8")

plot(
  examplePredictions,
  underPrediction,
  xlim = c(0,1),
  ylim = c(0,1),
  main = "Underprediction",
  xlab = "Predicted Probability",
  ylab = "Observed Proportion",
  bty = "l",
  cex = 1.5,
  col = "#e41a1c",
  type = "o")

lines(
  c(0,1),
  c(0,1),
  lwd = 2,
  col = "#377eb8")
```

However, predictions could also be miscalibrated in more specific ways.
For instance, predictions could be well-calibrated at all predicted probabilities except for a given predicted probability (e.g., 20%).
Or, the predictions could be miscalibrated but not systematically over- or underpredicted.
Thus, it is important to evaluate a calibration plot to evaluate the extent to which the predictions are miscalibrated and the pattern of that miscalibration.

#### Spiegelhalter's *z* {#sec-spiegelhalterZ}

Spiegelhalter's *z* was calculated using the `rms` package [@R-rms].
Smaller *z* values (and larger associated *p*-values) reflect greater [calibration accuracy](#calibration).
A statistically significant Spiegelhalter's *z* (*p* < .05) indicates a significant degree of miscalibration.

#### Calibration for Predicting a Continuous Outcome {#sec-calibrationContinuous}

When predicting a continuous outcome, [calibration](#sec-calibration) of the predicted values in relation to the outcome values can be examined in multiple ways including:

- in a [calibration plot](#sec-calibrationPlot), the extent to which the intercept is near zero and the slope is near one
- in a [calibration plot](#sec-calibrationPlot), the extent to which the 95% confidence interval of the observed value, across all values of the predicted values, includes the diagonal reference line with an intercept of zero and a slope of one
- [mean error](#sec-meanError)
- [mean absolute error](#sec-meanAbsoluteError)
- [mean squared error](#sec-meanSquaredError)
- [root mean squared error](#sec-rootMeanSquaredError)

With a plot of the predictions on the x-axis, and the outcomes on the y-axis (i.e., a [calibration plot](#sec-calibrationPlot)), [calibration](#sec-calibration) can be examined graphically as the extent to which the best-fit regression line has an intercept (alpha) close to zero and a slope (beta) close to one [@Steyerberg2014; @Stevens2020].
The intercept is also called "calibration-in-the-large", whereas "calibration-in-the-small" refers to the extent to which the predicted values match the observed values at a specific predicted value (e.g., when the weather forecaster says that there is a 10% chance of rain, does it actually rain 10% of the time?).
For predictions to be well [calibrated](#sec-calibration), the intercept should be close to zero and the slope should be close to one.
If the slope is close to one but the intercept is not close to zero (or the intercept is close to zero but the slope is not close to one), the predictions would not be considered well [calibrated](#sec-calibration).
The 95% confidence interval of the observed value, across all values of the predicted values, should include the diagonal reference line whose intercept is zero and whose slope is one.
Gold-standard recommendations include examining the predicted values in relation to the observed values using locally estimated scatterplot smoothing (LOESS) [@Austin2014], such as in @fig-calibrationPlotSeasonalOverall.
We can examine whether the LOESS-based 95% confidence interval of the observed value at every level of the predicted values includes the diagonal reference line (i.e., the actual observed value).

## Integrating the Accuracy Indices {#sec-integratingAccuracy}

After computing the accuracy indices of [discrimination](#sec-discrimination) and (2) [calibration](#sec-calibration), it is then the task to integrate the indices to determine (a) which are the most accurate predictions for the given goals, and (b) whether additional improvements and refinements to the predictions need to be made.
Each of the accuracy indices is computed differently and thus reward (and penalize) predictive (in)accuracy differently.
Sometimes, the the accuracy indices will paint a consistent picture regarding which predictions are the most accurate.
Other times, the accuracy indices may disagree about which predictions are most accurate.

In fantasy football, when evaluating the accuracy of seasonal projections, we care most about accurately distinguishing between higher levels of points (e.g., 200 vs 150) as opposed to lower levels of points (e.g., 0 vs 10).
Thus, it can be helpful to punish larger errors more heavily than smaller errors, as [RMSE](#sec-rootMeanSquaredError) (unlike [MAE](#sec-meanAbsoluteError)).

Thus, we would emphasize the following metrics:

- [discrimination](#sec-discrimination):
  - [standardized regression coefficient (beta)](#sec-standardizedRegressionCoefficient)
- [calibration](#sec-calibration):
  - [calibration plot](#sec-calibrationPlot)
- [general accuracy](#sec-calibration):
  - [calibration plot](#sec-calibrationPlot)
  - [adjusted $R^2$](#sec-adjustedRsquared)
  - [MAE](#sec-meanAbsoluteError)
  - [RMSE](#sec-rootMeanSquaredError)

If you focus on only one accuracy index, [MAE](#sec-meanAbsoluteError) or [RMSE](#sec-rootMeanSquaredError) would be a good choice.
However, I would also examine a [calibration plot](#sec-calibrationPlot) to evaluate whether predictions are poorly calibrated at higher levels of points.
I would also examine [ME](#sec-meanError)—not to compare the accuracy of various predictions per se—but to determine whether predictions are systematically under- or overestimating actual points.
If so, predictions may be able to be refined by adding or subtracting a constant to the predictions (or to a subset of the predictions); however, this could worsen other accuracy indices, so it is important to conduct an iterative process of modifying then evaluating, then further modifying and evaluating, etc.
It may also be valuable to evaluate the accuracy of various subsets of the predictions.
For instance, you might examine the predictive accuracy of players whose projected points are greater than 100, to evaluate the accuracy of predictions specifically to distinguish between players at higher levels of points, which is one of the key goals when selecting which players to draft.

If we are making predictions about a categorical variable, we would emphasize the following metrics:

- [discrimination](#sec-discrimination):
  - [area under the receiver operating characteristic curve](#sec-auc) (AUC)
  - and, secondarily—depending on the particulary cutoff and the relative costs of [false positives](#sec-falsePositive) versus [false negatives](#sec-falseNegative):
    - [sensitivity](#sec-sensitivity)
    - [specificity](#sec-specificity)
    - [positive predictive value](#sec-ppv) (PPV)
    - [negative predictive value](#sec-npv) (NPV)
- [calibration](#sec-calibration):
  - [calibration plot](#sec-calibrationPlot)
  - [Spiegelhalter's *z*](#sec-spiegelhalterZ)
  - [Mean difference between observed and predicted values](#sec-miscalibration)

## Theory Versus Empiricism {#sec-theoryVsEmpiricism}

One question that inevitably arises when making predictions is the extent to which one should leverage theory versus empiricism.
Theory involves conceptual claims of understanding how the causal system works (i.e., what influences what).
For example, use of theory in prediction might involve specification of the causal system that influences player performance, measurement of those factors, and the integration of that information to make a prediction.
Empiricism involves "letting the data speak for themselves" and is an atheoretical approach.
For example, empiricism might involve examining how thousands of variables are associated with the criterion of interest (e.g., fantasy points) and developing the best-fitting model based on those thousands of predictor variables.

Although the atheoretical approach can perform reasonably well, it can be improved by making better use of theory.
An empirical result (e.g., a correlation) might not necessarily have a lot of meaning associated with it.
As the maxim goes, [correlation does not imply causation](#sec-correlationCausality).
Moreover, empiricism can lead to [overfitting](#sec-overfitting).
So, empiricism is often not enough.

As @Silver2012 notes, "The numbers have no way of speaking for themselves.
We speak for them.
We imbue them with meaning." (p. 9).
If we *understand* the variables in the system and how they influence each other, we can predict things more accurately than predicting for the sake of predicting.
For instance, [we have made great strides in the last decades when it comes to more accurate weather forecasts](https://www.npr.org/sections/money/2023/07/11/1186458991/should-we-invest-more-in-weather-forecasting-it-may-save-your-life) [@Rosalsky2023; archived at <https://perma.cc/PF8P-BT3D>], including extreme weather events like hurricanes.
These great strides have more to do with a better causal understanding of the weather system and the ability to conduct simulations of the atmosphere than merely because of big data [@Silver2012].
By contrast, other events are still incredibly difficult to predict, including earthquakes, in large part because we do not have a strong understanding of the system (and because we do not have ways of precisely measuring those causes because they occur at a depth below which we are realistically able to drill) [@Silver2012].

At the same time, in the social and behavioral sciences, our theories of the causal processes that influence outcomes are not yet very strong.
Indeed, I have misgivings calling them theories because they do not meet the traditional scientific standard for a theory.
A scientific theory is an explanation of the natural world that is testable and falsifiable, and that has withstood rigorous scientific testing and scrutiny.
In psychology (and other areas of social and behavioral sciences), our "theories" are more like conceptual frameworks.
And these conceptual frameworks are often vague, do not make specific predictions of effects *and* noneffects, and do not hold up consistently when rigorously tested.
As described by @Meehl1978:

> *I consider it unnecessary to persuade you that most so-called "theories" in the soft areas of psychology (clinical, counseling, social, personality, community, and school psychology) are scientifically unimpressive and technologically worthless ... Perhaps the easiest way to convince yourself is by scanning the literature of soft psychology over the last 30 years and noticing what happens to theories.
> Most of them suffer the fate that General MacArthur ascribed to old generals—They never die, they just slowly fade away.
> In the developed sciences, theories tend either to become widely accepted and built into the larger edifice of well-tested human knowledge or else they suffer destruction in the face of recalcitrant facts and are abandoned, perhaps regretfully as a "nice try."
> But in fields like personology and social psychology, this seems not to happen.
> There is a period of enthusiasm about a new theory, a period of attempted application to several fact domains, a period of disillusionment as the negative data come in, a growing bafflement about inconsistent and unreplicable empirical results, multiple resort to ad hoc excuses, and then finally people just sort of lose interest in the thing and pursue other endeavors.*
> 
> --- Meehl [-@Meehl1978, pp. 806–807]

Even if we had strong theoretical understanding of the causal system that influences behavior, we would likely still have difficulty making accurate predictions because the field has largely relied on relatively crude instruments.
According to one philosophical perspective known as LaPlace's demon, if we were able to know the exact conditions of everything in the universe, we would be able to know how the conditions would be in the future.
This is an example of scientific determinism, where if you know the initial conditions, you also know the future.
Other perspectives, such as quantum mechanics and chaos theory, would say that, even if we knew the initial conditions with 100% certainty, there would still be uncertainty in our understanding of the future.
But assume, for a moment, that LaPlace's demon is true.
A challenge in the social and behavioral sciences is that we have a relatively poor understanding of the initial conditions of the universe.
Thus, our predictions would necessarily be probabilistic, similar to weather forecasts.
Despite having a strong understanding of how weather systems behave, we have imperfect understanding of the initial conditions (e.g., the position and movement of all molecules) [@Silver2012].

Theories tend to make grand conceptual claims that one observed variable influences another observed variable through a complex chain of intervening processes that are unobservable.
Empiricism provides rich lower-level information, but lacks the broader picture.
So, it seems, that we need both theory *and* empiricism.
Theory and empiricism can—and should—inform each other.

## Test Bias {#sec-testBias}

Test bias refers to systematic error (in measurement, prediction, etc.) as a function of group membership that leads the same score to have different meaning for different groups.
For instance, if the Wonderlic Contemporary Cognitive Ability Test is a strong predictor of performance for Quarterbacks but not for Running Backs, the test is biased.
Test bias, including how to identify and address it, is described in [@PetersenPrinciplesPsychAssessment](https://isaactpetersen.github.io/Principles-Psychological-Assessment/bias.html).

## Example of Predicting a Categorical outcome {#sec-predictionCategoricalExample}

Let's consider an example of predicting a categorical outcome.
For this example, let's predict whether or not a Running Back rushes for 200 yards in a game.
To predict that, we will use the number of rushing yards the player had in the previous game.

```{r}
player_stats_weekly_example <- player_stats_weekly %>% 
  filter(position == "RB") %>% 
  arrange(player_id, season, week) %>% 
  group_by(player_id, season) %>% 
  mutate(rushing_yards_priorGame = lag(rushing_yards)) %>% 
  ungroup()
```

```{r}
player_stats_weekly_example %>% 
  select(player_id, season, week, rushing_yards, rushing_yards_priorGame) %>% 
  head()
```

Here are our accuracy indices at a cutoff of 100.
That is, we predict that each player who rushed more than 100 yards in a given game will rush for 200 yards in their next game.

```{r}
petersenlab::accuracyAtCutoff(
  predicted = player_stats_weekly_example$rushing_yards_priorGame,
  actual = player_stats_weekly_example$rush_200_yds,
  cutoff = 100
)
```

Now, let's lower the cutoff to 50 and see how that impacts our predictive accuracy.

```{r}
petersenlab::accuracyAtCutoff(
  predicted = player_stats_weekly_example$rushing_yards_priorGame,
  actual = player_stats_weekly_example$rush_200_yds,
  cutoff = 50
)
```

Now, let's raise the cutoff to 150 and see how that impacts our predictive accuracy.

```{r}
petersenlab::accuracyAtCutoff(
  predicted = player_stats_weekly_example$rushing_yards_priorGame,
  actual = player_stats_weekly_example$rush_200_yds,
  cutoff = 150
)
```

We can also examine the accuracy at each possible cutoff.

```{r}
petersenlab::accuracyAtEachCutoff(
  predicted = player_stats_weekly_example$rushing_yards_priorGame,
  actual = player_stats_weekly_example$rush_200_yds
)
```

We can also create a receiver operating characteristic (ROC) curve, as in @fig-rocCurveExample.

```{r}
rocCurve <- pROC::roc(
  data = player_stats_weekly_example,
  response = rush_200_yds,
  predictor = rushing_yards_priorGame,
  smooth = FALSE)
```

Here is the area under the ROC curve (AUC):

```{r}
rocCurve$auc
```

```{r}
#| label: fig-rocCurveExample
#| fig-cap: "Example Receiver Operating Characteristic (ROC) Curve."
#| fig-alt: "Example Receiver Operating Characteristic (ROC) Curve."
#| fig-width: 8
#| fig-height: 8

par(pty = "s")

plot(
  rocCurve,
  legacy.axes = TRUE,
  print.auc = TRUE)
```

We can identify the cutoff that optimizes each of various accuracy estimates.

```{r}
petersenlab::optimalCutoff(
  predicted = player_stats_weekly_example$rushing_yards_priorGame,
  actual = player_stats_weekly_example$rush_200_yds)
```

## Accuracy of Fantasy Projections {#sec-accuracyProjections}

Below are estimates of projection accuracy and [calibration plots](#sec-calibrationPlot) for [seasonal](#sec-accuracyProjectionsSeasonal) and [weekly](#sec-accuracyProjectionsWeekly) projections.
FantasyFootballAnalytics.net also provides tools to evaluate the accuracy of historical projections [@FFA-accuracy]: <https://fantasyfootballanalytics.net/ffanalytics-web-app-accuracy-tab>.
For instance, the web application allows evaluating the accuracy of historical projections:
<https://apps.fantasyfootballanalytics.net>.

### Seasonal Projections {#sec-accuracyProjectionsSeasonal}

#### Overall {#sec-accuracyProjectionsSeasonalOverall}

Here are the seasonal accuracy indexes for all players (across all positions):

```{r}
petersenlab::accuracyOverall(
  predicted = projectionsWithActuals_seasonal$raw_points,
  actual = projectionsWithActuals_seasonal$fantasyPoints,
  dropUndefined = TRUE
)
```

```{r}
#| include: false

accuracyIndices_seasonal_overall <- petersenlab::accuracyOverall(
  predicted = projectionsWithActuals_seasonal$raw_points,
  actual = projectionsWithActuals_seasonal$fantasyPoints,
  dropUndefined = TRUE
)

rsquare_seasonal_overall <- round(accuracyIndices_seasonal_overall$rsquared, digits = 2)
me_seasonal_overall <- round(accuracyIndices_seasonal_overall$ME, digits = 2)
mae_seasonal_overall <- round(accuracyIndices_seasonal_overall$MAE, digits = 2)
```

In the data object, each projection source has a row for each player and season.
Thus, the $R^2$ may be higher for this aggregated object than it is for many of the individual sources.
To calculate the accuracy by source, we could use the following code:

```{r}
accuracy_by_source <- projectionsWithActuals_seasonal %>%
  filter(!is.na(data_src)) %>% 
  filter(data_src != "FantasyPros") %>% # remove crowd-averaged source; we compare to crowd average later
  group_by(data_src) %>%
  summarise(
    accuracy = list(
      accuracyOverall(
        predicted = raw_points,
        actual = fantasyPoints,
        dropUndefined = TRUE
      )
    ),
    .groups = "drop"
  )

accuracy_by_source
accuracy_by_source$accuracy
```

The intercept and slope of the best-fit line can be estimated using regression, as in below:

```{r}
summary(lm(
  fantasyPoints ~ raw_points,
  data = projectionsWithActuals_seasonal
))
```

A calibration plot of the seasonal projections for all players (across all positions) is in @fig-calibrationPlotSeasonalOverall.
The best-fit LOESS line is the yellow line.
The intercept from the best-fit line is positive; the slope is less than one.
The predicted values are less than the observed values at lower levels of projected points, whereas the predicted values are higher than the observed values at higher levels of projected points, consistent with the overextremity form of [miscalibration](#sec-calibration).
The confidence interval of the observed value (i.e., the purple band) is the interval within which we have 95% confidence that the true observed value would lie for a given predicted value, based on the model.
The 95% prediction interval of the observed value (i.e., the dashed red lines) is the interval within which we would expect that 95% of future observations would lie for a given predicted value.
We calculate the 95% prediction interval based on a LOESS model, which allows nonlinear associations, using the `msir::loess.sd()` function of the `msir` package [@R-msir; @Scrucca2011_packages].
The black diagonal line indicates the reference line with an intercept of zero and a slope of one.
The predictions would be significantly [miscalibrated](#sec-calibration) at a given level of the predicted values if the 95% confidence interval of the observed value does not include the reference line at that level of the predicted value.
In this case, based on the intercept and slope of the [calibration plot](#sec-calibrationPlot) in @fig-calibrationPlotSeasonalOverall, the 95% confidence interval of the observed value does not include the reference line (i.e., the actual observed value) at lower or upper levels of the predicted values, so the predictions are [miscalibrated](#sec-calibration) at lower and upper levels of the predicted values.

```{r}
#| label: fig-calibrationPlotSeasonalOverall
#| fig-cap: "Calibration Plot for Seasonal Projections. The diagonal black line is the reference line representing perfect calibration. The yellow line is the best-fit line based on a locally estimated scatterplot smoothing (LOESS) model. The purple band is the 95% confidence interval of actual fantasy points. The dashed red lines are the 95% prediction interval of actual fantasy points."
#| fig-alt: "Calibration Plot for Seasonal Projections. The diagonal black line is the reference line representing perfect calibration. The yellow line is the best-fit line based on a locally estimated scatterplot smoothing (LOESS) model. The purple band is the 95% confidence interval of actual fantasy points. The dashed red lines are the 95% prediction interval of actual fantasy points."
#| fig-width: 8
#| fig-height: 6

#95 prediction interval based on LOESS model
calibrationLoessModel <- msir::loess.sd(
  x = projectionsWithActuals_seasonal$raw_points,
  y = projectionsWithActuals_seasonal$fantasyPoints,
  nsigma = qnorm(.975),
  na.action = "na.exclude")

calibrationLoessPredictionInterval <- data.frame(
  x = calibrationLoessModel$x,
  y = calibrationLoessModel$y,
  lower = calibrationLoessModel$lower,
  upper = calibrationLoessModel$upper)

plotRangeMin <- min(calibrationLoessModel$lower, na.rm = TRUE)

plotRangeMax <- max(calibrationLoessModel$upper, na.rm = TRUE)

ggplot2::ggplot(
  data = projectionsWithActuals_seasonal,
  aes(
    x = raw_points,
    y = fantasyPoints)) + 
  coord_cartesian(
    xlim = c(0, plotRangeMax),
    ylim = c(plotRangeMin, plotRangeMax),
    expand = FALSE) +
  scale_x_continuous(breaks = seq(0, plotRangeMax, by = 100)) +
  scale_y_continuous(breaks = seq(0, plotRangeMax, by = 100)) +
  geom_line(
    data = calibrationLoessPredictionInterval,
    aes(
      x = x,
      y = lower),
    color = "red",
    linetype = "dashed") + #Lower estimate of 95% prediction interval of linear model
  geom_line(
    data = calibrationLoessPredictionInterval,
    aes(
      x = x,
      y = upper),
    color = "red",
    linetype = "dashed") + #Upper estimate of 95% prediction interval of linear model
  geom_smooth(
    method = "loess",
    color = viridisLite::viridis(3)[3],
    fill = viridisLite::viridis(3)[1],
    alpha = 0.7) + #95% confidence interval of LOESS model
  geom_abline(
    slope = 1,
    intercept = 0) +
  labs(
    x = "Projected Fantasy Points",
    y = "Actual Fantasy Points",
    title = "Calibration Plot for Seasonal Projections"
  ) +
  theme_classic() + 
  theme(axis.title.y = element_text(angle = 0, vjust = 0.5)) # horizontal y-axis title
```

Here are the seasonal accuracy indexes for players across all positions, but only among those who had high projected or actual points (i.e., players who had more than 100 projected or actual points; the players that are most important to differentiate between):

```{r}
petersenlab::accuracyOverall(
  predicted = projectionsWithActuals_seasonal$raw_points[which(projectionsWithActuals_seasonal$player_id_season %in% playersWithHighProjectedOrActualPoints)],
  actual = projectionsWithActuals_seasonal$fantasyPoints[which(projectionsWithActuals_seasonal$player_id_season %in% playersWithHighProjectedOrActualPoints)],
  dropUndefined = TRUE
)
```

```{r}
#| include: false

accuracyIndices_seasonal_overall_subset <- petersenlab::accuracyOverall(
  predicted = projectionsWithActuals_seasonal$raw_points[which(projectionsWithActuals_seasonal$player_id_season %in% playersWithHighProjectedOrActualPoints)],
  actual = projectionsWithActuals_seasonal$fantasyPoints[which(projectionsWithActuals_seasonal$player_id_season %in% playersWithHighProjectedOrActualPoints)],
  dropUndefined = TRUE
)

rsquare_seasonal_overall_subset <- round(accuracyIndices_seasonal_overall_subset$rsquared, digits = 2)
me_seasonal_overall_subset <- round(accuracyIndices_seasonal_overall_subset$ME, digits = 2)
mae_seasonal_overall_subset <- round(accuracyIndices_seasonal_overall_subset$MAE, digits = 2)
```

Here are the seasonal accuracy indexes for crowd-averaged projections of all players (across all positions):

```{r}
petersenlab::accuracyOverall(
  predicted = crowdAveragedProjectionsWithActuals_seasonal$points,
  actual = crowdAveragedProjectionsWithActuals_seasonal$fantasyPoints,
  dropUndefined = TRUE
)
```

```{r}
#| include: false

accuracyIndices_seasonal_overall_crowd <- petersenlab::accuracyOverall(
  predicted = crowdAveragedProjectionsWithActuals_seasonal$points,
  actual = crowdAveragedProjectionsWithActuals_seasonal$fantasyPoints,
  dropUndefined = TRUE
)

rsquare_seasonal_overall_crowd <- round(accuracyIndices_seasonal_overall_crowd$rsquared, digits = 2)
me_seasonal_overall_crowd <- round(accuracyIndices_seasonal_overall_crowd$ME, digits = 2)
mae_seasonal_overall_crowd <- round(accuracyIndices_seasonal_overall_crowd$MAE, digits = 2)
```

Here are the seasonal accuracy indexes for crowd-averaged projections of players across all positions, but only among those who had high projected or actual points (i.e., players who had more than 100 projected or actual points; the players that are most important to differentiate between):

```{r}
petersenlab::accuracyOverall(
  predicted = crowdAveragedProjectionsWithActuals_seasonal$points[which(crowdAveragedProjectionsWithActuals_seasonal$player_id_season %in% playersWithHighProjectedOrActualPoints)],
  actual = crowdAveragedProjectionsWithActuals_seasonal$fantasyPoints[which(crowdAveragedProjectionsWithActuals_seasonal$player_id_season %in% playersWithHighProjectedOrActualPoints)],
  dropUndefined = TRUE
)
```

```{r}
#| include: false

accuracyIndices_seasonal_overall_crowd_subset <- petersenlab::accuracyOverall(
  predicted = crowdAveragedProjectionsWithActuals_seasonal$points[which(crowdAveragedProjectionsWithActuals_seasonal$player_id_season %in% playersWithHighProjectedOrActualPoints)],
  actual = crowdAveragedProjectionsWithActuals_seasonal$fantasyPoints[which(crowdAveragedProjectionsWithActuals_seasonal$player_id_season %in% playersWithHighProjectedOrActualPoints)],
  dropUndefined = TRUE
)

rsquare_seasonal_overall_crowd_subset <- round(accuracyIndices_seasonal_overall_crowd_subset$rsquared, digits = 2)
me_seasonal_overall_crowd_subset <- round(accuracyIndices_seasonal_overall_crowd_subset$ME, digits = 2)
mae_seasonal_overall_crowd_subset <- round(accuracyIndices_seasonal_overall_crowd_subset$MAE, digits = 2)
```

#### Quarterbacks {#sec-accuracyProjectionsSeasonalQB}

Here are the seasonal accuracy indexes for all Quarterbacks:

```{r}
petersenlab::accuracyOverall(
  predicted = projectionsWithActuals_seasonal_qb$raw_points,
  actual = projectionsWithActuals_seasonal_qb$fantasyPoints,
  dropUndefined = TRUE
)
```

```{r}
#| include: false

accuracyIndices_seasonal_qb <- petersenlab::accuracyOverall(
  predicted = projectionsWithActuals_seasonal_qb$raw_points,
  actual = projectionsWithActuals_seasonal_qb$fantasyPoints,
  dropUndefined = TRUE
)

rsquare_seasonal_qb <- round(accuracyIndices_seasonal_qb$rsquared, digits = 2)
me_seasonal_qb <- round(accuracyIndices_seasonal_qb$ME, digits = 2)
mae_seasonal_qb <- round(accuracyIndices_seasonal_qb$MAE, digits = 2)
```

A calibration plot of the seasonal projections for Quarterbacks is in @fig-calibrationPlotSeasonalQBs.

```{r}
#| label: fig-calibrationPlotSeasonalQBs
#| fig-cap: "Calibration Plot for Seasonal Projections of Quarterbacks. The diagonal black line is the reference line representing perfect calibration. The yellow line is the best-fit line based on a locally estimated scatterplot smoothing (LOESS) model. The purple band is the 95% confidence interval of actual fantasy points. The dashed red lines are the 95% prediction interval of actual fantasy points."
#| fig-alt: "Calibration Plot for Seasonal Projections of Quarterbacks. The diagonal black line is the reference line representing perfect calibration. The yellow line is the best-fit line based on a locally estimated scatterplot smoothing (LOESS) model. The purple band is the 95% confidence interval of actual fantasy points. The dashed red lines are the 95% prediction interval of actual fantasy points."
#| fig-width: 8
#| fig-height: 6

#95 prediction interval based on LOESS model
calibrationLoessModel <- msir::loess.sd(
  x = projectionsWithActuals_seasonal_qb$raw_points,
  y = projectionsWithActuals_seasonal_qb$fantasyPoints,
  nsigma = qnorm(.975),
  na.action = "na.exclude")

calibrationLoessPredictionInterval <- data.frame(
  x = calibrationLoessModel$x,
  y = calibrationLoessModel$y,
  lower = calibrationLoessModel$lower,
  upper = calibrationLoessModel$upper)

plotRangeMin <- min(calibrationLoessModel$lower, na.rm = TRUE)

plotRangeMax <- max(calibrationLoessModel$upper, na.rm = TRUE)

ggplot2::ggplot(
  data = projectionsWithActuals_seasonal_qb,
  aes(
    x = raw_points,
    y = fantasyPoints)) + 
  coord_cartesian(
    xlim = c(0, plotRangeMax),
    ylim = c(plotRangeMin, plotRangeMax),
    expand = FALSE) +
  scale_x_continuous(breaks = seq(0, plotRangeMax, by = 100)) +
  scale_y_continuous(breaks = seq(0, plotRangeMax, by = 100)) +
  geom_line(
    data = calibrationLoessPredictionInterval,
    aes(
      x = x,
      y = lower),
    color = "red",
    linetype = "dashed") + #Lower estimate of 95% prediction interval of linear model
  geom_line(
    data = calibrationLoessPredictionInterval,
    aes(
      x = x,
      y = upper),
    color = "red",
    linetype = "dashed") + #Upper estimate of 95% prediction interval of linear model
  geom_smooth(
    method = "loess",
    color = viridisLite::viridis(3)[3],
    fill = viridisLite::viridis(3)[1],
    alpha = 0.7) + #95% confidence interval of LOESS model
  geom_abline(
    slope = 1,
    intercept = 0) +
  labs(
    x = "Projected Fantasy Points",
    y = "Actual Fantasy Points",
    title = "Calibration Plot for Seasonal Projections of Quarterbacks"
  ) +
  theme_classic() + 
  theme(axis.title.y = element_text(angle = 0, vjust = 0.5)) # horizontal y-axis title
```

Here are the seasonal accuracy indexes for only those Quarterbacks who had high projected or actual points (i.e., players who had more than 100 projected or actual points; the players that are most important to differentiate between):

```{r}
petersenlab::accuracyOverall(
  predicted = projectionsWithActuals_seasonal_qb$raw_points[which(projectionsWithActuals_seasonal$player_id_season %in% playersWithHighProjectedOrActualPoints)],
  actual = projectionsWithActuals_seasonal_qb$fantasyPoints[which(projectionsWithActuals_seasonal$player_id_season %in% playersWithHighProjectedOrActualPoints)],
  dropUndefined = TRUE
)
```

```{r}
#| include: false

accuracyIndices_seasonal_qb_subset <- petersenlab::accuracyOverall(
  predicted = projectionsWithActuals_seasonal_qb$raw_points[which(projectionsWithActuals_seasonal$player_id_season %in% playersWithHighProjectedOrActualPoints)],
  actual = projectionsWithActuals_seasonal_qb$fantasyPoints[which(projectionsWithActuals_seasonal$player_id_season %in% playersWithHighProjectedOrActualPoints)],
  dropUndefined = TRUE
)

rsquare_seasonal_qb_subset <- round(accuracyIndices_seasonal_qb_subset$rsquared, digits = 2)
me_seasonal_qb_subset <- round(accuracyIndices_seasonal_qb_subset$ME, digits = 2)
mae_seasonal_qb_subset <- round(accuracyIndices_seasonal_qb_subset$MAE, digits = 2)
```

Here are the seasonal accuracy indexes for crowd-averaged projections for Quarterbacks:

```{r}
petersenlab::accuracyOverall(
  predicted = crowdAveragedProjectionsWithActuals_seasonal_qb$points,
  actual = crowdAveragedProjectionsWithActuals_seasonal_qb$fantasyPoints,
  dropUndefined = TRUE
)
```

```{r}
#| include: false

accuracyIndices_seasonal_qb_crowd <- petersenlab::accuracyOverall(
  predicted = crowdAveragedProjectionsWithActuals_seasonal_qb$points,
  actual = crowdAveragedProjectionsWithActuals_seasonal_qb$fantasyPoints,
  dropUndefined = TRUE
)

rsquare_seasonal_qb_crowd <- round(accuracyIndices_seasonal_qb_crowd$rsquared, digits = 2)
me_seasonal_qb_crowd <- round(accuracyIndices_seasonal_qb_crowd$ME, digits = 2)
mae_seasonal_qb_crowd <- round(accuracyIndices_seasonal_qb_crowd$MAE, digits = 2)
```

Here are the seasonal accuracy indexes for crowd-averaged projections of Quarterbacks, but only among those who had high projected or actual points (i.e., players who had more than 100 projected or actual points; the players that are most important to differentiate between):

```{r}
petersenlab::accuracyOverall(
  predicted = crowdAveragedProjectionsWithActuals_seasonal_qb$points[which(crowdAveragedProjectionsWithActuals_seasonal_qb$player_id_season %in% playersWithHighProjectedOrActualPoints)],
  actual = crowdAveragedProjectionsWithActuals_seasonal_qb$fantasyPoints[which(crowdAveragedProjectionsWithActuals_seasonal_qb$player_id_season %in% playersWithHighProjectedOrActualPoints)],
  dropUndefined = TRUE
)
```

```{r}
#| include: false

accuracyIndices_seasonal_qb_crowd_subset <- petersenlab::accuracyOverall(
  predicted = crowdAveragedProjectionsWithActuals_seasonal_qb$points[which(crowdAveragedProjectionsWithActuals_seasonal_qb$player_id_season %in% playersWithHighProjectedOrActualPoints)],
  actual = crowdAveragedProjectionsWithActuals_seasonal_qb$fantasyPoints[which(crowdAveragedProjectionsWithActuals_seasonal_qb$player_id_season %in% playersWithHighProjectedOrActualPoints)],
  dropUndefined = TRUE
)

rsquare_seasonal_qb_crowd_subset <- round(accuracyIndices_seasonal_qb_crowd_subset$rsquared, digits = 2)
me_seasonal_qb_crowd_subset <- round(accuracyIndices_seasonal_qb_crowd_subset$ME, digits = 2)
mae_seasonal_qb_crowd_subset <- round(accuracyIndices_seasonal_qb_crowd_subset$MAE, digits = 2)
```

#### Running Backs {#sec-accuracyProjectionsSeasonalRB}

Here are the seasonal accuracy indexes for all Running Backs:

```{r}
petersenlab::accuracyOverall(
  predicted = projectionsWithActuals_seasonal_rb$raw_points,
  actual = projectionsWithActuals_seasonal_rb$fantasyPoints,
  dropUndefined = TRUE
)
```

```{r}
#| include: false

accuracyIndices_seasonal_rb <- petersenlab::accuracyOverall(
  predicted = projectionsWithActuals_seasonal_rb$raw_points,
  actual = projectionsWithActuals_seasonal_rb$fantasyPoints,
  dropUndefined = TRUE
)

rsquare_seasonal_rb <- round(accuracyIndices_seasonal_rb$rsquared, digits = 2)
me_seasonal_rb <- round(accuracyIndices_seasonal_rb$ME, digits = 2)
mae_seasonal_rb <- round(accuracyIndices_seasonal_rb$MAE, digits = 2)
```

A calibration plot of the seasonal projections for Running Backs is in @fig-calibrationPlotSeasonalRBs.

```{r}
#| label: fig-calibrationPlotSeasonalRBs
#| fig-cap: "Calibration Plot for Seasonal Projections of Running Backs. The diagonal black line is the reference line representing perfect calibration. The yellow line is the best-fit line based on a locally estimated scatterplot smoothing (LOESS) model. The purple band is the 95% confidence interval of actual fantasy points. The dashed red lines are the 95% prediction interval of actual fantasy points."
#| fig-alt: "Calibration Plot for Seasonal Projections of Running Backs. The diagonal black line is the reference line representing perfect calibration. The yellow line is the best-fit line based on a locally estimated scatterplot smoothing (LOESS) model. The purple band is the 95% confidence interval of actual fantasy points. The dashed red lines are the 95% prediction interval of actual fantasy points."
#| fig-width: 8
#| fig-height: 6

#95 prediction interval based on LOESS model
calibrationLoessModel <- msir::loess.sd(
  x = projectionsWithActuals_seasonal_rb$raw_points,
  y = projectionsWithActuals_seasonal_rb$fantasyPoints,
  nsigma = qnorm(.975),
  na.action = "na.exclude")

calibrationLoessPredictionInterval <- data.frame(
  x = calibrationLoessModel$x,
  y = calibrationLoessModel$y,
  lower = calibrationLoessModel$lower,
  upper = calibrationLoessModel$upper)

plotRangeMin <- min(calibrationLoessModel$lower, na.rm = TRUE)

plotRangeMax <- max(calibrationLoessModel$upper, na.rm = TRUE)

ggplot2::ggplot(
  data = projectionsWithActuals_seasonal_rb,
  aes(
    x = raw_points,
    y = fantasyPoints)) + 
  coord_cartesian(
    xlim = c(0, plotRangeMax),
    ylim = c(plotRangeMin, plotRangeMax),
    expand = FALSE) +
  scale_x_continuous(breaks = seq(0, plotRangeMax, by = 100)) +
  scale_y_continuous(breaks = seq(0, plotRangeMax, by = 100)) +
  geom_line(
    data = calibrationLoessPredictionInterval,
    aes(
      x = x,
      y = lower),
    color = "red",
    linetype = "dashed") + #Lower estimate of 95% prediction interval of linear model
  geom_line(
    data = calibrationLoessPredictionInterval,
    aes(
      x = x,
      y = upper),
    color = "red",
    linetype = "dashed") + #Upper estimate of 95% prediction interval of linear model
  geom_smooth(
    method = "loess",
    color = viridisLite::viridis(3)[3],
    fill = viridisLite::viridis(3)[1],
    alpha = 0.7) + #95% confidence interval of LOESS model
  geom_abline(
    slope = 1,
    intercept = 0) +
  labs(
    x = "Projected Fantasy Points",
    y = "Actual Fantasy Points",
    title = "Calibration Plot for Seasonal Projections of Running Backs"
  ) +
  theme_classic() + 
  theme(axis.title.y = element_text(angle = 0, vjust = 0.5)) # horizontal y-axis title
```

Here are the seasonal accuracy indexes for only those Running Backs who had high projected or actual points (i.e., players who had more than 100 projected or actual points; the players that are most important to differentiate between):

```{r}
petersenlab::accuracyOverall(
  predicted = projectionsWithActuals_seasonal_rb$raw_points[which(projectionsWithActuals_seasonal$player_id_season %in% playersWithHighProjectedOrActualPoints)],
  actual = projectionsWithActuals_seasonal_rb$fantasyPoints[which(projectionsWithActuals_seasonal$player_id_season %in% playersWithHighProjectedOrActualPoints)],
  dropUndefined = TRUE
)
```

```{r}
#| include: false

accuracyIndices_seasonal_rb_subset <- petersenlab::accuracyOverall(
  predicted = projectionsWithActuals_seasonal_rb$raw_points[which(projectionsWithActuals_seasonal$player_id_season %in% playersWithHighProjectedOrActualPoints)],
  actual = projectionsWithActuals_seasonal_rb$fantasyPoints[which(projectionsWithActuals_seasonal$player_id_season %in% playersWithHighProjectedOrActualPoints)],
  dropUndefined = TRUE
)

rsquare_seasonal_rb_subset <- round(accuracyIndices_seasonal_rb_subset$rsquared, digits = 2)
me_seasonal_rb_subset <- round(accuracyIndices_seasonal_rb_subset$ME, digits = 2)
mae_seasonal_rb_subset <- round(accuracyIndices_seasonal_rb_subset$MAE, digits = 2)
```

Here are the seasonal accuracy indexes for crowd-averaged projections for Running Backs:

```{r}
petersenlab::accuracyOverall(
  predicted = crowdAveragedProjectionsWithActuals_seasonal_rb$points,
  actual = crowdAveragedProjectionsWithActuals_seasonal_rb$fantasyPoints,
  dropUndefined = TRUE
)
```

```{r}
#| include: false

accuracyIndices_seasonal_rb_crowd <- petersenlab::accuracyOverall(
  predicted = crowdAveragedProjectionsWithActuals_seasonal_rb$points,
  actual = crowdAveragedProjectionsWithActuals_seasonal_rb$fantasyPoints,
  dropUndefined = TRUE
)

rsquare_seasonal_rb_crowd <- round(accuracyIndices_seasonal_rb_crowd$rsquared, digits = 2)
me_seasonal_rb_crowd <- round(accuracyIndices_seasonal_rb_crowd$ME, digits = 2)
mae_seasonal_rb_crowd <- round(accuracyIndices_seasonal_rb_crowd$MAE, digits = 2)
```

Here are the seasonal accuracy indexes for crowd-averaged projections of Running Backs, but only among those who had high projected or actual points (i.e., players who had more than 100 projected or actual points; the players that are most important to differentiate between):

```{r}
petersenlab::accuracyOverall(
  predicted = crowdAveragedProjectionsWithActuals_seasonal_rb$points[which(crowdAveragedProjectionsWithActuals_seasonal_rb$player_id_season %in% playersWithHighProjectedOrActualPoints)],
  actual = crowdAveragedProjectionsWithActuals_seasonal_rb$fantasyPoints[which(crowdAveragedProjectionsWithActuals_seasonal_rb$player_id_season %in% playersWithHighProjectedOrActualPoints)],
  dropUndefined = TRUE
)
```

```{r}
#| include: false

accuracyIndices_seasonal_rb_crowd_subset <- petersenlab::accuracyOverall(
  predicted = crowdAveragedProjectionsWithActuals_seasonal_rb$points[which(crowdAveragedProjectionsWithActuals_seasonal_rb$player_id_season %in% playersWithHighProjectedOrActualPoints)],
  actual = crowdAveragedProjectionsWithActuals_seasonal_rb$fantasyPoints[which(crowdAveragedProjectionsWithActuals_seasonal_rb$player_id_season %in% playersWithHighProjectedOrActualPoints)],
  dropUndefined = TRUE
)

rsquare_seasonal_rb_crowd_subset <- round(accuracyIndices_seasonal_rb_crowd_subset$rsquared, digits = 2)
me_seasonal_rb_crowd_subset <- round(accuracyIndices_seasonal_rb_crowd_subset$ME, digits = 2)
mae_seasonal_rb_crowd_subset <- round(accuracyIndices_seasonal_rb_crowd_subset$MAE, digits = 2)
```

#### Wide Receivers {#sec-accuracyProjectionsSeasonalWR}

Here are the seasonal accuracy indexes for all Wide Receivers:

```{r}
petersenlab::accuracyOverall(
  predicted = projectionsWithActuals_seasonal_wr$raw_points,
  actual = projectionsWithActuals_seasonal_wr$fantasyPoints,
  dropUndefined = TRUE
)
```

```{r}
#| include: false

accuracyIndices_seasonal_wr <- petersenlab::accuracyOverall(
  predicted = projectionsWithActuals_seasonal_wr$raw_points,
  actual = projectionsWithActuals_seasonal_wr$fantasyPoints,
  dropUndefined = TRUE
)

rsquare_seasonal_wr <- round(accuracyIndices_seasonal_wr$rsquared, digits = 2)
me_seasonal_wr <- round(accuracyIndices_seasonal_wr$ME, digits = 2)
mae_seasonal_wr <- round(accuracyIndices_seasonal_wr$MAE, digits = 2)
```

A calibration plot of the seasonal projections for Wide Receivers is in @fig-calibrationPlotSeasonalWRs.

```{r}
#| label: fig-calibrationPlotSeasonalWRs
#| fig-cap: "Calibration Plot for Seasonal Projections of Wide Receivers. The diagonal black line is the reference line representing perfect calibration. The yellow line is the best-fit line based on a locally estimated scatterplot smoothing (LOESS) model. The purple band is the 95% confidence interval of actual fantasy points. The dashed red lines are the 95% prediction interval of actual fantasy points."
#| fig-alt: "Calibration Plot for Seasonal Projections of Wide Receivers. The diagonal black line is the reference line representing perfect calibration. The yellow line is the best-fit line based on a locally estimated scatterplot smoothing (LOESS) model. The purple band is the 95% confidence interval of actual fantasy points. The dashed red lines are the 95% prediction interval of actual fantasy points."
#| fig-width: 8
#| fig-height: 6

#95 prediction interval based on LOESS model
calibrationLoessModel <- msir::loess.sd(
  x = projectionsWithActuals_seasonal_wr$raw_points,
  y = projectionsWithActuals_seasonal_wr$fantasyPoints,
  nsigma = qnorm(.975),
  na.action = "na.exclude")

calibrationLoessPredictionInterval <- data.frame(
  x = calibrationLoessModel$x,
  y = calibrationLoessModel$y,
  lower = calibrationLoessModel$lower,
  upper = calibrationLoessModel$upper)

plotRangeMin <- min(calibrationLoessModel$lower, na.rm = TRUE)

plotRangeMax <- max(calibrationLoessModel$upper, na.rm = TRUE)

ggplot2::ggplot(
  data = projectionsWithActuals_seasonal_wr,
  aes(
    x = raw_points,
    y = fantasyPoints)) + 
  coord_cartesian(
    xlim = c(0, plotRangeMax),
    ylim = c(plotRangeMin, plotRangeMax),
    expand = FALSE) +
  scale_x_continuous(breaks = seq(0, plotRangeMax, by = 100)) +
  scale_y_continuous(breaks = seq(0, plotRangeMax, by = 100)) +
  geom_line(
    data = calibrationLoessPredictionInterval,
    aes(
      x = x,
      y = lower),
    color = "red",
    linetype = "dashed") + #Lower estimate of 95% prediction interval of linear model
  geom_line(
    data = calibrationLoessPredictionInterval,
    aes(
      x = x,
      y = upper),
    color = "red",
    linetype = "dashed") + #Upper estimate of 95% prediction interval of linear model
  geom_smooth(
    method = "loess",
    color = viridisLite::viridis(3)[3],
    fill = viridisLite::viridis(3)[1],
    alpha = 0.7) + #95% confidence interval of LOESS model
  geom_abline(
    slope = 1,
    intercept = 0) +
  labs(
    x = "Projected Fantasy Points",
    y = "Actual Fantasy Points",
    title = "Calibration Plot for Seasonal Projections of Wide Receivers"
  ) +
  theme_classic() + 
  theme(axis.title.y = element_text(angle = 0, vjust = 0.5)) # horizontal y-axis title
```

Here are the seasonal accuracy indexes for only those Wide Receivers who had high projected or actual points (i.e., players who had more than 100 projected or actual points; the players that are most important to differentiate between):

```{r}
petersenlab::accuracyOverall(
  predicted = projectionsWithActuals_seasonal_wr$raw_points[which(projectionsWithActuals_seasonal$player_id_season %in% playersWithHighProjectedOrActualPoints)],
  actual = projectionsWithActuals_seasonal_wr$fantasyPoints[which(projectionsWithActuals_seasonal$player_id_season %in% playersWithHighProjectedOrActualPoints)],
  dropUndefined = TRUE
)
```

```{r}
#| include: false

accuracyIndices_seasonal_wr_subset <- petersenlab::accuracyOverall(
  predicted = projectionsWithActuals_seasonal_wr$raw_points[which(projectionsWithActuals_seasonal$player_id_season %in% playersWithHighProjectedOrActualPoints)],
  actual = projectionsWithActuals_seasonal_wr$fantasyPoints[which(projectionsWithActuals_seasonal$player_id_season %in% playersWithHighProjectedOrActualPoints)],
  dropUndefined = TRUE
)

rsquare_seasonal_wr_subset <- round(accuracyIndices_seasonal_wr_subset$rsquared, digits = 2)
me_seasonal_wr_subset <- round(accuracyIndices_seasonal_wr_subset$ME, digits = 2)
mae_seasonal_wr_subset <- round(accuracyIndices_seasonal_wr_subset$MAE, digits = 2)
```

Here are the seasonal accuracy indexes for crowd-averaged projections for Wide Receivers:

```{r}
petersenlab::accuracyOverall(
  predicted = crowdAveragedProjectionsWithActuals_seasonal_wr$points,
  actual = crowdAveragedProjectionsWithActuals_seasonal_wr$fantasyPoints,
  dropUndefined = TRUE
)
```

```{r}
#| include: false

accuracyIndices_seasonal_wr_crowd <- petersenlab::accuracyOverall(
  predicted = crowdAveragedProjectionsWithActuals_seasonal_wr$points,
  actual = crowdAveragedProjectionsWithActuals_seasonal_wr$fantasyPoints,
  dropUndefined = TRUE
)

rsquare_seasonal_wr_crowd <- round(accuracyIndices_seasonal_wr_crowd$rsquared, digits = 2)
me_seasonal_wr_crowd <- round(accuracyIndices_seasonal_wr_crowd$ME, digits = 2)
mae_seasonal_wr_crowd <- round(accuracyIndices_seasonal_wr_crowd$MAE, digits = 2)
```

Here are the seasonal accuracy indexes for crowd-averaged projections of Wide Receivers, but only among those who had high projected or actual points (i.e., players who had more than 100 projected or actual points; the players that are most important to differentiate between):

```{r}
petersenlab::accuracyOverall(
  predicted = crowdAveragedProjectionsWithActuals_seasonal_wr$points[which(crowdAveragedProjectionsWithActuals_seasonal_wr$player_id_season %in% playersWithHighProjectedOrActualPoints)],
  actual = crowdAveragedProjectionsWithActuals_seasonal_wr$fantasyPoints[which(crowdAveragedProjectionsWithActuals_seasonal_wr$player_id_season %in% playersWithHighProjectedOrActualPoints)],
  dropUndefined = TRUE
)
```

```{r}
#| include: false

accuracyIndices_seasonal_wr_crowd_subset <- petersenlab::accuracyOverall(
  predicted = crowdAveragedProjectionsWithActuals_seasonal_wr$points[which(crowdAveragedProjectionsWithActuals_seasonal_wr$player_id_season %in% playersWithHighProjectedOrActualPoints)],
  actual = crowdAveragedProjectionsWithActuals_seasonal_wr$fantasyPoints[which(crowdAveragedProjectionsWithActuals_seasonal_wr$player_id_season %in% playersWithHighProjectedOrActualPoints)],
  dropUndefined = TRUE
)

rsquare_seasonal_wr_crowd_subset <- round(accuracyIndices_seasonal_wr_crowd_subset$rsquared, digits = 2)
me_seasonal_wr_crowd_subset <- round(accuracyIndices_seasonal_wr_crowd_subset$ME, digits = 2)
mae_seasonal_wr_crowd_subset <- round(accuracyIndices_seasonal_wr_crowd_subset$MAE, digits = 2)
```

#### Tight Ends {#sec-accuracyProjectionsSeasonalTE}

Here are the seasonal accuracy indexes for all Tight Ends:

```{r}
petersenlab::accuracyOverall(
  predicted = projectionsWithActuals_seasonal_te$raw_points,
  actual = projectionsWithActuals_seasonal_te$fantasyPoints,
  dropUndefined = TRUE
)
```

```{r}
#| include: false

accuracyIndices_seasonal_te <- petersenlab::accuracyOverall(
  predicted = projectionsWithActuals_seasonal_te$raw_points,
  actual = projectionsWithActuals_seasonal_te$fantasyPoints,
  dropUndefined = TRUE
)

rsquare_seasonal_te <- round(accuracyIndices_seasonal_te$rsquared, digits = 2)
me_seasonal_te <- round(accuracyIndices_seasonal_te$ME, digits = 2)
mae_seasonal_te <- round(accuracyIndices_seasonal_te$MAE, digits = 2)
```

A calibration plot of the seasonal projections for Tight Ends is in @fig-calibrationPlotSeasonalTEs.

```{r}
#| label: fig-calibrationPlotSeasonalTEs
#| fig-cap: "Calibration Plot for Seasonal Projections of Tight Ends. The diagonal black line is the reference line representing perfect calibration. The yellow line is the best-fit line based on a locally estimated scatterplot smoothing (LOESS) model. The purple band is the 95% confidence interval of actual fantasy points. The dashed red lines are the 95% prediction interval of actual fantasy points."
#| fig-alt: "Calibration Plot for Seasonal Projections of Tight Ends. The diagonal black line is the reference line representing perfect calibration. The yellow line is the best-fit line based on a locally estimated scatterplot smoothing (LOESS) model. The purple band is the 95% confidence interval of actual fantasy points. The dashed red lines are the 95% prediction interval of actual fantasy points."
#| fig-width: 8
#| fig-height: 6

#95 prediction interval based on LOESS model
calibrationLoessModel <- msir::loess.sd(
  x = projectionsWithActuals_seasonal_te$raw_points,
  y = projectionsWithActuals_seasonal_te$fantasyPoints,
  nsigma = qnorm(.975),
  na.action = "na.exclude")

calibrationLoessPredictionInterval <- data.frame(
  x = calibrationLoessModel$x,
  y = calibrationLoessModel$y,
  lower = calibrationLoessModel$lower,
  upper = calibrationLoessModel$upper)

plotRangeMin <- min(calibrationLoessModel$lower, na.rm = TRUE)

plotRangeMax <- max(calibrationLoessModel$upper, na.rm = TRUE)

ggplot2::ggplot(
  data = projectionsWithActuals_seasonal_te,
  aes(
    x = raw_points,
    y = fantasyPoints)) + 
  coord_cartesian(
    xlim = c(0, plotRangeMax),
    ylim = c(plotRangeMin, plotRangeMax),
    expand = FALSE) +
  scale_x_continuous(breaks = seq(0, plotRangeMax, by = 50)) +
  scale_y_continuous(breaks = seq(0, plotRangeMax, by = 50)) +
  geom_line(
    data = calibrationLoessPredictionInterval,
    aes(
      x = x,
      y = lower),
    color = "red",
    linetype = "dashed") + #Lower estimate of 95% prediction interval of linear model
  geom_line(
    data = calibrationLoessPredictionInterval,
    aes(
      x = x,
      y = upper),
    color = "red",
    linetype = "dashed") + #Upper estimate of 95% prediction interval of linear model
  geom_smooth(
    method = "loess",
    color = viridisLite::viridis(3)[3],
    fill = viridisLite::viridis(3)[1],
    alpha = 0.7) + #95% confidence interval of LOESS model
  geom_abline(
    slope = 1,
    intercept = 0) +
  labs(
    x = "Projected Fantasy Points",
    y = "Actual Fantasy Points",
    title = "Calibration Plot for Seasonal Projections of Tight Ends"
  ) +
  theme_classic() + 
  theme(axis.title.y = element_text(angle = 0, vjust = 0.5)) # horizontal y-axis title
```

Here are the seasonal accuracy indexes for only those Tight Ends who had high projected or actual points (i.e., players who had more than 100 projected or actual points; the players that are most important to differentiate between):

```{r}
petersenlab::accuracyOverall(
  predicted = projectionsWithActuals_seasonal_te$raw_points[which(projectionsWithActuals_seasonal$player_id_season %in% playersWithHighProjectedOrActualPoints)],
  actual = projectionsWithActuals_seasonal_te$fantasyPoints[which(projectionsWithActuals_seasonal$player_id_season %in% playersWithHighProjectedOrActualPoints)],
  dropUndefined = TRUE
)
```

```{r}
#| include: false

accuracyIndices_seasonal_te_subset <- petersenlab::accuracyOverall(
  predicted = projectionsWithActuals_seasonal_te$raw_points[which(projectionsWithActuals_seasonal$player_id_season %in% playersWithHighProjectedOrActualPoints)],
  actual = projectionsWithActuals_seasonal_te$fantasyPoints[which(projectionsWithActuals_seasonal$player_id_season %in% playersWithHighProjectedOrActualPoints)],
  dropUndefined = TRUE
)

rsquare_seasonal_te_subset <- round(accuracyIndices_seasonal_te_subset$rsquared, digits = 2)
me_seasonal_te_subset <- round(accuracyIndices_seasonal_te_subset$ME, digits = 2)
mae_seasonal_te_subset <- round(accuracyIndices_seasonal_te_subset$MAE, digits = 2)
```

Here are the seasonal accuracy indexes for crowd-averaged projections for Tight Ends:

```{r}
petersenlab::accuracyOverall(
  predicted = crowdAveragedProjectionsWithActuals_seasonal_te$points,
  actual = crowdAveragedProjectionsWithActuals_seasonal_te$fantasyPoints,
  dropUndefined = TRUE
)
```

```{r}
#| include: false

accuracyIndices_seasonal_te_crowd <- petersenlab::accuracyOverall(
  predicted = crowdAveragedProjectionsWithActuals_seasonal_te$points,
  actual = crowdAveragedProjectionsWithActuals_seasonal_te$fantasyPoints,
  dropUndefined = TRUE
)

rsquare_seasonal_te_crowd <- round(accuracyIndices_seasonal_te_crowd$rsquared, digits = 2)
me_seasonal_te_crowd <- round(accuracyIndices_seasonal_te_crowd$ME, digits = 2)
mae_seasonal_te_crowd <- round(accuracyIndices_seasonal_te_crowd$MAE, digits = 2)
```

Here are the seasonal accuracy indexes for crowd-averaged projections of Tight Ends, but only among those who had high projected or actual points (i.e., players who had more than 100 projected or actual points; the players that are most important to differentiate between):

```{r}
petersenlab::accuracyOverall(
  predicted = crowdAveragedProjectionsWithActuals_seasonal_te$points[which(crowdAveragedProjectionsWithActuals_seasonal_te$player_id_season %in% playersWithHighProjectedOrActualPoints)],
  actual = crowdAveragedProjectionsWithActuals_seasonal_te$fantasyPoints[which(crowdAveragedProjectionsWithActuals_seasonal_te$player_id_season %in% playersWithHighProjectedOrActualPoints)],
  dropUndefined = TRUE
)
```

```{r}
#| include: false

accuracyIndices_seasonal_te_crowd_subset <- petersenlab::accuracyOverall(
  predicted = crowdAveragedProjectionsWithActuals_seasonal_te$points[which(crowdAveragedProjectionsWithActuals_seasonal_te$player_id_season %in% playersWithHighProjectedOrActualPoints)],
  actual = crowdAveragedProjectionsWithActuals_seasonal_te$fantasyPoints[which(crowdAveragedProjectionsWithActuals_seasonal_te$player_id_season %in% playersWithHighProjectedOrActualPoints)],
  dropUndefined = TRUE
)

rsquare_seasonal_te_crowd_subset <- round(accuracyIndices_seasonal_te_crowd_subset$rsquared, digits = 2)
me_seasonal_te_crowd_subset <- round(accuracyIndices_seasonal_te_crowd_subset$ME, digits = 2)
mae_seasonal_te_crowd_subset <- round(accuracyIndices_seasonal_te_crowd_subset$MAE, digits = 2)
```

#### Kickers {#sec-accuracyProjectionsSeasonalK}

Here are the seasonal accuracy indexes for all Kickers:

```{r}
petersenlab::accuracyOverall(
  predicted = projectionsWithActuals_seasonal_k$raw_points,
  actual = projectionsWithActuals_seasonal_k$fantasyPoints,
  dropUndefined = TRUE
)
```

```{r}
#| include: false

accuracyIndices_seasonal_k <- petersenlab::accuracyOverall(
  predicted = projectionsWithActuals_seasonal_k$raw_points,
  actual = projectionsWithActuals_seasonal_k$fantasyPoints,
  dropUndefined = TRUE
)

rsquare_seasonal_k <- round(accuracyIndices_seasonal_k$rsquared, digits = 2)
me_seasonal_k <- round(accuracyIndices_seasonal_k$ME, digits = 2)
mae_seasonal_k <- round(accuracyIndices_seasonal_k$MAE, digits = 2)
```

A calibration plot of the seasonal projections for Kickers is in @fig-calibrationPlotSeasonalKs.

```{r}
#| label: fig-calibrationPlotSeasonalKs
#| fig-cap: "Calibration Plot for Seasonal Projections of Kickers. The diagonal black line is the reference line representing perfect calibration. The yellow line is the best-fit line based on a locally estimated scatterplot smoothing (LOESS) model. The purple band is the 95% confidence interval of actual fantasy points. The dashed red lines are the 95% prediction interval of actual fantasy points."
#| fig-alt: "Calibration Plot for Seasonal Projections of Kickers. The diagonal black line is the reference line representing perfect calibration. The yellow line is the best-fit line based on a locally estimated scatterplot smoothing (LOESS) model. The purple band is the 95% confidence interval of actual fantasy points. The dashed red lines are the 95% prediction interval of actual fantasy points."
#| fig-width: 8
#| fig-height: 6

#95 prediction interval based on LOESS model
calibrationLoessModel <- msir::loess.sd(
  x = projectionsWithActuals_seasonal_k$raw_points,
  y = projectionsWithActuals_seasonal_k$fantasyPoints,
  nsigma = qnorm(.975),
  na.action = "na.exclude")

calibrationLoessPredictionInterval <- data.frame(
  x = calibrationLoessModel$x,
  y = calibrationLoessModel$y,
  lower = calibrationLoessModel$lower,
  upper = calibrationLoessModel$upper)

plotRangeMin <- min(calibrationLoessModel$lower, na.rm = TRUE)

plotRangeMax <- max(calibrationLoessModel$upper, na.rm = TRUE)

ggplot2::ggplot(
  data = projectionsWithActuals_seasonal_k,
  aes(
    x = raw_points,
    y = fantasyPoints)) + 
  coord_cartesian(
    xlim = c(0, plotRangeMax),
    ylim = c(plotRangeMin, plotRangeMax),
    expand = FALSE) +
  scale_x_continuous(breaks = seq(0, plotRangeMax, by = 50)) +
  scale_y_continuous(breaks = seq(0, plotRangeMax, by = 50)) +
  geom_line(
    data = calibrationLoessPredictionInterval,
    aes(
      x = x,
      y = lower),
    color = "red",
    linetype = "dashed") + #Lower estimate of 95% prediction interval of linear model
  geom_line(
    data = calibrationLoessPredictionInterval,
    aes(
      x = x,
      y = upper),
    color = "red",
    linetype = "dashed") + #Upper estimate of 95% prediction interval of linear model
  geom_smooth(
    method = "loess",
    color = viridisLite::viridis(3)[3],
    fill = viridisLite::viridis(3)[1],
    alpha = 0.7) + #95% confidence interval of LOESS model
  geom_abline(
    slope = 1,
    intercept = 0) +
  labs(
    x = "Projected Fantasy Points",
    y = "Actual Fantasy Points",
    title = "Calibration Plot for Seasonal Projections of Kickers"
  ) +
  theme_classic() + 
  theme(axis.title.y = element_text(angle = 0, vjust = 0.5)) # horizontal y-axis title
```

Here are the seasonal accuracy indexes for only those Kickers who had high projected or actual points (i.e., players who had more than 100 projected or actual points; the players that are most important to differentiate between):

```{r}
petersenlab::accuracyOverall(
  predicted = projectionsWithActuals_seasonal_k$raw_points[which(projectionsWithActuals_seasonal$player_id_season %in% playersWithHighProjectedOrActualPoints)],
  actual = projectionsWithActuals_seasonal_k$fantasyPoints[which(projectionsWithActuals_seasonal$player_id_season %in% playersWithHighProjectedOrActualPoints)],
  dropUndefined = TRUE
)
```

```{r}
#| include: false

accuracyIndices_seasonal_k_subset <- petersenlab::accuracyOverall(
  predicted = projectionsWithActuals_seasonal_k$raw_points[which(projectionsWithActuals_seasonal$player_id_season %in% playersWithHighProjectedOrActualPoints)],
  actual = projectionsWithActuals_seasonal_k$fantasyPoints[which(projectionsWithActuals_seasonal$player_id_season %in% playersWithHighProjectedOrActualPoints)],
  dropUndefined = TRUE
)

rsquare_seasonal_k_subset <- round(accuracyIndices_seasonal_k_subset$rsquared, digits = 2)
me_seasonal_k_subset <- round(accuracyIndices_seasonal_k_subset$ME, digits = 2)
mae_seasonal_k_subset <- round(accuracyIndices_seasonal_k_subset$MAE, digits = 2)
```

Here are the seasonal accuracy indexes for crowd-averaged projections for Kickers:

```{r}
petersenlab::accuracyOverall(
  predicted = crowdAveragedProjectionsWithActuals_seasonal_k$points,
  actual = crowdAveragedProjectionsWithActuals_seasonal_k$fantasyPoints,
  dropUndefined = TRUE
)
```

```{r}
#| include: false

accuracyIndices_seasonal_k_crowd <- petersenlab::accuracyOverall(
  predicted = crowdAveragedProjectionsWithActuals_seasonal_k$points,
  actual = crowdAveragedProjectionsWithActuals_seasonal_k$fantasyPoints,
  dropUndefined = TRUE
)

rsquare_seasonal_k_crowd <- round(accuracyIndices_seasonal_k_crowd$rsquared, digits = 2)
me_seasonal_k_crowd <- round(accuracyIndices_seasonal_k_crowd$ME, digits = 2)
mae_seasonal_k_crowd <- round(accuracyIndices_seasonal_k_crowd$MAE, digits = 2)
```

Here are the seasonal accuracy indexes for crowd-averaged projections of Kickers, but only among those who had high projected or actual points (i.e., players who had more than 100 projected or actual points; the players that are most important to differentiate between):

```{r}
petersenlab::accuracyOverall(
  predicted = crowdAveragedProjectionsWithActuals_seasonal_k$points[which(crowdAveragedProjectionsWithActuals_seasonal_k$player_id_season %in% playersWithHighProjectedOrActualPoints)],
  actual = crowdAveragedProjectionsWithActuals_seasonal_k$fantasyPoints[which(crowdAveragedProjectionsWithActuals_seasonal_k$player_id_season %in% playersWithHighProjectedOrActualPoints)],
  dropUndefined = TRUE
)
```

```{r}
#| include: false

accuracyIndices_seasonal_k_crowd_subset <- petersenlab::accuracyOverall(
  predicted = crowdAveragedProjectionsWithActuals_seasonal_k$points[which(crowdAveragedProjectionsWithActuals_seasonal_k$player_id_season %in% playersWithHighProjectedOrActualPoints)],
  actual = crowdAveragedProjectionsWithActuals_seasonal_k$fantasyPoints[which(crowdAveragedProjectionsWithActuals_seasonal_k$player_id_season %in% playersWithHighProjectedOrActualPoints)],
  dropUndefined = TRUE
)

rsquare_seasonal_k_crowd_subset <- round(accuracyIndices_seasonal_k_crowd_subset$rsquared, digits = 2)
me_seasonal_k_crowd_subset <- round(accuracyIndices_seasonal_k_crowd_subset$ME, digits = 2)
mae_seasonal_k_crowd_subset <- round(accuracyIndices_seasonal_k_crowd_subset$MAE, digits = 2)
```

#### Defensive Linemen {#sec-accuracyProjectionsSeasonalDL}

Here are the seasonal accuracy indexes for all Defensive Linemen:

```{r}
petersenlab::accuracyOverall(
  predicted = projectionsWithActuals_seasonal_dl$raw_points,
  actual = projectionsWithActuals_seasonal_dl$fantasyPoints,
  dropUndefined = TRUE
)
```

```{r}
#| include: false

accuracyIndices_seasonal_dl <- petersenlab::accuracyOverall(
  predicted = projectionsWithActuals_seasonal_dl$raw_points,
  actual = projectionsWithActuals_seasonal_dl$fantasyPoints,
  dropUndefined = TRUE
)

rsquare_seasonal_dl <- round(accuracyIndices_seasonal_dl$rsquared, digits = 2)
me_seasonal_dl <- round(accuracyIndices_seasonal_dl$ME, digits = 2)
mae_seasonal_dl <- round(accuracyIndices_seasonal_dl$MAE, digits = 2)
```

A calibration plot of the seasonal projections for Defensive Linemen is in @fig-calibrationPlotSeasonalDLs.

```{r}
#| label: fig-calibrationPlotSeasonalDLs
#| fig-cap: "Calibration Plot for Seasonal Projections of Defensive Linemen. The diagonal black line is the reference line representing perfect calibration. The yellow line is the best-fit line based on a locally estimated scatterplot smoothing (LOESS) model. The purple band is the 95% confidence interval of actual fantasy points. The dashed red lines are the 95% prediction interval of actual fantasy points."
#| fig-alt: "Calibration Plot for Seasonal Projections of Defensive Linemen. The diagonal black line is the reference line representing perfect calibration. The yellow line is the best-fit line based on a locally estimated scatterplot smoothing (LOESS) model. The purple band is the 95% confidence interval of actual fantasy points. The dashed red lines are the 95% prediction interval of actual fantasy points."
#| fig-width: 8
#| fig-height: 6

#95 prediction interval based on LOESS model
calibrationLoessModel <- msir::loess.sd(
  x = projectionsWithActuals_seasonal_dl$raw_points,
  y = projectionsWithActuals_seasonal_dl$fantasyPoints,
  nsigma = qnorm(.975),
  na.action = "na.exclude")

calibrationLoessPredictionInterval <- data.frame(
  x = calibrationLoessModel$x,
  y = calibrationLoessModel$y,
  lower = calibrationLoessModel$lower,
  upper = calibrationLoessModel$upper)

plotRangeMin <- min(calibrationLoessModel$lower, na.rm = TRUE)

plotRangeMax <- max(calibrationLoessModel$upper, na.rm = TRUE)

ggplot2::ggplot(
  data = projectionsWithActuals_seasonal_dl,
  aes(
    x = raw_points,
    y = fantasyPoints)) + 
  coord_cartesian(
    xlim = c(0, plotRangeMax),
    ylim = c(plotRangeMin, plotRangeMax),
    expand = FALSE) +
  scale_x_continuous(breaks = seq(0, plotRangeMax, by = 20)) +
  scale_y_continuous(breaks = seq(0, plotRangeMax, by = 20)) +
  geom_line(
    data = calibrationLoessPredictionInterval,
    aes(
      x = x,
      y = lower),
    color = "red",
    linetype = "dashed") + #Lower estimate of 95% prediction interval of linear model
  geom_line(
    data = calibrationLoessPredictionInterval,
    aes(
      x = x,
      y = upper),
    color = "red",
    linetype = "dashed") + #Upper estimate of 95% prediction interval of linear model
  geom_smooth(
    method = "loess",
    color = viridisLite::viridis(3)[3],
    fill = viridisLite::viridis(3)[1],
    alpha = 0.7) + #95% confidence interval of LOESS model
  geom_abline(
    slope = 1,
    intercept = 0) +
  labs(
    x = "Projected Fantasy Points",
    y = "Actual Fantasy Points",
    title = "Calibration Plot for Seasonal Projections of Defensive Linemen"
  ) +
  theme_classic() + 
  theme(axis.title.y = element_text(angle = 0, vjust = 0.5)) # horizontal y-axis title
```

Here are the seasonal accuracy indexes for only those Defensive Linemen who had high projected or actual points (i.e., players who had more than 100 projected or actual points; the players that are most important to differentiate between):

```{r}
petersenlab::accuracyOverall(
  predicted = projectionsWithActuals_seasonal_dl$raw_points[which(projectionsWithActuals_seasonal$player_id_season %in% playersWithHighProjectedOrActualPoints)],
  actual = projectionsWithActuals_seasonal_dl$fantasyPoints[which(projectionsWithActuals_seasonal$player_id_season %in% playersWithHighProjectedOrActualPoints)],
  dropUndefined = TRUE
)
```

```{r}
#| include: false

accuracyIndices_seasonal_dl_subset <- petersenlab::accuracyOverall(
  predicted = projectionsWithActuals_seasonal_dl$raw_points[which(projectionsWithActuals_seasonal$player_id_season %in% playersWithHighProjectedOrActualPoints)],
  actual = projectionsWithActuals_seasonal_dl$fantasyPoints[which(projectionsWithActuals_seasonal$player_id_season %in% playersWithHighProjectedOrActualPoints)],
  dropUndefined = TRUE
)

rsquare_seasonal_dl_subset <- round(accuracyIndices_seasonal_dl_subset$rsquared, digits = 2)
me_seasonal_dl_subset <- round(accuracyIndices_seasonal_dl_subset$ME, digits = 2)
mae_seasonal_dl_subset <- round(accuracyIndices_seasonal_dl_subset$MAE, digits = 2)
```

Here are the seasonal accuracy indexes for crowd-averaged projections for Defensive Linemen:

```{r}
petersenlab::accuracyOverall(
  predicted = crowdAveragedProjectionsWithActuals_seasonal_dl$points,
  actual = crowdAveragedProjectionsWithActuals_seasonal_dl$fantasyPoints,
  dropUndefined = TRUE
)
```

```{r}
#| include: false

accuracyIndices_seasonal_dl_crowd <- petersenlab::accuracyOverall(
  predicted = crowdAveragedProjectionsWithActuals_seasonal_dl$points,
  actual = crowdAveragedProjectionsWithActuals_seasonal_dl$fantasyPoints,
  dropUndefined = TRUE
)

rsquare_seasonal_dl_crowd <- round(accuracyIndices_seasonal_dl_crowd$rsquared, digits = 2)
me_seasonal_dl_crowd <- round(accuracyIndices_seasonal_dl_crowd$ME, digits = 2)
mae_seasonal_dl_crowd <- round(accuracyIndices_seasonal_dl_crowd$MAE, digits = 2)
```

Here are the seasonal accuracy indexes for crowd-averaged projections of Defensive Linemen, but only among those who had high projected or actual points (i.e., players who had more than 100 projected or actual points; the players that are most important to differentiate between):

```{r}
petersenlab::accuracyOverall(
  predicted = crowdAveragedProjectionsWithActuals_seasonal_dl$points[which(crowdAveragedProjectionsWithActuals_seasonal_dl$player_id_season %in% playersWithHighProjectedOrActualPoints)],
  actual = crowdAveragedProjectionsWithActuals_seasonal_dl$fantasyPoints[which(crowdAveragedProjectionsWithActuals_seasonal_dl$player_id_season %in% playersWithHighProjectedOrActualPoints)],
  dropUndefined = TRUE
)
```

```{r}
#| include: false

accuracyIndices_seasonal_dl_crowd_subset <- petersenlab::accuracyOverall(
  predicted = crowdAveragedProjectionsWithActuals_seasonal_dl$points[which(crowdAveragedProjectionsWithActuals_seasonal_dl$player_id_season %in% playersWithHighProjectedOrActualPoints)],
  actual = crowdAveragedProjectionsWithActuals_seasonal_dl$fantasyPoints[which(crowdAveragedProjectionsWithActuals_seasonal_dl$player_id_season %in% playersWithHighProjectedOrActualPoints)],
  dropUndefined = TRUE
)

rsquare_seasonal_dl_crowd_subset <- round(accuracyIndices_seasonal_dl_crowd_subset$rsquared, digits = 2)
me_seasonal_dl_crowd_subset <- round(accuracyIndices_seasonal_dl_crowd_subset$ME, digits = 2)
mae_seasonal_dl_crowd_subset <- round(accuracyIndices_seasonal_dl_crowd_subset$MAE, digits = 2)
```

#### Linebackers {#sec-accuracyProjectionsSeasonalLB}

Here are the seasonal accuracy indexes for all Linebackers:

```{r}
petersenlab::accuracyOverall(
  predicted = projectionsWithActuals_seasonal_lb$raw_points,
  actual = projectionsWithActuals_seasonal_lb$fantasyPoints,
  dropUndefined = TRUE
)
```

```{r}
#| include: false

accuracyIndices_seasonal_lb <- petersenlab::accuracyOverall(
  predicted = projectionsWithActuals_seasonal_lb$raw_points,
  actual = projectionsWithActuals_seasonal_lb$fantasyPoints,
  dropUndefined = TRUE
)

rsquare_seasonal_lb <- round(accuracyIndices_seasonal_lb$rsquared, digits = 2)
me_seasonal_lb <- round(accuracyIndices_seasonal_lb$ME, digits = 2)
mae_seasonal_lb <- round(accuracyIndices_seasonal_lb$MAE, digits = 2)
```

A calibration plot of the seasonal projections for Linebackers is in @fig-calibrationPlotSeasonalLBs.

```{r}
#| label: fig-calibrationPlotSeasonalLBs
#| fig-cap: "Calibration Plot for Seasonal Projections of Linebackers. The diagonal black line is the reference line representing perfect calibration. The yellow line is the best-fit line based on a locally estimated scatterplot smoothing (LOESS) model. The purple band is the 95% confidence interval of actual fantasy points. The dashed red lines are the 95% prediction interval of actual fantasy points."
#| fig-alt: "Calibration Plot for Seasonal Projections of Linebackers. The diagonal black line is the reference line representing perfect calibration. The yellow line is the best-fit line based on a locally estimated scatterplot smoothing (LOESS) model. The purple band is the 95% confidence interval of actual fantasy points. The dashed red lines are the 95% prediction interval of actual fantasy points."
#| fig-width: 8
#| fig-height: 6

#95 prediction interval based on LOESS model
calibrationLoessModel <- msir::loess.sd(
  x = projectionsWithActuals_seasonal_lb$raw_points,
  y = projectionsWithActuals_seasonal_lb$fantasyPoints,
  nsigma = qnorm(.975),
  na.action = "na.exclude")

calibrationLoessPredictionInterval <- data.frame(
  x = calibrationLoessModel$x,
  y = calibrationLoessModel$y,
  lower = calibrationLoessModel$lower,
  upper = calibrationLoessModel$upper)

plotRangeMin <- min(calibrationLoessModel$lower, na.rm = TRUE)

plotRangeMax <- max(calibrationLoessModel$upper, na.rm = TRUE)

ggplot2::ggplot(
  data = projectionsWithActuals_seasonal_lb,
  aes(
    x = raw_points,
    y = fantasyPoints)) + 
  coord_cartesian(
    xlim = c(0, plotRangeMax),
    ylim = c(plotRangeMin, plotRangeMax),
    expand = FALSE) +
  scale_x_continuous(breaks = seq(0, plotRangeMax, by = 20)) +
  scale_y_continuous(breaks = seq(0, plotRangeMax, by = 20)) +
  geom_line(
    data = calibrationLoessPredictionInterval,
    aes(
      x = x,
      y = lower),
    color = "red",
    linetype = "dashed") + #Lower estimate of 95% prediction interval of linear model
  geom_line(
    data = calibrationLoessPredictionInterval,
    aes(
      x = x,
      y = upper),
    color = "red",
    linetype = "dashed") + #Upper estimate of 95% prediction interval of linear model
  geom_smooth(
    method = "loess",
    color = viridisLite::viridis(3)[3],
    fill = viridisLite::viridis(3)[1],
    alpha = 0.7) + #95% confidence interval of LOESS model
  geom_abline(
    slope = 1,
    intercept = 0) +
  labs(
    x = "Projected Fantasy Points",
    y = "Actual Fantasy Points",
    title = "Calibration Plot for Seasonal Projections of Linebackers"
  ) +
  theme_classic() + 
  theme(axis.title.y = element_text(angle = 0, vjust = 0.5)) # horizontal y-axis title
```

Here are the seasonal accuracy indexes for only those Linebackers who had high projected or actual points (i.e., players who had more than 100 projected or actual points; the players that are most important to differentiate between):

```{r}
petersenlab::accuracyOverall(
  predicted = projectionsWithActuals_seasonal_lb$raw_points[which(projectionsWithActuals_seasonal$player_id_season %in% playersWithHighProjectedOrActualPoints)],
  actual = projectionsWithActuals_seasonal_lb$fantasyPoints[which(projectionsWithActuals_seasonal$player_id_season %in% playersWithHighProjectedOrActualPoints)],
  dropUndefined = TRUE
)
```

```{r}
#| include: false

accuracyIndices_seasonal_lb_subset <- petersenlab::accuracyOverall(
  predicted = projectionsWithActuals_seasonal_lb$raw_points[which(projectionsWithActuals_seasonal$player_id_season %in% playersWithHighProjectedOrActualPoints)],
  actual = projectionsWithActuals_seasonal_lb$fantasyPoints[which(projectionsWithActuals_seasonal$player_id_season %in% playersWithHighProjectedOrActualPoints)],
  dropUndefined = TRUE
)

rsquare_seasonal_lb_subset <- round(accuracyIndices_seasonal_lb_subset$rsquared, digits = 2)
me_seasonal_lb_subset <- round(accuracyIndices_seasonal_lb_subset$ME, digits = 2)
mae_seasonal_lb_subset <- round(accuracyIndices_seasonal_lb_subset$MAE, digits = 2)
```

Here are the seasonal accuracy indexes for crowd-averaged projections for Linebackers:

```{r}
petersenlab::accuracyOverall(
  predicted = crowdAveragedProjectionsWithActuals_seasonal_lb$points,
  actual = crowdAveragedProjectionsWithActuals_seasonal_lb$fantasyPoints,
  dropUndefined = TRUE
)
```

```{r}
#| include: false

accuracyIndices_seasonal_lb_crowd <- petersenlab::accuracyOverall(
  predicted = crowdAveragedProjectionsWithActuals_seasonal_lb$points,
  actual = crowdAveragedProjectionsWithActuals_seasonal_lb$fantasyPoints,
  dropUndefined = TRUE
)

rsquare_seasonal_lb_crowd <- round(accuracyIndices_seasonal_lb_crowd$rsquared, digits = 2)
me_seasonal_lb_crowd <- round(accuracyIndices_seasonal_lb_crowd$ME, digits = 2)
mae_seasonal_lb_crowd <- round(accuracyIndices_seasonal_lb_crowd$MAE, digits = 2)
```

Here are the seasonal accuracy indexes for crowd-averaged projections of Linebackers, but only among those who had high projected or actual points (i.e., players who had more than 100 projected or actual points; the players that are most important to differentiate between):

```{r}
petersenlab::accuracyOverall(
  predicted = crowdAveragedProjectionsWithActuals_seasonal_lb$points[which(crowdAveragedProjectionsWithActuals_seasonal_lb$player_id_season %in% playersWithHighProjectedOrActualPoints)],
  actual = crowdAveragedProjectionsWithActuals_seasonal_lb$fantasyPoints[which(crowdAveragedProjectionsWithActuals_seasonal_lb$player_id_season %in% playersWithHighProjectedOrActualPoints)],
  dropUndefined = TRUE
)
```

```{r}
#| include: false

accuracyIndices_seasonal_lb_crowd_subset <- petersenlab::accuracyOverall(
  predicted = crowdAveragedProjectionsWithActuals_seasonal_lb$points[which(crowdAveragedProjectionsWithActuals_seasonal_lb$player_id_season %in% playersWithHighProjectedOrActualPoints)],
  actual = crowdAveragedProjectionsWithActuals_seasonal_lb$fantasyPoints[which(crowdAveragedProjectionsWithActuals_seasonal_lb$player_id_season %in% playersWithHighProjectedOrActualPoints)],
  dropUndefined = TRUE
)

rsquare_seasonal_lb_crowd_subset <- round(accuracyIndices_seasonal_lb_crowd_subset$rsquared, digits = 2)
me_seasonal_lb_crowd_subset <- round(accuracyIndices_seasonal_lb_crowd_subset$ME, digits = 2)
mae_seasonal_lb_crowd_subset <- round(accuracyIndices_seasonal_lb_crowd_subset$MAE, digits = 2)
```

#### Defensive Backs {#sec-accuracyProjectionsSeasonalDB}

Here are the seasonal accuracy indexes for all Defensive Backs:

```{r}
petersenlab::accuracyOverall(
  predicted = projectionsWithActuals_seasonal_db$raw_points,
  actual = projectionsWithActuals_seasonal_db$fantasyPoints,
  dropUndefined = TRUE
)
```

```{r}
#| include: false

accuracyIndices_seasonal_db <- petersenlab::accuracyOverall(
  predicted = projectionsWithActuals_seasonal_db$raw_points,
  actual = projectionsWithActuals_seasonal_db$fantasyPoints,
  dropUndefined = TRUE
)

rsquare_seasonal_db <- round(accuracyIndices_seasonal_db$rsquared, digits = 2)
me_seasonal_db <- round(accuracyIndices_seasonal_db$ME, digits = 2)
mae_seasonal_db <- round(accuracyIndices_seasonal_db$MAE, digits = 2)
```

A calibration plot of the seasonal projections for Defensive backs is in @fig-calibrationPlotSeasonalDBs.

```{r}
#| label: fig-calibrationPlotSeasonalDBs
#| fig-cap: "Calibration Plot for Seasonal Projections of Defensive Backs. The diagonal black line is the reference line representing perfect calibration. The yellow line is the best-fit line based on a locally estimated scatterplot smoothing (LOESS) model. The purple band is the 95% confidence interval of actual fantasy points. The dashed red lines are the 95% prediction interval of actual fantasy points."
#| fig-alt: "Calibration Plot for Seasonal Projections of Defensive Backs. The diagonal black line is the reference line representing perfect calibration. The yellow line is the best-fit line based on a locally estimated scatterplot smoothing (LOESS) model. The purple band is the 95% confidence interval of actual fantasy points. The dashed red lines are the 95% prediction interval of actual fantasy points."
#| fig-width: 8
#| fig-height: 6

#95 prediction interval based on LOESS model
calibrationLoessModel <- msir::loess.sd(
  x = projectionsWithActuals_seasonal_db$raw_points,
  y = projectionsWithActuals_seasonal_db$fantasyPoints,
  nsigma = qnorm(.975),
  na.action = "na.exclude")

calibrationLoessPredictionInterval <- data.frame(
  x = calibrationLoessModel$x,
  y = calibrationLoessModel$y,
  lower = calibrationLoessModel$lower,
  upper = calibrationLoessModel$upper)

plotRangeMin <- min(calibrationLoessModel$lower, na.rm = TRUE)

plotRangeMax <- max(calibrationLoessModel$upper, na.rm = TRUE)

ggplot2::ggplot(
  data = projectionsWithActuals_seasonal_db,
  aes(
    x = raw_points,
    y = fantasyPoints)) + 
  coord_cartesian(
    xlim = c(0, plotRangeMax),
    ylim = c(plotRangeMin, plotRangeMax),
    expand = FALSE) +
  scale_x_continuous(breaks = seq(0, plotRangeMax, by = 20)) +
  scale_y_continuous(breaks = seq(0, plotRangeMax, by = 20)) +
  geom_line(
    data = calibrationLoessPredictionInterval,
    aes(
      x = x,
      y = lower),
    color = "red",
    linetype = "dashed") + #Lower estimate of 95% prediction interval of linear model
  geom_line(
    data = calibrationLoessPredictionInterval,
    aes(
      x = x,
      y = upper),
    color = "red",
    linetype = "dashed") + #Upper estimate of 95% prediction interval of linear model
  geom_smooth(
    method = "loess",
    color = viridisLite::viridis(3)[3],
    fill = viridisLite::viridis(3)[1],
    alpha = 0.7) + #95% confidence interval of LOESS model
  geom_abline(
    slope = 1,
    intercept = 0) +
  labs(
    x = "Projected Fantasy Points",
    y = "Actual Fantasy Points",
    title = "Calibration Plot for Seasonal Projections of Defensive Backs"
  ) +
  theme_classic() + 
  theme(axis.title.y = element_text(angle = 0, vjust = 0.5)) # horizontal y-axis title
```

Here are the seasonal accuracy indexes for only those Defensive Backs who had high projected or actual points (i.e., players who had more than 100 projected or actual points; the players that are most important to differentiate between):

```{r}
petersenlab::accuracyOverall(
  predicted = projectionsWithActuals_seasonal_db$raw_points[which(projectionsWithActuals_seasonal$player_id_season %in% playersWithHighProjectedOrActualPoints)],
  actual = projectionsWithActuals_seasonal_db$fantasyPoints[which(projectionsWithActuals_seasonal$player_id_season %in% playersWithHighProjectedOrActualPoints)],
  dropUndefined = TRUE
)
```

```{r}
#| include: false

accuracyIndices_seasonal_db_subset <- petersenlab::accuracyOverall(
  predicted = projectionsWithActuals_seasonal_db$raw_points[which(projectionsWithActuals_seasonal$player_id_season %in% playersWithHighProjectedOrActualPoints)],
  actual = projectionsWithActuals_seasonal_db$fantasyPoints[which(projectionsWithActuals_seasonal$player_id_season %in% playersWithHighProjectedOrActualPoints)],
  dropUndefined = TRUE
)

rsquare_seasonal_db_subset <- round(accuracyIndices_seasonal_db_subset$rsquared, digits = 2)
me_seasonal_db_subset <- round(accuracyIndices_seasonal_db_subset$ME, digits = 2)
mae_seasonal_db_subset <- round(accuracyIndices_seasonal_db_subset$MAE, digits = 2)
```

Here are the seasonal accuracy indexes for crowd-averaged projections for Defensive Backs:

```{r}
petersenlab::accuracyOverall(
  predicted = crowdAveragedProjectionsWithActuals_seasonal_db$points,
  actual = crowdAveragedProjectionsWithActuals_seasonal_db$fantasyPoints,
  dropUndefined = TRUE
)
```

```{r}
#| include: false

accuracyIndices_seasonal_db_crowd <- petersenlab::accuracyOverall(
  predicted = crowdAveragedProjectionsWithActuals_seasonal_db$points,
  actual = crowdAveragedProjectionsWithActuals_seasonal_db$fantasyPoints,
  dropUndefined = TRUE
)

rsquare_seasonal_db_crowd <- round(accuracyIndices_seasonal_db_crowd$rsquared, digits = 2)
me_seasonal_db_crowd <- round(accuracyIndices_seasonal_db_crowd$ME, digits = 2)
mae_seasonal_db_crowd <- round(accuracyIndices_seasonal_db_crowd$MAE, digits = 2)
```

Here are the seasonal accuracy indexes for crowd-averaged projections of Defensive Backs, but only among those who had high projected or actual points (i.e., players who had more than 100 projected or actual points; the players that are most important to differentiate between):

```{r}
petersenlab::accuracyOverall(
  predicted = crowdAveragedProjectionsWithActuals_seasonal_db$points[which(crowdAveragedProjectionsWithActuals_seasonal_db$player_id_season %in% playersWithHighProjectedOrActualPoints)],
  actual = crowdAveragedProjectionsWithActuals_seasonal_db$fantasyPoints[which(crowdAveragedProjectionsWithActuals_seasonal_db$player_id_season %in% playersWithHighProjectedOrActualPoints)],
  dropUndefined = TRUE
)
```

```{r}
#| include: false

accuracyIndices_seasonal_db_crowd_subset <- petersenlab::accuracyOverall(
  predicted = crowdAveragedProjectionsWithActuals_seasonal_db$points[which(crowdAveragedProjectionsWithActuals_seasonal_db$player_id_season %in% playersWithHighProjectedOrActualPoints)],
  actual = crowdAveragedProjectionsWithActuals_seasonal_db$fantasyPoints[which(crowdAveragedProjectionsWithActuals_seasonal_db$player_id_season %in% playersWithHighProjectedOrActualPoints)],
  dropUndefined = TRUE
)

rsquare_seasonal_db_crowd_subset <- round(accuracyIndices_seasonal_db_crowd_subset$rsquared, digits = 2)
me_seasonal_db_crowd_subset <- round(accuracyIndices_seasonal_db_crowd_subset$ME, digits = 2)
mae_seasonal_db_crowd_subset <- round(accuracyIndices_seasonal_db_crowd_subset$MAE, digits = 2)
```

### Weekly Projections {#sec-accuracyProjectionsWeekly}

#### Overall {#sec-accuracyProjectionsWeeklyOverall}

Here are the weekly accuracy indexes for all players (across all positions):

```{r}
petersenlab::accuracyOverall(
  predicted = projectionsWithActuals_weekly$raw_points,
  actual = projectionsWithActuals_weekly$fantasyPoints,
  dropUndefined = TRUE
)
```

```{r}
#| include: false

accuracyIndices_weekly_overall <- petersenlab::accuracyOverall(
  predicted = projectionsWithActuals_weekly$raw_points,
  actual = projectionsWithActuals_weekly$fantasyPoints,
  dropUndefined = TRUE
)

rsquare_weekly_overall <- round(accuracyIndices_weekly_overall$rsquared, digits = 2)
me_weekly_overall <- round(accuracyIndices_weekly_overall$ME, digits = 2)
mae_weekly_overall <- round(accuracyIndices_weekly_overall$MAE, digits = 2)
```

A calibration plot of the weekly projections for all players (across all positions) is in @fig-calibrationPlotWeeklyOverall.

```{r}
#| label: fig-calibrationPlotWeeklyOverall
#| fig-cap: "Calibration Plot for Weekly Projections. The diagonal black line is the reference line representing perfect calibration. The yellow line is the best-fit line based on a generalized additive model. The purple band is the 95% confidence interval of actual fantasy points. The dashed red lines are the 95% prediction interval of actual fantasy points based on a locally estimated scatterplot smoothing (LOESS) model."
#| fig-alt: "Calibration Plot for Weekly Projections. The diagonal black line is the reference line representing perfect calibration. The yellow line is the best-fit line based on a generalized additive model. The purple band is the 95% confidence interval of actual fantasy points. The dashed red lines are the 95% prediction interval of actual fantasy points based on a locally estimated scatterplot smoothing (LOESS) model."
#| fig-width: 8
#| fig-height: 6

#95 prediction interval based on LOESS model
calibrationLoessModel <- msir::loess.sd(
  x = projectionsWithActuals_weekly$raw_points,
  y = projectionsWithActuals_weekly$fantasyPoints,
  nsigma = qnorm(.975),
  na.action = "na.exclude")

calibrationLoessPredictionInterval <- data.frame(
  x = calibrationLoessModel$x,
  y = calibrationLoessModel$y,
  lower = calibrationLoessModel$lower,
  upper = calibrationLoessModel$upper)

plotRangeMin <- min(calibrationLoessModel$lower, na.rm = TRUE)

plotRangeMax <- max(calibrationLoessModel$upper, na.rm = TRUE)

ggplot2::ggplot(
  data = projectionsWithActuals_weekly,
  aes(
    x = raw_points,
    y = fantasyPoints)) + 
  coord_cartesian(
    xlim = c(0, plotRangeMax),
    ylim = c(plotRangeMin, plotRangeMax),
    expand = FALSE) +
  scale_x_continuous(breaks = seq(0, plotRangeMax, by = 5)) +
  scale_y_continuous(breaks = seq(0, plotRangeMax, by = 5)) +
  geom_line(
    data = calibrationLoessPredictionInterval,
    aes(
      x = x,
      y = lower),
    color = "red",
    linetype = "dashed") + #Lower estimate of 95% prediction interval of linear model
  geom_line(
    data = calibrationLoessPredictionInterval,
    aes(
      x = x,
      y = upper),
    color = "red",
    linetype = "dashed") + #Upper estimate of 95% prediction interval of linear model
  geom_smooth(
    method = "gam",
    color = viridisLite::viridis(3)[3],
    fill = viridisLite::viridis(3)[1],
    alpha = 0.7) + #95% confidence interval of GAM model
  geom_abline(
    slope = 1,
    intercept = 0) +
  labs(
    x = "Projected Fantasy Points",
    y = "Actual Fantasy Points",
    title = "Calibration Plot for Weekly Projections"
  ) +
  theme_classic() + 
  theme(axis.title.y = element_text(angle = 0, vjust = 0.5)) # horizontal y-axis title
```

Here are the weekly accuracy indexes for players across all positions, but only among those who had high projected or actual points (i.e., players who had more than 6 projected or actual points; the players that are most important to differentiate between):

```{r}
petersenlab::accuracyOverall(
  predicted = projectionsWithActuals_weekly$raw_points[which(projectionsWithActuals_weekly$player_id_season_week %in% playersWithHighProjectedOrActualPoints_weekly)],
  actual = projectionsWithActuals_weekly$fantasyPoints[which(projectionsWithActuals_weekly$player_id_season_week %in% playersWithHighProjectedOrActualPoints_weekly)],
  dropUndefined = TRUE
)
```

```{r}
#| include: false

accuracyIndices_weekly_overall_subset <- petersenlab::accuracyOverall(
  predicted = projectionsWithActuals_weekly$raw_points[which(projectionsWithActuals_weekly$player_id_season_week %in% playersWithHighProjectedOrActualPoints_weekly)],
  actual = projectionsWithActuals_weekly$fantasyPoints[which(projectionsWithActuals_weekly$player_id_season_week %in% playersWithHighProjectedOrActualPoints_weekly)],
  dropUndefined = TRUE
)

rsquare_weekly_overall_subset <- round(accuracyIndices_weekly_overall_subset$rsquared, digits = 2)
me_weekly_overall_subset <- round(accuracyIndices_weekly_overall_subset$ME, digits = 2)
mae_weekly_overall_subset <- round(accuracyIndices_weekly_overall_subset$MAE, digits = 2)
```

Here are the weekly accuracy indexes for crowd-averaged projections of all players (across all positions):

```{r}
petersenlab::accuracyOverall(
  predicted = crowdAveragedProjectionsWithActuals_weekly$points,
  actual = crowdAveragedProjectionsWithActuals_weekly$fantasyPoints,
  dropUndefined = TRUE
)
```

```{r}
#| include: false

accuracyIndices_weekly_overall_crowd <- petersenlab::accuracyOverall(
  predicted = crowdAveragedProjectionsWithActuals_weekly$points,
  actual = crowdAveragedProjectionsWithActuals_weekly$fantasyPoints,
  dropUndefined = TRUE
)

rsquare_weekly_overall_crowd <- round(accuracyIndices_weekly_overall_crowd$rsquared, digits = 2)
me_weekly_overall_crowd <- round(accuracyIndices_weekly_overall_crowd$ME, digits = 2)
mae_weekly_overall_crowd <- round(accuracyIndices_weekly_overall_crowd$MAE, digits = 2)
```

Here are the weekly accuracy indexes for crowd-averaged projections of players across all positions, but only among those who had high projected or actual points (i.e., players who had more than 6 projected or actual points; the players that are most important to differentiate between):

```{r}
petersenlab::accuracyOverall(
  predicted = crowdAveragedProjectionsWithActuals_weekly$points[which(crowdAveragedProjectionsWithActuals_weekly$player_id_season_week %in% playersWithHighProjectedOrActualPoints_weekly)],
  actual = crowdAveragedProjectionsWithActuals_weekly$fantasyPoints[which(crowdAveragedProjectionsWithActuals_weekly$player_id_season_week %in% playersWithHighProjectedOrActualPoints_weekly)],
  dropUndefined = TRUE
)
```

```{r}
#| include: false

accuracyIndices_weekly_overall_crowd_subset <- petersenlab::accuracyOverall(
  predicted = crowdAveragedProjectionsWithActuals_weekly$points[which(crowdAveragedProjectionsWithActuals_weekly$player_id_season_week %in% playersWithHighProjectedOrActualPoints_weekly)],
  actual = crowdAveragedProjectionsWithActuals_weekly$fantasyPoints[which(crowdAveragedProjectionsWithActuals_weekly$player_id_season_week %in% playersWithHighProjectedOrActualPoints_weekly)],
  dropUndefined = TRUE
)

rsquare_weekly_overall_crowd_subset <- round(accuracyIndices_weekly_overall_crowd_subset$rsquared, digits = 2)
me_weekly_overall_crowd_subset <- round(accuracyIndices_weekly_overall_crowd_subset$ME, digits = 2)
mae_weekly_overall_crowd_subset <- round(accuracyIndices_weekly_overall_crowd_subset$MAE, digits = 2)
```

#### Quarterbacks {#sec-accuracyProjectionsWeeklyQB}

Here are the weekly accuracy indexes for all Quarterbacks:

```{r}
petersenlab::accuracyOverall(
  predicted = projectionsWithActuals_weekly_qb$raw_points,
  actual = projectionsWithActuals_weekly_qb$fantasyPoints,
  dropUndefined = TRUE
)
```

```{r}
#| include: false

accuracyIndices_weekly_qb <- petersenlab::accuracyOverall(
  predicted = projectionsWithActuals_weekly_qb$raw_points,
  actual = projectionsWithActuals_weekly_qb$fantasyPoints,
  dropUndefined = TRUE
)

rsquare_weekly_qb <- round(accuracyIndices_weekly_qb$rsquared, digits = 2)
me_weekly_qb <- round(accuracyIndices_weekly_qb$ME, digits = 2)
mae_weekly_qb <- round(accuracyIndices_weekly_qb$MAE, digits = 2)
```

A calibration plot of the weekly projections for Quarterbacks is in @fig-calibrationPlotWeeklyQBs.

```{r}
#| label: fig-calibrationPlotWeeklyQBs
#| fig-cap: "Calibration Plot for Weekly Projections of Quarterbacks. The diagonal black line is the reference line representing perfect calibration. The yellow line is the best-fit line based on a generalized additive model. The purple band is the 95% confidence interval of actual fantasy points. The dashed red lines are the 95% prediction interval of actual fantasy points based on a locally estimated scatterplot smoothing (LOESS) model."
#| fig-alt: "Calibration Plot for Weekly Projections of Quarterbacks. The diagonal black line is the reference line representing perfect calibration. The yellow line is the best-fit line based on a generalized additive model. The purple band is the 95% confidence interval of actual fantasy points. The dashed red lines are the 95% prediction interval of actual fantasy points based on a locally estimated scatterplot smoothing (LOESS) model."
#| fig-width: 8
#| fig-height: 6

#95 prediction interval based on LOESS model
calibrationLoessModel <- msir::loess.sd(
  x = projectionsWithActuals_weekly_qb$raw_points,
  y = projectionsWithActuals_weekly_qb$fantasyPoints,
  nsigma = qnorm(.975),
  na.action = "na.exclude")

calibrationLoessPredictionInterval <- data.frame(
  x = calibrationLoessModel$x,
  y = calibrationLoessModel$y,
  lower = calibrationLoessModel$lower,
  upper = calibrationLoessModel$upper)

plotRangeMin <- min(calibrationLoessModel$lower, na.rm = TRUE)

plotRangeMax <- max(calibrationLoessModel$upper, na.rm = TRUE)

ggplot2::ggplot(
  data = projectionsWithActuals_weekly_qb,
  aes(
    x = raw_points,
    y = fantasyPoints)) + 
  coord_cartesian(
    xlim = c(0, plotRangeMax),
    ylim = c(plotRangeMin, plotRangeMax),
    expand = FALSE) +
  scale_x_continuous(breaks = seq(0, plotRangeMax, by = 5)) +
  scale_y_continuous(breaks = seq(0, plotRangeMax, by = 5)) +
  geom_line(
    data = calibrationLoessPredictionInterval,
    aes(
      x = x,
      y = lower),
    color = "red",
    linetype = "dashed") + #Lower estimate of 95% prediction interval of linear model
  geom_line(
    data = calibrationLoessPredictionInterval,
    aes(
      x = x,
      y = upper),
    color = "red",
    linetype = "dashed") + #Upper estimate of 95% prediction interval of linear model
  geom_smooth(
    method = "gam",
    color = viridisLite::viridis(3)[3],
    fill = viridisLite::viridis(3)[1],
    alpha = 0.7) + #95% confidence interval of GAM model
  geom_abline(
    slope = 1,
    intercept = 0) +
  labs(
    x = "Projected Fantasy Points",
    y = "Actual Fantasy Points",
    title = "Calibration Plot for Weekly Projections of Quarterbacks"
  ) +
  theme_classic() + 
  theme(axis.title.y = element_text(angle = 0, vjust = 0.5)) # horizontal y-axis title
```

Here are the weekly accuracy indexes for only those Quarterbacks who had high projected or actual points (i.e., players who had more than 6 projected or actual points; the players that are most important to differentiate between):

```{r}
petersenlab::accuracyOverall(
  predicted = projectionsWithActuals_weekly_qb$raw_points[which(projectionsWithActuals_weekly$player_id_season_week %in% playersWithHighProjectedOrActualPoints_weekly)],
  actual = projectionsWithActuals_weekly_qb$fantasyPoints[which(projectionsWithActuals_weekly$player_id_season_week %in% playersWithHighProjectedOrActualPoints_weekly)],
  dropUndefined = TRUE
)
```

```{r}
#| include: false

accuracyIndices_weekly_qb_subset <- petersenlab::accuracyOverall(
  predicted = projectionsWithActuals_weekly_qb$raw_points[which(projectionsWithActuals_weekly$player_id_season_week %in% playersWithHighProjectedOrActualPoints_weekly)],
  actual = projectionsWithActuals_weekly_qb$fantasyPoints[which(projectionsWithActuals_weekly$player_id_season_week %in% playersWithHighProjectedOrActualPoints_weekly)],
  dropUndefined = TRUE
)

rsquare_weekly_qb_subset <- round(accuracyIndices_weekly_qb_subset$rsquared, digits = 2)
me_weekly_qb_subset <- round(accuracyIndices_weekly_qb_subset$ME, digits = 2)
mae_weekly_qb_subset <- round(accuracyIndices_weekly_qb_subset$MAE, digits = 2)
```

Here are the weekly accuracy indexes for crowd-averaged projections of Quarterbacks:

```{r}
petersenlab::accuracyOverall(
  predicted = crowdAveragedProjectionsWithActuals_weekly_qb$points,
  actual = crowdAveragedProjectionsWithActuals_weekly_qb$fantasyPoints,
  dropUndefined = TRUE
)
```

```{r}
#| include: false

accuracyIndices_weekly_qb_crowd <- petersenlab::accuracyOverall(
  predicted = crowdAveragedProjectionsWithActuals_weekly_qb$points,
  actual = crowdAveragedProjectionsWithActuals_weekly_qb$fantasyPoints,
  dropUndefined = TRUE
)

rsquare_weekly_qb_crowd <- round(accuracyIndices_weekly_qb_crowd$rsquared, digits = 2)
me_weekly_qb_crowd <- round(accuracyIndices_weekly_qb_crowd$ME, digits = 2)
mae_weekly_qb_crowd <- round(accuracyIndices_weekly_qb_crowd$MAE, digits = 2)
```

Here are the weekly accuracy indexes for crowd-averaged projections of Quarterbacks, but only among those who had high projected or actual points (i.e., players who had more than 6 projected or actual points; the players that are most important to differentiate between):

```{r}
petersenlab::accuracyOverall(
  predicted = crowdAveragedProjectionsWithActuals_weekly_qb$points[which(crowdAveragedProjectionsWithActuals_weekly_qb$player_id_season_week %in% playersWithHighProjectedOrActualPoints_weekly)],
  actual = crowdAveragedProjectionsWithActuals_weekly_qb$fantasyPoints[which(crowdAveragedProjectionsWithActuals_weekly_qb$player_id_season_week %in% playersWithHighProjectedOrActualPoints_weekly)],
  dropUndefined = TRUE
)
```

```{r}
#| include: false

accuracyIndices_weekly_qb_crowd_subset <- petersenlab::accuracyOverall(
  predicted = crowdAveragedProjectionsWithActuals_weekly_qb$points[which(crowdAveragedProjectionsWithActuals_weekly_qb$player_id_season_week %in% playersWithHighProjectedOrActualPoints_weekly)],
  actual = crowdAveragedProjectionsWithActuals_weekly_qb$fantasyPoints[which(crowdAveragedProjectionsWithActuals_weekly_qb$player_id_season_week %in% playersWithHighProjectedOrActualPoints_weekly)],
  dropUndefined = TRUE
)

rsquare_weekly_qb_crowd_subset <- round(accuracyIndices_weekly_qb_crowd_subset$rsquared, digits = 2)
me_weekly_qb_crowd_subset <- round(accuracyIndices_weekly_qb_crowd_subset$ME, digits = 2)
mae_weekly_qb_crowd_subset <- round(accuracyIndices_weekly_qb_crowd_subset$MAE, digits = 2)
```

#### Running Backs {#sec-accuracyProjectionsWeeklyRB}

Here are the weekly accuracy indexes for all Running Backs:

```{r}
petersenlab::accuracyOverall(
  predicted = projectionsWithActuals_weekly_rb$raw_points,
  actual = projectionsWithActuals_weekly_rb$fantasyPoints,
  dropUndefined = TRUE
)
```

```{r}
#| include: false

accuracyIndices_weekly_rb <- petersenlab::accuracyOverall(
  predicted = projectionsWithActuals_weekly_rb$raw_points,
  actual = projectionsWithActuals_weekly_rb$fantasyPoints,
  dropUndefined = TRUE
)

rsquare_weekly_rb <- round(accuracyIndices_weekly_rb$rsquared, digits = 2)
me_weekly_rb <- round(accuracyIndices_weekly_rb$ME, digits = 2)
mae_weekly_rb <- round(accuracyIndices_weekly_rb$MAE, digits = 2)
```

A calibration plot of the weekly projections for Running Backs is in @fig-calibrationPlotWeeklyRBs.

```{r}
#| label: fig-calibrationPlotWeeklyRBs
#| fig-cap: "Calibration Plot for Weekly Projections of Running Backs. The diagonal black line is the reference line representing perfect calibration. The yellow line is the best-fit line based on a generalized additive model. The purple band is the 95% confidence interval of actual fantasy points. The dashed red lines are the 95% prediction interval of actual fantasy points based on a locally estimated scatterplot smoothing (LOESS) model."
#| fig-alt: "Calibration Plot for Weekly Projections of Running Backs. The diagonal black line is the reference line representing perfect calibration. The yellow line is the best-fit line based on a generalized additive model. The purple band is the 95% confidence interval of actual fantasy points. The dashed red lines are the 95% prediction interval of actual fantasy points based on a locally estimated scatterplot smoothing (LOESS) model."
#| fig-width: 8
#| fig-height: 6

#95 prediction interval based on LOESS model
calibrationLoessModel <- msir::loess.sd(
  x = projectionsWithActuals_weekly_rb$raw_points,
  y = projectionsWithActuals_weekly_rb$fantasyPoints,
  nsigma = qnorm(.975),
  na.action = "na.exclude")

calibrationLoessPredictionInterval <- data.frame(
  x = calibrationLoessModel$x,
  y = calibrationLoessModel$y,
  lower = calibrationLoessModel$lower,
  upper = calibrationLoessModel$upper)

plotRangeMin <- min(calibrationLoessModel$lower, na.rm = TRUE)

plotRangeMax <- max(calibrationLoessModel$upper, na.rm = TRUE)

ggplot2::ggplot(
  data = projectionsWithActuals_weekly_rb,
  aes(
    x = raw_points,
    y = fantasyPoints)) + 
  coord_cartesian(
    xlim = c(0, plotRangeMax),
    ylim = c(plotRangeMin, plotRangeMax),
    expand = FALSE) +
  scale_x_continuous(breaks = seq(0, plotRangeMax, by = 5)) +
  scale_y_continuous(breaks = seq(0, plotRangeMax, by = 5)) +
  geom_line(
    data = calibrationLoessPredictionInterval,
    aes(
      x = x,
      y = lower),
    color = "red",
    linetype = "dashed") + #Lower estimate of 95% prediction interval of linear model
  geom_line(
    data = calibrationLoessPredictionInterval,
    aes(
      x = x,
      y = upper),
    color = "red",
    linetype = "dashed") + #Upper estimate of 95% prediction interval of linear model
  geom_smooth(
    method = "gam",
    color = viridisLite::viridis(3)[3],
    fill = viridisLite::viridis(3)[1],
    alpha = 0.7) + #95% confidence interval of GAM model
  geom_abline(
    slope = 1,
    intercept = 0) +
  labs(
    x = "Projected Fantasy Points",
    y = "Actual Fantasy Points",
    title = "Calibration Plot for Weekly Projections of Running Backs"
  ) +
  theme_classic() + 
  theme(axis.title.y = element_text(angle = 0, vjust = 0.5)) # horizontal y-axis title
```

Here are the weekly accuracy indexes for only those Running Backs who had high projected or actual points (i.e., players who had more than 6 projected or actual points; the players that are most important to differentiate between):

```{r}
petersenlab::accuracyOverall(
  predicted = projectionsWithActuals_weekly_rb$raw_points[which(projectionsWithActuals_weekly$player_id_season_week %in% playersWithHighProjectedOrActualPoints_weekly)],
  actual = projectionsWithActuals_weekly_rb$fantasyPoints[which(projectionsWithActuals_weekly$player_id_season_week %in% playersWithHighProjectedOrActualPoints_weekly)],
  dropUndefined = TRUE
)
```

```{r}
#| include: false

accuracyIndices_weekly_rb_subset <- petersenlab::accuracyOverall(
  predicted = projectionsWithActuals_weekly_rb$raw_points[which(projectionsWithActuals_weekly$player_id_season_week %in% playersWithHighProjectedOrActualPoints_weekly)],
  actual = projectionsWithActuals_weekly_rb$fantasyPoints[which(projectionsWithActuals_weekly$player_id_season_week %in% playersWithHighProjectedOrActualPoints_weekly)],
  dropUndefined = TRUE
)

rsquare_weekly_rb_subset <- round(accuracyIndices_weekly_rb_subset$rsquared, digits = 2)
me_weekly_rb_subset <- round(accuracyIndices_weekly_rb_subset$ME, digits = 2)
mae_weekly_rb_subset <- round(accuracyIndices_weekly_rb_subset$MAE, digits = 2)
```

Here are the weekly accuracy indexes for crowd-averaged projections of Running Backs:

```{r}
petersenlab::accuracyOverall(
  predicted = crowdAveragedProjectionsWithActuals_weekly_rb$points,
  actual = crowdAveragedProjectionsWithActuals_weekly_rb$fantasyPoints,
  dropUndefined = TRUE
)
```

```{r}
#| include: false

accuracyIndices_weekly_rb_crowd <- petersenlab::accuracyOverall(
  predicted = crowdAveragedProjectionsWithActuals_weekly_rb$points,
  actual = crowdAveragedProjectionsWithActuals_weekly_rb$fantasyPoints,
  dropUndefined = TRUE
)

rsquare_weekly_rb_crowd <- round(accuracyIndices_weekly_rb_crowd$rsquared, digits = 2)
me_weekly_rb_crowd <- round(accuracyIndices_weekly_rb_crowd$ME, digits = 2)
mae_weekly_rb_crowd <- round(accuracyIndices_weekly_rb_crowd$MAE, digits = 2)
```

Here are the weekly accuracy indexes for crowd-averaged projections of Running Backs, but only among those who had high projected or actual points (i.e., players who had more than 6 projected or actual points; the players that are most important to differentiate between):

```{r}
petersenlab::accuracyOverall(
  predicted = crowdAveragedProjectionsWithActuals_weekly_rb$points[which(crowdAveragedProjectionsWithActuals_weekly_rb$player_id_season_week %in% playersWithHighProjectedOrActualPoints_weekly)],
  actual = crowdAveragedProjectionsWithActuals_weekly_rb$fantasyPoints[which(crowdAveragedProjectionsWithActuals_weekly_rb$player_id_season_week %in% playersWithHighProjectedOrActualPoints_weekly)],
  dropUndefined = TRUE
)
```

```{r}
#| include: false

accuracyIndices_weekly_rb_crowd_subset <- petersenlab::accuracyOverall(
  predicted = crowdAveragedProjectionsWithActuals_weekly_rb$points[which(crowdAveragedProjectionsWithActuals_weekly_rb$player_id_season_week %in% playersWithHighProjectedOrActualPoints_weekly)],
  actual = crowdAveragedProjectionsWithActuals_weekly_rb$fantasyPoints[which(crowdAveragedProjectionsWithActuals_weekly_rb$player_id_season_week %in% playersWithHighProjectedOrActualPoints_weekly)],
  dropUndefined = TRUE
)

rsquare_weekly_rb_crowd_subset <- round(accuracyIndices_weekly_rb_crowd_subset$rsquared, digits = 2)
me_weekly_rb_crowd_subset <- round(accuracyIndices_weekly_rb_crowd_subset$ME, digits = 2)
mae_weekly_rb_crowd_subset <- round(accuracyIndices_weekly_rb_crowd_subset$MAE, digits = 2)
```

#### Wide Receivers {#sec-accuracyProjectionsWeeklyWR}

Here are the weekly accuracy indexes for all Wide Receivers:

```{r}
petersenlab::accuracyOverall(
  predicted = projectionsWithActuals_weekly_wr$raw_points,
  actual = projectionsWithActuals_weekly_wr$fantasyPoints,
  dropUndefined = TRUE
)
```


```{r}
#| include: false

accuracyIndices_weekly_wr <- petersenlab::accuracyOverall(
  predicted = projectionsWithActuals_weekly_wr$raw_points,
  actual = projectionsWithActuals_weekly_wr$fantasyPoints,
  dropUndefined = TRUE
)

rsquare_weekly_wr <- round(accuracyIndices_weekly_wr$rsquared, digits = 2)
me_weekly_wr <- round(accuracyIndices_weekly_wr$ME, digits = 2)
mae_weekly_wr <- round(accuracyIndices_weekly_wr$MAE, digits = 2)
```

A calibration plot of the weekly projections for Wide Receivers is in @fig-calibrationPlotWeeklyWRs.

```{r}
#| label: fig-calibrationPlotWeeklyWRs
#| fig-cap: "Calibration Plot for Weekly Projections of Wide Receivers. The diagonal black line is the reference line representing perfect calibration. The yellow line is the best-fit line based on a generalized additive model. The purple band is the 95% confidence interval of actual fantasy points. The dashed red lines are the 95% prediction interval of actual fantasy points based on a locally estimated scatterplot smoothing (LOESS) model."
#| fig-alt: "Calibration Plot for Weekly Projections of Wide Receivers. The diagonal black line is the reference line representing perfect calibration. The yellow line is the best-fit line based on a generalized additive model. The purple band is the 95% confidence interval of actual fantasy points. The dashed red lines are the 95% prediction interval of actual fantasy points based on a locally estimated scatterplot smoothing (LOESS) model."
#| fig-width: 8
#| fig-height: 6

#95 prediction interval based on LOESS model
calibrationLoessModel <- msir::loess.sd(
  x = projectionsWithActuals_weekly_wr$raw_points,
  y = projectionsWithActuals_weekly_wr$fantasyPoints,
  nsigma = qnorm(.975),
  na.action = "na.exclude")

calibrationLoessPredictionInterval <- data.frame(
  x = calibrationLoessModel$x,
  y = calibrationLoessModel$y,
  lower = calibrationLoessModel$lower,
  upper = calibrationLoessModel$upper)

plotRangeMin <- min(calibrationLoessModel$lower, na.rm = TRUE)

plotRangeMax <- max(calibrationLoessModel$upper, na.rm = TRUE)

ggplot2::ggplot(
  data = projectionsWithActuals_weekly_wr,
  aes(
    x = raw_points,
    y = fantasyPoints)) + 
  coord_cartesian(
    xlim = c(0, plotRangeMax),
    ylim = c(plotRangeMin, plotRangeMax),
    expand = FALSE) +
  scale_x_continuous(breaks = seq(0, plotRangeMax, by = 5)) +
  scale_y_continuous(breaks = seq(0, plotRangeMax, by = 5)) +
  geom_line(
    data = calibrationLoessPredictionInterval,
    aes(
      x = x,
      y = lower),
    color = "red",
    linetype = "dashed") + #Lower estimate of 95% prediction interval of linear model
  geom_line(
    data = calibrationLoessPredictionInterval,
    aes(
      x = x,
      y = upper),
    color = "red",
    linetype = "dashed") + #Upper estimate of 95% prediction interval of linear model
  geom_smooth(
    method = "gam",
    color = viridisLite::viridis(3)[3],
    fill = viridisLite::viridis(3)[1],
    alpha = 0.7) + #95% confidence interval of GAM model
  geom_abline(
    slope = 1,
    intercept = 0) +
  labs(
    x = "Projected Fantasy Points",
    y = "Actual Fantasy Points",
    title = "Calibration Plot for Weekly Projections of Wide Receivers"
  ) +
  theme_classic() + 
  theme(axis.title.y = element_text(angle = 0, vjust = 0.5)) # horizontal y-axis title
```

Here are the weekly accuracy indexes for only those Wide Receivers who had high projected or actual points (i.e., players who had more than 6 projected or actual points; the players that are most important to differentiate between):

```{r}
petersenlab::accuracyOverall(
  predicted = projectionsWithActuals_weekly_wr$raw_points[which(projectionsWithActuals_weekly$player_id_season_week %in% playersWithHighProjectedOrActualPoints_weekly)],
  actual = projectionsWithActuals_weekly_wr$fantasyPoints[which(projectionsWithActuals_weekly$player_id_season_week %in% playersWithHighProjectedOrActualPoints_weekly)],
  dropUndefined = TRUE
)
```

```{r}
#| include: false

accuracyIndices_weekly_wr_subset <- petersenlab::accuracyOverall(
  predicted = projectionsWithActuals_weekly_wr$raw_points[which(projectionsWithActuals_weekly$player_id_season_week %in% playersWithHighProjectedOrActualPoints_weekly)],
  actual = projectionsWithActuals_weekly_wr$fantasyPoints[which(projectionsWithActuals_weekly$player_id_season_week %in% playersWithHighProjectedOrActualPoints_weekly)],
  dropUndefined = TRUE
)

rsquare_weekly_wr_subset <- round(accuracyIndices_weekly_wr_subset$rsquared, digits = 2)
me_weekly_wr_subset <- round(accuracyIndices_weekly_wr_subset$ME, digits = 2)
mae_weekly_wr_subset <- round(accuracyIndices_weekly_wr_subset$MAE, digits = 2)
```

Here are the weekly accuracy indexes for crowd-averaged projections of Wide Receivers:

```{r}
petersenlab::accuracyOverall(
  predicted = crowdAveragedProjectionsWithActuals_weekly_wr$points,
  actual = crowdAveragedProjectionsWithActuals_weekly_wr$fantasyPoints,
  dropUndefined = TRUE
)
```

```{r}
#| include: false

accuracyIndices_weekly_wr_crowd <- petersenlab::accuracyOverall(
  predicted = crowdAveragedProjectionsWithActuals_weekly_wr$points,
  actual = crowdAveragedProjectionsWithActuals_weekly_wr$fantasyPoints,
  dropUndefined = TRUE
)

rsquare_weekly_wr_crowd <- round(accuracyIndices_weekly_wr_crowd$rsquared, digits = 2)
me_weekly_wr_crowd <- round(accuracyIndices_weekly_wr_crowd$ME, digits = 2)
mae_weekly_wr_crowd <- round(accuracyIndices_weekly_wr_crowd$MAE, digits = 2)
```

Here are the weekly accuracy indexes for crowd-averaged projections of Wide Receivers, but only among those who had high projected or actual points (i.e., players who had more than 6 projected or actual points; the players that are most important to differentiate between):

```{r}
petersenlab::accuracyOverall(
  predicted = crowdAveragedProjectionsWithActuals_weekly_wr$points[which(crowdAveragedProjectionsWithActuals_weekly_wr$player_id_season_week %in% playersWithHighProjectedOrActualPoints_weekly)],
  actual = crowdAveragedProjectionsWithActuals_weekly_wr$fantasyPoints[which(crowdAveragedProjectionsWithActuals_weekly_wr$player_id_season_week %in% playersWithHighProjectedOrActualPoints_weekly)],
  dropUndefined = TRUE
)
```

```{r}
#| include: false

accuracyIndices_weekly_wr_crowd_subset <- petersenlab::accuracyOverall(
  predicted = crowdAveragedProjectionsWithActuals_weekly_wr$points[which(crowdAveragedProjectionsWithActuals_weekly_wr$player_id_season_week %in% playersWithHighProjectedOrActualPoints_weekly)],
  actual = crowdAveragedProjectionsWithActuals_weekly_wr$fantasyPoints[which(crowdAveragedProjectionsWithActuals_weekly_wr$player_id_season_week %in% playersWithHighProjectedOrActualPoints_weekly)],
  dropUndefined = TRUE
)

rsquare_weekly_wr_crowd_subset <- round(accuracyIndices_weekly_wr_crowd_subset$rsquared, digits = 2)
me_weekly_wr_crowd_subset <- round(accuracyIndices_weekly_wr_crowd_subset$ME, digits = 2)
mae_weekly_wr_crowd_subset <- round(accuracyIndices_weekly_wr_crowd_subset$MAE, digits = 2)
```

#### Tight Ends {#sec-accuracyProjectionsWeeklyTE}

Here are the weekly accuracy indexes for all Tight Ends:

```{r}
petersenlab::accuracyOverall(
  predicted = projectionsWithActuals_weekly_te$raw_points,
  actual = projectionsWithActuals_weekly_te$fantasyPoints,
  dropUndefined = TRUE
)
```

```{r}
#| include: false

accuracyIndices_weekly_te <- petersenlab::accuracyOverall(
  predicted = projectionsWithActuals_weekly_te$raw_points,
  actual = projectionsWithActuals_weekly_te$fantasyPoints,
  dropUndefined = TRUE
)

rsquare_weekly_te <- round(accuracyIndices_weekly_te$rsquared, digits = 2)
me_weekly_te <- round(accuracyIndices_weekly_te$ME, digits = 2)
mae_weekly_te <- round(accuracyIndices_weekly_te$MAE, digits = 2)
```

A calibration plot of the weekly projections for Tight Ends is in @fig-calibrationPlotWeeklyTEs.

```{r}
#| label: fig-calibrationPlotWeeklyTEs
#| fig-cap: "Calibration Plot for Weekly Projections of Tight Ends. The diagonal black line is the reference line representing perfect calibration. The yellow line is the best-fit line based on a generalized additive model. The purple band is the 95% confidence interval of actual fantasy points. The dashed red lines are the 95% prediction interval of actual fantasy points based on a locally estimated scatterplot smoothing (LOESS) model."
#| fig-alt: "Calibration Plot for Weekly Projections of Tight Ends. The diagonal black line is the reference line representing perfect calibration. The yellow line is the best-fit line based on a generalized additive model. The purple band is the 95% confidence interval of actual fantasy points. The dashed red lines are the 95% prediction interval of actual fantasy points based on a locally estimated scatterplot smoothing (LOESS) model."
#| fig-width: 8
#| fig-height: 6

#95 prediction interval based on LOESS model
calibrationLoessModel <- msir::loess.sd(
  x = projectionsWithActuals_weekly_te$raw_points,
  y = projectionsWithActuals_weekly_te$fantasyPoints,
  nsigma = qnorm(.975),
  na.action = "na.exclude")

calibrationLoessPredictionInterval <- data.frame(
  x = calibrationLoessModel$x,
  y = calibrationLoessModel$y,
  lower = calibrationLoessModel$lower,
  upper = calibrationLoessModel$upper)

plotRangeMin <- min(calibrationLoessModel$lower, na.rm = TRUE)

plotRangeMax <- max(calibrationLoessModel$upper, na.rm = TRUE)

ggplot2::ggplot(
  data = projectionsWithActuals_weekly_te,
  aes(
    x = raw_points,
    y = fantasyPoints)) + 
  coord_cartesian(
    xlim = c(0, plotRangeMax),
    ylim = c(plotRangeMin, plotRangeMax),
    expand = FALSE) +
  scale_x_continuous(breaks = seq(0, plotRangeMax, by = 5)) +
  scale_y_continuous(breaks = seq(0, plotRangeMax, by = 5)) +
  geom_line(
    data = calibrationLoessPredictionInterval,
    aes(
      x = x,
      y = lower),
    color = "red",
    linetype = "dashed") + #Lower estimate of 95% prediction interval of linear model
  geom_line(
    data = calibrationLoessPredictionInterval,
    aes(
      x = x,
      y = upper),
    color = "red",
    linetype = "dashed") + #Upper estimate of 95% prediction interval of linear model
  geom_smooth(
    method = "gam",
    color = viridisLite::viridis(3)[3],
    fill = viridisLite::viridis(3)[1],
    alpha = 0.7) + #95% confidence interval of GAM model
  geom_abline(
    slope = 1,
    intercept = 0) +
  labs(
    x = "Projected Fantasy Points",
    y = "Actual Fantasy Points",
    title = "Calibration Plot for Weekly Projections of Tight Ends"
  ) +
  theme_classic() + 
  theme(axis.title.y = element_text(angle = 0, vjust = 0.5)) # horizontal y-axis title
```

Here are the weekly accuracy indexes for only those Tight Ends who had high projected or actual points (i.e., players who had more than 6 projected or actual points; the players that are most important to differentiate between):

```{r}
petersenlab::accuracyOverall(
  predicted = projectionsWithActuals_weekly_te$raw_points[which(projectionsWithActuals_weekly$player_id_season_week %in% playersWithHighProjectedOrActualPoints_weekly)],
  actual = projectionsWithActuals_weekly_te$fantasyPoints[which(projectionsWithActuals_weekly$player_id_season_week %in% playersWithHighProjectedOrActualPoints_weekly)],
  dropUndefined = TRUE
)
```

```{r}
#| include: false

accuracyIndices_weekly_te_subset <- petersenlab::accuracyOverall(
  predicted = projectionsWithActuals_weekly_te$raw_points[which(projectionsWithActuals_weekly$player_id_season_week %in% playersWithHighProjectedOrActualPoints_weekly)],
  actual = projectionsWithActuals_weekly_te$fantasyPoints[which(projectionsWithActuals_weekly$player_id_season_week %in% playersWithHighProjectedOrActualPoints_weekly)],
  dropUndefined = TRUE
)

rsquare_weekly_te_subset <- round(accuracyIndices_weekly_te_subset$rsquared, digits = 2)
me_weekly_te_subset <- round(accuracyIndices_weekly_te_subset$ME, digits = 2)
mae_weekly_te_subset <- round(accuracyIndices_weekly_te_subset$MAE, digits = 2)
```

Here are the weekly accuracy indexes for crowd-averaged projections of Tight Ends:

```{r}
petersenlab::accuracyOverall(
  predicted = crowdAveragedProjectionsWithActuals_weekly_te$points,
  actual = crowdAveragedProjectionsWithActuals_weekly_te$fantasyPoints,
  dropUndefined = TRUE
)
```

```{r}
#| include: false

accuracyIndices_weekly_te_crowd <- petersenlab::accuracyOverall(
  predicted = crowdAveragedProjectionsWithActuals_weekly_te$points,
  actual = crowdAveragedProjectionsWithActuals_weekly_te$fantasyPoints,
  dropUndefined = TRUE
)

rsquare_weekly_te_crowd <- round(accuracyIndices_weekly_te_crowd$rsquared, digits = 2)
me_weekly_te_crowd <- round(accuracyIndices_weekly_te_crowd$ME, digits = 2)
mae_weekly_te_crowd <- round(accuracyIndices_weekly_te_crowd$MAE, digits = 2)
```

Here are the weekly accuracy indexes for crowd-averaged projections of Tight Ends, but only among those who had high projected or actual points (i.e., players who had more than 6 projected or actual points; the players that are most important to differentiate between):

```{r}
petersenlab::accuracyOverall(
  predicted = crowdAveragedProjectionsWithActuals_weekly_te$points[which(crowdAveragedProjectionsWithActuals_weekly_te$player_id_season_week %in% playersWithHighProjectedOrActualPoints_weekly)],
  actual = crowdAveragedProjectionsWithActuals_weekly_te$fantasyPoints[which(crowdAveragedProjectionsWithActuals_weekly_te$player_id_season_week %in% playersWithHighProjectedOrActualPoints_weekly)],
  dropUndefined = TRUE
)
```

```{r}
#| include: false

accuracyIndices_weekly_te_crowd_subset <- petersenlab::accuracyOverall(
  predicted = crowdAveragedProjectionsWithActuals_weekly_te$points[which(crowdAveragedProjectionsWithActuals_weekly_te$player_id_season_week %in% playersWithHighProjectedOrActualPoints_weekly)],
  actual = crowdAveragedProjectionsWithActuals_weekly_te$fantasyPoints[which(crowdAveragedProjectionsWithActuals_weekly_te$player_id_season_week %in% playersWithHighProjectedOrActualPoints_weekly)],
  dropUndefined = TRUE
)

rsquare_weekly_te_crowd_subset <- round(accuracyIndices_weekly_te_crowd_subset$rsquared, digits = 2)
me_weekly_te_crowd_subset <- round(accuracyIndices_weekly_te_crowd_subset$ME, digits = 2)
mae_weekly_te_crowd_subset <- round(accuracyIndices_weekly_te_crowd_subset$MAE, digits = 2)
```

#### Kickers {#sec-accuracyProjectionsWeeklyK}

Here are the weekly accuracy indexes for all Kickers:

```{r}
petersenlab::accuracyOverall(
  predicted = projectionsWithActuals_weekly_k$raw_points,
  actual = projectionsWithActuals_weekly_k$fantasyPoints,
  dropUndefined = TRUE
)
```

```{r}
#| include: false

accuracyIndices_weekly_k <- petersenlab::accuracyOverall(
  predicted = projectionsWithActuals_weekly_k$raw_points,
  actual = projectionsWithActuals_weekly_k$fantasyPoints,
  dropUndefined = TRUE
)

rsquare_weekly_k <- round(accuracyIndices_weekly_k$rsquared, digits = 2)
me_weekly_k <- round(accuracyIndices_weekly_k$ME, digits = 2)
mae_weekly_k <- round(accuracyIndices_weekly_k$MAE, digits = 2)
```

A calibration plot of the weekly projections for Kickers is in @fig-calibrationPlotWeeklyKs.

```{r}
#| label: fig-calibrationPlotWeeklyKs
#| fig-cap: "Calibration Plot for Weekly Projections of Kickers. The diagonal black line is the reference line representing perfect calibration. The yellow line is the best-fit line based on a generalized additive model. The purple band is the 95% confidence interval of actual fantasy points. The dashed red lines are the 95% prediction interval of actual fantasy points based on a locally estimated scatterplot smoothing (LOESS) model."
#| fig-alt: "Calibration Plot for Weekly Projections of Kickers. The diagonal black line is the reference line representing perfect calibration. The yellow line is the best-fit line based on a generalized additive model. The purple band is the 95% confidence interval of actual fantasy points. The dashed red lines are the 95% prediction interval of actual fantasy points based on a locally estimated scatterplot smoothing (LOESS) model."
#| fig-width: 8
#| fig-height: 6

#95 prediction interval based on LOESS model
calibrationLoessModel <- msir::loess.sd(
  x = projectionsWithActuals_weekly_k$raw_points,
  y = projectionsWithActuals_weekly_k$fantasyPoints,
  nsigma = qnorm(.975),
  na.action = "na.exclude")

calibrationLoessPredictionInterval <- data.frame(
  x = calibrationLoessModel$x,
  y = calibrationLoessModel$y,
  lower = calibrationLoessModel$lower,
  upper = calibrationLoessModel$upper)

plotRangeMin <- min(calibrationLoessModel$lower, na.rm = TRUE)

plotRangeMax <- max(calibrationLoessModel$upper, na.rm = TRUE)

ggplot2::ggplot(
  data = projectionsWithActuals_weekly_k,
  aes(
    x = raw_points,
    y = fantasyPoints)) + 
  coord_cartesian(
    xlim = c(0, plotRangeMax),
    ylim = c(plotRangeMin, plotRangeMax),
    expand = FALSE) +
  scale_x_continuous(breaks = seq(0, plotRangeMax, by = 5)) +
  scale_y_continuous(breaks = seq(0, plotRangeMax, by = 5)) +
  geom_line(
    data = calibrationLoessPredictionInterval,
    aes(
      x = x,
      y = lower),
    color = "red",
    linetype = "dashed") + #Lower estimate of 95% prediction interval of linear model
  geom_line(
    data = calibrationLoessPredictionInterval,
    aes(
      x = x,
      y = upper),
    color = "red",
    linetype = "dashed") + #Upper estimate of 95% prediction interval of linear model
  geom_smooth(
    method = "gam",
    color = viridisLite::viridis(3)[3],
    fill = viridisLite::viridis(3)[1],
    alpha = 0.7) + #95% confidence interval of GAM model
  geom_abline(
    slope = 1,
    intercept = 0) +
  labs(
    x = "Projected Fantasy Points",
    y = "Actual Fantasy Points",
    title = "Calibration Plot for Weekly Projections of Kickers"
  ) +
  theme_classic() + 
  theme(axis.title.y = element_text(angle = 0, vjust = 0.5)) # horizontal y-axis title
```

Here are the weekly accuracy indexes for only those Kickers who had high projected or actual points (i.e., players who had more than 6 projected or actual points; the players that are most important to differentiate between):

```{r}
petersenlab::accuracyOverall(
  predicted = projectionsWithActuals_weekly_k$raw_points[which(projectionsWithActuals_weekly$player_id_season_week %in% playersWithHighProjectedOrActualPoints_weekly)],
  actual = projectionsWithActuals_weekly_k$fantasyPoints[which(projectionsWithActuals_weekly$player_id_season_week %in% playersWithHighProjectedOrActualPoints_weekly)],
  dropUndefined = TRUE
)
```

```{r}
#| include: false

accuracyIndices_weekly_k_subset <- petersenlab::accuracyOverall(
  predicted = projectionsWithActuals_weekly_k$raw_points[which(projectionsWithActuals_weekly$player_id_season_week %in% playersWithHighProjectedOrActualPoints_weekly)],
  actual = projectionsWithActuals_weekly_k$fantasyPoints[which(projectionsWithActuals_weekly$player_id_season_week %in% playersWithHighProjectedOrActualPoints_weekly)],
  dropUndefined = TRUE
)

rsquare_weekly_k_subset <- round(accuracyIndices_weekly_k_subset$rsquared, digits = 2)
me_weekly_k_subset <- round(accuracyIndices_weekly_k_subset$ME, digits = 2)
mae_weekly_k_subset <- round(accuracyIndices_weekly_k_subset$MAE, digits = 2)
```

Here are the weekly accuracy indexes for crowd-averaged projections of Kickers:

```{r}
petersenlab::accuracyOverall(
  predicted = crowdAveragedProjectionsWithActuals_weekly_k$points,
  actual = crowdAveragedProjectionsWithActuals_weekly_k$fantasyPoints,
  dropUndefined = TRUE
)
```

```{r}
#| include: false

accuracyIndices_weekly_k_crowd <- petersenlab::accuracyOverall(
  predicted = crowdAveragedProjectionsWithActuals_weekly_k$points,
  actual = crowdAveragedProjectionsWithActuals_weekly_k$fantasyPoints,
  dropUndefined = TRUE
)

rsquare_weekly_k_crowd <- round(accuracyIndices_weekly_k_crowd$rsquared, digits = 2)
me_weekly_k_crowd <- round(accuracyIndices_weekly_k_crowd$ME, digits = 2)
mae_weekly_k_crowd <- round(accuracyIndices_weekly_k_crowd$MAE, digits = 2)
```

Here are the weekly accuracy indexes for crowd-averaged projections of Kickers, but only among those who had high projected or actual points (i.e., players who had more than 6 projected or actual points; the players that are most important to differentiate between):

```{r}
petersenlab::accuracyOverall(
  predicted = crowdAveragedProjectionsWithActuals_weekly_k$points[which(crowdAveragedProjectionsWithActuals_weekly_k$player_id_season_week %in% playersWithHighProjectedOrActualPoints_weekly)],
  actual = crowdAveragedProjectionsWithActuals_weekly_k$fantasyPoints[which(crowdAveragedProjectionsWithActuals_weekly_k$player_id_season_week %in% playersWithHighProjectedOrActualPoints_weekly)],
  dropUndefined = TRUE
)
```

```{r}
#| include: false

accuracyIndices_weekly_k_crowd_subset <- petersenlab::accuracyOverall(
  predicted = crowdAveragedProjectionsWithActuals_weekly_k$points[which(crowdAveragedProjectionsWithActuals_weekly_k$player_id_season_week %in% playersWithHighProjectedOrActualPoints_weekly)],
  actual = crowdAveragedProjectionsWithActuals_weekly_k$fantasyPoints[which(crowdAveragedProjectionsWithActuals_weekly_k$player_id_season_week %in% playersWithHighProjectedOrActualPoints_weekly)],
  dropUndefined = TRUE
)

rsquare_weekly_k_crowd_subset <- round(accuracyIndices_weekly_k_crowd_subset$rsquared, digits = 2)
me_weekly_k_crowd_subset <- round(accuracyIndices_weekly_k_crowd_subset$ME, digits = 2)
mae_weekly_k_crowd_subset <- round(accuracyIndices_weekly_k_crowd_subset$MAE, digits = 2)
```

#### Defensive Linemen {#sec-accuracyProjectionsWeeklyDL}

Here are the weekly accuracy indexes for all Defensive Linemen:

```{r}
petersenlab::accuracyOverall(
  predicted = projectionsWithActuals_weekly_dl$raw_points,
  actual = projectionsWithActuals_weekly_dl$fantasyPoints,
  dropUndefined = TRUE
)
```

```{r}
#| include: false

accuracyIndices_weekly_dl <- petersenlab::accuracyOverall(
  predicted = projectionsWithActuals_weekly_dl$raw_points,
  actual = projectionsWithActuals_weekly_dl$fantasyPoints,
  dropUndefined = TRUE
)

rsquare_weekly_dl <- round(accuracyIndices_weekly_dl$rsquared, digits = 2)
me_weekly_dl <- round(accuracyIndices_weekly_dl$ME, digits = 2)
mae_weekly_dl <- round(accuracyIndices_weekly_dl$MAE, digits = 2)
```

A calibration plot of the weekly projections for Defensive Linemen is in @fig-calibrationPlotWeeklyDLs.

```{r}
#| label: fig-calibrationPlotWeeklyDLs
#| fig-cap: "Calibration Plot for Weekly Projections of Defensive Linemen. The diagonal black line is the reference line representing perfect calibration. The yellow line is the best-fit line based on a generalized additive model. The purple band is the 95% confidence interval of actual fantasy points. The dashed red lines are the 95% prediction interval of actual fantasy points based on a locally estimated scatterplot smoothing (LOESS) model."
#| fig-alt: "Calibration Plot for Weekly Projections of Defensive Linemen. The diagonal black line is the reference line representing perfect calibration. The yellow line is the best-fit line based on a generalized additive model. The purple band is the 95% confidence interval of actual fantasy points. The dashed red lines are the 95% prediction interval of actual fantasy points based on a locally estimated scatterplot smoothing (LOESS) model."
#| fig-width: 8
#| fig-height: 6

#95 prediction interval based on LOESS model
calibrationLoessModel <- msir::loess.sd(
  x = projectionsWithActuals_weekly_dl$raw_points,
  y = projectionsWithActuals_weekly_dl$fantasyPoints,
  nsigma = qnorm(.975),
  na.action = "na.exclude")

calibrationLoessPredictionInterval <- data.frame(
  x = calibrationLoessModel$x,
  y = calibrationLoessModel$y,
  lower = calibrationLoessModel$lower,
  upper = calibrationLoessModel$upper)

plotRangeMin <- min(calibrationLoessModel$lower, na.rm = TRUE)

plotRangeMax <- max(calibrationLoessModel$upper, na.rm = TRUE)

ggplot2::ggplot(
  data = projectionsWithActuals_weekly_dl,
  aes(
    x = raw_points,
    y = fantasyPoints)) + 
  coord_cartesian(
    xlim = c(0, plotRangeMax),
    ylim = c(plotRangeMin, plotRangeMax),
    expand = FALSE) +
  scale_x_continuous(breaks = seq(0, plotRangeMax, by = 5)) +
  scale_y_continuous(breaks = seq(0, plotRangeMax, by = 5)) +
  geom_line(
    data = calibrationLoessPredictionInterval,
    aes(
      x = x,
      y = lower),
    color = "red",
    linetype = "dashed") + #Lower estimate of 95% prediction interval of linear model
  geom_line(
    data = calibrationLoessPredictionInterval,
    aes(
      x = x,
      y = upper),
    color = "red",
    linetype = "dashed") + #Upper estimate of 95% prediction interval of linear model
  geom_smooth(
    method = "gam",
    color = viridisLite::viridis(3)[3],
    fill = viridisLite::viridis(3)[1],
    alpha = 0.7) + #95% confidence interval of GAM model
  geom_abline(
    slope = 1,
    intercept = 0) +
  labs(
    x = "Projected Fantasy Points",
    y = "Actual Fantasy Points",
    title = "Calibration Plot for Weekly Projections of Defensive Linemen"
  ) +
  theme_classic() + 
  theme(axis.title.y = element_text(angle = 0, vjust = 0.5)) # horizontal y-axis title
```

Here are the weekly accuracy indexes for only those Defensive Linemen who had high projected or actual points (i.e., players who had more than 6 projected or actual points; the players that are most important to differentiate between):

```{r}
petersenlab::accuracyOverall(
  predicted = projectionsWithActuals_weekly_dl$raw_points[which(projectionsWithActuals_weekly$player_id_season_week %in% playersWithHighProjectedOrActualPoints_weekly)],
  actual = projectionsWithActuals_weekly_dl$fantasyPoints[which(projectionsWithActuals_weekly$player_id_season_week %in% playersWithHighProjectedOrActualPoints_weekly)],
  dropUndefined = TRUE
)
```

```{r}
#| include: false

accuracyIndices_weekly_dl_subset <- petersenlab::accuracyOverall(
  predicted = projectionsWithActuals_weekly_dl$raw_points[which(projectionsWithActuals_weekly$player_id_season_week %in% playersWithHighProjectedOrActualPoints_weekly)],
  actual = projectionsWithActuals_weekly_dl$fantasyPoints[which(projectionsWithActuals_weekly$player_id_season_week %in% playersWithHighProjectedOrActualPoints_weekly)],
  dropUndefined = TRUE
)

rsquare_weekly_dl_subset <- round(accuracyIndices_weekly_dl_subset$rsquared, digits = 2)
me_weekly_dl_subset <- round(accuracyIndices_weekly_dl_subset$ME, digits = 2)
mae_weekly_dl_subset <- round(accuracyIndices_weekly_dl_subset$MAE, digits = 2)
```

Here are the weekly accuracy indexes for crowd-averaged projections of Defensive Linemen:

```{r}
petersenlab::accuracyOverall(
  predicted = crowdAveragedProjectionsWithActuals_weekly_dl$points,
  actual = crowdAveragedProjectionsWithActuals_weekly_dl$fantasyPoints,
  dropUndefined = TRUE
)
```

```{r}
#| include: false

accuracyIndices_weekly_dl_crowd <- petersenlab::accuracyOverall(
  predicted = crowdAveragedProjectionsWithActuals_weekly_dl$points,
  actual = crowdAveragedProjectionsWithActuals_weekly_dl$fantasyPoints,
  dropUndefined = TRUE
)

rsquare_weekly_dl_crowd <- round(accuracyIndices_weekly_dl_crowd$rsquared, digits = 2)
me_weekly_dl_crowd <- round(accuracyIndices_weekly_dl_crowd$ME, digits = 2)
mae_weekly_dl_crowd <- round(accuracyIndices_weekly_dl_crowd$MAE, digits = 2)
```

Here are the weekly accuracy indexes for crowd-averaged projections of Defensive Linemen, but only among those who had high projected or actual points (i.e., players who had more than 6 projected or actual points; the players that are most important to differentiate between):

```{r}
petersenlab::accuracyOverall(
  predicted = crowdAveragedProjectionsWithActuals_weekly_dl$points[which(crowdAveragedProjectionsWithActuals_weekly_dl$player_id_season_week %in% playersWithHighProjectedOrActualPoints_weekly)],
  actual = crowdAveragedProjectionsWithActuals_weekly_dl$fantasyPoints[which(crowdAveragedProjectionsWithActuals_weekly_dl$player_id_season_week %in% playersWithHighProjectedOrActualPoints_weekly)],
  dropUndefined = TRUE
)
```

```{r}
#| include: false

accuracyIndices_weekly_dl_crowd_subset <- petersenlab::accuracyOverall(
  predicted = crowdAveragedProjectionsWithActuals_weekly_dl$points[which(crowdAveragedProjectionsWithActuals_weekly_dl$player_id_season_week %in% playersWithHighProjectedOrActualPoints_weekly)],
  actual = crowdAveragedProjectionsWithActuals_weekly_dl$fantasyPoints[which(crowdAveragedProjectionsWithActuals_weekly_dl$player_id_season_week %in% playersWithHighProjectedOrActualPoints_weekly)],
  dropUndefined = TRUE
)

rsquare_weekly_dl_crowd_subset <- round(accuracyIndices_weekly_dl_crowd_subset$rsquared, digits = 2)
me_weekly_dl_crowd_subset <- round(accuracyIndices_weekly_dl_crowd_subset$ME, digits = 2)
mae_weekly_dl_crowd_subset <- round(accuracyIndices_weekly_dl_crowd_subset$MAE, digits = 2)
```

#### Linebackers {#sec-accuracyProjectionsWeeklyLB}

Here are the weekly accuracy indexes for all Linebackers:

```{r}
petersenlab::accuracyOverall(
  predicted = projectionsWithActuals_weekly_lb$raw_points,
  actual = projectionsWithActuals_weekly_lb$fantasyPoints,
  dropUndefined = TRUE
)
```

```{r}
#| include: false

accuracyIndices_weekly_lb <- petersenlab::accuracyOverall(
  predicted = projectionsWithActuals_weekly_lb$raw_points,
  actual = projectionsWithActuals_weekly_lb$fantasyPoints,
  dropUndefined = TRUE
)

rsquare_weekly_lb <- round(accuracyIndices_weekly_lb$rsquared, digits = 2)
me_weekly_lb <- round(accuracyIndices_weekly_lb$ME, digits = 2)
mae_weekly_lb <- round(accuracyIndices_weekly_lb$MAE, digits = 2)
```

A calibration plot of the weekly projections for Linebackers is in @fig-calibrationPlotWeeklyLBs.

```{r}
#| label: fig-calibrationPlotWeeklyLBs
#| fig-cap: "Calibration Plot for Weekly Projections of Linebackers. The diagonal black line is the reference line representing perfect calibration. The yellow line is the best-fit line based on a generalized additive model. The purple band is the 95% confidence interval of actual fantasy points. The dashed red lines are the 95% prediction interval of actual fantasy points based on a locally estimated scatterplot smoothing (LOESS) model."
#| fig-alt: "Calibration Plot for Weekly Projections of Linebackers. The diagonal black line is the reference line representing perfect calibration. The yellow line is the best-fit line based on a generalized additive model. The purple band is the 95% confidence interval of actual fantasy points. The dashed red lines are the 95% prediction interval of actual fantasy points based on a locally estimated scatterplot smoothing (LOESS) model."
#| fig-width: 8
#| fig-height: 6

#95 prediction interval based on LOESS model
calibrationLoessModel <- msir::loess.sd(
  x = projectionsWithActuals_weekly_lb$raw_points,
  y = projectionsWithActuals_weekly_lb$fantasyPoints,
  nsigma = qnorm(.975),
  na.action = "na.exclude")

calibrationLoessPredictionInterval <- data.frame(
  x = calibrationLoessModel$x,
  y = calibrationLoessModel$y,
  lower = calibrationLoessModel$lower,
  upper = calibrationLoessModel$upper)

plotRangeMin <- min(calibrationLoessModel$lower, na.rm = TRUE)

plotRangeMax <- max(calibrationLoessModel$upper, na.rm = TRUE)

ggplot2::ggplot(
  data = projectionsWithActuals_weekly_lb,
  aes(
    x = raw_points,
    y = fantasyPoints)) + 
  coord_cartesian(
    xlim = c(0, plotRangeMax),
    ylim = c(plotRangeMin, plotRangeMax),
    expand = FALSE) +
  scale_x_continuous(breaks = seq(0, plotRangeMax, by = 5)) +
  scale_y_continuous(breaks = seq(0, plotRangeMax, by = 5)) +
  geom_line(
    data = calibrationLoessPredictionInterval,
    aes(
      x = x,
      y = lower),
    color = "red",
    linetype = "dashed") + #Lower estimate of 95% prediction interval of linear model
  geom_line(
    data = calibrationLoessPredictionInterval,
    aes(
      x = x,
      y = upper),
    color = "red",
    linetype = "dashed") + #Upper estimate of 95% prediction interval of linear model
  geom_smooth(
    method = "gam",
    color = viridisLite::viridis(3)[3],
    fill = viridisLite::viridis(3)[1],
    alpha = 0.7) + #95% confidence interval of GAM model
  geom_abline(
    slope = 1,
    intercept = 0) +
  labs(
    x = "Projected Fantasy Points",
    y = "Actual Fantasy Points",
    title = "Calibration Plot for Weekly Projections of Linebackers"
  ) +
  theme_classic() + 
  theme(axis.title.y = element_text(angle = 0, vjust = 0.5)) # horizontal y-axis title
```

Here are the weekly accuracy indexes for only those Linebackers who had high projected or actual points (i.e., players who had more than 6 projected or actual points; the players that are most important to differentiate between):

```{r}
petersenlab::accuracyOverall(
  predicted = projectionsWithActuals_weekly_lb$raw_points[which(projectionsWithActuals_weekly$player_id_season_week %in% playersWithHighProjectedOrActualPoints_weekly)],
  actual = projectionsWithActuals_weekly_lb$fantasyPoints[which(projectionsWithActuals_weekly$player_id_season_week %in% playersWithHighProjectedOrActualPoints_weekly)],
  dropUndefined = TRUE
)
```

```{r}
#| include: false

accuracyIndices_weekly_lb_subset <- petersenlab::accuracyOverall(
  predicted = projectionsWithActuals_weekly_lb$raw_points[which(projectionsWithActuals_weekly$player_id_season_week %in% playersWithHighProjectedOrActualPoints_weekly)],
  actual = projectionsWithActuals_weekly_lb$fantasyPoints[which(projectionsWithActuals_weekly$player_id_season_week %in% playersWithHighProjectedOrActualPoints_weekly)],
  dropUndefined = TRUE
)

rsquare_weekly_lb_subset <- round(accuracyIndices_weekly_lb_subset$rsquared, digits = 2)
me_weekly_lb_subset <- round(accuracyIndices_weekly_lb_subset$ME, digits = 2)
mae_weekly_lb_subset <- round(accuracyIndices_weekly_lb_subset$MAE, digits = 2)
```

Here are the weekly accuracy indexes for crowd-averaged projections of Linebackers:

```{r}
petersenlab::accuracyOverall(
  predicted = crowdAveragedProjectionsWithActuals_weekly_lb$points,
  actual = crowdAveragedProjectionsWithActuals_weekly_lb$fantasyPoints,
  dropUndefined = TRUE
)
```

```{r}
#| include: false

accuracyIndices_weekly_lb_crowd <- petersenlab::accuracyOverall(
  predicted = crowdAveragedProjectionsWithActuals_weekly_lb$points,
  actual = crowdAveragedProjectionsWithActuals_weekly_lb$fantasyPoints,
  dropUndefined = TRUE
)

rsquare_weekly_lb_crowd <- round(accuracyIndices_weekly_lb_crowd$rsquared, digits = 2)
me_weekly_lb_crowd <- round(accuracyIndices_weekly_lb_crowd$ME, digits = 2)
mae_weekly_lb_crowd <- round(accuracyIndices_weekly_lb_crowd$MAE, digits = 2)
```

Here are the weekly accuracy indexes for crowd-averaged projections of Linebackers, but only among those who had high projected or actual points (i.e., players who had more than 6 projected or actual points; the players that are most important to differentiate between):

```{r}
petersenlab::accuracyOverall(
  predicted = crowdAveragedProjectionsWithActuals_weekly_lb$points[which(crowdAveragedProjectionsWithActuals_weekly_lb$player_id_season_week %in% playersWithHighProjectedOrActualPoints_weekly)],
  actual = crowdAveragedProjectionsWithActuals_weekly_lb$fantasyPoints[which(crowdAveragedProjectionsWithActuals_weekly_lb$player_id_season_week %in% playersWithHighProjectedOrActualPoints_weekly)],
  dropUndefined = TRUE
)
```

```{r}
#| include: false

accuracyIndices_weekly_lb_crowd_subset <- petersenlab::accuracyOverall(
  predicted = crowdAveragedProjectionsWithActuals_weekly_lb$points[which(crowdAveragedProjectionsWithActuals_weekly_lb$player_id_season_week %in% playersWithHighProjectedOrActualPoints_weekly)],
  actual = crowdAveragedProjectionsWithActuals_weekly_lb$fantasyPoints[which(crowdAveragedProjectionsWithActuals_weekly_lb$player_id_season_week %in% playersWithHighProjectedOrActualPoints_weekly)],
  dropUndefined = TRUE
)

rsquare_weekly_lb_crowd_subset <- round(accuracyIndices_weekly_lb_crowd_subset$rsquared, digits = 2)
me_weekly_lb_crowd_subset <- round(accuracyIndices_weekly_lb_crowd_subset$ME, digits = 2)
mae_weekly_lb_crowd_subset <- round(accuracyIndices_weekly_lb_crowd_subset$MAE, digits = 2)
```

#### Defensive Backs {#sec-accuracyProjectionsWeeklyDB}

Here are the weekly accuracy indexes for all Defensive Backs:

```{r}
petersenlab::accuracyOverall(
  predicted = projectionsWithActuals_weekly_db$raw_points,
  actual = projectionsWithActuals_weekly_db$fantasyPoints,
  dropUndefined = TRUE
)
```

```{r}
#| include: false

accuracyIndices_weekly_db <- petersenlab::accuracyOverall(
  predicted = projectionsWithActuals_weekly_db$raw_points,
  actual = projectionsWithActuals_weekly_db$fantasyPoints,
  dropUndefined = TRUE
)

rsquare_weekly_db <- round(accuracyIndices_weekly_db$rsquared, digits = 2)
me_weekly_db <- round(accuracyIndices_weekly_db$ME, digits = 2)
mae_weekly_db <- round(accuracyIndices_weekly_db$MAE, digits = 2)
```

A calibration plot of the weekly projections for Linebackers is in @fig-calibrationPlotWeeklyDBs.

```{r}
#| label: fig-calibrationPlotWeeklyDBs
#| fig-cap: "Calibration Plot for Weekly Projections of Defensive Backs. The diagonal black line is the reference line representing perfect calibration. The yellow line is the best-fit line based on a generalized additive model. The purple band is the 95% confidence interval of actual fantasy points. The dashed red lines are the 95% prediction interval of actual fantasy points based on a locally estimated scatterplot smoothing (LOESS) model."
#| fig-alt: "Calibration Plot for Weekly Projections of Defensive Backs. The diagonal black line is the reference line representing perfect calibration. The yellow line is the best-fit line based on a generalized additive model. The purple band is the 95% confidence interval of actual fantasy points. The dashed red lines are the 95% prediction interval of actual fantasy points based on a locally estimated scatterplot smoothing (LOESS) model."
#| fig-width: 8
#| fig-height: 6

#95 prediction interval based on LOESS model
calibrationLoessModel <- msir::loess.sd(
  x = projectionsWithActuals_weekly_db$raw_points,
  y = projectionsWithActuals_weekly_db$fantasyPoints,
  nsigma = qnorm(.975),
  na.action = "na.exclude")

calibrationLoessPredictionInterval <- data.frame(
  x = calibrationLoessModel$x,
  y = calibrationLoessModel$y,
  lower = calibrationLoessModel$lower,
  upper = calibrationLoessModel$upper)

plotRangeMin <- min(calibrationLoessModel$lower, na.rm = TRUE)

plotRangeMax <- max(calibrationLoessModel$upper, na.rm = TRUE)

ggplot2::ggplot(
  data = projectionsWithActuals_weekly_db,
  aes(
    x = raw_points,
    y = fantasyPoints)) + 
  coord_cartesian(
    xlim = c(0, plotRangeMax),
    ylim = c(plotRangeMin, plotRangeMax),
    expand = FALSE) +
  scale_x_continuous(breaks = seq(0, plotRangeMax, by = 5)) +
  scale_y_continuous(breaks = seq(0, plotRangeMax, by = 5)) +
  geom_line(
    data = calibrationLoessPredictionInterval,
    aes(
      x = x,
      y = lower),
    color = "red",
    linetype = "dashed") + #Lower estimate of 95% prediction interval of linear model
  geom_line(
    data = calibrationLoessPredictionInterval,
    aes(
      x = x,
      y = upper),
    color = "red",
    linetype = "dashed") + #Upper estimate of 95% prediction interval of linear model
  geom_smooth(
    method = "gam",
    color = viridisLite::viridis(3)[3],
    fill = viridisLite::viridis(3)[1],
    alpha = 0.7) + #95% confidence interval of GAM model
  geom_abline(
    slope = 1,
    intercept = 0) +
  labs(
    x = "Projected Fantasy Points",
    y = "Actual Fantasy Points",
    title = "Calibration Plot for Weekly Projections of Defensive Backs"
  ) +
  theme_classic() + 
  theme(axis.title.y = element_text(angle = 0, vjust = 0.5)) # horizontal y-axis title
```

Here are the weekly accuracy indexes for only those Defensive Backs who had high projected or actual points (i.e., players who had more than 6 projected or actual points; the players that are most important to differentiate between):

```{r}
petersenlab::accuracyOverall(
  predicted = projectionsWithActuals_weekly_db$raw_points[which(projectionsWithActuals_weekly$player_id_season_week %in% playersWithHighProjectedOrActualPoints_weekly)],
  actual = projectionsWithActuals_weekly_db$fantasyPoints[which(projectionsWithActuals_weekly$player_id_season_week %in% playersWithHighProjectedOrActualPoints_weekly)],
  dropUndefined = TRUE
)
```

```{r}
#| include: false

accuracyIndices_weekly_db_subset <- petersenlab::accuracyOverall(
  predicted = projectionsWithActuals_weekly_db$raw_points[which(projectionsWithActuals_weekly$player_id_season_week %in% playersWithHighProjectedOrActualPoints_weekly)],
  actual = projectionsWithActuals_weekly_db$fantasyPoints[which(projectionsWithActuals_weekly$player_id_season_week %in% playersWithHighProjectedOrActualPoints_weekly)],
  dropUndefined = TRUE
)

rsquare_weekly_db_subset <- round(accuracyIndices_weekly_db_subset$rsquared, digits = 2)
me_weekly_db_subset <- round(accuracyIndices_weekly_db_subset$ME, digits = 2)
mae_weekly_db_subset <- round(accuracyIndices_weekly_db_subset$MAE, digits = 2)
```

Here are the weekly accuracy indexes for crowd-averaged projections of Defensive Backs:

```{r}
petersenlab::accuracyOverall(
  predicted = crowdAveragedProjectionsWithActuals_weekly_db$points,
  actual = crowdAveragedProjectionsWithActuals_weekly_db$fantasyPoints,
  dropUndefined = TRUE
)
```

```{r}
#| include: false

accuracyIndices_weekly_db_crowd <- petersenlab::accuracyOverall(
  predicted = crowdAveragedProjectionsWithActuals_weekly_db$points,
  actual = crowdAveragedProjectionsWithActuals_weekly_db$fantasyPoints,
  dropUndefined = TRUE
)

rsquare_weekly_db_crowd <- round(accuracyIndices_weekly_db_crowd$rsquared, digits = 2)
me_weekly_db_crowd <- round(accuracyIndices_weekly_db_crowd$ME, digits = 2)
mae_weekly_db_crowd <- round(accuracyIndices_weekly_db_crowd$MAE, digits = 2)
```

Here are the weekly accuracy indexes for crowd-averaged projections of Defensive Backs, but only among those who had high projected or actual points (i.e., players who had more than 6 projected or actual points; the players that are most important to differentiate between):

```{r}
petersenlab::accuracyOverall(
  predicted = crowdAveragedProjectionsWithActuals_weekly_db$points[which(crowdAveragedProjectionsWithActuals_weekly_db$player_id_season_week %in% playersWithHighProjectedOrActualPoints_weekly)],
  actual = crowdAveragedProjectionsWithActuals_weekly_db$fantasyPoints[which(crowdAveragedProjectionsWithActuals_weekly_db$player_id_season_week %in% playersWithHighProjectedOrActualPoints_weekly)],
  dropUndefined = TRUE
)
```

```{r}
#| include: false

accuracyIndices_weekly_db_crowd_subset <- petersenlab::accuracyOverall(
  predicted = crowdAveragedProjectionsWithActuals_weekly_db$points[which(crowdAveragedProjectionsWithActuals_weekly_db$player_id_season_week %in% playersWithHighProjectedOrActualPoints_weekly)],
  actual = crowdAveragedProjectionsWithActuals_weekly_db$fantasyPoints[which(crowdAveragedProjectionsWithActuals_weekly_db$player_id_season_week %in% playersWithHighProjectedOrActualPoints_weekly)],
  dropUndefined = TRUE
)

rsquare_weekly_db_crowd_subset <- round(accuracyIndices_weekly_db_crowd_subset$rsquared, digits = 2)
me_weekly_db_crowd_subset <- round(accuracyIndices_weekly_db_crowd_subset$ME, digits = 2)
mae_weekly_db_crowd_subset <- round(accuracyIndices_weekly_db_crowd_subset$MAE, digits = 2)
```

### Summarizing the Accuracy By Position {#sec-predictionAccuracyByPosition}

```{r}
#| include: false

seasonalAccuracy <- data.frame(
  position = c(
    "All Positions",
    "Quarterbacks",
    "Running Backs",
    "Wide Receivers",
    "Tight Ends",
    "Kickers",
    "Defensive Linemen",
    "Linebackers",
    "Defensive Backs"
  ), 
  rsquared = c(
    rsquare_seasonal_overall,
    rsquare_seasonal_qb,
    rsquare_seasonal_rb,
    rsquare_seasonal_wr,
    rsquare_seasonal_te,
    rsquare_seasonal_k,
    rsquare_seasonal_dl,
    rsquare_seasonal_lb,
    rsquare_seasonal_db
  ),
  me = c(
    me_seasonal_overall,
    me_seasonal_qb,
    me_seasonal_rb,
    me_seasonal_wr,
    me_seasonal_te,
    me_seasonal_k,
    me_seasonal_dl,
    me_seasonal_lb,
    me_seasonal_db
  ),
  mae = c(
    mae_seasonal_overall,
    mae_seasonal_qb,
    mae_seasonal_rb,
    mae_seasonal_wr,
    mae_seasonal_te,
    mae_seasonal_k,
    mae_seasonal_dl,
    mae_seasonal_lb,
    mae_seasonal_db
  )
)

seasonalAccuracy_subset <- data.frame(
  position = c(
    "All Positions",
    "Quarterbacks",
    "Running Backs",
    "Wide Receivers",
    "Tight Ends",
    "Kickers",
    "Defensive Linemen",
    "Linebackers",
    "Defensive Backs"
  ), 
  rsquared = c(
    rsquare_seasonal_overall_subset,
    rsquare_seasonal_qb_subset,
    rsquare_seasonal_rb_subset,
    rsquare_seasonal_wr_subset,
    rsquare_seasonal_te_subset,
    rsquare_seasonal_k_subset,
    rsquare_seasonal_dl_subset,
    rsquare_seasonal_lb_subset,
    rsquare_seasonal_db_subset
  ),
  me = c(
    me_seasonal_overall_subset,
    me_seasonal_qb_subset,
    me_seasonal_rb_subset,
    me_seasonal_wr_subset,
    me_seasonal_te_subset,
    me_seasonal_k_subset,
    me_seasonal_dl_subset,
    me_seasonal_lb_subset,
    me_seasonal_db_subset
  ),
  mae = c(
    mae_seasonal_overall_subset,
    mae_seasonal_qb_subset,
    mae_seasonal_rb_subset,
    mae_seasonal_wr_subset,
    mae_seasonal_te_subset,
    mae_seasonal_k_subset,
    mae_seasonal_dl_subset,
    mae_seasonal_lb_subset,
    mae_seasonal_db_subset
  )
)

seasonalAccuracy_crowd <- data.frame(
  position = c(
    "All Positions",
    "Quarterbacks",
    "Running Backs",
    "Wide Receivers",
    "Tight Ends",
    "Kickers",
    "Defensive Linemen",
    "Linebackers",
    "Defensive Backs"
  ), 
  rsquared = c(
    rsquare_seasonal_overall_crowd,
    rsquare_seasonal_qb_crowd,
    rsquare_seasonal_rb_crowd,
    rsquare_seasonal_wr_crowd,
    rsquare_seasonal_te_crowd,
    rsquare_seasonal_k_crowd,
    rsquare_seasonal_dl_crowd,
    rsquare_seasonal_lb_crowd,
    rsquare_seasonal_db_crowd
  ),
  me = c(
    me_seasonal_overall_crowd,
    me_seasonal_qb_crowd,
    me_seasonal_rb_crowd,
    me_seasonal_wr_crowd,
    me_seasonal_te_crowd,
    me_seasonal_k_crowd,
    me_seasonal_dl_crowd,
    me_seasonal_lb_crowd,
    me_seasonal_db_crowd
  ),
  mae = c(
    mae_seasonal_overall_crowd,
    mae_seasonal_qb_crowd,
    mae_seasonal_rb_crowd,
    mae_seasonal_wr_crowd,
    mae_seasonal_te_crowd,
    mae_seasonal_k_crowd,
    mae_seasonal_dl_crowd,
    mae_seasonal_lb_crowd,
    mae_seasonal_db_crowd
  )
)

seasonalAccuracy_crowd_subset <- data.frame(
  position = c(
    "All Positions",
    "Quarterbacks",
    "Running Backs",
    "Wide Receivers",
    "Tight Ends",
    "Kickers",
    "Defensive Linemen",
    "Linebackers",
    "Defensive Backs"
  ), 
  rsquared = c(
    rsquare_seasonal_overall_crowd_subset,
    rsquare_seasonal_qb_crowd_subset,
    rsquare_seasonal_rb_crowd_subset,
    rsquare_seasonal_wr_crowd_subset,
    rsquare_seasonal_te_crowd_subset,
    rsquare_seasonal_k_crowd_subset,
    rsquare_seasonal_dl_crowd_subset,
    rsquare_seasonal_lb_crowd_subset,
    rsquare_seasonal_db_crowd_subset
  ),
  me = c(
    me_seasonal_overall_crowd_subset,
    me_seasonal_qb_crowd_subset,
    me_seasonal_rb_crowd_subset,
    me_seasonal_wr_crowd_subset,
    me_seasonal_te_crowd_subset,
    me_seasonal_k_crowd_subset,
    me_seasonal_dl_crowd_subset,
    me_seasonal_lb_crowd_subset,
    me_seasonal_db_crowd_subset
  ),
  mae = c(
    mae_seasonal_overall_crowd_subset,
    mae_seasonal_qb_crowd_subset,
    mae_seasonal_rb_crowd_subset,
    mae_seasonal_wr_crowd_subset,
    mae_seasonal_te_crowd_subset,
    mae_seasonal_k_crowd_subset,
    mae_seasonal_dl_crowd_subset,
    mae_seasonal_lb_crowd_subset,
    mae_seasonal_db_crowd_subset
  )
)

weeklyAccuracy <- data.frame(
  position = c(
    "All Positions",
    "Quarterbacks",
    "Running Backs",
    "Wide Receivers",
    "Tight Ends",
    "Kickers",
    "Defensive Linemen",
    "Linebackers",
    "Defensive Backs"
  ), 
  rsquared = c(
    rsquare_weekly_overall,
    rsquare_weekly_qb,
    rsquare_weekly_rb,
    rsquare_weekly_wr,
    rsquare_weekly_te,
    rsquare_weekly_k,
    rsquare_weekly_dl,
    rsquare_weekly_lb,
    rsquare_weekly_db
  ),
  me = c(
    me_weekly_overall,
    me_weekly_qb,
    me_weekly_rb,
    me_weekly_wr,
    me_weekly_te,
    me_weekly_k,
    me_weekly_dl,
    me_weekly_lb,
    me_weekly_db
  ),
  mae = c(
    mae_weekly_overall,
    mae_weekly_qb,
    mae_weekly_rb,
    mae_weekly_wr,
    mae_weekly_te,
    mae_weekly_k,
    mae_weekly_dl,
    mae_weekly_lb,
    mae_weekly_db
  )
)

weeklyAccuracy_subset <- data.frame(
  position = c(
    "All Positions",
    "Quarterbacks",
    "Running Backs",
    "Wide Receivers",
    "Tight Ends",
    "Kickers",
    "Defensive Linemen",
    "Linebackers",
    "Defensive Backs"
  ), 
  rsquared = c(
    rsquare_weekly_overall_subset,
    rsquare_weekly_qb_subset,
    rsquare_weekly_rb_subset,
    rsquare_weekly_wr_subset,
    rsquare_weekly_te_subset,
    rsquare_weekly_k_subset,
    rsquare_weekly_dl_subset,
    rsquare_weekly_lb_subset,
    rsquare_weekly_db_subset
  ),
  me = c(
    me_weekly_overall_subset,
    me_weekly_qb_subset,
    me_weekly_rb_subset,
    me_weekly_wr_subset,
    me_weekly_te_subset,
    me_weekly_k_subset,
    me_weekly_dl_subset,
    me_weekly_lb_subset,
    me_weekly_db_subset
  ),
  mae = c(
    mae_weekly_overall_subset,
    mae_weekly_qb_subset,
    mae_weekly_rb_subset,
    mae_weekly_wr_subset,
    mae_weekly_te_subset,
    mae_weekly_k_subset,
    mae_weekly_dl_subset,
    mae_weekly_lb_subset,
    mae_weekly_db_subset
  )
)

weeklyAccuracy_crowd <- data.frame(
  position = c(
    "All Positions",
    "Quarterbacks",
    "Running Backs",
    "Wide Receivers",
    "Tight Ends",
    "Kickers",
    "Defensive Linemen",
    "Linebackers",
    "Defensive Backs"
  ), 
  rsquared = c(
    rsquare_weekly_overall_crowd,
    rsquare_weekly_qb_crowd,
    rsquare_weekly_rb_crowd,
    rsquare_weekly_wr_crowd,
    rsquare_weekly_te_crowd,
    rsquare_weekly_k_crowd,
    rsquare_weekly_dl_crowd,
    rsquare_weekly_lb_crowd,
    rsquare_weekly_db_crowd
  ),
  me = c(
    me_weekly_overall_crowd,
    me_weekly_qb_crowd,
    me_weekly_rb_crowd,
    me_weekly_wr_crowd,
    me_weekly_te_crowd,
    me_weekly_k_crowd,
    me_weekly_dl_crowd,
    me_weekly_lb_crowd,
    me_weekly_db_crowd
  ),
  mae = c(
    mae_weekly_overall_crowd,
    mae_weekly_qb_crowd,
    mae_weekly_rb_crowd,
    mae_weekly_wr_crowd,
    mae_weekly_te_crowd,
    mae_weekly_k_crowd,
    mae_weekly_dl_crowd,
    mae_weekly_lb_crowd,
    mae_weekly_db_crowd
  )
)

weeklyAccuracy_crowd_subset <- data.frame(
  position = c(
    "All Positions",
    "Quarterbacks",
    "Running Backs",
    "Wide Receivers",
    "Tight Ends",
    "Kickers",
    "Defensive Linemen",
    "Linebackers",
    "Defensive Backs"
  ), 
  rsquared = c(
    rsquare_weekly_overall_crowd_subset,
    rsquare_weekly_qb_crowd_subset,
    rsquare_weekly_rb_crowd_subset,
    rsquare_weekly_wr_crowd_subset,
    rsquare_weekly_te_crowd_subset,
    rsquare_weekly_k_crowd_subset,
    rsquare_weekly_dl_crowd_subset,
    rsquare_weekly_lb_crowd_subset,
    rsquare_weekly_db_crowd_subset
  ),
  me = c(
    me_weekly_overall_crowd_subset,
    me_weekly_qb_crowd_subset,
    me_weekly_rb_crowd_subset,
    me_weekly_wr_crowd_subset,
    me_weekly_te_crowd_subset,
    me_weekly_k_crowd_subset,
    me_weekly_dl_crowd_subset,
    me_weekly_lb_crowd_subset,
    me_weekly_db_crowd_subset
  ),
  mae = c(
    mae_weekly_overall_crowd_subset,
    mae_weekly_qb_crowd_subset,
    mae_weekly_rb_crowd_subset,
    mae_weekly_wr_crowd_subset,
    mae_weekly_te_crowd_subset,
    mae_weekly_k_crowd_subset,
    mae_weekly_dl_crowd_subset,
    mae_weekly_lb_crowd_subset,
    mae_weekly_db_crowd_subset
  )
)
```

We summarize the accuracy of seasonal projections by position in Tables [-@tbl-seasonalAccuracyByPosition] and [-@tbl-seasonalAccuracyByPositionSubset].

```{r}
#| label: tbl-seasonalAccuracyByPosition
#| tbl-cap: "Accuracy of Seasonal Projections By Position."
#| echo: false

knitr::kable(
  seasonalAccuracy,
  col.names = c("Position","$R^2$","Mean Error","Mean Absolute Error"),
  booktabs = TRUE)
```

```{r}
#| label: tbl-seasonalAccuracyByPositionSubset
#| tbl-cap: "Accuracy of Seasonal Projections By Position, Among Players with Greater than 100 Projected or Actual Points."
#| echo: false

knitr::kable(
  seasonalAccuracy_subset,
  col.names = c("Position","$R^2$","Mean Error","Mean Absolute Error"),
  booktabs = TRUE)
```

We summarize the accuracy of crowd-averaged seasonal projections by position in Tables [-@tbl-seasonalCrowdAccuracyByPosition] and [-@tbl-seasonalCrowdAccuracyByPositionSubset].

```{r}
#| label: tbl-seasonalCrowdAccuracyByPosition
#| tbl-cap: "Accuracy of Crowd-Averaged Seasonal Projections By Position."
#| echo: false

knitr::kable(
  seasonalAccuracy_crowd,
  col.names = c("Position","$R^2$","Mean Error","Mean Absolute Error"),
  booktabs = TRUE)
```

```{r}
#| label: tbl-seasonalCrowdAccuracyByPositionSubset
#| tbl-cap: "Accuracy of Crowd-Averaged Seasonal Projections By Position, Among Players with Greater than 100 Projected or Actual Points."
#| echo: false

knitr::kable(
  seasonalAccuracy_crowd_subset,
  col.names = c("Position","$R^2$","Mean Error","Mean Absolute Error"),
  booktabs = TRUE)
```

We summarize the accuracy of weekly projections by position in Tables [-@tbl-weeeklyAccuracyByPosition] and [-@tbl-weeklyAccuracyByPositionSubset].

```{r}
#| label: tbl-weeeklyAccuracyByPosition
#| tbl-cap: "Accuracy of Weekly Projections By Position."
#| echo: false

knitr::kable(
  weeklyAccuracy,
  col.names = c("Position","$R^2$","Mean Error","Mean Absolute Error"),
  booktabs = TRUE)
```

```{r}
#| label: tbl-weeklyAccuracyByPositionSubset
#| tbl-cap: "Accuracy of Weekly Projections By Position, Among Players with Greater than 6 Projected or Actual Points."
#| echo: false

knitr::kable(
  weeklyAccuracy_subset,
  col.names = c("Position","$R^2$","Mean Error","Mean Absolute Error"),
  booktabs = TRUE)
```

We summarize the accuracy of crowd-averaged seasonal projections by position in Tables [-@tbl-weeklyCrowdAccuracyByPosition] and [-@tbl-weeklyCrowdAccuracyByPositionSubset].

```{r}
#| label: tbl-weeklyCrowdAccuracyByPosition
#| tbl-cap: "Accuracy of Crowd-Averaged Weekly Projections By Position."
#| echo: false

knitr::kable(
  weeklyAccuracy_crowd,
  col.names = c("Position","$R^2$","Mean Error","Mean Absolute Error"),
  booktabs = TRUE)
```

```{r}
#| label: tbl-weeklyCrowdAccuracyByPositionSubset
#| tbl-cap: "Accuracy of Crowd-Averaged Weekly Projections By Position, Among Players with Greater than 6 Projected or Actual Points."
#| echo: false

knitr::kable(
  weeklyAccuracy_crowd_subset,
  col.names = c("Position","$R^2$","Mean Error","Mean Absolute Error"),
  booktabs = TRUE)
```

In general, projections showed moderate accuracy in predicting players' fantasy performance.
Projections showed moderate accuracy in terms of [discrimination](#sec-discrimination), based on [$R^2$](#sec-coefficientOfDetermination).
However, projections were not highly accurate.
Projections showed some [miscalibration](#sec-calibrationIndices) with respect to actual fantasy points.
In general, projected showed a modest tendency to underpredict performance at lower levels of projected points and a moderate-to-strong tendency overpredict performance at higher levels of projected points, an example of the overextremity form of [miscalibration](#sec-calibration).
As a reminder, the overextremity form of [miscalibration](#sec-calibration) is an example of the overprecision form of [overconfidence](#sec-cognitiveBiasesOverconfidence).
That is, projection sources appear to be [overconfident](#sec-cognitiveBiasesOverconfidence) in their projections of player performance.

For seasonal projections, in terms of comparison by position, projections showed greatest discrimination ($R^2$) for Quarterbacks, followed by Running Backs/Tight Ends, and Wide Receivers.
Predictions for defensive players and kickers showed a negative $R^2$, indicating that projections would have been more accurate merely by predicting the mean of the actual values for every observation (i.e., [predicting from the base rate](#sec-predictingFromBaseRate)).
In terms of comparison by projection source, crowd-averaged projections showed greater accuracy than individual projection sources (i.e., "experts") in terms of discrimination ($R^2$) and calibration (MAE).
This was especially the case when examining individual sources separately (rather than in one combined object).

For weekly projections, in terms of comparison by position, projections showed greatest discrimination ($R^2$) for Running Backs, followed by Wide Receivers, Quarterbacks, and Tight Ends.
Predictions for defensive players and kickers showed a negative $R^2$, indicating that projections would have been more accurate merely by predicting the mean of the actual values for every observation (i.e., [predicting from the base rate](#sec-predictingFromBaseRate)).
In terms of comparison by projection source, crowd-averaged projections showed greater accuracy than individual projection sources in terms of discrimination ($R^2$) and calibration (MAE).

In summary, we found that, for both seasonal and weekly projections, crowd-averaged projections showed greater accuracy than individual projection sources (i.e., "experts"), consistent with prior findings [@Kartes2024; archived at <https://perma.cc/69F7-LLTN>; @Petersen2017; archived at <https://perma.cc/BG2W-ANUF>].
Nevertheless projections—including individual sources and crowd-averaged—were not highly accurate.
Projections tended not to explain more than about two-thirds of the variance in players' performance, and frequently explained well less than half of the variance, particularly when distinguishing between players with high (i.e, more than 100) projected or actual points—who are the players that are the most important to distinguish, because those are the players that you are most likely trying to decide between when drafting.
Thus, although projections for offensive positions (besides Kickers) do better than chance, there remains considerable room for improvement in predictive accuracy.
The modest accuracy of projections likely reflects that human behavior is multiply determined and hard to predict.

Prediction accuracy tended to be higher for seasonal projections than for weekly projections—likely because of the greater number of "trials" (i.e., plays) in a season compared to a game, so more of the random error averages out.
The weaker accuracy weekly projections makes betting on daily fantasy sports a gamble.

The association between projected and actual fantasy points tended to flatten at the higher levels of projected points, for some positions, including Running Backs, Kickers, and defensive players.
A consequence of this pattern, from the perspective of draft strategy, is that it would not make sense to draft players projected to score more than the flattening of the projected–actual curve.
For instance, drafting a highly routed Wide Receiver may be safer than drafting a highly ranked Running Back, who may be more prone to injury.
This finding is consistent with findings from @Petersen2017 [archived at <https://perma.cc/BG2W-ANUF>], who found that projections were more accurate for Quarterbacks and Wide Receivers than for Running Backs; projections were the least accurate for Kickers, Defensive Backs, and Defense/Special Teams.
These finding were also extended by @Kartes2025 (archived at <https://perma.cc/R3WS-CAKD>) whose evaluation of the accuracy of projections by position found that:

a. Quarterbacks with preseason ranks of 6–10 showed the greatest systematic underperformance relative to their projections, suggesting that you should either draft an elite Quarterback (ranked 1–5) or wait until later rounds to draft multiple lower-ranked Quarterbacks.
a. Elite Running Backs (with preseason ranks of 1–5) showed strong underperformance (relative to projections), suggesting that you should draft Running Backs ranked 6 and below.
a. Wide Receivers showed among the more consistent and predictable patterns in projections, suggesting that it may be safer to draft a top Wide Receiver than top-ranked players at other positions.
a. Tight Ends showed relative inaccuracy of projections with limited upside concentrated among a few players, which means it is difficult, at the outset, to predict which Tight Ends will excel; based on this, @Kartes2025 suggested avoiding overpaying for mid-tier Tight Ends; to either draft a Tight End early or to wait until later rounds.

This does *not* mean that you should intentionally draft a 6th ranked Running Back instead of the top-ranked Running Back.
Instead, what it may mean is that, instead of drafting the top-ranked Running Back, you may be better off drafting the top-ranked Wide Receiver and to get a value player at Running Back in a subsequent pick.

## Ways to Improve Prediction Accuracy {#sec-waysToImprovePredictionAccuracy}

On the whole, experts' predictions are inaccurate.
Experts' predictions from many different domains tend to be inaccurate, including political scientists [@Tetlock2017], physicians [@Koehler2002], clinical psychologists [@Oskamp1965], stock market traders and corporate financial officers [@Skala2008], seismologists' predictions of earthquakes [@Hough2016], economists' predictions about the economy [@Makridakis2009], lawyers [@Koehler2002], and business managers [@Russo1992].
Thus, I would not put much confidence in the predictions by fantasy football pundits.
The most common pattern of experts' predictions is that they show overextremity, that is, their predictions have probability judgments that tend to be too extreme, as described in @sec-calibration.
Overextremity of experts' predictions reflects the [overprecision](#sec-cognitiveBiasesOverconfidence) type of [overconfidence bias](#sec-cognitiveBiasesOverconfidence).
The degree of confidence of a person's predictions is often not a good indicator of the accuracy of their predictions [and confidence and prediction accuracy are sometimes inversely associated; @Silver2012].
[Heuristics](#sec-heuristics) such as the [anchoring and adjustment heuristic](#sec-heuristicsAnchoringAdjustment), [cognitive biases](#sec-cognitiveBiases) such as [confirmation bias](#sec-cognitiveBiasesConfirmation) [@Hoch1985; @Koriat1980], [fallacies](#sec-fallacies) such as the [base rate fallacy](#sec-fallaciesBaseRate) [@Eddy1982; @Koehler2002] could contribute to overconfidence of predictions.
[Poorly calibrated](#sec-calibration) predictions are especially likely when the [base rate](#sec-baseRate) is very low (e.g., suicide) or when the [base rate](#sec-baseRate) is very high [@Koehler2002].

Nevertheless, there are some domains that have shown greater predictive accuracy, from which we may learn what practices may lead to greater accuracy.
For instance, experts have shown stronger predictive accuracy in weather forecasting [@Murphy1984], horse race betting [@Johnson2001], and playing the card game of bridge [@Keren1987], but see @Koehler2002 for exceptions.

Here are some potential ways to improve the accuracy (and honesty) of predictions and judgments:

- Provide appropriate [anchoring of your predictions to the base rate](#sec-accountForBaseRates) of the phenomenon you are predicting.
To the extent that the [base rate](#sec-baseRate) of the event you are predicting is low, more extreme evidence should be necessary to consistently and accurately predict that the event will occur.
Applying [actuarial formulas](#sec-actuarialPrediction) and [Bayes' theorem](#sec-bayesTheorem) can help you appropriately weigh the [base rate](#sec-baseRate) and evidence.
- Include multiple predictors, ideally from different measures and measurement methods.
Include the predictors with the strongest validity based on theory of the causal process and based on [criterion-related validity](#sec-criterionValidity).
- When possible, aggregate multiple perspectives of predictions, especially predictions made independently (from different people/methods/etc.).
The "wisdom of the crowd" is often more accurate than individuals' predictions, including predictions by so-called "experts" [@Silver2012].
- Instead of aggregating scores from multiple variables, another option is to "unamalgamate" the predictors, that is, to use each variable as a separate predictor, to maximize predictive power [@TrafimowInPress].
- A goal of prediction is to capture as much signal as possible and as little noise (error) as possible [@Silver2012].
Parsimony (i.e., not having too many predictors) can help reduce the amount of error variance captured by the prediction model.
However, to accurately model complex systems like human behavior, complex models may be necessary.
However, strong theory of the causal processes and dynamics may be necessary to develop accurate complex models.
- Although incorporating theory can be helpful, provide more weight to empiricism than to theory, until our theories and measures are stronger.
Ideally, we would use theory to design a model that mirrors the causal system, with accurate measures of each process in the system, so we could make accurate predictions.
However, as described in @sec-theoryVsEmpiricism, our psychological theories of the causal processes that influence behavior are not yet very strong.
Until we have stronger theories that specify the causal process for a given outcome, and until we have accurate measures of those causal processes, [actuarial approaches](#sec-actuarialPrediction) are likely to be most accurate, as discussed in @sec-judgmentVsActuarial.
At the same time, keep in mind that measures involving human behavior, and their resulting data, are often noisy.
As a result, theoretically (conceptually) informed empirical approaches may lead to more accuracy than empiricism alone.
- Use an empirically validated and cross-validated [statistical algorithm](#sec-actuarialPrediction) to combine information from the predictors in a formalized way.
Give each predictor appropriate weight in the statistical algorithm, according to its strength of association with the outcome.
Use measures with strong [reliability](#sec-reliability) and [validity](#sec-validity) for assessing these processes to be used in the algorithm.
Cross-validation will help reduce the likelihood that your model is fitting to noise and will maximize the likelihood that the model predicts accurately when applied to new data (i.e., the model's predictions accurately generalize), as described in @sec-bestActuarialApproaches.
- When presenting your predictions, acknowledge what you do not know.
- Express your predictions in terms of probabilistic estimates and present the uncertainty in your predictions with confidence intervals [even though bolder, more extreme predictions tend to receive stronger television ratings; @Silver2012].
- Qualify your predictions by identifying and noting counter-examples that would not be well fit by your prediction model, such as extreme cases, edge cases, and "broken leg" [@Meehl1957] cases.
- Provide clear, consistent, and timely feedback on the outcomes of the predictions to the people making the predictions [@Bolger2004].
- Be self-critical about your predictions.
Update your judgments based on their accuracy, rather than trying to confirm your beliefs [@Atanasov2020].
- In addition to considering the accuracy of the prediction, consider the quality of the prediction *process*, especially when random chance is involved to a degree, such as in poker and fantasy football [@Silver2012].
- Work to identify and mitigate potential blindspots; be aware of [cognitive biases](#sec-cognitiveBiases) and [fallacies](#sec-fallacies), such as [confirmation bias](#sec-cognitiveBiasesConfirmation) and the [base rate fallacy](#sec-fallaciesBaseRate).
- Evaluate for the possibility of [test bias](#sec-testBias).
Correct for any [test bias](#sec-testBias).

## Conclusion {#sec-predictionAccuracyConclusion}

When the [base rate](#baseRate) of a behavior is very low or very high, you can be highly accurate in predicting the behavior by [predicting from the base rate](#sec-predictingFromBaseRate).
Thus, you cannot judge how accurate your prediction is until you know how accurate your predictions would be by [random chance](#sec-accuracyByChance).
Moreover, maximizing [percent accuracy](#sec-percentAccuracy) may not be the ultimate goal because [different errors have different costs](#sec-differentErrorsDifferentCosts).
Though there are many indices of accuracy, there are two general types of accuracy: [discrimination](#sec-discrimination) and [calibration](#sec-calibration).
[Discrimination](#sec-discrimination) accuracy is frequently evaluated with the [area under the receiver operating characteristic curve](#sec-auc), or with [sensitivity](#sec-sensitivity) and [specificity](#sec-specificity), or with [standardized regression coefficients](#sec-standardizedRegressionCoefficient) or the [coefficient of determination](#sec-multipleRegressionRSquared).
[Calibration](#sec-calibration) accuracy is frequently evaluated graphically and with various indices.
[Sensitivity](#sec-sensitivity) and [specificity](#sec-specificity) [depend on the cutoff](#sec-accuracyCutoff).
It is important to evaluate both [discrimination](#sec-discrimination) and [calibration](#sec-calibration) when evaluating prediction accuracy.

In terms of the accuracy of historical fantasy football projections, projections showed moderate accuracy in terms of [discrimination](#sec-discrimination) in predicting players' fantasy performance.
However, projections were not highly accurate.
Projections showed some [miscalibration](#sec-calibrationIndices) with respect to actual fantasy points.
Projection sources appeared to be [overconfident](#sec-cognitiveBiasesOverconfidence) in their projections of player performance.
In general, projected showed a modest tendency to underpredict performance at lower levels of projected points and a moderate-to-strong tendency overpredict performance at higher levels of projected points, an example of the overextremity, which is an example of the overprecision form of [overconfidence](#sec-cognitiveBiasesOverconfidence).
Crowd-averaged projections tend to be more accurate than individual sources of projections.

::: {.content-visible when-format="html"}

## Session Info {#sec-predictionAccuracySessionInfo}

```{r}
sessionInfo()
```

:::