##########################################################
# Perceptual and Preference Mapping in R                 #
# Chestnut Ridge Competitive Positioning Example         #
##########################################################

# This script reproduces the full Chestnut Ridge perceptual and preference mapping example in R:
#   Step 1. Principal components analysis (PCA) on consumer perceptions
#   Step 2. Perceptual map data (attribute vectors and brand positions)
#   Step 3. Perceptual map of retailers and attributes
#   Step 4. Joint perceptual and preference map (adds consumer preferences)
#   Step 5. Market share predictions (first choice and share of preference rules)
# Run it from top to bottom. Each step prints its result to the console or Plots pane.

## Install Packages (if needed - only installs packages that are missing)
packages <- c("dplyr", "ggplot2", "ggrepel")
new_packages <- packages[!(packages %in% installed.packages()[, "Package"])]
if (length(new_packages) > 0) install.packages(new_packages)

## Load Packages
library(dplyr)     # data manipulation
library(ggplot2)   # plots and maps
library(ggrepel)   # labels that do not overlap on the maps

## Set Seed
# Setting the seed ensures your results are the same as the results in this example.
set.seed(1)

# Import Data
# check.names = FALSE keeps the original column names (e.g., "Customer Service"),
# which are used as labels on the maps
per <- read.csv(file.choose(), check.names = FALSE)  ## Choose perceptions.csv file
pref <- read.csv(file.choose(), check.names = FALSE) ## Choose preferences.csv file


#####################################################
# Step 1: Principal Components Analysis             #
#####################################################

# The seven attributes (all columns except Brand)
attributes <- colnames(per)[-1]

# Run PCA on the perception ratings
# scale = TRUE standardizes each attribute so all are measured on the same scale
pca <- prcomp(per[, attributes], retx = TRUE, scale = TRUE)

# Share of the variance in perceptions explained by each principal component
# The first two components are the two dimensions (Factor 1 and Factor 2) of the map
summary(pca)


#####################################################
# Step 2: Perceptual Map Data                       #
#####################################################

# Attribute vectors: the loadings of each attribute on the first two components.
# Multiplying by the standard deviation of each component gives the correlation
# between the attribute and the component, so each vector runs from -1 to 1.
attribute_vectors <- data.frame(attribute = attributes,
                                factor1 = pca$rotation[, 1] * pca$sdev[1],
                                factor2 = pca$rotation[, 2] * pca$sdev[2],
                                row.names = NULL)

cat("\nAttribute Vectors (Loadings on Factor 1 and Factor 2)\n")
print(mutate(attribute_vectors, across(c(factor1, factor2), ~ round(.x, 2))), row.names = FALSE)

# Brand positions: the component scores of each retailer, rescaled so the
# retailer farthest from the center on each dimension sits at -1 or 1.
# This puts the brands on the same scale as the attribute vectors.
brand_positions <- data.frame(brand = per$Brand,
                              score1 = pca$x[, 1] / max(abs(pca$x[, 1])),
                              score2 = pca$x[, 2] / max(abs(pca$x[, 2])))

cat("\nBrand Positions (Scores on Factor 1 and Factor 2)\n")
print(mutate(brand_positions, across(c(score1, score2), ~ round(.x, 2))), row.names = FALSE)


#####################################################
# Step 3: Perceptual Map                            #
#####################################################

ggplot() +
  geom_hline(yintercept = 0, color = "grey85") +
  geom_vline(xintercept = 0, color = "grey85") +
  # Attribute vectors drawn from the origin
  geom_segment(data = attribute_vectors,
               aes(x = 0, y = 0, xend = factor1, yend = factor2),
               arrow = arrow(length = unit(0.2, "cm")), color = "grey40") +
  geom_text_repel(data = attribute_vectors,
                  aes(x = factor1, y = factor2, label = attribute),
                  size = 3.5, color = "grey20", seed = 1) +
  # Retailer positions
  geom_point(data = brand_positions, aes(x = score1, y = score2),
             size = 3, color = "firebrick") +
  geom_text_repel(data = brand_positions,
                  aes(x = score1, y = score2, label = brand),
                  size = 3.5, fontface = "bold", color = "firebrick", seed = 1) +
  coord_equal(xlim = c(-1.1, 1.1), ylim = c(-1.1, 1.1)) +
  labs(title = "Perceptual Map of Retailers and Attributes",
       x = "Factor 1", y = "Factor 2") +
  theme_minimal()

# Retailers close together are perceived as similar. A retailer located far along
# an attribute vector is perceived as strong on that attribute.


#####################################################
# Step 4: Joint Perceptual and Preference Map       #
#####################################################

# Each respondent's preference vector is the weighted sum of the brand positions,
# using that respondent's 0-10 preference ratings as weights. Respondents who like
# a retailer are pulled toward that retailer's position on the map.
preference_matrix <- as.matrix(pref[, brand_positions$brand])
brand_matrix <- as.matrix(brand_positions[, c("score1", "score2")])
respondent_points <- preference_matrix %*% brand_matrix

# Rescale so the respondent farthest from the center on each dimension sits at -1 or 1
respondent_points[, 1] <- respondent_points[, 1] / max(abs(respondent_points[, 1]))
respondent_points[, 2] <- respondent_points[, 2] / max(abs(respondent_points[, 2]))

respondent_preferences <- data.frame(respondent = pref$Respondents,
                                     score1 = respondent_points[, 1],
                                     score2 = respondent_points[, 2])

# Each point marks the tip of a respondent's preference vector. The vectors
# themselves are not drawn to reduce clutter.
ggplot() +
  geom_hline(yintercept = 0, color = "grey85") +
  geom_vline(xintercept = 0, color = "grey85") +
  # Consumer preferences
  geom_point(data = respondent_preferences,
             aes(x = score1, y = score2, color = "Consumer Preference"),
             size = 2, alpha = 0.7) +
  # Attribute vectors drawn from the origin
  geom_segment(data = attribute_vectors,
               aes(x = 0, y = 0, xend = factor1, yend = factor2),
               arrow = arrow(length = unit(0.2, "cm")), color = "grey40") +
  geom_text_repel(data = attribute_vectors,
                  aes(x = factor1, y = factor2, label = attribute),
                  size = 3.5, color = "grey20", seed = 1) +
  # Retailer positions
  geom_point(data = brand_positions,
             aes(x = score1, y = score2, color = "Retailer"),
             size = 3) +
  geom_text_repel(data = brand_positions,
                  aes(x = score1, y = score2, label = brand),
                  size = 3.5, fontface = "bold", color = "firebrick", seed = 1) +
  scale_color_manual(values = c("Consumer Preference" = "steelblue", "Retailer" = "firebrick"),
                     name = NULL) +
  coord_equal(xlim = c(-1.1, 1.1), ylim = c(-1.1, 1.1)) +
  labs(title = "Joint Perceptual and Preference Map of Retailers and Attributes",
       x = "Factor 1", y = "Factor 2") +
  theme_minimal() +
  theme(legend.position = "bottom")

# Look for areas of the map with many consumer preferences. Retailers located in
# or moving toward those areas are positioned to attract more consumer preference.


#####################################################
# Step 5: Market Share Predictions                  #
#####################################################

# First choice rule: each respondent buys only from the retailer they rate highest.
# If a respondent gives the same top rating to more than one retailer, each of
# those retailers gets credit for that respondent.
first_choice <- preference_matrix == apply(preference_matrix, 1, max)
first_choice_share <- colSums(first_choice) / sum(first_choice)

# Share of preference rule (logit): each respondent spreads their purchases across
# retailers in proportion to exp(preference rating). A retailer's market share is
# the average of these proportions across respondents.
logit.share <- exp(preference_matrix) / rowSums(exp(preference_matrix))
logit.share_share <- colMeans(logit.share)

market_share <- data.frame(brand = colnames(preference_matrix),
                           first_choice = first_choice_share,
                           logit.share = logit.share_share,
                           row.names = NULL)

cat("\nPredicted Market Share by Retailer\n")
print(mutate(market_share, across(-brand, ~ round(.x, 3))), row.names = FALSE)