Sampling Distributions and the Central Limit Theorem: Diamonds Analysis

Packages and Data Loading

library(Stat2Data)
library(dplyr)
library(ggplot2)

# Load the Diamonds dataset
data("Diamonds")

Step 1: Population Distribution

We begin by examining the population distribution of total diamond prices (TotalPrice).

# Make a histogram of the population variable TotalPrice
ggplot(Diamonds, aes(x = TotalPrice)) +
  geom_histogram(fill = "skyblue", color = "black", bins = 30) +
  labs(
    title = "Population Distribution of Diamond Prices",
    x = "Total Price (in USD)",
    y = "Count"
  ) +
  theme_minimal()

# Calculate and store population parameters
mu <- mean(Diamonds$TotalPrice)
sigma <- sd(Diamonds$TotalPrice)

mu

## [1] 7450.012

sigma

## [1] 7780.894

Analysis

The shape of this population distribution is skewed to the right. The units of measurement for TotalPrice are USD.

---

## Step 2: Simulated Sampling Distribution

Next, we draw 1,000 random samples of size \(n = 30\) from the population with replacement and calculate the sample mean for each.

set.seed(42)
n <- 30

# Simulate 1000 samples of size n and calculate the mean of each
sample_means <- replicate(1000, {
  sample_data <- sample(Diamonds$TotalPrice, size = n, replace = TRUE)
  mean(sample_data)
})

# Convert to data frame for graphing
df_means <- data.frame(sample_means)

# Graph the sampling distribution of sample means
ggplot(df_means, aes(x = sample_means)) +
  geom_histogram(fill = "lightgreen", color = "black", bins = 30) +
  labs(
    title = "Sampling Distribution of Sample Means (n = 30)",
    x = "Sample Mean Total Price ($)",
    y = "Count"
  ) +
  theme_minimal()

# Summary statistics of simulated sample means
mean_sim <- mean(sample_means)
sd_sim <- sd(sample_means)

mean_sim

## [1] 7421.124

sd_sim

## [1] 1405.82

Analysis

The shape of sample_means compared to the shape of the population is much more symmetrical, but not completely, compared to the right-skewed population graph.

---

## Step 3: Central Limit Theorem Overlay

The Central Limit Theorem predicts that the sampling distribution of sample means is approximately normal with center \(\mu\) and standard error \(SE = \frac{\sigma}{\sqrt{n}}\).

# Compute theoretical Standard Error
SE <- sigma / sqrt(n)

# Density histogram with superimposed CLT normal curve
ggplot(df_means, aes(x = sample_means)) +
  geom_histogram(aes(y = after_stat(density)), fill = "lightgreen", color = "black", bins = 30) +
  stat_function(fun = dnorm, args = list(mean = mu, sd = SE), color = "darkblue", linewidth = 1.2) +
  labs(
    title = "Sampling Distribution vs. CLT Normal Curve",
    x = "Sample Mean Total Price ($)",
    y = "Density"
  ) +
  theme_minimal()

Analysis

The theoretical parameters (\(\mu \approx 7450\) and \(SE \approx 1420.59\)) closely match the empirical simulation statistics (mean_sim \(\approx 7421.12\) and sd_sim \(\approx 1405.82\)). Small differences between the theoretical model and simulation results are expected due to random sampling variability in 1,000 iterations.

---

## Step 4: Probability Calculation with pnorm()

We calculate the theoretical probability that a random sample of size \(n = 30\) has a mean TotalPrice greater than $9,800 using pnorm(), and compare it to the proportion in our simulation.

# CLT theoretical probability: P(sample mean > 9800)
clt_prob <- pnorm(9800, mean = mu, sd = SE, lower.tail = FALSE)

# Empirical simulation probability
sim_prob <- mean(sample_means > 9800)

clt_prob

## [1] 0.04904003

sim_prob

## [1] 0.062

Analysis

clt_prob has a theoretical value of 0.0490, while sim_prob has an empirical value of 0.062. These two values are close, but not identical, due to sampling variability in our simulation.

---

## Step 5: Cutoff Calculation with qnorm()

Finally, we determine the cutoff price above which 90% of sample means will fall (meaning 10% fall below) using qnorm(), and check it against the 10th percentile of our simulated sample means.

# Theoretical cutoff using CLT (10th percentile)
clt_cutoff <- qnorm(0.10, mean = mu, sd = SE)

# Empirical cutoff from simulated sample means
sim_cutoff <- quantile(sample_means, 0.10)

clt_cutoff

## [1] 5629.452

sim_cutoff

##      10% 
## 5776.638

Analysis

The clt_cutoff value is approximately $5,629. This means there is a 10% probability that a random sample of 30 diamonds will have an average price of ~$5,629 or less (and a 90% probability that the sample mean will be above this cutoff).