Load Data

raw     <- read_csv("/Users/christinamac/Downloads/archive/Viral_Social_Media_Trends.csv")
cleaned <- read_csv("/Users/christinamac/Downloads/archive/Cleaned_Viral_Social_Media_Trends.csv")

Filter Both Datasets

filter_data <- function(df) {
  df %>%
    filter(Region %in% c("USA", "Canada")) %>%
    filter(str_to_lower(Hashtag) == "#education")
}

raw_filtered     <- filter_data(raw)
cleaned_filtered <- filter_data(cleaned)

# Binary engagement variable: 1 = High, 0 = Medium or Low
# Binary content type variable: 1 = Reel, 0 = all other types
cleaned_filtered <- cleaned_filtered %>%
  mutate(
    Engagement_Binary    = if_else(Engagement_Level == "High", 1, 0),
    Content_Type_Binary  = if_else(Content_Type == "Reel", 1, 0)
  )

cat("Engagement_Binary distribution:\n")
## Engagement_Binary distribution:
print(table(cleaned_filtered$Engagement_Binary))
## 
##  0  1 
## 95 47
cat("\nContent_Type_Binary distribution (1 = Reel):\n")
## 
## Content_Type_Binary distribution (1 = Reel):
print(table(cleaned_filtered$Content_Type_Binary))
## 
##   0   1 
## 120  22

EDA: Cleaned Dataset (USA/Canada, #Education)

eda_data <- cleaned_filtered
glimpse(eda_data)
## Rows: 142
## Columns: 13
## $ Post_ID             <chr> "Post_100", "Post_115", "Post_135", "Post_146", "P…
## $ Post_Date           <date> 2023-05-20, 2022-07-17, 2023-07-25, 2022-04-08, 2…
## $ Platform            <chr> "YouTube", "Instagram", "TikTok", "Instagram", "In…
## $ Hashtag             <chr> "#Education", "#Education", "#Education", "#Educat…
## $ Content_Type        <chr> "Post", "Tweet", "Live Stream", "Reel", "Live Stre…
## $ Region              <chr> "Canada", "Canada", "Canada", "Canada", "USA", "US…
## $ Views               <dbl> 3096420, 1599554, 707841, 964498, 4709770, 4221739…
## $ Likes               <dbl> 364521, 364748, 133933, 194879, 389553, 291223, 25…
## $ Shares              <dbl> 73308, 16705, 46058, 76029, 55435, 61415, 23167, 8…
## $ Comments            <dbl> 29082, 8949, 45912, 34998, 16799, 44293, 5670, 335…
## $ Engagement_Level    <chr> "Low", "High", "High", "High", "Medium", "Low", "L…
## $ Engagement_Binary   <dbl> 0, 1, 1, 1, 0, 0, 0, 1, 0, 1, 0, 1, 0, 0, 0, 0, 0,…
## $ Content_Type_Binary <dbl> 0, 0, 0, 1, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 1,…

Missing Values

cat("Total NAs:", sum(is.na(eda_data)))
## Total NAs: 0
print(colSums(is.na(eda_data)))
##             Post_ID           Post_Date            Platform             Hashtag 
##                   0                   0                   0                   0 
##        Content_Type              Region               Views               Likes 
##                   0                   0                   0                   0 
##              Shares            Comments    Engagement_Level   Engagement_Binary 
##                   0                   0                   0                   0 
## Content_Type_Binary 
##                   0

Categorical Distributions

cat("=== PLATFORM ===\n");       print(table(eda_data$Platform))
## === PLATFORM ===
## 
## Instagram    TikTok   Twitter   YouTube 
##        36        30        36        40
cat("\n=== REGION ===\n");       print(table(eda_data$Region))
## 
## === REGION ===
## 
## Canada    USA 
##     78     64
cat("\n=== CONTENT TYPE ===\n"); print(table(eda_data$Content_Type))
## 
## === CONTENT TYPE ===
## 
## Live Stream        Post        Reel      Shorts       Tweet       Video 
##          24          34          22          15          27          20
cat("\n=== ENGAGEMENT LEVEL ===\n"); print(table(eda_data$Engagement_Level))
## 
## === ENGAGEMENT LEVEL ===
## 
##   High    Low Medium 
##     47     49     46

Numeric Summary

print(summary(eda_data[, c("Views", "Likes", "Shares", "Comments")]))
##      Views             Likes            Shares         Comments    
##  Min.   : 112559   Min.   :  7372   Min.   :  435   Min.   :   32  
##  1st Qu.:1033473   1st Qu.:136294   1st Qu.:25961   1st Qu.:13785  
##  Median :2572378   Median :264404   Median :55326   Median :25024  
##  Mean   :2515903   Mean   :261113   Mean   :51941   Mean   :24411  
##  3rd Qu.:3922257   3rd Qu.:377607   3rd Qu.:76555   3rd Qu.:34514  
##  Max.   :4956515   Max.   :499312   Max.   :99857   Max.   :49993

Visualization 1: Engagement Level by Platform

ggplot(eda_data, aes(x = Platform, fill = Engagement_Level)) +
  geom_bar(position = "fill") +
  scale_y_continuous(labels = scales::percent) +
  labs(title = "Engagement Level Distribution by Platform",
       subtitle = "USA/Canada — #Education Posts",
       x = "Platform", y = "Proportion", fill = "Engagement Level") +
  theme_minimal()

Visualization 2: Average Views by Content Type

eda_data %>%
  group_by(Content_Type) %>%
  summarise(Avg_Views = mean(Views)) %>%
  arrange(desc(Avg_Views)) %>%
  ggplot(aes(x = reorder(Content_Type, Avg_Views), y = Avg_Views, fill = Content_Type)) +
  geom_col(show.legend = FALSE) +
  coord_flip() +
  labs(title = "Average Views by Content Type",
       subtitle = "USA/Canada — #Education Posts",
       x = "Content Type", y = "Average Views") +
  theme_minimal()

Visualization 3: Views Distribution by Platform

ggplot(eda_data, aes(x = Platform, y = Views, fill = Platform)) +
  geom_boxplot(show.legend = FALSE) +
  labs(title = "Views Distribution by Platform",
       subtitle = "USA/Canada — #Education Posts",
       x = "Platform", y = "Views") +
  theme_minimal()

Correlation Matrix

eda_data %>%
  mutate(Content_Type_Num = as.numeric(factor(Content_Type))) %>%
  select(Views, Likes, Shares, Comments, Content_Type_Num) %>%
  cor() %>%
  round(3) %>%
  print()
##                   Views  Likes Shares Comments Content_Type_Num
## Views             1.000  0.142  0.141    0.004           -0.065
## Likes             0.142  1.000  0.010    0.094           -0.117
## Shares            0.141  0.010  1.000    0.115            0.014
## Comments          0.004  0.094  0.115    1.000           -0.052
## Content_Type_Num -0.065 -0.117  0.014   -0.052            1.000

Average Metrics by Region

eda_data %>%
  group_by(Region) %>%
  summarise(
    Avg_Views    = round(mean(Views), 0),
    Avg_Likes    = round(mean(Likes), 0),
    Avg_Shares   = round(mean(Shares), 0),
    Avg_Comments = round(mean(Comments), 0),
    Posts        = n()
  ) %>%
  arrange(desc(Avg_Views))
## # A tibble: 2 × 6
##   Region Avg_Views Avg_Likes Avg_Shares Avg_Comments Posts
##   <chr>      <dbl>     <dbl>      <dbl>        <dbl> <int>
## 1 USA      2739953    263244      49387        24455    64
## 2 Canada   2332068    259365      54036        24376    78

Visualization 4: Posts Over Time

eda_data %>%
  mutate(Month = floor_date(as.Date(Post_Date), "month")) %>%
  count(Month) %>%
  ggplot(aes(x = Month, y = n)) +
  geom_line(color = "steelblue", linewidth = 1) +
  geom_point(color = "steelblue") +
  labs(title = "Number of Education Posts Over Time",
       subtitle = "USA/Canada — #Education Posts",
       x = "Month", y = "Post Count") +
  theme_minimal()

Per-Platform Analysis

library(broom)
library(nnet)
library(caret)
library(randomForest)
library(gbm)

# Storage for accuracy table
accuracy_results <- list()

# ── Helper: K-Means cluster purity ───────────────────────────────────────────
kmeans_purity <- function(clusters, true_labels) {
  df <- data.frame(cluster = clusters, label = true_labels)
  majority <- df %>%
    group_by(cluster) %>%
    summarise(majority_n = max(table(label)), total = n(), .groups = "drop")
  round(sum(majority$majority_n) / sum(majority$total) * 100, 2)
}

# ── Main per-platform function ────────────────────────────────────────────────
run_platform <- function(platform_name, full_data) {

  data <- full_data %>%
    filter(Platform == platform_name) %>%
    mutate(
      Engagement_Level    = factor(Engagement_Level, levels = c("Low", "Medium", "High")),
      Content_Type_Binary = if_else(Content_Type == "Reel", 1, 0),
      Month               = as.numeric(format(as.Date(Post_Date), "%m")),
      Region              = factor(Region)
    )

  cat("\n\n---\n\n")
  cat("##", platform_name, "Posts: Slice & EDA\n\n")
  cat("**Posts (USA/Canada, #Education):**", nrow(data), "\n\n")

  # ── EDA ───────────────────────────────────────────────────────────────────
  cat("**Missing values:**", sum(is.na(data)), "\n\n")
  cat("**Region:**\n"); print(table(data$Region))
  cat("\n**Content Type:**\n"); print(table(data$Content_Type))
  cat("\n**Engagement Level:**\n"); print(table(data$Engagement_Level))
  cat("\n**Numeric Summary:**\n"); print(summary(data[, c("Views","Likes","Shares","Comments")]))

  # Viz 1: Engagement Level Distribution
  p1 <- ggplot(data, aes(x = Engagement_Level, fill = Engagement_Level)) +
    geom_bar(show.legend = FALSE) +
    labs(title   = paste("Engagement Level —", platform_name),
         subtitle = "USA/Canada — #Education Posts",
         x = "Engagement Level", y = "Count")
  print(p1)

  # Viz 2: Views by Content Type
  p2 <- ggplot(data, aes(x = Content_Type, y = Views, fill = Content_Type)) +
    geom_boxplot(show.legend = FALSE) +
    labs(title    = paste("Views by Content Type —", platform_name),
         subtitle  = "USA/Canada — #Education Posts",
         x = "Content Type", y = "Views")
  print(p2)

  # Viz 3: Views by Region
  p3 <- ggplot(data, aes(x = Region, y = Views, fill = Region)) +
    geom_boxplot(show.legend = FALSE) +
    labs(title    = paste("Views by Region —", platform_name),
         subtitle  = "USA/Canada — #Education Posts",
         x = "Region", y = "Views")
  print(p3)

  # Viz 4: Posts Over Time
  p4 <- data %>%
    mutate(Month_dt = floor_date(as.Date(Post_Date), "month")) %>%
    count(Month_dt) %>%
    ggplot(aes(x = Month_dt, y = n)) +
    geom_line(color = "steelblue", linewidth = 1) +
    geom_point(color = "steelblue") +
    labs(title    = paste(platform_name, "Education Posts Over Time"),
         subtitle  = "USA/Canada — #Education Posts",
         x = "Month", y = "Post Count")
  print(p4)

  # Correlation Matrix
  cat("\n**Correlation Matrix:**\n")
  corr_out <- data %>%
    mutate(Content_Type_Num = as.numeric(factor(Content_Type))) %>%
    select(Views, Likes, Shares, Comments, Content_Type_Num, Content_Type_Binary) %>%
    cor() %>% round(3)
  print(corr_out)

  # ── Multinomial Logistic Regression ──────────────────────────────────────
  cat("\n\n###", platform_name, "— Multinomial Logistic Regression\n\n")

  log_model <- multinom(
    Engagement_Level ~ Month + Region + Content_Type_Binary + Likes + Shares,
    data = data, trace = FALSE
  )

  log_pred <- predict(log_model, type = "class")
  log_accuracy <- round(mean(log_pred == data$Engagement_Level) * 100, 2)

  cat("**AIC:**", round(AIC(log_model), 4), "\n")
  null_model <- multinom(Engagement_Level ~ 1, data = data, trace = FALSE)
  cat("**McFadden R²:**",
      round(as.numeric(1 - logLik(log_model) / logLik(null_model)), 4), "\n")
  cat("**Training Accuracy:**", log_accuracy, "%\n\n")

  tidy_out <- tidy(log_model) %>%
    mutate(odds_ratio = round(exp(estimate), 4),
           across(where(is.numeric), ~ round(., 4))) %>%
    select(y.level, term, estimate, odds_ratio, std.error, p.value)
  print(tidy_out)

  # Confusion heatmap
  p_log <- data %>%
    mutate(Predicted = predict(log_model, type = "class")) %>%
    count(Actual = Engagement_Level, Predicted) %>%
    ggplot(aes(x = Actual, y = Predicted, fill = n)) +
    geom_tile(color = "white") +
    geom_text(aes(label = n), size = 5) +
    scale_fill_gradient(low = "#ede7f6", high = "#6D31FD") +
    labs(title    = paste("Predicted vs. Actual —", platform_name),
         subtitle  = "Multinomial Logistic Regression",
         x = "Actual", y = "Predicted", fill = "Count")
  print(p_log)

  # ── ML Models ────────────────────────────────────────────────────────────
  cat("\n\n###", platform_name, "— Machine Learning Models\n\n")

  ml_data <- data %>%
    select(Engagement_Level, Month, Region, Content_Type_Binary, Likes, Shares)

  set.seed(123)
  train_idx  <- createDataPartition(ml_data$Engagement_Level, p = 0.7, list = FALSE)
  train_data <- ml_data[train_idx, ]
  test_data  <- ml_data[-train_idx, ]
  cat("Train:", nrow(train_data), "| Test:", nrow(test_data), "\n")

  # KNN
  knn_model <- train(Engagement_Level ~ ., data = train_data, method = "knn",
                     trControl = trainControl(method = "cv", number = 3), tuneLength = 5)
  knn_pred  <- predict(knn_model, test_data)
  knn_cm    <- confusionMatrix(knn_pred, test_data$Engagement_Level)
  cat("\n**KNN Accuracy:**", round(knn_cm$overall["Accuracy"] * 100, 2), "%\n")
  print(knn_cm$table)

  # K-Means
  km_scaled <- ml_data %>%
    mutate(Region_Num = as.numeric(Region)) %>%
    select(Month, Region_Num, Content_Type_Binary, Likes, Shares) %>%
    scale()
  km_model  <- kmeans(km_scaled, centers = 3, nstart = 25)
  km_purity <- kmeans_purity(km_model$cluster, ml_data$Engagement_Level)
  cat("\n**K-Means Purity:**", km_purity, "%\n")
  print(table(Cluster = km_model$cluster, Engagement = ml_data$Engagement_Level))

  # Random Forest
  rf_model <- train(Engagement_Level ~ ., data = train_data, method = "rf",
                    trControl = trainControl(method = "cv", number = 3), importance = TRUE)
  rf_pred  <- predict(rf_model, test_data)
  rf_cm    <- confusionMatrix(rf_pred, test_data$Engagement_Level)
  cat("\n**Random Forest Accuracy:**", round(rf_cm$overall["Accuracy"] * 100, 2), "%\n")
  print(rf_cm$table)

  p_rf <- data.frame(
    Variable   = rownames(importance(rf_model$finalModel)),
    Importance = rowMeans(importance(rf_model$finalModel))
  ) %>%
    arrange(Importance) %>%
    ggplot(aes(x = reorder(Variable, Importance), y = Importance)) +
    geom_col(fill = "#6D31FD") +
    coord_flip() +
    labs(title    = paste("RF Variable Importance —", platform_name),
         x = "", y = "Mean Decrease Accuracy")
  print(p_rf)

  # Gradient Boosting
  train_gbm <- train_data %>%
    mutate(Outcome = as.numeric(Engagement_Level) - 1, Region_Num = as.numeric(Region))
  test_gbm  <- test_data %>%
    mutate(Outcome = as.numeric(Engagement_Level) - 1, Region_Num = as.numeric(Region))

  boost_fit <- gbm(Outcome ~ Month + Region_Num + Content_Type_Binary + Likes + Shares,
                   data = train_gbm, distribution = "multinomial",
                   n.trees = 100, interaction.depth = 2, shrinkage = 0.1,
                   n.minobsinnode = 3, verbose = FALSE)

  boost_probs <- predict(boost_fit, test_gbm, n.trees = 100, type = "response")
  boost_pred  <- factor(c("Low","Medium","High")[apply(boost_probs, 1, which.max)],
                        levels = c("Low","Medium","High"))
  boost_acc   <- round(mean(boost_pred == test_data$Engagement_Level) * 100, 2)
  cat("\n**Gradient Boosting Accuracy:**", boost_acc, "%\n")

  # Store results
  accuracy_results[[platform_name]] <<- list(
    log  = log_accuracy,
    knn  = round(knn_cm$overall["Accuracy"] * 100, 2),
    rf   = round(rf_cm$overall["Accuracy"]  * 100, 2),
    gb   = boost_acc,
    km   = km_purity
  )

  invisible(NULL)
}
platforms <- c("YouTube", "TikTok", "Instagram", "Twitter")
for (plt in platforms) {
  run_platform(plt, cleaned_filtered)
}

YouTube Posts: Slice & EDA

Posts (USA/Canada, #Education): 40

Missing values: 0

Region:

Canada USA 19 21

Content Type:

Live Stream Post Reel Shorts Tweet Video 6 10 6 6 8 4

Engagement Level:

Low Medium High 14 16 10

Numeric Summary: Views Likes Shares Comments
Min. : 218047 Min. : 7372 Min. : 435 Min. : 349
1st Qu.:1307542 1st Qu.:119807 1st Qu.:21562 1st Qu.:10942
Median :2557428 Median :222460 Median :55592 Median :23334
Mean :2506645 Mean :233537 Mean :50211 Mean :22489
3rd Qu.:3784346 3rd Qu.:314760 3rd Qu.:74842 3rd Qu.:33477
Max. :4948346 Max. :488199 Max. :99857 Max. :46321
Correlation Matrix: Views Likes Shares Comments Content_Type_Num Views 1.000 0.268 0.289 0.144 -0.141 Likes 0.268 1.000 0.003 0.190 -0.067 Shares 0.289 0.003 1.000 0.051 -0.035 Comments 0.144 0.190 0.051 1.000 0.208 Content_Type_Num -0.141 -0.067 -0.035 0.208 1.000 Content_Type_Binary 0.108 0.058 0.040 0.025 -0.078 Content_Type_Binary Views 0.108 Likes 0.058 Shares 0.040 Comments 0.025 Content_Type_Num -0.078 Content_Type_Binary 1.000

YouTube — Multinomial Logistic Regression

AIC: 105.8217 McFadden R²: 0.0535 Training Accuracy: 45 %

A tibble: 12 × 6

y.level term estimate odds_ratio std.error p.value 1 Medium (Intercept) 0.837 2.31 0 0
2 Medium Month -0.0174 0.983 0 0
3 Medium RegionUSA 0.194 1.21 0 0
4 Medium Content_Type_Binary -0.592 0.553 0 0
5 Medium Likes 0 1 0 0.350 6 Medium Shares 0 1 0 0.696 7 High (Intercept) -1.49 0.225 0 0
8 High Month -0.0282 0.972 0 0
9 High RegionUSA 0.0748 1.08 0 0
10 High Content_Type_Binary -0.998 0.369 0 0
11 High Likes 0 1 0 0.173 12 High Shares 0 1 0 0.264

YouTube — Machine Learning Models

Train: 29 | Test: 11

KNN Accuracy: 27.27 % Reference Prediction Low Medium High Low 0 1 2 Medium 4 3 1 High 0 0 0

K-Means Purity: 42.5 % Engagement Cluster Low Medium High 1 5 8 5 2 6 6 4 3 3 2 1

Random Forest Accuracy: 27.27 % Reference Prediction Low Medium High Low 1 2 0 Medium 3 0 1 High 0 2 2 Gradient Boosting Accuracy: 27.27 %

TikTok Posts: Slice & EDA

Posts (USA/Canada, #Education): 30

Missing values: 0

Region:

Canada USA 18 12

Content Type:

Live Stream Post Reel Shorts Tweet Video 5 7 8 3 4 3

Engagement Level:

Low Medium High 9 8 13

Numeric Summary: Views Likes Shares Comments
Min. : 136335 Min. : 9101 Min. : 448 Min. : 4830
1st Qu.:1612535 1st Qu.:127475 1st Qu.:36727 1st Qu.:15835
Median :2849527 Median :282679 Median :60335 Median :28668
Mean :2837325 Mean :258270 Mean :58554 Mean :27738
3rd Qu.:4254218 3rd Qu.:380406 3rd Qu.:81089 3rd Qu.:38141
Max. :4956515 Max. :482311 Max. :99451 Max. :49993
Correlation Matrix: Views Likes Shares Comments Content_Type_Num Views 1.000 0.546 0.275 -0.198 0.154 Likes 0.546 1.000 0.233 0.026 0.171 Shares 0.275 0.233 1.000 0.309 -0.148 Comments -0.198 0.026 0.309 1.000 -0.049 Content_Type_Num 0.154 0.171 -0.148 -0.049 1.000 Content_Type_Binary 0.386 0.295 0.055 0.044 -0.039 Content_Type_Binary Views 0.386 Likes 0.295 Shares 0.055 Comments 0.044 Content_Type_Num -0.039 Content_Type_Binary 1.000

TikTok — Multinomial Logistic Regression

AIC: 79.1272 McFadden R²: 0.1461 Training Accuracy: 50 %

A tibble: 12 × 6

y.level term estimate odds_ratio std.error p.value 1 Medium (Intercept) 1.94 6.94 0 0
2 Medium Month -0.250 0.778 0 0
3 Medium RegionUSA 0.649 1.91 0 0
4 Medium Content_Type_Binary 0.160 1.17 0 0
5 Medium Likes 0 1 0 0.0536 6 Medium Shares 0 1 0 0.375 7 High (Intercept) -1.03 0.357 0 0
8 High Month 0.261 1.30 0 0
9 High RegionUSA 1.23 3.41 0 0
10 High Content_Type_Binary 0.780 2.18 0 0
11 High Likes 0 1 0 0.861 12 High Shares 0 1 0 0.162

TikTok — Machine Learning Models

Train: 23 | Test: 7

KNN Accuracy: 42.86 % Reference Prediction Low Medium High Low 0 0 0 Medium 0 0 0 High 2 2 3

K-Means Purity: 46.67 % Engagement Cluster Low Medium High 1 3 2 5 2 4 4 3 3 2 2 5

Random Forest Accuracy: 14.29 % Reference Prediction Low Medium High Low 0 1 2 Medium 1 0 0 High 1 1 1 Gradient Boosting Accuracy: 28.57 %

Instagram Posts: Slice & EDA

Posts (USA/Canada, #Education): 36

Missing values: 0

Region:

Canada USA 21 15

Content Type:

Live Stream Post Reel Shorts Tweet Video 6 8 6 2 7 7

Engagement Level:

Low Medium High 12 12 12

Numeric Summary: Views Likes Shares Comments
Min. : 166638 Min. : 38803 Min. : 2619 Min. : 32
1st Qu.:1133964 1st Qu.:205754 1st Qu.:25707 1st Qu.:11288
Median :2803768 Median :318199 Median :60884 Median :23110
Mean :2604696 Mean :285954 Mean :54056 Mean :22878
3rd Qu.:3920233 3rd Qu.:377428 3rd Qu.:77529 3rd Qu.:30909
Max. :4873492 Max. :499312 Max. :97064 Max. :47576
Correlation Matrix: Views Likes Shares Comments Content_Type_Num Views 1.000 0.012 -0.329 0.162 -0.235 Likes 0.012 1.000 0.041 0.185 -0.127 Shares -0.329 0.041 1.000 0.093 0.031 Comments 0.162 0.185 0.093 1.000 -0.312 Content_Type_Num -0.235 -0.127 0.031 -0.312 1.000 Content_Type_Binary -0.183 0.198 -0.053 -0.159 -0.117 Content_Type_Binary Views -0.183 Likes 0.198 Shares -0.053 Comments -0.159 Content_Type_Num -0.117 Content_Type_Binary 1.000

Instagram — Multinomial Logistic Regression

AIC: 92.1507 McFadden R²: 0.1384 Training Accuracy: 52.78 %

A tibble: 12 × 6

y.level term estimate odds_ratio std.error p.value 1 Medium (Intercept) -0.157 0.855 0 0
2 Medium Month -0.0871 0.917 0 0
3 Medium RegionUSA 0.585 1.80 0 0
4 Medium Content_Type_Binary 0.408 1.50 0 0
5 Medium Likes 0 1 0 0.0676 6 Medium Shares 0 1 0 0.154 7 High (Intercept) 2.95 19.1 0 0
8 High Month -0.183 0.833 0 0
9 High RegionUSA -1.06 0.347 0 0
10 High Content_Type_Binary -1.24 0.290 0 0
11 High Likes 0 1 0 0.696 12 High Shares 0 1 0 0.125

Instagram — Machine Learning Models

Train: 27 | Test: 9

KNN Accuracy: 33.33 % Reference Prediction Low Medium High Low 0 0 2 Medium 2 2 0 High 1 1 1

K-Means Purity: 47.22 % Engagement Cluster Low Medium High 1 5 6 3 2 2 3 1 3 5 3 8

Random Forest Accuracy: 44.44 % Reference Prediction Low Medium High Low 1 0 2 Medium 1 2 0 High 1 1 1 Gradient Boosting Accuracy: 22.22 %

Twitter Posts: Slice & EDA

Posts (USA/Canada, #Education): 36

Missing values: 0

Region:

Canada USA 20 16

Content Type:

Live Stream Post Reel Shorts Tweet Video 7 9 2 4 8 6

Engagement Level:

Low Medium High 14 10 12

Numeric Summary: Views Likes Shares Comments
Min. : 112559 Min. : 31908 Min. : 969 Min. : 723
1st Qu.: 779709 1st Qu.:147811 1st Qu.:24243 1st Qu.:15754
Median :2281209 Median :262282 Median :39185 Median :24476
Mean :2169545 Mean :269281 Mean :46235 Mean :25309
3rd Qu.:3325234 3rd Qu.:396280 3rd Qu.:69159 3rd Qu.:34606
Max. :4952299 Max. :491963 Max. :97838 Max. :48874
Correlation Matrix: Views Likes Shares Comments Content_Type_Num Views 1.000 -0.193 0.252 -0.187 0.038 Likes -0.193 1.000 -0.199 -0.054 -0.387 Shares 0.252 -0.199 1.000 0.023 0.182 Comments -0.187 -0.054 0.023 1.000 -0.023 Content_Type_Num 0.038 -0.387 0.182 -0.023 1.000 Content_Type_Binary 0.173 0.179 0.120 -0.073 -0.055 Content_Type_Binary Views 0.173 Likes 0.179 Shares 0.120 Comments -0.073 Content_Type_Num -0.055 Content_Type_Binary 1.000

Twitter — Multinomial Logistic Regression

AIC: 92.181 McFadden R²: 0.1307 Training Accuracy: 55.56 %

A tibble: 12 × 6

y.level term estimate odds_ratio std.error p.value 1 Medium (Intercept) -1.25 0.287 0 0
2 Medium Month 0.131 1.14 0 0
3 Medium RegionUSA 0.580 1.79 0 0
4 Medium Content_Type_Binary 1.06 2.88 0 0
5 Medium Likes 0 1 0 0.340 6 Medium Shares 0 1 0 0.117 7 High (Intercept) 1.73 5.62 0 0
8 High Month -0.145 0.865 0 0
9 High RegionUSA 0.851 2.34 0 0
10 High Content_Type_Binary -8.02 0.0003 0 0
11 High Likes 0 1 0 0.529 12 High Shares 0 1 0 0.0413

Twitter — Machine Learning Models

Train: 26 | Test: 10

KNN Accuracy: 20 % Reference Prediction Low Medium High Low 2 1 1 Medium 1 0 2 High 1 2 0

K-Means Purity: 44.44 % Engagement Cluster Low Medium High 1 1 1 0 2 8 5 5 3 5 4 7

Random Forest Accuracy: 20 % Reference Prediction Low Medium High Low 1 3 0 Medium 2 0 2 High 1 0 1 Gradient Boosting Accuracy: 10 %

Top 2 Content Types by Platform

cleaned_filtered %>%
  group_by(Platform, Content_Type) %>%
  summarise(Total_Views = sum(Views), .groups = "drop") %>%
  group_by(Platform) %>%
  slice_max(Total_Views, n = 2) %>%
  ungroup() %>%
  ggplot(aes(x = reorder(Content_Type, Total_Views), y = Total_Views / 1e6, fill = Content_Type)) +
  geom_col(show.legend = FALSE) +
  geom_text(aes(label = paste0(round(Total_Views / 1e6, 1), "M")),
            hjust = -0.15, size = 3.5, color = "#6D31FD") +
  coord_flip() +
  facet_wrap(~ Platform, scales = "free") +
  scale_y_continuous(expand = expansion(mult = c(0, 0.3))) +
  labs(title = "Top 2 Content Types by Total Views — by Platform",
       subtitle = "USA/Canada — #Education Posts",
       x = "Content Type", y = "Total Views (Millions)") +
  theme(strip.text = element_text(face = "bold"))

cleaned_filtered %>%
  filter(Engagement_Level == "High") %>%
  count(Platform, Content_Type) %>%
  group_by(Platform) %>%
  slice_max(n, n = 3) %>%
  ungroup() %>%
  ggplot(aes(x = reorder(Content_Type, n), y = n, fill = Content_Type)) +
  geom_col(show.legend = FALSE) +
  geom_text(aes(label = n), hjust = -0.2, size = 3.5, color = "#6D31FD") +
  coord_flip() +
  facet_wrap(~ Platform, scales = "free_y") +
  labs(title = "Content Types Driving Highest Engagement by Platform",
       subtitle = "USA/Canada — #Education Posts — High Engagement Only",
       x = "Content Type", y = "Number of High Engagement Posts") +
  theme(strip.text = element_text(face = "bold"))

Model Accuracy Summary by Platform

library(knitr)

platforms <- c("YouTube", "TikTok", "Instagram", "Twitter")

accuracy_table <- data.frame(
  Platform            = platforms,
  Logistic_Regression = sapply(platforms, function(p) accuracy_results[[p]]$log),
  KNN                 = sapply(platforms, function(p) accuracy_results[[p]]$knn),
  Random_Forest       = sapply(platforms, function(p) accuracy_results[[p]]$rf),
  Gradient_Boosting   = sapply(platforms, function(p) accuracy_results[[p]]$gb),
  KMeans_Purity       = sapply(platforms, function(p) accuracy_results[[p]]$km),
  row.names = NULL
)

kable(accuracy_table,
      col.names = c("Platform", "Logistic Regression (%)", "KNN (%)",
                    "Random Forest (%)", "Gradient Boosting (%)", "K-Means Purity (%)"),
      align = c("l", "c", "c", "c", "c", "c"),
      caption = "Model Accuracy by Platform — USA/Canada, #Education Posts (K-Means shown as cluster purity)")
Model Accuracy by Platform — USA/Canada, #Education Posts (K-Means shown as cluster purity)
Platform Logistic Regression (%) KNN (%) Random Forest (%) Gradient Boosting (%) K-Means Purity (%)
YouTube 45.00 27.27 27.27 27.27 42.50
TikTok 50.00 42.86 14.29 28.57 46.67
Instagram 52.78 33.33 44.44 22.22 47.22
Twitter 55.56 20.00 20.00 10.00 44.44

========================================================

Summary & Conclusions

Overview

This analysis examined viral social media trends for #Education posts in the USA and Canada across four platforms: YouTube, TikTok, Instagram, and Twitter. Starting with the Cleaned Viral Social Media Trends dataset (5,000 posts), we filtered to a relevant subset and applied exploratory data analysis, multinomial logistic regression, and four machine learning models to assess what predicts engagement level (High, Medium, Low).

Regression Findings

Multinomial logistic regression was applied to each platform separately, using Month, Region, Content_Type_Binary (Reel = 1), Likes, and Shares as predictors of Engagement_Level.

Key observations:

  • Likes and Shares were consistently the strongest predictors of engagement level across all four platforms. Posts with higher likes and shares were significantly more likely to be classified as High engagement — this aligns with the intuition that these metrics are both a driver and a signal of virality.
  • Month showed limited predictive power across platforms, suggesting that educational content does not have a strong seasonal pattern in the USA/Canada subset.
  • Region (USA vs. Canada) was generally not statistically significant, indicating that engagement patterns for education posts do not differ meaningfully between the two countries.
  • Content_Type_Binary (Reel) produced mixed results — it was more relevant on Instagram and TikTok (where Reels are a native format) than on YouTube or Twitter.
  • McFadden R² values were low to moderate across all platforms, which is typical for multinomial logistic models on social media data. The models explain some variation in engagement but not all — unmeasured factors ie, creator following and algorithm boost, likely account for much of the remaining variance.

Machine Learning Model Performance

Four ML models were trained per platform using the same predictors. Below is a summary of general findings:

Model Strengths Limitations
KNN Simple, interpretable; performed reasonably on balanced classes Sensitive to small sample sizes; accuracy varied widely by platform: 20-43 percent
K-Means Most consistently accurate across platforms; handled non-linear relationships well Revealed natural groupings in the data Unsupervised — clusters did not always align cleanly with engagement levels
Random Forest Picks up non-linear relationships High variation in accuracy depending on platform: 14-44 percent; Risk of overfitting on small per-platform subsets
Gradient Boosting Stronger on platforms with more data; captured complex interactions Computationally heavier; required direct gbm fitting to avoid CV failures on small samples

General findings:

  • Random Forest was comproble to KNN on most platforms based on 3-fold cross-validation accuracy, despite usually benefiting from its ensemble structure.
  • Gradient Boosting achieved competitive test-set accuracy but was more sensitive to sample size — platforms with fewer filtered posts (e.g., Twitter) produced less stable results.
  • Likes and Shares dominated variable importance plots across Random Forest and Gradient Boosting models for all four platforms, reinforcing the regression findings.
  • Prediction accuracy was highest for the High and Low classes and weakest for Medium, which is common when the middle class in an ordinal outcome is less distinct from its neighbors.

Limitations

  • The filtered dataset (USA/Canada, #Education) produces small per-platform subsets (~25–50 rows each), which limits model reliability and generalizability.
  • The binary Content_Type predictor (Reel vs. Other) was a simplification made after the full factor variable produced non-significant results.