TopGear dataset
First, we analyze the TopGear dataset from the robustHD
package. We dplyr::select all numeric variables except the
verdict variable and use a logarithmic transformation for
five variables to obtain more symmetrical marginal distributions. We
robustly center and scale each column using the median and the MAD and
estimate the covariance using the MCD estimator.
data(TopGear)
rownames(TopGear) = paste(TopGear[,1],TopGear[,2])
myTopGear <- TopGear[,-31] #removing the verdict variable
myTopGear <- myTopGear[,sapply(myTopGear,function(x)any(is.numeric(x)))]
myTopGear <- myTopGear[!apply(myTopGear,1, function(x)any(is.na(x))),]
myTopGear <- myTopGear[,-2]
# Transform some variables to get roughly gaussianity in the center:
transTG = myTopGear
transTG$Price = log(myTopGear$Price)
transTG$Displacement = log(myTopGear$Displacement)
transTG$BHP = log(myTopGear$BHP)
transTG$Torque = log(myTopGear$Torque)
transTG$TopSpeed = log(myTopGear$TopSpeed)
transTG <- transTG %>% rename("log(Price)" = Price,
"log(Displacement)" = Displacement,
"log(BHP)" = BHP,
"log(Torque)" = Torque,
"log(TopSpeed)" = TopSpeed)
X <- as.matrix(transTG)
X <- robStandardize(X)
n <- nrow(X)
p <- ncol(X)
set.seed(1)
MCD <- covMcd(X, nsamp = "best")
#> Warning in .fastmcd(x, h, nsamp, nmini, kmini, trace = as.integer(trace)): 'nsamp = "best"' allows maximally 100000 subsets;
#> computing these subsets of size 12 out of 245
mu <-MCD$center
Sigma <- MCD$cov
Sigma_inv <- solve(MCD$cov)
phi <- shapley(x = X, mu = mu, Sigma = Sigma_inv, inverted = TRUE)$phi
colnames(phi) <- colnames(transTG)
rownames(phi) <- rownames(transTG)
md <- rowSums(phi)
chi2.q <- 0.99
crit <- sqrt(qchisq(chi2.q,p))Explaining multivariate outlyingness
In the following, we use the SCD and MOE
procedure to analyze the TopGear data. We focus on the six observations
with the highest Mahalanobis distance.
n_obs <- 6
TopGear_SCD <- SCD(x = X[names(sort(md, decreasing = TRUE)[1:n_obs]),], mu, Sigma, Sigma_inv, step_size = 0.1, min_deviation = 0.2)
plot(TopGear_SCD, type = "bar", md_squared = FALSE)
TopGear_MOE <- MOE(x = X[names(sort(md, decreasing = TRUE)[1:n_obs]),], mu, Sigma, Sigma_inv, step_size = 0.1, local = TRUE, min_deviation = 0.2)
plot(TopGear_MOE, type = "bar", md_squared = FALSE)
As a comparison, we use the cellHandler procedure from
the cellWise package and explain the results using Shapley
values.
X_sub <- X[names(sort(md, decreasing = TRUE)[1:n_obs]),]
X_sub_cH <- cellHandler(X_sub, mu = mu, Sigma = Sigma)$Ximp
explain_cH <- shapley(x = X_sub, mu = mu, Sigma = Sigma_inv, inverted = TRUE, cells = (X_sub != X_sub_cH))
plot(explain_cH, abbrev.var = FALSE, abbrev.obs = FALSE, md_squared = FALSE)
Analyzing cellwise outliers
We plot the outlying cells according to the SCD,
MOE, and cellHandler procedure.
TopGear_SCD_rescaled <- TopGear_SCD
TopGear_SCD_rescaled$x_original <- t(apply(TopGear_SCD_rescaled$x_original,1, function(x) x*attr(X, "scale") + attr(X, "center")))
TopGear_SCD_rescaled$x <- t(apply(TopGear_SCD_rescaled$x,1, function(x) x*attr(X, "scale") + attr(X, "center")))
plot(TopGear_SCD_rescaled, type = "cell") + coord_flip()
#> Coordinate system already present. Adding new coordinate system, which will
#> replace the existing one.
TopGear_MOE_rescaled <- TopGear_MOE
TopGear_MOE_rescaled$x_original <- t(apply(TopGear_MOE_rescaled$x_original,1, function(x) x*attr(X, "scale") + attr(X, "center")))
TopGear_MOE_rescaled$x <- t(apply(TopGear_MOE_rescaled$x,1, function(x) x*attr(X, "scale") + attr(X, "center")))
plot(TopGear_MOE_rescaled, type = "cell") + coord_flip()
#> Coordinate system already present. Adding new coordinate system, which will
#> replace the existing one.
plot(x = new_shapley_algorithm(x = t(apply(X_sub_cH,1, function(x) x*attr(X, "scale") + attr(X, "center"))),
phi = explain_cH$phi,
x_original = t(apply(X_sub,1, function(x) x*attr(X, "scale") + attr(X, "center")))),
type = "cell") + coord_flip()
#> Coordinate system already present. Adding new coordinate system, which will
#> replace the existing one.
Shapley interaction indices
Comparison of the pairwise outlyingness scores based on the Shapley interaction indices for two cars.
ind <- 3
interaction1 <- shapley_interaction(X[names(sort(md, decreasing = TRUE)[ind]),], TopGear_MOE$mu_tilde[ind,], Sigma)
interaction2 <- shapley_interaction(X[names(sort(md, decreasing = TRUE)[ind+1]),], TopGear_MOE$mu_tilde[ind+1,], Sigma)
dimnames(interaction1) <- list(c("Price", "Displ.", "BHP", "Torque", "Acc", "T.Speed", "MPG", "Weight", "Length", "Width", "Height"),
c("Price", "Displ.", "BHP", "Torque", "Acc", "T.Speed", "MPG", "Weight", "Length", "Width", "Height"))
dimnames(interaction2) <- dimnames(interaction1)
plot(interaction1, abbrev = FALSE, title = names(sort(md, decreasing = TRUE)[ind]))
## Analyzing cellwise outliers
## Iterations of 
