The Anatomy of Baldness: Statistical and Machine Learning Perspectives on Key Factors of Hair Loss

0. Executive Summary

• The surveyed individuals are, on average, 34 years old, with their ages evenly distributed between 18 to 50 years.
• Alopecia areata emerges as the most common medical condition associated with baldness, consistent with its established medical background. Other notable conditions include psoriasis, thyroid problems, androgenetic alopecia, and dermatitis, each reported by approximately one-third of the 889 individuals with documented medical conditions.
• Among the 919 respondents with data on nutritional deficiencies, zinc and vitamin D deficiencies are the most prevalent. Biotin, omega-3 fatty acids, and vitamin A deficiencies also rank in the top five, each reported by at least 10% of these respondents.
• Middle-aged individuals, aged 31–45 years, constitute the largest proportion of those who have experienced baldness.
• Hair loss exhibits near-zero associations with all factors, indicating that it results from a combination of multiple factors rather than a single one.
• Stress levels—categorized as low, moderate, and high—are found to be evenly distributed among individuals with and without baldness.
• Among the three classification models evaluated, a random forest model, which demonstrates an initial AUC score of ~0.58 and an accuracy of ~0.59, is recommended for further tuning and optimization.
• Cluster analysis identifies two groups of individuals with shared key underlying features related to hair loss, including scalp infection, psoriasis, androgenetic alopecia, hormonal changes, and the use of immunomodulators.
• Through the importance analysis of the model, stress, age, and smoking are identified as major predictors of hair loss, while several features related to lifestyle and medical history are found to have considerable influence on the model’s predictive performance.

1. Background

1.1. Introduction

Hair loss is a growing health concern that affects both appearance and overall well-being for many individuals. Gaining insights into the factors that contribute to its occurrence is essential for the development of personal health management, medical interventions, and related industries.

1.2. Objectives

This report analyzes survey data on potential contributors to hair loss, with a focus on three specific objectives:

• Explore the characteristics of surveyed individuals.
• Examine the relationships between hair loss and its factors.
• Determine key predictors of hair loss through machine learning models.

1.3. Libraries & Functions

# Load required packages
library(tidyverse)
library(dplyr)
library(ggplot2)
library(plotly)
library(scales)
library(readr)
library(DT)
library(ggthemes)
library(rcompanion)
library(statpsych)
library(pROC)
library(moments)

library(caret)
library(cluster)
library(dendextend)
library(gridExtra)
library(grid)
library(fpc)
library(reshape2)
library(randomForest)

See Appendix for a comprehensive list of the functions used.

1.4. Dataset

The dataset contains a total of 999 rows of observations, each of which represents a single respondent. The table below provides a list of variables and their corresponding descriptions:

# Read the 'Predict Hair Fall' dataset
data <- read_csv("data/Predict Hair Fall.csv", show_col_types=FALSE)

# Encode data types and factors
data <- data %>%
  mutate(Id = as.integer(Id),
       Age = as.integer(Age),
       across(where(is.character), as.factor),
       Stress = factor(Stress, levels=c("Low", "Moderate", "High"), ordered=TRUE),
       `Hair Loss` = as.factor(`Hair Loss`)
       )

# Backup original dataset
data1 <- read_csv("data/Predict Hair Fall.csv", show_col_types=FALSE)
              
# Tabularize first five rows of the dataset			  
summarize_variable(slice(data, 1:5), dom="t")		  

2. Descriptive Analysis

This section provides an overview of the characteristics of the surveyed individuals using summary statistics, focusing on age, medical history, stress, and lifestyle factors.

2.1. Age

# Summary statistics of the age
age_stats <- data.frame(Value = unclass(summary(data$Age))) %>%
  bind_rows(data.frame(Value = c(sd(data$Age), skewness(data$Age)), row.names = c("Std. Dev.", "Sk\u209a"))) %>%
  mutate_if(is.numeric, round, 2)

# Age distribution plot
age_dist_plot <- ggplot(data, aes(x = Age, text = paste0(after_stat(count)))) +
  geom_histogram(breaks = hist(data$Age, breaks="FD", plot = FALSE)$breaks) +
  theme_economist() + 
  scale_color_economist() +
  scale_x_continuous(breaks = seq(15, 50, by=5)) +
  ggtitle("<b>𝗙𝗜𝗚. 𝟭﹕𝗔𝗚𝗘 𝗗𝗜𝗦𝗧𝗥𝗜𝗕𝗨𝗧𝗜𝗢𝗡 𝗢𝗙 𝗧𝗛𝗘 𝗦𝗨𝗥𝗩𝗘𝗬𝗘𝗗 𝗜𝗡𝗗𝗜𝗩𝗜𝗗𝗨𝗔𝗟𝗦<b>") +
  theme(
    plot.title = element_text(size=13, hjust=0.5),
    axis.title.x = element_text(family="ITC Officina Sans", size=13),
    axis.title.y = element_text(family="ITC Officina Sans", size=13)
  ) +
  labs(y="Count")

# Convert ggplot to plotly
age_dist_plotly <- ggplotly(age_dist_plot, tooltip=c("text")) %>%
  layout(
    hoverlabel = list(font = list(family="ITC Officina Sans", size=15)),
    xaxis = list(tickfont = list(family="ITC Officina Sans", size=13)),
    yaxis = list(tickfont = list(family="ITC Officina Sans", size=13))
  )

{
  "data": [
    {
      "x": ["15-20", "21-25", "26-30", "31-35", "36-40", "41-45", "46-50"],
      "y": [86, 138, 153, 166, 156, 151, 149],
      "type": "bar",
      "marker": {
        "color": "#595959"
      },
      "name": "Age",
      "hoverinfo": "y"
    }
  ],
  "layout": {
    "title": {
      "text": "<br><b>𝗙𝗜𝗚. 𝟭﹕𝗔𝗚𝗘 𝗗𝗜𝗦𝗧𝗥𝗜𝗕𝗨𝗧𝗜𝗢𝗡 𝗢𝗙 𝗧𝗛𝗘 𝗦𝗨𝗥𝗩𝗘𝗬𝗘𝗗 𝗜𝗡𝗗𝗜𝗩𝗜𝗗𝗨𝗔𝗟𝗦<b>",
      "font": {
        "size": 17
      },
      "xref": "paper",
      "x": 0.5
    },
    "xaxis": {
      "title": {
        "text": "Age Range",
        "font": {
          "family": "ITC Officina Sans",
          "size": 13
        }
      },
      "tickfont": {
        "family": "ITC Officina Sans",
        "size": 13
      }
    },
    "yaxis": {
      "title": {
        "text": "Count",
        "font": {
          "family": "ITC Officina Sans",
          "size": 13
        }
      },
      "tickfont": {
        "family": "ITC Officina Sans",
        "size": 13
      }
    },
    "paper_bgcolor": "#D5E4EB",
    "plot_bgcolor": "#D5E4EB",
    "margin": {
      "t": 60,
      "l": 40,
      "b": 40,
      "r": 20
    }
  }
}

• Range: The youngest individual in the survey is 18 years old, and the oldest is 50 years old.
• 1st Quartile (Q1): Twenty-five percent of respondents are younger than 26 years.
• Mean: The average age of the respondents is 34.19 years.
• Median (Q2): Half of the individuals are younger (or older) than 34 years. This value is nearly the same as the mean, indicating a relatively symmetrical distribution of ages among the respondents.
• 3rd Quartile (Q3): Seventy-five percent of the surveyed individuals are younger than 42 years.
• Standard Deviation: 9.38 years, indicating a moderate spread of ages around the mean.
• Skewness: -0.03, indicating a nearly symmetrical age distribution with no significant skew toward younger or older groups.

2.2. Medical History

This report defines an individual’s medical history as their medical background and experiences, particularly those related to hair loss. The following statistics highlight key characteristics of the respondents’ medical histories:

• Genetics: A total of 52.25% of respondents reported having a family history of baldness.
• Hormonal Changes: Approximately 51% of respondents have experienced hormonal changes.
• Medical Conditions: Among the 889 individuals with recorded medical conditions potentially leading to baldness, alopecia areata is the most common, affecting 12.04% of the group. It is followed by psoriasis (11.25%), thyroid problems (11.14%), and androgenetic alopecia (11.02%). Dermatitis (10.35%) also ranks highly, rounding out the top five conditions.

# Tabularize summary statistics of Medical Conditions
summarize_variable(
  data = data %>% rename(`Medical condition that may lead to baldness` = `Medical Conditions`),
  variable = "Medical condition that may lead to baldness"
)

• Medications & Treatments: Rogaine is the most commonly used medication or treatment associated with hair loss among the respondents, with 11.63% reporting its use. It is followed by antidepressants (11.03%), steroids (10.73%), heart medication (10.43%), and Accutane (10.23%).

# Tabularize summary statistics of Nutritional Deficiencies
summarize_variable(
  data %>% rename(`Nutritional deficiency that may contribute to hair loss` = `Nutritional Deficiencies`),
  variable = "Nutritional deficiency that may contribute to hair loss"
)

• Nutritional Deficiencies: Most of the documented 919 individuals with nutritional deficiencies that may contribute to hair loss are zinc deficient (11.75%). Vitamin D deficiency follows closely at 11.32%, while both Biotin and vitamin A deficiencies impact 10.77% each. The deficiency of omega-3 fatty acids completes the top five, affecting 10.01% of the group.

# Tabularize summary statistics of Nutritional Deficiencies
summarize_variable(
  data %>% rename(`Nutritional deficiency that may contribute to hair loss` = `Nutritional Deficiencies`),
  variable = "Nutritional deficiency that may contribute to hair loss"
)

2.3. Stress

Stress levels among respondents are found to be almost evenly distributed, with 32.73% reporting low stress, 35.14% experiencing moderate stress, and 32.13% dealing with high stress.

2.4. Lifestyle

In this report, lifestyle factors are defined as various habits and behaviors that may influence hair loss. The statistics below provide an overview of key lifestyle traits among the respondents:

• Poor Hair Care Habits: Nearly half (49.25%) of the respondents reported engaging in poor hair care practices.
• Environmental Factors: A total of 50.85% indicated exposure to environmental factors associated with hair loss.
• Smoking: Approximately 52% of the respondents are identified as smokers.
• Weight Loss: Significant weight loss is reported by 47.25% of the respondents.

3. Measures of Association

# Data frame for the pie graph, by Hair Loss
hair_loss <- data %>%
  select(`Hair Loss`) %>%
  group_by(`Hair Loss`) %>%
  summarise(Count = n(), .groups="drop") %>% 
  mutate(Proportion = Count/sum(Count)) %>%
  arrange(desc(`Hair Loss`), desc(Count))

# Factorize the Hair Loss variable
hair_loss$`Hair Loss` <- factor(hair_loss$`Hair Loss`, levels=c(0, 1))

# Create a pie graph for hair loss experience
hair_loss_pie <- plot_ly(
  type="pie",
  labels=paste0("<b>",ifelse(hair_loss$`Hair Loss` == 1, "With baldness", "Without baldness"),"</b>"),
  values = hair_loss$Count,
  textinfo="label",
  textposition="inside",
  hoverinfo="text",
  hovertext = paste0(
    "<b>Percentage:</b> ", label_percent(accuracy=0.01)(hair_loss$Proportion),
    "<b>\nCount:</b> ", hair_loss$Count
  ),
  marker = list(
    colors = case_when(
      hair_loss$`Hair Loss`==1 ~ "#FF6347",
      hair_loss$`Hair Loss`==0 ~ "#8c8c8c"
    )
  ),
  textfont = list(
    family="ITC Officina Sans",
    size=18,
    color="white"
  )
) %>%
  layout(
    title = list(
      text="<b>𝗙𝗜𝗚. 𝟮﹕𝗣𝗜𝗘 𝗚𝗥𝗔𝗣𝗛 𝗢𝗙 𝗧𝗛𝗘 𝗦𝗨𝗥𝗩𝗘𝗬𝗘𝗗 𝗜𝗡𝗗𝗜𝗩𝗜𝗗𝗨𝗔𝗟𝗦<br>𝗕𝗬 𝗛𝗔𝗜𝗥 𝗟𝗢𝗦𝗦 𝗢𝗨𝗧𝗖𝗢𝗠𝗘</b>",
      font = list(size=18)
    ),
    paper_bgcolor="#D5E4EB",
    margin = list(l=0, r=0, b=20, t=80),
    showlegend = FALSE  # Hide the legend
  ) %>%
  style(
    hoverlabel = list(
      font = list(
        family="ITC Officina Sans",
        size=15
      )
    )
  )

{
  "data": [
    {
      "type": "pie",
      "labels": ["<b>With baldness</b>", "<b>Without baldness</b>"],
      "values": [497, 502],
      "textinfo": "label",
      "textposition": "inside",
      "hoverinfo": "text",
      "hovertext": [
        "<b>Percentage:</b> 49.75%<br><b>Count:</b> 497",
        "<b>Percentage:</b> 50.25%<br><b>Count:</b> 502"
      ],
      "marker": {
        "colors": ["#FF6347", "#8c8c8c"]
      },
      "textfont": {
        "family": "ITC Officina Sans, Arial, sans-serif",
        "size": 18,
        "color": "white"
      }
    }
  ],
  "layout": {
    "title": {
      "text": "<b>𝗙𝗜𝗚. 𝟮﹕𝗦𝗨𝗥𝗩𝗘𝗬𝗘𝗗 𝗜𝗡𝗗𝗜𝗩𝗜𝗗𝗨𝗔𝗟𝗦 𝗕𝗬 𝗛𝗔𝗜𝗥 𝗟𝗢𝗦𝗦 𝗢𝗨𝗧𝗖𝗢𝗠𝗘</b>",
      "font": { "size": 18 },
      "x": 0.5,
      "xanchor": "center"
    },
    "paper_bgcolor": "#D5E4EB",
    "margin": { "l": 0, "r": 0, "b": 20, "t": 80 },
    "showlegend": false
  }
}

Below is a table presenting each factor, its levels of measurement, and the corresponding statistical methods applied for the analysis:

3.1. Biserial Correlation

3.1.1. Point-Biserial

For the variable of age, the point-biserial \(({r_{pb}})\) correlation is used to measure its association with the binary outcome of hair loss. The correlation coefficient is calculated using the formula:

where:

• \({\bar{X}_{1}}\) is the mean age of the group with baldness (Hair Loss = 1)
• \({\bar{X}_{0}}\) is the mean age of the group without baldness (Hair Loss = 0)
• \({s_n}\) is the standard deviation of the ages
• \({n_1}\) is the number of observations with baldness
• \({n_0}\) is the number of observations without baldness
• \({n}\) is the total number of observations

# Create dataframe for Age Group
age_data <- data %>%
  select(Age, `Hair Loss`) %>%
  mutate(
    `Age Group` = case_when(
      Age >= 17 & Age <= 30 ~ "Young (17-30)",
      Age >= 31 & Age <= 45 ~ "Middle-aged (31-45)",
      Age > 45 ~ "Old (>45)",
      TRUE ~ NA_character_
    ),
    `Age Group` = factor(`Age Group`, levels = c("Young (17-30)", "Middle-aged (31-45)", "Old (>45)"), ordered = TRUE)
  )

# Create contingency table by Age Group and Hair Loss outcome
age_table <- create_contingency_table(create_contingency_data(age_data, "Age Group"), "Age Group")

# Create a boxplot by Age Group and Hair Loss outcome
age_hair_loss_boxplot <- plot_ly(
  data = age_data,
  x = ~factor(`Hair Loss`, labels = c("Without Baldness", "With Baldness")),
  y = ~Age,
  type = "box",
  boxpoints = "outliers", # Show only outliers
  jitter = 0.3, # Add some jitter to the points
  color = ~factor(`Hair Loss`, labels = c("Without Baldness", "With Baldness")), # Add color by Hair Loss
  colors = c('#8c8c8c', '#FF6347') # Define colors
) %>%
  layout(
    title = list(
      text = "<br><b>𝗙𝗜𝗚. 𝟯﹕𝗔𝗚𝗘 𝗗𝗜𝗦𝗧𝗥𝗜𝗕𝗨𝗧𝗜𝗢𝗡 𝗕𝗬 𝗛𝗔𝗜𝗥 𝗟𝗢𝗦𝗦 𝗢𝗨𝗧𝗖𝗢𝗠𝗘</b>",
      font = list(size = 18),
      x = 0.5,
      xanchor = "center",
      y = 0.95,
      yanchor = "top"
    ),
    margin = list(t = 100), # Add margin between title and plot
    xaxis = list(
      title = "Hair Loss Outcome",
      tickfont = list(family = "ITC Officina Sans"),
      titlefont = list(family = "ITC Officina Sans", size = 18),
      showticklabels = FALSE # Do not show x ticks texts
    ),
    yaxis = list(
      title = "Age",
      tickfont = list(family = "ITC Officina Sans"),
      titlefont = list(family = "ITC Officina Sans", size = 18)
    ),
    paper_bgcolor = "#D5E4EB",
    plot_bgcolor = "#D5E4EB",
    legend = list(
      orientation = "h",
      x = 0.5,
      xanchor = "center",
      y = 1.1,
      yanchor = "top"
    )
  ) %>%
  style(
    hoverlabel = list(
      font = list(
        family = "ITC Officina Sans",
        size = 15
      )
    )
  )

{
  "data": [
    {
      "y": [
        19, 43, 26, 46, 35, 49, 26, 30, 34, 29, 46, 26, 29, 33, 34, 28, 41, 35, 21, 22, 30, 30, 24, 38, 19,
        48, 38, 28, 45, 50, 50, 34, 27, 25, 43, 44, 49, 34, 24, 41, 18, 46, 43, 37, 24, 19, 45, 24, 34, 41,
        37, 50, 34, 37, 18, 24, 24, 23, 27, 35, 23, 24, 35, 48, 30, 39, 47, 42, 23, 34, 18, 35, 39, 50, 19,
        32, 43, 32, 33, 26, 30, 25, 49, 33, 42, 43, 50, 26, 46, 30, 42, 36, 41, 22, 30, 18, 29, 29, 36, 39,
        31, 24, 32, 47, 25, 30, 43, 18, 35, 45, 39, 50, 32, 18, 27, 39, 23, 22, 42, 42, 36, 29, 47, 50, 44,
        19, 43, 43, 43, 34, 25, 37, 45, 24, 48, 27, 37, 45, 33, 46, 35, 26, 26, 37, 44, 49, 39, 47, 27, 43,
        24, 43, 28, 41, 47, 38, 45, 27, 29, 21, 36, 38, 18, 38, 22, 21, 30, 48, 47, 41, 26, 22, 39, 33, 45,
        32, 25, 31, 40, 30, 49, 38, 36, 50, 22, 40, 27, 32, 18, 47, 48, 20, 43, 48, 33, 23, 36, 40, 25, 46,
        33, 29, 44, 32, 44, 40, 36, 41, 26, 46, 47, 45, 40, 38, 45, 41, 19, 23, 35, 44, 40, 27, 46, 26, 24,
        47, 32, 40, 18, 32, 43, 44, 50, 32, 31, 34, 41, 37, 50, 49, 49, 27, 23, 28, 41, 35, 28, 39, 47, 18,
        45, 50, 43, 41, 40, 31, 24, 31, 37, 50, 18, 46, 22, 47, 49, 29, 45, 46, 48, 21, 48, 25, 41, 36, 39,
        24, 43, 28, 41, 28, 28, 49, 46, 35, 45, 31, 50, 42, 34, 37, 29, 39, 38, 19, 26, 23, 46, 41, 32, 22,
        34, 32, 37, 44, 27, 38, 24, 20, 30, 37, 32, 41, 43, 20, 25, 50, 27, 42, 40, 22, 31, 26, 44, 34, 34,
        22, 25, 39, 22, 46, 19, 21, 30, 24, 39, 24, 40, 36, 23, 48, 19, 47, 21, 45, 48, 37, 27, 29, 49, 30,
        41, 43, 24, 32, 33, 33, 49, 47, 29, 43, 22, 45, 40, 49, 20, 28, 36, 26, 46, 35, 31, 33, 27, 50, 31,
        32, 47, 18, 18, 50, 25, 19, 18, 45, 40, 19, 34, 30, 26, 21, 38, 19, 31, 38, 50, 26, 31, 19, 24, 40,
        47, 26, 30, 32, 23, 23, 41, 50, 41, 44, 19, 27, 34, 36, 35, 30, 50, 20, 20, 47, 25, 39, 36, 20, 44,
        49, 18, 27, 39, 34, 43, 48, 47, 37, 42, 31, 20, 45, 28, 19, 23, 50, 46, 39, 27, 35, 40, 44, 23, 33,
        26, 29, 45, 36, 50, 38, 27, 26, 49, 40, 20, 45, 41, 32, 48, 18, 37, 38, 47, 22, 41, 44, 38, 28, 50,
        38, 33, 42, 43, 49, 22, 23, 41, 35, 46, 38, 41, 44, 21, 25, 46, 26, 40, 50, 43, 33, 19, 23, 42, 33,
        23, 47
      ],
      "type": "box",
      "name": "Without Baldness",
      "marker": { "color": "#8c8c8c" },
      "boxpoints": "outliers",
      "jitter": 0.3
    },
    {
      "y": [
        30, 37, 40, 19, 48, 20, 19, 46, 46, 20, 37, 45, 24, 31, 39, 21, 39, 30, 24, 37, 36, 18, 18, 46, 39,
        31, 28, 44, 21, 35, 28, 35, 22, 34, 23, 44, 24, 25, 50, 38, 22, 47, 32, 31, 46, 34, 29, 28, 41, 37,
        19, 39, 27, 19, 23, 50, 28, 24, 36, 47, 29, 42, 19, 30, 43, 27, 42, 37, 18, 29, 27, 32, 30, 45, 32,
        20, 38, 32, 26, 41, 20, 35, 39, 45, 23, 46, 18, 44, 47, 47, 33, 44, 50, 44, 26, 27, 48, 47, 48, 28,
        45, 46, 23, 29, 19, 30, 27, 40, 34, 18, 32, 30, 18, 22, 47, 38, 18, 33, 20, 39, 26, 21, 31, 25, 42,
        38, 34, 25, 44, 50, 18, 47, 42, 32, 36, 37, 47, 25, 20, 33, 35, 36, 33, 21, 32, 40, 40, 33, 22, 26,
        24, 22, 40, 44, 47, 47, 45, 29, 27, 48, 29, 46, 35, 23, 43, 31, 28, 48, 28, 41, 41, 43, 41, 19, 22,
        35, 38, 40, 30, 40, 28, 40, 19, 20, 43, 29, 21, 46, 19, 24, 43, 43, 39, 21, 36, 39, 20, 42, 27, 18,
        25, 34, 35, 32, 32, 32, 21, 32, 36, 22, 37, 20, 32, 43, 19, 48, 33, 48, 49, 29, 23, 42, 34, 24, 26,
        29, 31, 18, 41, 29, 49, 48, 27, 28, 39, 35, 38, 37, 42, 40, 33, 40, 28, 18, 47, 32, 18, 24, 34, 30,
        50, 23, 29, 48, 39, 48, 24, 36, 37, 33, 36, 44, 36, 34, 49, 34, 32, 49, 33, 41, 29, 18, 43, 48, 37,
        38, 40, 29, 24, 38, 36, 19, 40, 29, 24, 46, 24, 26, 40, 18, 45, 49, 28, 31, 28, 27, 32, 45, 48, 43,
        25, 33, 36, 39, 19, 18, 28, 35, 35, 18, 33, 19, 25, 22, 28, 28, 43, 22, 23, 31, 43, 22, 36, 35, 24,
        49, 22, 33, 44, 42, 21, 46, 47, 41, 31, 37, 42, 35, 39, 42, 36, 32, 35, 39, 49, 45, 24, 33, 49, 49,
        35, 26, 43, 21, 31, 33, 32, 31, 43, 38, 23, 45, 29, 44, 37, 29, 38, 28, 29, 34, 30, 37, 24, 30, 22,
        29, 26, 25, 31, 43, 34, 38, 28, 37, 32, 35, 40, 48, 38, 29, 41, 45, 37, 35, 32, 50, 45, 50, 39, 19,
        40, 37, 22, 21, 34, 48, 37, 23, 40, 40, 47, 48, 21, 38, 30, 49, 27, 22, 39, 37, 34, 31, 28, 35, 30,
        19, 20, 31, 22, 26, 36, 42, 31, 45, 33, 45, 35, 42, 33, 24, 24, 31, 23, 29, 38, 21, 19, 43, 43, 21,
        40, 29, 35, 48, 39, 32, 28, 20, 45, 49, 26, 34, 48, 41, 46, 21, 29, 25, 42, 28, 24, 48, 31, 49, 33,
        38, 24, 21, 46, 26, 35, 45, 27, 21, 35, 41, 18, 40, 27, 33, 46, 45, 30, 33, 20, 32, 34
      ],
      "type": "box",
      "name": "With Baldness",
      "marker": { "color": "#FF6347" },
      "boxpoints": "outliers",
      "jitter": 0.3
    }
  ],
  "layout": {
    "title": {
      "text": "<br><b>𝗙𝗜𝗚. 𝟯﹕𝗔𝗚𝗘 𝗗𝗜𝗦𝗧𝗥𝗜𝗕𝗨𝗧𝗜𝗢𝗡 𝗕𝗬 𝗛𝗔𝗜𝗥 𝗟𝗢𝗦𝗦 𝗢𝗨𝗧𝗖𝗢𝗠𝗘</b>",
      "font": { "size": 18 },
      "x": 0.5,
      "xanchor": "center",
      "y": 0.95,
      "yanchor": "top"
    },
    "margin": { "t": 100 },
    "paper_bgcolor": "#D5E4EB",
    "plot_bgcolor": "#D5E4EB",
    "xaxis": {
      "title": {
        "text": "Hair Loss Outcome",
        "font": { "family": "ITC Officina Sans", "size": 18 }
      },
      "tickfont": { "family": "ITC Officina Sans" },
      "showticklabels": false
    },
    "yaxis": {
      "title": {
        "text": "Age",
        "font": { "family": "ITC Officina Sans", "size": 18 }
      },
      "tickfont": { "family": "ITC Officina Sans" }
    },
    "legend": {
      "orientation": "h",
      "x": 0.5,
      "xanchor": "center",
      "y": 1.1,
      "yanchor": "top"
    }
  }
}

# Data frame for the treemap, by Age Group and by Hair Loss outcome
age_grp_and_hair_loss <- data %>%
  select(Age, `Hair Loss`) %>%
  mutate(
    `Age Group` = case_when(
      Age >= 17 & Age <= 30 ~ "Young (17-30)",
      Age >= 31 & Age <= 45 ~ "Middle-aged (31-45)",
      Age > 45 ~ "Old (>45)",
      TRUE ~ NA_character_
    )
  ) %>%
  group_by(`Hair Loss`, `Age Group`) %>%
  summarise(Count = n(), .groups = "drop") %>%
  mutate(Proportion = Count / sum(Count)) %>%
  arrange(desc(`Hair Loss`), desc(Count))

# Factorize Age Group
age_grp_and_hair_loss$`Age Group` <- factor(
  age_grp_and_hair_loss$`Age Group`,
  levels = c("Young (17-30)", "Middle-aged (31-45)", "Old (>45)"),
  ordered = TRUE
)

# Create a treemap for by Age Group and Hair Loss outcome
colors <- c("#175952", "#762127", "#0b385b", "#01877c", "#ae1726", "#005289")
age_hair_loss_treemap <- plot_ly(
  type = "treemap",
  labels = paste0(
    "<b>", stringr::str_to_sentence(age_grp_and_hair_loss$`Age Group`),
    "\n", ifelse(age_grp_and_hair_loss$`Hair Loss` == 1, "with baldness", "without baldness"), "</b>"
  ),
  parents = rep("", nrow(age_grp_and_hair_loss)),
  values = age_grp_and_hair_loss$Count,
  domain = list(column = 0),
  name = " ",
  hoverinfo = "text",
  hovertext = paste0(
    "<b>Percentage:</b> ", label_percent(accuracy = 0.01)(age_grp_and_hair_loss$Proportion),
    "<b>\nCount:</b> ", age_grp_and_hair_loss$Count
  ),
  marker = list(
    colors = case_when(
      age_grp_and_hair_loss$`Age Group` == "Young (17-30)" & age_grp_and_hair_loss$`Hair Loss` == 1 ~ colors[1],
      age_grp_and_hair_loss$`Age Group` == "Middle-aged (31-45)" & age_grp_and_hair_loss$`Hair Loss` == 1 ~ colors[2],
      age_grp_and_hair_loss$`Age Group` == "Old (>45)" & age_grp_and_hair_loss$`Hair Loss` == 1 ~ colors[3],
      age_grp_and_hair_loss$`Age Group` == "Young (17-30)" & age_grp_and_hair_loss$`Hair Loss` == 0 ~ colors[4],
      age_grp_and_hair_loss$`Age Group` == "Middle-aged (31-45)" & age_grp_and_hair_loss$`Hair Loss` == 0 ~ colors[5],
      age_grp_and_hair_loss$`Age Group` == "Old (>45)" & age_grp_and_hair_loss$`Hair Loss` == 0 ~ colors[6]
    )
  ),
  textfont = list(
    family = "ITC Officina Sans",
    size = 15,
    color = "white"
  ),
  textinfo = "label+text",
  textposition = "middle center"
) %>%
  layout(
    title = list(
      text = "<br><b>𝗙𝗜𝗚. 𝟰﹕𝗦𝗨𝗥𝗩𝗘𝗬𝗘𝗗 𝗜𝗡𝗗𝗜𝗩𝗜𝗗𝗨𝗔𝗟𝗦<br>𝗕𝗬 𝗔𝗚𝗘 𝗚𝗥𝗢𝗨𝗣 & 𝗛𝗔𝗜𝗥 𝗟𝗢𝗦𝗦 𝗢𝗨𝗧𝗖𝗢𝗠𝗘</b>",
      font = list(size = 18)
    ),
    paper_bgcolor = "#D5E4EB",
    margin = list(l = 30, r = 30, b = 25, t = 45)
  ) %>%
  style(
    hoverlabel = list(
      font = list(
        family = "ITC Officina Sans",
        size = 15
      )
    )
  )

{
  "data": [
    {
      "type": "treemap",
      "labels": [
        "<b>Young (17-30)<br>with baldness</b>",
        "<b>Middle-aged (31-45)<br>with baldness</b>",
        "<b>Old (>45)<br>with baldness</b>",
        "<b>Young (17-30)<br>without baldness</b>",
        "<b>Middle-aged (31-45)<br>without baldness</b>",
        "<b>Old (>45)<br>without baldness</b>"
      ],
      "parents": ["", "", "", "", "", ""],
      "values": [193, 241, 63, 184, 232, 86],
      "marker": { "colors": ["#175952", "#762127", "#0b385b", "#01877c", "#ae1726", "#005289"] },
      "textfont": { "family": "ITC Officina Sans", "size": 15, "color": "white" },
      "hoverinfo": "text",
      "hovertext": [
        "<b>Percentage:</b> 19.32%<br><b>Count:</b> 193",
        "<b>Percentage:</b> 24.12%<br><b>Count:</b> 241",
        "<b>Percentage:</b> 6.31%<br><b>Count:</b> 63",
        "<b>Percentage:</b> 18.42%<br><b>Count:</b> 184",
        "<b>Percentage:</b> 23.22%<br><b>Count:</b> 232",
        "<b>Percentage:</b> 8.61%<br><b>Count:</b> 86"
      ],
      "textinfo": "label",
      "textposition": "middle center"
    }
  ],
  "layout": {
    "title": {
      "text": "<br><b>𝗙𝗜𝗚. 𝟰﹕𝗦𝗨𝗥𝗩𝗘𝗬𝗘𝗗 𝗜𝗡𝗗𝗜𝗩𝗜𝗗𝗨𝗔𝗟𝗦<br>𝗕𝗬 𝗔𝗚𝗘 𝗚𝗥𝗢𝗨𝗣 & 𝗛𝗔𝗜𝗥 𝗟𝗢𝗦𝗦 𝗢𝗨𝗧𝗖𝗢𝗠𝗘</b>",
      "font": { "size": 18 },
    "x": 0.5,
    "xanchor": "center"
    },
    "paper_bgcolor": "#D5E4EB",
    "margin": { "l": 30, "r": 30, "b": 25, "t": 45 }
  }
}

The distributions of individuals with and without hair loss appear similar, particularly among middle-aged and young adults. However, a significant difference is observed among older adults, where the absence of hair loss is more common than its presence. This indicates a possible negative association between being over 45 and experiencing hair loss.

# Compute point-biserial correlation coefficient between Age and Hair Loss outcome
age_rpb <- compute_point_biserial(data1, x = "Age", y = "Hair Loss")

# Tabularize results 
summarize_variable(age_rpb[, c(1, 3:4, 7, 5, 6)] %>% column_to_rownames("x"), rownames = TRUE
)

Based on the results of a point-biserial correlation, the relationship between age and baldness is found to be inverse, as indicated by the negative coefficient. This means that as age increases, there is a slight tendency for baldness to occur less frequently. However, the coefficient of -0.06 is close to 0, which translates to a very weak relationship. This suggests that age alone does not strongly influence the likelihood of hair loss in this dataset.

3.1.2. Rank-Biserial

The rank-biserial correlation is used to measure the relationship between stress levels and hair loss. It is computed using the formula:

where:

• \({R_{1}}\) is the mean rank of stress levels for the group with baldness
• \({R_{0}}\) is the mean rank of stress levels for the group without baldness
• \({n}\) is the total number of observations

# Data frame for the treemap, by Stress and Hair Loss
stress_lvl_and_hair_loss <- data %>%
	select(Stress, `Hair Loss`) %>%
	group_by(`Hair Loss`, `Stress`) %>%
	summarise(Count = n(), .groups="drop") %>%
	mutate(Proportion = Count/sum(Count)) %>%
	arrange(desc(`Hair Loss`), desc(Count))

# Factorize the Stress variable
stress_lvl_and_hair_loss$Stress <- factor(stress_lvl_and_hair_loss$Stress, levels=c("Low", "Moderate", "High"), ordered=TRUE)

# Create a treemap for by stress level and hair loss experience
colors1 <- c("#567c07", "#996f00", "#a73735", "#77b200", "#e19c00", "#ec3330") 
stress_hair_loss_treemap <- plot_ly(
  type="treemap",
  labels=paste0("<b>",stringr::str_to_sentence(stress_lvl_and_hair_loss$`Stress`)," stress level",
				 "\n",ifelse(stress_lvl_and_hair_loss$`Hair Loss`==1, "with baldness", "without baldness"),"</b>"),
  parents=rep("", nrow(stress_lvl_and_hair_loss)),
  values=stress_lvl_and_hair_loss$Count,
  domain = list(column=0),
  name=" ",
  hoverinfo="text",
  hovertext=paste0(
    "<b>Percentage:</b> ", label_percent(accuracy=0.01)(stress_lvl_and_hair_loss$Count/sum(stress_lvl_and_hair_loss$Count)),
    "<b>\nCount: </b>", stress_lvl_and_hair_loss$Count
  ),
  marker = list(
    colors=case_when(
      stress_lvl_and_hair_loss$`Stress`=="Low" & stress_lvl_and_hair_loss$`Hair Loss`==1 ~ colors1[1],
      stress_lvl_and_hair_loss$`Stress`=="Moderate" & stress_lvl_and_hair_loss$`Hair Loss`==1 ~ colors1[2],
      stress_lvl_and_hair_loss$`Stress`=="High" & stress_lvl_and_hair_loss$`Hair Loss`==1 ~ colors1[3],
      stress_lvl_and_hair_loss$`Stress`=="Low" & stress_lvl_and_hair_loss$`Hair Loss`==0 ~ colors1[4],
      stress_lvl_and_hair_loss$`Stress`=="Moderate" & stress_lvl_and_hair_loss$`Hair Loss`==0 ~ colors1[5],
      stress_lvl_and_hair_loss$`Stress`=="High" & stress_lvl_and_hair_loss$`Hair Loss`==0 ~ colors1[6]
    )
  ),
  textfont = list(
    family="ITC Officina Sans",
    size=15,
    color="white"
  ),
  textinfo="label+text",
  textposition="middle center"
) %>%
  layout(
    title = list(
      text="<br><b>𝗙𝗜𝗚. 𝟱﹕𝗦𝗨𝗥𝗩𝗘𝗬𝗘𝗗 𝗜𝗡𝗗𝗜𝗩𝗜𝗗𝗨𝗔𝗟𝗦<br>𝗕𝗬 𝗦𝗧𝗥𝗘𝗦𝗦 𝗟𝗘𝗩𝗘𝗟 & 𝗛𝗔𝗜𝗥 𝗟𝗢𝗦𝗦 𝗢𝗨𝗧𝗖𝗢𝗠𝗘</b>",
      font = list(size=18)
    ),
    paper_bgcolor="#D5E4EB",
    margin = list(l=30, r=30, b=25, t=45)
  ) %>%
  style(
    hoverlabel = list(
      font = list(
        family="ITC Officina Sans",
		size=15
      )
    )
  )

{
  "data": [
    {
      "type": "treemap",
      "labels": [
        "<b>Low stress level<br>with baldness</b>",
        "<b>Moderate stress level<br>with baldness</b>",
        "<b>High stress level<br>with baldness</b>",
        "<b>Low stress level<br>without baldness</b>",
        "<b>Moderate stress level<br>without baldness</b>",
        "<b>High stress level<br>without baldness</b>"
      ],
      "parents": ["", "", "", "", "", ""],
      "values": [159, 182, 156, 168, 169, 165],
      "marker": {
        "colors": ["#567c07", "#996f00", "#a73735", "#77b200", "#e19c00", "#ec3330"]
      },
      "textfont": {
        "family": "ITC Officina Sans",
        "size": 15,
        "color": "white"
      },
      "hoverinfo": "text",
      "hovertext": [
        "<b>Percentage:</b> 15.92%<br><b>Count:</b> 159",
        "<b>Percentage:</b> 18.22%<br><b>Count:</b> 182",
        "<b>Percentage:</b> 15.62%<br><b>Count:</b> 156",
        "<b>Percentage:</b> 16.82%<br><b>Count:</b> 168",
        "<b>Percentage:</b> 16.92%<br><b>Count:</b> 169",
        "<b>Percentage:</b> 16.52%<br><b>Count:</b> 165"
      ],
      "textinfo": "label",
      "textposition": "middle center"
    }
  ],
  "layout": {
    "title": {
      "text": "<br><b>𝗙𝗜𝗚. 𝟱﹕𝗦𝗨𝗥𝗩𝗘𝗬𝗘𝗗 𝗜𝗡𝗗𝗜𝗩𝗜𝗗𝗨𝗔𝗟𝗦<br>𝗕𝗬 𝗦𝗧𝗥𝗘𝗦𝗦 𝗟𝗘𝗩𝗘𝗟 & 𝗛𝗔𝗜𝗥 𝗟𝗢𝗦𝗦 𝗢𝗨𝗧𝗖𝗢𝗠𝗘</b>",
      "font": { "family": "ITC Officina Sans", "size": 18 },
      "x": 0.5,
      "xanchor": "center"
    },
    "paper_bgcolor": "#D5E4EB",
    "plot_bgcolor": "#D5E4EB",
    "margin": { "l": 30, "r": 30, "b": 25, "t": 65 }
  }
}

# Compute rank-biserial correlation coefficients between Stress and Hair Loss outcome
stress_rrb <- compute_rank_biserial(data, x = "Stress", y = "Hair Loss")

# Tabularize results
summarize_variable(stress_rrb[, c(1, 3:4, 7, 5, 6)] %>% column_to_rownames("x"), rownames = TRUE)

As expected, the rank-biserial correlation results confirm a negligible association (4.81e-05) between stress and baldness, indicating that stress alone does not significantly influence the outcome of hair loss.

3.2. Cramer’s V

For nominal variables with multiple categories (e.g., medical conditions, medications and treatments, nutritional deficiencies), Cramér’s V assesses associations with hair loss, computed as:

where:

• \({\chi^2}\) is the chi-square statistic
• \({n}\) is the total number of observations
• \(r\) is the number of categories of the factor
• \(c\) is the number of categories for hair loss
• \(O_i\) is the observed count for category \(i\)
• \(E_i\) is the expected count for category \(i\)

# Create a proportional stacked bar plot by Medical Conditions and Hair Loss outcome
create_stackbar_plot1(
  data1, 
  var = "Medical Conditions", 
  yaxis_text = "Medical Condition", 
  tickangle = 0,
  plot_title = "𝗙𝗜𝗚. 𝟲﹕𝗦𝗨𝗥𝗩𝗘𝗬𝗘𝗗 𝗜𝗡𝗗𝗜𝗩𝗜𝗗𝗨𝗔𝗟𝗦<br>𝗕𝗬 𝗠𝗘𝗗𝗜𝗖𝗔𝗟 𝗖𝗢𝗡𝗗𝗜𝗧𝗜𝗢𝗡 & 𝗛𝗔𝗜𝗥 𝗟𝗢𝗦𝗦 𝗢𝗨𝗧𝗖𝗢𝗠𝗘"
)

{
  "data": [
    {
      "type": "bar",
      "orientation": "h",
      "x": [43.43, 47.83, 47.83, 47.83, 48.10, 48.86, 50.00, 56.12, 56.82, 57.01],
      "y": [
        "Thyroid Problems",
        "Dermatitis",
        "Eczema",
        "Ringworm",
        "Scalp Infection",
        "Dermatosis",
        "Psoriasis",
        "Androgenetic Alopecia",
        "Seborrheic Dermatitis",
        "Alopecia Areata"
      ],
      "name": "With Baldness",
      "marker": {"color": "#FF6347"},
      "textposition": "auto",
      "customdata": [43, 44, 33, 33, 38, 43, 50, 55, 50, 61],
      "hovertemplate": "<b>Percentage:</b> %{x}%<br><b>Count:</b> %{customdata}"
    },
    {
      "type": "bar",
      "orientation": "h",
      "x": [56.57, 52.17, 52.17, 52.17, 51.90, 51.14, 50.00, 43.88, 43.18, 42.99],
      "y": [
        "Thyroid Problems",
        "Dermatitis",
        "Eczema",
        "Ringworm",
        "Scalp Infection",
        "Dermatosis",
        "Psoriasis",
        "Androgenetic Alopecia",
        "Seborrheic Dermatitis",
        "Alopecia Areata"
      ],
      "name": "Without Baldness",
      "marker": {"color": "#8c8c8c"},
      "textposition": "auto",
      "customdata": [56, 48, 36, 36, 41, 45, 50, 43, 38, 46],
      "hovertemplate": "<b>Percentage:</b> %{x}%<br><b>Count:</b> %{customdata}"
    }
  ],
  "layout": {
    "barmode": "stack",
    "title": {
      "text": "<br><b>𝗙𝗜𝗚. 𝟲﹕𝗦𝗨𝗥𝗩𝗘𝗬𝗘𝗗 𝗜𝗡𝗗𝗜𝗩𝗜𝗗𝗨𝗔𝗟𝗦<br>𝗕𝗬 𝗠𝗘𝗗𝗜𝗖𝗔𝗟 𝗖𝗢𝗡𝗗𝗜𝗧𝗜𝗢𝗡 & 𝗛𝗔𝗜𝗥 𝗟𝗢𝗦𝗦 𝗢𝗨𝗧𝗖𝗢𝗠𝗘</b>",
      "font": {"family": "ITC Officina Sans", "size": 20},
      "x": 0.5,
      "xanchor": "center",
      "y": 0.93
    },
    "xaxis": {
      "title": {
        "text": "Percentage (%)",
        "font": {"family": "ITC Officina Sans", "size": 16}
      },
      "tickfont": {"family": "ITC Officina Sans", "size": 15},
      "range": [0, 100]
    },
    "yaxis": {
      "title": {
        "text": "<br><b>Medical Condition</b>",
        "font": {"family": "ITC Officina Sans", "size": 18}
      },
      "tickfont": {"family": "ITC Officina Sans", "size": 15},
      "categoryorder": "array",
      "categoryarray": [
        "Thyroid Problems",
        "Dermatitis",
        "Eczema",
        "Ringworm",
        "Scalp Infection",
        "Dermatosis",
        "Psoriasis",
        "Androgenetic Alopecia",
        "Seborrheic Dermatitis",
        "Alopecia Areata"
      ]
    },
    "plot_bgcolor": "#D5E4EB",
    "paper_bgcolor": "#D5E4EB",
    "margin": {"t": 95}
  }
}

# Create a proportional stacked bar plot by Medications and Treatments and Hair Loss outcome
create_stackbar_plot1(
  data1 %>% rename(`Medications and Treatments` = `Medications & Treatments`),
  var = "Medications and Treatments", 
  yaxis_text = "\nMedication / Treatment", 
  tickangle = 0, 
  plot_title = "<br><b>𝗙𝗜𝗚. 𝟳﹕𝗦𝗨𝗥𝗩𝗘𝗬𝗘𝗗 𝗜𝗡𝗗𝗜𝗩𝗜𝗗𝗨𝗔𝗟𝗦<br>𝗕𝗬 𝗠𝗘𝗗𝗜𝗖𝗔𝗧𝗜𝗢𝗡 𝗢𝗥 𝗧𝗥𝗘𝗔𝗧𝗠𝗘𝗡𝗧 & 𝗛𝗔𝗜𝗥 𝗟𝗢𝗦𝗦 𝗢𝗨𝗧𝗖𝗢𝗠𝗘</b>"
)

{
  "data": [
    {
      "type": "bar",
      "orientation": "h",
      "x": [44.44, 46.67, 46.81, 48.18, 49.02, 50.86, 50.96, 51.11, 53.19, 55.14],
      "y": [
        "Immunomodulators",
        "Blood Pressure Medication",
        "Antifungal Cream",
        "Antidepressants",
        "Accutane",
        "Rogaine",
        "Heart Medication",
        "Chemotherapy",
        "Antibiotics",
        "Steroids"
      ],
      "name": "With Baldness",
      "marker": {"color": "#FF6347"},
      "textposition": "auto",
      "customdata": [40, 42, 44, 53, 50, 59, 53, 46, 50, 59],
      "hovertemplate": "<b>Percentage:</b> %{x}%<br><b>Count:</b> %{customdata}"
    },
    {
      "type": "bar",
      "orientation": "h",
      "x": [55.56, 53.33, 53.19, 51.82, 50.98, 49.14, 49.04, 48.89, 46.81, 44.86],
      "y": [
        "Immunomodulators",
        "Blood Pressure Medication",
        "Antifungal Cream",
        "Antidepressants",
        "Accutane",
        "Rogaine",
        "Heart Medication",
        "Chemotherapy",
        "Antibiotics",
        "Steroids"
      ],
      "name": "Without Baldness",
      "marker": {"color": "#8c8c8c"},
      "textposition": "auto",
      "customdata": [50, 48, 50, 57, 52, 57, 51, 44, 44, 48],
      "hovertemplate": "<b>Percentage:</b> %{x}%<br><b>Count:</b> %{customdata}"
    }
  ],
  "layout": {
    "barmode": "stack",
    "title": {
      "text": "<br><b>𝗙𝗜𝗚. 𝟳﹕𝗦𝗨𝗥𝗩𝗘𝗬𝗘𝗗 𝗜𝗡𝗗𝗜𝗩𝗜𝗗𝗨𝗔𝗟𝗦<br>𝗕𝗬 𝗠𝗘𝗗𝗜𝗖𝗔𝗧𝗜𝗢𝗡 𝗢𝗥 𝗧𝗥𝗘𝗔𝗧𝗠𝗘𝗡𝗧 & 𝗛𝗔𝗜𝗥 𝗟𝗢𝗦𝗦 𝗢𝗨𝗧𝗖𝗢𝗠𝗘</b>",
      "font": {"family": "ITC Officina Sans", "size": 20},
      "x": 0.5,
      "xanchor": "center",
      "y": 0.93
    },
    "xaxis": {
      "title": {
        "text": "Percentage (%)",
        "font": {"family": "ITC Officina Sans", "size": 16}
      },
      "tickfont": {"family": "ITC Officina Sans", "size": 15},
      "range": [0, 100]
    },
    "yaxis": {
      "title": {
        "text": "<br><b>Medication / Treatment</b>",
        "font": {"family": "ITC Officina Sans", "size": 18}
      },
      "tickfont": {"family": "ITC Officina Sans", "size": 15},
      "categoryorder": "array",
      "categoryarray": [
        "Immunomodulators",
        "Blood Pressure Medication",
        "Antifungal Cream",
        "Antidepressants",
        "Accutane",
        "Rogaine",
        "Heart Medication",
        "Chemotherapy",
        "Antibiotics",
        "Steroids"
      ]
    },
    "plot_bgcolor": "#D5E4EB",
    "paper_bgcolor": "#D5E4EB",
    "margin": {"t": 95}
  }
}

# Create a proportional stacked bar plot for Nutritional Deficiencies and Hair Loss outcome
create_stackbar_plot1(
  data1, 
  var = "Nutritional Deficiencies", 
  yaxis_text = "\nNutritional Deficiency", 
  tickangle = 0,
  plot_title = "𝗙𝗜𝗚. 𝟴﹕𝗦𝗨𝗥𝗩𝗘𝗬𝗘𝗗 𝗜𝗡𝗗𝗜𝗩𝗜𝗗𝗨𝗔𝗟𝗦<br>𝗕𝗬 𝗡𝗨𝗧𝗥𝗜𝗧𝗜𝗢𝗡𝗔𝗟 𝗗𝗘𝗙𝗜𝗖𝗜𝗘𝗡𝗖𝗬 & 𝗛𝗔𝗜𝗥 𝗟𝗢𝗦𝗦 𝗢𝗨𝗧𝗖𝗢𝗠𝗘"
)

{
  "data": [
    {
      "type": "bar",
      "orientation": "h",
      "x": [45.65, 45.78, 46.46, 47.22, 50.00, 51.22, 51.28, 51.52, 52.22, 54.76],
      "y": [
        "Omega-3 fatty acids",
        "Vitamin E deficiency",
        "Biotin Deficiency",
        "Zinc Deficiency",
        "Vitamin D Deficiency",
        "Selenium deficiency",
        "Iron deficiency",
        "Vitamin A Deficiency",
        "Protein deficiency",
        "Magnesium deficiency"
      ],
      "name": "With Baldness",
      "marker": {"color": "#FF6347"},
      "textposition": "auto",
      "customdata": [42, 38, 46, 51, 52, 42, 40, 51, 47, 46],
      "hovertemplate": "<b>Percentage:</b> %{x}%<br><b>Count:</b> %{customdata}"
    },
    {
      "type": "bar",
      "orientation": "h",
      "x": [54.35, 54.22, 53.54, 52.78, 50.00, 48.78, 48.72, 48.48, 47.78, 45.24],
      "y": [
        "Omega-3 fatty acids",
        "Vitamin E deficiency",
        "Biotin Deficiency",
        "Zinc Deficiency",
        "Vitamin D Deficiency",
        "Selenium deficiency",
        "Iron deficiency",
        "Vitamin A Deficiency",
        "Protein deficiency",
        "Magnesium deficiency"
      ],
      "name": "Without Baldness",
      "marker": {"color": "#8c8c8c"},
      "textposition": "auto",
      "customdata": [50, 45, 53, 57, 52, 40, 38, 48, 43, 38],
      "hovertemplate": "<b>Percentage:</b> %{x}%<br><b>Count:</b> %{customdata}"
    }
  ],
  "layout": {
    "barmode": "stack",
    "title": {
      "text": "<br><b>𝗙𝗜𝗚. 𝟴﹕𝗦𝗨𝗥𝗩𝗘𝗬𝗘𝗗 𝗜𝗡𝗗𝗜𝗩𝗜𝗗𝗨𝗔𝗟𝗦<br>𝗕𝗬 𝗡𝗨𝗧𝗥𝗜𝗧𝗜𝗢𝗡𝗔𝗟 𝗗𝗘𝗙𝗜𝗖𝗜𝗘𝗡𝗖𝗬 & 𝗛𝗔𝗜𝗥 𝗟𝗢𝗦𝗦 𝗢𝗨𝗧𝗖𝗢𝗠𝗘</b>",
      "font": {"family": "ITC Officina Sans", "size": 20},
      "x": 0.5,
      "xanchor": "center",
      "y": 0.93
    },
    "xaxis": {
      "title": {
        "text": "Percentage (%)",
        "font": {"family": "ITC Officina Sans", "size": 16}
      },
      "tickfont": {"family": "ITC Officina Sans", "size": 15},
      "range": [0, 100]
    },
    "yaxis": {
      "title": {
        "text": "<br><b>Nutritional Deficiency</b>",
        "font": {"family": "ITC Officina Sans", "size": 18}
      },
      "tickfont": {"family": "ITC Officina Sans", "size": 15},
      "categoryorder": "array",
      "categoryarray": [
        "Omega-3 fatty acids",
        "Vitamin E deficiency",
        "Biotin Deficiency",
        "Zinc Deficiency",
        "Vitamin D Deficiency",
        "Selenium deficiency",
        "Iron deficiency",
        "Vitamin A Deficiency",
        "Protein deficiency",
        "Magnesium deficiency"
      ]
    },
    "plot_bgcolor": "#D5E4EB",
    "paper_bgcolor": "#D5E4EB",
    "margin": {"t": 95}
  }
}

where \(a\),\(b\),\(c\), and \(d\) represent the counts in the contingency table as shown below:

## Create proportional stacked bar plots

# Genetics
stackbar_plot1 <- create_plotly_stackbar(
  data, 
  "Genetics", 
  TRUE, 
  "\n\nGenetics\n", 
  yaxis_titleSize = 18, 
  yaxis_tickSize = 15, 
  tickangle = 0
)

# Hormonal Changes
stackbar_plot2 <- create_plotly_stackbar(
  data, 
  "Hormonal Changes", 
  FALSE, 
  "\n\nHormonal Changes\n", 
  yaxis_titleSize = 18, 
  yaxis_tickSize = 15, 
  tickangle = 0
)

# Combine the plots
subplot(stackbar_plot1, stackbar_plot2, nrows = 2, shareX = TRUE, shareY = TRUE) %>%
  layout(
    plot_bgcolor = "#D5E4EB",
    paper_bgcolor = "#D5E4EB",
    title = list(
      text = "𝗙𝗜𝗚. 𝟵﹕𝗦𝗨𝗥𝗩𝗘𝗬𝗘𝗗 𝗜𝗡𝗗𝗜𝗩𝗜𝗗𝗨𝗔𝗟𝗦<br>𝗕𝗬 𝗚𝗘𝗡𝗘𝗧𝗜𝗖𝗦, 𝗛𝗢𝗥𝗠𝗢𝗡𝗔𝗟 𝗖𝗛𝗔𝗡𝗚𝗘𝗦, & 𝗛𝗔𝗜𝗥 𝗟𝗢𝗦𝗦 𝗢𝗨𝗧𝗖𝗢𝗠𝗘", 
      font = list(family = "ITC Officina Sans", size = 18), 
      y = 0.93
    ),
    margin = list(t = 95),
    xaxis = list(tickfont = list(family = "ITC Officina Sans", size = 15))
  )

{
  "data": [
    {
      "type": "bar",
      "orientation": "h",
      "x": [51.72, 47.59],
      "y": ["<b>Genetics</b> - Yes", "<b>Genetics</b> - No"],
      "name": "With Baldness",
      "marker": {"color": "#FF6347"},
      "textposition": "auto",
      "customdata": [270, 227],
      "hovertemplate": "<b>Percentage:</b> %{x}%<br><b>Count:</b> %{customdata}"
    },
    {
      "type": "bar",
      "orientation": "h",
      "x": [48.28, 52.41],
      "y": ["<b>Genetics</b> - Yes", "<b>Genetics</b> - No"],
      "name": "Without Baldness",
      "marker": {"color": "#8c8c8c"},
      "textposition": "auto",
      "customdata": [252, 250],
      "hovertemplate": "<b>Percentage:</b> %{x}%<br><b>Count:</b> %{customdata}"
    },
    {
      "type": "bar",
      "orientation": "h",
      "x": [50.10, 49.39],
      "y": ["<b>Hormonal Changes</b> - Yes", "<b>Hormonal Changes</b> - No"],
      "name": "With Baldness",
      "marker": {"color": "#FF6347"},
      "textposition": "auto",
      "customdata": [255, 242],
      "hovertemplate": "<b>Percentage:</b> %{x}%<br><b>Count:</b> %{customdata}",
      "showlegend": false
    },
    {
      "type": "bar",
      "orientation": "h",
      "x": [49.90, 50.61],
      "y": ["<b>Hormonal Changes</b> - Yes", "<b>Hormonal Changes</b> - No"],
      "name": "Without Baldness",
      "marker": {"color": "#8c8c8c"},
      "textposition": "auto",
      "customdata": [254, 248],
      "hovertemplate": "<b>Percentage:</b> %{x}%<br><b>Count:</b> %{customdata}",
      "showlegend": false
    }
  ],
  "layout": {
    "barmode": "stack",
    "title": {
      "text": "<br><b>𝗙𝗜𝗚. 𝟵﹕𝗦𝗨𝗥𝗩𝗘𝗬𝗘𝗗 𝗜𝗡𝗗𝗜𝗩𝗜𝗗𝗨𝗔𝗟𝗦<br>𝗕𝗬 𝗚𝗘𝗡𝗘𝗧𝗜𝗖𝗦, 𝗛𝗢𝗥𝗠𝗢𝗡𝗔𝗟 𝗖𝗛𝗔𝗡𝗚𝗘𝗦, & 𝗛𝗔𝗜𝗥 𝗟𝗢𝗦𝗦 𝗢𝗨𝗧𝗖𝗢𝗠𝗘</b>",
      "font": {"family": "ITC Officina Sans", "size": 18},
      "x": 0.5,
      "xanchor": "center",
      "y": 0.93
    },
    "xaxis": {
      "title": {"text": "Percentage (%)", "font": {"family": "ITC Officina Sans", "size": 16}},
      "tickfont": {"family": "ITC Officina Sans", "size": 15},
      "range": [0, 100]
    },
    "yaxis": {
      "tickfont": {"family": "ITC Officina Sans", "size": 15},
      "categoryorder": "array",
      "categoryarray": [
        "<b>Hormonal Changes</b> - No",
        "<b>Hormonal Changes</b> - Yes",
        "<b>Genetics</b> - No",
        "<b>Genetics</b> - Yes"
      ]
    },
    "plot_bgcolor": "#D5E4EB",
    "paper_bgcolor": "#D5E4EB",
    "margin": {"t": 95}
  }
}

• Genetics: Among those with a family history of baldness, more individuals have experienced hair loss than those who have not.

• Hormonal Changes: The distribution is fairly balanced across hormonal changes and baldness experience groups, indicating no clear link in the dataset.

## Create proportional stacked bar plots for lifestyle factors

# Poor Hair Care Habits
stackbar_plot6 <- create_plotly_stackbar(
  data, 
  "Poor Hair Care Habits", 
  TRUE, 
  "\n\nPoor Hair\nCare Habits"
)

# Environmental Factors
stackbar_plot7 <- create_plotly_stackbar(
  data, 
  "Environmental Factors", 
  yaxis_text = "\n\nEnvironmental\n  Factors"
)

# Smoking
stackbar_plot8 <- create_plotly_stackbar(
  data, 
  "Smoking", 
  yaxis_text = "\n\nSmoking\n"
)

# Weight Loss
stackbar_plot9 <- create_plotly_stackbar(
  data, 
  "Weight Loss", 
  yaxis_text = "\n\nWeight Loss\n"
)

# Combine the plots
subplot(
  stackbar_plot6, 
  stackbar_plot7, 
  stackbar_plot8, 
  stackbar_plot9, 
  nrows = 4, 
  shareX = TRUE, 
  shareY = TRUE
) %>%
  layout(
    plot_bgcolor = "#D5E4EB",
    paper_bgcolor = "#D5E4EB",
    title = list(
      text = "<br><b>𝗙𝗜𝗚. 𝟭𝟬﹕𝗦𝗨𝗥𝗩𝗘𝗬𝗘𝗗 𝗜𝗡𝗗𝗜𝗩𝗜𝗗𝗨𝗔𝗟𝗦<br>𝗕𝗬 𝗟𝗜𝗙𝗘𝗦𝗧𝗬𝗟𝗘 𝗙𝗔𝗖𝗧𝗢𝗥 & 𝗛𝗔𝗜𝗥 𝗟𝗢𝗦𝗦 𝗢𝗨𝗧𝗖𝗢𝗠𝗘</b>", 
      font = list(family = "ITC Officina Sans", size = 18), 
      y = 0.93
    ),
    margin = list(t = 95),
    xaxis = list(
      tickfont = list(family = "ITC Officina Sans", size = 15)
    )
  )

{
  "data": [
    {
      "type": "bar",
      "orientation": "h",
      "x": [47.76, 51.68, 48.82, 50.71, 47.01, 52.71, 52.12, 47.63],
      "y": [
        "<b>Poor Hair Care Habits</b> - Yes",
        "<b>Poor Hair Care Habits</b> - No",
        "<b>Environmental Factors</b> - Yes",
        "<b>Environmental Factors</b> - No",
        "<b>Smoking</b> - Yes",
        "<b>Smoking</b> - No",
        "<b>Weight Loss</b> - Yes",
        "<b>Weight Loss</b> - No"
      ],
      "name": "With Baldness",
      "marker": {"color": "#FF6347"},
      "textposition": "auto",
      "customdata": [235, 262, 248, 249, 244, 253, 246, 251],
      "hovertemplate": "<b>Percentage:</b> %{x}%<br><b>Count:</b> %{customdata}"
    },
    {
      "type": "bar",
      "orientation": "h",
      "x": [52.24, 48.32, 51.18, 49.29, 52.99, 47.29, 47.88, 52.37],
      "y": [
        "<b>Poor Hair Care Habits</b> - Yes",
        "<b>Poor Hair Care Habits</b> - No",
        "<b>Environmental Factors</b> - Yes",
        "<b>Environmental Factors</b> - No",
        "<b>Smoking</b> - Yes",
        "<b>Smoking</b> - No",
        "<b>Weight Loss</b> - Yes",
        "<b>Weight Loss</b> - No"
      ],
      "name": "Without Baldness",
      "marker": {"color": "#8c8c8c"},
      "textposition": "auto",
      "customdata": [257, 245, 260, 242, 275, 227, 226, 276],
      "hovertemplate": "<b>Percentage:</b> %{x}%<br><b>Count:</b> %{customdata}"
    }
  ],
  "layout": {
    "barmode": "stack",
    "title": {
      "text": "<br><b>𝗙𝗜𝗚. 𝟭𝟬﹕𝗦𝗨𝗥𝗩𝗘𝗬𝗘𝗗 𝗜𝗡𝗗𝗜𝗩𝗜𝗗𝗨𝗔𝗟𝗦<br>𝗕𝗬 𝗟𝗜𝗙𝗘𝗦𝗧𝗬𝗟𝗘 𝗙𝗔𝗖𝗧𝗢𝗥 & 𝗛𝗔𝗜𝗥 𝗟𝗢𝗦𝗦 𝗢𝗨𝗧𝗖𝗢𝗠𝗘</b>",
      "font": {"family": "ITC Officina Sans", "size": 18},
      "x": 0.5,
      "xanchor": "center",
      "y": 0.93
    },
    "xaxis": {
      "title": {"text": "Percentage (%)", "font": {"family": "ITC Officina Sans", "size": 16}},
      "tickfont": {"family": "ITC Officina Sans", "size": 15},
      "range": [0, 100]
    },
    "yaxis": {
      "tickfont": {"family": "ITC Officina Sans", "size": 15},
      "categoryorder": "array",
      "categoryarray": [
        "<b>Weight Loss</b> - No",
        "<b>Weight Loss</b> - Yes",
        "<b>Smoking</b> - No",
        "<b>Smoking</b> - Yes",
        "<b>Environmental Factors</b> - No",
        "<b>Environmental Factors</b> - Yes",
        "<b>Poor Hair Care Habits</b> - No",
        "<b>Poor Hair Care Habits</b> - Yes"
      ]
    },
    "plot_bgcolor": "#D5E4EB",
    "paper_bgcolor": "#D5E4EB",
    "margin": {"t": 95}
  }
}

• Poor Hair Care Habits, Environmental Factors, and Smoking: Among those who practice poor hair care habits, are exposed to environmental factors, and smoke, fewer individuals reported baldness.
• Weight Loss: More individuals who experience significant weight loss reported baldness compared to those who do not experience such weight loss.

Overall, lifestyle factors show only slight differences between those with and without baldness.

## Compute phi coefficients

# Between Genetics and Hair Loss
genetics_phi <- compute_phi(data, x = "Genetics", y = "Hair Loss", u = "No", t = "Yes")

# Between Hormonal Changes and Hair Loss
hormonal_changes_phi <- compute_phi(data, x = "Hormonal Changes", y = "Hair Loss", u = "No", t = "Yes")

# Between Poor Hair Care Habits and Hair Loss
hair_care_phi <- compute_phi(data, x = "Poor Hair Care Habits", y = "Hair Loss", u = "No", t = "Yes")

# Between Environmental Factors and Hair Loss
envi_factors_phi <- compute_phi(data, x = "Environmental Factors", y = "Hair Loss", u = "No", t = "Yes")

# Between Smoking and Hair Loss
smoking_phi <- compute_phi(data, x = "Smoking", y = "Hair Loss", u = "No", t = "Yes")

# Between Weight Loss and Hair Loss
weight_loss_phi <- compute_phi(data, x = "Weight Loss", y = "Hair Loss", u = "No", t = "Yes")

# Tabularize the results
summarize_variable(
  bind_rows(
    genetics_phi, hormonal_changes_phi, hair_care_phi,
    envi_factors_phi, smoking_phi, weight_loss_phi
  ) %>%
    select(-y) %>%
    column_to_rownames("x"),
  rownames = TRUE
)

The results suggest that hormonal changes have a negligible positive association with hair loss. In contrast, Genetics and Weight Loss show a weak positive relationship, while Poor Hair Care Habits, Environmental Factors, and Smoking exhibit a weak negative relationship with hair loss.

4. Machine Learning

The previous analysis highlighted a balanced dataset with minimal individual association coefficients, indicating that hair loss is primarily influenced by a combination of factors. Given its multifaceted nature, leveraging machine learning algorithms can provide valuable insights into these contributing factors and facilitate in predicting hair loss outcomes.

4.1. Model Evaluation

Before selecting the model, respondents with incomplete data, especially those lacking information on medical history factors (e.g., medical conditions, medications and treatments, and nutritional deficiencies), were excluded. This resulted in a dataset of 809 observations. Furthermore, categories were converted into dummy variables to facilitate their inclusion in the models. The dataset was then split into training and testing sets using a 70:30 ratio to ensure a comprehensive evaluation of the models’ performance.

Three classification models—Logistic Regression, Support Vector Machine (SVM), and Random Forest—were initially considered. Their baseline performances were then assessed using five key metrics, as summarized in the table below:

# Data cleaning and handling missing values
new_data <- data %>%
  dplyr::select(-Id) %>%
  mutate(across(where(is.factor), as.character)) %>%
  rename(MedicationsTreatments = `Medications & Treatments`) %>% # Remove the special character in column name
  rename_with(~ gsub("\\ ", "", .)) %>%
  filter_all(all_vars(. != "No Data"))

# Use model.matrix to one-hot encode the specified columns
encoded_data <- model.matrix(~ MedicalConditions + MedicationsTreatments + NutritionalDeficiencies - 1, data = new_data) %>%
  as.data.frame() %>%
  rename_with(~ gsub("\\ ", "", .)) %>% # Remove spaces in column name
  mutate(across(everything(), ~ factor(., levels = c(0, 1))))

# Data with no encoding needed
not_encoded_data <- new_data %>%
  dplyr::select(-c(MedicalConditions, MedicationsTreatments, NutritionalDeficiencies))

# Combine the one-hot encoded columns back with the rest of the data
new_data <- cbind(not_encoded_data, encoded_data)

# Relabel response variable's factors for interpretability
new_data <- new_data %>%
  mutate(
    HairLoss = factor(HairLoss, levels = c(0, 1), labels = c("withoutBaldness", "withBaldness")),
    Stress = factor(Stress, levels = c("Low", "Moderate", "High"), labels = c(1, 2, 3), ordered = TRUE),
    across(where(is.character), ~ factor(., levels = c("No", "Yes"), labels = c(0, 1)))
  ) %>%
  dplyr::select(HairLoss, everything()) %>%
  rename(NutritionalDeficienciesOmega3fattyacids = `NutritionalDeficienciesOmega-3fattyacids`) # Remove the special character in column name

# Split the dataset into training and testing sets
set.seed(123)
trainIndex <- createDataPartition(new_data$HairLoss, p = 0.7, list = FALSE)
train_data <- new_data[trainIndex, ]
test_data <- new_data[-trainIndex, ]

# Define train control
train_control <- trainControl(
  method = "cv",
  number = 10,
  classProbs = TRUE,
  summaryFunction = twoClassSummary,
  verboseIter = FALSE
)

# Train the logistic regression model
set.seed(123)
logistic_model <- train(
  HairLoss ~ ., 
  data = train_data, 
  method = "glm", 
  family = "binomial", 
  trControl = train_control, 
  metric = "ROC",
  trace = FALSE
)

# Train the SVM model
set.seed(123)
svm_model <- train(
  HairLoss ~ .,
  data = train_data,
  method = "svmRadial",
  trControl = train_control,
  metric = "ROC",
  trace = FALSE
)

# Train the random forest model
set.seed(123)
rf_model <- train(
  HairLoss ~ ., 
  data = train_data, 
  method = "rf", 
  trControl = train_control, 
  metric = "ROC",
  trace = FALSE,
  importance = TRUE
)

# Evaluate models' performances
class_metrics <- rbind(
  evaluate_model(model = logistic_model, test = test_data, y = "HairLoss", model_name = "Logistic Regression"),
  evaluate_model(model = svm_model, test = test_data, y = "HairLoss", model_name = "SVM"),
  evaluate_model(model = rf_model, test = test_data, y = "HairLoss", model_name = "Random Forest")
)

# Tabularize the summarized metrics of the models
summarize_variable(class_metrics, rownames = TRUE)

• Logistic Regression: Achieves four metric values that exceed the 0.5 threshold, which may potentially be useful due to its simplicity and interpretability.
• Support Vector Machine (SVM): Exhibits the lowest performance, with accuracy and precision falling below 0.5.
• Random Forest: Outperforms the others, achieving the highest scores across all five metrics, with values of at least 0.58, including a relatively strong Area Under the Curve (AUC).

Given its superior performance and the balanced nature of the dataset, the Random Forest model is proposed for further tuning and optimization.

4.2. Cluster Analysis

Clustering is utilized to identify potential groups of individuals with similar characteristics, which enables the exploration of different patterns and relationships related to hair loss. Specifically, hierarchical clustering by agglomerative approach with complete linkages is applied, as it produces clearer and more cohesive clusters compared to a divisive approach (see Figure 11).

# Compute the dissimilarity matrix
gower_dist <- daisy(new_data, metric = c("gower"))

# Perform divisive hierarchical clustering
divisive_clust <- diana(as.matrix(gower_dist), diss = TRUE, keep.diss = TRUE)

# Perform agglomerative hierarchical clustering with complete linkages
aggl_clust_comp <- hclust(gower_dist, method = "complete")

# Data for dendrogram plots
divisive_dendro_data <- as.dendrogram(divisive_clust)
aggl_dendro_data <- as.dendrogram(aggl_clust_comp)

# Create a list of dendrograms
dend_list <- dendlist(divisive_dendro_data, aggl_dendro_data)

# Convert dendrograms to ggplot objects
ggd1 <- as.ggdend(dend_list[[1]])
ggd2 <- as.ggdend(dend_list[[2]])

# Create a ggplot for the divisive dendrogram
p1 <- ggplot(ggd1) +
  theme_minimal() +
  labs(x = "\nNumber of observations\n", y = NULL, title = "\nDivisive\n") +
  theme(
    plot.title = element_text(hjust = 0.5, family = "ITC Officina Sans", size = 14.5),
    axis.title.x = element_text(family = "ITC Officina Sans", size = 12),
    axis.title.y = element_text(family = "ITC Officina Sans", size = 12),
    axis.text.x = element_text(family = "ITC Officina Sans"),
    plot.background = element_rect(fill = "#D5E4EB", color = NA)
  )

# Create a ggplot for the agglomerative dendrogram
p2 <- ggplot(ggd2) + 
  theme_minimal() +
  labs(x = "\nNumber of observations\n", y = NULL, title = "\nAgglomerative with\ncomplete linkages") +
  theme(
    plot.title = element_text(hjust = 0.5, family = "ITC Officina Sans", size = 14.5),
    axis.title.x = element_text(family = "ITC Officina Sans", size = 12),
    axis.title.y = element_text(family = "ITC Officina Sans", size = 12),
    axis.text.y = element_blank(),
    axis.text = element_text(family = "ITC Officina Sans"),
    plot.background = element_rect(fill = "#D5E4EB", color = NA)
  )

# Combine plots
p12 <- arrangeGrob(
  p1, p2, nrow = 1, 
  top = grid::textGrob(
    "<br><b>𝗙𝗜𝗚. 𝟭𝟭﹕𝗗𝗘𝗡𝗗𝗥𝗢𝗚𝗥𝗔𝗠 𝗢𝗙 𝗛𝗜𝗘𝗥𝗔𝗥𝗖𝗛𝗜𝗖𝗔𝗟 𝗖𝗟𝗨𝗦𝗧𝗘𝗥𝗜𝗡𝗚<br>𝗕𝗬 𝗔𝗣𝗣𝗥𝗢𝗔𝗖𝗛</b>", 
    gp = grid::gpar(fontsize = 15, fontfamily = "ITC Officina Sans", fontface = "bold")
  ), 
  padding = unit(0.5, "line")
)

# Add background color to the title and draw the combined plot
grid.newpage()
grid.rect(gp = gpar(fill = "#D5E4EB", col = NA))
grid.draw(p12)

4.2.1 Number of Clusters

The dendrogram generated through hierarchical clustering highlights the presence of two main branches. To supplement this analysis, methods such as the Elbow Plot and Silhouette Analysis are also employed to determine the optimal number of clusters.

# Data for scree plot using elbow method
max <- 10
clus_plot_data <- data.frame(t(cstats.table(gower_dist, aggl_clust_comp, max))) %>%
  rename(
    `Cluster number` = cluster.number,
    `Within sum of squares (WSS)` = within.cluster.ss,
    `Average silhouette width` = avg.silwidth
  )

# Elbow Method
elbow_plot <- ggplot(data = clus_plot_data, 
                     aes(x = `Cluster number`, y = `Within sum of squares (WSS)`)) + 
  geom_point() +
  geom_line() +
  # geom_vline(xintercept = 4, linetype="dotted", color = "red", linewidth=0.5) +
  ggtitle("") +
  theme(
    plot.title = element_text(hjust = 0.5, family = "ITC Officina Sans"),
    axis.title.x = element_text(family = "ITC Officina Sans", size = 13.5),
    axis.title.y = element_text(family = "ITC Officina Sans", size = 13.5),
    axis.text = element_text(family = "ITC Officina Sans")
  )

# Convert ggplot to plotly
elbow_plotly <- ggplotly(elbow_plot) %>%
  layout(
    hoverlabel = list(font = list(family = "ITC Officina Sans", size = 15)),
    plot_bgcolor = "#D5E4EB",
    paper_bgcolor = "#D5E4EB",
    title = list(
      text = "𝗙𝗜𝗚. 𝟭𝟮﹕𝗢𝗣𝗧𝗜𝗠𝗔𝗟 𝗡𝗨𝗠𝗕𝗘𝗥 𝗢𝗙 𝗖𝗟𝗨𝗦𝗧𝗘𝗥𝗦 𝗨𝗦𝗜𝗡𝗚 𝗘𝗟𝗕𝗢𝗪 𝗠𝗘𝗧𝗛𝗢𝗗", 
      font = list(family = "ITC Officina Sans", size = 18), 
      y = 0.93
    ),
    margin = list(t = 75)
  )

# Silhouette Method
sil_plot <- ggplot(data = clus_plot_data, 
                   aes(x = `Cluster number`, y = `Average silhouette width`)) + 
  geom_point() +
  geom_line() +
  # geom_vline(xintercept = 4, linetype="dotted", color = "red", linewidth=0.5) +
  ggtitle("") +
  theme(
    plot.title = element_text(hjust = 0.5, family = "ITC Officina Sans"),
    axis.title.x = element_text(family = "ITC Officina Sans", size = 13.5),
    axis.title.y = element_text(family = "ITC Officina Sans", size = 13.5),
    axis.text = element_text(family = "ITC Officina Sans")
  )

# Convert ggplot to plotly
sil_plotly <- ggplotly(sil_plot) %>%
  layout(
    hoverlabel = list(font = list(family = "ITC Officina Sans", size = 15)),
    plot_bgcolor = "#D5E4EB",
    paper_bgcolor = "#D5E4EB",
    title = list(
      text = "<br><b>𝗙𝗜𝗚. 𝟭𝟮﹕𝗢𝗣𝗧𝗜𝗠𝗔𝗟 𝗡𝗨𝗠𝗕𝗘𝗥 𝗢𝗙 𝗖𝗟𝗨𝗦𝗧𝗘𝗥𝗦<br>𝗨𝗦𝗜𝗡𝗚 𝗘𝗟𝗕𝗢𝗪 & 𝗦𝗜𝗟𝗛𝗢𝗨𝗘𝗧𝗧𝗘 𝗠𝗘𝗧𝗛𝗢𝗗𝗦</b>", 
      font = list(family = "ITC Officina Sans", size = 18), 
      y = 0.93
    ),
    margin = list(t = 75)
  )

# Combine the plots
combined_plotly <- subplot(
  elbow_plotly, 
  sil_plotly, 
  nrows = 1, 
  titleX = TRUE, 
  titleY = TRUE, 
  margin = 0.04
)

{
  "data": [
    {
      "type": "scatter",
      "mode": "lines+markers",
      "x": [2, 3, 4, 5, 6, 7, 8, 9, 10],
      "y": [25.50, 24.90, 24.27, 23.81, 23.36, 22.80, 22.34, 21.79, 21.36],
      "name": "Within sum of squares (WSS)",
      "marker": {"color": "#FF6347", "size": 8},
      "line": {"color": "#FF6347", "width": 2},
      "hovertemplate": "<b>Cluster:</b> %{x}<br><b>Within sum of squares (WSS)</b> %{y}<extra></extra>"
    },
    {
      "type": "scatter",
      "mode": "lines+markers",
      "x": [2, 3, 4, 5, 6, 7, 8, 9, 10],
      "y": [0.02, 0.01, 0.01, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00],
      "xaxis": "x2",
      "yaxis": "y2",
      "name": "Average silhouette width",
      "marker": {"color": "#4682B4", "size": 8},
      "line": {"color": "#4682B4", "width": 2},
      "hovertemplate": "<b>Cluster:</b> %{x}<br><b>Average silhouette width:</b> %{y}<extra></extra>"
    }
  ],
  "layout": {
    "grid": {"rows": 1, "columns": 2, "pattern": "independent"},
    "plot_bgcolor": "#D5E4EB",
    "paper_bgcolor": "#D5E4EB",
    "title": {
      "text": "<br><b>𝗙𝗜𝗚. 𝟭𝟮﹕𝗢𝗣𝗧𝗜𝗠𝗔𝗟 𝗡𝗨𝗠𝗕𝗘𝗥 𝗢𝗙 𝗖𝗟𝗨𝗦𝗧𝗘𝗥𝗦<br>𝗨𝗦𝗜𝗡𝗚 𝗘𝗟𝗕𝗢𝗪 & 𝗦𝗜𝗟𝗛𝗢𝗨𝗘𝗧𝗧𝗘 𝗠𝗘𝗧𝗛𝗢𝗗𝗦</b>",
      "font": {"family": "ITC Officina Sans", "size": 18},
      "x": 0.5,
      "xanchor": "center",
      "y": 0.93
    },
    "xaxis": {
      "title": {"text": "Cluster number", "font": {"family": "ITC Officina Sans", "size": 13.5}},
      "tickfont": {"family": "ITC Officina Sans", "size": 12.5}
    },
    "yaxis": {
      "title": {"text": "Within sum of squares (WSS)", "font": {"family": "ITC Officina Sans", "size": 13.5}},
      "tickfont": {"family": "ITC Officina Sans", "size": 12.5}
    },
    "xaxis2": {
      "title": {"text": "Cluster number", "font": {"family": "ITC Officina Sans", "size": 13.5}},
      "tickfont": {"family": "ITC Officina Sans", "size": 12.5},
      "anchor": "y2",
      "domain": [0.55, 1.0]
    },
    "yaxis2": {
      "title": {"text": "Average silhouette width", "font": {"family": "ITC Officina Sans", "size": 13.5}},
      "tickfont": {"family": "ITC Officina Sans", "size": 12.5},
      "domain": [0, 1]
    },
    "hoverlabel": {"font": {"family": "ITC Officina Sans", "size": 15}},
    "margin": {"t": 80, "l": 65, "r": 40, "b": 60},
    "showlegend": false
  }
}

Silhouette Analysis:

• The silhouette width, which measures the quality of clustering, drops significantly after 2 clusters.
• It remains relatively constant between 3 and 4 clusters and gradually approaches near zero at 6 clusters, remaining stable beyond this point.
• The highest average silhouette width occurs at 2 clusters; this is considered the optimal number for further analysis.

4.2.2. Cluster Visualization

The graph below provides a clearer representation of the formation of two distinct clusters, each highlighted by a specific color.

# Cut the dendrogram to form clusters
k <- 2  # Choose the number of clusters
clusters <- cutree(as.hclust(aggl_clust_comp), k = 2)

# Make a data copy
new_data1 <- new_data

# Add cluster assignments to the original data
new_data1$Cluster <- as.factor(clusters)

# Dendrogram data for Agglomerative clustering
dendro_col <- as.dendrogram(aggl_clust_comp) %>%
  set("branches_k_color", k = 2, value = c("#01877C", "#005289")) %>%
  set("branches_lwd", 0.6) %>%
  set("labels_colors", value = c("darkslategray")) %>%
  set("labels_cex", 0.2)

# Radial graph
radial_graph <- ggplot(as.ggdend(dendro_col), labels = TRUE) + 
  labs(title = "<br>𝗙𝗜𝗚. 𝟭𝟯﹕ 𝗥𝗔𝗗𝗜𝗔𝗟 𝗚𝗥𝗔𝗣𝗛 𝗢𝗙 𝗧𝗛𝗘 𝗧𝗪𝗢 𝗖𝗟𝗨𝗦𝗧𝗘𝗥𝗦") +
  scale_y_reverse(expand = c(0.2, 0)) +
  coord_polar(theta = "x") +
  theme(
    plot.title = element_text(hjust = 0.5, family = "ITC Officina Sans", size = 15),
    axis.title.x = element_blank(),
    axis.title.y = element_blank(),
    axis.text.x = element_blank(),
    axis.text.y = element_blank(),
    axis.ticks = element_blank(),
    plot.background = element_rect(fill = "#D5E4EB", color = NA)
  )

Alternatively, the heatmap in Figure 14 visually represents relationships between the two identified clusters and various categorical features associated with hair loss. The intensity of the color gradient, ranging from white to dark orange, reflects the percentage of individuals with hair loss for each specific feature.

# Reshape data with cluster numbers to long format
clust_long <- melt(
  new_data1, 
  id.vars = c("Cluster", "Age", "HairLoss", "Stress"),
  variable.name = "Variable", 
  value.name = "Value"
)

# Calculate counts and percentages for heatmap
clust_long_summ <- clust_long %>%
  group_by(Cluster, Variable, Value, HairLoss) %>%
  summarise(Count = n(), .groups = "drop") %>%
  group_by(Cluster, Variable, Value) %>%
  mutate(Percentage = Count / sum(Count)) %>%
  ungroup() %>%
  filter(Value == "1", HairLoss == "withBaldness")

# Create heatmap
clus_heatmap <- plot_ly(
  data = clust_long_summ,
  x = ~Cluster,
  y = ~Variable,
  z = ~Percentage,
  type = "heatmap",
  colors = colorRamp(c("white", "#FF6347")),
  text = ~paste("<b>Cluster:</b>", Cluster, "<br><b>Feature:</b>", Variable, "<br><b>Percentage of individuals with feature and baldness:</b>", label_percent(accuracy = 0.01)(round(Percentage, 4))),
  hoverinfo = "text"
) %>%
  layout(
    title = "Heatmap of Cluster vs Feature",
    xaxis = list(
      title = "Cluster", 
      titlefont = list(family = "ITC Officina Sans", size = 18), 
      tickfont = list(family = "ITC Officina Sans")
    ),
    yaxis = list(
      title = "Feature", 
      titlefont = list(family = "ITC Officina Sans", size = 18), 
      tickfont = list(family = "ITC Officina Sans", size = 10), 
      showticklabels = TRUE
    )
  ) %>%
  layout(
    title = list(
      text = "<br><b>𝗙𝗜𝗚. 𝟭𝟰﹕𝗖𝗟𝗨𝗦𝗧𝗘𝗥 𝗩𝗦. 𝗙𝗘𝗔𝗧𝗨𝗥𝗘</b>",
      font = list(size = 18)
    ),
    paper_bgcolor = "#D5E4EB",
    margin = list(l = 30, r = 30, b = 25, t = 70)
  ) %>%
  style(
    hoverlabel = list(
      font = list(
        family = "ITC Officina Sans",
        size = 15
      )
    )
  )

{
  "data": [
    {
      "x": ["1", "2"],
      "y": [
        "Genetics", "HormonalChanges", "PoorHairCareHabits", "EnvironmentalFactors",
        "Smoking", "WeightLoss", "MedicalConditionsAlopeciaAreata",
        "MedicalConditionsAndrogeneticAlopecia", "MedicalConditionsDermatitis",
        "MedicalConditionsDermatosis", "MedicalConditionsEczema",
        "MedicalConditionsPsoriasis", "MedicalConditionsRingworm",
        "MedicalConditionsScalpInfection", "MedicalConditionsSeborrheicDermatitis",
        "MedicalConditionsThyroidProblems", "MedicationsTreatmentsAntibiotics",
        "MedicationsTreatmentsAntidepressants", "MedicationsTreatmentsAntifungalCream",
        "MedicationsTreatmentsBloodPressureMedication", "MedicationsTreatmentsChemotherapy",
        "MedicationsTreatmentsHeartMedication", "MedicationsTreatmentsImmunomodulators",
        "MedicationsTreatmentsRogaine", "MedicationsTreatmentsSteroids",
        "NutritionalDeficienciesIrondeficiency", "NutritionalDeficienciesMagnesiumdeficiency",
        "NutritionalDeficienciesOmega3fattyacids", "NutritionalDeficienciesProteindeficiency",
        "NutritionalDeficienciesSeleniumdeficiency", "NutritionalDeficienciesVitaminADeficiency",
        "NutritionalDeficienciesVitaminDDeficiency", "NutritionalDeficienciesVitaminEdeficiency",
        "NutritionalDeficienciesZincDeficiency"
      ],
      "z": [
        [0.4508, 0.6735], [0.4607, 0.5580], [0.4196, 0.5575], [0.4225, 0.6797],
        [0.3694, 0.5950], [0.4167, 0.6726], [0.4565, 0.6923], [0.5472, 0.5556],
        [0.4211, 0.5227], [0.2000, 0.6600], [0.3750, 0.6400], [0.5000, 0.5152],
        [0.3902, 0.6316], [0.4667, 0.5000], [0.5143, 0.5909], [0.3594, 0.5926],
        [0.4524, 0.6667], [0.3243, 0.6000], [0.4286, 0.5091], [0.5111, 0.4000],
        [0.4412, 0.6471], [0.4667, 0.5789], [0.3750, 0.4615], [0.3455, 0.7174],
        [0.4762, 0.7500], [0.5000, 0.6429], [0.5263, 0.6667], [0.3469, 0.6364],
        [0.4000, 0.6923], [0.6154, 0.3448], [0.4444, 0.6216], [0.3636, 0.5410],
        [0.3636, 0.6053], [0.2979, 0.6327]
      ],
      "type": "heatmap",
      "colorscale": [
        [0, "white"],
        [1, "#FF6347"]
      ],
      "showscale": true,
      "colorbar": {
        "title": "Percentage",
        "tickformat": ".0%",
        "titlefont": {"family": "ITC Officina Sans", "size": 14},
        "tickfont": {"family": "ITC Officina Sans", "size": 12}
      },
      "hovertemplate": "<b>Cluster:</b> %{x}<br><b>Feature:</b> %{y}<br><b>Percentage of individuals with feature and baldness:</b> %{z:.2%}<extra></extra>"
    }
  ],
  "layout": {
    "title": {
      "text": "<br><b>𝗙𝗜𝗚. 𝟭𝟰﹕𝗖𝗟𝗨𝗦𝗧𝗘𝗥 𝗩𝗦. 𝗙𝗘𝗔𝗧𝗨𝗥𝗘</b>",
      "font": {"family": "ITC Officina Sans", "size": 18},
      "x": 0.5,
      "xanchor": "center"
    },
    "xaxis": {
      "title": {"text": "Cluster", "font": {"family": "ITC Officina Sans", "size": 18}},
      "tickfont": {"family": "ITC Officina Sans"}
    },
    "yaxis": {
      "title": {"text": "Feature", "font": {"family": "ITC Officina Sans", "size": 18}},
      "tickfont": {"family": "ITC Officina Sans", "size": 10},
      "automargin": true
    },
    "hoverlabel": {"font": {"family": "ITC Officina Sans", "size": 15}},
    "plot_bgcolor": "#D5E4EB",
    "paper_bgcolor": "#D5E4EB",
    "margin": {"l": 120, "r": 30, "b": 25, "t": 70}
  }
}

• Both clusters exhibit similar patterns for features associated with medical conditions, including scalp infection, psoriasis, and androgenetic alopecia, as well as hormonal changes and medications and treatments such as immunomodulators.
• A notable difference emerges in the feature related to selenium deficiency, with Cluster 2 showing a significantly higher percentage compared to Cluster 1.
• Overall, Cluster 2 shows higher percentages of individuals with both a specific feature and baldness compared to Cluster 1. This suggests stronger feature-related associations with hair loss in Cluster 2.

4.3. Importance Analysis

Importance measures are examined to determine which features contribute most significantly to the model’s performance, thereby identifying the key predictors of hair loss.

4.3.1. Mean Decrease (MD) Measures

Figure 15 visualizes the importance of various features in the model by showing how much the accuracy decreases when each feature is removed (Absolute Mean Decrease Accuracy).

# Extract features importances
rf_importance <- as.data.frame(importance(rf_model$finalModel))[, 3:4] %>%
  rownames_to_column("Feature") %>%
  filter(MeanDecreaseAccuracy > 0) %>%
  mutate(Feature = gsub("1$", "", Feature))

# Create a bar plot by MDA
importance_plot_mda <- plot_ly(
  slice(rf_importance %>% arrange(desc(MeanDecreaseAccuracy)), 1:20), # Top 20 features
  x = ~abs(MeanDecreaseAccuracy), 
  y = ~reorder(Feature, abs(MeanDecreaseAccuracy)), 
  type = "bar", 
  orientation = "h",
  marker = list(color = "#005289")
) %>%
  layout(
    xaxis = list(
      title = "Absolute Mean Decrease Accuracy",
      tickfont = list(family = "ITC Officina Sans", size = 13.5),
      titlefont = list(family = "ITC Officina Sans", size = 16.5)
    ),
    yaxis = list(
      title = "Feature", 
      showticklabels = TRUE,
      tickfont = list(family = "ITC Officina Sans", size = 12),
      titlefont = list(family = "ITC Officina Sans", size = 16.5)
    ),
    paper_bgcolor = "#D5E4EB",
    plot_bgcolor = "#D5E4EB",
    margin = list(l = 30, r = 30, b = 25, t = 100)
  ) %>%
  style(
    hoverlabel = list(
      font = list(
        family = "ITC Officina Sans",
        size = 15
      )
    )
  ) %>%
  layout(
    title = list(
      text = "<br><b>𝗙𝗜𝗚. 𝟭𝟱﹕𝗙𝗘𝗔𝗧𝗨𝗥𝗘 𝗜𝗠𝗣𝗢𝗥𝗧𝗔𝗡𝗖𝗘 𝗕𝗬 𝗠𝗘𝗔𝗡 𝗗𝗘𝗖𝗥𝗘𝗔𝗦𝗘 𝗔𝗖𝗖𝗨𝗥𝗔𝗖𝗬</b>",
      font = list(size = 18)
    ),
    paper_bgcolor = "#D5E4EB",
    plot_bgcolor = "#D5E4EB",
    margin = list(l = 30, r = 30, b = 25, t = 60)
  ) %>%
  style(
    hoverlabel = list(
      font = list(
        family = "ITC Officina Sans",
        size = 15
      )
    )
  )

{
  "data": [
    {
      "type": "bar",
      "orientation": "h",
      "x": [
        0.410533117,
        0.5125133257,
        0.9303964862,
        1.165859495,
        1.692938138,
        1.90421985,
        1.932613685,
        2.273669871,
        2.354332772,
        2.464625269,
        2.492441677,
        2.820749482,
        3.292914027,
        3.777786437,
        3.893870349,
        4.108564852,
        4.79762658,
        5.99272817,
        6.881902389,
        8.132302347
      ],
      "y": [
        "Genetics",
        "MedicationsTreatmentsBloodPressureMedication",
        "MedicationsTreatmentsSteroids",
        "MedicalConditionsScalpInfection",
        "MedicationsTreatmentsAntidepressants",
        "NutritionalDeficienciesMagnesiumdeficiency",
        "MedicationsTreatmentsChemotherapy",
        "WeightLoss",
        "HormonalChanges",
        "MedicationsTreatmentsRogaine",
        "MedicalConditionsAlopeciaAreata",
        "Stress.Q",
        "MedicalConditionsPsoriasis",
        "EnvironmentalFactors",
        "NutritionalDeficienciesProteindeficiency",
        "NutritionalDeficienciesZincDeficiency",
        "MedicationsTreatmentsImmunomodulators",
        "Smoking",
        "Age",
        "Stress.L"
      ],
      "marker": {
        "color": "#005289"
      },
      "hovertemplate": "(%{x:.4f}, %{y})<extra></extra>"
    }
  ],
  "layout": {
    "title": {
      "text": "<br><b>𝗙𝗜𝗚. 𝟭𝟱﹕𝗙𝗘𝗔𝗧𝗨𝗥𝗘 𝗜𝗠𝗣𝗢𝗥𝗧𝗔𝗡𝗖𝗘 𝗕𝗬 𝗠𝗘𝗔𝗡 𝗗𝗘𝗖𝗥𝗘𝗔𝗦𝗘 𝗔𝗖𝗖𝗨𝗥𝗔𝗖𝗬</b>",
      "font": {
        "family": "ITC Officina Sans",
        "size": 18
      },
      "x": 0.5,
      "xanchor": "center"
    },
    "xaxis": {
      "title": {
        "text": "Absolute Mean Decrease Accuracy",
        "font": {"family": "ITC Officina Sans", "size": 16.5}
      },
      "tickfont": {"family": "ITC Officina Sans", "size": 13.5}
    },
    "yaxis": {
      "title": {"text": "Feature", "font": {"family": "ITC Officina Sans", "size": 16.5}},
      "tickfont": {"family": "ITC Officina Sans", "size": 12}
    },
    "hoverlabel": {
      "font": {"family": "ITC Officina Sans", "size": 15}
    },
    "plot_bgcolor": "#D5E4EB",
    "paper_bgcolor": "#D5E4EB",
    "margin": {"l": 120, "r": 30, "b": 25, "t": 70}
  }
}

• Stress in its linear form (represented by Stress.L) emerges as the most influential feature, closely followed by age and smoking.
• Features related to medications and treatments (e.g., immunomodulators and Rogaine), nutritional deficiencies (e.g., zinc and protein deficiency), environmental factors, medical conditions (e.g., psoriasis and alopecia areata), and the quadratic form of stress also contribute substantially to the model’s predictive capabilities.

# Create a bar plot by MDG
importance_plot_mdg <- plot_ly(
  slice(rf_importance %>% arrange(desc(MeanDecreaseGini)), 1:20), # Top 20 features
  x = ~abs(MeanDecreaseGini), 
  y = ~reorder(Feature, abs(MeanDecreaseGini)), 
  type = "bar", 
  orientation = "h",
  marker = list(color = "#01877C")
) %>%
layout(
  xaxis = list(
    title = "Absolute Mean Decrease Gini",
    tickfont = list(family = "ITC Officina Sans", size = 13.5),
    titlefont = list(family = "ITC Officina Sans", size = 16.5)
  ),
  yaxis = list(
    title = "Feature", 
    showticklabels = TRUE,
    tickfont = list(family = "ITC Officina Sans", size = 12),
    titlefont = list(family = "ITC Officina Sans", size = 16.5)
  ),
  paper_bgcolor = "#D5E4EB",
  plot_bgcolor = "#D5E4EB",
  margin = list(l = 30, r = 30, b = 25, t = 100)
) %>%
style(
  hoverlabel = list(
    font = list(
      family = "ITC Officina Sans",
      size = 15
    )
  )
) %>%
layout(
  title = list(
    text = "<br><b>𝗙𝗜𝗚. 𝟭𝟲﹕𝗙𝗘𝗔𝗧𝗨𝗥𝗘 𝗜𝗠𝗣𝗢𝗥𝗧𝗔𝗡𝗖𝗘 𝗕𝗬 𝗠𝗘𝗔𝗡 𝗗𝗘𝗖𝗥𝗘𝗔𝗦𝗘 𝗚𝗜𝗡𝗜</b>",
    font = list(size = 18)
  ),
  paper_bgcolor = "#D5E4EB",
  plot_bgcolor = "#D5E4EB",
  margin = list(l = 30, r = 30, b = 25, t = 60)
) %>%
style(
  hoverlabel = list(
    font = list(
      family = "ITC Officina Sans",
      size = 15
    )
  )
)