Problem 1-Transportation Safety

1. Data visualizatoin

data(cars)

plot(cars$speed, cars$dist, 
     main = "Stopping Distance vs Speed",
     xlab = "Speed (mph)", 
     ylab = "Stopping Distance (ft)", 
     pch = 19, col = "blue")


model <- lm(dist ~ speed, data = cars)
abline(model, col = "red", lwd = 2)

2. Data Visualization

model <- lm(dist ~ speed, data = cars)


summary(model)
## 
## Call:
## lm(formula = dist ~ speed, data = cars)
## 
## Residuals:
##     Min      1Q  Median      3Q     Max 
## -29.069  -9.525  -2.272   9.215  43.201 
## 
## Coefficients:
##             Estimate Std. Error t value Pr(>|t|)    
## (Intercept) -17.5791     6.7584  -2.601   0.0123 *  
## speed         3.9324     0.4155   9.464 1.49e-12 ***
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
## 
## Residual standard error: 15.38 on 48 degrees of freedom
## Multiple R-squared:  0.6511, Adjusted R-squared:  0.6438 
## F-statistic: 89.57 on 1 and 48 DF,  p-value: 1.49e-12

3. Model Quality Evaluation

The R-squared value of 0.6511 indicates that approximately 65.1% of the variance in stopping distance is explained by the car’s speed . This suggests a moderately strong linear relationship between the two variables, with speed being a significant predictor of stopping distance, as shown by its small p-value (1.49e-12).

The Residuals vs. Fitted plot shows the residuals scattered around the horizontal line at zero. While the residuals are mostly centered, there appears to be some variability in the spread of residuals across fitted values, hinting at potential heteroscedasticity (unequal variance). This violates one of the assumptions of linear regression and may need further investigation. Additionally, the Shapiro-Wilk test (p-value = 0.02152) suggests that the residuals deviate from normality, which could affect the reliability of the model’s predictions.

4. Residual Analysis

plot(model$fitted.values, residuals(model),
     main = "Residuals vs Fitted",
     xlab = "Fitted Values",
     ylab = "Residuals",
     pch = 19, col = "blue")
abline(h = 0, col = "red", lwd = 2)

qqnorm(residuals(model), main = "Q-Q Plot of Residuals")
qqline(residuals(model), col = "red")

shapiro.test(residuals(model))
## 
##  Shapiro-Wilk normality test
## 
## data:  residuals(model)
## W = 0.94509, p-value = 0.02152
hist(residuals(model),
     main = "Histogram of Residuals",
     xlab = "Residuals",
     col = "lightblue",
     border = "black")

5. Conculsion

Based on the model summary, the linear model is moderately appropriate for the data, with an R-squared value of 65.1%, indicating that speed explains a significant portion of the variance in stopping distance. However, residual analysis reveals potential violations of assumptions, including heteroscedasticity (unequal variance in residuals, as seen in the residuals vs. fitted plot) and non-normality of residuals (confirmed by the Shapiro-Wilk test, p-value = 0.02152). These issues suggest that the model may not fully capture the relationship. To address this, transforming the stopping distance (e.g., log or square root) or exploring a non-linear model could improve the model’s fit and adherence to assumptions.

Problem 2-Health Policy Analyst

Question 1: Initial Assessment of Healthcare Expenditures and Life Expectancy

library(scales)
## Warning: package 'scales' was built under R version 4.4.1
ggplot(data, aes(x = TotExp, y = LifeExp)) +
  geom_point(color = "blue") +
  labs(title = "Life Expectancy vs. Total Healthcare Expenditures",
       x = "Total Healthcare Expenditures (USD)",
       y = "Life Expectancy (Years)") +
  scale_x_continuous(labels = comma) +  # Format x-axis values as regular numbers
  theme_minimal()

model <- lm(LifeExp ~ TotExp, data = data)


summary(model)
## 
## Call:
## lm(formula = LifeExp ~ TotExp, data = data)
## 
## Residuals:
##     Min      1Q  Median      3Q     Max 
## -24.764  -4.778   3.154   7.116  13.292 
## 
## Coefficients:
##              Estimate Std. Error t value Pr(>|t|)    
## (Intercept) 6.475e+01  7.535e-01  85.933  < 2e-16 ***
## TotExp      6.297e-05  7.795e-06   8.079 7.71e-14 ***
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
## 
## Residual standard error: 9.371 on 188 degrees of freedom
## Multiple R-squared:  0.2577, Adjusted R-squared:  0.2537 
## F-statistic: 65.26 on 1 and 188 DF,  p-value: 7.714e-14
par(mfrow = c(2, 2)) 
plot(model)

Discussion: The F-statistic of 65.26 (p-value < 0.001) indicates that the regression model is highly significant, suggesting that total healthcare expenditures (TotExp) are a meaningful predictor of life expectancy (LifeExp). The R-squared value of 0.2577 shows that approximately 25.8% of the variation in life expectancy across countries is explained by healthcare expenditures, implying a moderate relationship. The p-value for TotExp (< 0.001) confirms that the positive association between expenditures and life expectancy is statistically significant. However, the residual standard error of 9.37 suggests that substantial variability in life expectancy remains unexplained. Diagnostic plots should be reviewed to verify regression assumptions, such as linearity and homoscedasticity. While higher expenditures are generally associated with longer life expectancy, other factors likely play significant roles, emphasizing the need for a multifaceted approach to health policy.

Question 2: Transforming Variables for a Better Fit

data$LifeExp_new <- data$LifeExp^4.6
data$TotExp_new <- data$TotExp^0.06


library(ggplot2)
ggplot(data, aes(x = TotExp_new , y = LifeExp_new)) +
  geom_point(color = "darkblue") +
  labs(
    title = "Transformed Life Expectancy vs. Transformed Total Expenditures",
    x = "Transformed Total Expenditures (TotExp^0.06)",
    y = "Transformed Life Expectancy (LifeExp^4.6)"
  ) +
  theme_minimal()

trans_model <- lm(LifeExp_new ~ TotExp_new, data = data)

# Summary of the transformed model
summary(trans_model)
## 
## Call:
## lm(formula = LifeExp_new ~ TotExp_new, data = data)
## 
## Residuals:
##        Min         1Q     Median         3Q        Max 
## -308616089  -53978977   13697187   59139231  211951764 
## 
## Coefficients:
##               Estimate Std. Error t value Pr(>|t|)    
## (Intercept) -736527910   46817945  -15.73   <2e-16 ***
## TotExp_new   620060216   27518940   22.53   <2e-16 ***
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
## 
## Residual standard error: 90490000 on 188 degrees of freedom
## Multiple R-squared:  0.7298, Adjusted R-squared:  0.7283 
## F-statistic: 507.7 on 1 and 188 DF,  p-value: < 2.2e-16

Discussion:

The transformed model shows a significantly improved fit compared to the original, with an R^2 of 0.7298, indicating that 72.98% of the variance in transformed life expectancy is explained by transformed total expenditures. The F-statistic of 507.7 and a highly significant p-value (<2.2e-16) further confirm the strength of the relationship. These transformations account for the non-linear dynamics between healthcare spending and life expectancy, providing a more realistic depiction of diminishing returns at higher expenditure levels. This suggests that targeted increases in healthcare spending, particularly in low-spending countries, could have substantial impacts on life expectancy, underscoring the need for equity in health resource allocation for effective policy recommendations.

Question 3: Forecasting Life Expectancy Based on Transformed Expenditures

data$TotExp_transformed <- data$TotExp^0.06


model_trans <- lm(LifeExp ~ TotExp_transformed, data = data)


summary(model_trans)
## 
## Call:
## lm(formula = LifeExp ~ TotExp_transformed, data = data)
## 
## Residuals:
##     Min      1Q  Median      3Q     Max 
## -22.246  -3.188   1.413   4.164  14.259 
## 
## Coefficients:
##                    Estimate Std. Error t value Pr(>|t|)    
## (Intercept)           8.226      3.561    2.31    0.022 *  
## TotExp_transformed   35.116      2.093   16.78   <2e-16 ***
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
## 
## Residual standard error: 6.883 on 188 degrees of freedom
## Multiple R-squared:  0.5995, Adjusted R-squared:  0.5974 
## F-statistic: 281.5 on 1 and 188 DF,  p-value: < 2.2e-16
new_data <- data.frame(TotExp_transformed = c(1.5, 2.5))


predicted_lifeexp <- predict(model_trans, new_data)
predicted_lifeexp
##        1        2 
## 60.90040 96.01643

Discussion The forecasts suggest that countries with higher transformed total healthcare expenditures (tend to have significantly higher life expectancy. For instance, at TotExp0.06=1.5, the predicted life expectancy is 60.9 years, whereas at TotExp0.06=2.5, it rises to 96.0 years. This strong positive relationship, reflected in a R^2 value of 0.5995, indicates that 59.95% of the variability in life expectancy is explained by healthcare expenditures. However, while increasing healthcare spending appears to be impactful, other determinants like healthcare efficiency, public health infrastructure, and social determinants must also be addressed to maximize outcomes. These findings highlight the critical role of strategic healthcare investments in enhancing global health.

Question 4: Interaction Effects in Multiple Regression

model_interaction <- lm(LifeExp ~ PropMD + TotExp + PropMD*TotExp, data = data)


summary(model_interaction)
## 
## Call:
## lm(formula = LifeExp ~ PropMD + TotExp + PropMD * TotExp, data = data)
## 
## Residuals:
##     Min      1Q  Median      3Q     Max 
## -27.320  -4.132   2.098   6.540  13.074 
## 
## Coefficients:
##                 Estimate Std. Error t value Pr(>|t|)    
## (Intercept)    6.277e+01  7.956e-01  78.899  < 2e-16 ***
## PropMD         1.497e+03  2.788e+02   5.371 2.32e-07 ***
## TotExp         7.233e-05  8.982e-06   8.053 9.39e-14 ***
## PropMD:TotExp -6.026e-03  1.472e-03  -4.093 6.35e-05 ***
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
## 
## Residual standard error: 8.765 on 186 degrees of freedom
## Multiple R-squared:  0.3574, Adjusted R-squared:  0.3471 
## F-statistic: 34.49 on 3 and 186 DF,  p-value: < 2.2e-16

Discussion: The multiple regression model, including the interaction term between the proportion of MDs and total healthcare expenditures, reveals significant findings. The F-statistic (34.49) with a p-value less than 2.2e-16 indicates that the model is highly significant and explains a notable portion of the variance in life expectancy. The R-squared value of 0.3574 suggests that approximately 35.7% of the variation in life expectancy is explained by the model, which is a moderate fit. The coefficient for PropMD (1,497) is significant, indicating that an increase in the proportion of MDs positively impacts life expectancy. Similarly, TotExp (7.233e-05) is also positively associated with life expectancy. However, the interaction term (PropMD * TotExp), with a negative coefficient of -0.006, suggests that the effect of total healthcare expenditures on life expectancy diminishes as the proportion of MDs increases. This interaction effect suggests that while both a higher number of MDs and increased healthcare expenditures improve life expectancy, their combined effect is not simply additive. In countries with more MDs, the benefit of additional healthcare spending on life expectancy might decrease, implying that increasing healthcare expenditures may be more effective in countries with fewer medical professionals. Therefore, policy efforts should balance increasing healthcare spending with initiatives to train and retain medical professionals to maximize the benefits of such expenditures.

Question 5: Forecasting Life Expectancy with Interaction Terms

new_data <- data.frame(PropMD = 0.03, TotExp = 14)


forecasted_lifeexp <- predict(model_interaction, newdata = new_data)


forecasted_lifeexp
##       1 
## 107.696

The forecasted life expectancy of 107.68 years for a country with a 0.03 proportion of MDs and healthcare expenditure of 14 seems unrealistic. While the model predicts a high life expectancy based on the combination of healthcare spending and medical professionals, this value exceeds typical life expectancies observed globally. In real-world policy settings, this model may have limitations. It assumes a linear relationship between healthcare expenditure, the proportion of MDs, and life expectancy, without considering other critical factors such as healthcare system quality, lifestyle, or social determinants of health. Additionally, the interaction term between MDs and expenditures might exaggerate the effect in certain contexts. Therefore, while the model provides useful insights, it should be used with caution and complemented by more comprehensive data and context-specific analysis for policy decisions.

Problem 3-Retail Company Analyst

Question 1-Inventory Cost

D <- 110  
S <- 8.25  
H <- 3.75  


total_cost <- function(Q) {
  return((D / Q) * S + (Q / 2) * H)
}


derivative_total_cost <- function(Q) {
  return(-(D * S) / (Q^2) + H / 2)
}


optimize_cost <- function() {

  result <- optimize(f = total_cost, interval = c(1, D), maximum = FALSE)
  return(result$minimum)  # Optimal order quantity Q
}


optimal_Q <- optimize_cost()


optimal_orders_per_year <- D / optimal_Q


cat("The optimal order quantity (Q) is:", round(optimal_Q, 2), "units\n")
## The optimal order quantity (Q) is: 22 units
cat("The optimal number of orders per year is:", round(optimal_orders_per_year, 2), "\n")
## The optimal number of orders per year is: 5

Question 2 Revenue Maximization

R <- function(t) {
  -3150 * t^(-4) - 220 * t + 6530
}


R_prime <- function(t) {
  12600 * t^(-5) - 220
}


R_double_prime <- function(t) {
  -63000 * t^(-6)
}



critical_point <- uniroot(R_prime, c(1, 10))$root  


second_derivative_at_critical <- R_double_prime(critical_point)


max_revenue <- R(critical_point)


cat("The critical point (time t) at which revenue is maximized is:", critical_point, "days\n")
## The critical point (time t) at which revenue is maximized is: 2.246931 days
cat("The second derivative at this critical point is:", second_derivative_at_critical, "\n")
## The second derivative at this critical point is: -489.5562
cat("Since the second derivative is negative, this is a maximum.\n")
## Since the second derivative is negative, this is a maximum.
cat("The maximum revenue the company can expect is:", max_revenue, "dollars\n")
## The maximum revenue the company can expect is: 5912.094 dollars

Question 3 Demand Area Under Curve

revenue_function <- function(x) {
  return(2 * x^2 - 9.3 * x)
}


revenue_at_2 <- (2 * 2^3 / 3) - (9.3 * 2^2 / 2)
revenue_at_5 <- (2 * 5^3 / 3) - (9.3 * 5^2 / 2)


total_revenue <- revenue_at_2 - revenue_at_5


cat("The total revenue generated between x1 = 2 and x2 = 5 is:", total_revenue, "dollars\n")
## The total revenue generated between x1 = 2 and x2 = 5 is: 19.65 dollars

Question 4 Profit Optimization

profit_function <- function(x) {
  return(x * log(9 * x) - (x^6) / 6)
}


profit_derivative <- function(x) {
  return(log(9 * x) + 1 - x^5)
}


library(rootSolve)


critical_point <- uniroot(profit_derivative, c(0.1, 2))$root


max_profit <- profit_function(critical_point)

cat("The optimal sales level (x) to maximize profit is:", critical_point, "\n")
## The optimal sales level (x) to maximize profit is: 1.280634
cat("The maximum profit that can be achieved is:", max_profit, "dollars\n")
## The maximum profit that can be achieved is: 2.395423 dollars

Question 5 Spending Behavior

pdf_function <- function(x) {
  return(1 / (6 * x))
}


integral_result <- integrate(pdf_function, lower = 1, upper = exp(6))


cat("The result of the integral is:", integral_result$value, "\n")
## The result of the integral is: 1
cat("The probability that a customer spends between $1 and $e^6 is:", integral_result$value, "\n")
## The probability that a customer spends between $1 and $e^6 is: 1

Question 6 Market Share Estimation

rate_of_penetration <- function(t) {
  return(500 / (t^4 + 10))
}


initial_market_share <- 6530
market_share_at_t <- function(t) {
  
  integral_result <- integrate(rate_of_penetration, lower = 1, upper = t)
  return(integral_result$value + initial_market_share)
}


market_share_at_10 <- market_share_at_t(10)


cat("The market share after 10 days is:", market_share_at_10, "\n")
## The market share after 10 days is: 6579.54

Problem 4 Business Optimization

Question 1 Revenue and Cost

R_exact <- function(x) exp(x)
C_exact <- function(x) log(1 + x)
Pi_exact <- function(x) R_exact(x) - C_exact(x)

# Taylor approximations
R_approx <- function(x) 1 + x + (x^2) / 2
C_approx <- function(x) x - (x^2) / 2
Pi_approx <- function(x) R_approx(x) - C_approx(x)

# Plot comparison
x <- seq(0, 2, length.out = 100)
plot(x, Pi_exact(x), type = "l", col = "blue", lwd = 2, ylim = c(0, 8),
     ylab = "Profit", xlab = "Units Sold (x)", main = "Profit Comparison")
lines(x, Pi_approx(x), col = "red", lwd = 2, lty = 2)
legend("topleft", legend = c("Exact Profit", "Approx Profit"),
       col = c("blue", "red"), lty = c(1, 2), lwd = 2)

opt_exact <- optimize(Pi_exact, interval = c(0, 2), maximum = TRUE)
opt_approx <- optimize(Pi_approx, interval = c(0, 2), maximum = TRUE)


cat("Exact Optimization Result:\n")
## Exact Optimization Result:
print(opt_exact)
## $maximum
## [1] 1.999959
## 
## $objective
## [1] 6.290155
cat("\nApproximated Optimization Result:\n")
## 
## Approximated Optimization Result:
print(opt_approx)
## $maximum
## [1] 1.999959
## 
## $objective
## [1] 4.999836

Discussion: The comparison of the exact and approximated profit functions highlights key differences in optimization results. The Taylor Series approximation accurately estimates the location of the profit maximum but underestimates the maximum profit value. Specifically, the exact function gives a maximum profit of approximately 6.29, while the second-order approximation yields 5.00. This discrepancy arises from the truncation of higher-order terms in the Taylor expansion, which become significant for larger values of xxx. In business decision-making, the approximation is useful for quick calculations and small-scale predictions but may lead to suboptimal decisions for larger values of xxx where the exact function is essential for accurate profit estimation

Question 2 Financial Modeling

f_exact <- function(x) sqrt(x)


f_approx <- function(x) {
  c1 <- 1 / (2 * sqrt(0.1)) 
  c2 <- -1 / (4 * 0.1^(3/2)) 
  c1 * x + c2 * x^2
}


x_values <- seq(0, 1, by = 0.01) 
exact_values <- f_exact(x_values)
approx_values <- f_approx(x_values)


plot(x_values, exact_values, type = "l", col = "blue", lwd = 2,
     xlab = "Investment Amount (x)", ylab = "Risk (f(x))",
     main = "Exact vs Approximation for sqrt(x)")
lines(x_values, approx_values, col = "red", lwd = 2, lty = 2)
legend("topleft", legend = c("Exact Function", "Taylor Approximation"),
       col = c("blue", "red"), lty = c(1, 2), lwd = 2)

investments <- c(0.01, 0.05, 0.1, 0.5, 1)
exact_risks <- f_exact(investments)
approx_risks <- f_approx(investments)
comparison <- data.frame(Investment = investments,
                         Exact_Risk = exact_risks,
                         Approximated_Risk = approx_risks)

print("Comparison of exact and approximated risk values:")
## [1] "Comparison of exact and approximated risk values:"
print(comparison)
##   Investment Exact_Risk Approximated_Risk
## 1       0.01  0.1000000        0.01502082
## 2       0.05  0.2236068        0.05929271
## 3       0.10  0.3162278        0.07905694
## 4       0.50  0.7071068       -1.18585412
## 5       1.00  1.0000000       -6.32455532
optimal_investment <- optimize(f_approx, interval = c(0, 1), maximum = FALSE)
cat("\nOptimal Investment (Approximated):\n")
## 
## Optimal Investment (Approximated):
print(optimal_investment)
## $minimum
## [1] 0.9999339
## 
## $objective
## [1] -6.323615

Discussion: The Taylor Series approximation for f(x)= sqrt{x} highlights its practical limitations in financial modeling. While the approximation provides reasonably accurate estimates for small investment amounts, it significantly diverges from the exact function for larger values, as evident in the negative approximated risks for x>0. 5. This divergence suggests that the Taylor approximation is suitable only for low-investment scenarios where computational simplicity is critical. For pricing strategies, this implies that simplistic models may lead to underestimating risk for higher investments, potentially resulting in suboptimal pricing or misjudging profitability thresholds. A balance between simplicity and precision must be struck based on the scale of investment decisions.

Question 3 Inventory Management

D <- function(p) 1 - p
C_exact <- function(p) exp(p)
Pi_exact <- function(p) p * D(p) - C_exact(p)


C_approx <- function(p) 1 + p + (p^2) / 2


Pi_approx <- function(p) {
  p * (1 - p) - C_approx(p)
}


p_values <- seq(0, 2, by = 0.01) 
exact_profit <- Pi_exact(p_values)
approx_profit <- Pi_approx(p_values)


plot(p_values, exact_profit, type = "l", col = "blue", lwd = 2,
     xlab = "Price (p)", ylab = "Profit",
     main = "Exact vs Approximated Profit")
lines(p_values, approx_profit, col = "red", lwd = 2, lty = 2)
legend("topright", legend = c("Exact Profit", "Approximated Profit"),
       col = c("blue", "red"), lty = c(1, 2), lwd = 2)

optimal_price_exact <- optimize(Pi_exact, interval = c(0, 2), maximum = TRUE)
optimal_price_approx <- optimize(Pi_approx, interval = c(0, 2), maximum = TRUE)

cat("Optimal Price and Profit (Exact):\n")
## Optimal Price and Profit (Exact):
print(optimal_price_exact)
## $maximum
## [1] 5.741247e-05
## 
## $objective
## [1] -1
cat("Optimal Price and Profit (Approximated):\n")
## Optimal Price and Profit (Approximated):
print(optimal_price_approx)
## $maximum
## [1] 4.102259e-05
## 
## $objective
## [1] -1

Discussion The Taylor Series approximation of the cost function C(p) simplifies the analysis by reducing the computational complexity while maintaining reasonable accuracy for small price ranges. The comparison between the exact and approximated profit functions reveals a close match near the optimal price, with both achieving the maximum profit of −1. However, as price increases, the approximation deviates from the exact profit due to higher-order terms ignored in the Taylor expansion. For pricing strategies, the Taylor approximation is sufficient when focusing on small price intervals, enabling faster decision-making. However, for broader price ranges or precision-critical contexts, the exact function should be used to account for nonlinear effects accurately.

Question 4 Economic Forecasting

G_exact <- function(x) log(1 + x)


G_approx <- function(x) x - (x^2) / 2


x_values <- seq(0, 1, by = 0.01) 
exact_growth <- G_exact(x_values)
approx_growth <- G_approx(x_values)


plot(x_values, exact_growth, type = "l", col = "blue", lwd = 2,
     xlab = "Investment (x)", ylab = "Growth (G(x))",
     main = "Exact vs Approximated Growth")
lines(x_values, approx_growth, col = "red", lwd = 2, lty = 2)
legend("bottomright", legend = c("Exact Growth", "Approximated Growth"),
       col = c("blue", "red"), lty = c(1, 2), lwd = 2)

target_growth <- 0.1 # Example target growth rate
investment_approx <- uniroot(function(x) G_approx(x) - target_growth, c(0, 1))$root
investment_exact <- uniroot(function(x) G_exact(x) - target_growth, c(0, 1))$root

cat("Investment for target growth (approximation):", investment_approx, "\n")
## Investment for target growth (approximation): 0.1055994
cat("Investment for target growth (exact):", investment_exact, "\n")
## Investment for target growth (exact): 0.1051698

Discussion The Taylor Series approximation for the growth function provides a practical method for estimating economic growth, especially when investments are small. For a target growth rate of 0.1, the approximate investment is 0.10560, while the exact calculation gives 0.10520. The small difference between the two values indicates that the approximation is quite accurate for small investments. However, as investments grow larger, the approximation becomes less reliable due to the neglect of higher-order terms. Therefore, while the Taylor Series is useful for quick estimates and small-scale forecasting, more precise methods should be used for larger investments to ensure policy decisions are based on accurate growth predictions

Problem 5 Profit, Cost, & Pricing

Question 1 Profit Maximization

profit_function <- function(x, y) {
  return(30 * x - 2 * x^2 - 3 * x * y + 24 * y - 4 * y^2)
}


partial_x <- function(x, y) {
  return(30 - 4 * x - 3 * y)
}

partial_y <- function(x, y) {
  return(24 - 3 * x - 8 * y)
}


second_partial_xx <- function(x, y) {
  return(-4)
}

second_partial_yy <- function(x, y) {
  return(-8)
}

second_partial_xy <- function(x, y) {
  return(-3)
}


solve_system <- function() {
 
  
  A <- matrix(c(-4, -3, -3, -8), nrow = 2)
  b <- c(-30, -24)
  
  critical_point <- solve(A, b)
  return(critical_point)
}


critical_point <- solve_system()
x_critical <- critical_point[1]
y_critical <- critical_point[2]


D <- second_partial_xx(x_critical, y_critical) * second_partial_yy(x_critical, y_critical) -
  (second_partial_xy(x_critical, y_critical))^2


cat("Critical point: (", x_critical, ", ", y_critical, ")\n", sep = "")
## Critical point: (7.304348, 0.2608696)
cat("Discriminant: ", D, "\n")
## Discriminant:  23
if (D > 0) {
  if (second_partial_xx(x_critical, y_critical) < 0) {
    cat("This is a local maximum.\n")
  } else {
    cat("This is a local minimum.\n")
  }
} else {
  cat("This is a saddle point.\n")
}
## This is a local maximum.
profit_at_critical_point <- profit_function(x_critical, y_critical)
cat("Profit at the critical point: ", profit_at_critical_point, "\n")
## Profit at the critical point:  112.6957

The critical point for the profit function occurs at approximately (7.304348, 0.2608696), and the corresponding profit at this point is 112.70. The discriminant is positive (23), and since the second partial derivative with respect to x is negative, the critical point is classified as a local maximum. This implies that producing around 7.3 units of Product A and 0.26 units of Product B will maximize the company’s profit. There are no saddle points or local minima in this scenario, and the company should aim for these production levels to achieve the highest profit.

Question 2 Pricing Strategy

A <- matrix(c(-30, 15, 15, -40), nrow = 2, byrow = TRUE)


B <- c(-120, -80)


solution <- solve(A, B)


x_opt <- solution[1]
y_opt <- solution[2]


cat("Optimal price for Brand X: ", x_opt, "\n")
## Optimal price for Brand X:  6.153846
cat("Optimal price for Brand Y: ", y_opt, "\n")
## Optimal price for Brand Y:  4.307692
R <- function(x, y) {
  return(-15*x^2 - 20*y^2 + 120*x + 80*y + 15*x*y)
}


d2R_dx2 <- -30
d2R_dy2 <- -40
d2R_dxdy <- 15


D <- d2R_dx2 * d2R_dy2 - (d2R_dxdy)^2


if (D > 0 && d2R_dx2 < 0) {
  classification <- "Local Maximum"
} else if (D > 0 && d2R_dx2 > 0) {
  classification <- "Local Minimum"
} else {
  classification <- "Saddle Point"
}


total_revenue <- R(x_opt, y_opt)


cat("The optimal price for Brand X is: ", x_opt, "\n")
## The optimal price for Brand X is:  6.153846
cat("The optimal price for Brand Y is: ", y_opt, "\n")
## The optimal price for Brand Y is:  4.307692
cat("The total revenue at the optimal prices is: ", total_revenue, "\n")
## The total revenue at the optimal prices is:  541.5385
cat("Classification of the critical point: ", classification, "\n")
## Classification of the critical point:  Local Maximum

Discussion

The optimal pricing strategy, with Brand X priced at approximately $6.15 and Brand Y at $4.31, maximizes the supermarket’s total revenue, which is estimated to be $541.54. This pricing balance takes into account the demand interdependence between the two brands, ensuring that neither is overpriced, which could reduce sales, nor underpriced, which could lower revenue per unit. In a competitive retail environment, this strategy helps the supermarket optimize its profit while staying competitive with pricing. By adjusting prices based on demand elasticity, the store can maximize its earnings and ensure both brands perform well in the market without cannibalizing each other’s sales. The classification of the critical point as a local maximum assures that this price combination will indeed result in the highest possible revenue.

Question 3 Cost Minimization

cost_function <- function(x, y) {
  return((1/8)*x^2 + (1/10)*y^2 + 12*x + 18*y + 1500)
}


constraint <- function(x) {
  return(200 - x)  # y = 200 - x
}


dC_dx <- function(x, y) {
  return(1/4 * x + 12)  
}

dC_dy <- function(x, y) {
  return(1/5 * y + 18)  
}


solve_system <- function() {

  eq1 <- function(x) {
    return(1/4 * x + 12 - (1/5 * (200 - x) + 18))
  }
  

  solution_x <- uniroot(eq1, c(0, 200))$root
  

  solution_y <- constraint(solution_x)
  

  minimized_cost <- cost_function(solution_x, solution_y)
  
  return(list(x = solution_x, y = solution_y, cost = minimized_cost))
}


solution <- solve_system()

cat("Optimal number of units to produce in New York (x): ", solution$x, "\n")
## Optimal number of units to produce in New York (x):  102.2222
cat("Optimal number of units to produce in Chicago (y): ", solution$y, "\n")
## Optimal number of units to produce in Chicago (y):  97.77778
cat("Minimized total cost: $", round(solution$cost, 2), "\n")
## Minimized total cost: $ 6748.89

Discussion: The cost-minimization strategy, which allocates approximately 102.22 units to New York and 97.78 units to Chicago, ensures that the total weekly cost is minimized at $6748.89. This balanced distribution of production takes into account the relative cost structures of both plants, optimizing resources while meeting the constraint of producing 200 units. In a practical setting, factors such as labor costs, proximity to suppliers or markets, and plant capacity could influence this allocation. For instance, if one plant has lower operational costs or better access to raw materials, the company might consider adjusting production quantities to further reduce costs or improve efficiency. While the model provides an optimal baseline, these external factors should be incorporated into the decision-making process.

Question 4 Marketing Mix

E <- function(x, y) {
  return(500*x + 700*y - 5*x^2 - 10*x*y - 8*y^2)
}


dE_dx <- function(x, y) {
  return(500 - 10*x - 10*y)  # Partial derivative with respect to x
}

dE_dy <- function(x, y) {
  return(700 - 10*x - 16*y)  # Partial derivative with respect to y
}


solve_system <- function() {
  
  eq1 <- function(x) {
    return(500 - 10*x - 10*(50 - x))  
  }
  

  solution_x <- uniroot(eq1, c(0, 50))$root
  

  solution_y <- 50 - solution_x
  

  max_reach <- E(solution_x, solution_y)
  
  return(list(x = solution_x, y = solution_y, reach = max_reach))
}


d2E_dx2 <- function() {
  return(-10)  
}

d2E_dy2 <- function() {
  return(-16)  
}

d2E_dxdy <- function() {
  return(-10)  
}


discriminant <- function() {
  D <- d2E_dx2() * d2E_dy2() - (d2E_dxdy())^2
  return(D)
}


solution <- solve_system()
D <- discriminant()

cat("Optimal spending on online ads (x): ", solution$x, " thousand dollars\n")
## Optimal spending on online ads (x):  0  thousand dollars
cat("Optimal spending on television ads (y): ", solution$y, " thousand dollars\n")
## Optimal spending on television ads (y):  50  thousand dollars
cat("Maximum customer reach: ", solution$reach, "\n")
## Maximum customer reach:  15000
if (D > 0 && d2E_dx2() < 0) {
  cat("Classification: Local Maximum\n")
} else {
  cat("Classification: Saddle Point\n")
}
## Classification: Local Maximum

The results suggest that to maximize customer reach, the company should allocate the entire marketing budget to television ads, with no budget spent on online ads. This optimal allocation is derived from the model’s coefficients, where television ads have a stronger linear impact on reach. However, in practice, the company should consider factors beyond the mathematical model, such as audience targeting, platform effectiveness, and potential diminishing returns on a single platform. If the company encounters saddle points in other scenarios, these could indicate regions where increasing spend on both platforms may not yield proportional increases in reach, and careful adjustments would be necessary to avoid inefficient budget allocations.