Rationale

Cultivation Theory says the assumptions or perceived norms about crime risk, race, gender and those types of norms depend upon the audience’s absorption of TV content. People get assumptions about norms and how things are in the real world from TV content, especially when they are heavy consumers.

In this analysis, I surveyed 400 television viewers and examined the relationship between the number of hours each consumes (independent variable) and the correlation of their perceptions of the percentage of the population who are employed as doctors, law enforcement or other first responders (dependent variable). Viewers voluntarily had an electronic device attached to their television to record the amount of hours weekly viewing for a six-month period.

Hypothesis

I surmise those who watch higher amounts of television (IV) will perceive a higher percentage of the population is employed as medical professionals, first responders and law enforcement/criminal justice officials (DV).

Variables & method

The histogram of IV (number of hours watched) indicates that most values fall between about 25 and 40, with the highest counts around 35. The distribution is somewhat bell-shaped but not perfectly normal, with a few irregularities. Overall, IV appears to have a reasonable spread without clear extreme outliers. As expected, there are a handful who watch 60 hours a week, and a handful who watch close to no television at all.

The DV (percentage of people who estimate a percentage of those employed in the aforementioned professions) shows that most scores fall between about 40 and 65, with a peak at around 43 (highest) and 53 (second highest). The spread somewhat follows a bell curve model, with the highest concentrated in the center.

The scatterplot of DV versus IV shows a clear positive linear trend. As the IV increases, DV increases. The regression line fits the general pattern of the points, supporting the idea of a positive relationship between the two variables.

The outliers table shows the 10 highest leverage values — 164, 360, 359, etc. — but the leverage values themselves are small, ranging from .03 down to .01, showing no extreme differences. Thus, there is no need to remove any outliers.

The regression analysis shows a clear, statistically significant relationship between IV and DV. We are most concerned with the p-value (probability), which shows 0. Thus, it is unlikely the pattern was created at random.

The model fit statistics table indicates that the regression explains roughly 31% of the variation in the dependent variable.

Results & discussion

The results supported the hypothesis, which aligns with Cultivation Theory. The higher amounts of television consumed by viewers has a direct correlation with the perceptions of the percentage of citizens employed as medical professionals, first responders and law enforcement.

Leverage estimates for 10 largest outliers
Row # Leverage
164 0.0305
360 0.0207
359 0.0194
371 0.0174
72 0.0162
201 0.0159
265 0.0159
392 0.0148
44 0.0144
97 0.0144
Regression Analysis Results
Coefficient Estimates
Term Estimate Std. Error t p-value
(Intercept) 23.2076 2.2026 10.5363 0.0000
IV 0.8440 0.0630 13.4056 0.0000
Model Fit Statistics
Overall Regression Performance
R-squared Adj. R-squared F-statistic df (model) df (residual) Residual Std. Error
0.3111 0.3093 179.7107 1.0000 398.0000 9.7373

Code

Here is the R script used to produce the results.

##################################################
# 1. Install and load required packages
##################################################
if (!require("tidyverse")) install.packages("tidyverse")
if (!require("gt")) install.packages("gt")
if (!require("gtExtras")) install.packages("gtExtras")

library(tidyverse)
library(gt)
library(gtExtras)


##################################################
# 2. Read in the dataset
##################################################
# Replace "YOURFILENAME.csv" with the actual filename
mydata <- read.csv("Cultivation.csv")


knitr::opts_chunk$set(message = FALSE, warning = FALSE)



##################################################
# 3. Define dependent variable (DV) and independent variable (IV)
##################################################
# Replace YOURDVNAME and YOURIVNAME with actual column names
mydata$DV <- mydata$pct
mydata$IV <- mydata$video


##################################################
# 4. Explore distributions of DV and IV
##################################################
# Make a histogram for DV
DVGraph <- ggplot(mydata, aes(x = DV)) + 
  geom_histogram(color = "black", fill = "#1f78b4")

# Make a histogram for IV
IVGraph <- ggplot(mydata, aes(x = IV)) + 
  geom_histogram(color = "black", fill = "#1f78b4")


##################################################
# 5. Fit and summarize initial regression model
##################################################
# Suppress scientific notation
options(scipen = 999)

# Fit model
myreg <- lm(DV ~ IV, data = mydata)

# Model summary
summary(myreg)


##################################################
# 6. Visualize regression and check for bivariate outliers
##################################################
# Create scatterplot with regression line as a ggplot object
RegressionPlot <- ggplot(mydata, aes(x = IV, y = DV)) +
  geom_point(color = "#1f78b4") +
  geom_smooth(method = "lm", se = FALSE, color = "red") +
  labs(
    title = "Scatterplot of DV vs IV with Regression Line",
    x = "Independent Variable (IV)",
    y = "Dependent Variable (DV)"
  ) +
  theme_minimal()


##################################################
# 7. Check for potential outliers (high leverage points)
##################################################
# Calculate leverage values
hat_vals <- hatvalues(myreg)

# Rule of thumb: leverage > 2 * (number of predictors + 1) / n may be influential
threshold <- 2 * (length(coef(myreg)) / nrow(mydata))

# Create table showing 10 largest leverage values
outliers <- data.frame(
  Obs = 1:nrow(mydata),
  Leverage = hatvalues(myreg)
) %>%
  arrange(desc(Leverage)) %>%
  slice_head(n = 10)

# Format as a gt table
outliers_table <- outliers %>%
  gt() %>%
  tab_header(
    title = "Leverage estimates for 10 largest outliers"
  ) %>%
  cols_label(
    Obs = "Row #",
    Leverage = "Leverage"
  ) %>%
  fmt_number(
    columns = Leverage,
    decimals = 4
  )


##################################################
# 8. Create nicely formatted regression results tables
##################################################
# --- Coefficient-level results ---
reg_results <- as.data.frame(coef(summary(myreg))) %>%
  tibble::rownames_to_column("Term") %>%
  rename(
    Estimate = Estimate,
    `Std. Error` = `Std. Error`,
    t = `t value`,
    `p-value` = `Pr(>|t|)`
  )

reg_table <- reg_results %>%
  gt() %>%
  tab_header(
    title = "Regression Analysis Results",
    subtitle = "Coefficient Estimates"
  ) %>%
  fmt_number(
    columns = c(Estimate, `Std. Error`, t, `p-value`),
    decimals = 4
  )


# --- Model fit statistics ---
reg_summary <- summary(myreg)

fit_stats <- tibble::tibble(
  `R-squared` = reg_summary$r.squared,
  `Adj. R-squared` = reg_summary$adj.r.squared,
  `F-statistic` = reg_summary$fstatistic[1],
  `df (model)` = reg_summary$fstatistic[2],
  `df (residual)` = reg_summary$fstatistic[3],
  `Residual Std. Error` = reg_summary$sigma
)

fit_table <- fit_stats %>%
  gt() %>%
  tab_header(
    title = "Model Fit Statistics",
    subtitle = "Overall Regression Performance"
  ) %>%
  fmt_number(
    columns = everything(),
    decimals = 4
  )


##################################################
# 9. Final print of key graphics and tables
##################################################
DVGraph
IVGraph
RegressionPlot
outliers_table
reg_table
fit_table