Project1: Prevalence and Precision in Neurological Diseases
DAT 301 | Madison Kim 1237960505
9/2/2026
Project Description
Neurological diseases are a major cause of disability and mortality worldwide, affecting millions of people across global populations. Because the occurrence and prevalence of these diseases are influenced by multiple demographic, geographic, and clinical factors, understanding and predicting their prevalence is important for identifying disease patterns and changes over time within different sociological contexts. This project analyzes and predicts the prevalence of major neurological diseases from 1990 to 2023 based on geographic location, following with future disease population.
Data source: Institute for Health Metrics and Evaluation (IHME)
Importing the Data
df = read.csv("DAT301PROJECT1.csv")
sum(is.na(df))## [1] 0Import Libraries
library(tidyverse)
library(ggplot2)
library(data.table)
library(plotly)
library(dplyr)
library(tidyr)
library(patchwork)head(df)## population_group_id population_group_name measure_id measure_name location_id
## 1 1 All Population 5 Prevalence 67
## 2 1 All Population 5 Prevalence 67
## 3 1 All Population 5 Prevalence 67
## 4 1 All Population 5 Prevalence 67
## 5 1 All Population 5 Prevalence 67
## 6 1 All Population 5 Prevalence 67
## location_name sex_id sex_name age_id age_name cause_id
## 1 Japan 3 Both 22 All ages 543
## 2 Japan 3 Both 22 All ages 543
## 3 Japan 3 Both 22 All ages 544
## 4 Japan 3 Both 22 All ages 544
## 5 Japan 3 Both 22 All ages 545
## 6 Japan 3 Both 22 All ages 545
## cause_name metric_id metric_name year
## 1 Alzheimer's disease and other dementias 1 Number 1991
## 2 Alzheimer's disease and other dementias 3 Rate 1991
## 3 Parkinson's disease 1 Number 1991
## 4 Parkinson's disease 3 Rate 1991
## 5 Idiopathic epilepsy 1 Number 1991
## 6 Idiopathic epilepsy 3 Rate 1991
## val upper lower
## 1 1.026295e+06 1185951.7271 873474.40690
## 2 8.270651e+02 955.7285 703.91094
## 3 1.118571e+05 137369.8478 89834.16780
## 4 9.014279e+01 110.7029 72.39508
## 5 2.854495e+05 380269.2612 197888.92502
## 6 2.300365e+02 306.4494 159.47368range(df$year)## [1] 1990 2023Selecting the columns that will be used for further analysis
df = df %>%
select(location_name, cause_name, metric_name, year, val, sex_id, lower, upper)
head(df)## location_name cause_name metric_name year
## 1 Japan Alzheimer's disease and other dementias Number 1991
## 2 Japan Alzheimer's disease and other dementias Rate 1991
## 3 Japan Parkinson's disease Number 1991
## 4 Japan Parkinson's disease Rate 1991
## 5 Japan Idiopathic epilepsy Number 1991
## 6 Japan Idiopathic epilepsy Rate 1991
## val sex_id lower upper
## 1 1.026295e+06 3 873474.40690 1185951.7271
## 2 8.270651e+02 3 703.91094 955.7285
## 3 1.118571e+05 3 89834.16780 137369.8478
## 4 9.014279e+01 3 72.39508 110.7029
## 5 2.854495e+05 3 197888.92502 380269.2612
## 6 2.300365e+02 3 159.47368 306.4494Data Exploration
Trend of Total Rate of Diseases
To examine changes in prevalence rates across the five countries over time, I will use the sum of the rates across the six diseases as an approximate measure.
ttrate = df %>%
filter(metric_name == "Rate") %>%
group_by(location_name, year) %>%
summarise(
total_rate = sum(val)
) %>%
arrange(location_name, year)## `summarise()` has regrouped the output.
## ℹ Summaries were computed grouped by location_name and year.
## ℹ Output is grouped by location_name.
## ℹ Use `summarise(.groups = "drop_last")` to silence this message.
## ℹ Use `summarise(.by = c(location_name, year))` for per-operation grouping
## (`?dplyr::dplyr_by`) instead.ttrate## # A tibble: 170 × 3
## # Groups: location_name [5]
## location_name year total_rate
## <chr> <int> <dbl>
## 1 India 1990 34058.
## 2 India 1991 34184.
## 3 India 1992 34296.
## 4 India 1993 34395.
## 5 India 1994 34484.
## 6 India 1995 34568.
## 7 India 1996 34597.
## 8 India 1997 34556.
## 9 India 1998 34492.
## 10 India 1999 34457.
## # ℹ 160 more rowsttrate_change = ttrate %>%
group_by(location_name) %>%
summarise(
rate_1990 = first(total_rate),
rate_2023 = last(total_rate),
pct_change = (rate_2023 / rate_1990 - 1) * 100
) %>%
arrange(desc(pct_change))
ttrate_change## # A tibble: 5 × 4
## location_name rate_1990 rate_2023 pct_change
## <chr> <dbl> <dbl> <dbl>
## 1 India 34058. 38283. 12.4
## 2 Japan 40434. 42343. 4.72
## 3 Nigeria 31772. 32420. 2.04
## 4 Italy 49981. 50783. 1.60
## 5 United States of America 48435. 48405. -0.0614Trend of Total Number of Diseases
Now we check the trend of number of diseases for each countries
ttnumber = df %>%
filter(metric_name == "Number") %>%
group_by(location_name, year) %>%
summarise(
total_number = sum(val),
.groups = "drop"
) %>%
arrange(location_name, year)
head(ttnumber)## # A tibble: 6 × 3
## location_name year total_number
## <chr> <int> <dbl>
## 1 India 1990 287912445.
## 2 India 1991 294272863.
## 3 India 1992 300846960.
## 4 India 1993 307653651.
## 5 India 1994 314683886.
## 6 India 1995 321903146.ttnumber_change = ttnumber %>%
group_by(location_name) %>%
summarise(
num_1990 = first(total_number),
num_2023 = last(total_number),
pct_change = (num_2023 / num_1990 - 1) * 100
) %>%
arrange(desc(pct_change))
ttnumber_change## # A tibble: 5 × 4
## location_name num_1990 num_2023 pct_change
## <chr> <dbl> <dbl> <dbl>
## 1 Nigeria 28621657. 79375761. 177.
## 2 India 287912445. 552575604. 91.9
## 3 United States of America 123061271. 162358148. 31.9
## 4 Japan 50012072. 52790768. 5.56
## 5 Italy 28391175. 29908212. 5.34p1 <- ggplot(ttrate_change,
aes(x = reorder(location_name, pct_change),
y = pct_change)) +
geom_col(fill = "darkorange") +
labs(
x = "Country",
y = "Percent Change",
title = "Rate"
)
p2 <- ggplot(ttnumber_change,
aes(x = reorder(location_name, pct_change),
y = pct_change)) +
geom_col(fill = "steelblue") +
labs(
x = "Country",
y = "Percent Change",
title = "Number"
)
p1 / p2
Summary of data analysis
Two figures compare percentage change in disease prevalence rates per 100,000 people, and the number of cases between 1990 and 2023 for five countries. India showed the largest increase in prevalence rate (12.4%), whereas Nigeria showed the greatest increase in the number of cases (63.9%). Japan and Italy showed modest increases in both measures, while the United States showed little change in prevalence rate despite a substantial increase in the number of cases. These results demonstrates that changes in the absolute number of cases do not necessarily correspond to changes in disease prevalence rates, and the increase in the number of cases may have been influenced by population growth, or any other factors. Because summing of all diseases is inappropriate for predictive modelling, since a person may have multiple diagnoses simultaneously, this analysis instead will compare the trends in the number of cases and prevalence rates across countries and over time to investigate the discrepancy between these two measures.
Disease Trend in Number and Rate
p_num = df %>%
filter(metric_name == "Number") %>%
ggplot(aes(year, val, color = location_name)) +
geom_line(linewidth = 0.8) +
facet_wrap(~ cause_name, scales = "free_y") +
labs(title = "Number of cases", y = "Cases", color = "Country")
p_rate = df %>%
filter(metric_name == "Rate") %>%
ggplot(aes(year, val, color = location_name)) +
geom_line(linewidth = 0.8) +
facet_wrap(~ cause_name, scales = "free_y") +
labs(title = "Rate per 100k", y = "Per 100k", color = "Country")
p_num / p_rate
Summay of data analysis
As we have seen from the accumulated disease rate and number graph, the trend in the number of cases does not necessarily follow the trend in disease prevalence rates because the number of cases can be affected by multiple factors.
Headache disorders show stable trend for both number of cases and prevalence rate over years across all the countries, and idiopathic epilepsy shows variability over years. While Alzheimer’s Disease and Motor neuron disease both show upward trend in both measures, Alzheimer’s disease has substantially more number of cases than motor neuron disease.
Since this project aims to compare disease prevalence across populations, the prevalence rate per 100,000 people will be used as the target for the predictive model. In this way, the model would be able to capture changes in disease prevalence rather than just population. Among the diseases, I selected Alzheimer’s Disease as prediction disease. Not only it is a major health concern associated with population aging, it demonstrates upward trend across all five countries. This pattern assumes that it is suitable for prediction modeling.
Linear Model
Uncertainty of Data
Before fitting a model, we need to understand the precision of the estimates. Each disease rate is reported as a mean estimate with a 95% uncertainty interval, which represents the range of likely values for the estimated rate. Therefore, we examine the width of these uncertainty intervals to assess the precision of the disease rate before proceeding to linear modeling.
The width of the 95% uncertainty interval is calculated by subtracting the lower bound from the upper bound. Then, the interval width is divided by the prevalence rate (val) to obtain the relative uncertainty interval of each estimate.\[\text{Uncertainty} = \frac{\text{Estimate Width}}{\text{val}}\]
Higher in this value indicates that the uncertainty is large compared with the estimated rate, meaning the estimated value is less precise. Conversely, a lower relative uncertainty indicates more precise estimated value.
alz_rate = df %>%
filter(cause_name == "Alzheimer's disease and other dementias",
metric_name == "Rate")
prev_rate = ggplot(alz_rate, aes(year, val, color = location_name)) +
geom_line(linewidth = 1) +
labs(title = "Alzheimer's prevalence rate over time",
y = "Rate per 100k", x = "Year", color = "Country")
width = alz_rate %>%
mutate(width = upper - lower) %>%
ggplot(aes(year, width, color = location_name)) +
geom_line(linewidth = 1) +
labs(title = "Width of 95% uncertainty interval over time",
y = "Width (per 100k)", x = "Year", color = "Country")
relplot = alz_rate %>%
mutate(rel_width = (upper - lower) / val) %>%
ggplot(aes(year, rel_width, color = location_name)) +
geom_line(linewidth = 1) +
labs(title = "Relative uncertainty over time",
y = "Relative uncertainty", x = "Year", color = "Country")
prev_rate / width / relplot
The prevalence rate and uncertainty interval width show very similar trends, which is expected because higher estimated prevalence rates generally have wider uncertainty intervals. However, uncertainty shows a different pattern. While there are some fluctuations, it remains relatively stable for most countries, with Italy showing the biggest increase. Although Italy’s estimated prevalence rate increased over time, the uncertainty did not decrease proportionally, resulting in higher relative uncertainty and less precise estimates in the later years. In contrast, the USA maintained fairly stable relative uncertainty throughout the years, indicating that the relative precision of the prevalence estimates remained consistent over time. Therefore, the USA will be used for further modeling of Alzheimer’s Disease.
Linear Modeling
usa = alz_rate %>%
filter(location_name == "United States of America") %>%
arrange(year)
mod = lm(val ~ year, data = usa)
summary(mod)##
## Call:
## lm(formula = val ~ year, data = usa)
##
## Residuals:
## Min 1Q Median 3Q Max
## -25.751 -15.097 1.153 9.456 58.219
##
## Coefficients:
## Estimate Std. Error t value Pr(>|t|)
## (Intercept) -2.204e+04 6.485e+02 -33.98 <2e-16 ***
## year 1.158e+01 3.232e-01 35.84 <2e-16 ***
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
##
## Residual standard error: 18.49 on 32 degrees of freedom
## Multiple R-squared: 0.9757, Adjusted R-squared: 0.9749
## F-statistic: 1285 on 1 and 32 DF, p-value: < 2.2e-16The linear model has high \[{R^2}\] value at 0.98, so 98% of variation in Alzheimer’s Disease rate in USA is explained by linear regression model. So we can assume that the overall fit is strong.
Plotting the model
ggplot(usa, aes(x = year, y = val)) +
geom_point() +
geom_smooth(method = "lm", se = TRUE, color = "blue") +
labs(
title = "Linear regression of Alzheimer's prevalence in US",
x = "Year",
y = "Prevalence rate per 100K"
)
The U.S. Alzheimer’s prevalence rate shows increasing trend from 1990 to 2023. However, some parts of the observed values deviate from the fitted regression line, particularly in the middle and later years. This suggests that although prevalence generally increases over time, the relationship is not perfectly linear.
Residual plot
res = resid(mod)
hist(res,
breaks = 20,
main = "Histogram of residuals",
xlab = "Residual",
col = "gray")
The residuals do not look symmetrical at 0, meaning the model is not fitting the data well. Because the prevalence rate appears to increase at an accelerating rate, a simple linear model may not correctly capture the observed trend.
plot(
fitted(mod),
resid(mod),
xlab = "Fitted Values",
ylab = "Residuals",
main = "Residual Plot"
)
abline(h = 0, lty = 2)
The residual plot shows a U-shaped pattern rather than random scattering around zero. Residuals are positive at lower fitted values, become negative in the middle, and become positive again at higher fitted values. This pattern indicates that the relationship is nonlinear and that a simple linear regression model does not capture the trend in Alzheimer’s prevalence well.
Enhanced model
Using log transformed model to see if it fits the data better.
log_mod = lm(log(val) ~ year, data = usa)
summary(mod)##
## Call:
## lm(formula = val ~ year, data = usa)
##
## Residuals:
## Min 1Q Median 3Q Max
## -25.751 -15.097 1.153 9.456 58.219
##
## Coefficients:
## Estimate Std. Error t value Pr(>|t|)
## (Intercept) -2.204e+04 6.485e+02 -33.98 <2e-16 ***
## year 1.158e+01 3.232e-01 35.84 <2e-16 ***
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
##
## Residual standard error: 18.49 on 32 degrees of freedom
## Multiple R-squared: 0.9757, Adjusted R-squared: 0.9749
## F-statistic: 1285 on 1 and 32 DF, p-value: < 2.2e-16Plotting the enhanced model
ggplot(usa, aes(x = year, y = log(val))) +
geom_point() +
geom_smooth(method = 'lm', se = TRUE, color = 'blue') +
labs(title = "Linear regression of Alzheimer's prevalence in US- Enhanced Model",
x = 'year',
y = 'Log Prevalence rate per 100K')
The transformed values follow the fitted regression line more closely than the original scale, suggesting that the log transformation improves the linear fit. However, the most recent observations still deviate from the line, indicating that some nonlinearity remains.
Residual plot of enhanced model
res_en = resid(log_mod)
hist(res_en,
breaks = 20,
main = "Histogram of residuals- Enhanced Model",
xlab = "Residual",
col = "gray")
As seen above,
plot(
fitted(log_mod),
resid(log_mod),
xlab = "Fitted Values",
ylab = "Residuals",
main = "Residual Plot- Enhanced Model"
)
abline(h = 0, lty = 2)
The residual plot still shows a curved pattern rather than random scattering around zero. Residuals tend to be positive at lower fitted values, negative in the middle, and positive again at higher fitted values. This suggests that the log-transformed linear model also does not fully capture the nonlinear relationship in the data.
Conclusion
Overall, this project showed that neurological disease trends are different across countries, and an increase in the number of cases does not always mean an increase in prevalence rate. Alzheimer’s disease was selected for further analysis because it showed clear changes over time across several countries. The linear regression model showed a strong relationship between year and Alzheimer’s prevalence rate, but the residual analysis showed that the relationship was not perfectly linear. Therefore, although the linear model explains most of the variation in prevalence rate, it may not fully capture the pattern in the data.