Quiz 1 - answer
Aliya Cinta Qaumi
2026-03-31
Question 1: Trimmed Mean
Function
trimmed_mean <- function(x, alpha = 0.1) {
n <- length(x)
k<- floor(n * alpha)
sum_manual <- function(x, n, k){
result <- 0
for(i in (k+1):(n-k)){
result <- result + x[i]
}
return(result)
}
TM <- (1 / (n - 2*k)) * sum_manual(x, n, k)
return(TM)
}Data & Sorting Data
x <- c(850, 920, 1100, 1250, 1300, 1400, 1500, 1550, 1600, 1750, 2100, 8500)
sortedx <- sort(x)Ordinary mean (alpha = 0)
ord_mean <- trimmed_mean(sortedx, 0)
ord_mean## [1] 198510% Trimmed mean (alpha = 0.10)
trim_mean <- trimmed_mean(sortedx)
trim_mean## [1] 1447Visualization
stripchart(sortedx,
method = "jitter",
pch = 19,
col = "dodgerblue",
main = "Household Expenditures: Ordinary vs. 10% Trimmed Mean",
xlab = "Expenditure (Thousands IDR)",
xlim = c(0, 9000),
frame.plot = FALSE)
abline(v = ord_mean, col = "red", lwd = 2, lty = 2)
abline(v = trim_mean, col = "darkgreen", lwd = 2, lty = 1)
legend("topright",
legend = c("Data Points", "Ordinary Mean", "10% Trimmed Mean"),
col = c("dodgerblue", "red", "darkgreen"),
pch = c(19, NA, NA),
lty = c(NA, 2, 1),
lwd = c(NA, 2, 2),
bty = "n")
Question 2:
Function
weighted_multi_desc <- function(X, w){
W <- diag(w)
n <- nrow(X)
nw <- 0
onematrix <- matrix(rep(1, n), ncol = 1)
for(i in 1:n){
nw <- nw + w[i]
}
Xbarw <- 1 / nw * (t(X) %*% W %*% onematrix)
D <- X - (onematrix %*% t(Xbarw))
S_w <- 1 / (nw - 1) * (t(D) %*% W %*% D)
sw <- sqrt(diag(S_w))
return(list(W1 = W,
w_mean = Xbarw,
x_cov = S_w,
w_std = sw))
}Data
data <- read.csv("data_quiz.csv", header = TRUE)
X <- as.matrix(data[, c("Income", "Expenditure", "HH_Size")])
w <- data$Weightweighted_multi_desc(X, w)## $W1
## [,1] [,2] [,3] [,4] [,5] [,6] [,7] [,8] [,9] [,10] [,11] [,12] [,13]
## [1,] 5 0 0 0 0 0 0 0 0 0 0 0 0
## [2,] 0 7 0 0 0 0 0 0 0 0 0 0 0
## [3,] 0 0 10 0 0 0 0 0 0 0 0 0 0
## [4,] 0 0 0 5 0 0 0 0 0 0 0 0 0
## [5,] 0 0 0 0 6 0 0 0 0 0 0 0 0
## [6,] 0 0 0 0 0 4 0 0 0 0 0 0 0
## [7,] 0 0 0 0 0 0 6 0 0 0 0 0 0
## [8,] 0 0 0 0 0 0 0 13 0 0 0 0 0
## [9,] 0 0 0 0 0 0 0 0 6 0 0 0 0
## [10,] 0 0 0 0 0 0 0 0 0 5 0 0 0
## [11,] 0 0 0 0 0 0 0 0 0 0 7 0 0
## [12,] 0 0 0 0 0 0 0 0 0 0 0 18 0
## [13,] 0 0 0 0 0 0 0 0 0 0 0 0 11
## [14,] 0 0 0 0 0 0 0 0 0 0 0 0 0
## [15,] 0 0 0 0 0 0 0 0 0 0 0 0 0
## [16,] 0 0 0 0 0 0 0 0 0 0 0 0 0
## [17,] 0 0 0 0 0 0 0 0 0 0 0 0 0
## [18,] 0 0 0 0 0 0 0 0 0 0 0 0 0
## [19,] 0 0 0 0 0 0 0 0 0 0 0 0 0
## [20,] 0 0 0 0 0 0 0 0 0 0 0 0 0
## [21,] 0 0 0 0 0 0 0 0 0 0 0 0 0
## [22,] 0 0 0 0 0 0 0 0 0 0 0 0 0
## [23,] 0 0 0 0 0 0 0 0 0 0 0 0 0
## [24,] 0 0 0 0 0 0 0 0 0 0 0 0 0
## [25,] 0 0 0 0 0 0 0 0 0 0 0 0 0
## [26,] 0 0 0 0 0 0 0 0 0 0 0 0 0
## [27,] 0 0 0 0 0 0 0 0 0 0 0 0 0
## [28,] 0 0 0 0 0 0 0 0 0 0 0 0 0
## [29,] 0 0 0 0 0 0 0 0 0 0 0 0 0
## [30,] 0 0 0 0 0 0 0 0 0 0 0 0 0
## [31,] 0 0 0 0 0 0 0 0 0 0 0 0 0
## [,14] [,15] [,16] [,17] [,18] [,19] [,20] [,21] [,22] [,23] [,24] [,25]
## [1,] 0 0 0 0 0 0 0 0 0 0 0 0
## [2,] 0 0 0 0 0 0 0 0 0 0 0 0
## [3,] 0 0 0 0 0 0 0 0 0 0 0 0
## [4,] 0 0 0 0 0 0 0 0 0 0 0 0
## [5,] 0 0 0 0 0 0 0 0 0 0 0 0
## [6,] 0 0 0 0 0 0 0 0 0 0 0 0
## [7,] 0 0 0 0 0 0 0 0 0 0 0 0
## [8,] 0 0 0 0 0 0 0 0 0 0 0 0
## [9,] 0 0 0 0 0 0 0 0 0 0 0 0
## [10,] 0 0 0 0 0 0 0 0 0 0 0 0
## [11,] 0 0 0 0 0 0 0 0 0 0 0 0
## [12,] 0 0 0 0 0 0 0 0 0 0 0 0
## [13,] 0 0 0 0 0 0 0 0 0 0 0 0
## [14,] 6 0 0 0 0 0 0 0 0 0 0 0
## [15,] 0 9 0 0 0 0 0 0 0 0 0 0
## [16,] 0 0 7 0 0 0 0 0 0 0 0 0
## [17,] 0 0 0 6 0 0 0 0 0 0 0 0
## [18,] 0 0 0 0 12 0 0 0 0 0 0 0
## [19,] 0 0 0 0 0 7 0 0 0 0 0 0
## [20,] 0 0 0 0 0 0 20 0 0 0 0 0
## [21,] 0 0 0 0 0 0 0 18 0 0 0 0
## [22,] 0 0 0 0 0 0 0 0 9 0 0 0
## [23,] 0 0 0 0 0 0 0 0 0 11 0 0
## [24,] 0 0 0 0 0 0 0 0 0 0 10 0
## [25,] 0 0 0 0 0 0 0 0 0 0 0 23
## [26,] 0 0 0 0 0 0 0 0 0 0 0 0
## [27,] 0 0 0 0 0 0 0 0 0 0 0 0
## [28,] 0 0 0 0 0 0 0 0 0 0 0 0
## [29,] 0 0 0 0 0 0 0 0 0 0 0 0
## [30,] 0 0 0 0 0 0 0 0 0 0 0 0
## [31,] 0 0 0 0 0 0 0 0 0 0 0 0
## [,26] [,27] [,28] [,29] [,30] [,31]
## [1,] 0 0 0 0 0 0
## [2,] 0 0 0 0 0 0
## [3,] 0 0 0 0 0 0
## [4,] 0 0 0 0 0 0
## [5,] 0 0 0 0 0 0
## [6,] 0 0 0 0 0 0
## [7,] 0 0 0 0 0 0
## [8,] 0 0 0 0 0 0
## [9,] 0 0 0 0 0 0
## [10,] 0 0 0 0 0 0
## [11,] 0 0 0 0 0 0
## [12,] 0 0 0 0 0 0
## [13,] 0 0 0 0 0 0
## [14,] 0 0 0 0 0 0
## [15,] 0 0 0 0 0 0
## [16,] 0 0 0 0 0 0
## [17,] 0 0 0 0 0 0
## [18,] 0 0 0 0 0 0
## [19,] 0 0 0 0 0 0
## [20,] 0 0 0 0 0 0
## [21,] 0 0 0 0 0 0
## [22,] 0 0 0 0 0 0
## [23,] 0 0 0 0 0 0
## [24,] 0 0 0 0 0 0
## [25,] 0 0 0 0 0 0
## [26,] 9 0 0 0 0 0
## [27,] 0 10 0 0 0 0
## [28,] 0 0 6 0 0 0
## [29,] 0 0 0 7 0 0
## [30,] 0 0 0 0 8 0
## [31,] 0 0 0 0 0 16
##
## $w_mean
## [,1]
## Income 4.186869
## Expenditure 3.350505
## HH_Size 3.832997
##
## $x_cov
## Income Expenditure HH_Size
## Income 0.8703337 0.6840776 -0.4882477
## Expenditure 0.6840776 0.5384541 -0.3843073
## HH_Size -0.4882477 -0.3843073 0.2926238
##
## $w_std
## Income Expenditure HH_Size
## 0.9329168 0.7337943 0.5409471Visualization
income <- X[, "Income"]
expenditure <- X[, "Expenditure"]
plot(income, expenditure,
main = "Income vs. Expenditure by Kecamatan",
xlab = "Monthly Income (Million IDR)",
ylab = "Monthly Expenditure (Million IDR)",
pch = 19, # Solid circle
col = adjustcolor("darkorange", alpha.f = 0.7),
cex = w / 8,
frame.plot = FALSE)
legend("topleft",
legend = "Larger dots = Higher Population Weight",
bty = "n",
text.col = "black")