Homework 3
Victor Torres
2025-04-22
Problem 1-Transportation Safety
Scenario: You are a data analyst at a transportation safety organization. Your task is to analyze the relationship between the speed of cars and their stopping distance using the built-in R dataset cars. This analysis will help in understanding how speed affects the stopping distance, which is crucial for improving road safety regulations.
Task:
Using the cars dataset in R, perform the following steps:
# Explore the cars dataset
head(cars)summary(cars)## speed dist
## Min. : 4.0 Min. : 2.00
## 1st Qu.:12.0 1st Qu.: 26.00
## Median :15.0 Median : 36.00
## Mean :15.4 Mean : 42.98
## 3rd Qu.:19.0 3rd Qu.: 56.00
## Max. :25.0 Max. :120.001. Data Visualization:
Create a scatter plot of stopping distance (dist) as a function of speed (speed). Add a regression line to the plot to visually assess the relationship.
# Create the plot with regression line
ggplot(cars, aes(x = speed, y = dist)) +
geom_point() +
geom_smooth(method = "lm", se = TRUE, color = "blue") +
labs(title = "Car Stopping Distance vs. Speed",
x = "Speed (mph)",
y = "Stopping Distance (ft)",
caption = "Data source: Cars dataset in R") +
theme_minimal()## `geom_smooth()` using formula = 'y ~ x'
2. Build a Linear Model:
Construct a simple linear regression model where stopping distance (dist) is the dependent variable and speed (speed) is the independent variable. Summarize the model to evaluate its coefficients, R-squared value, and p-value.
# Construct a basic linear regression model
car_model <- lm(dist ~ speed, data = cars)
model_summary <- summary(car_model)
model_summary##
## 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-123. Model Quality Evaluation:
Calculate and interpret the R-squared value to assess the proportion of variance in stopping distance explained by speed. Perform a residual analysis to check the assumptions of the linear regression model, including linearity, homoscedasticity, independence, and normality of residuals.
# Extract R-squared value
r_squared <- model_summary$r.squared
cat("R-squared value:", r_squared, "\n")## R-squared value: 0.6510794cat("This means that", round(r_squared * 100, 2), "% of the variance in stopping distance is explained by speed.\n")## This means that 65.11 % of the variance in stopping distance is explained by speed.4. Residual Analysis:
Plot the residuals versus fitted values to check for any patterns. Create a Q-Q plot of the residuals to assess normality. Perform a Shapiro-Wilk test for normality of residuals. Plot a histogram of residuals to further check for normality.
# Create diagnostic plot
par(mfrow = c(2, 2))
plot(car_model)
par(mfrow = c(1, 1))# Plot residuals vs fitted
plot(car_model$fitted.values, car_model$residuals,
xlab = "Fitted Values", ylab = "Residuals",
main = "Residuals vs Fitted Values")
abline(h = 0, col = "red", lty = 2)
# Create a Q-Q plot for residuals
qqnorm(car_model$residuals)
qqline(car_model$residuals, col = "red")
# Shapiro-Wilk test for normality
shapiro_test <- shapiro.test(car_model$residuals)
print(shapiro_test)##
## Shapiro-Wilk normality test
##
## data: car_model$residuals
## W = 0.94509, p-value = 0.02152# Histogram of residuals
hist(car_model$residuals, breaks = 10,
main = "Histogram of Residuals",
xlab = "Residuals",
col = "lightblue",
border = "black")
5.Conclusion:
Based on the model summary and residual analysis, determine whether the linear model is appropriate for this data. Discuss any potential violations of model assumptions and suggest improvements if necessary.
cat("\nConclusion:\n")##
## Conclusion:cat("Linear Model Appropriateness:\n")## Linear Model Appropriateness:cat("Model significance: The p-value of the overall model is",
format.pval(model_summary$fstatistic[1], digits = 4),
"which indicates the model is statistically significant.\n")## Model significance: The p-value of the overall model is 89.57 which indicates the model is statistically significant.cat("R-squared value is", round(r_squared, 4),
"indicating that approximately", round(r_squared * 100, 2),
"% of the variance in stopping distance is explained by speed.\n")## R-squared value is 0.6511 indicating that approximately 65.11 % of the variance in stopping distance is explained by speed.cat("Assessment of Regression Assumptions:\n")## Assessment of Regression Assumptions:if(shapiro_test$p.value < 0.05) {
cat("Normality: The Shapiro-Wilk test p-value is",
format.pval(shapiro_test$p.value, digits = 4),
"suggesting that the residuals may not be normally distributed.\n")
} else {
cat("Normality: The Shapiro-Wilk test p-value is",
format.pval(shapiro_test$p.value, digits = 4),
"suggesting that the residuals appear to be normally distributed.\n")
}## Normality: The Shapiro-Wilk test p-value is 0.02152 suggesting that the residuals may not be normally distributed.cat("Linearity and Homoscedasticity: Based on the Residuals vs Fitted plot, ")## Linearity and Homoscedasticity: Based on the Residuals vs Fitted plot,cat("there appears to be some pattern in residuals suggesting potential non-linearity or heteroscedasticity.\n")## there appears to be some pattern in residuals suggesting potential non-linearity or heteroscedasticity.cat("Potential improvements:\n")## Potential improvements:cat("1. Consider a non-linear model such as polynomial regression to better capture the relationship.\n")## 1. Consider a non-linear model such as polynomial regression to better capture the relationship.cat("2. Check for outliers that might influence the model.\n")## 2. Check for outliers that might influence the model.cat("3. Data transformation (e.g., log transformation) might help address any non-constant variance issues.\n")## 3. Data transformation (e.g., log transformation) might help address any non-constant variance issues.Problem 2-Health Policy Analyst
As a health policy analyst for an international organization, you are tasked with analyzing data from the World Health Organization (WHO) to inform global health policies. The dataset provided (who.csv) contains crucial health indicators for various countries from the year 2008. The variables include:
Country: Name of the country
LifeExp: Average life expectancy for the country in years
InfantSurvival: Proportion of those surviving to one year or more
Under5Survival: Proportion of those surviving to five years or more
TBFree: Proportion of the population without TB
PropMD: Proportion of the population who are MDs
PropRN: Proportion of the population who are RNs
PersExp: Mean personal expenditures on healthcare in US dollars at average exchange rate
GovtExp: Mean government expenditures per capita on healthcare, US dollars at average exchange rate
TotExp: Sum of personal and government expenditures
Your analysis will directly influence recommendations for improving global life expectancy and the allocation of healthcare resources.
who_data <- read.csv("C:/Users/vitug/OneDrive/Desktop/CUNY Masters/DATA_605/who.csv")
head(who_data)summary(who_data)## Country LifeExp InfantSurvival Under5Survival
## Length:190 Min. :40.00 Min. :0.8350 Min. :0.7310
## Class :character 1st Qu.:61.25 1st Qu.:0.9433 1st Qu.:0.9253
## Mode :character Median :70.00 Median :0.9785 Median :0.9745
## Mean :67.38 Mean :0.9624 Mean :0.9459
## 3rd Qu.:75.00 3rd Qu.:0.9910 3rd Qu.:0.9900
## Max. :83.00 Max. :0.9980 Max. :0.9970
## TBFree PropMD PropRN PersExp
## Min. :0.9870 Min. :0.0000196 Min. :0.0000883 Min. : 3.00
## 1st Qu.:0.9969 1st Qu.:0.0002444 1st Qu.:0.0008455 1st Qu.: 36.25
## Median :0.9992 Median :0.0010474 Median :0.0027584 Median : 199.50
## Mean :0.9980 Mean :0.0017954 Mean :0.0041336 Mean : 742.00
## 3rd Qu.:0.9998 3rd Qu.:0.0024584 3rd Qu.:0.0057164 3rd Qu.: 515.25
## Max. :1.0000 Max. :0.0351290 Max. :0.0708387 Max. :6350.00
## GovtExp X TotExp LifeExp.1
## Min. : 10.0 Mode:logical Min. : 13 Min. :40.00
## 1st Qu.: 559.5 NA's:190 1st Qu.: 584 1st Qu.:61.25
## Median : 5385.0 Median : 5541 Median :70.00
## Mean : 40953.5 Mean : 41696 Mean :67.38
## 3rd Qu.: 25680.2 3rd Qu.: 26331 3rd Qu.:75.00
## Max. :476420.0 Max. :482750 Max. :83.00str(who_data)## 'data.frame': 190 obs. of 12 variables:
## $ Country : chr "Afghanistan" "Albania" "Algeria" "Andorra" ...
## $ LifeExp : int 42 71 71 82 41 73 75 69 82 80 ...
## $ InfantSurvival: num 0.835 0.985 0.967 0.997 0.846 0.99 0.986 0.979 0.995 0.996 ...
## $ Under5Survival: num 0.743 0.983 0.962 0.996 0.74 0.989 0.983 0.976 0.994 0.996 ...
## $ TBFree : num 0.998 1 0.999 1 0.997 ...
## $ PropMD : num 2.29e-04 1.14e-03 1.06e-03 3.30e-03 7.04e-05 ...
## $ PropRN : num 0.000572 0.004614 0.002091 0.0035 0.001146 ...
## $ PersExp : int 20 169 108 2589 36 503 484 88 3181 3788 ...
## $ GovtExp : int 92 3128 5184 169725 1620 12543 19170 1856 187616 189354 ...
## $ X : logi NA NA NA NA NA NA ...
## $ TotExp : int 112 3297 5292 172314 1656 13046 19654 1944 190797 193142 ...
## $ LifeExp.1 : int 42 71 71 82 41 73 75 69 82 80 ...Questions:
1: Initial Assessment of Healthcare Expenditures and Life Expectancy
Task: Create a scatterplot of LifeExp vs. TotExp to visualize the relationship between healthcare expenditures and life expectancy across countries. Then, run a simple linear regression with LifeExp as the dependent variable and TotExp as the independent variable (without transforming the variables).
# Create a scatterplot of LifeExp vs. TotExp
ggplot(who_data, aes(x = TotExp, y = LifeExp)) +
geom_point() +
geom_smooth(method = "lm", se = TRUE, color = "blue") +
labs(title = "Life Expectancy vs. Total Healthcare Expenditure",
x = "Total Healthcare Expenditure (USD)",
y = "Life Expectancy (years)",
caption = "Data source: WHO 2008") +
theme_minimal()## `geom_smooth()` using formula = 'y ~ x'
# Run simple linear regression
model1 <- lm(LifeExp ~ TotExp, data = who_data)
model1_summary <- summary(model1)
# Display model summary
model1_summary##
## Call:
## lm(formula = LifeExp ~ TotExp, data = who_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-14Provide and interpret the F-statistic, R-squared value, standard error, and p-values. Discuss whether the assumptions of simple linear regression (linearity, independence, homoscedasticity, and normality of residuals) are met in this analysis.
# Extract key statistics
f_stat1 <- model1_summary$fstatistic[1]
f_pvalue1 <- pf(model1_summary$fstatistic[1],
model1_summary$fstatistic[2],
model1_summary$fstatistic[3],
lower.tail = FALSE)
r_squared1 <- model1_summary$r.squared
std_error1 <- model1_summary$sigma
cat("\nQuestion 1 Results:\n")##
## Question 1 Results:cat("F-statistic:", f_stat1, "with p-value:", f_pvalue1, "\n")## F-statistic: 65.2642 with p-value: 7.713993e-14cat("R-squared:", r_squared1, "\n")## R-squared: 0.2576922cat("Standard error (residual):", std_error1, "\n")## Standard error (residual): 9.371033# Check regression assumptions
par(mfrow = c(2, 2))
plot(model1)
par(mfrow = c(1, 1))# Shapiro-Wilk test for normality of residuals
shapiro_test1 <- shapiro.test(model1$residuals)
cat("Shapiro-Wilk normality test p-value:", shapiro_test1$p.value, "\n")## Shapiro-Wilk normality test p-value: 1.60925e-10Discussion: Consider the implications of your findings for health policy. Are higher healthcare expenditures generally associated with longer life expectancy? What do the assumptions of the regression model suggest about the reliability of this relationship?
Based on the analysis findings, there is non-linearity relationship between expenditure and life expectancy variables, also there is a relatively low R-squared as well as the Q-Q plots shows that the residuals are not normally distributed.
The analysis provides evidence that healthcare spending does positively influence life expectancy, but the relationship is complex, non-linear, and likely moderated by numerous other factors not captured in this simple model.
2: Transforming Variables for a Better Fit
Task: Recognizing potential non-linear relationships, transform the variables as follows:
Raise life expectancy to the 4.6 power \((LifeExp^4.6)\). Raise total expenditures to the 0.06 power \((TotExp^0.06)\), which is nearly a logarithmic transformation. Create a new scatterplot with the transformed variables and re-run the simple linear regression model.
# Transform variables
who_data$LifeExp_trans <- who_data$LifeExp^4.6
who_data$TotExp_trans <- who_data$TotExp^0.06
# Create scatterplot with transformed variables
ggplot(who_data, aes(x = TotExp_trans, y = LifeExp_trans)) +
geom_point() +
geom_smooth(method = "lm", se = TRUE, color = "blue") +
labs(title = "Transformed Life Expectancy vs. Transformed Total Healthcare Expenditure",
x = "Transformed Total Healthcare Expenditure (TotExp^0.06)",
y = "Transformed Life Expectancy (LifeExp^4.6)",
caption = "Data source: WHO 2008") +
theme_minimal()## `geom_smooth()` using formula = 'y ~ x'
Provide and interpret the F-statistic, R-squared value, standard error, and p-values for the transformed model.
# Run linear regression with transformed variables
model2 <- lm(LifeExp_trans ~ TotExp_trans, data = who_data)
model2_summary <- summary(model2)
# Display model summary
model2_summary##
## Call:
## lm(formula = LifeExp_trans ~ TotExp_trans, data = who_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_trans 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# Extract key statistics
f_stat2 <- model2_summary$fstatistic[1]
f_pvalue2 <- pf(model2_summary$fstatistic[1],
model2_summary$fstatistic[2],
model2_summary$fstatistic[3],
lower.tail = FALSE)
r_squared2 <- model2_summary$r.squared
std_error2 <- model2_summary$sigma
cat("\nQuestion 2 Results:\n")##
## Question 2 Results:cat("F-statistic:", f_stat2, "with p-value:", f_pvalue2, "\n")## F-statistic: 507.6967 with p-value: 2.601428e-55cat("R-squared:", r_squared2, "\n")## R-squared: 0.7297673cat("Standard error (residual):", std_error2, "\n")## Standard error (residual): 90492393# Check regression assumptions for transformed model
par(mfrow = c(2, 2))
plot(model2)
par(mfrow = c(1, 1))# Shapiro-Wilk test for normality of residuals
shapiro_test2 <- shapiro.test(model2$residuals)
cat("Shapiro-Wilk normality test p-value:", shapiro_test2$p.value, "\n")## Shapiro-Wilk normality test p-value: 0.0001908218Compare this model to the original model (from Question 1). Which model provides a better fit, and why?
# Compare models
cat("\nModel Comparison:\n")##
## Model Comparison:cat("Original model R-squared:", r_squared1, "\n")## Original model R-squared: 0.2576922cat("Transformed model R-squared:", r_squared2, "\n")## Transformed model R-squared: 0.7297673cat("Improvement in R-squared:", r_squared2 - r_squared1, "\n")## Improvement in R-squared: 0.4720751Discussion: How do the transformations impact the interpretation of the relationship between healthcare spending and life expectancy? Why might the transformed model be more appropriate for policy recommendations?
The transformation of variables improved the model’s metric values, R-squared increased from 0.258 to 0.730 which increased approximately 73% of the variation in transformed life expectancy, compared to only 26% in the original model.F-statistic increased from 65.26 to 507.70: This indicates a much stronger overall fit of the model, as well as highly significant relationship (p < 2.2e-16): The transformed model confirms an extremely strong statistical relationship between healthcare spending and life expectancy.
The transformed model provides a more accurate representation of the complex relationship between healthcare expenditure and life expectancy. This can guide more effective policy decisions, particularly regarding optimal resource allocation based on a country’s current position on the healthcare expenditure curve.
3: Forecasting Life Expectancy Based on Transformed Expenditures
Task: Using the results from the transformed model in Question 2, forecast the life expectancy for countries with the following transformed total expenditures \((TotExp^0.06)\):
When \(TotExp^0.06 = 1.5\)
When \(TotExp^0.06 = 2.5\)
# Extract model coefficients
intercept2 <- model2$coefficients[1]
slope2 <- model2$coefficients[2]
# Forecast life expectancy for TotExp^0.06 = 1.5
forecast1_trans <- intercept2 + slope2 * 1.5
forecast1 <- forecast1_trans^(1/4.6)
# Forecast life expectancy for TotExp^0.06 = 2.5
forecast2_trans <- intercept2 + slope2 * 2.5
forecast2 <- forecast2_trans^(1/4.6)
cat("\nQuestion 3 Results:\n")##
## Question 3 Results:cat("Forecasted life expectancy when TotExp^0.06 = 1.5:", forecast1, "years\n")## Forecasted life expectancy when TotExp^0.06 = 1.5: 63.31153 yearscat("Forecasted life expectancy when TotExp^0.06 = 2.5:", forecast2, "years\n")## Forecasted life expectancy when TotExp^0.06 = 2.5: 86.50645 years# Calculate original TotExp values for these forecasts
totexp1 <- 1.5^(1/0.06)
totexp2 <- 2.5^(1/0.06)
cat("This corresponds to TotExp =", totexp1, "USD for forecast 1\n")## This corresponds to TotExp = 860.705 USD for forecast 1cat("This corresponds to TotExp =", totexp2, "USD for forecast 2\n")## This corresponds to TotExp = 4288777 USD for forecast 2Discussion: Discuss the implications of these forecasts for countries with different levels of healthcare spending. What do these predictions suggest about the potential impact of increasing healthcare expenditures on life expectancy?
The forecasting results from the transformed model reveal profound implications about the relationship between healthcare spending and life expectancy across different economic contexts.
Also, it provides valuable insights about healthcare spending which it has a significant but non-linear relationship with life expectancy. The transformed model captures this complexity and provides insights for tailored policy approaches based on a country’s current economic position, highlighting the multifaceted nature of population health outcomes.
4: Interaction Effects in Multiple Regression
Task: Build a multiple regression model to investigate the combined effect of the proportion of MDs and total healthcare expenditures on life expectancy. Specifically, use the model: \[ \text{LifeExp} = b_0 + b_1 \times \text{PropMD} + b_2 \times \text{TotExp} + b_3 \times (\text{PropMD} \times \text{TotExp}) \]
Interpret the F-statistic, R-squared value, standard error, and p-values. Evaluate the interaction term (PropMD * TotExp). What does this interaction tell us about the relationship between the number of MDs, healthcare spending, and life expectancy?
# Create interaction term
who_data$PropMD_TotExp <- who_data$PropMD * who_data$TotExp
# Build multiple regression model with interaction
model3 <- lm(LifeExp ~ PropMD + TotExp + PropMD_TotExp, data = who_data)
model3_summary <- summary(model3)
# Display model summary
model3_summary##
## Call:
## lm(formula = LifeExp ~ PropMD + TotExp + PropMD_TotExp, data = who_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# Extract key statistics
f_stat3 <- model3_summary$fstatistic[1]
f_pvalue3 <- pf(model3_summary$fstatistic[1],
model3_summary$fstatistic[2],
model3_summary$fstatistic[3],
lower.tail = FALSE)
r_squared3 <- model3_summary$r.squared
std_error3 <- model3_summary$sigma
cat("\nQuestion 4 Results:\n")##
## Question 4 Results:cat("F-statistic:", f_stat3, "with p-value:", f_pvalue3, "\n")## F-statistic: 34.48833 with p-value: 9.024193e-18cat("R-squared:", r_squared3, "\n")## R-squared: 0.3574352cat("Standard error (residual):", std_error3, "\n")## Standard error (residual): 8.765493# Check if interaction term is significant
interaction_pvalue <- model3_summary$coefficients[4, 4]
cat("Interaction term p-value:", interaction_pvalue, "\n")## Interaction term p-value: 6.352733e-05Discussion: How does the presence of more MDs amplify or diminish the effect of healthcare expenditures on life expectancy? What policy recommendations can be drawn from this analysis?
The analysis reveals that the relationship between healthcare resources and population health outcomes is complex and non-additive. The significant negative interaction between physician density and healthcare expenditure suggests that health systems should adopt tailored approaches to resource allocation based on their current healthcare infrastructure and workforce characteristics. My main recommendation would be a balanced, integrated strategy that optimizes the complementary roles of human resources and financial investments to create improvements in population life expectancy.
5: Forecasting Life Expectancy with Interaction Terms
Task: Using the multiple regression model from Question 4, forecast the life expectancy for a country where:
The proportion of MDs is 0.03 (PropMD = 0.03). The total healthcare expenditure is 14 (TotExp = 14). Discussion: Does this forecast seem realistic? Why or why not? Consider both the potential strengths and limitations of using this model for forecasting in real-world policy settings.
# Extract model coefficients
beta0 <- model3$coefficients[1] # Intercept
beta1 <- model3$coefficients[2] # PropMD coefficient
beta2 <- model3$coefficients[3] # TotExp coefficient
beta3 <- model3$coefficients[4] # Interaction coefficient
# Forecast life expectancy
forecast3 <- beta0 + beta1 * 0.03 + beta2 * 14 + beta3 * (0.03 * 14)
cat("\nQuestion 5 Results:\n")##
## Question 5 Results:cat("Forecasted life expectancy for a country with PropMD = 0.03 and TotExp = 14:",
forecast3, "years\n")## Forecasted life expectancy for a country with PropMD = 0.03 and TotExp = 14: 107.696 years# Compare with average life expectancy
avg_lifeexp <- mean(who_data$LifeExp, na.rm = TRUE)
cat("Average life expectancy in the dataset:", avg_lifeexp, "years\n")## Average life expectancy in the dataset: 67.37895 years# Find countries with similar characteristics for comparison
similar_countries <- who_data %>%
filter(abs(PropMD - 0.03) < 0.01 & abs(TotExp - 14) < 5)
if(nrow(similar_countries) > 0) {
cat("\nCountries with similar characteristics (PropMD = 0.03, TotExp = 14):\n")
print(similar_countries[, c("Country", "LifeExp", "PropMD", "TotExp")])
}
# Comprehensive conclusion for the analysis
cat("\nComprehensive Analysis Conclusion:\n")##
## Comprehensive Analysis Conclusion:cat("1. Initial linear model showed", ifelse(f_pvalue1 < 0.05, "a significant", "no significant"),
"relationship between total healthcare expenditure and life expectancy.\n")## 1. Initial linear model showed a significant relationship between total healthcare expenditure and life expectancy.cat("2. Transformed model", ifelse(r_squared2 > r_squared1, "improved", "did not improve"),
"the model fit, suggesting that the relationship between healthcare spending and life expectancy is non-linear.\n")## 2. Transformed model improved the model fit, suggesting that the relationship between healthcare spending and life expectancy is non-linear.cat("3. The interaction model revealed that the effect of healthcare expenditure on life expectancy",
ifelse(interaction_pvalue < 0.05, "is", "is not"), "significantly modified by the proportion of MDs in a country.\n")## 3. The interaction model revealed that the effect of healthcare expenditure on life expectancy is significantly modified by the proportion of MDs in a country.Problem 3-Retail Company Analyst
Questions:
1-Inventory Cost
Scenario: A retail company is planning its inventory strategy for the upcoming year. They expect to sell 110 units of a high-demand product. The storage cost is $ 3.75 per unit per year, and there is a fixed ordering cost of $ 8.25 per order. The company wants to minimize its total inventory cost.
Task: Using calculus, determine the optimal lot size (the number of units to order each time) and the number of orders the company should place per year to minimize total inventory costs. Assume that the total cost function is given by: \[ C(Q) = \frac{D}{Q} \times S + \frac{Q}{2} \times H \]
Where:
\(D\) is the total demand (110 units).
\(Q\) is the order quantity.
\(S\) is the fixed ordering cost per order ($ 8.25).
\(H\) is the holding cost per unit per year ($ 3.75).
To find the minimum cost, I’ll take the derivative and set it equal to zero: \[ \frac{dC}{dQ}=−\frac{DS}{Q^2}+\frac{H}{2}=0 \] Solving for \(Q\):
\[ -\frac{DS}{Q^2} + \frac{H}{2} = 0 \]
\[ \frac{DS}{Q^2} = \frac{H}{2} \]
\[ Q^2 = \frac{2DS}{H} \]
\[ Q=\sqrt \frac{2DS}{H} \]
Substituting the values:
\[ Q = \sqrt{\frac{2 \times 110 \times 8.25}{3.75}}Q=3.752×110×8.25 \]
\[Q = \sqrt{\frac{1815}{3.75}}\]
\[Q = \sqrt{484}\] \[Q=22 units\] Number of orders per year: \(\frac{D}{Q} = \frac{110}{22} = 5 \text{ orders}\)
Therefore, the optimal lot size is 22 units, and the company should place 5 orders per year.
2 Revenue Maximization
Scenario: A company is running an online advertising campaign. The effectiveness of the campaign, in terms of revenue generated per day, is modeled by the function:
\[ R(t) = -3150t^{-4} - 220t + 6530 \]
Where:
\(.R(t)\) represents the revenue in dollars after \(t\) days of the campaign.
Task: Determine the time \(t\) at which the revenue is maximized by finding the critical points of the revenue function and determining which point provides the maximum value. What is the maximum revenue the company can expect from this campaign?
To find the maximum revenue, I need to find the critical points by taking the derivative and setting it equal to zero: \[\frac{dR}{dt} = -3150(-4)t^{-5} - 220\] \[\frac{dR}{dt} = 12600t^{-5} - 2200\] \[\frac{dR}{dt} = \frac{12600}{t^5} - 220 = 0\] Solving for tt t:
\[\frac{12600}{t^5} = 220\] \[12600 = 220t^5\] \[t^5 = \frac{12600}{220}\] \[t^5 = 57.27\] \[t = (57.27)^{1/5}\] \[t\approx2.22 days\] To verify this is a maximum, I can check the second derivative:
\[\frac{d^2R}{dt^2} = 12600(-5)t^{-6} = -63000t^{-6}\] At \(t=2.22, \frac{d^2R}{dt^2} < 0\), confirming this critical point is a maximum.
Maximum revenue is:
\[R(2.22)=−3150(2.22)^{−4}−220(2.22)+6530\] \[R(2.22) = -\frac{3150}{(2.22)^4} - 220(2.22) + 6530\]
\[R(2.22) = -\frac{3150}{24.18} - 488.4 + 6530\] \[R(2.22) = -130.27 - 488.4 + 6530\] \[R(2.22)\approx5911.33\] Therefore, the maximum revenue of approximately \(\$5,911.33\) occurs at \(t=2.22 \ days\).
3 Demand Area Under Curve
Scenario: A company sells a product at a price that decreases over time according to the linear demand function:
\[ P(x) = 2x - 9.3 \]
Where:
\(P(x)\) is the price in dollars, and \(x\) is the quantity sold.
Task: The company is interested in calculating the total revenue generated by this product between two quantity levels, \(x_1 = 2\) and \(x_2 = 5\), where the price still generates sales. Compute the area under the demand curve between these two points, representing the total revenue generated over this range.
To find the total revenue between \(x1=2 \ and \ x2=5\) I need to calculate the area under the curve, which is given by the integral:
\[\text{Total Revenue} = \int_{2}^{5} P(x) dx = \int_{2}^{5} (2x - 9.3) dx\] Integrating:
\[\int_{2}^{5} (2x - 9.3) dx = [x^2 - 9.3x]_{2}^{5}\] Evaluating:
\[[x^2 - 9.3x]_{2}^{5} = (5^2 - 9.3 \times 5) - (2^2 - 9.3 \times 2)\] \[=(25−46.5)−(4−18.6)\] \[=−21.5−(−14.6)\] \[=−21.5+14.6\] \[=−6.9\] Therefore, the total revenue generated over this range is \(−\$6.90\).
4 Profit Optimization
Scenario: A beauty supply store sells flat irons, and the profit function associated with selling \(x\)x flat irons is given by:
\[ \Pi(x) = x \ln(9x) - \frac{x^6}{6} \]
Where:
\(\Pi(x)\) is the profit in dollars.
Task: Use calculus to find the value of \(x\) that maximizes profit. Calculate the maximum profit that can be achieved and determine if this optimal sales level is feasible given market conditions.
To find the value of \(x\) that maximizes profit, I’ll take the derivative and set it equal to zero:
\[\frac{d\Pi}{dx} = \ln(9x) + x \cdot \frac{9}{9x} - \frac{1}{6}\] \[\frac{d\Pi}{dx} = \ln(9x) + 1 - \frac{1}{6}\] \[\frac{d\Pi}{dx} = \ln(9x) + \frac{5}{6} = 0\] Solving for \(x\):
\[\ln(9x) = -\frac{5}{6}\] \[9x = e^{-5/6}\] \[x = \frac{e^{-5/6}}{9}\] \[x\approx0.048\] To verify this is a maximum, I’ll check the second derivative:
\[\frac{d^2\Pi}{dx^2} = \frac{1}{x}\] Since \(x>0\frac{d^2\Pi}{dx^2} > 0\), which indicates this critical point is actually a minimum, not a maximum.
5 Spending Behavior
Scenario: A market research firm is analyzing the spending behavior of customers in a retail store. The spending behavior is modeled by the probability density function:
\[ f(x) = \frac{1}{6x} \]
Where \(x\) represents spending in dollars.
Task: Determine whether this function is a valid probability density function over the interval \([1, e^6]\). If it is, calculate the probability that a customer spends between $ 1 and $ e^6.
To determine if this is a valid probability density function, I need to check if:
\[1.\ f(x)≥0\ for \ all\ x∈[1,e6]\]
\[2. \ \int_{1}^{e^6} f(x) dx = 1\]
For the first condition, \(f(x) = \frac{1}{6x} > 0\ for\ all\ x> 0\), so this is satisfied.
For the second condition:
\[\int_{1}^{e^6} \frac{1}{6x} dx = \frac{1}{6} \cdot\ln(x)|_{1}^{e^6}\] \[= \frac{1}{6} \cdot [\ln(e^6) - \ln(1)]\] \[=\frac{1}{6} \cdot [6 - 0]\] \[=1\] Since both conditions are satisfied, this is a valid probability density function. The probability that a customer spends between \(\$1\) and \(\$e^6\) is:
\[\int_{1}^{e^6} f(x) dx = 1\] Therefore, the probability is 1, which means customers will always spend between \(\$1\) and \(\$e^6\).
Problem 4 Business Optimization
As a data scientist at a consultancy firm, you are tasked with optimizing various business functions to improve efficiency and profitability. Taylor Series expansions are a powerful tool to approximate complex functions, allowing for simpler calculations and more straightforward decision-making. This week, you will work on Taylor Series expansions of popular functions commonly encountered in business scenarios.
Questions:
1 Revenue and Cost
Scenario: A company’s revenue from a product can be approximated by the function \(R(x) = e^x\) , where \(x\) is the number of units sold. The cost of production is given by \(C(x) = \ln(1 + x)\). The company wants to maximize its profit, defined as \(\Pi(x) = R(x) - C(x)\).
Task:
Approximate the Revenue Function: Use the Taylor Series expansion around \(x=0\)(Maclaurin series) to approximate the revenue function \(R(x) = e^x\) up to the second degree. Explain why this approximation might be useful in a business context.
The revenue function is \(R(x) = 1000 \ln(1 + x)\), where \(x\) is the number of units sold. To find the Maclaurin series (Taylor series around \(x = 0\)), I’ll calculate the derivatives and evaluate them at \(x = 0\): \(R(x) = 1000 \ln(1 + x)\) \(R'(x) = 1000 \cdot \frac{1}{1+x}\) \(R''(x) = 1000 \cdot \frac{-1}{(1+x)^2}\) \(R(0) = 1000 \ln(1 + 0) = 1000 \ln(1) = 0\) \(R'(0) = 1000 \cdot \frac{1}{1+0} = 1000\) \(R''(0) = 1000 \cdot \frac{-1}{(1+0)^2} = -1000\) The Maclaurin series expansion up to the second degree is: \[R(x) \approx R(0) + R'(0)x + \frac{R''(0)}{2!}x^2 = 0 + 1000x + \frac{-1000}{2}x^2 = 1000x - 500x^2\]
Business Context
This approximation is useful in a business context because:
It provides a simpler polynomial form that’s easier to manipulate.
For small values of \(x\) (low sales volume), it closely approximates the true revenue function.
It clearly shows the diminishing returns effect - as sales volume increases, the growth in revenue slows down.
It allows managers to quickly estimate revenue for different sales volumes without complex calculations
Approximate the Cost Function: Similarly, approximate the cost function \(C(x) = \ln(1 + x)\) using its Maclaurin series expansion up to the second degree. Discuss the implications of this approximation for decision-making in production.
The cost function is \(C(x) = 200 + 300e^{0.1x}\), where \(x\) is the number of units produced.
Finding the Maclaurin series: \(C(x) = 200 + 300e^{0.1x}\)
\(C'(x) = 300 \cdot 0.1 \cdot e^{0.1x} = 30e^{0.1x}\)
\(C''(x) = 30 \cdot 0.1 \cdot e^{0.1x} = 3e^{0.1x}\)
\(C(0) = 200 + 300e^{0.1 \cdot 0} = 200 + 300 \cdot 1 = 500\)
$C’(0) = 30e^{0.1 } = 30 = 30
\(C''(0) = 3e^{0.1 \cdot 0} = 3 \cdot 1 = 3\)
The Maclaurin series expansion up to the second degree is:
\[C(x) \approx C(0) + C'(0)x + \frac{C''(0)}{2!}x^2 = 500 + 30x + \frac{3}{2}x^2 = 500 + 30x + 1.5x^2\]
Business Implications This approximation aids decision-making in production because:
It breaks down costs into fixed costs (\(\$500\)), variable costs (\(30x\)), and increasing marginal costs (\(1.5x^2\)).
It clearly shows the cost structure - fixed costs plus increasingly expensive variable costs.
It helps predict how costs scale with production volume.
It makes breakeven analysis more straightforward.
Linear vs. Nonlinear Optimization: Using the Taylor Series expansions, approximate the profit function \(\Pi(x)\). Compare the optimization results when using the linear approximations versus the original nonlinear functions. What are the differences, and when might it be more appropriate to use the approximation?
The profit function is \(P(x) = R(x) - C(x)\)
Using the original functions: \(P(x) = 1000\ln(1+x) - (200 + 300e^{0.1x})\)
Using the Taylor series approximations: \(P(x) \approx (1000x - 500x^2) - (500 + 30x + 1.5x^2) = -500 + 970x - 501.5x^2\)
Comparing Optimization Results
To find the optimal production level that maximizes profit, I’ll take the derivative of both profit functions and set them equal to zero. For the approximated profit function: \(P'(x) = 970 - 1003x = 0\)
\(1003x = 970\)
\(x\approx 0.97\) For the original profit function: \(P'(x) = \frac{1000}{1+x} - 30e^{0.1x} = 0\)
This requires numerical methods to solve exactly.
# Define the derivative of the profit function
prof_derivative <- function(x) {
1000/(1+x) - 30*exp(0.1*x)
}
# Create a sequence of x values to evaluate
x_vals <- seq(0, 10, by=0.1)
derivative_vals <- sapply(x_vals, prof_derivative)
# Plot the derivative function to see where it crosses zero
plot_data <- data.frame(x = x_vals, derivative = derivative_vals)
ggplot(plot_data, aes(x = x, y = derivative)) +
geom_line() +
geom_hline(yintercept = 0, linetype = "dashed", color = "red") +
labs(title = "Derivative of Profit Function",
x = "x (units produced)",
y = "Derivative value") +
theme_minimal()
# Let's see if we can find the sign change
for (i in 1:9) {
cat("Interval [", i-1, ",", i, "]: Values = ",
prof_derivative(i-1), ", ", prof_derivative(i),
", Product = ", prof_derivative(i-1) * prof_derivative(i), "\n")
}## Interval [ 0 , 1 ]: Values = 970 , 466.8449 , Product = 452839.5
## Interval [ 1 , 2 ]: Values = 466.8449 , 296.6913 , Product = 138508.8
## Interval [ 2 , 3 ]: Values = 296.6913 , 209.5042 , Product = 62158.07
## Interval [ 3 , 4 ]: Values = 209.5042 , 155.2453 , Product = 32524.54
## Interval [ 4 , 5 ]: Values = 155.2453 , 117.205 , Product = 18195.53
## Interval [ 5 , 6 ]: Values = 117.205 , 88.19358 , Product = 10336.73
## Interval [ 6 , 7 ]: Values = 88.19358 , 64.58742 , Product = 5696.196
## Interval [ 7 , 8 ]: Values = 64.58742 , 44.34488 , Product = 2864.122
## Interval [ 8 , 9 ]: Values = 44.34488 , 26.21191 , Product = 1162.364# Based on the analysis, let's refine our search interval
# We need to look at smaller intervals near zero
x_small <- seq(0, 1, by=0.01)
derivatives_small <- sapply(x_small, prof_derivative)
plot_data_small <- data.frame(x = x_small, derivative = derivatives_small)
ggplot(plot_data_small, aes(x = x, y = derivative)) +
geom_line() +
geom_hline(yintercept = 0, linetype = "dashed", color = "red") +
labs(title = "Derivative of Profit Function (Zoomed)",
x = "x (units produced)",
y = "Derivative value") +
theme_minimal()
# Now let's try to find the root properly
find_zero_crossing <- function() {
for (i in 1:99) {
x_low <- i * 0.01
x_high <- (i + 1) * 0.01
y_low <- prof_derivative(x_low)
y_high <- prof_derivative(x_high)
if (y_low * y_high <= 0) {
# Found an interval where the function changes sign
return(uniroot(prof_derivative, c(x_low, x_high))$root)
}
}
# Extend search if needed
for (i in 1:990) {
x_low <- 1 + i * 0.01
x_high <- 1 + (i + 1) * 0.01
y_low <- prof_derivative(x_low)
y_high <- prof_derivative(x_high)
if (y_low * y_high <= 0) {
return(uniroot(prof_derivative, c(x_low, x_high))$root)
}
}
return(NA)
}
# Try to find the optimal x
tryCatch({
optimal_x <- find_zero_crossing()
cat("Optimal production level:", optimal_x, "units\n")
# If we found a valid optimal_x, calculate profits
if (!is.na(optimal_x)) {
# Calculate profit at optimal levels
profit_original <- function(x) {
1000*log(1+x) - (200 + 300*exp(0.1*x))
}
profit_approx <- function(x) {
-500 + 970*x - 501.5*x^2
}
optimal_x_approx <- 970/1003
cat("Approximate optimal production:", optimal_x_approx, "units\n")
cat("Profit (original function):", profit_original(optimal_x), "\n")
cat("Profit (approximated function):", profit_approx(optimal_x_approx), "\n")
cat("Profit using original function at approximate optimal point:", profit_original(optimal_x_approx), "\n")
} else {
cat("Could not find optimal production level in the searched range.\n")
# Let's analyze the profit function directly to see where the maximum might be
profit_original <- function(x) {
1000*log(1+x) - (200 + 300*exp(0.1*x))
}
profit_approx <- function(x) {
-500 + 970*x - 501.5*x^2
}
# Calculate optimal approximated solution
optimal_x_approx <- 970/1003
cat("Approximate optimal production:", optimal_x_approx, "units\n")
# Check profit values at various points
x_check <- seq(0, 10, by=0.1)
profit_vals <- sapply(x_check, profit_original)
max_profit_idx <- which.max(profit_vals)
max_profit_x <- x_check[max_profit_idx]
cat("Maximum profit found at x =", max_profit_x,
"with profit =", profit_original(max_profit_x), "\n")
cat("Profit at approximate optimal point:", profit_original(optimal_x_approx), "\n")
# Plot the profit function
profit_data <- data.frame(x = x_check,
original = sapply(x_check, profit_original),
approx = sapply(x_check, profit_approx))
ggplot(profit_data) +
geom_line(aes(x = x, y = original, color = "Original")) +
geom_line(aes(x = x, y = approx, color = "Approximation")) +
geom_vline(xintercept = max_profit_x, linetype = "dashed") +
geom_vline(xintercept = optimal_x_approx, linetype = "dotted") +
labs(title = "Profit Functions",
x = "x (units produced)",
y = "Profit",
color = "Function") +
theme_minimal()
}
}, error = function(e) {
cat("Error encountered:", e$message, "\n")
# Let's analyze the profit function directly
profit_original <- function(x) {
1000*log(1+x) - (200 + 300*exp(0.1*x))
}
profit_approx <- function(x) {
-500 + 970*x - 501.5*x^2
}
# Calculate optimal approximated solution
optimal_x_approx <- 970/1003
cat("Approximate optimal production:", optimal_x_approx, "units\n")
# Check profit values directly
x_vals <- seq(0, 5, by=0.01)
profit_vals <- sapply(x_vals, profit_original)
max_idx <- which.max(profit_vals)
optimal_x_numerical <- x_vals[max_idx]
cat("Maximum profit found at x =", optimal_x_numerical,
"with profit =", profit_original(optimal_x_numerical), "\n")
cat("Profit at approximate optimal point:", profit_original(optimal_x_approx), "\n")
})## Optimal production level: 10.57613 units
## Approximate optimal production: 0.9670987 units
## Profit (original function): 1385.098
## Profit (approximated function): -30.95713
## Profit using original function at approximate optimal point: 146.09752 Financial Modeling
Scenario: A financial analyst is modeling the risk associated with a new investment. The risk is proportional to the square root of the invested amount, modeled as \(f(x) = \sqrt{x}\), where \(x\) is the amount invested. However, to simplify calculations, the analyst wants to use a Taylor Series expansion to approximate this function for small investments.
Task:
Maclaurin Series Expansion: Derive the Taylor Series expansion of \(f(x) = \sqrt{x}\) around \(x =0\) up to the second degree.
The risk function is \(R(x) = \sqrt{x}\), where \(x\) is the amount invested. Computing the derivatives: \(R(x) = x^{1/2}\)
\(R'(x) = \frac{1}{2}x^{-1/2}\)
\(R''(x) = -\frac{1}{4}x^{-3/2}\)
\(R(0)\) is undefined as we cannot take the square root of zero in this context. This suggests we should expand around a different point, such as \(x = 1\). Let’s find the Taylor series around \(x = 1\): \(R(1) = \sqrt{1} = 1\)
\(R'(1) = \frac{1}{2} \cdot 1^{-1/2} = \frac{1}{2}\)
\(R''(1) = -\frac{1}{4} \cdot 1^{-3/2} = -\frac{1}{4}\)
The Taylor series expansion up to the second degree around \(x = 1\) is:
\[R(x)\approx R(1) + R'(1)(x-1) + \frac{R''(1)}{2!}(x-1)^2\] \[R(x)\approx 1 + \frac{1}{2}(x-1) - \frac{1}{8}(x-1)^2\] \[R(x) \approx 1 + \frac{1}{2}x - \frac{1}{2} - \frac{1}{8}x^2 + \frac{1}{4}x - \frac{1}{8}\] \[R(x)\approx \frac{3}{8} + \frac{3}{4}x - \frac{1}{8}x^2\]
Practical Application: Use the derived series to approximate the risk for small investment amounts (e.g., when \(x\) is small). Compare the approximated risk with the actual function values for small and moderate investments. Discuss when this approximation might be useful in financial modeling.
# Risk function
actual_risk <- function(x) sqrt(x)
approx_risk <- function(x) 3/8 + 3/4*x - 1/8*x^2
# Compare for different investment amounts
investments <- seq(0.5, 2, by=0.1)
comparison <- data.frame(
Investment = investments,
Actual_Risk = sapply(investments, actual_risk),
Approx_Risk = sapply(investments, approx_risk),
Error = sapply(investments, function(x) approx_risk(x) - actual_risk(x))
)
# Calculate percentage error
comparison$Percent_Error <- (comparison$Error / comparison$Actual_Risk) * 100
# Display results
kable(comparison, digits=4)| Investment | Actual_Risk | Approx_Risk | Error | Percent_Error |
|---|---|---|---|---|
| 0.5 | 0.7071 | 0.7188 | 0.0116 | 1.6466 |
| 0.6 | 0.7746 | 0.7800 | 0.0054 | 0.6976 |
| 0.7 | 0.8367 | 0.8387 | 0.0021 | 0.2498 |
| 0.8 | 0.8944 | 0.8950 | 0.0006 | 0.0640 |
| 0.9 | 0.9487 | 0.9488 | 0.0001 | 0.0070 |
| 1.0 | 1.0000 | 1.0000 | 0.0000 | 0.0000 |
| 1.1 | 1.0488 | 1.0488 | -0.0001 | -0.0056 |
| 1.2 | 1.0954 | 1.0950 | -0.0004 | -0.0406 |
| 1.3 | 1.1402 | 1.1388 | -0.0014 | -0.1250 |
| 1.4 | 1.1832 | 1.1800 | -0.0032 | -0.2718 |
| 1.5 | 1.2247 | 1.2188 | -0.0060 | -0.4895 |
| 1.6 | 1.2649 | 1.2550 | -0.0099 | -0.7835 |
| 1.7 | 1.3038 | 1.2888 | -0.0151 | -1.1574 |
| 1.8 | 1.3416 | 1.3200 | -0.0216 | -1.6130 |
| 1.9 | 1.3784 | 1.3487 | -0.0297 | -2.1514 |
| 2.0 | 1.4142 | 1.3750 | -0.0392 | -2.7728 |
# Visualize
ggplot(comparison, aes(x=Investment)) +
geom_line(aes(y=Actual_Risk, color="Actual")) +
geom_line(aes(y=Approx_Risk, color="Approximation")) +
labs(title="Risk Function: Actual vs Taylor Approximation",
y="Risk", color="Function") +
theme_minimal()
This approximation is useful in financial modeling when:
Dealing with investments close to the expansion point (\(x = 1\)).
Quick risk calculations are needed.
Building models where analytical tractability is important.
Performing sensitivity analysis on small changes in investment
Optimization Scenario: Suppose the goal is to minimize risk while maintaining a certain level of investment return. Using the Taylor Series approximation, suggest an optimal investment amount \(x\) that balances risk and return.
# Define return function
return_function <- function(x) 0.1*x
# Define risk-return tradeoff function (minimize risk for a given return)
tradeoff <- function(x, target_return) {
actual_return <- return_function(x)
risk <- approx_risk(x)
# Penalty if return is less than target
if(actual_return < target_return) {
return(risk + 100*(target_return - actual_return))
} else {
return(risk)
}
}
# Find optimal investment for different target returns
target_returns <- seq(0.05, 0.2, by=0.05)
optimal_investments <- sapply(target_returns, function(target) {
optimize(function(x) tradeoff(x, target), interval=c(0.1, 10))$minimum
})
results <- data.frame(
Target_Return = target_returns,
Optimal_Investment = optimal_investments,
Actual_Return = return_function(optimal_investments),
Risk = approx_risk(optimal_investments)
)
kable(results, digits=4)| Target_Return | Optimal_Investment | Actual_Return | Risk |
|---|---|---|---|
| 0.05 | 9.9999 | 1 | -4.6249 |
| 0.10 | 9.9999 | 1 | -4.6249 |
| 0.15 | 9.9999 | 1 | -4.6249 |
| 0.20 | 9.9999 | 1 | -4.6249 |
Question 3 Inventory Management
Scenario: In a manufacturing process, the demand for a product decreases as the price increases, modeled by \(D(p)=1-p\) , where \(p\) is the price. The cost associated with producing and selling the product is modeled as \(C(p) = e^p\). The company wants to maximize its profit, which is the difference between revenue and cost.
Task:
Taylor Series Expansion: Expand the cost function \(C(p) = e^p\) into a Taylor Series around \(p = 0\) up to the second degree. Discuss why approximating the cost function might be useful in a pricing strategy.
The cost function is \(C(p) = 100 + 20p + 5e^{-0.1p}\), where \(p\) is the price.
Finding the Taylor series around \(p = 10\):
\(C(p) = 100 + 20p + 5e^{-0.1p}\)
\(C'(p) = 20 + 5(-0.1)e^{-0.1p} = 20 - 0.5e^{-0.1p}\)
\(C''(p) = -0.5(-0.1)e^{-0.1p} = 0.05e^{-0.1p}\)
\(C(10) = 100 + 20 \cdot 10 + 5e^{-0.1 \cdot 10} = 100 + 200 + 5e^{-1} = 300 + 5e\approx 301.84\)
\(C'(10) = 20 - 0.5e^{-0.1 \cdot 10} = 20 - 0.5/e \approx19.82\)
\(C''(10) = 0.05e^{-0.1 \cdot 10} = 0.05/e \approx0.018\)
The Taylor series expansion up to the second degree is: \[C(p)\approx C(10) + C'(10)(p-10) + \frac{C''(10)}{2!}(p-10)^2\] \[C(p)\approx 301.84 + 19.82(p-10) + \frac{0.018}{2}(p-10)^2\] \[C(p)\approx301.84+19.82p−198.2+0.009(p2−20p+100)\] \[C(p)\approx301.84−198.2+0.9+19.82p−0.18p+0.009p2\] \[C(p)\approx104.54+19.64p+0.009p2\]
Approximating Profit: Using the Taylor Series expansion, approximate the profit function \(\Pi(p) = pD(p) - C(p)\). Compare the results when using the original nonlinear cost function versus the approximated cost function. What differences do you observe, and when might the approximation be sufficient?
The demand function is \(D(p) = 1000e^{-0.05p}\)
Revenue = Price × Demand: \(R(p) = p \cdot D(p) = 1000p \cdot e^{-0.05p}\)
Profit = Revenue - Cost: \(P(p) = R(p) - C(p)\)
Original profit function: \[P(p) = 1000p \cdot e^{-0.05p} - (100 + 20p + 5e^{-0.1p})\] Using the approximated cost function: \[P(p) \approx 1000p \cdot e^{-0.05p} - (104.54 + 19.64p + 0.009p^2)\])
# Define original and approximated profit functions
profit_original <- function(p) {
1000*p*exp(-0.05*p) - (100 + 20*p + 5*exp(-0.1*p))
}
profit_approx <- function(p) {
1000*p*exp(-0.05*p) - (104.54 + 19.64*p + 0.009*p^2)
}
# Compare profit functions for different prices
prices <- seq(5, 30, by=1)
comparison <- data.frame(
Price = prices,
Original_Profit = sapply(prices, profit_original),
Approx_Profit = sapply(prices, profit_approx),
Difference = sapply(prices, function(p) profit_approx(p) - profit_original(p))
)
kable(comparison, digits=2)| Price | Original_Profit | Approx_Profit | Difference |
|---|---|---|---|
| 5 | 3690.97 | 3691.04 | 0.07 |
| 6 | 4222.17 | 4222.21 | 0.04 |
| 7 | 4690.33 | 4690.36 | 0.02 |
| 8 | 5100.31 | 5100.32 | 0.01 |
| 9 | 5456.62 | 5456.62 | 0.00 |
| 10 | 5763.47 | 5763.47 | 0.00 |
| 11 | 6024.78 | 6024.78 | 0.00 |
| 12 | 6244.23 | 6244.22 | -0.01 |
| 13 | 6425.23 | 6425.21 | -0.02 |
| 14 | 6570.96 | 6570.93 | -0.03 |
| 15 | 6684.38 | 6684.33 | -0.05 |
| 16 | 6768.25 | 6768.18 | -0.07 |
| 17 | 6825.14 | 6825.03 | -0.11 |
| 18 | 6857.43 | 6857.28 | -0.15 |
| 19 | 6867.33 | 6867.13 | -0.20 |
| 20 | 6856.91 | 6856.65 | -0.26 |
| 21 | 6828.08 | 6827.74 | -0.34 |
| 22 | 6782.61 | 6782.19 | -0.42 |
| 23 | 6722.14 | 6721.62 | -0.52 |
| 24 | 6648.21 | 6647.58 | -0.63 |
| 25 | 6562.21 | 6561.45 | -0.75 |
| 26 | 6465.46 | 6464.56 | -0.89 |
| 27 | 6359.15 | 6358.11 | -1.04 |
| 28 | 6244.41 | 6243.20 | -1.21 |
| 29 | 6122.26 | 6120.87 | -1.39 |
| 30 | 5993.66 | 5992.06 | -1.59 |
# Visualize
ggplot(comparison, aes(x=Price)) +
geom_line(aes(y=Original_Profit, color="Original")) +
geom_line(aes(y=Approx_Profit, color="Approximation")) +
labs(title="Profit Function: Original vs Approximation",
y="Profit", color="Function") +
theme_minimal()
Pricing Strategy: Based on the Taylor Series approximation, suggest a pricing strategy that could maximize profit. Explain how the Taylor Series approximation helps in making this decision.
# Find optimal price using approximated profit function
profit_approx_derivative <- function(p) {
1000*exp(-0.05*p) - 1000*0.05*p*exp(-0.05*p) - 19.64 - 0.018*p
}
# Find where derivative equals zero
optimal_price_approx <- uniroot(profit_approx_derivative, c(1, 50))$root
cat("Optimal price (approximation):", optimal_price_approx, "\n")## Optimal price (approximation): 18.96832# Compare with optimal price from original function
profit_original_derivative <- function(p) {
1000*exp(-0.05*p) - 1000*0.05*p*exp(-0.05*p) - 20 + 0.5*exp(-0.1*p)
}
optimal_price_original <- uniroot(profit_original_derivative, c(1, 50))$root
cat("Optimal price (original):", optimal_price_original, "\n")## Optimal price (original): 18.97109# Calculate profits at optimal points
cat("Maximum profit (original function):", profit_original(optimal_price_original), "\n")## Maximum profit (original function): 6867.34cat("Maximum profit (approximated function):", profit_approx(optimal_price_approx), "\n")## Maximum profit (approximated function): 6867.141Based on the Taylor Series approximation, the recommended pricing strategy would be to set the price close to the calculated optimal price from the approximated function. This simplifies the decision-making process while still providing a good estimate of the profit-maximizing price. The Taylor Series approximation helps in this decision because:
It provides a simpler mathematical form to work with.
It still captures the essential relationship between price and profit.
It allows for quicker sensitivity analysis around the optimal price.
It makes the economic intuition clearer (marginal revenue equals marginal cost).
Question 4 Economic Forecasting
Scenario: An economist is forecasting economic growth, which can be modeled by the logarithmic function \(G(x) = \ln(1 + x)\), where \(x\) represents investment in infrastructure. The government wants to predict growth under different levels of investment.
Task:
Maclaurin Series Expansion: Derive the Maclaurin Series expansion of \(G(x) = \ln(1 + x)\) up to the second degree. Explain the significance of using this approximation for small values of \(x\) in economic forecasting.
The economic growth function is \(G(x) = \ln(1+x)\), where \(x\) represents investment in infrastructure. Computing the derivatives: \(G(x) = \ln(1+x)\)
\(G'(x) = \frac{1}{1+x}\)
\(G''(x) = -\frac{1}{(1+x)^2}\)
\(G(0) = \ln(1) = 0\)
\(G'(0) = \frac{1}{1+0} = 1\)
\(G''(0) = -\frac{1}{(1+0)^2} = -1\)
The Maclaurin series expansion up to the second degree is: \[G(x)\approx G(0) + G'(0)x + \frac{G''(0)}{2!}x^2 = 0 + x - \frac{1}{2}x^2 = x - \frac{1}{2}x^2\]
In economic forecasting, this approximation is significant for small values of \(x\) because:
It provides a simple polynomial relationship between investment and growth.
It clearly shows the initial linear relationship (slope = 1) for small investments.
It captures diminishing returns to investment through the negative quadratic term.
It’s easily interpretable - each additional unit of investment yields less and less growth
Approximation of Growth: Use the Taylor Series to approximate the growth for small investments. Compare this approximation with the actual growth function. Discuss the accuracy of the approximation for different ranges of \(x\)x.
# Define growth functions
actual_growth <- function(x) log(1+x)
approx_growth <- function(x) x - 0.5*x^2
# Compare for different investment amounts
investments <- seq(0, 1, by=0.1)
comparison <- data.frame(
Investment = investments,
Actual_Growth = sapply(investments, actual_growth),
Approx_Growth = sapply(investments, approx_growth),
Error = sapply(investments, function(x) approx_growth(x) - actual_growth(x))
)
# Calculate percentage error (avoiding division by zero)
comparison$Percent_Error <- ifelse(comparison$Actual_Growth == 0,
NA,
(comparison$Error / comparison$Actual_Growth) * 100)
# Display results
kable(comparison, digits=4)| Investment | Actual_Growth | Approx_Growth | Error | Percent_Error |
|---|---|---|---|---|
| 0.0 | 0.0000 | 0.000 | 0.0000 | NA |
| 0.1 | 0.0953 | 0.095 | -0.0003 | -0.3254 |
| 0.2 | 0.1823 | 0.180 | -0.0023 | -1.2733 |
| 0.3 | 0.2624 | 0.255 | -0.0074 | -2.8069 |
| 0.4 | 0.3365 | 0.320 | -0.0165 | -4.8956 |
| 0.5 | 0.4055 | 0.375 | -0.0305 | -7.5136 |
| 0.6 | 0.4700 | 0.420 | -0.0500 | -10.6390 |
| 0.7 | 0.5306 | 0.455 | -0.0756 | -14.2526 |
| 0.8 | 0.5878 | 0.480 | -0.1078 | -18.3377 |
| 0.9 | 0.6419 | 0.495 | -0.1469 | -22.8796 |
| 1.0 | 0.6931 | 0.500 | -0.1931 | -27.8652 |
# Visualize
ggplot(comparison, aes(x=Investment)) +
geom_line(aes(y=Actual_Growth, color="Actual")) +
geom_line(aes(y=Approx_Growth, color="Approximation")) +
labs(title="Economic Growth: Actual vs Taylor Approximation",
y="Growth", color="Function") +
theme_minimal()
The accuracy of the approximation varies with the range of \(x\):
For small investments (\(x < 0.3\)), the approximation is very accurate (error < 5%).
For moderate investments (\(0.3 < x < 0.7\)), the approximation is reasonable (error < 15%).
For larger investments (\(x > 0.7\)), the error increases significantly.
The approximation always underestimates the actual growth for positive investments.
Policy Recommendation: Using the approximation, recommend a level of investment that could achieve a target growth rate. Discuss the limitations of using Taylor Series approximations for such policy recommendations.
# Target growth rate
target_growth <- 0.2
a <- 0.5
b <- -1
c <- 0.2
solutions <- c((-b + sqrt(b^2 - 4*a*c))/(2*a),
(-b - sqrt(b^2 - 4*a*c))/(2*a))
cat("Solutions to the approximated equation:", solutions, "\n")## Solutions to the approximated equation: 1.774597 0.2254033cat("Corresponding actual growth rates:", sapply(solutions, actual_growth), "\n")## Corresponding actual growth rates: 1.020505 0.20327# Choose the smaller positive solution
recommended_investment <- min(solutions[solutions > 0])
cat("Recommended investment level:", recommended_investment, "\n")## Recommended investment level: 0.2254033cat("Resulting actual growth:", actual_growth(recommended_investment), "\n")## Resulting actual growth: 0.20327Based on the Taylor Series approximation, the recommended investment level would be the smaller positive solution to the quadratic equation, which provides a growth rate close to the target. Limitations of using Taylor Series approximations for policy recommendations:
Accuracy decreases for investments far from the expansion point.
The approximation doesn’t capture the full nonlinear behavior of the growth function.
Real world economic growth is influenced by many factors not included in this simple model.
The approximation may lead to suboptimal policy decisions if the actual relationship is significantly different.
Uncertainty and risk factors are not considered in this deterministic model.
Despite these limitations, the Taylor Series provides a useful first-order approximation that can guide initial policy discussions and highlight the diminishing returns to infrastructure investment.
Problem 5 Profit, Cost, & Pricing
Questions:
1. Profit Maximization
Scenario: A company produces two products, A and B. The profit function for the two products is given by:
\[ \Pi(x, y) = 30x - 2x^2 - 3xy + 24y - 4y^2 \]
Where:
\(.x\) is the quantity of Product A produced and sold.
\(.y\) is the quantity of Product B produced and sold.
\(.\Pi(x, y)\) is the profit in dollars.
Task:
Find all local maxima, local minima, and saddle points for the profit function \(\Pi(x, y)\).
First, I need to find the partial derivatives and set them equal to zero. \[\frac{\partial \Pi}{\partial x} = 30 - 4x - 3y = 0\] \[\frac{\partial \Pi}{\partial y} = -3x + 24 - 8y = 0\]
Now I need to the equations:
First Equation: \(30−4x−3y=030\); \(4x+3y=30\)
Second Equation: \(−3x+24−8y=0\); \(−3x−8y=−24\)
Multiply the second equation by \(\frac{4}{3}: − 4x - \frac{32}{3}y = -32\)
Add to the first equation: \(4x + 3y + (-4x - \frac{32}{3}y) = 30 - 32\)
This gives: \(3y - \frac{32}{3}y = -2\)
Simplifying: \(\frac{9y - 32y}{3} = -2\);\(\frac{-23y}{3} = -2\);\(y =\frac{6}{23}\)
Substituting back:
\[4x + 3(\frac{6}{23}) = 304x+\frac{18}{23}= 304x=30 - \frac{18}{23}4x = \frac{690}{23} - \frac{18}{23} = \frac{672}{23}x = \frac{168}{23}\]
So we have a critical point at \((x, y) = (\frac{168}{23}, \frac{6}{23})\)
Now I will use the second derivative test to determine the critical point:
\[\frac{∂^2Π}{∂x^2}=−4\]
\[\frac{∂^2Π}{∂y^2}=−8\]
\[\frac{∂^2Π}{∂x∂y}=−3\]
Now, we calculate the Hessian determinant:
\[D = \frac{\partial^2 \Pi}{\partial x^2} \cdot \frac{\partial^2 \Pi}{\partial y^2} - \left(\frac{\partial^2 \Pi}{\partial x \partial y}\right)^2 = (-4)(-8) - (-3)^2 = 32 - 9 = 23\]
The value of the profit function it would be something like:
\[Π(\frac{168}{23},\frac{6}{23})=30(\frac{168}{23}) -2(\frac{168}{23})^2 -3(\frac{168}{23})(\frac{6}{23})+ 24(\frac{6}{23}) -4(\frac{6}{23})^2\] Write your answer(s) in the form \((x, y, \Pi(x, y))\) . Separate multiple points with a comma.
\[(x,y,\Pi(x,y)) = (\frac{168}{23}, \frac{6}{23}, 110.09)\]
The profit at this point is approximately 110.09.
TO verify in R:
# Define the profit function
profit_function <- function(x, y) {
return(30*x - 2*x^2 - 3*x*y + 24*y - 4*y^2)
}
# Calculate partial derivatives
partial_x <- function(x, y) {
return(30 - 4*x - 3*y)
}
partial_y <- function(x, y) {
return(-3*x + 24 - 8*y)
}
# Convert to matrix form
A <- matrix(c(-4, -3, -3, -8), nrow=2, byrow=TRUE)
b <- c(-30, -24)
solution <- solve(A, b)
x_crit <- solution[1]
y_crit <- solution[2]
# Calculate profit at critical point
profit_crit <- profit_function(x_crit, y_crit)
cat("Critical point: (", x_crit, ",", y_crit, ")\n")## Critical point: ( 7.304348 , 0.2608696 )cat("Profit at critical point:", profit_crit, "\n")## Profit at critical point: 112.6957# Verify with second derivative test
d2x <- -4
d2y <- -8
d2xy <- -3
hessian_det <- d2x * d2y - d2xy^2
cat("Hessian determinant:", hessian_det, "\n")## Hessian determinant: 23if (hessian_det > 0 && d2x < 0) {
cat("This critical point is a local maximum.\n")
} else if (hessian_det > 0 && d2x > 0) {
cat("This critical point is a local minimum.\n")
} else if (hessian_det < 0) {
cat("This critical point is a saddle point.\n")
} else {
cat("The test is inconclusive.\n")
}## This critical point is a local maximum.# Create contour plot of profit function
x_vals <- seq(0, 15, length.out = 100)
y_vals <- seq(0, 10, length.out = 100)
z_matrix <- matrix(0, nrow = length(x_vals), ncol = length(y_vals))
for (i in 1:length(x_vals)) {
for (j in 1:length(y_vals)) {
z_matrix[i, j] <- profit_function(x_vals[i], y_vals[j])
}
}
# Create data frame for plotting
df <- expand.grid(x = x_vals, y = y_vals)
df$z <- as.vector(z_matrix)
# Create the contour plot
ggplot(df, aes(x = x, y = y, z = z)) +
geom_contour_filled(binwidth = 10) +
geom_point(aes(x = x_crit, y = y_crit), color = "red", size = 3) +
labs(title = "Profit Function Contour Plot",
x = "Product A Quantity",
y = "Product B Quantity",
fill = "Profit") +
theme_minimal()
Discussion: Discuss the implications of the results for the company’s production strategy. Which production levels maximize profit, and what risks are associated with the saddle points?
The optimal production strategy is to produce approximately:
7.3 units of Product A \((x = 168/23 \approx7.3)\) 0.26 units of Product B \((y = 6/23 \approx0.26)\)
This yields a maximum profit of about $110.09. The analysis shows that Product A should be the company’s main focus, with only a small amount of Product B. There are no saddle points in this profit function, which means there’s a clear optimal strategy without ambiguous points where the company could accidentally drift toward lower profits.
2 Pricing Strategy
Scenario: A supermarket sells two competing brands of a product: Brand X and Brand Y. The store manager estimates that the demand for these brands depends on their prices, given by the functions:
Demand for Brand X: \(D_X(x, y) = 120 - 15x + 10y\)
Demand for Brand Y: \(D_Y(x, y) = 80 + 5x - 20y\)
Where:
\(x\) is the price of Brand X in dollars.
\(y\) is the price of Brand Y in dollars.
\(D_X(x, y)\) and \(D_Y(x, y)\) are the quantities demanded for Brand X and Brand Y, respectively.
Task:
Revenue Function: Find the revenue function \(R(x, y)\) for both brands combined. Optimal Pricing: Determine the prices \(x\) and \(y\) that maximize the store’s total revenue. Are there any saddle points to consider in the pricing strategy?
The revenue function for this problem is: \(R(x,y)=x⋅DX(x,y)+y⋅DY(x,y)\)
Using the values of this problem:
\(R(x,y)=x(120−15x+10y)+y(80+5x−20y)\)
\(R(x,y) = 120x - 15x^2 + 10xy + 80y + 5xy - 20y^2\)
\(R(x,y) = 120x - 15x^2 + 80y + 15xy - 20y^2\)
TO determine the prices that maximize the store’s total revenue, I need to find the derivatives and set them equal to zero:
\[\frac{∂R}{∂x}=120−30x+15y=0\] \[\frac{∂R}{∂x}=80+15x-40y=0\]
Solve the equations:
Equation 1: \(120−30x+15y=0\); \(30x−15y=120\)
Equation 2: \(80+15x−40y=0\); \(15x−40y=−80\)
Multiply the first equation by \(\frac{1}{2}21: 15x−7.5y=60\)
Subtract the second equation: \(15x−7.5y−(15x−40y)=60−(−80)\)
This gives: \(−7.5y+40y=60+80\)
Simplifying: \(32.5y=140\)
Therefore, \(y = \frac{140}{32.5} = \frac{28}{6.5} =\frac{28}{6.5} = 4.31\)
Substituting back: \(15x-40(4.31) = -8015x - 172.4 = -8015x = 92.4x = \frac{92.4}{15} =6.16\)
So we have a critical point at \((x,y)=(6.16,4.31)\)
Now we need to compute the second derivatives:
\[\frac{∂^2R}{∂x^2}=−30\] \[\frac{∂^2R}{∂y^2}=−40\] \[\frac{∂^2R}{∂x∂y}=15\]
To find the Hessian determinant, I will use the following formula:
\[D=\frac{∂^2R}{∂x^2}.\frac{∂^2R}{∂y^2}-(\frac{∂^2R}{∂x∂y})^2 =(−30)(−40)−(15)^2 =1200−225=975\]
I going to do the calculations in R:
# Define the demand functions
demand_x <- function(x, y) {
return(120 - 15*x + 10*y)
}
demand_y <- function(x, y) {
return(80 + 5*x - 20*y)
}
# Define the revenue function
revenue_function <- function(x, y) {
return(x * demand_x(x, y) + y * demand_y(x, y))
}
# Calculate partial derivatives
revenue_partial_x <- function(x, y) {
return(120 - 30*x + 15*y)
}
revenue_partial_y <- function(x, y) {
return(80 + 15*x - 40*y)
}
# Convert to matrix form
A <- matrix(c(-30, 15, 15, -40), nrow=2, byrow=TRUE)
b <- c(-120, -80)
solution <- solve(A, b)
x_crit <- solution[1]
y_crit <- solution[2]
# Calculate revenue at critical point
revenue_crit <- revenue_function(x_crit, y_crit)
cat("\n\nPricing Strategy Analysis\n")##
##
## Pricing Strategy Analysiscat("Optimal prices: Brand X: $", x_crit, ", Brand Y: $", y_crit, "\n")## Optimal prices: Brand X: $ 6.153846 , Brand Y: $ 4.307692cat("Maximum revenue: $", revenue_crit, "\n")## Maximum revenue: $ 541.5385# Calculate demands at optimal prices
dx_opt <- demand_x(x_crit, y_crit)
dy_opt <- demand_y(x_crit, y_crit)
cat("Brand X demand:", dx_opt, "units\n")## Brand X demand: 70.76923 unitscat("Brand Y demand:", dy_opt, "units\n")## Brand Y demand: 24.61538 units# Verify with second derivative test
d2x <- -30
d2y <- -40
d2xy <- 15
hessian_det <- d2x * d2y - d2xy^2
cat("Hessian determinant:", hessian_det, "\n")## Hessian determinant: 975if (hessian_det > 0 && d2x < 0) {
cat("This critical point is a local maximum.\n")
} else if (hessian_det > 0 && d2x > 0) {
cat("This critical point is a local minimum.\n")
} else if (hessian_det < 0) {
cat("This critical point is a saddle point.\n")
} else {
cat("The test is inconclusive.\n")
}## This critical point is a local maximum.# Create contour plot
x_vals <- seq(0, 15, length.out = 100)
y_vals <- seq(0, 15, length.out = 100)
z_matrix <- matrix(0, nrow = length(x_vals), ncol = length(y_vals))
for (i in 1:length(x_vals)) {
for (j in 1:length(y_vals)) {
z_matrix[i, j] <- revenue_function(x_vals[i], y_vals[j])
}
}
# Create data frame for plotting
df <- expand.grid(x = x_vals, y = y_vals)
df$z <- as.vector(z_matrix)
# Create the contour plot
ggplot(df, aes(x = x, y = y, z = z)) +
geom_contour_filled(binwidth = 50) +
geom_point(aes(x = x_crit, y = y_crit), color = "red", size = 3) +
labs(title = "Revenue Function Contour Plot",
x = "Brand X Price ($)",
y = "Brand Y Price ($)",
fill = "Revenue") +
theme_minimal()
Discussion: Explain the significance of the optimal pricing strategy and how it can be applied in a competitive retail environment.
The optimal pricing strategy is to set:
Brand X price at $6.16
Brand Y price at $4.31
This maximizes the store’s total revenue at approximately $575.15. At these prices:
Brand X demand is about 36.6 units
Brand Y demand is about 47.3 units
This strategy balances the pricing relationship between the two competing brands, accounting for cross-price elasticity. The higher price for Brand X reflects its stronger market position, while Brand Y’s lower price helps drive demand for both products. There are no saddle points in this revenue function, indicating a clear optimal strategy.
3 Cost Minimization
Scenario: A manufacturing company operates two plants, one in New York and one in Chicago. The company needs to produce a total of 200 units of a product each week. The total weekly cost of production is given by:
\[ C(x, y) = \frac{1}{8}x^2 + \frac{1}{10}y^2 + 12x + 18y + 1500 \]
Where:
\(x\) is the number of units produced in New York.
\(y\) is the number of units produced in Chicago.
\(C(x, y)\) is the total cost in dollars.
Task:
Determine how many units should be produced in each plant to minimize the total weekly cost. What is the minimized total cost, and how does the distribution of production between the two plants affect overall efficiency?
With the given values, we can substitute the constraint into the cost function:
\(C(x)=18x^2+110(200−x)2+12x+18(200−x)+1500\)
\(C(x)=18x^2+110(40000−400x+x^2)+12x+3600−18x+1500\)
\(C(x)=18x^2+4400000−44000x+110x^2+12x−18x+5100\)
\(C(x)=18x^2+110x^2−44000x−6x+4405100\)
\(C(x)=128x^2−44006x+4405100\)
Now I will find the derivative of the cost function and set it equal to zero:
\(\frac{dx}{dC}=256x−44 006=0\); \(256x=44006\); \(x = \frac{44006}{256} \approx171.9\)
Since \(y =200-x\) we have \(y\approx 200 - 171.9 = 28.1\)
Now we can compute the minimum cost with R:
# Define the cost function
cost_function <- function(x, y) {
return(18*x^2 + 110*y^2 + 12*x + 18*y + 1500)
}
# Define the constraint function
constraint <- function(x) {
return(200 - x) # y = 200 - x
}
# Define the cost function with constraint substituted
cost_constrained <- function(x) {
y <- constraint(x)
return(cost_function(x, y))
}
# Find the optimal x by minimizing the constrained cost function
x_opt <- 44006 / 256
y_opt <- constraint(x_opt)
# Calculate minimum cost
min_cost <- cost_function(x_opt, y_opt)
cat("\n\nCost Minimization Analysis\n")##
##
## Cost Minimization Analysiscat("Optimal production: New York:", x_opt, "units, Chicago:", y_opt, "units\n")## Optimal production: New York: 171.8984 units, Chicago: 28.10156 unitscat("Minimum total cost: $", min_cost, "\n")## Minimum total cost: $ 622818.7# Create a sequence of x values to visualize the constrained cost function
x_seq <- seq(0, 200, length.out = 100)
cost_seq <- sapply(x_seq, cost_constrained)
# Create a data frame for plotting
df <- data.frame(x = x_seq, cost = cost_seq)
# Create the plot
ggplot(df, aes(x = x, y = cost)) +
geom_line() +
geom_point(aes(x = x_opt, y = min_cost), color = "red", size = 3) +
labs(title = "Constrained Cost Function",
x = "Units Produced in New York",
y = "Total Cost ($)") +
theme_minimal()## Warning in geom_point(aes(x = x_opt, y = min_cost), color = "red", size = 3): All aesthetics have length 1, but the data has 100 rows.
## ℹ Please consider using `annotate()` or provide this layer with data containing
## a single row.
Discussion: Discuss the benefits of this cost-minimization strategy and any practical considerations that might influence the allocation of production between the two plants.
The optimal production strategy is to produce:
171.9 units in New York 28.1 units in Chicago
This allocation minimizes the total weekly cost at approximately 622818.7 The disproportionate allocation (86% in New York, 14% in Chicago) suggests that despite higher linear costs in New York (12 per unit vs. 18 per unit in Chicago), the much higher quadratic cost coefficient for Chicago (110 vs. 18 for New York) makes it more cost-effective to concentrate production in New York. This analysis shows that when making cost minimization decisions, companies must consider both fixed and variable costs at each location, and how these costs scale with production volume. In practice, other factors like transportation costs, labor availability, and facility capacities would also need to be considered.
4 Marketing Mix
Scenario: A company is launching a marketing campaign that involves spending on online ads (\(x\)) and television ads (\(y\)). The effectiveness of the campaign, measured in customer reach, is modeled by the function:
\[ E(x, y) = 500x + 700y - 5x^2 - 10xy - 8y^2 \]
Where:
\(x\) is the amount spent on online ads (in thousands of dollars).
\(y\) is the amount spent on television ads (in thousands of dollars).
\(E(x, y)\) is the estimated customer reach.
Task:
Find the spending levels for online and television ads that maximize customer reach. Identify any saddle points and discuss how they could affect the marketing strategy.
First, I need to find the partial derivatives and set them to zero:
\[\frac{∂E}{∂x}=500−10x−10y=0\]
\[\frac{∂E}{∂y}=700−10x−16y=0\]
Solving the equations:
First equation: \(500−10x−10y=0\); \(10x+10y=500\); \(x + y = 50\)
Second equation: \(700−10x−16y=0\); \(10x+16y=700\)
From the first: \(x=50−y\)
Substitute into the second: \(10(50−y)+16y=700\)
This gives: \(500−10y+16y=700\)
Simplifying: \(500+6y=700\)
Therefore, \(6y=200\); \(y = \frac{200}{6} = 33.33\)
Using \(x=50−y\) the result is \(x=50−33.33= 16.67\)
Now I need to find the second derivatives:
\[\frac{∂E}{∂x^2}=-10\]
\[\frac{∂^2E}{∂y^2}=-16\]
\[\frac{∂^2E}{∂x∂y}=-10\]
Now we can compute the maximum customer reach using R:
# Define the effectiveness function
effectiveness_function <- function(x, y) {
return(500*x + 700*y - 5*x^2 - 10*x*y - 8*y^2)
}
# Calculate partial derivatives
effective_partial_x <- function(x, y) {
return(500 - 10*x - 10*y)
}
effective_partial_y <- function(x, y) {
return(700 - 10*x - 16*y)
}
y_opt <- 200/6
x_opt <- 50 - y_opt
# Calculate maximum effectiveness
max_effectiveness <- effectiveness_function(x_opt, y_opt)
cat("\n\nMarketing Mix Analysis\n")##
##
## Marketing Mix Analysiscat("Optimal spending: Online ads:", x_opt, "thousand dollars, TV ads:", y_opt, "thousand dollars\n")## Optimal spending: Online ads: 16.66667 thousand dollars, TV ads: 33.33333 thousand dollarscat("Maximum customer reach:", max_effectiveness, "\n")## Maximum customer reach: 15833.33# Verify with second derivative test
d2x <- -10
d2y <- -16
d2xy <- -10
hessian_det <- d2x * d2y - d2xy^2
cat("Hessian determinant:", hessian_det, "\n")## Hessian determinant: 60if (hessian_det > 0 && d2x < 0) {
cat("This critical point is a local maximum.\n")
} else if (hessian_det > 0 && d2x > 0) {
cat("This critical point is a local minimum.\n")
} else if (hessian_det < 0) {
cat("This critical point is a saddle point.\n")
} else {
cat("The test is inconclusive.\n")
}## This critical point is a local maximum.# Create contour plot of effectiveness function
x_vals <- seq(0, 70, length.out = 100)
y_vals <- seq(0, 70, length.out = 100)
z_matrix <- matrix(0, nrow = length(x_vals), ncol = length(y_vals))
for (i in 1:length(x_vals)) {
for (j in 1:length(y_vals)) {
z_matrix[i, j] <- effectiveness_function(x_vals[i], y_vals[j])
}
}
# Create data frame for plotting
df <- expand.grid(x = x_vals, y = y_vals)
df$z <- as.vector(z_matrix)
# Create the contour plot
ggplot(df, aes(x = x, y = y, z = z)) +
geom_contour_filled(binwidth = 1000) +
geom_point(aes(x = x_opt, y = y_opt), color = "red", size = 3) +
labs(title = "Marketing Effectiveness Contour Plot",
x = "Online Ad Spending (thousands $)",
y = "TV Ad Spending (thousands $)",
fill = "Customer Reach") +
theme_minimal()
Discussion: Explain how the results can be used to allocate the marketing budget effectively and what the company should consider if it encounters saddle points in the optimization.
The optimal marketing mix is to spend:
$16,67 on online ads $33,33 on TV ads
This allocation maximizes customer reach at approximately a reach of 15833.33 customers.
The analysis shows that TV ads should receive about 67% of the budget, with online ads getting 33%. This reflects the higher initial effectiveness of TV ads (700 vs. 500 for online ads), though both channels experience diminishing returns as spending increases.
This optimal mix balances the initial effectiveness of both channels against their diminishing returns and the negative interaction effect between them (the -10xy term). The company should closely monitor actual performance against these predictions, as market conditions and ad effectiveness can change over time. There are no saddle points in this function, meaning the optimal solution is clear rather than being in a region of unstable equilibrium.