概要
このノートブックでは、サプライチェーンリスク管理データを再解析します。
データは医療機器の生産受注を想定した合成データで、450件の受注レベル
観測値を含みます。
PLS-SEMモデルでは、以下の7つの潜在変数を設定します。
SCR_Risk: サプライチェーンリスクの露出度SCRM_Practices: リスク管理実践Trace_Info: トレーサビリティと情報品質Cost_Var: 単位コストの変動性NoQ_Cost: 非品質コストと不良関連指標Op_Perf: オペレーション成果Econ_Perf: 経済的成果
構造モデルでは、リスク露出度とSCRM実践がトレーサビリティ、コスト変動、
品質コスト、オペレーション成果、経済的成果に影響すると仮定します。
また、トレーサビリティを媒介変数として扱い、コスト・品質関連の成果が
最終的な業績に影響する構造を確認します。
パッケージ
rm(list = ls(all = TRUE))
library(lvsem)
library(ggplot2)
library(knitr)
データ読み込み
data_file <- "SCRM_Orders_Dataset_450.csv"
data_candidates <- c(
file.path("data003", data_file),
data_file,
file.path("..", "data003", data_file)
)
data_path <- data_candidates[file.exists(data_candidates)][1]
if (is.na(data_path)) {
stop("CSVファイルが見つかりません: ", data_file)
}
data_dir <- dirname(data_path)
raw_data <- read.csv(data_path, check.names = TRUE)
dim(raw_data)
## [1] 450 42
head(raw_data)
## order_id year month quarter supplier_id supplier_type transport_mode
## 1 ORDR-0001 2025 9 3 18 internacional aereo
## 2 ORDR-0002 2025 12 4 4 internacional terrestre
## 3 ORDR-0003 2024 11 4 18 internacional terrestre
## 4 ORDR-0004 2025 9 3 7 internacional terrestre
## 5 ORDR-0005 2024 4 2 7 nacional terrestre
## 6 ORDR-0006 2025 12 4 10 nacional terrestre
## product_complexity order_qty_units shock_event regulatory_intensity
## 1 1 175 0 0.046
## 2 3 109 0 0.125
## 3 1 101 0 0.049
## 4 3 211 0 0.084
## 5 1 252 0 0.647
## 6 2 286 0 0.349
## crit_dep_index supplier_delay_rate inbound_damage_rate storage_loss_rate
## 1 0.341 0.157 0.032 0.037
## 2 0.422 0.201 0.015 0.047
## 3 0.249 0.220 0.089 0.033
## 4 0.390 0.351 0.089 0.076
## 5 0.376 0.290 0.111 0.074
## 6 0.286 0.223 0.043 0.064
## process_rework_trigger_rate distribution_delay_rate stockout_rate
## 1 0.068 0.101 0.162
## 2 0.153 0.201 0.073
## 3 0.115 0.159 0.164
## 4 0.237 0.259 0.244
## 5 0.245 0.199 0.234
## 6 0.131 0.198 0.134
## supplier_audit_score monitoring_frequency_per_month
## 1 100 13
## 2 100 6
## 3 100 9
## 4 100 12
## 5 100 11
## 6 100 4
## contingency_maturity_likert collaboration_index traceability_completeness
## 1 4 0.811 0.939
## 2 3 0.681 0.626
## 3 4 0.568 0.382
## 4 4 0.318 0.318
## 5 3 0.711 0.324
## 6 4 0.236 0.319
## data_accuracy inspection_coverage unit_cost_cop unit_cost_sd_cop
## 1 0.920 0.920 93897 1000
## 2 0.471 0.339 206957 5665
## 3 0.281 0.233 85000 11463
## 4 0.305 0.273 234624 43506
## 5 0.695 0.784 131497 16139
## 6 0.669 0.485 134377 22862
## cost_var_metric no_quality_cost_cop scrap_rate rework_rate noq_metric
## 1 0.0100 0 0.0103 0.0282 0.0000
## 2 0.0274 10806 0.0000 0.0912 0.0591
## 3 0.1349 3715 0.0096 0.0575 0.0387
## 4 0.1854 27006 0.0562 0.1260 0.1298
## 5 0.1227 8077 0.0663 0.0926 0.0564
## 6 0.1701 0 0.0236 0.0506 0.0000
## margin_pct breakeven_units on_time_delivery cycle_time_hours
## 1 38.00 897 0.833 13.13
## 2 29.36 527 0.962 32.90
## 3 27.21 1200 0.874 8.15
## 4 14.83 920 0.730 28.75
## 5 31.30 777 0.763 13.61
## 6 26.79 889 0.791 21.69
## cycle_time_hours_inv nonconformity_rate RiskIndex SCRM_Practices TraceIndex
## 1 0.4179 2.68 0.2697 0.7183 0.9440
## 2 0.0188 0.33 0.3560 0.4316 0.4597
## 3 0.8244 6.12 0.4430 0.5499 0.2696
## 4 0.0571 6.96 0.7973 0.5313 0.2711
## 5 0.3947 12.10 0.7546 0.5503 0.6031
## 6 0.1559 10.98 0.4630 0.3300 0.4788
## cluster
## 1 4
## 2 1
## 3 1
## 4 3
## 5 2
## 6 1
モデル定義
minmax <- function(x) {
rng <- range(x, na.rm = TRUE)
if (!is.finite(rng[1]) || diff(rng) == 0) {
return(rep(0, length(x)))
}
(x - rng[1]) / diff(rng)
}
raw_data$breakeven_efficiency <- 1 - minmax(raw_data$breakeven_units)
blocks <- list(
SCR_Risk = c(
"supplier_delay_rate",
"inbound_damage_rate",
"storage_loss_rate",
"process_rework_trigger_rate",
"distribution_delay_rate",
"stockout_rate"
),
SCRM_Practices = c(
"supplier_audit_score",
"monitoring_frequency_per_month",
"contingency_maturity_likert",
"collaboration_index"
),
Trace_Info = c(
"traceability_completeness",
"data_accuracy",
"inspection_coverage"
),
Cost_Var = c(
"cost_var_metric",
"unit_cost_sd_cop"
),
NoQ_Cost = c(
"noq_metric",
"scrap_rate",
"rework_rate",
"nonconformity_rate"
),
Op_Perf = c(
"on_time_delivery",
"cycle_time_hours_inv"
),
Econ_Perf = c(
"margin_pct",
"breakeven_efficiency"
)
)
block_summary <- data.frame(
block = names(blocks),
item_count = vapply(blocks, length, integer(1))
)
kable(block_summary, caption = "測定ブロック")
測定ブロック
| SCR_Risk |
SCR_Risk |
6 |
| SCRM_Practices |
SCRM_Practices |
4 |
| Trace_Info |
Trace_Info |
3 |
| Cost_Var |
Cost_Var |
2 |
| NoQ_Cost |
NoQ_Cost |
4 |
| Op_Perf |
Op_Perf |
2 |
| Econ_Perf |
Econ_Perf |
2 |
latent_vars <- names(blocks)
path <- matrix(
0,
nrow = length(latent_vars),
ncol = length(latent_vars),
dimnames = list(latent_vars, latent_vars)
)
path["Trace_Info", c("SCR_Risk", "SCRM_Practices")] <- 1
path["Cost_Var", c("SCR_Risk", "SCRM_Practices", "Trace_Info")] <- 1
path["NoQ_Cost", c("SCR_Risk", "SCRM_Practices", "Trace_Info")] <- 1
path["Op_Perf", c("SCR_Risk", "SCRM_Practices", "Trace_Info", "Cost_Var", "NoQ_Cost")] <- 1
path["Econ_Perf", c("SCR_Risk", "SCRM_Practices", "Trace_Info", "Cost_Var", "NoQ_Cost", "Op_Perf")] <- 1
path
## SCR_Risk SCRM_Practices Trace_Info Cost_Var NoQ_Cost Op_Perf
## SCR_Risk 0 0 0 0 0 0
## SCRM_Practices 0 0 0 0 0 0
## Trace_Info 1 1 0 0 0 0
## Cost_Var 1 1 1 0 0 0
## NoQ_Cost 1 1 1 0 0 0
## Op_Perf 1 1 1 1 1 0
## Econ_Perf 1 1 1 1 1 1
## Econ_Perf
## SCR_Risk 0
## SCRM_Practices 0
## Trace_Info 0
## Cost_Var 0
## NoQ_Cost 0
## Op_Perf 0
## Econ_Perf 0
score_relation <- path + t(path)
score_relation
## SCR_Risk SCRM_Practices Trace_Info Cost_Var NoQ_Cost Op_Perf
## SCR_Risk 0 0 1 1 1 1
## SCRM_Practices 0 0 1 1 1 1
## Trace_Info 1 1 0 1 1 1
## Cost_Var 1 1 1 0 0 1
## NoQ_Cost 1 1 1 0 0 1
## Op_Perf 1 1 1 1 1 0
## Econ_Perf 1 1 1 1 1 1
## Econ_Perf
## SCR_Risk 1
## SCRM_Practices 1
## Trace_Info 1
## Cost_Var 1
## NoQ_Cost 1
## Op_Perf 1
## Econ_Perf 0
前処理
model_vars <- unique(unlist(blocks))
model_data <- raw_data[, model_vars, drop = FALSE]
model_data[] <- lapply(model_data, function(x) {
x <- as.numeric(as.character(x))
x[!is.finite(x)] <- NA_real_
x
})
too_constant <- vapply(model_data, function(x) {
observed <- x[!is.na(x)]
if (!length(observed)) {
return(TRUE)
}
stats::sd(observed) == 0 || max(table(observed)) / length(observed) >= 0.95
}, logical(1))
if (any(too_constant)) {
model_data <- model_data[, !too_constant, drop = FALSE]
blocks <- lapply(blocks, function(x) intersect(x, names(model_data)))
}
empty_blocks <- vapply(blocks, length, integer(1)) == 0
if (any(empty_blocks)) {
stop("前処理後に空になった測定ブロックがあります: ",
paste(names(blocks)[empty_blocks], collapse = ", "))
}
model_data[] <- lapply(model_data, function(x) {
ifelse(is.na(x), stats::median(x, na.rm = TRUE), x)
})
data.frame(
samples = nrow(model_data),
variables = ncol(model_data),
removed_constant_variables = sum(too_constant),
removed_variable_names = paste(names(too_constant)[too_constant], collapse = ", ")
)
## samples variables removed_constant_variables removed_variable_names
## 1 450 22 1 supplier_audit_score
潜在変数スコア
lv_scores <- make_lv_scores(model_data, blocks, score_relation)
head(lv_scores)
## SCR_Risk SCRM_Practices Trace_Info Cost_Var NoQ_Cost Op_Perf
## 1 -1.4787182 0.186639126 0.69391626 -0.687880803 -1.0625360 0.1396651
## 2 -1.0728984 -0.134687965 -0.23688248 -0.543675447 -0.6784427 0.2626310
## 3 -0.7108776 -0.049827657 -0.60696727 -0.022310113 -0.5371827 0.6925531
## 4 0.9152761 -0.132365916 -0.60552375 0.693232651 0.9256472 -0.6130851
## 5 0.7225212 -0.003695428 0.02745328 0.004140457 0.7812865 -0.1580423
## 6 -0.5880825 -0.362396321 -0.20600965 0.300905085 -0.3297714 -0.2779505
## Econ_Perf
## 1 0.57455553
## 2 0.24103099
## 3 -0.09904178
## 4 -0.66099808
## 5 0.25983109
## 6 -0.01679692
round(cor(lv_scores), 3)
## SCR_Risk SCRM_Practices Trace_Info Cost_Var NoQ_Cost Op_Perf
## SCR_Risk 1.000 -0.089 -0.111 0.696 0.822 -0.775
## SCRM_Practices -0.089 1.000 0.556 -0.265 -0.302 0.195
## Trace_Info -0.111 0.556 1.000 -0.466 -0.486 0.342
## Cost_Var 0.696 -0.265 -0.466 1.000 0.821 -0.756
## NoQ_Cost 0.822 -0.302 -0.486 0.821 1.000 -0.827
## Op_Perf -0.775 0.195 0.342 -0.756 -0.827 1.000
## Econ_Perf -0.521 0.465 0.635 -0.770 -0.778 0.630
## Econ_Perf
## SCR_Risk -0.521
## SCRM_Practices 0.465
## Trace_Info 0.635
## Cost_Var -0.770
## NoQ_Cost -0.778
## Op_Perf 0.630
## Econ_Perf 1.000
構造モデル
path_coefficients <- estimate_paths(lv_scores, path, scale_scores = FALSE)
path_effects <- effects_from_beta(path_coefficients)
path_coefficients
## path beta
## 1 SCR_Risk_to_Trace_Info -0.02936821
## 2 SCRM_Practices_to_Trace_Info 0.96856014
## 3 SCR_Risk_to_Cost_Var 0.28248861
## 4 SCRM_Practices_to_Cost_Var 0.02769148
## 5 Trace_Info_to_Cost_Var -0.37165989
## 6 SCR_Risk_to_NoQ_Cost 0.61375588
## 7 SCRM_Practices_to_NoQ_Cost -0.04800540
## 8 Trace_Info_to_NoQ_Cost -0.65779625
## 9 SCR_Risk_to_Op_Perf -0.13223527
## 10 SCRM_Practices_to_Op_Perf -0.04225107
## 11 Trace_Info_to_Op_Perf 0.02435557
## 12 Cost_Var_to_Op_Perf -0.22351924
## 13 NoQ_Cost_to_Op_Perf -0.23534124
## 14 SCR_Risk_to_Econ_Perf 0.06477441
## 15 SCRM_Practices_to_Econ_Perf 0.20579620
## 16 Trace_Info_to_Econ_Perf 0.13086033
## 17 Cost_Var_to_Econ_Perf -0.33663551
## 18 NoQ_Cost_to_Econ_Perf -0.24738297
## 19 Op_Perf_to_Econ_Perf -0.02465957
path_effects
## relationships direct indirect total
## 1 Cost_Var -> Econ_Perf -0.33663551 0.005511889 -0.33112362
## 2 Cost_Var -> Op_Perf -0.22351924 0.000000000 -0.22351924
## 3 NoQ_Cost -> Econ_Perf -0.24738297 0.005803414 -0.24157955
## 4 NoQ_Cost -> Op_Perf -0.23534124 0.000000000 -0.23534124
## 5 Op_Perf -> Econ_Perf -0.02465957 0.000000000 -0.02465957
## 6 SCR_Risk -> Cost_Var 0.28248861 0.010914985 0.29340359
## 7 SCR_Risk -> Econ_Perf 0.06477441 -0.250655265 -0.18588086
## 8 SCR_Risk -> NoQ_Cost 0.61375588 0.019318297 0.63307418
## 9 SCR_Risk -> Op_Perf -0.13223527 -0.215285085 -0.34752035
## 10 SCR_Risk -> Trace_Info -0.02936821 0.000000000 -0.02936821
## 11 SCRM_Practices -> Cost_Var 0.02769148 -0.359974951 -0.33228348
## 12 SCRM_Practices -> Econ_Perf 0.20579620 0.402744320 0.60854052
## 13 SCRM_Practices -> NoQ_Cost -0.04800540 -0.637115222 -0.68512062
## 14 SCRM_Practices -> Op_Perf -0.04225107 0.259098714 0.21684764
## 15 SCRM_Practices -> Trace_Info 0.96856014 0.000000000 0.96856014
## 16 Trace_Info -> Cost_Var -0.37165989 0.000000000 -0.37165989
## 17 Trace_Info -> Econ_Perf 0.13086033 0.281374891 0.41223522
## 18 Trace_Info -> NoQ_Cost -0.65779625 0.000000000 -0.65779625
## 19 Trace_Info -> Op_Perf 0.02435557 0.237879715 0.26223528
endogenous_vars <- rownames(path)[rowSums(path) > 0]
r2_values <- sapply(endogenous_vars, function(dv) {
preds <- names(which(path[dv, ] == 1))
fit <- lm(
as.formula(paste(dv, "~", paste(preds, collapse = " + "))),
data = as.data.frame(lv_scores)
)
summary(fit)$r.squared
})
kable(
data.frame(
construct = names(r2_values),
R2 = round(as.numeric(r2_values), 3)
),
caption = "内生潜在変数のR2"
)
内生潜在変数のR2
| Trace_Info |
0.313 |
| Cost_Var |
0.637 |
| NoQ_Cost |
0.833 |
| Op_Perf |
0.728 |
| Econ_Perf |
0.749 |
Bootstrap
set.seed(123)
boot_paths <- bootstrap_paths(
model_data,
blocks,
path,
br = 1000,
seed = 123,
score_matrix = score_relation
)
kable(
data.frame(
path = boot_paths$path,
round(boot_paths[, c("beta", "boot_se", "t_value")], 3)
),
caption = "Bootstrapによるパス推定"
)
Bootstrapによるパス推定
| SCR_Risk_to_Trace_Info |
-0.063 |
0.042 |
1.486 |
| SCRM_Practices_to_Trace_Info |
0.551 |
0.032 |
17.131 |
| SCR_Risk_to_Cost_Var |
0.652 |
0.024 |
26.822 |
| SCRM_Practices_to_Cost_Var |
0.017 |
0.033 |
0.513 |
| Trace_Info_to_Cost_Var |
-0.403 |
0.034 |
11.840 |
| SCR_Risk_to_NoQ_Cost |
0.777 |
0.019 |
40.618 |
| SCRM_Practices_to_NoQ_Cost |
-0.016 |
0.023 |
0.692 |
| Trace_Info_to_NoQ_Cost |
-0.391 |
0.025 |
15.576 |
| SCR_Risk_to_Op_Perf |
-0.291 |
0.053 |
5.526 |
| SCRM_Practices_to_Op_Perf |
-0.025 |
0.031 |
0.790 |
| Trace_Info_to_Op_Perf |
0.025 |
0.039 |
0.640 |
| Cost_Var_to_Op_Perf |
-0.213 |
0.040 |
5.325 |
| NoQ_Cost_to_Op_Perf |
-0.409 |
0.059 |
6.910 |
| SCR_Risk_to_Econ_Perf |
0.169 |
0.055 |
3.062 |
| SCRM_Practices_to_Econ_Perf |
0.143 |
0.030 |
4.814 |
| Trace_Info_to_Econ_Perf |
0.160 |
0.041 |
3.905 |
| Cost_Var_to_Econ_Perf |
-0.379 |
0.049 |
7.676 |
| NoQ_Cost_to_Econ_Perf |
-0.509 |
0.065 |
7.884 |
| Op_Perf_to_Econ_Perf |
-0.029 |
0.045 |
0.655 |
測定モデル
measures <- measurement_summary(model_data, blocks, lv_scores)
kable(
data.frame(
block = measures$reliability$block,
round(measures$reliability[, c("alpha", "composite_reliability", "ave")], 3)
),
caption = "信頼性とAVE"
)
信頼性とAVE
| SCR_Risk |
0.927 |
0.943 |
0.733 |
| SCRM_Practices |
0.822 |
0.889 |
0.727 |
| Trace_Info |
0.918 |
0.948 |
0.859 |
| Cost_Var |
0.908 |
0.956 |
0.915 |
| NoQ_Cost |
0.887 |
0.922 |
0.748 |
| Op_Perf |
0.609 |
0.831 |
0.713 |
| Econ_Perf |
0.599 |
0.787 |
0.661 |
kable(
data.frame(
block = measures$loadings$block,
item = measures$loadings$item,
loading = round(measures$loadings$loading, 3)
),
caption = "外部負荷量"
)
外部負荷量
| SCR_Risk |
supplier_delay_rate |
0.844 |
| SCR_Risk |
inbound_damage_rate |
0.885 |
| SCR_Risk |
storage_loss_rate |
0.876 |
| SCR_Risk |
process_rework_trigger_rate |
0.826 |
| SCR_Risk |
distribution_delay_rate |
0.860 |
| SCR_Risk |
stockout_rate |
0.847 |
| SCRM_Practices |
monitoring_frequency_per_month |
0.853 |
| SCRM_Practices |
contingency_maturity_likert |
0.807 |
| SCRM_Practices |
collaboration_index |
0.896 |
| Trace_Info |
traceability_completeness |
0.938 |
| Trace_Info |
data_accuracy |
0.938 |
| Trace_Info |
inspection_coverage |
0.905 |
| Cost_Var |
cost_var_metric |
0.963 |
| Cost_Var |
unit_cost_sd_cop |
0.950 |
| NoQ_Cost |
noq_metric |
0.847 |
| NoQ_Cost |
scrap_rate |
0.879 |
| NoQ_Cost |
rework_rate |
0.869 |
| NoQ_Cost |
nonconformity_rate |
0.863 |
| Op_Perf |
on_time_delivery |
0.906 |
| Op_Perf |
cycle_time_hours_inv |
0.778 |
| Econ_Perf |
margin_pct |
0.979 |
| Econ_Perf |
breakeven_efficiency |
0.604 |
モデル図
node_df <- data.frame(
block = c("SCR_Risk", "SCRM_Practices", "Trace_Info", "Cost_Var", "NoQ_Cost", "Op_Perf", "Econ_Perf"),
label = c(
"サプライチェーン\nリスク\n(SCR_Risk)",
"SCRM実践\n(SCRM_Practices)",
"トレーサビリティ\n情報品質\n(Trace_Info)",
"コスト変動\n(Cost_Var)",
"非品質コスト\n(NoQ_Cost)",
"オペレーション\n成果\n(Op_Perf)",
"経済的成果\n(Econ_Perf)"
),
x = c(0, 0, 2.0, 4.0, 4.0, 6.0, 8.0),
y = c(2.2, 0.8, 1.5, 2.25, 0.75, 1.5, 1.5),
stringsAsFactors = FALSE
)
edge_df <- path_coefficients
edge_split <- strsplit(edge_df$path, "_to_")
edge_df$from <- vapply(edge_split, `[`, character(1), 1)
edge_df$to <- vapply(edge_split, `[`, character(1), 2)
edge_df$label <- sprintf("beta = %.3f", edge_df$beta)
edge_df <- merge(
edge_df,
node_df[, c("block", "x", "y")],
by.x = "from",
by.y = "block"
)
names(edge_df)[names(edge_df) %in% c("x", "y")] <- c("x_from", "y_from")
edge_df <- merge(
edge_df,
node_df[, c("block", "x", "y")],
by.x = "to",
by.y = "block"
)
names(edge_df)[names(edge_df) %in% c("x", "y")] <- c("x_to", "y_to")
edge_df$x_label <- (edge_df$x_from + edge_df$x_to) / 2
edge_df$y_label <- (edge_df$y_from + edge_df$y_to) / 2
r2_df <- data.frame(
block = names(r2_values),
r2_label = sprintf("R2 = %.3f", as.numeric(r2_values)),
stringsAsFactors = FALSE
)
r2_df <- merge(r2_df, node_df[, c("block", "x", "y")], by = "block")
model_plot <- ggplot() +
geom_segment(
data = edge_df,
aes(x = x_from + 0.52, y = y_from, xend = x_to - 0.52, yend = y_to),
arrow = arrow(length = unit(0.20, "cm")),
linewidth = 0.65,
color = "#374151",
alpha = 0.85
) +
geom_label(
data = node_df,
aes(x = x, y = y, label = label),
size = 3.7,
fontface = "bold",
label.size = 0.35,
fill = "#ffffff",
color = "#111827"
) +
geom_label(
data = edge_df,
aes(x = x_label, y = y_label + 0.12, label = label),
size = 2.5,
label.size = 0,
fill = "#ffffff",
color = "#111827"
) +
geom_label(
data = r2_df,
aes(x = x, y = y - 0.48, label = r2_label),
size = 2.9,
label.size = 0.25,
fill = "#eef7f2",
color = "#111827"
) +
coord_cartesian(xlim = c(-0.9, 8.9), ylim = c(0.0, 3.0), clip = "off") +
theme_void() +
labs(title = "SCRM受注データのlvsemモデル")
model_plot
ggsave(file.path(data_dir, "data003_lvsem_scrm_model.png"),
model_plot, width = 12, height = 8, dpi = 180)
最終出力
cat("サンプルサイズ:", nrow(model_data), "\n")
## サンプルサイズ: 450
cat("除外した定数に近い変数:",
paste(names(too_constant)[too_constant], collapse = ", "), "\n")
## 除外した定数に近い変数: supplier_audit_score
print(round(r2_values, 3))
## Trace_Info Cost_Var NoQ_Cost Op_Perf Econ_Perf
## 0.313 0.637 0.833 0.728 0.749
参考情報
- Hernandez Palma, H. G. (2026). Supply Chain Risk Management and
Order-Based Costing: A Synthetic Industrial Dataset for Structural
Equation Modeling (PLS-SEM). Mendeley Data, V1. https://doi.org/10.17632/bh5y663jnd.1
- 使用パッケージ:
lvsem
- 使用データ:
SCRM_Orders_Dataset_450.csv