MATH2406 Applied Analytics

#Loading all required packages
library(dplyr) # Useful for data manipulation
library(ggplot2) # Useful for building data visualisations
library(knitr) # Useful for creating nice tables

Task 1.1: Find the mean age of all people included in the dataset.

df <- read.csv("pop_dataset_0002.csv")
df$age <- as.numeric(df$age)
df$population <- as.numeric(df$population)
weighted_mean_age <- df %>%
group_by(region) %>%
summarise(weighted_mean_age = weighted.mean(age, w = population))
print(weighted_mean_age)

## # A tibble: 500 × 2
##    region   weighted_mean_age
##    <chr>                <dbl>
##  1 SSC20005              30.5
##  2 SSC20012              30.1
##  3 SSC20018              32.8
##  4 SSC20027              27.9
##  5 SSC20029              21.4
##  6 SSC20048              29.3
##  7 SSC20062              29.2
##  8 SSC20076              27.9
##  9 SSC20079              29.1
## 10 SSC20099              46  
## # ℹ 490 more rows

Task 1.2: Find the standard deviation of all people included in the dataset.

the weighted SD age was 15.77804

#df$age <- as.numeric(df$age)
#df$population <- as.numeric(df$population)
#print(str(df))
#df <- df[!is.na(df$age) & !is.na(df$population), ]
#print(head(df))
#weighted_sd_age <- sqrt(sum(df$population * (df$age - weighted_mean_age)^2) / sum(df$population))
#print(weighted_sd_age)

Task 2.1.0: Provide mean age for each region:

The mean is 30.6

#providing the summary statistic mean for each region.
#df$age <- as.numeric(df$age)
#df$population <- as.numeric(df$population)
#View(weighted_mean_age)
#overall_mean <- mean(weighted_mean_age$weighted_mean_age)
#print(overall_mean)

Task 2.1.1: Provide the SD age of each region.

#providing the summary statistic standard deviation for each region.
overall_sd <- sd(weighted_mean_age$weighted_mean_age)
print(overall_sd)

## [1] 7.996179

#result was 7.996179

Task 2.1.2: Provide the Minimum

overall_min <- min(weighted_mean_age$weighted_mean_age)
print(overall_min)

## [1] 2

# output was: 2

Task 2.1.3 Provide the first quartile:

first_quartile <- quantile(weighted_mean_age$weighted_mean_age, probs = 0.25)
print(first_quartile)

##      25% 
## 27.42578

#output was: 27.42578

Task 2.1.4: Provide the Median

overall_median <- median(weighted_mean_age$weighted_mean_age)
print(overall_median)

## [1] 29.23158

#The result was: 29.23158

Task 2.1.5: Provide the third quartile

third_quartile <- quantile(weighted_mean_age$weighted_mean_age, probs = 0.75)
print(third_quartile)

##      75% 
## 33.35013

#output was: 33.35013

Task 2.1.6: Provide the maximum

overall_max <- max(weighted_mean_age$weighted_mean_age)
print(overall_max)

## [1] 55

#result was: 55

Task 2.1.7: Provide the interquartile range

interquartile_range <- third_quartile - first_quartile
print(interquartile_range)

##     75% 
## 5.92435

#output was: 5.92435

Task 2.1.8: Provide the histogram of the distribution of region means

#hist(weighted_mean_age$weighted_mean_age, 
     #main = "Histogram of Region Means",
     #xlab = "Weighted Mean Age",
     #ylab = "Frequency",
     #col = "skyblue",
     #border = "black")
# I will now add some vertical lines for median, first quartile, third quartile, minimum, and maximum
#abline(v = overall_median, col = "red", lwd = 2, lty = 2)  # Red line is for Median
#abline(v = first_quartile, col = "blue", lwd = 2, lty = 2)  # Blue line is for the First Quartile
#abline(v = third_quartile, col = "green", lwd = 2, lty = 2)  # Green line will indicate the Third Quartile
#abline(v = overall_min, col = "orange", lwd = 2, lty = 2)  # Orange line will indicate the Minimum
#abline(v = overall_max, col = "purple", lwd = 2, lty = 2)  # Purple line will indicate the Maximum
#abline(v = summary_mean, col = "black", lwd = 2, lty = 2)  # Black line will indicate the Mean
#abline(v = summary_sd, col = "brown", lwd = 2, lty = 2)  # brown line will indicate the Standard Deviation
#abline(v = overall_min + interquartile_range, col = "yellow", lwd = 2, lty = 2)  # Interquartile Range

# hashtags were added to show code done for the below plot. to run, please remove them.

Task 2.2 Discuss whether the region means exhibit the characteristic shape of anormal distribution. Include at least two justifications in support of your conclusion:**

Looking to the visualization above, you can see that most of the mean age values fall within the mean age (see black dotted line in the middle of the graph). Furthermore the data set shows you that majority of the means sits within the 25-35 years old range which perfectly sits around the summarised mean of 30.6 years old.

Task 3.1: Identify the region and describe its population size in comparison with the other regions.

The region with the biggest population is ‘SSC20492’. This region has a population of 726. If you consider that the 5th largest region has a population of 652, you can see that this region has a significant amount more than the second most populated region.

Task 3.2.0: Provide mean age for the region with the highest population

region_row <- df[df$region == "SSC20492", ]
mean_age <- mean(region_row$age)
print(mean_age)

## [1] 27.5

#Output: 27.5

Task 3.2.1: Provide standard deviation age for the region with the highest population

region_row <- df[df$region == "SSC20492", ]
sd_age <- sd(region_row$age)
print(sd_age)

## [1] 16.23587

#Output: 16.23587

Task 3.2.2: Provide the minimum age for the region with the highest population

region_row <- df[df$region == "SSC20492", ]
min_age <- min(region_row$age)
print(min_age)

## [1] 0

#Output: 0

Task 3.2.3: Provide the first quartile

region_row <- df[df$region == "SSC20492", ]
q1_age <- quantile(region_row$age, 0.25)
print(q1_age)

##   25% 
## 13.75

#Output: 13.75

Task 3.2.4: Provide the median age

region_row <- df[df$region == "SSC20492", ]
median_age <- median(region_row$age)
print(median_age)

## [1] 27.5

#Output: 27.5

Task 3.2.5: Provide the third quartile

region_row <- df[df$region == "SSC20492", ]
q3_age <- quantile(region_row$age, 0.75)
print(q3_age)

##   75% 
## 41.25

#Output: 41.25

Task 3.2.6: Provide the maximum

region_row <- df[df$region == "SSC20492", ]
max_age <- max(region_row$age)
print(max_age)

## [1] 55

#Output: 55

Task 3.2.7: Provide the interquartile range

region_row <- df[df$region == "SSC20492", ]
q1 <- quantile(region_row$age, 0.25)
q3 <- quantile(region_row$age, 0.75)
iqr_age <- q3 - q1
print(iqr_age)

##  75% 
## 27.5

#Output: 27.5

Task 3.2.8: Histogram showing the distribution of age in the highest populated region.

Task 3.3: How does the age distribution for this region compare with the distribution of means provided in Task 2?

The first graph shows that people aged 25-35 were most common overall across all regions. However, the average age present within the highest populated region estimates around 15-55 years old. This indicates that whilst in most worlds middle aged people were more common, in the world with the highest population, there is a lot more variance of age.

Task 3.4: Plot the distribution of age for males in the region.

filtered_data <- df %>%
  filter(region == "SSC20492" & gender %in% c("M", "m"))

ggplot(filtered_data, aes(x = population)) +
  geom_histogram(binwidth = 1, fill = "blue", color = "black", alpha = 0.7) +
  labs(title = "Distribution of Male Population in Region SSC20492",
       x = "Population",
       y = "Frequency") +
  theme_minimal()

#Making a density plot:
ggplot(filtered_data, aes(x = population)) + geom_density(fill = "blue",
alpha = 0.7) + labs(title = "Density Plot of Male Population in Region
SSC20492", x = "Population", y = "Density") + theme_minimal()

Task 3.5: Plot the distribution of age for females in the region

filtered_data_female <- df %>%
  filter(region == "SSC20492" & gender %in% c("F", "f"))

ggplot(filtered_data_female, aes(x = population)) +
  geom_histogram(binwidth = 1, fill = "pink", color = "black", alpha = 0.7) +
  labs(title = "Distribution of Female Population in Region SSC20492",
       x = "Population",
       y = "Frequency") +
  theme_minimal()

#Making a density plot:
ggplot(filtered_data_female, aes(x = population)) +
  geom_density(fill = "pink", alpha = 0.7) +
  labs(title = "Density Plot of Female Population in Region SSC20492",
       x = "Population",
       y = "Density") +
  theme_minimal()

Task 3.5: Compare the distributions and discuss your findings.

You can see a similar spread between the two genders. Whilst there are similarities, the most noticable difference is that there appear to be more dense population of women at the 200 population mark than there are for men. However at the 400 mark there appear to be more density in males then in females.

Task 4.1: calculate the ratio of older to younger people, where ‘younger’ is defined as aged below 40 years and ‘older’ as age 40 years and above

older_than_40 <- df %>% filter(age > 40) %>% nrow()
younger_than_or_equal_40 <- df %>% filter(age <= 40) %>% nrow()

# Calculating the ratio
if (younger_than_or_equal_40 == 0) {
  ratio <- Inf
} else {
  ratio <- older_than_40 / younger_than_or_equal_40
}

cat('Number of individuals older than 40:', older_than_40, '\n')

## Number of individuals older than 40: 15000

cat('Number of individuals 40 or younger:', younger_than_or_equal_40, '\n')

## Number of individuals 40 or younger: 41000

cat('Ratio of older to younger:', ratio, '\n')

## Ratio of older to younger: 0.3658537

Task 4.2: Plot the ratio of each region against its population size.

# Making sure that the 'age' column is in numeric format firstly
df$age <- as.numeric(as.character(df$age))

# Filtering for older than 40 and 40 or younger
older_than_40 <- df %>% filter(age > 40) %>% nrow()
younger_than_or_equal_40 <- df %>% filter(age <= 40) %>% nrow()

ratio_df <- data.frame(
  Category = c('Older than 40', '40 or Younger'),
  Count = c(older_than_40, younger_than_or_equal_40)
)
#plotting the bar graph. 
ggplot(ratio_df, aes(x = Category, y = Count, fill = Category)) +
  geom_bar(stat = "identity") +
  theme_minimal() +
  labs(title = "Number of Individuals Older and Younger than 40",
       x = "Age Group",
       y = "Count") +
  scale_fill_manual(values = c("Older than 40" = "#87CEEB", "40 or Younger" = "#FF6F61"))

Task 4.3: Comment on any trends you see in the data. What could explain such trends?

When we evaluate the findings from this section, we see that there are overall more people younger than 40 than there are over 40.

Specifically we can see that the number of people under the age of 40 are 41,000 and the number of people over the age of 40 are 15,000 across all regions.

This means that when we look at our target audience for the energy drink we want to sell in the later stages of this assessment, we find that there are more younger people than there are older people which gives us a larger pool for us to market and advertise to.

Task 5.1: For each region, calculate the ratio of males to females.

df$population <- as.numeric(df$population)
filtered_data <- df %>%
  filter(gender %in% c("M", "F", "m", "f"), population > 0)
grouped_data <- filtered_data %>%
  group_by(region) %>%
  summarize(male_count = sum(gender %in% c("M", "m")),
            female_count = sum(gender %in% c("F", "f")))
grouped_data <- grouped_data %>%
  mutate(Male_to_Female_Ratio = male_count / female_count)
print(grouped_data[, c("region", "Male_to_Female_Ratio")])

## # A tibble: 500 × 2
##    region   Male_to_Female_Ratio
##    <chr>                   <dbl>
##  1 SSC20005                0.667
##  2 SSC20012                1.02 
##  3 SSC20018                1.64 
##  4 SSC20027                0.982
##  5 SSC20029                1.29 
##  6 SSC20048                1.02 
##  7 SSC20062                1.03 
##  8 SSC20076                1    
##  9 SSC20079                1    
## 10 SSC20099              Inf    
## # ℹ 490 more rows

Task 5.2

total_male <- sum(grouped_data$male_count)
total_female <- sum(grouped_data$female_count)

male_percentage <- total_male / (total_male + total_female) * 100
female_percentage <- total_female / (total_male + total_female) * 100
pie_data <- data.frame(Gender = c("Male", "Female"),
                       Count = c(total_male, total_female),
                       Percentage = c(male_percentage, female_percentage))
ggplot(pie_data, aes(x = "", y = Count, fill = Gender)) +
  geom_bar(stat = "identity", width = 1) +
  geom_text(aes(label = paste0(round(Percentage), "%")), position = position_stack(vjust = 0.5), color = "white", size = 5) +
  coord_polar("y", start = 0) +
  labs(title = "Ratio of Males to Females",
       fill = "Gender") +
  theme_void() +
  theme(legend.position = "bottom")

Task 5.3 Comment on any trends you see in the data.:

There appear to be a fifty-fifty split in the spread of males to females across regions.

Task 6.1 Select a gender and age group which spans 3 to 5 years. This will be the

primary target market for your hypothetical energy drink.:

As seen from earlier findings, the mean age was 30 years old. We also know that there are equal amount males to females in this dataset. Given this knowledge, there is some research that suggests that “more men than women are drinking sugar sweetened drinks” (Australain Bureau of Statistics, 2018) and thus males are the choice of gender for this section of the assessment.

# Selected Age Range - Lower Age Range = 28 Upper Age Range = 32
# Selected Gender: Male.
# Total Male population: 395510

#code to find population of males. 
#filtered_data <- df %>%
#filter(gender %in% c("M","m", population > 0))
# Calculate the total population of males and females
#total_male <- grouped_data %>% filter(gender %in% c("M", "m")) %>% pull(total_population)
# Print the total male and female population
#cat("Total male population:", sum(total_male), "\n")

Task 6.2 Which two regions would you choose? Explain your reasoning:

Here we can see the top two regions with males are SSCSSC22015 and SSC21671.I have picked these two regions as they are the most populated. 
 
Region 1: SSC20473  23      M          543
Region 2: SSC22015   4      M          527
Total population: 1070

**Task 6.3:

In planning each region’s campaign launch, you believe that 15% of your primary target market in the region will attend the launch. Use this assumption to estimate the number of the primary target market that you expect to attend in each region. Also estimate the likelihood that at least 30% of the primary target market will attend in each region. Explain your reasoning for both estimates.**

15% of the primary target attending the launch will equate to 160 people attending the launch.

the likely hood of 30% attending from the following regions are: Region 1: 51.24 % Region 2: 52.02 %

library(stats)

n1 <- 543  # Population of the first region
p1 <- 0.3  # Probability of an individual attending
k1 <- 163  # Minimum number of attendees required

n2 <- 527  # Population of the second region
p2 <- 0.3  # Probability of an individual attending
k2 <- 158  # Minimum number of attendees required

prob_less_than_163_region1 <- pbinom(k1 - 1, n1, p1)

prob_at_least_163_region1 <- 1 - prob_less_than_163_region1

prob_less_than_158_region2 <- pbinom(k2 - 1, n2, p2)

prob_at_least_158_region2 <- 1 - prob_less_than_158_region2

cat("The likelihood that at least 30% of the primary target market will attend in the first region is approximately", round(prob_at_least_163_region1 * 100, 2), "%\n")

## The likelihood that at least 30% of the primary target market will attend in the first region is approximately 51.24 %

cat("The likelihood that at least 30% of the primary target market will attend in the second region is approximately", round(prob_at_least_158_region2 * 100, 2), "%\n")

## The likelihood that at least 30% of the primary target market will attend in the second region is approximately 52.02 %

```
## ** References:** 1) ABS (Australian Bureau of Statistics) (2018) WMore men than women drinking sugar sweetened drinks, ABS website, accessed 14TH May 2024. https://www.abs.gov.au/articles/more-men-women-drinking-sugar-sweetened-drinks

IMPORTANT NOTE

The report must be uploaded to Assignment 1 section in Canvas as a PDF document with R codes and outputs showing. The easiest way to do this is to:
1) Run all R chunks
2) Preview your notebook in HTML (by clicking Preview Notebook)
3) Open in Browser (Chrome)
4) Right Click on the report in Chrome
5) Click Print and Select the Destination Option to Save as PDF.
6) Now upload this PDF report as one single file via the Assignment 1 page in Canvas.

Remember to DELETE the instructional text provided in the template. Failure to do this will INCREASE the SIMILARITY INDEX reported in TURNITIN

If you have any questions regarding the assignment instructions or the R Markdown template, please post them on the discussion board.