From 8bd70c3cb114a1f53e84f9def9772f66ae860946 Mon Sep 17 00:00:00 2001 From: iik1 Date: Tue, 14 Jul 2026 20:08:21 +0200 Subject: [PATCH] metafrontier v0.3.0 New features: - estimator = c('bc88', 'jlms'): Battese-Coelli (1988) conditional expectation as the new default efficiency estimator; both stored, switchable via efficiencies() without refitting. - objective = c('lp', 'qp'): both identification criteria for the deterministic metafrontier (QP solved exactly via quadprog with a constrOptim barrier fallback); the bootstrap forwards the choice. - engine = c('internal', 'sfaR', 'frontier', 'Benchmarking'): backend delegation for group frontiers; Benchmarking XREF/YREF drives the pooled DEA metafrontier. - malmquist_meta(id = ): explicit firm matching with strict checks; cross-period infeasibilities counted, warned, and reported; the SFA path documents and announces its pointwise-maximum approximation. - check_convergence() diagnostics; convergence blocks in print() and summary(); warning gaps closed in panel, QP, EM, and Malmquist paths. - DEA: rts = 'fdh', hyperbolic (graph) efficiency, user-supplied DDF direction vectors/matrices, two-stage slack analysis; permutation poolability test for DEA fits. - coef()/vcov()/summary() expose eta and variance parameters (extraPar, which = 'group'). - simulate_metafrontier(): beta_groups, input_means, input_corr; simulate_panel_metafrontier(): attrition; unbalanced BC92 panels fully supported. Bug fixes: - Panel TE row-order alignment; BC92 decay anchored at the global final period; cross-period DEA phi lower bound; frontier-class dispatch and converter idempotency; poolability data.name; autoplot CI lines and MPI trend axis; EM cleanup. Docs: vignettes rewritten and rebuilt, man pages expanded, likelihood derivation comments added. 650 tests passing; R CMD check clean. --- .Rbuildignore | 7 + DESCRIPTION | 26 +- NAMESPACE | 9 +- NEWS.md | 106 ++++ R/bootstrap.R | 30 +- R/diagnostics.R | 205 +++++++ R/efficiencies.R | 47 +- R/ggplot.R | 24 +- R/hypothesis_tests.R | 139 ++++- R/latent_class.R | 42 +- R/malmquist.R | 399 ++++++++++-- R/metafrontier.R | 444 +++++++++++--- R/metafrontier_dea.R | 540 ++++++++++++++-- R/metafrontier_sfa.R | 194 ++++-- R/methods.R | 260 +++++++- R/model_extractors.R | 98 ++- R/sfa_estimation.R | 56 +- R/sfa_panel.R | 131 +++- R/simulate.R | 251 ++++++-- R/tgr.R | 21 +- README.md | 20 +- cran-comments.md | 47 +- inst/doc/introduction.R | 32 + inst/doc/introduction.Rmd | 74 ++- inst/doc/introduction.html | 680 ++++++++++++--------- inst/doc/malmquist.R | 16 + inst/doc/malmquist.Rmd | 63 +- inst/doc/malmquist.html | 251 +++++--- inst/doc/methods.R | 26 + inst/doc/methods.Rmd | 79 ++- inst/doc/methods.html | 374 +++++++----- man/as_metafrontier_model.Rd | 27 +- man/check_convergence.Rd | 63 ++ man/coef.metafrontier.Rd | 42 ++ man/efficiencies.Rd | 13 +- man/latent_class_metafrontier.Rd | 6 + man/malmquist_meta.Rd | 104 +++- man/metafrontier-package.Rd | 2 +- man/metafrontier.Rd | 116 +++- man/poolability_test.Rd | 64 +- man/print.metafrontier.Rd | 6 +- man/select_n_classes.Rd | 17 +- man/simulate_metafrontier.Rd | 72 ++- man/simulate_panel_metafrontier.Rd | 20 +- man/summary.metafrontier.Rd | 38 +- man/technology_gap_ratio.Rd | 6 +- man/tgr_summary.Rd | 17 +- man/vcov.metafrontier.Rd | 37 +- tests/testthat/test-bc88.R | 88 +++ tests/testthat/test-dea-features.R | 371 +++++++++++ tests/testthat/test-diagnostics.R | 172 ++++++ tests/testthat/test-frontier-equivalence.R | 26 + tests/testthat/test-malmquist-id.R | 188 ++++++ tests/testthat/test-objective.R | 95 +++ tests/testthat/test-panel-fixes.R | 136 +++++ tests/testthat/test-plots-interop.R | 111 ++++ tests/testthat/test-poolability-dea.R | 110 ++++ tests/testthat/test-simulate-dgp.R | 147 +++++ vignettes/introduction.Rmd | 74 ++- vignettes/malmquist.Rmd | 63 +- vignettes/methods.Rmd | 79 ++- 61 files changed, 5912 insertions(+), 1089 deletions(-) create mode 100644 R/diagnostics.R create mode 100644 man/check_convergence.Rd create mode 100644 man/coef.metafrontier.Rd create mode 100644 tests/testthat/test-bc88.R create mode 100644 tests/testthat/test-dea-features.R create mode 100644 tests/testthat/test-diagnostics.R create mode 100644 tests/testthat/test-frontier-equivalence.R create mode 100644 tests/testthat/test-malmquist-id.R create mode 100644 tests/testthat/test-objective.R create mode 100644 tests/testthat/test-panel-fixes.R create mode 100644 tests/testthat/test-plots-interop.R create mode 100644 tests/testthat/test-poolability-dea.R create mode 100644 tests/testthat/test-simulate-dgp.R diff --git a/.Rbuildignore b/.Rbuildignore index a7b82dd..6e781e4 100644 --- a/.Rbuildignore +++ b/.Rbuildignore @@ -13,9 +13,16 @@ ^QA_ROUND2_EDITORIAL_REPORT\.md$ ^ROADMAP\.md$ ^mc_review_r10\.R$ +^mc_murphy_topel\.R$ +^review_malmquist_r14\.R$ ^reviewer2_dso_test\.R$ +^reviewer4_dea_test\.R$ +^reviewer8_test\.R$ ^test_edge_cases\.R$ ^test_panel_review\.R$ ^test_reviewer16_edgecases\.R$ ^test_reviewer9\.R$ ^test_steel_review\.R$ +^test_vignette\.R$ +^submit_cran2\.R$ +^metafrontier_0\.2\.1\.tar\.gz$ diff --git a/DESCRIPTION b/DESCRIPTION index a60655c..0eff1c4 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,25 +1,32 @@ Package: metafrontier Type: Package Title: Analysis of Metafrontier Models for Efficiency and Productivity -Version: 0.2.2 +Version: 0.3.0 Authors@R: c( person("Erik", "Enstad", email = "erik.enstad@nhh.no", role = c("aut", "cre"), comment = c(ORCID = "0009-0006-1053-3849"))) Description: Implements metafrontier production function models for - estimating technical efficiencies and technology gaps for firms - operating under different technologies. Supports both stochastic - frontier analysis (SFA) and data envelopment analysis (DEA) based + estimating technical efficiencies and technology gaps for groups of + firms that face different restrictions of a common underlying + metatechnology (group-specific technologies in the sense of Battese, + Rao, and O'Donnell, 2004). Supports both stochastic frontier + analysis (SFA) and data envelopment analysis (DEA) based metafrontiers. Includes the deterministic metafrontier of Battese, Rao, and O'Donnell (2004) , the stochastic metafrontier of Huang, Huang, and Liu (2014) , and the metafrontier Malmquist productivity index of O'Donnell, Rao, and Battese (2008) - . Additional features include - panel SFA with time-varying inefficiency, bootstrap confidence - intervals for technology gap ratios, latent class metafrontier - estimation via the EM algorithm, Murphy-Topel corrected standard - errors, and 'ggplot2' visualisation methods. + . The deterministic metafrontier can + be identified by either the minimum sum of absolute deviations (LP) + or the minimum sum of squared deviations (QP) criterion. Additional + features include panel SFA with time-varying inefficiency, bootstrap + confidence intervals for technology gap ratios, a DEA poolability + permutation test, latent class metafrontier estimation via the EM + algorithm, Murphy-Topel corrected standard errors, convergence + diagnostics, import of pre-fitted models from external estimation + engines ('sfaR', 'frontier', 'Benchmarking'), and 'ggplot2' + visualisation methods. License: GPL (>= 3) Encoding: UTF-8 RoxygenNote: 7.3.3 @@ -39,6 +46,7 @@ Suggests: sfaR, frontier, Benchmarking, + quadprog, plm, ggplot2, parallel diff --git a/NAMESPACE b/NAMESPACE index cc2ea1d..29821fd 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -2,9 +2,14 @@ S3method(as_metafrontier_model,Farrell) S3method(as_metafrontier_model,default) +S3method(as_metafrontier_model,frontier) S3method(as_metafrontier_model,list) -S3method(as_metafrontier_model,sfa) +S3method(as_metafrontier_model,metafrontier_model) S3method(as_metafrontier_model,sfacross) +S3method(check_convergence,default) +S3method(check_convergence,lc_metafrontier) +S3method(check_convergence,malmquist_meta) +S3method(check_convergence,metafrontier) S3method(coef,lc_metafrontier) S3method(coef,metafrontier) S3method(confint,boot_tgr) @@ -24,6 +29,7 @@ S3method(print,boot_tgr) S3method(print,lc_metafrontier) S3method(print,malmquist_meta) S3method(print,metafrontier) +S3method(print,metafrontier_convergence) S3method(print,summary.lc_metafrontier) S3method(print,summary.malmquist_meta) S3method(print,summary.metafrontier) @@ -34,6 +40,7 @@ S3method(summary,metafrontier) S3method(vcov,metafrontier) export(as_metafrontier_model) export(boot_tgr) +export(check_convergence) export(efficiencies) export(latent_class_metafrontier) export(malmquist_meta) diff --git a/NEWS.md b/NEWS.md index 8b0c2cc..7d413d4 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,3 +1,109 @@ +# metafrontier 0.3.0 + +## Breaking changes + +- The default technical efficiency estimator for SFA models is now the + Battese-Coelli (1988) conditional expectation `E[exp(-u)|eps]` + (`estimator = "bc88"`), which provides consistent efficiency + estimates. The previous JLMS estimator remains available via + `estimator = "jlms"`, and both are stored on every fit; + `efficiencies(fit, estimator = )` switches without refitting. + Deterministic and stochastic TGRs are unaffected (they do not depend + on the estimator), but TE and TE* values change slightly relative to + 0.2.x. +- `malmquist_meta()` output `id` column now carries the user-supplied + firm identifier (previously a within-group loop index). +- The `as_metafrontier_model()` method for `frontier::sfa()` fits is + now registered for the correct class `"frontier"`; the previous + registration (`"sfa"`) never dispatched. + +## Bug fixes + +- Panel SFA (BC92/BC95): fixed a row-alignment bug where + observation-level efficiencies were returned in internally sorted + (id, time) order but assigned back in input-row order, scrambling + `te_group`/`te_meta` whenever the input rows were not already in + string-sorted order. Coefficients, TGRs, and group means were + unaffected. Results are now row-order invariant (regression-tested). +- BC92 decay is now anchored at the panel-wide final period `T` + (previously the firm-specific last period), matching Battese and + Coelli's (1992) unbalanced formulation and the package's own + simulator. Balanced panels are numerically unchanged. +- Panel SFA now aligns the firm/time index with rows dropped by + `na.action`, and uses the same BFGS-to-Nelder-Mead fallback cascade + as the cross-sectional path. +- DEA: removed an erroneous lower bound (`phi >= 1`) in the + output-oriented LPs that made cross-period evaluation of + super-efficient DMUs infeasible even under CRS, silently biasing + Malmquist TC and MPI means. Cross-period scores with `phi < 1` now + solve correctly. +- `as_metafrontier_model()` is now idempotent (converting an already + converted object is a no-op), so the previously documented + pre-conversion workflow works. +- `poolability_test()` now derives `data.name` from the passed + expression instead of deparsing the stored call. +- `autoplot(boot)` (and the base `plot()` method) now actually draw + the dashed CI bound lines promised by the documentation. +- `autoplot(malm, which = "mpi_trend")` now plots each transition at + its end period (axis 2..T), consistent with the caption convention + "change relative to the previous period". +- Removed a redundant marginal likelihood computation in the latent + class EM loop. + +## New features + +- `estimator = c("bc88", "jlms")` on `metafrontier()` and + `malmquist_meta()` (see Breaking changes). +- `objective = c("lp", "qp")` on `metafrontier()`: both identification + criteria of Battese, Rao and O'Donnell (2004) for the deterministic + metafrontier. The default LP minimises the sum of absolute + deviations (O'Donnell, Rao and Battese, 2008, Eqs. 23-25); the QP + minimises the sum of squared deviations, solved exactly via + `quadprog` (new in Suggests) with a `constrOptim()` barrier + fallback. The bootstrap respects the choice. +- `engine = c("internal", "sfaR", "frontier", "Benchmarking")` on + `metafrontier()`: delegate group-frontier estimation to external + packages; `engine = "Benchmarking"` also delegates the pooled DEA + metafrontier via `XREF`/`YREF`. +- `check_convergence()`: new exported diagnostic reporting one row per + estimation stage (group frontiers and metafrontier). `print()` and + `summary()` methods now include convergence status; every stage + warns on non-zero optimiser codes. +- `malmquist_meta(id = )`: explicit firm matching across periods, with + errors on duplicated (id, period) pairs, warnings counting dropped + observations on unbalanced panels, and a message when falling back + to positional matching. Cross-period infeasible programmes (possible + under vrs/drs/irs/fdh) are now counted and reported in a + consolidated warning, stored as `n_infeasible`, and shown by + `print()`/`summary()`; the SFA path announces its pointwise-maximum + approximation in a message and in the documentation. +- Unbalanced panels are fully supported in BC92 (firm-specific period + sets), and `simulate_panel_metafrontier()` gains an `attrition` + argument for generating unbalanced test panels. +- DEA: `rts = "fdh"` (free disposable hull; exact enumeration for + radial measures, binary MIP for DDF), `type = "hyperbolic"` (graph + efficiency; closed form under CRS, bisection otherwise; always + feasible cross-period), user-supplied direction vectors or + firm-specific direction matrices for DDF (reported via the additive + `ddf_gap`), and `slack = TRUE` two-stage slack maximisation. +- `poolability_test()` now dispatches a permutation test for DEA fits + (group labels exchangeable under the pooled-technology null), with + `B` and `seed` arguments. +- `coef()`, `vcov()`, and `summary()` expose all estimated parameters: + `extraPar = TRUE` returns variance parameters (and `eta` for BC92) + with back-transformed values; `vcov(which = "group")` returns full + per-group covariance matrices; group summary tables now include the + variance parameters and `eta` with standard errors. +- `simulate_metafrontier()` gains `beta_groups` (group-specific slope + coefficients; the true TGR is then computed against the pointwise + maximum over group frontiers and varies within groups), + `input_means` (group-specific input distributions), and + `input_corr` (correlated log inputs). +- Latent class: the EM now records whether the best start met the + convergence tolerance (`em_converged`) and warns when it did not. + +--- + # metafrontier 0.2.2 ## Bug fixes diff --git a/R/bootstrap.R b/R/bootstrap.R index 1c12f63..80dbada 100644 --- a/R/bootstrap.R +++ b/R/bootstrap.R @@ -60,6 +60,10 @@ boot_tgr <- function(object, R = 999, stop("'object' must be a fitted metafrontier model.", call. = FALSE) } + # The parametric bootstrap draws new noise and inefficiency terms + # from the estimated error distributions, which requires a + # distributional model. DEA is nonparametric and provides no such + # model, so only case resampling is valid for DEA fits. if (type == "parametric" && object$method == "dea") { stop("Parametric bootstrap is not available for DEA metafrontiers. ", "Use type = 'nonparametric'.", call. = FALSE) @@ -190,10 +194,13 @@ boot_tgr <- function(object, R = 999, groups <- object$groups if (type == "parametric") { - # Parametric: resample residuals from estimated distributions + # Parametric: keep the design fixed and regenerate the response by + # drawing new noise (v) and inefficiency (u) terms from the fitted + # group-specific error distributions boot_data <- .parametric_resample(object) } else { - # Nonparametric: resample rows within groups + # Nonparametric: case resampling, i.e. resample whole rows with + # replacement within each group so group sizes are preserved boot_data <- .nonparametric_resample(data, group_vec, groups) } @@ -218,6 +225,19 @@ boot_tgr <- function(object, R = 999, !is.null(object$rts)) { object$rts } else "crs", + # Forward the estimation choices of the original fit so the + # bootstrap distribution reflects the reported point estimates. + type = if (!is.null(object$type)) object$type else "radial", + direction = if (!is.null(object$direction)) { + object$direction + } else "proportional", + estimator = if (!is.null(object$estimator)) { + object$estimator + } else "bc88", + objective = if (!is.null(object$objective)) { + object$objective + } else "lp", + engine = if (!is.null(object$engine)) object$engine else "internal", ... ) @@ -433,6 +453,12 @@ plot.boot_tgr <- function(x, which = c("distribution", "ci"), graphics::hist(group_means, main = paste("TGR:", g), xlab = "Mean TGR", col = "lightblue", border = "white") graphics::abline(v = mean(x$tgr_original[idx]), col = "red", lwd = 2) + # Dashed lines at the group-level CI bounds (columns 3:4 of + # ci_group; names are level-dependent, e.g. "2.5%"/"97.5%") + if (!is.null(x$ci_group)) { + bounds <- unlist(x$ci_group[x$ci_group$Group == g, 3:4]) + graphics::abline(v = bounds, col = "red", lwd = 1, lty = 2) + } } } else { # CI plot per group diff --git a/R/diagnostics.R b/R/diagnostics.R new file mode 100644 index 0000000..cde531d --- /dev/null +++ b/R/diagnostics.R @@ -0,0 +1,205 @@ +# Convergence diagnostics for metafrontier fits. + + +#' Internal: per-stage convergence table for a metafrontier object +#' +#' Builds one row per group-level stage plus one row for the +#' metafrontier stage. Shared by \code{check_convergence()}, +#' \code{summary.metafrontier()}, and \code{print.metafrontier()}. +#' +#' @param object a \code{"metafrontier"} object. +#' @return A data frame with columns \code{stage}, \code{method}, +#' \code{code}, \code{converged}, and \code{note}. +#' @keywords internal +#' @noRd +.convergence_table <- function(object) { + + groups <- object$groups + is_dea <- identical(object$method, "dea") + n_stages <- length(groups) + 1L + + stage <- character(n_stages) + method <- character(n_stages) + code <- integer(n_stages) + converged <- logical(n_stages) + note <- character(n_stages) + + .dea_note <- function(n_na) { + if (n_na > 0L) { + paste0(n_na, " infeasible DEA programs (NA efficiency)") + } else { + "" + } + } + + for (i in seq_along(groups)) { + g <- groups[i] + gm <- object$group_models[[g]] + stage[i] <- paste0("group: ", g) + + if (is_dea) { + n_na <- sum(is.na(object$te_group[object$group_vec == g])) + method[i] <- "DEA" + code[i] <- NA_integer_ + converged[i] <- n_na == 0L + note[i] <- .dea_note(n_na) + } else if (is.null(gm$convergence)) { + # Models-path import: the external fitter's convergence status + # is not carried through the extractors. + method[i] <- "external" + code[i] <- NA_integer_ + converged[i] <- NA + note[i] <- "fitted externally - convergence not tracked" + } else { + method[i] <- "MLE" + code[i] <- as.integer(gm$convergence) + converged[i] <- code[i] == 0L + note[i] <- "" + } + } + + j <- n_stages + stage[j] <- "metafrontier" + + if (is_dea) { + n_na <- sum(is.na(object$te_meta)) + method[j] <- "DEA" + code[j] <- NA_integer_ + converged[j] <- n_na == 0L + note[j] <- .dea_note(n_na) + } else { + if (identical(object$meta_type, "stochastic")) { + method[j] <- "MLE" + } else { + # Deterministic metafrontier: meta_solver records which solver + # produced the estimate; NULL on objects from older versions, + # where the LP was the only solver. + solver <- object$meta_solver + method[j] <- if (is.null(solver)) { + "LP" + } else { + switch(solver, + "lp" = "LP", + "qp" = "QP", + "qp-barrier" = "QP (barrier)", + solver) + } + } + code[j] <- if (is.null(object$meta_convergence)) { + NA_integer_ + } else { + as.integer(object$meta_convergence) + } + converged[j] <- if (is.na(code[j])) NA else code[j] == 0L + note[j] <- "" + } + + data.frame( + stage = stage, + method = method, + code = code, + converged = converged, + note = note, + stringsAsFactors = FALSE + ) +} + + +#' Check Convergence of All Estimation Stages +#' +#' Reports the convergence status of every estimation stage of a +#' fitted metafrontier model: each group-level frontier and the +#' metafrontier itself. This makes it easy to verify that all +#' optimisers (MLE) and mathematical programmes (LP/QP) finished +#' successfully before interpreting technology gap ratios, +#' confidence intervals, or efficiency decompositions. +#' +#' @param object a fitted model object. +#' @param ... additional arguments passed to methods. +#' +#' @return A data frame of class \code{"metafrontier_convergence"} +#' with one row per estimation stage and columns: +#' \describe{ +#' \item{stage}{stage label, e.g. \code{"group: G1"} or +#' \code{"metafrontier"}} +#' \item{method}{how the stage was estimated: \code{"MLE"}, +#' \code{"LP"}, \code{"QP"}, \code{"QP (barrier)"}, +#' \code{"DEA"}, or \code{"external"}} +#' \item{code}{the integer convergence code returned by the +#' optimiser (0 indicates success); \code{NA} for DEA stages +#' and externally fitted groups} +#' \item{converged}{logical convergence indicator; for DEA +#' stages \code{TRUE} unless any efficiency score is +#' \code{NA} (infeasible programme); \code{NA} for externally +#' fitted groups} +#' \item{note}{additional detail, e.g. the number of infeasible +#' DEA programmes} +#' } +#' +#' @details +#' For groups supplied via the \code{models} argument of +#' \code{\link{metafrontier}} the convergence status of the external +#' fitter is not tracked, and the corresponding rows carry +#' \code{NA} with an explanatory note. +#' +#' @examples +#' sim <- simulate_metafrontier(n_groups = 2, n_per_group = 50, seed = 42) +#' fit <- metafrontier(log_y ~ log_x1 + log_x2, data = sim$data, +#' group = "group") +#' check_convergence(fit) +#' +#' @export +check_convergence <- function(object, ...) { + UseMethod("check_convergence") +} + + +#' @rdname check_convergence +#' @export +check_convergence.metafrontier <- function(object, ...) { + tab <- .convergence_table(object) + class(tab) <- c("metafrontier_convergence", "data.frame") + tab +} + + +#' @rdname check_convergence +#' @export +check_convergence.lc_metafrontier <- function(object, ...) { + # The latent class fit embeds a full metafrontier object estimated + # on the MAP class allocation; report its stages (labelled by the + # latent classes LC1, LC2, ...). + check_convergence(object$metafrontier) +} + + +#' @rdname check_convergence +#' @export +check_convergence.malmquist_meta <- function(object, ...) { + stop("check_convergence() is not available for 'malmquist_meta' ", + "objects: the period-by-group frontier fits are not retained ", + "on the returned object.", call. = FALSE) +} + + +#' @export +check_convergence.default <- function(object, ...) { + stop("check_convergence() is not implemented for objects of class '", + paste(class(object), collapse = "', '"), + "'. It supports 'metafrontier' and 'lc_metafrontier' objects.", + call. = FALSE) +} + + +#' @export +print.metafrontier_convergence <- function(x, ...) { + cat("\nConvergence of estimation stages\n") + cat("--------------------------------\n") + print.data.frame(x, row.names = FALSE) + if (any(!x$converged, na.rm = TRUE)) { + cat("\nOne or more stages did not converge; interpret TGRs, ", + "confidence intervals,\nand decompositions with caution.\n", + sep = "") + } + invisible(x) +} diff --git a/R/efficiencies.R b/R/efficiencies.R index 8a089ce..bcac722 100644 --- a/R/efficiencies.R +++ b/R/efficiencies.R @@ -10,6 +10,16 @@ #' \code{"group"} for efficiency relative to the group frontier, #' \code{"meta"} (default) for efficiency relative to the #' metafrontier, or \code{"tgr"} for the technology gap ratio. +#' @param estimator optional character. Override the efficiency +#' estimator used at fit time: \code{"bc88"} for the Battese-Coelli +#' (1988) conditional expectation \eqn{E[\exp(-u)|\varepsilon]} or +#' \code{"jlms"} for \eqn{\exp(-E[u|\varepsilon])} (Jondrow et al., +#' 1982). Both are stored on SFA fits, so no refitting is needed; +#' \code{type = "meta"} is recomputed as \eqn{TE \times TGR}. The +#' TGR itself does not depend on the estimator. Ignored (with a +#' warning) for DEA fits and externally fitted group models that do +#' not carry both estimators. Default \code{NULL} returns the +#' scores selected at fit time. #' @param ... additional arguments (currently unused). #' #' @return A numeric vector of efficiency scores of length @@ -49,12 +59,43 @@ efficiencies <- function(object, ...) { #' @export efficiencies.metafrontier <- function(object, type = c("meta", "group", "tgr"), + estimator = NULL, ...) { type <- match.arg(type) + if (is.null(estimator)) { + return(switch(type, + meta = object$te_meta, + group = object$te_group, + tgr = object$tgr + )) + } + + estimator <- match.arg(estimator, c("bc88", "jlms")) + field <- paste0("efficiency_", estimator) + + # Rebuild group-level TE from the stored per-estimator vectors + te_group <- object$te_group + available <- TRUE + for (g in object$groups) { + gm <- object$group_models[[g]] + if (is.null(gm[[field]])) { + available <- FALSE + break + } + te_group[object$group_vec == g] <- gm[[field]] + } + + if (!available) { + warning("Estimator-specific efficiencies are not stored for all ", + "groups (DEA or externally fitted models); returning the ", + "scores selected at fit time.", call. = FALSE) + te_group <- object$te_group + } + switch(type, - meta = object$te_meta, - group = object$te_group, - tgr = object$tgr + group = te_group, + tgr = object$tgr, + meta = te_group * object$tgr ) } diff --git a/R/ggplot.R b/R/ggplot.R index c0ecdbd..92823f0 100644 --- a/R/ggplot.R +++ b/R/ggplot.R @@ -233,17 +233,20 @@ autoplot.malmquist_meta <- function(object, ggplot2::theme_minimal() } else { - mpi_mean <- aggregate(MPI ~ group + period_from, data = m, mean, + # Each MPI measures the change into period_to, so points sit at the + # end period of each transition (axis runs 2..T) + mpi_mean <- aggregate(MPI ~ group + period_to, data = m, mean, na.rm = TRUE) p <- ggplot2::ggplot(mpi_mean, - ggplot2::aes(x = .data$period_from, + ggplot2::aes(x = .data$period_to, y = .data$MPI, color = .data$group)) + ggplot2::geom_line(linewidth = 1) + ggplot2::geom_point(size = 2) + ggplot2::geom_hline(yintercept = 1, linetype = "dashed") + - ggplot2::labs(x = "Period", y = "Mean MPI", + ggplot2::labs(x = "Period (change from previous period)", + y = "Mean MPI", title = "MPI Trend", color = "Group") + ggplot2::theme_minimal() @@ -297,10 +300,25 @@ autoplot.boot_tgr <- function(object, } df <- do.call(rbind, frames) + # Per-group CI bounds (columns 3:4 of ci_group carry level-dependent + # names such as "2.5%" and "97.5%", so index by position) + ci <- object$ci_group + ci_long <- data.frame( + group = rep(ci$Group, 2), + bound = c(ci[[3]], ci[[4]]), + stringsAsFactors = FALSE + ) + ci_long <- ci_long[is.finite(ci_long$bound), , drop = FALSE] + p <- ggplot2::ggplot(df, ggplot2::aes(x = .data$mean_tgr, fill = .data$group)) + ggplot2::geom_histogram(bins = 30, alpha = 0.6, position = "identity") + + ggplot2::geom_vline( + data = ci_long, + ggplot2::aes(xintercept = .data$bound, colour = .data$group), + linetype = "dashed", show.legend = FALSE + ) + ggplot2::labs(x = "Bootstrap Mean TGR", y = "Count", title = "Bootstrap TGR Distribution", diff --git a/R/hypothesis_tests.R b/R/hypothesis_tests.R index b48f7d8..09e5b9c 100644 --- a/R/hypothesis_tests.R +++ b/R/hypothesis_tests.R @@ -2,23 +2,31 @@ #' #' Tests the null hypothesis that all groups share a common frontier #' (i.e., the metafrontier coincides with all group frontiers) against -#' the alternative that group-specific frontiers differ. Uses a -#' likelihood ratio test. +#' the alternative that group-specific frontiers differ. For SFA-based +#' metafrontiers a likelihood ratio test is used; for DEA-based +#' metafrontiers a permutation test is used. #' #' @param object a fitted \code{"metafrontier"} object with -#' \code{method = "sfa"}. +#' \code{method = "sfa"} or \code{method = "dea"}. +#' @param B integer. Number of permutation replicates for the DEA +#' permutation test (default 199). Ignored for SFA objects. +#' @param seed integer or \code{NULL}. Random seed for the DEA +#' permutation test, for reproducibility. Ignored for SFA objects. #' @param ... additional arguments (currently unused). #' #' @return A list of class \code{"htest"} with components: #' \describe{ -#' \item{statistic}{the LR test statistic} -#' \item{parameter}{degrees of freedom} +#' \item{statistic}{the test statistic (LR statistic for SFA; the +#' mean technology gap, \eqn{\bar{S} = \mathrm{mean}(1 - TGR)}, +#' for DEA)} +#' \item{parameter}{degrees of freedom (SFA) or the effective +#' number of permutation replicates (DEA)} #' \item{p.value}{p-value of the test} #' \item{method}{description of the test} #' } #' #' @details -#' The LR statistic is: +#' \strong{Likelihood ratio test (SFA).} The LR statistic is: #' \deqn{LR = -2 [LL_{pooled} - \sum_j LL_j]} #' where \eqn{LL_{pooled}} is the log-likelihood of the pooled (single #' frontier) model and \eqn{LL_j} are the group-specific @@ -31,7 +39,37 @@ #' distributional parameters, this equals #' \eqn{(J - 1) \times p_{total}} where \eqn{p_{total}} includes #' frontier coefficients, \eqn{\sigma_v}, and \eqn{\sigma_u} -#' (and \eqn{\mu} for truncated-normal). +#' (and \eqn{\mu} for truncated-normal). This test requires a +#' likelihood and is therefore only available for SFA-based +#' metafrontiers. +#' +#' \strong{Permutation test (DEA).} DEA has no likelihood, so the +#' poolability hypothesis is assessed by a permutation test. Under the +#' null of a single pooled technology, group labels are exchangeable: +#' reassigning observations to groups at random should not +#' systematically change the distance between the group frontiers and +#' the metafrontier. The observed statistic is the mean technology gap, +#' \eqn{S_{obs} = \mathrm{mean}(1 - TGR_i)}, and its null distribution +#' is approximated by refitting the metafrontier on \code{B} random +#' permutations of the group labels. The p-value is +#' \eqn{(1 + \#\{S_b \ge S_{obs}\}) / (B + 1)}, following the +#' aggregate-efficiency inference logic of Simar and Zelenyuk (2007). +#' The smoothed subsampling approach of Kneip, Simar, and Wilson (2016) +#' is the asymptotically rigorous alternative for testing hypotheses in +#' nonparametric production models; the permutation test offered here +#' is a computationally simple approximation. The default \code{B = 199} +#' is a pragmatic choice; p-values have resolution \eqn{1/(B + 1)}, so +#' increase \code{B} for finer resolution. +#' +#' @references +#' Simar, L. and Zelenyuk, V. (2007). Statistical inference for +#' aggregates of Farrell-type efficiencies. \emph{Journal of Applied +#' Econometrics}, 22(7), 1367--1394. \doi{10.1002/jae.991} +#' +#' Kneip, A., Simar, L. and Wilson, P.W. (2016). Testing hypotheses +#' in nonparametric models of production. \emph{Journal of Business & +#' Economic Statistics}, 34(3), 435--447. +#' \doi{10.1080/07350015.2015.1049747} #' #' @examples #' set.seed(42) @@ -41,10 +79,25 @@ #' data = sim$data, group = "group") #' poolability_test(fit) #' +#' \donttest{ +#' # DEA permutation test +#' fit_dea <- metafrontier(log_y ~ log_x1 + log_x2, +#' data = sim$data, group = "group", +#' method = "dea") +#' poolability_test(fit_dea, B = 99, seed = 1) +#' } +#' #' @export -poolability_test <- function(object, ...) { +poolability_test <- function(object, B = 199, seed = NULL, ...) { + data_name <- paste(deparse(substitute(object)), collapse = "") + + if (inherits(object, "metafrontier_dea")) { + return(.poolability_permutation_dea(object, B = B, seed = seed, + data_name = data_name)) + } + if (!inherits(object, "metafrontier_sfa")) { - stop("Poolability test requires an SFA-based metafrontier.", + stop("Poolability test requires an SFA- or DEA-based metafrontier.", call. = FALSE) } @@ -76,10 +129,76 @@ poolability_test <- function(object, ...) { parameter = c(df = df), p.value = p_value, method = "Likelihood Ratio Test for Poolability of Group Frontiers", - data.name = deparse(object$call), + data.name = data_name, ll_pooled = ll_pooled, ll_groups = ll_groups ) class(result) <- "htest" result } + + +#' Permutation test for poolability of DEA-based metafrontiers +#' @noRd +.poolability_permutation_dea <- function(object, B, seed, data_name) { + if (!is.null(seed)) set.seed(seed) + + s_obs <- mean(1 - object$tgr, na.rm = TRUE) + + # type/direction were not stored on objects fitted by older versions + type <- if (!is.null(object$type)) object$type else "radial" + direction <- if (!is.null(object$direction)) { + object$direction + } else { + "proportional" + } + + group_vec <- object$group_vec + s_perm <- rep(NA_real_, B) + + for (b in seq_len(B)) { + perm <- sample(group_vec) + fit_b <- tryCatch( + suppressWarnings( + metafrontier(formula = object$formula, + data = object$data, + group = perm, + method = "dea", + orientation = object$orientation, + rts = object$rts, + type = type, + direction = direction) + ), + error = function(e) NULL + ) + if (!is.null(fit_b)) { + s_perm[b] <- mean(1 - fit_b$tgr, na.rm = TRUE) + } + } + + n_fail <- sum(is.na(s_perm)) + if (n_fail > 0.1 * B) { + warning(n_fail, " of ", B, " permutation refits failed; the ", + "p-value is based on the ", B - n_fail, + " successful replicates only.", call. = FALSE) + } + + s_perm <- s_perm[!is.na(s_perm)] + b_eff <- length(s_perm) + if (b_eff == 0L) { + stop("All permutation refits failed; cannot compute a p-value.", + call. = FALSE) + } + + p_value <- (1 + sum(s_perm >= s_obs)) / (b_eff + 1) + + result <- list( + statistic = c(`mean technology gap` = s_obs), + parameter = c(B = b_eff), + p.value = p_value, + method = "Permutation test for poolability of group frontiers (DEA)", + data.name = data_name + ) + class(result) <- "htest" + result +} diff --git a/R/latent_class.R b/R/latent_class.R index 28bea82..ea7f1a3 100644 --- a/R/latent_class.R +++ b/R/latent_class.R @@ -5,6 +5,11 @@ #' probabilities, class-specific frontier parameters, and the #' metafrontier. #' +#' Latent class estimation is available for SFA-based metafrontiers +#' only: the EM posterior class probabilities require a parametric +#' observation-level likelihood, which DEA does not provide. For DEA +#' fits with observed groups, see \code{\link{poolability_test}}. +#' #' @param formula a \code{Formula} object (y ~ x1 + x2). #' @param data a data frame. #' @param n_classes integer. Number of latent classes (default 2). @@ -145,6 +150,13 @@ latent_class_metafrontier <- function(formula, data, n_total_params <- n_classes * n_params_class + (n_classes - 1) bic <- -2 * best_ll + n_total_params * log(n) + if (isFALSE(best_result$converged)) { + warning("The best EM start reached max_iter = ", max_iter, + " without meeting the convergence tolerance; results may ", + "not be at a local optimum. Consider increasing 'max_iter' ", + "or 'n_starts'.", call. = FALSE) + } + out <- list( class_assignment = class_names[class_assign_sorted], posterior = best_result$posterior[, class_order], @@ -155,6 +167,7 @@ latent_class_metafrontier <- function(formula, data, BIC = bic, n_classes = n_classes, n_iter = best_result$n_iter, + em_converged = isTRUE(best_result$converged), n = n ) class(out) <- "lc_metafrontier" @@ -164,20 +177,25 @@ latent_class_metafrontier <- function(formula, data, #' Select Number of Latent Classes via BIC #' +#' Fits a latent class metafrontier model for each value in +#' \code{n_classes_range} and tabulates the Bayesian information +#' criterion (BIC) and marginal log-likelihood of each fit. The +#' optimal number of classes minimises BIC. Fits that fail are +#' silently dropped from the table. Because the EM algorithm can +#' converge to local optima, the ranking is sensitive to the number +#' of random starts: pass \code{n_starts} (forwarded to +#' \code{\link{latent_class_metafrontier}}) and increase it for a +#' more reliable comparison across class counts. +#' #' @param formula formula. #' @param data data frame. #' @param n_classes_range integer vector of class counts to try. #' @param ... additional arguments passed to -#' \code{\link{latent_class_metafrontier}}. +#' \code{\link{latent_class_metafrontier}}, notably \code{n_starts}. #' #' @return A data frame with columns \code{n_classes}, \code{BIC}, #' and \code{marginal_ll}. #' -#' @details -#' Fits latent class metafrontier models for each value in -#' \code{n_classes_range} and returns BIC values. The optimal -#' number of classes minimises BIC. -#' #' @examples #' \donttest{ #' sim <- simulate_metafrontier(n_groups = 2, n_per_group = 80, seed = 42) @@ -265,6 +283,7 @@ select_n_classes <- function(formula, data, } prev_ll <- -Inf + em_converged <- FALSE ctrl <- list(fnscale = -1, maxit = 50, reltol = 1e-8) ctrl[names(control)] <- control @@ -283,15 +302,13 @@ select_n_classes <- function(formula, data, tau <- exp(log_tau) tau <- tau / rowSums(tau) - # Marginal LL + # Marginal LL: sum_i log(sum_c pi_c * L_c(y_i)), computed on the + # max-shifted scale for numerical stability marginal_ll <- sum(log_tau_max + log(rowSums(exp(log_tau)))) - # Correction: we already subtracted max, so add it back - # Actually: marginal_ll = sum(log(sum_c pi_c * L_c(y_i))) - log_lik_mix <- log_tau_max + log(rowSums(exp(log_tau))) - marginal_ll <- sum(log_lik_mix) # Convergence check if (iter > 1 && abs(marginal_ll - prev_ll) < tol * abs(prev_ll)) { + em_converged <- TRUE break } prev_ll <- marginal_ll @@ -326,7 +343,8 @@ select_n_classes <- function(formula, data, pi = pi_c, class_params = class_params, marginal_ll = marginal_ll, - n_iter = iter + n_iter = iter, + converged = em_converged ) } diff --git a/R/malmquist.R b/R/malmquist.R index 34f4b52..5317f4f 100644 --- a/R/malmquist.R +++ b/R/malmquist.R @@ -17,17 +17,30 @@ #' @param time a character string naming the column in \code{data} #' that identifies time periods, or a vector of time indicators. #' Periods must be consecutive integers or sortable. +#' @param id optional. A character string naming the column in +#' \code{data} that identifies firms across periods, or a vector +#' of firm identifiers. When supplied, firms are matched across +#' consecutive periods by identifier within each group. When +#' \code{NULL} (default), firms are matched by row position within +#' each group, which is valid only for balanced panels sorted +#' identically in every period (see Details). #' @param method character. \code{"dea"} (default) for DEA-based #' distance functions or \code{"sfa"} for SFA-based parametric -#' distance functions. +#' distance functions (an approximation; see Details). #' @param dist character. Distribution of the inefficiency term #' when \code{method = "sfa"}: \code{"hnormal"} (default), #' \code{"tnormal"}, or \code{"exponential"}. +#' @param estimator character. Technical efficiency estimator used +#' when \code{method = "sfa"}: \code{"bc88"} (default) for the +#' Battese and Coelli (1988) estimator +#' \eqn{E[\exp(-u)|\varepsilon]}, or \code{"jlms"} for the Jondrow +#' et al. (1982) estimator \eqn{\exp(-E[u|\varepsilon])}. Passed to +#' the group SFA fitter. #' @param orientation character. \code{"output"} (default) or #' \code{"input"}. #' @param rts character. Returns to scale assumption: -#' \code{"crs"} (default), \code{"vrs"}, \code{"drs"}, or -#' \code{"irs"}. +#' \code{"crs"} (default), \code{"vrs"}, \code{"drs"}, +#' \code{"irs"}, or \code{"fdh"}. #' @param control a list of control parameters for the SFA optimiser. #' @param ... additional arguments (currently unused). #' @@ -39,7 +52,9 @@ #' \code{MPI} (metafrontier Malmquist TFP index), #' \code{TEC} (technical efficiency change), #' \code{TGC} (technology gap change), -#' \code{TC} (metafrontier technical change)} +#' \code{TC} (metafrontier technical change). The \code{id} +#' column holds the supplied firm identifiers when \code{id} +#' is given, and the within-group match position otherwise.} #' \item{group_malmquist}{data frame with the within-group #' Malmquist index decomposition: \code{MPI_group}, #' \code{EC_group}, \code{TC_group}} @@ -53,10 +68,17 @@ #' end period), and \code{TGC} (technology gap change, #' \code{TGR_to / TGR_from})} #' \item{call}{the matched function call} +#' \item{method}{the estimation method used (\code{"dea"} or +#' \code{"sfa"})} #' \item{orientation}{the orientation used} #' \item{rts}{the returns to scale assumption} #' \item{groups}{group labels} #' \item{periods}{time periods} +#' \item{n_infeasible}{total number of infeasible cross-period +#' DEA programs (always \code{0} for \code{method = "sfa"})} +#' \item{infeasible_by_period}{data frame with the number of +#' infeasible cross-period DEA programs per period pair +#' (\code{method = "dea"} only)} #' } #' #' @details @@ -76,18 +98,54 @@ #' the shift of the global production possibility frontier #' } #' -#' Computation uses DEA-based distance functions. For each +#' \strong{Firm matching:} when \code{id} is supplied, firms are +#' matched across consecutive periods by identifier within each +#' technology group. Duplicated (id, period) combinations within a +#' group are an error. Observations without a within-group match in +#' the adjacent period, either because the panel is unbalanced or +#' because a firm switches group between periods, are dropped, and a +#' single consolidated warning reports the number dropped per period +#' pair. When \code{id} is \code{NULL}, firms are matched by row +#' position within each group; this is valid only for balanced +#' panels sorted identically in every period, so a message is +#' emitted as a reminder, and a warning is issued when group sizes +#' differ across a period pair (the unmatched observations are +#' dropped). Supplying \code{id} is recommended. +#' +#' \strong{DEA-based computation (\code{method = "dea"}):} for each #' consecutive pair of periods \eqn{(s, t)}, eight sets of LP -#' problems are solved: within-group and pooled efficiencies at -#' each period, plus cross-period evaluations for the geometric -#' mean formulation of technical change. +#' problems are solved: within-group and pooled efficiencies at each +#' period, plus cross-period evaluations for the geometric mean +#' formulation of technical change. Distances to the metafrontier +#' are exact distances to the pooled-data frontier, as in O'Donnell, +#' Rao and Battese (2008). +#' +#' \strong{SFA-based computation is an approximation +#' (\code{method = "sfa"}):} period-specific group SFA frontiers are +#' estimated, and each observation's metafrontier distance is +#' approximated by the pointwise maximum of the estimated group +#' frontier functions evaluated at its inputs; no enveloping +#' metafrontier is re-estimated. This coincides with the O'Donnell +#' et al. (2008) metafrontier wherever a single group frontier +#' dominates, but can understate the metafrontier where group +#' frontiers cross, which affects TGC and TC*. Prefer +#' \code{method = "dea"} when an exact decomposition is required. #' -#' \strong{Balanced panel assumption:} Firms are matched across -#' periods by position within each group. The data should contain -#' a balanced panel (the same firms observed in every period) with -#' consistent ordering. If group sizes differ across periods, -#' only the first \code{min(n_s, n_t)} firms per group are paired -#' and unmatched observations are silently dropped. +#' \strong{Infeasible cross-period programs:} under +#' \code{rts = "vrs"}, \code{"drs"}, \code{"irs"}, or \code{"fdh"}, +#' cross-period LPs can be genuinely infeasible because the +#' reference technology cannot reach the evaluated observation. Such +#' cases yield \code{NA} (never \code{Inf}), are excluded from the +#' reported means, and are counted in a single consolidated warning; +#' the counts are stored in the \code{n_infeasible} and +#' \code{infeasible_by_period} components. \code{rts = "crs"} avoids +#' the issue, as does the hyperbolic orientation available in +#' \code{\link{metafrontier}}. +#' +#' Note that the standard Malmquist index is not a \sQuote{proper} +#' (multiplicatively complete and transitive) TFP index in the sense +#' of O'Donnell (2012), so chained comparisons of index levels +#' across more than two periods should be avoided. #' #' @references #' O'Donnell, C.J., Rao, D.S.P. and Battese, G.E. (2008). @@ -95,6 +153,11 @@ #' and technology ratios. \emph{Empirical Economics}, 34(2), #' 231--255. \doi{10.1007/s00181-007-0119-4} #' +#' O'Donnell, C.J. (2012). An aggregate quantity framework for +#' measuring and decomposing productivity change. +#' \emph{Journal of Productivity Analysis}, 38(3), 255--272. +#' \doi{10.1007/s11123-012-0275-1} +#' #' @examples #' # Simulate panel data for 2 groups, 3 time periods #' set.seed(42) @@ -111,12 +174,13 @@ #' }) #' panel_data <- do.call(rbind, panels) #' -#' # Compute metafrontier Malmquist index +#' # Compute metafrontier Malmquist index, matching firms by id #' malm <- malmquist_meta( #' log_y ~ log_x1 + log_x2, #' data = panel_data, #' group = "group", -#' time = "time" +#' time = "time", +#' id = "id" #' ) #' summary(malm) #' @@ -125,16 +189,19 @@ malmquist_meta <- function(formula = NULL, data = NULL, group = NULL, time = NULL, + id = NULL, method = c("dea", "sfa"), dist = c("hnormal", "tnormal", "exponential"), + estimator = c("bc88", "jlms"), orientation = c("output", "input"), - rts = c("crs", "vrs", "drs", "irs"), + rts = c("crs", "vrs", "drs", "irs", "fdh"), control = list(), ...) { cl <- match.call() method <- match.arg(method) dist <- match.arg(dist) + estimator <- match.arg(estimator) orientation <- match.arg(orientation) rts <- match.arg(rts) @@ -166,6 +233,22 @@ malmquist_meta <- function(formula = NULL, time_vec <- time } + # Parse id variable + if (is.null(id)) { + id_vec <- NULL + } else if (is.character(id) && length(id) == 1L) { + if (!id %in% names(data)) { + stop("Column '", id, "' not found in data.", call. = FALSE) + } + id_vec <- data[[id]] + } else { + id_vec <- id + } + if (!is.null(id_vec) && length(id_vec) != nrow(data)) { + stop("'id' must supply one identifier per row of 'data'.", + call. = FALSE) + } + group_levels <- levels(group_vec) time_levels <- sort(unique(time_vec)) @@ -176,13 +259,36 @@ malmquist_meta <- function(formula = NULL, stop("At least 2 time periods are required.", call. = FALSE) } + if (!is.null(id_vec)) { + for (g in group_levels) { + for (tt in time_levels) { + ids_gt <- id_vec[group_vec == g & time_vec == tt] + if (anyDuplicated(ids_gt)) { + dup <- unique(ids_gt[duplicated(ids_gt)]) + stop("Duplicated (id, period) combinations in group '", g, + "' at period ", tt, ": ", + paste(dup, collapse = ", "), ".", call. = FALSE) + } + } + } + } else { + message("No 'id' supplied: firms are matched by row position ", + "within each group, which is valid only for balanced ", + "panels sorted identically in every period. Supply 'id' ", + "to match firms explicitly.") + } + # Parse formula f <- Formula::Formula(formula) # --- SFA Malmquist path --- if (method == "sfa") { + message("Note: method = 'sfa' approximates metafrontier distances ", + "by the pointwise maximum over estimated group frontiers; ", + "see ?malmquist_meta for details.") result <- .malmquist_sfa(f, data, group_vec, group_levels, - time_vec, time_levels, dist, control) + time_vec, time_levels, dist, control, + id_vec = id_vec, estimator = estimator) result$call <- cl result$orientation <- orientation result$rts <- rts @@ -214,6 +320,14 @@ malmquist_meta <- function(formula = NULL, results <- vector("list", n_periods * n_groups * max_obs_per_group) result_idx <- 0L + # Per-period-pair accounting for consolidated warnings + pair_from <- time_levels[seq_len(n_periods)] + pair_to <- time_levels[seq_len(n_periods) + 1L] + infeas_by_pair <- integer(n_periods) + nprog_by_pair <- integer(n_periods) + dropped_by_pair <- integer(n_periods) + n_skipped <- 0L + for (tp in seq_len(length(time_levels) - 1L)) { t_s <- time_levels[tp] t_t <- time_levels[tp + 1L] @@ -229,6 +343,9 @@ malmquist_meta <- function(formula = NULL, grp_s <- group_vec[idx_s] grp_t <- group_vec[idx_t] + ids_s <- if (!is.null(id_vec)) id_vec[idx_s] else NULL + ids_t <- if (!is.null(id_vec)) id_vec[idx_t] else NULL + n_s <- length(idx_s) n_t <- length(idx_t) @@ -254,52 +371,80 @@ malmquist_meta <- function(formula = NULL, Y_gt <- Y_t[idx_gt, , drop = FALSE] # D_j^s(x_s, y_s) — same-period group efficiency - d_grp_ss[idx_gs] <- .dea_batch_fast( - X_gs, Y_gs, orientation, rts) + d_grp_ss[idx_gs] <- .muffle_lp_warnings(.dea_batch_fast( + X_gs, Y_gs, orientation, rts)) # D_j^t(x_t, y_t) — same-period group efficiency - d_grp_tt[idx_gt] <- .dea_batch_fast( - X_gt, Y_gt, orientation, rts) + d_grp_tt[idx_gt] <- .muffle_lp_warnings(.dea_batch_fast( + X_gt, Y_gt, orientation, rts)) # D_j^s(x_t, y_t) — cross-period: period-t obs against period-s group tech - d_grp_st[idx_gt] <- suppressWarnings(.dea_batch_fast( + d_grp_st[idx_gt] <- .muffle_lp_warnings(.dea_batch_fast( X_gt, Y_gt, orientation, rts, X_ref = X_gs, Y_ref = Y_gs)) # D_j^t(x_s, y_s) — cross-period: period-s obs against period-t group tech - d_grp_ts[idx_gs] <- suppressWarnings(.dea_batch_fast( + d_grp_ts[idx_gs] <- .muffle_lp_warnings(.dea_batch_fast( X_gs, Y_gs, orientation, rts, X_ref = X_gt, Y_ref = Y_gt)) + + nprog_by_pair[tp] <- nprog_by_pair[tp] + + length(idx_gt) + length(idx_gs) + infeas_by_pair[tp] <- infeas_by_pair[tp] + + sum(is.na(d_grp_st[idx_gt])) + sum(is.na(d_grp_ts[idx_gs])) } - # Metafrontier (pooled) DEA scores - # Suppress LP infeasibility warnings from cross-period evaluations - # (expected when reference technology cannot envelop all eval DMUs) - d_meta_ss <- suppressWarnings( + # Metafrontier (pooled) DEA scores. Infeasible cross-period LPs + # yield NA; they are counted here and reported once per call. + d_meta_ss <- .muffle_lp_warnings( .dea_batch(X_s, Y_s, X_s, Y_s, orientation, rts)) - d_meta_tt <- suppressWarnings( + d_meta_tt <- .muffle_lp_warnings( .dea_batch(X_t, Y_t, X_t, Y_t, orientation, rts)) - d_meta_st <- suppressWarnings( + d_meta_st <- .muffle_lp_warnings( .dea_batch(X_t, Y_t, X_s, Y_s, orientation, rts)) - d_meta_ts <- suppressWarnings( + d_meta_ts <- .muffle_lp_warnings( .dea_batch(X_s, Y_s, X_t, Y_t, orientation, rts)) + nprog_by_pair[tp] <- nprog_by_pair[tp] + n_t + n_s + infeas_by_pair[tp] <- infeas_by_pair[tp] + + sum(is.na(d_meta_st)) + sum(is.na(d_meta_ts)) + # --- Identify matched firms across periods --- - # We need firms present in both periods. Match by group. for (g in group_levels) { idx_gs <- which(grp_s == g) idx_gt <- which(grp_t == g) - n_pairs <- min(length(idx_gs), length(idx_gt)) - if (n_pairs == 0) next + if (!is.null(id_vec)) { + ids_gs <- ids_s[idx_gs] + ids_gt <- ids_t[idx_gt] + common <- intersect(ids_gs, ids_gt) + dropped_by_pair[tp] <- dropped_by_pair[tp] + + (length(ids_gs) - length(common)) + + (length(ids_gt) - length(common)) + pos_s <- idx_gs[match(common, ids_gs)] + pos_t <- idx_gt[match(common, ids_gt)] + out_ids <- common + } else { + n_matched <- min(length(idx_gs), length(idx_gt)) + dropped_by_pair[tp] <- dropped_by_pair[tp] + + abs(length(idx_gs) - length(idx_gt)) + pos_s <- idx_gs[seq_len(n_matched)] + pos_t <- idx_gt[seq_len(n_matched)] + out_ids <- seq_len(n_matched) + } + + if (length(pos_s) == 0L) next - for (i in seq_len(n_pairs)) { - is <- idx_gs[i] - it <- idx_gt[i] + for (i in seq_along(pos_s)) { + is <- pos_s[i] + it <- pos_t[i] # Guard against zero/NA if (is.na(d_grp_ss[is]) || is.na(d_grp_tt[it]) || - d_grp_ss[is] <= 0 || d_grp_tt[it] <= 0) next + d_grp_ss[is] <= 0 || d_grp_tt[it] <= 0) { + n_skipped <- n_skipped + 1L + next + } # -- Within-group Malmquist -- ec_grp <- d_grp_tt[it] / d_grp_ss[is] @@ -350,7 +495,7 @@ malmquist_meta <- function(formula = NULL, result_idx <- result_idx + 1L results[[result_idx]] <- data.frame( - id = i, + id = out_ids[i], group = g, period_from = t_s, period_to = t_t, @@ -381,6 +526,25 @@ malmquist_meta <- function(formula = NULL, call. = FALSE) } + .warn_dropped(dropped_by_pair, pair_from, pair_to, is.null(id_vec)) + + total_infeasible <- sum(infeas_by_pair) + if (total_infeasible > 0L || n_skipped > 0L) { + msg <- character(0) + if (total_infeasible > 0L) { + msg <- paste0(total_infeasible, " of ", sum(nprog_by_pair), + " cross-period DEA programs were infeasible (rts = \"", + rts, "\"); the affected TC and MPI values are NA and ", + "are excluded from reported means.") + } + if (n_skipped > 0L) { + msg <- c(msg, paste0(n_skipped, " matched observation(s) were ", + "skipped because of missing or non-positive ", + "same-period distance scores.")) + } + warning(paste(msg, collapse = " "), call. = FALSE) + } + malmquist_df <- do.call(rbind, results[seq_len(result_idx)]) rownames(malmquist_df) <- NULL @@ -398,10 +562,19 @@ malmquist_meta <- function(formula = NULL, "period_to", "TGR_from", "TGR_to", "TGC")], call = cl, + method = method, orientation = orientation, rts = rts, groups = group_levels, - periods = time_levels + periods = time_levels, + n_infeasible = total_infeasible, + infeasible_by_period = data.frame( + period_from = pair_from, + period_to = pair_to, + n_infeasible = infeas_by_pair, + n_programs = nprog_by_pair, + stringsAsFactors = FALSE + ) ) class(out) <- "malmquist_meta" out @@ -423,10 +596,55 @@ malmquist_meta <- function(formula = NULL, } +#' Muffle per-DMU LP infeasibility warnings +#' +#' Infeasible programs return NA scores; they are counted by the +#' caller and reported in one consolidated warning per call instead +#' of one warning per DMU. Other warnings pass through untouched. +#' +#' @keywords internal +#' @noRd +.muffle_lp_warnings <- function(expr) { + withCallingHandlers(expr, warning = function(w) { + if (grepl("LP infeasible|No dominating FDH reference point", + conditionMessage(w))) { + invokeRestart("muffleWarning") + } + }) +} + + +#' Consolidated warning for observations dropped during matching +#' +#' @keywords internal +#' @noRd +.warn_dropped <- function(dropped_by_pair, pair_from, pair_to, + positional) { + total_dropped <- sum(dropped_by_pair) + if (total_dropped == 0L) return(invisible(NULL)) + nz <- dropped_by_pair > 0L + detail <- paste0(dropped_by_pair[nz], " in ", pair_from[nz], + " -> ", pair_to[nz], collapse = "; ") + if (positional) { + warning("Group sizes differ across periods: positional matching ", + "dropped ", total_dropped, " observation(s) (", detail, + "). Supply 'id' to match firms explicitly.", call. = FALSE) + } else { + warning(total_dropped, " observation(s) could not be matched ", + "across periods within their group and were dropped (", + detail, ").", call. = FALSE) + } + invisible(NULL) +} + + #' @export print.malmquist_meta <- function(x, ...) { cat("\nMetafrontier Malmquist TFP Index\n") cat("================================\n") + if (!is.null(x$method)) { + cat("Method: ", x$method, "\n") + } cat("Orientation: ", x$orientation, "\n") cat("RTS: ", x$rts, "\n") cat("Groups: ", paste(x$groups, collapse = ", "), "\n") @@ -441,6 +659,16 @@ print.malmquist_meta <- function(x, ...) { cat(" TGC =", format(means["TGC"], digits = 4), "\n") cat(" TC* =", format(means["TC"], digits = 4), "\n") + if (!is.null(x$n_infeasible) && x$n_infeasible > 0) { + cat("\nInfeasible cross-period DEA programs:", x$n_infeasible, + "(affected values are NA and excluded from means)\n") + } + if (!is.null(x$method) && x$method == "sfa") { + cat("\nNote: SFA metafrontier distances are pointwise-maximum", + "approximations\nover estimated group frontiers (see", + "?malmquist_meta).\n") + } + invisible(x) } @@ -482,6 +710,7 @@ summary.malmquist_meta <- function(object, ...) { out <- list( call = object$call, + method = object$method, orientation = object$orientation, rts = object$rts, groups = object$groups, @@ -491,7 +720,9 @@ summary.malmquist_meta <- function(object, ...) { na.rm = TRUE), by_group = by_group, by_period = by_period, - tgr_summary = tgr_summary + tgr_summary = tgr_summary, + n_infeasible = object$n_infeasible, + infeasible_by_period = object$infeasible_by_period ) class(out) <- "summary.malmquist_meta" out @@ -504,11 +735,30 @@ print.summary.malmquist_meta <- function(x, ...) { cat("=========================================\n\n") cat("Call:\n") print(x$call) - cat("\nOrientation:", x$orientation, "\n") + if (!is.null(x$method)) { + cat("\nMethod: ", x$method, "\n") + cat("Orientation:", x$orientation, "\n") + } else { + cat("\nOrientation:", x$orientation, "\n") + } cat("RTS: ", x$rts, "\n") cat("Groups: ", paste(x$groups, collapse = ", "), "\n") cat("Periods: ", paste(x$periods, collapse = " -> "), "\n") - cat("Observations:", x$n_obs, "\n\n") + cat("Observations:", x$n_obs, "\n") + + if (!is.null(x$n_infeasible) && x$n_infeasible > 0) { + cat("Infeasible cross-period DEA programs:", x$n_infeasible, + "(values NA, excluded from means)\n") + if (!is.null(x$infeasible_by_period)) { + tab <- x$infeasible_by_period + tab <- tab[tab$n_infeasible > 0, , drop = FALSE] + for (k in seq_len(nrow(tab))) { + cat(" ", tab$period_from[k], "->", tab$period_to[k], ":", + tab$n_infeasible[k], "of", tab$n_programs[k], "programs\n") + } + } + } + cat("\n") # Overall means cat("Overall means:\n") @@ -557,12 +807,15 @@ print.summary.malmquist_meta <- function(x, ...) { #' SFA-based Malmquist decomposition #' #' Fits period-specific group SFA models and computes the three-way -#' decomposition using SFA distance functions. +#' decomposition using SFA distance functions. The metafrontier is +#' approximated by the pointwise maximum over the estimated group +#' frontiers (see the Details section of \code{malmquist_meta}). #' #' @keywords internal #' @noRd .malmquist_sfa <- function(formula, data, group_vec, group_levels, - time_vec, time_levels, dist, control) { + time_vec, time_levels, dist, control, + id_vec = NULL, estimator = "bc88") { # Fit period x group SFA models models <- list() @@ -577,7 +830,8 @@ print.summary.malmquist_meta <- function(x, ...) { } data_gt <- data[idx, , drop = FALSE] models[[as.character(tt)]][[g]] <- tryCatch( - .fit_sfa_group(formula, data_gt, dist, control), + .fit_sfa_group(formula, data_gt, dist, control, + estimator = estimator), error = function(e) NULL ) } @@ -596,6 +850,12 @@ print.summary.malmquist_meta <- function(x, ...) { results <- vector("list", sfa_n_periods * sfa_n_groups * sfa_max_obs) result_idx <- 0L + # Per-period-pair accounting for consolidated warnings + pair_from <- time_levels[seq_len(sfa_n_periods)] + pair_to <- time_levels[seq_len(sfa_n_periods) + 1L] + dropped_by_pair <- integer(sfa_n_periods) + n_skipped <- 0L + for (tp in seq_len(length(time_levels) - 1L)) { t_s <- time_levels[tp] t_t <- time_levels[tp + 1L] @@ -613,12 +873,31 @@ print.summary.malmquist_meta <- function(x, ...) { # Obs indices for each period idx_s <- which(group_vec == g & time_vec == t_s) idx_t <- which(group_vec == g & time_vec == t_t) - n_pairs <- min(length(idx_s), length(idx_t)) - if (n_pairs == 0) next - for (i in seq_len(n_pairs)) { - is <- idx_s[i] - it <- idx_t[i] + if (!is.null(id_vec)) { + ids_gs <- id_vec[idx_s] + ids_gt <- id_vec[idx_t] + common <- intersect(ids_gs, ids_gt) + dropped_by_pair[tp] <- dropped_by_pair[tp] + + (length(ids_gs) - length(common)) + + (length(ids_gt) - length(common)) + pos_s <- idx_s[match(common, ids_gs)] + pos_t <- idx_t[match(common, ids_gt)] + out_ids <- common + } else { + n_matched <- min(length(idx_s), length(idx_t)) + dropped_by_pair[tp] <- dropped_by_pair[tp] + + abs(length(idx_s) - length(idx_t)) + pos_s <- idx_s[seq_len(n_matched)] + pos_t <- idx_t[seq_len(n_matched)] + out_ids <- seq_len(n_matched) + } + + if (length(pos_s) == 0L) next + + for (i in seq_along(pos_s)) { + is <- pos_s[i] + it <- pos_t[i] x_s <- X_all[is, ] x_t <- X_all[it, ] @@ -639,7 +918,10 @@ print.summary.malmquist_meta <- function(x, ...) { te_s <- mod_s$efficiency[match(is, idx_s)] te_t <- mod_t$efficiency[match(it, idx_t)] - if (is.na(te_s) || is.na(te_t) || te_s <= 0 || te_t <= 0) next + if (is.na(te_s) || is.na(te_t) || te_s <= 0 || te_t <= 0) { + n_skipped <- n_skipped + 1L + next + } # TEC = TE_t / TE_s tec <- te_t / te_s @@ -692,7 +974,7 @@ print.summary.malmquist_meta <- function(x, ...) { result_idx <- result_idx + 1L results[[result_idx]] <- data.frame( - id = i, + id = out_ids[i], group = g, period_from = t_s, period_to = t_t, @@ -719,6 +1001,14 @@ print.summary.malmquist_meta <- function(x, ...) { call. = FALSE) } + .warn_dropped(dropped_by_pair, pair_from, pair_to, is.null(id_vec)) + + if (n_skipped > 0L) { + warning(n_skipped, " matched observation(s) were skipped because ", + "of missing or non-positive efficiency scores.", + call. = FALSE) + } + malmquist_df <- do.call(rbind, results[seq_len(result_idx)]) rownames(malmquist_df) <- NULL @@ -734,6 +1024,7 @@ print.summary.malmquist_meta <- function(x, ...) { "EC_meta", "TC_meta")], tgr = malmquist_df[, c("id", "group", "period_from", "period_to", "TGR_from", "TGR_to", - "TGC")] + "TGC")], + n_infeasible = 0L ) } diff --git a/R/metafrontier.R b/R/metafrontier.R index eeb2894..3f7f7db 100644 --- a/R/metafrontier.R +++ b/R/metafrontier.R @@ -33,12 +33,19 @@ #' \code{"input"} orientation. Ignored when \code{method = "sfa"}. #' @param rts character. Returns to scale for DEA: \code{"crs"} #' (constant, default), \code{"vrs"} (variable), \code{"drs"} -#' (decreasing), or \code{"irs"} (increasing). Ignored when +#' (decreasing), \code{"irs"} (increasing), or \code{"fdh"} (free +#' disposable hull, i.e. no convexity). Ignored when #' \code{method = "sfa"}. #' @param models an optional named list of pre-fitted group-specific -#' frontier models (objects from \pkg{sfaR}, \pkg{frontier}, or -#' \pkg{Benchmarking}). If provided, \code{formula}, \code{data}, -#' and \code{group} are ignored. +#' frontier models (objects from \pkg{sfaR} or \pkg{frontier}, or +#' hand-built lists). Fitted model objects are converted +#' automatically via \code{\link{as_metafrontier_model}}, so no +#' manual conversion is required (pre-converting is harmless, the +#' conversion is idempotent). Farrell objects from +#' \pkg{Benchmarking} store neither coefficients nor data and +#' cannot be used here; use the formula interface with +#' \code{method = "dea"} instead. If \code{models} is provided, +#' \code{formula}, \code{data}, and \code{group} are ignored. #' @param panel an optional list with components \code{id} and #' \code{time} naming the panel identifier and time columns in #' \code{data}. When non-NULL, panel SFA models (BC92/BC95) are @@ -48,16 +55,55 @@ #' or \code{"bc95"} (Battese and Coelli 1995, observation-specific #' mean). Only used when \code{panel} is non-NULL. #' @param type character. For DEA: \code{"radial"} (default) for -#' standard radial DEA or \code{"directional"} for directional -#' distance functions. -#' @param direction character. Direction vector for DDF: -#' \code{"proportional"} (default), \code{"output"}, or -#' \code{"input"}. Only used when \code{type = "directional"}. +#' standard radial DEA, \code{"directional"} for directional +#' distance functions, or \code{"hyperbolic"} for hyperbolic +#' (graph) efficiency, which contracts inputs and expands outputs +#' simultaneously. +#' @param direction direction vector for DDF. Either a character +#' preset (\code{"proportional"} (default), \code{"output"}, or +#' \code{"input"}), a numeric vector of length m + s giving a +#' common direction (first m elements for inputs, last s for +#' outputs), or a numeric n x (m + s) matrix of firm-specific +#' directions. With numeric directions the ratio-based TGR is not +#' defined; the additive gap (\code{ddf_gap}) is reported instead. +#' Only used when \code{type = "directional"}. #' @param control a named list of control parameters passed to #' \code{\link[stats]{optim}}. Common options include #' \code{maxit} (maximum iterations, default 5000), #' \code{reltol} (relative convergence tolerance, default 1e-10), #' and \code{fnscale} (set to -1 internally for maximisation). +#' @param estimator character. Technical efficiency estimator for +#' SFA models: \code{"bc88"} (default) for the conditional +#' expectation \eqn{E[\exp(-u)|\varepsilon]} of Battese and Coelli +#' (1988), which is the consistent estimator of technical +#' efficiency, or \code{"jlms"} for +#' \eqn{\exp(-E[u|\varepsilon])} following Jondrow et al. (1982). +#' Both are stored on the fitted object; see +#' \code{\link{efficiencies}}. Ignored when \code{method = "dea"}. +#' @param objective character. Identification criterion for the +#' deterministic metafrontier: \code{"lp"} (default) minimises the +#' sum of absolute deviations (a linear programme), \code{"qp"} +#' minimises the sum of squared deviations (a quadratic programme, +#' solved exactly via \pkg{quadprog} when available). Both criteria +#' are proposed in Battese, Rao, and O'Donnell (2004). Only used +#' when \code{method = "sfa"} and \code{meta_type = +#' "deterministic"}. +#' @param engine character. Estimation backend for the group +#' frontiers: \code{"internal"} (default) uses the package's own +#' estimators; \code{"sfaR"} or \code{"frontier"} delegate the SFA +#' group frontiers to \code{\link[sfaR]{sfacross}} or +#' \code{\link[frontier]{sfa}} (cross-sectional, single-part +#' formulas only); \code{"Benchmarking"} delegates the DEA group +#' frontiers and the pooled metafrontier to +#' \code{\link[Benchmarking]{dea}} (radial only), using its +#' \code{XREF}/\code{YREF} external-reference facility for the +#' metafrontier stage. The metafrontier stage for SFA methods is +#' always estimated internally (the Murphy-Topel correction +#' requires the internal likelihood). +#' @param slack logical. For radial DEA, compute second-stage input +#' and output slacks (with the radial score held fixed) against +#' both the group and the pooled reference sets. Default +#' \code{FALSE}. #' @param ... additional arguments passed to the group-level #' estimation functions. #' @@ -77,7 +123,15 @@ #' \item{groups}{group labels} #' \item{method}{estimation method used} #' \item{meta_type}{metafrontier type used} -#' \item{convergence}{convergence status} +#' \item{meta_convergence}{integer convergence code for the +#' metafrontier stage (0 = success; \code{\link[stats]{optim}} +#' codes for the stochastic metafrontier and the QP barrier +#' fallback; 0 for a successful LP or DEA solution). Each SFA +#' group model in \code{group_models} additionally carries its +#' own \code{convergence} code. Use +#' \code{\link{check_convergence}} to inspect all stages.} +#' \item{estimator, objective, engine, meta_solver}{the +#' estimation choices used for the fit} #' } #' #' @details @@ -90,17 +144,33 @@ #' \eqn{TGR_i} is the technology gap ratio measuring how close the #' group frontier is to the metafrontier. #' -#' The deterministic metafrontier (Battese, Rao, and O'Donnell, 2004) -#' is estimated by solving a linear program that minimises the total -#' envelope overshoot subject to the constraint that the metafrontier -#' envelops all group frontiers. BRO (2004) originally proposed a -#' constrained least-squares (QP) formulation; the LP yields the -#' tightest envelope and is solved via \pkg{lpSolveAPI}, with a QP -#' fallback via \code{constrOptim()} when the LP is infeasible. +#' The deterministic metafrontier is identified by one of the two +#' criteria proposed by Battese, Rao, and O'Donnell (2004), subject in +#' both cases to the constraint that the metafrontier envelops all +#' group frontiers: minimising the sum of absolute deviations, which +#' reduces to a linear programme because the envelope constraints +#' force every deviation to be non-negative (O'Donnell, Rao, and +#' Battese, 2008, Eqs. 23-25), or minimising the sum of squared +#' deviations, a convex quadratic programme. The LP +#' (\code{objective = "lp"}, the default) is solved via +#' \pkg{lpSolveAPI}; the QP (\code{objective = "qp"}) is solved +#' exactly via \pkg{quadprog} when available, with an adaptive-barrier +#' fallback via \code{constrOptim()}. #' The stochastic metafrontier (Huang, Huang, and Liu, 2014) replaces #' this with a second-stage SFA, providing a distributional framework #' for inference on the TGR. #' +#' \strong{Convergence and failure handling:} estimation stops with an +#' error only when no usable estimate exists (for example, when both +#' the BFGS and Nelder-Mead optimisers fail for a group frontier). +#' When an optimiser stops at a non-zero convergence code, the fitted +#' object is returned with a warning and the code is recorded; use +#' \code{\link{check_convergence}} or \code{summary()} to verify all +#' estimation stages before interpreting technology gap ratios, +#' confidence intervals, or productivity decompositions. Infeasible +#' DEA programmes yield \code{NA} efficiency scores, accompanied by a +#' warning and counted by \code{\link{check_convergence}}. +#' #' \strong{Note on standard errors (stochastic metafrontier):} #' The stochastic metafrontier is a two-stage estimator. Stage 2 treats #' the fitted group frontier values as data, so the reported standard @@ -159,13 +229,17 @@ metafrontier <- function(formula = NULL, meta_type = c("deterministic", "stochastic"), dist = c("hnormal", "tnormal", "exponential"), orientation = c("output", "input"), - rts = c("crs", "vrs", "drs", "irs"), + rts = c("crs", "vrs", "drs", "irs", "fdh"), models = NULL, panel = NULL, panel_dist = c("bc92", "bc95"), - type = c("radial", "directional"), + type = c("radial", "directional", "hyperbolic"), direction = c("proportional", "output", "input"), control = list(), + estimator = c("bc88", "jlms"), + objective = c("lp", "qp"), + engine = c("internal", "sfaR", "frontier", "Benchmarking"), + slack = FALSE, ...) { cl <- match.call() @@ -176,7 +250,55 @@ metafrontier <- function(formula = NULL, rts <- match.arg(rts) panel_dist <- match.arg(panel_dist) type <- match.arg(type) - direction <- match.arg(direction) + if (is.character(direction)) { + direction <- match.arg(direction) + } else if (!is.numeric(direction)) { + stop("'direction' must be a character preset or a numeric ", + "vector/matrix.", call. = FALSE) + } + estimator <- match.arg(estimator) + objective <- match.arg(objective) + engine <- match.arg(engine) + if (!is.logical(slack) || length(slack) != 1L || is.na(slack)) { + stop("'slack' must be TRUE or FALSE.", call. = FALSE) + } + + # ------ Engine / option compatibility ------ + if (engine == "Benchmarking") { + if (method != "dea") { + stop("engine = \"Benchmarking\" is only available for ", + "method = \"dea\".", call. = FALSE) + } + if (type != "radial") { + stop("engine = \"Benchmarking\" supports type = \"radial\" only; ", + "use engine = \"internal\" for directional or hyperbolic ", + "efficiency.", call. = FALSE) + } + } + if (engine %in% c("sfaR", "frontier")) { + if (method != "sfa") { + stop("engine = \"", engine, "\" is only available for ", + "method = \"sfa\".", call. = FALSE) + } + if (!is.null(panel)) { + stop("External SFA engines support cross-sectional fits only; ", + "use engine = \"internal\" for panel models.", call. = FALSE) + } + if (engine == "frontier" && dist != "hnormal") { + stop("engine = \"frontier\" supports dist = \"hnormal\" only.", + call. = FALSE) + } + } + if (objective == "qp" && (method != "sfa" || + meta_type != "deterministic")) { + warning("'objective' applies only to the deterministic SFA ", + "metafrontier; ignored.", call. = FALSE) + } + if (slack && (method != "dea" || type != "radial")) { + warning("'slack' is only used for radial DEA; ignored.", + call. = FALSE) + slack <- FALSE + } # ------ Input validation ------ if (is.null(models)) { @@ -190,9 +312,14 @@ metafrontier <- function(formula = NULL, panel = panel, panel_dist = panel_dist, type = type, - direction = direction, ...) + direction = direction, + estimator = estimator, + objective = objective, + engine = engine, + slack = slack, ...) } else { - result <- .estimate_from_models(models, meta_type, control, ...) + result <- .estimate_from_models(models, meta_type, control, + objective = objective, ...) } result$call <- cl @@ -200,6 +327,14 @@ metafrontier <- function(formula = NULL, result$meta_type <- meta_type result$orientation <- orientation result$rts <- rts + result$type <- type + result$direction <- direction + result$slack <- slack + result$engine <- engine + if (method == "sfa") { + result$estimator <- estimator + if (meta_type == "deterministic") result$objective <- objective + } if (is.character(group) && length(group) == 1L) { result$group_col <- group } else { @@ -218,7 +353,15 @@ metafrontier <- function(formula = NULL, # ---------- Internal: estimate from raw data ---------- .estimate_from_data <- function(formula, data, group, method, meta_type, dist, orientation, - rts, control, ...) { + rts, control, + panel = NULL, + panel_dist = "bc92", + type = "radial", + direction = "proportional", + estimator = "bc88", + objective = "lp", + engine = "internal", + slack = FALSE, ...) { # Parse the group variable if (is.character(group) && length(group) == 1L) { @@ -260,20 +403,37 @@ metafrontier <- function(formula = NULL, data_g <- data[idx, , drop = FALSE] if (method == "sfa") { - dots <- list(...) - if (!is.null(dots$panel)) { + if (engine %in% c("sfaR", "frontier")) { + group_models[[g]] <- .fit_sfa_group_external( + f, data_g, dist, engine, estimator + ) + } else if (!is.null(panel)) { group_models[[g]] <- .fit_sfa_panel_group( - f, data_g, dist, dots$panel_dist, dots$panel, control, ... + f, data_g, dist, panel_dist, panel, control, + estimator = estimator, ... ) } else { - group_models[[g]] <- .fit_sfa_group(f, data_g, dist, control, ...) + group_models[[g]] <- .fit_sfa_group(f, data_g, dist, control, + estimator = estimator, ...) } } else { - dots <- if (!exists("dots", inherits = FALSE)) list(...) else dots - if (!is.null(dots$type) && dots$type == "directional") { - group_models[[g]] <- .fit_ddf_group(f, data_g, rts, dots$direction) + if (engine == "Benchmarking") { + group_models[[g]] <- .fit_dea_group_benchmarking( + f, data_g, orientation, rts + ) + } else if (type == "directional") { + # Firm-specific direction matrices are subset to the group rows + dir_g <- if (is.matrix(direction)) { + direction[idx, , drop = FALSE] + } else { + direction + } + group_models[[g]] <- .fit_ddf_group(f, data_g, rts, dir_g) + } else if (type == "hyperbolic") { + group_models[[g]] <- .fit_hyperbolic_group(f, data_g, rts) } else { - group_models[[g]] <- .fit_dea_group(f, data_g, orientation, rts, ...) + group_models[[g]] <- .fit_dea_group(f, data_g, orientation, rts, + slack = slack, ...) } } } @@ -282,19 +442,27 @@ metafrontier <- function(formula = NULL, if (method == "sfa") { meta_result <- .estimate_sfa_metafrontier( f, data, group_vec, group_levels, group_models, - meta_type, dist, control + meta_type, dist, control, objective = objective ) } else { - dots <- list(...) - if (!is.null(dots$type) && dots$type == "directional") { + if (engine == "Benchmarking") { + meta_result <- .estimate_dea_metafrontier_benchmarking( + f, data, group_vec, group_levels, group_models, + orientation, rts + ) + } else if (type == "directional") { meta_result <- .estimate_ddf_metafrontier( f, data, group_vec, group_levels, group_models, - rts, dots$direction + rts, direction + ) + } else if (type == "hyperbolic") { + meta_result <- .estimate_hyperbolic_metafrontier( + f, data, group_vec, group_levels, group_models, rts ) } else { meta_result <- .estimate_dea_metafrontier( f, data, group_vec, group_levels, group_models, - orientation, rts + orientation, rts, slack = slack ) } } @@ -314,7 +482,8 @@ metafrontier <- function(formula = NULL, # ---------- Internal: estimate from pre-fitted models ---------- -.estimate_from_models <- function(models, meta_type, control, ...) { +.estimate_from_models <- function(models, meta_type, control, + objective = "lp", ...) { if (!is.list(models) || is.null(names(models))) { stop("'models' must be a named list of fitted frontier objects.", call. = FALSE) @@ -394,7 +563,8 @@ metafrontier <- function(formula = NULL, # Estimate the metafrontier if (meta_type == "deterministic") { meta_result <- .deterministic_metafrontier_lp( - X_combined, group_frontier, group_vec, group_levels, group_coef, k + X_combined, group_frontier, group_vec, group_levels, group_coef, k, + objective = objective ) } else { meta_result <- .stochastic_metafrontier( @@ -429,6 +599,7 @@ metafrontier <- function(formula = NULL, logLik_groups = sapply(group_models, function(m) m$logLik), meta_logLik = meta_result$meta_logLik, meta_convergence = meta_result$convergence, + meta_solver = meta_result$meta_solver, group_models = group_models, groups = group_levels, group_vec = group_vec, @@ -451,7 +622,7 @@ metafrontier <- function(formula = NULL, #' Extract from sfaR::sfacross object #' @noRd -.extract_sfacross <- function(model) { +.extract_sfacross <- function(model, estimator = "bc88") { if (!requireNamespace("sfaR", quietly = TRUE)) { stop("Package 'sfaR' is required to extract from sfacross objects.", call. = FALSE) @@ -466,15 +637,24 @@ metafrontier <- function(formula = NULL, } beta <- all_coef[seq_len(n_beta)] - # Technical efficiency — efficiencies() may return a data.frame + # Technical efficiency — efficiencies() may return a data.frame. + # sfaR's teBC is the BC88 estimator E[exp(-u)|eps]; teJLMS is + # exp(-E[u|eps]). Pick the column matching the requested estimator. te_obj <- sfaR::efficiencies(model) + te_bc88 <- NULL + te_jlms <- NULL if (is.data.frame(te_obj) || is.matrix(te_obj)) { - if ("teBC" %in% names(te_obj)) { - te <- as.numeric(te_obj[["teBC"]]) - } else if ("teJLMS" %in% names(te_obj)) { - te <- as.numeric(te_obj[["teJLMS"]]) + te_obj <- as.data.frame(te_obj) + if ("teBC" %in% names(te_obj)) te_bc88 <- as.numeric(te_obj[["teBC"]]) + if ("teJLMS" %in% names(te_obj)) te_jlms <- as.numeric(te_obj[["teJLMS"]]) + te <- if (identical(estimator, "jlms") && !is.null(te_jlms)) { + te_jlms + } else if (!is.null(te_bc88)) { + te_bc88 + } else if (!is.null(te_jlms)) { + te_jlms } else { - te <- as.numeric(te_obj[[1]]) + as.numeric(te_obj[[1]]) } } else { te <- as.numeric(te_obj) @@ -500,6 +680,8 @@ metafrontier <- function(formula = NULL, list( beta = beta, te = te, + te_bc88 = te_bc88, + te_jlms = te_jlms, X = X, y = as.numeric(y), sigma_v = as.numeric(sigma_v), @@ -516,51 +698,153 @@ metafrontier <- function(formula = NULL, } -#' Extract from frontier::sfa object +# ---------- Internal: external engines ---------- + +#' Fit a group SFA frontier via an external engine (sfaR or frontier) #' @noRd -.extract_frontier_sfa <- function(model) { - if (!requireNamespace("frontier", quietly = TRUE)) { - stop("Package 'frontier' is required to extract from sfa objects.", - call. = FALSE) +.fit_sfa_group_external <- function(formula, data, dist, engine, + estimator = "bc88") { + if (inherits(formula, "Formula") && length(formula)[2] > 1L) { + stop("External SFA engines support single-part formulas only ", + "(no inefficiency determinants).", call. = FALSE) + } + f_base <- if (inherits(formula, "Formula")) { + formula(formula, rhs = 1) + } else { + formula + } + + if (engine == "sfaR") { + if (!requireNamespace("sfaR", quietly = TRUE)) { + stop("Package 'sfaR' is required for engine = \"sfaR\".", + call. = FALSE) + } + fit <- sfaR::sfacross(formula = f_base, udist = dist, data = data, + S = 1) + ex <- .extract_sfacross(fit, estimator = estimator) + } else { + if (!requireNamespace("frontier", quietly = TRUE)) { + stop("Package 'frontier' is required for engine = \"frontier\".", + call. = FALSE) + } + fit <- frontier::sfa(f_base, data = data) + ex <- .extract_frontier(fit) + ex$te_bc88 <- ex$te # frontier::efficiencies() is the BC88-type estimator + ex$te_jlms <- NULL + if (identical(estimator, "jlms")) { + warning("engine = \"frontier\" provides BC88-type efficiencies ", + "only; 'estimator = \"jlms\"' is not available for this ", + "engine.", call. = FALSE) + } } - # frontier::sfa stores MLE params in mleParam - all_coef <- model$mleParam - # Frontier coefficients are named "beta_*" or similar - beta_idx <- grep("^beta", names(all_coef), ignore.case = TRUE) - if (length(beta_idx) == 0) { - # Fallback: OLS params have same structure - beta_idx <- grep("^beta", names(model$olsParam), ignore.case = TRUE) - n_beta <- length(beta_idx) - beta <- all_coef[seq_len(n_beta)] + list( + coefficients = ex$beta, + efficiency = ex$te, + efficiency_bc88 = ex$te_bc88, + efficiency_jlms = ex$te_jlms, + estimator = estimator, + sigma_v = ex$sigma_v, + sigma_u = ex$sigma_u, + logLik = ex$logLik, + hessian = ex$hessian, + nobs = ex$n, + X = ex$X, + y = ex$y, + dist = ex$dist, + engine = engine + ) +} + + +#' Build DEA input/output matrices from a formula and data +#' @noRd +.dea_matrices_mf <- function(formula, data) { + f_base <- if (inherits(formula, "Formula")) { + formula(formula, rhs = 1) } else { - beta <- all_coef[beta_idx] + formula + } + mf <- model.frame(f_base, data = data) + y_raw <- model.response(mf) + X_raw <- model.matrix(f_base, data = data) + if (colnames(X_raw)[1] == "(Intercept)") { + X_raw <- X_raw[, -1, drop = FALSE] } + Y <- if (is.matrix(y_raw)) y_raw else matrix(y_raw, ncol = 1) + list(X = X_raw, Y = Y) +} - # Efficiency: frontier stores TE in $efficiencies - te <- as.numeric(frontier::efficiencies(model)) - # Design matrix from the model - X <- model.matrix(model$formula, data = model$dataTable) - y <- model.response(model.frame(model$formula, data = model$dataTable)) +#' Farrell efficiency via Benchmarking::dea with an external reference set +#' @noRd +.benchmarking_te <- function(X, Y, XREF, YREF, orientation, rts) { + if (!requireNamespace("Benchmarking", quietly = TRUE)) { + stop("Package 'Benchmarking' is required for ", + "engine = \"Benchmarking\".", call. = FALSE) + } + ORIENT <- if (orientation == "input") "in" else "out" + e <- Benchmarking::dea(X = X, Y = Y, RTS = rts, ORIENTATION = ORIENT, + XREF = XREF, YREF = YREF) + scores <- as.numeric(Benchmarking::eff(e)) + # Benchmarking returns the Farrell output measure (>= 1) for "out"; + # convert to TE in (0, 1] to match the internal convention. + if (ORIENT == "out") 1 / scores else scores +} - # Extract sigma parameters - sigma_sq <- all_coef["sigmaSq"] - gamma <- all_coef["gamma"] - sigma_v <- sqrt(sigma_sq * (1 - gamma)) - sigma_u <- sqrt(sigma_sq * gamma) +#' Fit a group DEA frontier via Benchmarking::dea +#' @noRd +.fit_dea_group_benchmarking <- function(formula, data, orientation, rts) { + mats <- .dea_matrices_mf(formula, data) + te <- .benchmarking_te(mats$X, mats$Y, mats$X, mats$Y, orientation, rts) list( - beta = beta, - te = as.numeric(te), - X = X, - y = as.numeric(y), - sigma_v = as.numeric(sigma_v), - sigma_u = as.numeric(sigma_u), - logLik = model$mleLogl, - hessian = NULL, - n = length(y), - dist = "hnormal" + efficiency = te, + nobs = nrow(mats$X), + orientation = orientation, + rts = rts, + X = mats$X, + Y = mats$Y, + engine = "Benchmarking" ) } + +#' DEA metafrontier via Benchmarking::dea with XREF/YREF pooling +#' @noRd +.estimate_dea_metafrontier_benchmarking <- function(formula, data, + group_vec, + group_levels, + group_models, + orientation, rts) { + mats <- .dea_matrices_mf(formula, data) + n <- nrow(mats$X) + + te_group <- numeric(n) + for (g in group_levels) { + idx <- which(group_vec == g) + te_group[idx] <- group_models[[g]]$efficiency + } + + # Pooled metafrontier: every observation scored against the full + # reference set via Benchmarking's XREF/YREF facility. + te_meta <- .benchmarking_te(mats$X, mats$Y, mats$X, mats$Y, + orientation, rts) + + tgr <- te_meta / te_group + + list( + meta_coef = NULL, + meta_vcov = NULL, + group_coef = NULL, + tgr = tgr, + te_group = te_group, + te_meta = te_meta, + group_frontier = NULL, + meta_frontier = NULL, + logLik_groups = NULL, + meta_logLik = NULL, + meta_convergence = 0L, + meta_solver = "Benchmarking" + ) +} diff --git a/R/metafrontier_dea.R b/R/metafrontier_dea.R index 46d6eb2..e4a13d8 100644 --- a/R/metafrontier_dea.R +++ b/R/metafrontier_dea.R @@ -1,10 +1,15 @@ #' Internal: DEA estimation for a single group #' #' Solves the DEA linear programme for a single technology group. +#' Supports \code{rts = "fdh"} (free disposal hull, solved by exact +#' enumeration). When \code{slack = TRUE}, second-stage slacks against +#' the group's own reference set are stored as \code{slack_x} (n x m) +#' and \code{slack_y} (n x s) matrices. #' #' @keywords internal #' @noRd -.fit_dea_group <- function(formula, data, orientation, rts, ...) { +.fit_dea_group <- function(formula, data, orientation, rts, + slack = FALSE, ...) { mf <- model.frame(formula, data = data) y_raw <- model.response(mf) @@ -31,7 +36,7 @@ # Solve DEA LP for each DMU (batch for performance) efficiency <- .dea_batch_fast(X_raw, Y, orientation, rts) - list( + out <- list( efficiency = efficiency, nobs = n, orientation = orientation, @@ -39,10 +44,22 @@ X = X_raw, Y = Y ) + + if (isTRUE(slack)) { + sl <- .dea_slacks(X_raw, Y, efficiency, orientation, rts, X_raw, Y) + out$slack_x <- sl$slack_x + out$slack_y <- sl$slack_y + } + + out } #' Solve a single DEA LP +#' +#' Under \code{rts = "fdh"} the problem is solved by exact enumeration +#' of dominating reference points rather than by linear programming. +#' #' @keywords internal #' @noRd .dea_solve_lp <- function(x_i, y_i, X, Y, orientation, rts) { @@ -50,6 +67,11 @@ m <- ncol(X) s <- ncol(Y) + if (rts == "fdh") { + return(.fdh_radial(matrix(x_i, nrow = 1), matrix(y_i, nrow = 1), + orientation, X, Y)$efficiency) + } + if (orientation == "input") { # Input-oriented: min theta # s.t. X' lambda <= theta * x_i @@ -121,7 +143,12 @@ lpSolveAPI::add.constraint(lp, c(rep(1, n), 0), ">=", 1) } - lpSolveAPI::set.bounds(lp, lower = c(rep(0, n), 1)) + # phi is bounded below by 0, not 1: cross-period evaluation of + # super-efficient DMUs can have phi* < 1, and a lower bound of 1 + # would make those LPs infeasible. Same-period scores are + # unaffected since phi* >= 1 whenever the DMU is in its own + # reference set. + lpSolveAPI::set.bounds(lp, lower = c(rep(0, n), 0)) lpSolveAPI::lp.control(lp, sense = "max", verbose = "neutral") status <- lpSolveAPI::solve.lpExtPtr(lp) @@ -150,6 +177,10 @@ if (is.null(X_ref)) X_ref <- X if (is.null(Y_ref)) Y_ref <- Y + if (rts == "fdh") { + return(.fdh_radial(X, Y, orientation, X_ref, Y_ref)$efficiency) + } + n_eval <- nrow(X) n_ref <- nrow(X_ref) m <- ncol(X) @@ -234,7 +265,8 @@ } else if (rts == "irs") { lpSolveAPI::add.constraint(lp, c(rep(1, n_ref), 0), ">=", 1) } - lpSolveAPI::set.bounds(lp, lower = c(rep(0, n_ref), 1)) + # Lower bound 0 on phi (not 1): see .dea_solve_lp + lpSolveAPI::set.bounds(lp, lower = c(rep(0, n_ref), 0)) eff <- numeric(n_eval) for (i in seq_len(n_eval)) { @@ -262,15 +294,76 @@ } +#' Radial FDH efficiency by exact enumeration +#' +#' Computes Farrell radial efficiency under free disposability without +#' convexity. Input orientation: the minimum over reference points that +#' weakly dominate on all outputs of the maximum input ratio. Output +#' orientation: the maximum over reference points that use no more of +#' any input of the minimum output ratio, reported as 1/phi (Farrell +#' convention, matching the LP path). If no reference point dominates +#' (possible in cross-period evaluation), the score is \code{NA} with a +#' warning, mirroring the infeasible-LP behaviour. +#' +#' @return A list with \code{efficiency} (numeric vector) and +#' \code{peer} (integer row indices into the reference set of the +#' single best dominating peer, \code{NA} where none exists). +#' @keywords internal +#' @noRd +.fdh_radial <- function(X, Y, orientation, X_ref, Y_ref) { + n_eval <- nrow(X) + s <- ncol(Y_ref) + m <- ncol(X_ref) + + eff <- rep(NA_real_, n_eval) + peer <- rep(NA_integer_, n_eval) + + for (i in seq_len(n_eval)) { + if (orientation == "input") { + # Reference points that weakly dominate on all outputs + dom <- which(colSums(t(Y_ref) >= Y[i, ]) == s) + if (length(dom) == 0L) { + warning("No dominating FDH reference point for a DMU.", + call. = FALSE) + next + } + scores <- apply(X_ref[dom, , drop = FALSE], 1, + function(r) max(r / X[i, ])) + k <- which.min(scores) + eff[i] <- scores[k] + peer[i] <- dom[k] + } else { + # Reference points that use no more of any input + dom <- which(colSums(t(X_ref) <= X[i, ]) == m) + if (length(dom) == 0L) { + warning("No dominating FDH reference point for a DMU.", + call. = FALSE) + next + } + phis <- apply(Y_ref[dom, , drop = FALSE], 1, + function(r) min(r / Y[i, ])) + k <- which.max(phis) + eff[i] <- 1 / phis[k] + peer[i] <- dom[k] + } + } + + list(efficiency = eff, peer = peer) +} + + #' Internal: Estimate DEA-based metafrontier #' #' Computes group DEA and pooled (meta) DEA, then derives TGR. +#' Supports \code{rts = "fdh"}. When \code{slack = TRUE}, second-stage +#' slacks against the pooled reference set are stored as +#' \code{slack_x_meta} and \code{slack_y_meta}. #' #' @keywords internal #' @noRd .estimate_dea_metafrontier <- function(formula, data, group_vec, group_levels, group_models, - orientation, rts) { + orientation, rts, slack = FALSE) { mf <- model.frame(formula, data = data) y_raw <- model.response(mf) @@ -300,7 +393,7 @@ # TGR = metafrontier efficiency / group efficiency tgr <- te_meta / te_group - list( + out <- list( meta_coef = NULL, # DEA is nonparametric meta_vcov = NULL, group_coef = NULL, @@ -313,6 +406,113 @@ meta_logLik = NULL, meta_convergence = 0L ) + + if (isTRUE(slack)) { + sl <- .dea_slacks(X_raw, Y, te_meta, orientation, rts, X_raw, Y) + out$slack_x_meta <- sl$slack_x + out$slack_y_meta <- sl$slack_y + } + + out +} + + +#' Second-stage slack maximisation +#' +#' Standard two-stage slack computation with the radial score held +#' fixed. Input orientation: max sum(s_x) + sum(s_y) subject to +#' X_ref' lambda + s_x = theta_i * x_i and Y_ref' lambda - s_y = y_i. +#' Output orientation: X_ref' lambda + s_x = x_i and +#' Y_ref' lambda - s_y = phi_i * y_i. The equalities are implemented +#' as pairs of inequalities relaxed by a small tolerance because the +#' radially scaled targets are floating-point products. Under +#' \code{rts = "fdh"} slacks are measured against the single +#' dominating peer identified by the enumeration. +#' +#' @param scores Farrell efficiency scores as returned by the radial +#' solvers (input orientation: theta; output orientation: 1/phi). +#' @return A list with matrices \code{slack_x} (n x m) and +#' \code{slack_y} (n x s); rows are \code{NA} where the radial score +#' is \code{NA}. +#' @keywords internal +#' @noRd +.dea_slacks <- function(X, Y, scores, orientation, rts, X_ref, Y_ref) { + n <- nrow(X) + m <- ncol(X) + s <- ncol(Y) + n_ref <- nrow(X_ref) + + slack_x <- matrix(NA_real_, n, m) + slack_y <- matrix(NA_real_, n, s) + + if (rts == "fdh") { + fdh <- .fdh_radial(X, Y, orientation, X_ref, Y_ref) + for (i in seq_len(n)) { + j <- fdh$peer[i] + if (is.na(j)) next + if (orientation == "input") { + slack_x[i, ] <- pmax(scores[i] * X[i, ] - X_ref[j, ], 0) + slack_y[i, ] <- pmax(Y_ref[j, ] - Y[i, ], 0) + } else { + slack_x[i, ] <- pmax(X[i, ] - X_ref[j, ], 0) + slack_y[i, ] <- pmax(Y_ref[j, ] - Y[i, ] / scores[i], 0) + } + } + return(list(slack_x = slack_x, slack_y = slack_y)) + } + + n_vars <- n_ref + m + s # lambdas, then s_x, then s_y + tol <- 1e-9 + + for (i in seq_len(n)) { + if (is.na(scores[i])) next + + if (orientation == "input") { + x_target <- scores[i] * X[i, ] + y_target <- Y[i, ] + } else { + x_target <- X[i, ] + y_target <- Y[i, ] / scores[i] + } + + lp <- lpSolveAPI::make.lp(0, n_vars) + lpSolveAPI::set.objfn(lp, c(rep(0, n_ref), rep(1, m + s))) + lpSolveAPI::lp.control(lp, sense = "max", verbose = "neutral") + + # X_ref' lambda + s_x = x_target (relaxed equality) + for (mm in seq_len(m)) { + coef <- c(X_ref[, mm], as.numeric(seq_len(m) == mm), rep(0, s)) + eps <- tol * (1 + abs(x_target[mm])) + lpSolveAPI::add.constraint(lp, coef, "<=", x_target[mm] + eps) + lpSolveAPI::add.constraint(lp, coef, ">=", x_target[mm] - eps) + } + # Y_ref' lambda - s_y = y_target (relaxed equality) + for (ss in seq_len(s)) { + coef <- c(Y_ref[, ss], rep(0, m), -as.numeric(seq_len(s) == ss)) + eps <- tol * (1 + abs(y_target[ss])) + lpSolveAPI::add.constraint(lp, coef, "<=", y_target[ss] + eps) + lpSolveAPI::add.constraint(lp, coef, ">=", y_target[ss] - eps) + } + + if (rts == "vrs") { + lpSolveAPI::add.constraint(lp, c(rep(1, n_ref), rep(0, m + s)), "=", 1) + } else if (rts == "drs") { + lpSolveAPI::add.constraint(lp, c(rep(1, n_ref), rep(0, m + s)), "<=", 1) + } else if (rts == "irs") { + lpSolveAPI::add.constraint(lp, c(rep(1, n_ref), rep(0, m + s)), ">=", 1) + } + + status <- lpSolveAPI::solve.lpExtPtr(lp) + if (status == 0) { + sol <- lpSolveAPI::get.variables(lp) + slack_x[i, ] <- pmax(sol[n_ref + seq_len(m)], 0) + slack_y[i, ] <- pmax(sol[n_ref + m + seq_len(s)], 0) + } else { + warning("Slack LP infeasible for a DMU.", call. = FALSE) + } + } + + list(slack_x = slack_x, slack_y = slack_y) } @@ -329,7 +529,8 @@ #' @param Y output matrix (reference set). #' @param g_x input direction vector. #' @param g_y output direction vector. -#' @param rts returns to scale assumption. +#' @param rts returns to scale assumption; \code{"fdh"} is solved as a +#' mixed-integer programme with binary intensity variables. #' #' @return The DDF value beta (inefficiency measure). #' @keywords internal @@ -362,6 +563,11 @@ lpSolveAPI::add.constraint(lp, c(rep(1, n), 0), "<=", 1) } else if (rts == "irs") { lpSolveAPI::add.constraint(lp, c(rep(1, n), 0), ">=", 1) + } else if (rts == "fdh") { + # Free disposal hull: exactly one reference point, so the lambdas + # are binary and sum to one (mixed-integer programme) + lpSolveAPI::add.constraint(lp, c(rep(1, n), 0), "=", 1) + lpSolveAPI::set.type(lp, columns = seq_len(n), type = "binary") } # Bounds @@ -395,7 +601,72 @@ } +#' Build DDF direction matrices +#' +#' Accepts a character preset (\code{"proportional"} g = (x_i, y_i), +#' \code{"output"} g = (0, y_i), \code{"input"} g = (x_i, 0)), a +#' numeric vector of length m + s giving a common direction (first m +#' elements g_x, last s elements g_y), or a numeric n x (m + s) matrix +#' whose row i is firm i's direction. +#' +#' @return A list with \code{g_x} (n x m), \code{g_y} (n x s) and +#' \code{numeric} (\code{TRUE} for user-supplied numeric directions). +#' @keywords internal +#' @noRd +.ddf_direction_mats <- function(direction, X, Y) { + n <- nrow(X) + m <- ncol(X) + s <- ncol(Y) + + if (is.character(direction) && length(direction) == 1L) { + if (direction == "proportional") { + return(list(g_x = X, g_y = Y, numeric = FALSE)) + } else if (direction == "output") { + return(list(g_x = matrix(0, n, m), g_y = Y, numeric = FALSE)) + } else if (direction == "input") { + return(list(g_x = X, g_y = matrix(0, n, s), numeric = FALSE)) + } + stop("Unknown direction: ", direction, call. = FALSE) + } + + if (is.numeric(direction)) { + if (is.matrix(direction)) { + if (nrow(direction) != n || ncol(direction) != m + s) { + stop("A direction matrix must have dimensions n x (m + s), here ", + n, " x ", m + s, ".", call. = FALSE) + } + g <- direction + } else { + if (length(direction) != m + s) { + stop("A direction vector must have length m + s = ", m + s, ".", + call. = FALSE) + } + g <- matrix(direction, n, m + s, byrow = TRUE) + } + if (any(!is.finite(g)) || any(g < 0)) { + stop("Numeric directions must be finite and non-negative.", + call. = FALSE) + } + if (any(rowSums(g) == 0)) { + stop("Each direction must have at least one positive element.", + call. = FALSE) + } + return(list(g_x = g[, seq_len(m), drop = FALSE], + g_y = g[, m + seq_len(s), drop = FALSE], + numeric = TRUE)) + } + + stop("'direction' must be a character preset, a numeric vector of ", + "length m + s, or a numeric n x (m + s) matrix.", call. = FALSE) +} + + #' DDF-based group efficiency +#' +#' \code{direction} may be a character preset, a numeric vector of +#' length m + s, or a numeric matrix with one row per observation of +#' \code{data} (see \code{.ddf_direction_mats}). +#' #' @keywords internal #' @noRd .fit_ddf_group <- function(formula, data, rts, direction, ...) { @@ -409,30 +680,17 @@ } n <- nrow(X_raw) - m <- ncol(X_raw) if (is.matrix(y_raw)) { Y <- y_raw } else { Y <- matrix(y_raw, ncol = 1) } - s <- ncol(Y) # Direction vectors - if (direction == "proportional") { - g_x_mat <- X_raw - g_y_mat <- Y - } else if (direction == "output") { - g_x_mat <- matrix(0, n, m) - g_y_mat <- Y - } else if (direction == "input") { - g_x_mat <- X_raw - g_y_mat <- matrix(0, n, s) - } else { - stop("Unknown direction: ", direction, call. = FALSE) - } + dirs <- .ddf_direction_mats(direction, X_raw, Y) - efficiency <- .ddf_batch(X_raw, Y, g_x_mat, g_y_mat, rts) + efficiency <- .ddf_batch(X_raw, Y, dirs$g_x, dirs$g_y, rts) list( efficiency = efficiency, @@ -446,6 +704,20 @@ #' DDF-based metafrontier estimation +#' +#' \code{direction} may be a character preset, a numeric vector of +#' length m + s, or a numeric n x (m + s) matrix (see +#' \code{.ddf_direction_mats}). Convention: the multiplicative +#' conversion te = 1/(1 + beta) is only meaningful for the character +#' presets, where the direction scales with the observation. For +#' user-supplied numeric directions \code{te_group}, \code{te_meta} +#' and \code{tgr} are set to \code{NA} and the additive fields +#' \code{beta_group}, \code{beta_meta} and +#' \code{ddf_gap = beta_meta - beta_group} (the additive technology +#' gap, non-negative up to solver tolerance) carry the results. The +#' additive fields are populated for the presets too, for +#' comparability. +#' #' @keywords internal #' @noRd .estimate_ddf_metafrontier <- function(formula, data, group_vec, @@ -466,20 +738,9 @@ } n <- nrow(X_raw) - m <- ncol(X_raw) - s <- ncol(Y) # Direction vectors - if (direction == "proportional") { - g_x_mat <- X_raw - g_y_mat <- Y - } else if (direction == "output") { - g_x_mat <- matrix(0, n, m) - g_y_mat <- Y - } else { - g_x_mat <- X_raw - g_y_mat <- matrix(0, n, s) - } + dirs <- .ddf_direction_mats(direction, X_raw, Y) # Group-level DDF beta_group <- numeric(n) @@ -489,15 +750,23 @@ } # Pooled DDF (metafrontier) - beta_meta <- .ddf_batch(X_raw, Y, g_x_mat, g_y_mat, rts) - - # DDF TGR: additive decomposition - # beta_meta = beta_group + TGR_DDF - # TGR = beta_meta - beta_group (additive gap) - # For compatibility, also compute ratio-based TE - te_group <- 1 / (1 + beta_group) - te_meta <- 1 / (1 + beta_meta) - tgr <- te_meta / te_group + beta_meta <- .ddf_batch(X_raw, Y, dirs$g_x, dirs$g_y, rts) + + if (dirs$numeric) { + # te = 1/(1 + beta) is not meaningful for arbitrary directions; + # only the additive decomposition below applies + te_group <- rep(NA_real_, n) + te_meta <- rep(NA_real_, n) + tgr <- rep(NA_real_, n) + } else { + # DDF TGR: additive decomposition + # beta_meta = beta_group + TGR_DDF + # TGR = beta_meta - beta_group (additive gap) + # For compatibility, also compute ratio-based TE + te_group <- 1 / (1 + beta_group) + te_meta <- 1 / (1 + beta_meta) + tgr <- te_meta / te_group + } list( meta_coef = NULL, @@ -513,6 +782,189 @@ meta_convergence = 0L, beta_group = beta_group, beta_meta = beta_meta, - ddf_tgr = beta_meta - beta_group + ddf_tgr = beta_meta - beta_group, + ddf_gap = beta_meta - beta_group + ) +} + + +#' Batch hyperbolic graph efficiency +#' +#' Computes hyperbolic efficiency gamma in (0, 1]: the smallest gamma +#' such that (gamma * x_i, y_i / gamma) remains in the technology. +#' Under CRS the exact closed form gamma = sqrt(theta) is used, where +#' theta is the input-oriented radial score against the same reference +#' set. Under FDH the minimum over reference points of the smallest +#' feasible gamma is exact. Under vrs/drs/irs gamma is found by +#' bisection on feasibility LPs, reusing a single LP object across +#' DMUs and bisection steps. +#' +#' @keywords internal +#' @noRd +.hyperbolic_batch <- function(X, Y, rts, X_ref = NULL, Y_ref = NULL) { + if (is.null(X_ref)) X_ref <- X + if (is.null(Y_ref)) Y_ref <- Y + + n_eval <- nrow(X) + m <- ncol(X) + s <- ncol(Y) + n_ref <- nrow(X_ref) + + if (rts == "crs") { + theta <- .dea_batch_fast(X, Y, "input", "crs", X_ref, Y_ref) + return(sqrt(theta)) + } + + if (rts == "fdh") { + # Reference point j admits gamma iff gamma >= X_jm / x_im for all + # inputs and gamma >= y_is / Y_js for all outputs + gamma <- rep(NA_real_, n_eval) + for (i in seq_len(n_eval)) { + req_x <- apply(X_ref, 1, function(r) max(r / X[i, ])) + req_y <- apply(Y_ref, 1, function(r) max(Y[i, ] / r)) + gamma[i] <- min(pmax(req_x, req_y)) + } + return(gamma) + } + + # vrs / drs / irs: bisection on feasibility LPs + lp <- lpSolveAPI::make.lp(0, n_ref) + lpSolveAPI::set.objfn(lp, rep(0, n_ref)) + lpSolveAPI::lp.control(lp, sense = "min", verbose = "neutral") + for (mm in seq_len(m)) { + lpSolveAPI::add.constraint(lp, X_ref[, mm], "<=", 0) + } + for (ss in seq_len(s)) { + lpSolveAPI::add.constraint(lp, Y_ref[, ss], ">=", 0) + } + if (rts == "vrs") { + lpSolveAPI::add.constraint(lp, rep(1, n_ref), "=", 1) + } else if (rts == "drs") { + lpSolveAPI::add.constraint(lp, rep(1, n_ref), "<=", 1) + } else if (rts == "irs") { + lpSolveAPI::add.constraint(lp, rep(1, n_ref), ">=", 1) + } + + feasible <- function(gamma, x_i, y_i) { + for (mm in seq_len(m)) { + lpSolveAPI::set.rhs(lp, gamma * x_i[mm], mm) + } + for (ss in seq_len(s)) { + lpSolveAPI::set.rhs(lp, y_i[ss] / gamma, m + ss) + } + lpSolveAPI::solve.lpExtPtr(lp) == 0 + } + + gamma <- rep(NA_real_, n_eval) + for (i in seq_len(n_eval)) { + if (!feasible(1, X[i, ], Y[i, ])) { + warning("Hyperbolic feasibility fails at gamma = 1 for a DMU.", + call. = FALSE) + next + } + lo <- 0 + hi <- 1 + for (iter in seq_len(40L)) { + if (hi - lo < 1e-8) break + mid <- (lo + hi) / 2 + if (feasible(mid, X[i, ], Y[i, ])) { + hi <- mid + } else { + lo <- mid + } + } + gamma[i] <- hi + } + gamma +} + + +#' Hyperbolic group efficiency +#' +#' Mirrors \code{.fit_dea_group} with hyperbolic (graph) efficiency: +#' the firm is projected to (gamma * x, y / gamma) with te = gamma. +#' +#' @keywords internal +#' @noRd +.fit_hyperbolic_group <- function(formula, data, rts, ...) { + + mf <- model.frame(formula, data = data) + y_raw <- model.response(mf) + X_raw <- model.matrix(formula, data = data, rhs = 1) + + if (colnames(X_raw)[1] == "(Intercept)") { + X_raw <- X_raw[, -1, drop = FALSE] + } + + if (is.matrix(y_raw)) { + Y <- y_raw + } else { + Y <- matrix(y_raw, ncol = 1) + } + + efficiency <- .hyperbolic_batch(X_raw, Y, rts) + + list( + efficiency = efficiency, + nobs = nrow(X_raw), + rts = rts, + X = X_raw, + Y = Y + ) +} + + +#' Hyperbolic metafrontier estimation +#' +#' Mirrors \code{.estimate_dea_metafrontier}: group gammas are read +#' from the fitted group models, the meta gamma is computed against +#' the pooled reference set, and tgr = gamma_meta / gamma_group lies +#' in (0, 1] since the pooled reference set is a superset. +#' +#' @keywords internal +#' @noRd +.estimate_hyperbolic_metafrontier <- function(formula, data, group_vec, + group_levels, group_models, + rts) { + + mf <- model.frame(formula, data = data) + y_raw <- model.response(mf) + X_raw <- model.matrix(formula, data = data, rhs = 1) + if (colnames(X_raw)[1] == "(Intercept)") { + X_raw <- X_raw[, -1, drop = FALSE] + } + + if (!is.matrix(y_raw)) { + Y <- matrix(y_raw, ncol = 1) + } else { + Y <- y_raw + } + + n <- nrow(X_raw) + + # Group-level efficiency + te_group <- numeric(n) + for (g in group_levels) { + idx <- which(group_vec == g) + te_group[idx] <- group_models[[g]]$efficiency + } + + # Pooled hyperbolic efficiency (metafrontier) + te_meta <- .hyperbolic_batch(X_raw, Y, rts) + + tgr <- te_meta / te_group + + list( + meta_coef = NULL, # DEA is nonparametric + meta_vcov = NULL, + group_coef = NULL, + tgr = tgr, + te_group = te_group, + te_meta = te_meta, + group_frontier = NULL, + meta_frontier = NULL, + logLik_groups = NULL, + meta_logLik = NULL, + meta_convergence = 0L ) } diff --git a/R/metafrontier_sfa.R b/R/metafrontier_sfa.R index 812ff16..bd87b32 100644 --- a/R/metafrontier_sfa.R +++ b/R/metafrontier_sfa.R @@ -8,7 +8,10 @@ #' @noRd .estimate_sfa_metafrontier <- function(formula, data, group_vec, group_levels, group_models, - meta_type, dist, control) { + meta_type, dist, control, + objective = c("lp", "qp")) { + + objective <- match.arg(objective) n <- nrow(data) n_groups <- length(group_levels) @@ -51,7 +54,8 @@ if (meta_type == "deterministic") { meta_result <- .deterministic_metafrontier_lp( - X, group_frontier, group_vec_valid, group_levels, group_coef, k + X, group_frontier, group_vec_valid, group_levels, group_coef, k, + objective = objective ) } else { meta_result <- .stochastic_metafrontier( @@ -83,6 +87,8 @@ logLik_groups = sapply(group_models, function(m) m$logLik), meta_logLik = meta_result$meta_logLik, meta_convergence = meta_result$convergence, + meta_solver = meta_result$meta_solver, + objective = objective, meta_opt = meta_result$meta_opt, meta_dist = meta_result$meta_dist, valid_rows = valid_rows, @@ -91,76 +97,134 @@ } -#' Deterministic metafrontier via LP (Battese, Rao, O'Donnell 2004) +#' Deterministic metafrontier (Battese, Rao, O'Donnell 2004) #' -#' Minimises the sum of deviations of the metafrontier from -#' group frontiers via linear programming, subject to the +#' Estimates the deterministic metafrontier subject to the #' envelopment constraint that the metafrontier weakly dominates -#' all group frontiers at all observed input mixes. +#' all group frontiers at all observed input mixes. Battese, Rao +#' and O'Donnell (2004) propose two estimation criteria: +#' +#' 1. Minimum sum of absolute deviations. Because the envelopment +#' constraints force all deviations to be non-negative, this +#' reduces to a linear programme (O'Donnell, Rao and Battese +#' 2008, eqs. 23--25): +#' min sum_i (x_i' beta* - gf_i) [= colSums(X)' beta* - sum(gf)] +#' s.t. x_i' beta* >= gf_i for all i (envelopment) #' -#' LP formulation (BRO 2004): -#' min sum_i (x_i' beta* - gf_i) [= colSums(X)' beta* - sum(gf)] -#' s.t. x_i' beta* >= gf_i for all i (envelopment) +#' 2. Minimum sum of squared deviations, a quadratic programme: +#' min sum_i (x_i' beta* - gf_i)^2 +#' s.t. x_i' beta* >= gf_i for all i (envelopment) #' -#' Falls back to QP via constrOptim if the LP solver fails. +#' The `objective` argument selects the criterion ("lp" for the +#' first, "qp" for the second). The QP is solved with +#' quadprog::solve.QP when available, otherwise with a +#' logarithmic-barrier method via constrOptim. If the LP solver +#' fails, the estimation falls back to the QP machinery (with a +#' warning, since the criterion then changes). The `meta_solver` +#' element of the return value records which solver produced the +#' estimate: "lp", "qp" or "qp-barrier". #' #' @keywords internal #' @noRd .deterministic_metafrontier_lp <- function(X, group_frontier, group_vec, group_levels, - group_coef, k) { + group_coef, k, + objective = c("lp", "qp")) { + objective <- match.arg(objective) n <- length(group_frontier) - # ----- Primary: LP via lpSolveAPI (BRO 2004 formulation) ----- + # ----- LP via lpSolveAPI: minimum sum of absolute deviations ----- # Variables: beta* (k free variables) # Objective: min colSums(X)' beta* (constant -sum(gf) dropped) # Constraints: x_i' beta* >= gf_i for all i - lp_result <- tryCatch({ - lp <- lpSolveAPI::make.lp(nrow = n, ncol = k) - - # Set columns (variables beta*) - for (j in seq_len(k)) { - lpSolveAPI::set.column(lp, j, X[, j]) - } - - # Objective: min sum_i x_i' beta* = colSums(X)' beta* - lpSolveAPI::set.objfn(lp, colSums(X)) - lpSolveAPI::lp.control(lp, sense = "min") - - # Constraints: x_i' beta* >= gf_i - for (i in seq_len(n)) { - lpSolveAPI::set.constr.type(lp, type = ">=", constraints = i) - lpSolveAPI::set.rhs(lp, b = group_frontier[i], constraints = i) - } + if (objective == "lp") { + lp_result <- tryCatch({ + lp <- lpSolveAPI::make.lp(nrow = n, ncol = k) + + # Set columns (variables beta*) + for (j in seq_len(k)) { + lpSolveAPI::set.column(lp, j, X[, j]) + } + + # Objective: min sum_i x_i' beta* = colSums(X)' beta* + lpSolveAPI::set.objfn(lp, colSums(X)) + lpSolveAPI::lp.control(lp, sense = "min") + + # Constraints: x_i' beta* >= gf_i + for (i in seq_len(n)) { + lpSolveAPI::set.constr.type(lp, type = ">=", constraints = i) + lpSolveAPI::set.rhs(lp, b = group_frontier[i], constraints = i) + } + + # beta* variables are free (unbounded) + for (j in seq_len(k)) { + lpSolveAPI::set.bounds(lp, lower = -1e30, upper = 1e30, columns = j) + } + + status <- lpSolveAPI::solve.lpExtPtr(lp) + if (status != 0L) stop("lpSolveAPI returned status ", status) + + meta_coef <- lpSolveAPI::get.variables(lp) + names(meta_coef) <- colnames(X) + + list( + meta_coef = meta_coef, + meta_vcov = NULL, + meta_logLik = NULL, + convergence = 0L, + meta_solver = "lp" + ) + }, error = function(e) { + warning("LP solver failed (", conditionMessage(e), + "); falling back to quadratic programming. Note that the ", + "estimation objective then changes from minimum absolute ", + "deviations to minimum squared deviations.", call. = FALSE) + NULL + }) - # beta* variables are free (unbounded) - for (j in seq_len(k)) { - lpSolveAPI::set.bounds(lp, lower = -1e30, upper = 1e30, columns = j) - } + if (!is.null(lp_result)) return(lp_result) + } - status <- lpSolveAPI::solve.lpExtPtr(lp) - if (status != 0L) stop("lpSolveAPI returned status ", status) + # ----- QP: minimum sum of squared deviations ----- + # min sum((X b - gf)^2) = b' X'X b - 2 gf' X b + const, so the + # quadprog form uses Dmat = X'X and dvec = X'gf (the factor-of-two + # scaling does not change the argmin). + if (requireNamespace("quadprog", quietly = TRUE)) { + qp_result <- tryCatch({ + sol <- quadprog::solve.QP( + Dmat = crossprod(X), + dvec = crossprod(X, group_frontier), + Amat = t(X), + bvec = group_frontier, + meq = 0 + ) - meta_coef <- lpSolveAPI::get.variables(lp) - names(meta_coef) <- colnames(X) + meta_coef <- sol$solution + names(meta_coef) <- colnames(X) - list( - meta_coef = meta_coef, - meta_vcov = NULL, - meta_logLik = NULL, - convergence = 0L - ) - }, error = function(e) { - warning("LP solver failed (", conditionMessage(e), - "); falling back to QP via constrOptim.", call. = FALSE) - NULL - }) + list( + meta_coef = meta_coef, + meta_vcov = NULL, + meta_logLik = NULL, + convergence = 0L, + meta_solver = "qp" + ) + }, error = function(e) { + message("quadprog::solve.QP failed (", conditionMessage(e), + "); solving the QP with a logarithmic-barrier method via ", + "constrOptim instead.") + NULL + }) - if (!is.null(lp_result)) return(lp_result) + if (!is.null(qp_result)) return(qp_result) + } else { + message("Package 'quadprog' is not installed; solving the QP with a ", + "logarithmic-barrier method via constrOptim instead.") + } - # ----- Fallback: QP via constrOptim ----- + # ----- Fallback: QP via constrOptim (logarithmic barrier) ----- obj_fn <- function(beta_star) { fitted_meta <- X %*% beta_star sum((fitted_meta - group_frontier)^2) @@ -200,16 +264,27 @@ ui <- X ci <- group_frontier - result <- constrOptim( - theta = beta_start, - f = obj_fn, - grad = grad_fn, - ui = ui, - ci = ci - 1e-6, - method = "BFGS", - control = list(maxit = 10000, reltol = 1e-12) + result <- tryCatch( + constrOptim( + theta = beta_start, + f = obj_fn, + grad = grad_fn, + ui = ui, + ci = ci - 1e-6, + method = "BFGS", + control = list(maxit = 10000, reltol = 1e-12) + ), + error = function(e) { + stop("Deterministic metafrontier QP (barrier) optimisation failed: ", + conditionMessage(e), call. = FALSE) + } ) + if (result$convergence != 0L) { + warning("Deterministic metafrontier QP (barrier) optimisation did not ", + "converge (code ", result$convergence, ").", call. = FALSE) + } + meta_coef <- result$par names(meta_coef) <- colnames(X) @@ -217,7 +292,8 @@ meta_coef = meta_coef, meta_vcov = NULL, meta_logLik = NULL, - convergence = result$convergence + convergence = result$convergence, + meta_solver = "qp-barrier" ) } diff --git a/R/methods.R b/R/methods.R index 597d84d..f6a2382 100644 --- a/R/methods.R +++ b/R/methods.R @@ -1,5 +1,11 @@ #' Print a Metafrontier Object #' +#' Prints a compact overview of a fitted metafrontier model: the +#' estimation method and metafrontier type, the efficiency estimator +#' and identification objective (where applicable), the groups and +#' their sample sizes, group log-likelihoods, mean technology gap +#' ratio by group, and a one-line convergence status. +#' #' @param x a \code{"metafrontier"} object. #' @param ... additional arguments (currently unused). #' @return Invisibly returns \code{x}. @@ -13,6 +19,12 @@ print.metafrontier <- function(x, ...) { cat("------------------\n") cat("Method: ", x$method, "\n") cat("Metafrontier: ", x$meta_type, "\n") + if (!is.null(x$estimator)) { + cat("Estimator: ", x$estimator, "\n") + } + if (!is.null(x$objective)) { + cat("Objective: ", x$objective, "\n") + } cat("Groups: ", paste(x$groups, collapse = ", "), "\n") cat("Total obs: ", x$nobs["total"], "\n") @@ -34,15 +46,62 @@ print.metafrontier <- function(x, ...) { cat(" ", g, ": ", format(mean(x$tgr[idx]), digits = 4), "\n", sep = "") } + conv <- tryCatch(.convergence_table(x), error = function(e) NULL) + if (!is.null(conv)) { + bad <- conv$stage[which(!conv$converged)] + if (length(bad) == 0L) { + cat("\nConvergence: OK\n") + } else { + cat("\nConvergence: WARNING (", paste(bad, collapse = ", "), ")\n", + sep = "") + } + } + invisible(x) } #' Summary of a Metafrontier Model #' +#' Computes group-level summaries of technical efficiency (TE), +#' technology gap ratio (TGR), and metafrontier efficiency (TE*), +#' full coefficient tables for each group frontier (including +#' variance parameters and, for BC92 panels, \code{eta}, all with +#' standard errors where a Hessian is available), the metafrontier +#' coefficient table (with Murphy-Topel corrected standard errors +#' where applicable), and a per-stage convergence table. +#' #' @param object a \code{"metafrontier"} object. #' @param ... additional arguments (currently unused). -#' @return An object of class \code{"summary.metafrontier"}. +#' @return An object of class \code{"summary.metafrontier"}: a list +#' with components +#' \describe{ +#' \item{call}{the matched call of the original fit} +#' \item{method}{estimation method (\code{"sfa"} or \code{"dea"})} +#' \item{meta_type}{metafrontier type (\code{"deterministic"} or +#' \code{"stochastic"})} +#' \item{groups}{character vector of group labels} +#' \item{nobs}{named vector of observation counts (total and per +#' group)} +#' \item{group_tables}{named list of coefficient matrices, one per +#' group, with columns \code{Estimate}, \code{Std. Error}, +#' \code{z value}, and \code{Pr(>|z|)} where standard errors are +#' available (empty list for DEA fits)} +#' \item{meta_table}{metafrontier coefficient matrix in the same +#' format, or \code{NULL} for DEA fits} +#' \item{tgr_summary}{data frame of TGR statistics by group, as +#' returned by \code{\link{tgr_summary}}} +#' \item{efficiency_summary}{data frame with mean TE, mean TGR, +#' and mean TE* by group} +#' \item{logLik_groups}{named vector of group log-likelihoods, or +#' \code{NULL}} +#' \item{meta_logLik}{Stage 2 log-likelihood of the stochastic +#' metafrontier, or \code{NULL}} +#' \item{convergence}{data frame with columns \code{stage}, +#' \code{code}, and \code{converged} recording the optimiser +#' status of each estimation stage, or \code{NULL} if +#' unavailable; see \code{\link{check_convergence}}} +#' } #' @examples #' sim <- simulate_metafrontier(n_groups = 2, n_per_group = 50, seed = 42) #' fit <- metafrontier(log_y ~ log_x1 + log_x2, data = sim$data, @@ -52,12 +111,34 @@ print.metafrontier <- function(x, ...) { #' @export summary.metafrontier <- function(object, ...) { - # Group coefficient tables with SEs (SFA only) + # Group coefficient tables with SEs (SFA only). Internally fitted + # groups report the full MLE parameter vector (raw parameterisation: + # log_sigma_v, log_sigma_u, mu, eta, ...) so that auxiliary + # parameters such as eta (BC92) are visible with standard errors. group_tables <- list() if (object$method != "dea") { for (g in object$groups) { gm <- object$group_models[[g]] - if (!is.null(gm$hessian)) { + if (!is.null(gm$all_params) && !is.null(gm$hessian)) { + est <- gm$all_params + vcov_g <- tryCatch( + solve(-gm$hessian), + error = function(e) NULL + ) + if (!is.null(vcov_g) && nrow(vcov_g) == length(est)) { + se <- sqrt(pmax(diag(vcov_g), 0)) + } else { + se <- rep(NA_real_, length(est)) + } + zval <- est / se + pval <- 2 * pnorm(-abs(zval)) + group_tables[[g]] <- cbind( + Estimate = est, + `Std. Error` = se, + `z value` = zval, + `Pr(>|z|)` = pval + ) + } else if (!is.null(gm$hessian)) { vcov_g <- tryCatch( solve(-gm$hessian), error = function(e) NULL @@ -119,6 +200,12 @@ summary.metafrontier <- function(object, ...) { ) })) + # Per-stage convergence status + conv_tab <- tryCatch(.convergence_table(object), error = function(e) NULL) + if (!is.null(conv_tab)) { + conv_tab <- conv_tab[, c("stage", "code", "converged")] + } + out <- list( call = object$call, method = object$method, @@ -130,7 +217,8 @@ summary.metafrontier <- function(object, ...) { tgr_summary = tgr_tab, efficiency_summary = eff_tab, logLik_groups = object$logLik_groups, - meta_logLik = object$meta_logLik + meta_logLik = object$meta_logLik, + convergence = conv_tab ) class(out) <- "summary.metafrontier" out @@ -196,14 +284,54 @@ print.summary.metafrontier <- function(x, digits = 4, ...) { tgr_print[, -1] <- round(tgr_print[, -1], digits) print(tgr_print, row.names = FALSE) + # Convergence status + if (!is.null(x$convergence)) { + cat("\n--- Convergence ---\n") + bad <- which(!x$convergence$converged) + if (length(bad) == 0L) { + cat("All estimation stages converged.\n") + } else { + print(x$convergence[bad, , drop = FALSE], row.names = FALSE) + cat("See ?check_convergence.\n") + } + } + cat("\n") invisible(x) } +#' Extract Coefficients from a Metafrontier Model +#' +#' @param object a \code{"metafrontier"} object. +#' @param which character. \code{"meta"} (default) returns the +#' metafrontier coefficients; \code{"group"} returns a named list +#' of group-specific coefficient vectors. +#' @param extraPar logical. If \code{TRUE}, auxiliary parameters are +#' included alongside the frontier coefficients. For +#' \code{which = "group"} the variance parameters are +#' back-transformed to their natural scale (\code{sigmaV}, +#' \code{sigmaU}), \code{mu} and \code{eta} are kept as estimated, +#' and heteroscedastic Z coefficients are labelled with their +#' column names. For \code{which = "meta"} the Stage 2 variance +#' parameters are appended for stochastic metafrontiers. +#' @param ... additional arguments (currently unused). +#' +#' @return A named numeric vector (\code{which = "meta"}) or a named +#' list of numeric vectors (\code{which = "group"}). +#' +#' @examples +#' sim <- simulate_metafrontier(n_groups = 2, n_per_group = 50, seed = 42) +#' fit <- metafrontier(log_y ~ log_x1 + log_x2, data = sim$data, +#' group = "group", meta_type = "stochastic") +#' coef(fit) +#' coef(fit, extraPar = TRUE) +#' coef(fit, which = "group", extraPar = TRUE) +#' #' @export coef.metafrontier <- function(object, which = c("meta", "group"), + extraPar = FALSE, ...) { which <- match.arg(which) if (object$method == "dea") { @@ -211,24 +339,108 @@ coef.metafrontier <- function(object, "(nonparametric model).", call. = FALSE) } if (which == "meta") { - object$meta_coef - } else { - object$group_coef + if (!extraPar) return(object$meta_coef) + if (identical(object$meta_type, "stochastic") && + !is.null(object$meta_opt)) { + pars <- object$meta_opt$par + k <- length(object$meta_coef) + extra <- .relabel_extra_params(pars[-seq_len(k)]) + return(c(object$meta_coef, extra)) + } + message("No auxiliary parameters exist for this metafrontier; ", + "returning the frontier coefficients only.") + return(object$meta_coef) } + + # which == "group" + if (!extraPar) return(object$group_coef) + + missing_extra <- vapply(object$group_models, + function(gm) is.null(gm$all_params), + logical(1)) + if (any(missing_extra)) { + warning("Extra parameters are unavailable for externally fitted ", + "groups (", + paste(object$groups[missing_extra], collapse = ", "), + "); returning their frontier coefficients only.", + call. = FALSE) + } + + out <- lapply(object$groups, function(g) { + gm <- object$group_models[[g]] + if (is.null(gm$all_params)) return(gm$coefficients) + params <- gm$all_params + if (!is.null(gm$Z)) { + idx_z <- grep("^d_[0-9]+$", names(params)) + if (length(idx_z) == ncol(gm$Z)) { + names(params)[idx_z] <- colnames(gm$Z) + } + } + .relabel_extra_params(params) + }) + names(out) <- object$groups + out +} + + +#' Back-transform and rename raw MLE variance parameters +#' +#' Replaces \code{log_sigma_v}/\code{log_sigma_u} with +#' \code{sigmaV}/\code{sigmaU} on the natural scale; all other +#' entries (frontier coefficients, mu, eta, Z coefficients) pass +#' through unchanged. +#' +#' @keywords internal +#' @noRd +.relabel_extra_params <- function(params) { + nm <- names(params) + sv <- nm == "log_sigma_v" + su <- nm == "log_sigma_u" + params[sv] <- exp(params[sv]) + params[su] <- exp(params[su]) + nm[sv] <- "sigmaV" + nm[su] <- "sigmaU" + names(params) <- nm + params } #' Variance-Covariance Matrix for Metafrontier Coefficients #' +#' Returns the variance-covariance matrix of the Stage 2 +#' (metafrontier) coefficients, or, with \code{which = "group"}, the +#' per-group matrices from the Stage 1 maximum likelihood fits. +#' \code{NULL} is returned when no Stage 2 Hessian exists: the +#' deterministic metafrontier is fitted by LP/QP optimisation and has +#' no sampling variance in this framework, so \code{which = "meta"} +#' returns \code{NULL} with a warning; with \code{which = "group"}, +#' list entries are \code{NULL} for groups without a stored Hessian +#' (e.g. externally fitted models). DEA-based metafrontiers are +#' nonparametric and \code{vcov()} signals an error; use +#' \code{\link{boot_tgr}} for inference instead. +#' #' @param object a \code{"metafrontier"} object. #' @param correction character. \code{"none"} (default) returns the #' Stage 2 variance-covariance matrix. \code{"murphy-topel"} applies #' the Murphy and Topel (1985) correction for first-stage estimation #' uncertainty (the generated-regressor problem). Only available for #' stochastic metafrontiers. +#' @param which character. \code{"meta"} (default) returns the +#' metafrontier (Stage 2) variance-covariance matrix; +#' \code{"group"} returns a named list with one full +#' variance-covariance matrix per group (from the inverse negative +#' Hessian of the group MLE), with \code{NULL} entries for groups +#' without a stored Hessian. +#' @param extraPar logical. If \code{TRUE} and \code{which = "meta"}, +#' the full Stage 2 matrix is returned, including the rows and +#' columns for the auxiliary parameters (raw MLE parameterisation, +#' e.g. \code{log_sigma_v}); the default returns only the block for +#' the frontier coefficients. #' @param ... additional arguments (currently unused). #' -#' @return A variance-covariance matrix, or \code{NULL} if unavailable. +#' @return A variance-covariance matrix (\code{which = "meta"}), a +#' named list of matrices (\code{which = "group"}), or \code{NULL} +#' if unavailable. #' #' @references Murphy, K.M. and Topel, R.H. (1985). Estimation and #' inference in two-step econometric models. \emph{Journal of @@ -246,14 +458,31 @@ coef.metafrontier <- function(object, #' @export vcov.metafrontier <- function(object, correction = c("none", "murphy-topel"), + which = c("meta", "group"), + extraPar = FALSE, ...) { correction <- match.arg(correction) + which <- match.arg(which) if (object$method == "dea") { stop("vcov() is not available for DEA-based metafrontiers ", "(nonparametric model).", call. = FALSE) } + if (which == "group") { + out <- lapply(object$group_models, function(gm) { + if (is.null(gm$hessian)) return(NULL) + v <- tryCatch(solve(-gm$hessian), error = function(e) NULL) + if (!is.null(v) && !is.null(gm$all_params) && + nrow(v) == length(gm$all_params)) { + rownames(v) <- colnames(v) <- names(gm$all_params) + } + v + }) + names(out) <- object$groups + return(out) + } + k <- length(object$meta_coef) if (correction == "murphy-topel") { @@ -270,9 +499,7 @@ vcov.metafrontier <- function(object, if (is.null(v)) { warning("Murphy-Topel correction failed; returning uncorrected ", "variance-covariance matrix.", call. = FALSE) - v <- object$meta_vcov[seq_len(k), seq_len(k)] - } else { - v <- v[seq_len(k), seq_len(k)] + v <- object$meta_vcov } } else { if (is.null(object$meta_vcov)) { @@ -281,9 +508,18 @@ vcov.metafrontier <- function(object, call. = FALSE) return(NULL) } - v <- object$meta_vcov[seq_len(k), seq_len(k)] + v <- object$meta_vcov + } + + if (extraPar) { + if (!is.null(object$meta_opt) && + length(object$meta_opt$par) == nrow(v)) { + rownames(v) <- colnames(v) <- names(object$meta_opt$par) + } + return(v) } + v <- v[seq_len(k), seq_len(k), drop = FALSE] rownames(v) <- colnames(v) <- names(object$meta_coef) v } diff --git a/R/model_extractors.R b/R/model_extractors.R index 0fb280d..5ee6561 100644 --- a/R/model_extractors.R +++ b/R/model_extractors.R @@ -2,16 +2,33 @@ #' #' Generic function that extracts the components needed by #' \code{\link{metafrontier}} from a pre-fitted frontier model. -#' Methods are provided for \pkg{sfaR}, \pkg{frontier}, and -#' \pkg{Benchmarking} objects, as well as plain lists with the +#' Methods are provided for \pkg{sfaR} (\code{"sfacross"}), +#' \pkg{frontier} (\code{"frontier"}), and \pkg{Benchmarking} +#' (\code{"Farrell"}) objects, as well as plain lists with the #' required fields. #' #' @param x a fitted frontier model object. #' @param ... additional arguments passed to methods. #' -#' @return A list with components: \code{coefficients}, \code{efficiency}, -#' \code{X}, \code{y}, \code{sigma_v}, \code{sigma_u}, \code{logLik}, -#' \code{hessian}, \code{n}, \code{dist}. +#' @return A list of class \code{"metafrontier_model"} with components: +#' \code{beta}, \code{te}, \code{X}, \code{y}, \code{sigma_v}, +#' \code{sigma_u}, \code{logLik}, \code{hessian}, \code{n}, +#' \code{dist}. +#' +#' @details +#' \code{metafrontier(models = ...)} calls this function internally on +#' each supplied model, so fitted \pkg{sfaR} or \pkg{frontier} objects +#' can be passed to \code{metafrontier()} directly. Manual conversion +#' is only needed for hand-built list models. Converting an object that +#' has already been converted is a no-op, so it is safe to pass +#' converted objects to \code{metafrontier()} as well. +#' +#' Note that \code{Benchmarking::dea()} (\code{"Farrell"}) objects do +#' not store the inputs, outputs, or frontier coefficients, so the +#' converted model carries only efficiency scores and cannot be used +#' with \code{metafrontier(models = ...)}; use the formula interface +#' with \code{method = "dea"} instead. Converting a Farrell object +#' therefore raises a warning. #' #' @examples #' # Using a named list: @@ -29,21 +46,31 @@ as_metafrontier_model <- function(x, ...) { } +#' @export +as_metafrontier_model.metafrontier_model <- function(x, ...) { + x +} + + #' @export as_metafrontier_model.sfacross <- function(x, ...) { - .extract_sfacross(x) + structure(.extract_sfacross(x), class = "metafrontier_model") } #' @export -as_metafrontier_model.sfa <- function(x, ...) { - .extract_frontier_sfa(x) +as_metafrontier_model.frontier <- function(x, ...) { + structure(.extract_frontier(x), class = "metafrontier_model") } #' @export as_metafrontier_model.Farrell <- function(x, ...) { - .extract_benchmarking(x) + warning("Farrell (Benchmarking) objects do not store inputs, outputs, ", + "or frontier coefficients; the converted model cannot be used ", + "with metafrontier(models = ...). Use the formula interface ", + "with method = \"dea\" instead.", call. = FALSE) + structure(.extract_benchmarking(x), class = "metafrontier_model") } @@ -55,7 +82,7 @@ as_metafrontier_model.list <- function(x, ...) { stop("List is missing required fields: ", paste(missing_fields, collapse = ", "), ".", call. = FALSE) } - list( + structure(list( beta = x$coefficients, te = x$efficiency, X = x$X, @@ -66,19 +93,64 @@ as_metafrontier_model.list <- function(x, ...) { hessian = x$hessian, n = length(x$y), dist = if (is.null(x$dist)) "hnormal" else x$dist - ) + ), class = "metafrontier_model") } #' @export as_metafrontier_model.default <- function(x, ...) { stop("Unsupported model class: ", paste(class(x), collapse = ", "), - ". Supported: sfaR::sfacross, frontier::sfa, Benchmarking::dea, ", - "or a named list with 'coefficients', 'efficiency', 'X', and 'y'.", + ". Supported: 'sfacross' (sfaR::sfacross), 'frontier' ", + "(frontier::sfa), 'Farrell' (Benchmarking::dea), or a named ", + "list with 'coefficients', 'efficiency', 'X', and 'y'.", call. = FALSE) } +#' Extract from frontier::sfa object +#' +#' frontier::sfa() returns an object of class "frontier" whose +#' dataTable matrix holds id, t, and y in the first three columns +#' followed by the model matrix, and whose mleParam vector holds the +#' nb frontier coefficients followed by sigmaSq and gamma. +#' @keywords internal +#' @noRd +.extract_frontier <- function(model) { + if (!requireNamespace("frontier", quietly = TRUE)) { + stop("Package 'frontier' is required to extract from frontier objects.", + call. = FALSE) + } + + all_coef <- model$mleParam + n_beta <- model$nb + beta <- all_coef[seq_len(n_beta)] + + te <- as.numeric(frontier::efficiencies(model)) + + dat <- model$dataTable + y <- as.numeric(dat[, 3]) + X <- dat[, 3 + seq_len(n_beta), drop = FALSE] + + sigma_sq <- all_coef["sigmaSq"] + gamma <- all_coef["gamma"] + sigma_v <- sqrt(sigma_sq * (1 - gamma)) + sigma_u <- sqrt(sigma_sq * gamma) + + list( + beta = beta, + te = te, + X = X, + y = y, + sigma_v = as.numeric(sigma_v), + sigma_u = as.numeric(sigma_u), + logLik = model$mleLogl, + hessian = NULL, + n = length(y), + dist = "hnormal" + ) +} + + #' Extract from Benchmarking::dea object #' @keywords internal #' @noRd diff --git a/R/sfa_estimation.R b/R/sfa_estimation.R index 293fd5c..22f930a 100644 --- a/R/sfa_estimation.R +++ b/R/sfa_estimation.R @@ -12,15 +12,22 @@ #' @param dist distribution of the inefficiency term. #' @param control list of control parameters. #' @param ... additional arguments. +#' @param estimator character. Technical efficiency estimator: +#' \code{"bc88"} (Battese and Coelli, 1988; \code{E[exp(-u)|eps]}) +#' or \code{"jlms"} (Jondrow et al., 1982; \code{exp(-E[u|eps])}). #' #' @return A list with components: coefficients, sigma_v, sigma_u, -#' logLik, efficiency, fitted, residuals, hessian, convergence. +#' logLik, efficiency, efficiency_jlms, efficiency_bc88, estimator, +#' fitted, residuals, hessian, convergence. #' When Z variables are present, also includes delta, Z, and #' optionally sigma_u_vec or mu_vec. #' #' @keywords internal #' @noRd -.fit_sfa_group <- function(formula, data, dist, control, ...) { +.fit_sfa_group <- function(formula, data, dist, control, ..., + estimator = c("bc88", "jlms")) { + + estimator <- match.arg(estimator) # Build model frame from the full Formula if (inherits(formula, "Formula")) { @@ -174,6 +181,7 @@ sigma_u_vec <- exp(as.numeric(Z %*% delta)) sigma_u <- mean(sigma_u_vec) mu_star <- -as.numeric(eps) - sigma_v^2 / sigma_u_vec + sigma_star <- sigma_v u_hat <- mu_star + sigma_v * .mills(mu_star / sigma_v) } else if (dist == "tnormal") { mu_vec <- as.numeric(Z %*% delta) @@ -197,6 +205,7 @@ u_hat <- mu_star + sigma_star * .mills(mu_star / sigma_star) } else if (dist == "exponential") { mu_star <- -as.numeric(eps) - sigma_v^2 / sigma_u + sigma_star <- sigma_v u_hat <- mu_star + sigma_v * .mills(mu_star / sigma_v) } else if (dist == "tnormal") { mu_val <- opt$par["mu"] @@ -212,7 +221,23 @@ u_hat <- pmax(as.numeric(u_hat), 0) # JLMS (Jondrow et al., 1982) point efficiency: exp(-E[u|eps]) - te <- as.numeric(exp(-u_hat)) + te_jlms <- as.numeric(exp(-u_hat)) + + # BC88 (Battese and Coelli, 1988) point efficiency: E[exp(-u)|eps] + # = exp(-mu* + sigma*^2/2) * Phi(mu*/sigma* - sigma*) / Phi(mu*/sigma*) + # For the exponential distribution sigma* is sigma_v (set in the + # branches above). Where Phi(mu*/sigma*) underflows to zero the ratio + # is indeterminate; those observations fall back to the JLMS value. + bc_ratio <- as.numeric(mu_star) / sigma_star + bc_denom <- pnorm(bc_ratio) + te_bc88 <- as.numeric( + exp(-as.numeric(mu_star) + 0.5 * sigma_star^2) * + pnorm(bc_ratio - sigma_star) / bc_denom + ) + bc_bad <- !is.finite(te_bc88) | bc_denom == 0 + te_bc88[bc_bad] <- te_jlms[bc_bad] + + te <- if (estimator == "bc88") te_bc88 else te_jlms # Frontier values fitted_vals <- as.numeric(X %*% beta_hat) @@ -226,6 +251,9 @@ lambda = lambda, logLik = opt$value, efficiency = te, + efficiency_jlms = te_jlms, + efficiency_bc88 = te_bc88, + estimator = estimator, inefficiency = as.numeric(u_hat), fitted = fitted_vals, residuals = as.numeric(eps), @@ -251,6 +279,16 @@ # ==== Homoscedastic log-likelihoods (no Z) ==== +# Parameter-vector layout convention (all likelihoods below): +# params = c(beta[1:k], log_sigma_v, ), +# where the tail is log_sigma_u (half-normal, exponential), +# mu then log_sigma_u (truncated-normal), or delta[1:p] followed by +# log_sigma_u where Z variables enter. + +# Normal/half-normal composed error eps = v - u, u ~ |N(0, sigma_u^2)|: +# log f(eps) = log 2 - log sigma + log phi(eps/sigma) +# + log Phi(-eps*lambda/sigma), sigma^2 = sigma_v^2 + sigma_u^2, +# lambda = sigma_u/sigma_v. Aigner, Lovell and Schmidt (1977, Eq. 8). #' @noRd .loglik_hnormal <- function(params, y, X) { k <- ncol(X) @@ -275,6 +313,11 @@ result } +# Normal/truncated-normal, u ~ N+(mu, sigma_u^2): +# log f(eps) = log phi((eps + mu)/sigma) - log sigma +# + log Phi(mu*/sigma*) - log Phi(mu/sigma_u), +# with mu* = (mu*sigma_v^2 - eps*sigma_u^2)/sigma^2 and +# sigma* = sigma_v*sigma_u/sigma. Stevenson (1980, Eq. 15). #' @noRd .loglik_tnormal <- function(params, y, X) { k <- ncol(X) @@ -302,6 +345,10 @@ result } +# Normal/exponential, u ~ Exp(rate = 1/sigma_u): +# log f(eps) = -log sigma_u + eps/sigma_u + sigma_v^2/(2*sigma_u^2) +# + log Phi(-(eps + sigma_v^2/sigma_u)/sigma_v). +# Meeusen and van den Broeck (1977). #' @noRd .loglik_exponential <- function(params, y, X) { k <- ncol(X) @@ -324,6 +371,9 @@ # ==== Heteroscedastic log-likelihoods (with Z) ==== +# Same densities as above with the distribution parameter made +# observation-specific: sigma_u_i = exp(Z_i' delta) for half-normal and +# exponential, mu_i = Z_i' delta for truncated-normal. #' Half-normal with observation-specific sigma_u_i = exp(Z_i' delta) #' @noRd diff --git a/R/sfa_panel.R b/R/sfa_panel.R index 8e88d31..45b319b 100644 --- a/R/sfa_panel.R +++ b/R/sfa_panel.R @@ -2,7 +2,8 @@ #' #' Fits a panel SFA model to a single group using MLE. #' Implements BC92 (Battese and Coelli, 1992) with time-varying -#' inefficiency: u_it = u_i * exp(-eta*(t-T_i)) where u_i ~ |N(0, sigma_u^2)|. +#' inefficiency: u_it = u_i * exp(-eta*(t - T)) where T is the global +#' final period and u_i ~ |N(0, sigma_u^2)|. #' Also implements BC95 (Battese and Coelli, 1995) with observation-specific #' mean: u_it ~ N+(z_it'delta, sigma_u^2). #' @@ -13,6 +14,9 @@ #' @param panel_info list with id and time column names. #' @param control list of control parameters. #' @param ... additional arguments. +#' @param estimator character. Technical efficiency estimator: +#' \code{"bc88"} (Battese and Coelli, 1988; \code{E[exp(-u)|eps]}) +#' or \code{"jlms"} (Jondrow et al., 1982; \code{exp(-E[u|eps])}). #' #' @return A list compatible with .fit_sfa_group output plus panel fields. #' @keywords internal @@ -25,7 +29,10 @@ } .fit_sfa_panel_group <- function(formula, data, dist, panel_dist, - panel_info, control, ...) { + panel_info, control, ..., + estimator = c("bc88", "jlms")) { + + estimator <- match.arg(estimator) id_col <- panel_info$id time_col <- panel_info$time @@ -35,10 +42,8 @@ "' not found in data.", call. = FALSE) } - # Sort by (firm, time) for clean panel structure - data <- data[order(data[[id_col]], data[[time_col]]), ] - - # Build model matrices + # Build model matrices (input row order is preserved throughout so + # that returned vectors align with the caller's data) if (inherits(formula, "Formula")) { f <- formula has_z <- length(f)[2] >= 2L @@ -67,9 +72,15 @@ n <- length(y) k <- ncol(X) - # Panel structure + # Panel structure; drop any rows removed from the model frame by + # na.omit so that firms/times stay aligned with y and X firms <- data[[id_col]] times <- data[[time_col]] + na_act <- attr(mf, "na.action") + if (!is.null(na_act)) { + firms <- firms[-na_act] + times <- times[-na_act] + } firm_ids <- unique(firms) n_firms <- length(firm_ids) @@ -78,13 +89,10 @@ T_i <- sapply(firm_idx, length) # periods per firm T_max <- max(times) - # Time index relative to T_i for BC92 - t_rel <- numeric(n) - for (ff in seq_along(firm_ids)) { - idx <- firm_idx[[ff]] - T_f <- max(times[idx]) - t_rel[idx] <- times[idx] - T_f # t - T_i (negative or zero) - } + # Time index relative to the global final period T for BC92: + # u_it = u_i * exp(-eta * (t - T)), matching the unbalanced-panel + # formulation of Battese and Coelli (1992) + t_rel <- times - T_max # OLS starting values ols <- lm.fit(X, y) @@ -130,12 +138,22 @@ ctrl <- list(fnscale = -1, maxit = 5000, reltol = 1e-10) ctrl[names(control)] <- control - opt <- optim( - par = start_params, - fn = loglik_fn, - method = "BFGS", - control = ctrl, - hessian = TRUE + opt <- tryCatch( + optim(par = start_params, fn = loglik_fn, + method = "BFGS", control = ctrl, hessian = TRUE), + error = function(e) { + tryCatch( + optim(par = start_params, fn = loglik_fn, + method = "Nelder-Mead", + control = list(fnscale = -1, maxit = 10000), + hessian = TRUE), + error = function(e2) { + stop("MLE optimisation failed. The data may have too few ", + "observations or extreme values. Original error: ", + conditionMessage(e), call. = FALSE) + } + ) + } ) if (opt$convergence != 0) { @@ -154,11 +172,14 @@ if (panel_dist == "bc92") { eta <- opt$par["eta"] - # JLMS-style conditional mean for BC92 - # E[u_i | eps_i1, ..., eps_iT] + # Conditional efficiency for BC92, both JLMS-style and the + # Battese-Coelli (1992) closed form eps <- y - fitted_vals - te <- .bc92_efficiency(eps, sigma_v, sigma_u, eta, - firms, firm_idx, T_i, t_rel) + te_list <- .bc92_efficiency(eps, sigma_v, sigma_u, eta, + firms, firm_idx, T_i, t_rel) + te_jlms <- te_list$jlms + te_bc88 <- te_list$bc88 + te <- if (estimator == "bc88") te_bc88 else te_jlms result <- list( coefficients = beta, @@ -167,6 +188,9 @@ eta = as.numeric(eta), logLik = opt$value, efficiency = te, + efficiency_jlms = te_jlms, + efficiency_bc88 = te_bc88, + estimator = estimator, fitted = fitted_vals, residuals = eps, hessian = opt$hessian, @@ -196,7 +220,21 @@ sigma_star <- sigma_v * sigma_u / sqrt(sigma_sq) u_hat <- mu_star + sigma_star * .safe_mills(mu_star / sigma_star) - te <- exp(-u_hat) + te_jlms <- as.numeric(exp(-u_hat)) + + # BC88 (Battese and Coelli, 1988): E[exp(-u)|eps]. Where + # Phi(mu*/sigma*) underflows to zero the ratio is indeterminate; + # those observations fall back to the JLMS value. + bc_ratio <- mu_star / sigma_star + bc_denom <- pnorm(bc_ratio) + te_bc88 <- as.numeric( + exp(-mu_star + 0.5 * sigma_star^2) * + pnorm(bc_ratio - sigma_star) / bc_denom + ) + bc_bad <- !is.finite(te_bc88) | bc_denom == 0 + te_bc88[bc_bad] <- te_jlms[bc_bad] + + te <- if (estimator == "bc88") te_bc88 else te_jlms result <- list( coefficients = beta, @@ -204,7 +242,10 @@ sigma_u = as.numeric(sigma_u), delta = delta, logLik = opt$value, - efficiency = as.numeric(te), + efficiency = te, + efficiency_jlms = te_jlms, + efficiency_bc88 = te_bc88, + estimator = estimator, fitted = fitted_vals, residuals = eps, hessian = opt$hessian, @@ -230,11 +271,18 @@ #' BC92 log-likelihood #' -#' u_it = u_i * exp(-eta*(t-T_i)), u_i ~ |N(0, sigma_u^2)| -#' Integrated over u_i (closed-form for half-normal). +#' u_it = u_i * exp(-eta*(t - T)) with T the global final period, +#' u_i ~ |N(0, sigma_u^2)|. Integrated over u_i (closed-form for +#' half-normal). #' #' @keywords internal #' @noRd +# Per-firm marginal log-density after integrating out u_i +# (Battese and Coelli, 1992, Eq. 8): +# ll_i = -T_i/2 log(2*pi) - T_i log sigma_v - sum_t eps_it^2/(2 sigma_v^2) +# + log 2 - 0.5 log(1 + sigma_u^2 sum_t d_t^2 / sigma_v^2) +# + 0.5 (mu_i*/sigma_i*)^2 + log Phi(mu_i*/sigma_i*). +# Parameter layout: params = c(beta[1:k], log_sigma_v, log_sigma_u, eta). .loglik_bc92 <- function(params, y, X, k, firms, firm_idx, T_i, t_rel) { beta <- params[seq_len(k)] @@ -289,10 +337,17 @@ # ---------- BC92 efficiency estimation ---------- +# Returns both the JLMS-style estimator exp(-E[u_i|eps] * d_t) and the +# Battese-Coelli (1992, Eq. 10) closed form +# TE_it = {Phi(mu_i*/sigma_i* - d_t*sigma_i*) / Phi(mu_i*/sigma_i*)} +# * exp(-d_t*mu_i* + 0.5*d_t^2*sigma_i*^2), +# where d_t = exp(-eta*(t - T)) and (mu_i*, sigma_i*) are the per-firm +# conditional posterior parameters of u_i. .bc92_efficiency <- function(eps, sigma_v, sigma_u, eta, firms, firm_idx, T_i, t_rel) { n <- length(eps) - te <- numeric(n) + te_jlms <- numeric(n) + te_bc88 <- numeric(n) for (ff in seq_along(firm_idx)) { idx <- firm_idx[[ff]] @@ -313,10 +368,19 @@ # u_it = u_i * exp(-eta*(t-T)) u_it <- E_ui * d_t - te[idx] <- exp(-u_it) + te_jlms[idx] <- exp(-u_it) + + # BC92 closed form; where Phi(mu*/sigma*) underflows to zero the + # ratio is indeterminate, so fall back to the JLMS value + denom <- pnorm(ratio) + te_f <- pnorm(ratio - d_t * sigma_star) / denom * + exp(-d_t * mu_star + 0.5 * d_t^2 * sigma_star2) + bad <- !is.finite(te_f) | denom == 0 + te_f[bad] <- te_jlms[idx][bad] + te_bc88[idx] <- te_f } - te + list(jlms = te_jlms, bc88 = te_bc88) } @@ -330,6 +394,11 @@ #' #' @keywords internal #' @noRd +# Observation-level log-density (Battese and Coelli, 1995): +# ll_it = log phi((eps_it + mu_it)/sigma) - log sigma +# + log Phi(mu_it*/sigma*) - log Phi(mu_it/sigma_u), +# with mu_it = z_it'delta. Parameter layout: +# params = c(beta[1:k], log_sigma_v, delta[1:p], log_sigma_u). .loglik_bc95 <- function(params, y, X, Z, k) { n <- length(y) p <- ncol(Z) diff --git a/R/simulate.R b/R/simulate.R index 495d879..2403d57 100644 --- a/R/simulate.R +++ b/R/simulate.R @@ -1,8 +1,10 @@ #' Simulate Metafrontier Data #' #' Generates synthetic data from a known metafrontier data-generating -#' process. Useful for Monte Carlo simulations, package testing, and -#' teaching. +#' process. Each group frontier lies weakly below the metafrontier, +#' consistent with groups facing different restrictions of a common +#' metatechnology (Battese, Rao and O'Donnell, 2004). Useful for Monte +#' Carlo simulations, package testing, and teaching. #' #' @param n_groups integer. Number of technology groups (default 2). #' @param n_per_group integer or integer vector. Number of observations @@ -11,11 +13,14 @@ #' @param n_inputs integer. Number of input variables (default 2). #' @param beta_meta numeric vector. Metafrontier coefficients #' (including intercept). Length must be \code{n_inputs + 1}. -#' Default: \code{c(1.0, 0.5, 0.3)}. +#' Default: \code{c(1.0, seq(0.5, 0.2, length.out = n_inputs))}, +#' i.e. \code{c(1.0, 0.5, 0.2)} for the default two inputs. Ignored +#' when \code{beta_groups} is supplied. #' @param tech_gap numeric vector of length \code{n_groups}. The #' technology gap for each group, defined as the reduction in the #' intercept relative to the metafrontier. Default: evenly spaced -#' from 0 to 0.5. +#' from 0 to 0.5. Ignored (with a warning) when \code{beta_groups} +#' is supplied. #' @param sigma_u numeric vector of length \code{n_groups}. Standard #' deviation of the half-normal inefficiency term for each group. #' Default: \code{rep(0.3, n_groups)}. @@ -23,6 +28,51 @@ #' term. Default: 0.2. #' @param seed integer or \code{NULL}. Random seed for #' reproducibility. +#' @param beta_groups optional group-specific frontier coefficients, +#' including slopes: either an \code{n_groups} x \code{(n_inputs + 1)} +#' numeric matrix (one row per group) or a list of \code{n_groups} +#' numeric vectors of length \code{n_inputs + 1}. When supplied, it +#' replaces the intercept-shift construction based on +#' \code{tech_gap}; see Details. Default \code{NULL} (intercept-shift +#' design). +#' @param input_means optional \code{n_groups} x \code{n_inputs} numeric +#' matrix of per-group mean log-input levels. When supplied, the +#' log-inputs for group \code{g} are drawn from a normal distribution +#' centred at \code{input_means[g, ]}; see Details. Default +#' \code{NULL} (identical uniform inputs across groups). +#' @param input_corr optional \code{n_inputs} x \code{n_inputs} +#' correlation matrix for the log-inputs. When supplied, the +#' log-inputs are drawn from a multivariate normal distribution with +#' this correlation structure; see Details. Default \code{NULL} +#' (independent inputs). +#' +#' @details +#' By default the group frontiers share the metafrontier slopes and +#' differ only in their intercepts, so the true technology gap ratio +#' (TGR) is constant within each group and equals +#' \code{exp(-tech_gap[g])}. When \code{beta_groups} is supplied the +#' group frontiers may differ in their slopes, in which case no single +#' log-linear metafrontier envelops all groups: the tightest log-linear +#' envelope is then a pseudo-true quantity. The returned +#' \code{true_tgr} is instead computed observation by observation +#' against the pointwise maximum over the group frontiers, +#' \eqn{TGR_i = \exp(x_i^ op eta_g - \max_j x_i^ op eta_j)}, which is +#' guaranteed to lie in (0, 1]. The true group frontier for each firm +#' is \eqn{x_i^ op eta_g}, \code{true_te} is generated exactly as in the +#' default design, and \code{true_te_star = true_te * true_tgr}. In +#' this case \code{params$beta_meta} is \code{NULL} and +#' \code{params$beta_groups} holds the supplied coefficients. +#' +#' By default the log-inputs are drawn i.i.d. from a uniform +#' distribution on \code{[0, 5]}, identically across groups. Supplying +#' \code{input_means} and/or \code{input_corr} switches to normal +#' log-inputs with standard deviation \code{5 / sqrt(12)} (matching the +#' spread of the uniform draws), centred at \code{input_means[g, ]} +#' (2.5 for every group and input when \code{input_means} is +#' \code{NULL}). When \code{input_corr} is supplied the draws are +#' multivariate normal with that correlation matrix; when it is +#' \code{NULL} but \code{input_means} is given, the inputs are drawn +#' independently. #' #' @return A list with components: #' \describe{ @@ -40,6 +90,12 @@ #' # The true metafrontier coefficients #' sim$params$beta_meta #' +#' # Group-specific slopes: per-observation true TGR +#' sim2 <- simulate_metafrontier( +#' beta_groups = rbind(c(1.0, 0.5, 0.2), c(0.9, 0.6, 0.1)) +#' ) +#' range(sim2$data$true_tgr) +#' #' @export simulate_metafrontier <- function(n_groups = 2L, n_per_group = 100L, @@ -48,24 +104,57 @@ simulate_metafrontier <- function(n_groups = 2L, tech_gap = NULL, sigma_u = NULL, sigma_v = 0.2, - seed = NULL) { + seed = NULL, + beta_groups = NULL, + input_means = NULL, + input_corr = NULL) { if (!is.null(seed)) set.seed(seed) - # Default metafrontier coefficients - if (is.null(beta_meta)) { - beta_meta <- c(1.0, seq(0.5, 0.2, length.out = n_inputs)) - } - if (length(beta_meta) != n_inputs + 1L) { - stop("'beta_meta' must have length n_inputs + 1.", call. = FALSE) - } + custom_betas <- !is.null(beta_groups) - # Default technology gaps - if (is.null(tech_gap)) { - tech_gap <- seq(0, 0.5, length.out = n_groups) - } - if (length(tech_gap) != n_groups) { - stop("'tech_gap' must have length n_groups.", call. = FALSE) + if (custom_betas) { + if (!is.null(tech_gap)) { + warning("'tech_gap' is ignored when 'beta_groups' is supplied.", + call. = FALSE) + tech_gap <- NULL + } + if (is.matrix(beta_groups)) { + if (nrow(beta_groups) != n_groups || + ncol(beta_groups) != n_inputs + 1L) { + stop("'beta_groups' must be an n_groups x (n_inputs + 1) matrix.", + call. = FALSE) + } + beta_groups <- lapply(seq_len(n_groups), + function(g) as.numeric(beta_groups[g, ])) + } else if (is.list(beta_groups)) { + if (length(beta_groups) != n_groups || + !all(lengths(beta_groups) == n_inputs + 1L)) { + stop("'beta_groups' must be a list of n_groups vectors of length n_inputs + 1.", + call. = FALSE) + } + beta_groups <- lapply(beta_groups, as.numeric) + } else { + stop("'beta_groups' must be a matrix or a list of numeric vectors.", + call. = FALSE) + } + beta_meta <- NULL + } else { + # Default metafrontier coefficients + if (is.null(beta_meta)) { + beta_meta <- c(1.0, seq(0.5, 0.2, length.out = n_inputs)) + } + if (length(beta_meta) != n_inputs + 1L) { + stop("'beta_meta' must have length n_inputs + 1.", call. = FALSE) + } + + # Default technology gaps + if (is.null(tech_gap)) { + tech_gap <- seq(0, 0.5, length.out = n_groups) + } + if (length(tech_gap) != n_groups) { + stop("'tech_gap' must have length n_groups.", call. = FALSE) + } } # Default inefficiency SDs @@ -86,31 +175,82 @@ simulate_metafrontier <- function(n_groups = 2L, n_total <- sum(n_per_group) + # Input distribution: legacy i.i.d. uniform, or (correlated) normal + gaussian_inputs <- !is.null(input_means) || !is.null(input_corr) + sd_x <- 5 / sqrt(12) # matches the spread of runif(0, 5) + chol_corr <- NULL + if (gaussian_inputs) { + if (is.null(input_means)) { + input_means <- matrix(2.5, nrow = n_groups, ncol = n_inputs) + } + input_means <- as.matrix(input_means) + if (nrow(input_means) != n_groups || ncol(input_means) != n_inputs || + !is.numeric(input_means)) { + stop("'input_means' must be an n_groups x n_inputs numeric matrix.", + call. = FALSE) + } + if (!is.null(input_corr)) { + input_corr <- as.matrix(input_corr) + if (nrow(input_corr) != n_inputs || ncol(input_corr) != n_inputs || + !isSymmetric(unname(input_corr)) || + any(abs(diag(input_corr) - 1) > 1e-8)) { + stop("'input_corr' must be a symmetric n_inputs x n_inputs correlation matrix with unit diagonal.", + call. = FALSE) + } + chol_corr <- tryCatch( + chol(input_corr), + error = function(e) { + stop("'input_corr' must be positive definite: Cholesky factorisation failed.", + call. = FALSE) + } + ) + } + } + # Generate data frames <- vector("list", n_groups) group_names <- paste0("G", seq_len(n_groups)) - # Group-specific betas: shift intercept by tech_gap - beta_groups <- vector("list", n_groups) + # Group-specific betas: shift intercept by tech_gap (unless supplied) + if (!custom_betas) { + beta_groups <- vector("list", n_groups) + } for (g in seq_len(n_groups)) { n_g <- n_per_group[g] - # Generate inputs (log scale, from uniform) - X_inputs <- matrix(stats::runif(n_g * n_inputs, 0, 5), - nrow = n_g, ncol = n_inputs) + # Generate inputs (log scale) + if (gaussian_inputs) { + Z <- matrix(stats::rnorm(n_g * n_inputs), + nrow = n_g, ncol = n_inputs) + if (!is.null(chol_corr)) Z <- Z %*% chol_corr + X_inputs <- sweep(Z * sd_x, 2, input_means[g, ], "+") + } else { + X_inputs <- matrix(stats::runif(n_g * n_inputs, 0, 5), + nrow = n_g, ncol = n_inputs) + } colnames(X_inputs) <- paste0("log_x", seq_len(n_inputs)) # Design matrix with intercept X <- cbind(1, X_inputs) - # Group-specific frontier = metafrontier - tech_gap (intercept only) - beta_g <- beta_meta - beta_g[1] <- beta_meta[1] - tech_gap[g] - beta_groups[[g]] <- beta_g - - # Frontier output - frontier_y <- X %*% beta_g + if (custom_betas) { + beta_g <- beta_groups[[g]] + # Frontier of every group at these inputs, for the pointwise envelope + XB <- matrix(vapply(beta_groups, + function(b) as.numeric(X %*% b), + numeric(n_g)), + nrow = n_g) + frontier_y <- XB[, g] + } else { + # Group-specific frontier = metafrontier - tech_gap (intercept only) + beta_g <- beta_meta + beta_g[1] <- beta_meta[1] - tech_gap[g] + beta_groups[[g]] <- beta_g + + # Frontier output + frontier_y <- X %*% beta_g + } # Noise and inefficiency v <- stats::rnorm(n_g, 0, sigma_v) @@ -121,7 +261,12 @@ simulate_metafrontier <- function(n_groups = 2L, # True values true_te <- exp(-u) - true_tgr <- exp(-tech_gap[g]) # constant for intercept-shift DGP + if (custom_betas) { + # TGR against the pointwise maximum over group frontiers, in (0, 1] + true_tgr <- exp(frontier_y - apply(XB, 1, max)) + } else { + true_tgr <- exp(-tech_gap[g]) # constant for intercept-shift DGP + } df_g <- data.frame( X_inputs, @@ -145,7 +290,7 @@ simulate_metafrontier <- function(n_groups = 2L, params <- list( beta_meta = beta_meta, beta_groups = setNames(beta_groups, group_names), - tech_gap = setNames(tech_gap, group_names), + tech_gap = if (custom_betas) NULL else setNames(tech_gap, group_names), sigma_u = setNames(sigma_u, group_names), sigma_v = sigma_v, n_groups = n_groups, @@ -172,13 +317,23 @@ simulate_metafrontier <- function(n_groups = 2L, #' @param sigma_v numeric. Standard deviation of noise. #' @param eta numeric. Time-decay parameter for BC92. #' @param seed integer or NULL. Random seed. +#' @param attrition numeric in [0, 0.5]. Probability that each +#' firm-period observation after a firm's first period is dropped +#' independently, producing an unbalanced panel. Every firm's first +#' period is always kept, so all firms remain in the data. The +#' attrition draws are made after all other random numbers, so +#' \code{attrition = 0} (the default) reproduces legacy balanced +#' datasets exactly for the same seed. The realised share of at-risk +#' observations dropped is stored in \code{params$attrition_share}. #' #' @return A list with components: #' \describe{ #' \item{data}{data frame with columns: \code{firm}, \code{year}, #' \code{group}, \code{log_y}, \code{log_x1}, \code{log_x2}, #' \code{true_te}, \code{true_u}, \code{true_v}} -#' \item{params}{list of true parameter values used in generation} +#' \item{params}{list of true parameter values used in generation, +#' including \code{attrition} and the realised +#' \code{attrition_share}} #' } #' #' @examples @@ -189,6 +344,10 @@ simulate_metafrontier <- function(n_groups = 2L, #' head(sim$data) #' str(sim$params) #' +#' # An unbalanced panel with roughly 20% attrition +#' sim_unbal <- simulate_panel_metafrontier(seed = 42, attrition = 0.2) +#' table(table(sim_unbal$data$firm)) +#' #' @export simulate_panel_metafrontier <- function(n_groups = 2, n_firms_per_group = 30, @@ -198,7 +357,13 @@ simulate_panel_metafrontier <- function(n_groups = 2, sigma_u = 0.3, sigma_v = 0.2, eta = 0.05, - seed = NULL) { + seed = NULL, + attrition = 0) { + + if (!is.numeric(attrition) || length(attrition) != 1L || + is.na(attrition) || attrition < 0 || attrition > 0.5) { + stop("'attrition' must be a single number in [0, 0.5].", call. = FALSE) + } if (!is.null(seed)) set.seed(seed) @@ -265,6 +430,20 @@ simulate_panel_metafrontier <- function(n_groups = 2, } data$true_tgr <- exp(group_frontier - meta_frontier) + # Attrition: drop post-first-period observations independently. Drawn + # after all other random numbers so attrition = 0 reproduces legacy + # datasets exactly for the same seed. + attrition_share <- 0 + if (attrition > 0 && n_periods > 1) { + at_risk <- which(data$year > 1) + dropped <- at_risk[stats::runif(length(at_risk)) < attrition] + attrition_share <- length(dropped) / length(at_risk) + if (length(dropped) > 0) { + data <- data[-dropped, , drop = FALSE] + rownames(data) <- NULL + } + } + params <- list( beta_meta = beta_meta, tech_gap = setNames(tech_gap, group_names), @@ -273,7 +452,9 @@ simulate_panel_metafrontier <- function(n_groups = 2, eta = eta, n_groups = n_groups, n_firms_per_group = n_firms_per_group, - n_periods = n_periods + n_periods = n_periods, + attrition = attrition, + attrition_share = attrition_share ) list(data = data, params = params) diff --git a/R/tgr.R b/R/tgr.R index d5cf150..5011274 100644 --- a/R/tgr.R +++ b/R/tgr.R @@ -28,7 +28,11 @@ #' #' A TGR of 1 means the group frontier coincides with the #' metafrontier at that input mix. Values less than 1 indicate a -#' technology gap. +#' technology gap. Since each group technology is a restricted subset +#' of the common metatechnology (Battese, Rao and O'Donnell, 2004), +#' the gap reflects the restrictions a group faces (regulation, +#' environment, endowments) rather than a fundamentally different +#' technology. #' #' @examples #' set.seed(42) @@ -64,7 +68,9 @@ technology_gap_ratio <- function(object, by_group = TRUE, ...) { #' Summary of Technology Gap Ratios #' -#' Prints a summary table of TGR statistics by group. +#' Prints a summary table of TGR statistics by group. The underlying +#' observation-level TGR values are the same as those returned by +#' \code{efficiencies(object, type = "tgr")}. #' #' @param object a fitted \code{"metafrontier"} object. #' @param ... additional arguments (currently unused). @@ -72,6 +78,17 @@ technology_gap_ratio <- function(object, by_group = TRUE, ...) { #' @return A data frame with columns: Group, N, Mean, SD, Min, Q1, #' Median, Q3, Max. #' +#' @seealso \code{\link{efficiencies.metafrontier}}, +#' \code{\link{technology_gap_ratio}}, \code{\link{boot_tgr}} +#' +#' @examples +#' sim <- simulate_metafrontier(n_groups = 2, n_per_group = 50, +#' seed = 42) +#' fit <- metafrontier(log_y ~ log_x1 + log_x2, data = sim$data, +#' group = "group", method = "sfa", +#' meta_type = "deterministic") +#' tgr_summary(fit) +#' #' @export tgr_summary <- function(object, ...) { if (!inherits(object, "metafrontier")) { diff --git a/README.md b/README.md index 4afdcf0..778edb4 100644 --- a/README.md +++ b/README.md @@ -4,26 +4,28 @@ Analysis of Metafrontier Models for Efficiency and Productivity ## Overview -`metafrontier` provides a unified R implementation of metafrontier production function models for estimating technical efficiencies and technology gaps across groups of firms operating under different technologies. +`metafrontier` provides a unified R implementation of metafrontier production function models for estimating technical efficiencies and technology gaps across groups of firms that face different restrictions of a common underlying metatechnology (group-specific technologies in the sense of Battese, Rao & O'Donnell, 2004). ### Estimation methods -- **Deterministic metafrontier** (Battese, Rao & O'Donnell, 2004) via constrained LP/QP optimisation +- **Deterministic metafrontier** (Battese, Rao & O'Donnell, 2004) identified by minimum sum of absolute deviations (LP, default) or minimum sum of squared deviations (QP) - **Stochastic metafrontier** (Huang, Huang & Liu, 2014) via second-stage SFA with Murphy-Topel corrected standard errors -- **DEA-based metafrontier** with CRS, VRS, DRS, and IRS technology assumptions +- **DEA-based metafrontier** with CRS, VRS, DRS, IRS, and FDH technology assumptions - **Latent class metafrontier** via EM algorithm with BIC-based class selection +- **Efficiency estimators**: BC88 (default) and JLMS, both stored so `efficiencies(fit, estimator = )` switches without refitting ### Productivity analysis -- **Metafrontier Malmquist TFP index** (O'Donnell, Rao & Battese, 2008) with three-way decomposition (TEC x TGC x TC*) -- **Panel SFA** with time-varying inefficiency (BC92 and BC95 specifications) -- **Directional distance functions** for DEA-based efficiency measurement +- **Metafrontier Malmquist TFP index** (O'Donnell, Rao & Battese, 2008) with three-way decomposition (TEC x TGC x TC*), firm matching via `id =`, and explicit accounting of cross-period infeasibilities +- **Panel SFA** with time-varying inefficiency (BC92 and BC95 specifications), including unbalanced panels +- **Directional distance functions** for DEA-based efficiency measurement, including hyperbolic orientation, custom numeric direction vectors, and two-stage slack computation ### Inference and diagnostics - **Bootstrap confidence intervals** for TGR (parametric and nonparametric; percentile and BCa) - **Murphy-Topel variance correction** for stochastic metafrontier standard errors -- **Poolability tests** (likelihood ratio) for common vs group-specific frontiers +- **Poolability tests** for common vs group-specific frontiers: likelihood ratio (SFA) and a permutation test (DEA) +- **Convergence diagnostics** via `check_convergence()`, with convergence status reported in `print()` and `summary()` - **Half-normal, exponential, and truncated-normal** inefficiency distributions ### Visualisation @@ -33,9 +35,9 @@ Analysis of Metafrontier Models for Efficiency and Productivity ### Interoperability -- Import pre-fitted models from `sfaR`, `frontier`, and `Benchmarking` via `as_metafrontier_model()` +- Import pre-fitted models from `sfaR`, `frontier`, and `Benchmarking` via `as_metafrontier_model()`, or delegate group estimation directly with `engine = c("internal", "sfaR", "frontier", "Benchmarking")` - Formula interface with heteroscedastic SFA support (`y ~ x1 + x2 | z1 + z2`) -- Full S3 method suite: `print`, `summary`, `coef`, `vcov`, `logLik`, `fitted`, `residuals`, `nobs`, `confint`, `predict`, `plot` +- Full S3 method suite: `print`, `summary`, `coef`, `vcov`, `logLik`, `fitted`, `residuals`, `nobs`, `confint`, `predict`, `plot`; `coef()` and `vcov()` expose auxiliary parameters (e.g. `eta`, variance parameters) via `extraPar = TRUE` ## Installation diff --git a/cran-comments.md b/cran-comments.md index c686352..45553ef 100644 --- a/cran-comments.md +++ b/cran-comments.md @@ -2,27 +2,32 @@ 0 errors | 0 warnings | 0 notes -(CRAN incoming checks may show 1 NOTE for new submission and -possibly misspelled words: Battese, Malmquist, Metafrontier, SFA. -These are correct domain-specific terms.) - -## Resubmission - -This is a resubmission of v0.2.2 (previous CRAN version: 0.2.1). - -Changes since v0.2.1: - -- Fixed two bugs in `boot_tgr()`: orientation/rts now propagate - correctly to bootstrap replicates, and the group column name - is no longer hardcoded. -- Fixed latent class `.loglik_to_u_hat()` to respect the `dist` - argument with correct JLMS formulas for all three distributions. -- Fixed latent class parameter count for truncated-normal (k+3). -- Fixed two incorrect DOIs in DESCRIPTION: Huang et al. (2014) - and O'Donnell et al. (2008) now link to the correct papers. -- `autoplot` methods now use proper conditional S3 registration - via `@exportS3Method ggplot2::autoplot`. -- Pre-built vignettes included in inst/doc. +(CRAN incoming checks may show 1 NOTE for possibly misspelled words: +Battese, Malmquist, Metafrontier, SFA. These are correct +domain-specific terms.) + +## Release summary + +metafrontier 0.3.0 (previous CRAN version: 0.2.2). + +- New default efficiency estimator: the Battese-Coelli (1988) + conditional expectation (`estimator = "bc88"`); the JLMS estimator + remains available, both are stored on every fit, and the change is + documented as a breaking change in NEWS.md. +- Both identification criteria for the deterministic metafrontier + (`objective = c("lp", "qp")`; quadprog added to Suggests). +- Backend delegation via `engine = c("internal", "sfaR", "frontier", + "Benchmarking")`. +- `malmquist_meta()` gains id-based firm matching with strict checks + and counted infeasibility warnings. +- New `check_convergence()` diagnostic; convergence reporting in + `print()` and `summary()`. +- DEA additions: FDH, hyperbolic efficiency, user-supplied direction + vectors, two-stage slack analysis; permutation poolability test for + DEA fits. +- Bug fixes, including a row-alignment fix for panel SFA + efficiencies, BC92 decay anchoring on unbalanced panels, and an + erroneous lower bound in cross-period DEA programs. See NEWS.md. ## Test environments diff --git a/inst/doc/introduction.R b/inst/doc/introduction.R index 2f810a6..4573cfa 100644 --- a/inst/doc/introduction.R +++ b/inst/doc/introduction.R @@ -6,9 +6,11 @@ knitr::opts_chunk$set( fig.height = 5 ) + ## ----setup-------------------------------------------------------------------- library(metafrontier) + ## ----simulate----------------------------------------------------------------- sim <- simulate_metafrontier( n_groups = 3, @@ -23,6 +25,7 @@ sim <- simulate_metafrontier( str(sim$data[, c("log_y", "log_x1", "log_x2", "group")]) table(sim$data$group) + ## ----estimate----------------------------------------------------------------- fit <- metafrontier( log_y ~ log_x1 + log_x2, @@ -34,6 +37,7 @@ fit <- metafrontier( fit + ## ----deterministic------------------------------------------------------------ fit_det <- metafrontier( log_y ~ log_x1 + log_x2, @@ -44,6 +48,7 @@ fit_det <- metafrontier( summary(fit_det) + ## ----stochastic--------------------------------------------------------------- fit_sto <- metafrontier( log_y ~ log_x1 + log_x2, @@ -54,9 +59,11 @@ fit_sto <- metafrontier( summary(fit_sto) + ## ----vcov--------------------------------------------------------------------- vcov(fit_sto) + ## ----dea---------------------------------------------------------------------- fit_dea <- metafrontier( log_y ~ log_x1 + log_x2, @@ -68,6 +75,7 @@ fit_dea <- metafrontier( fit_dea + ## ----efficiencies------------------------------------------------------------- te <- efficiencies(fit_det, type = "group") tgr <- efficiencies(fit_det, type = "tgr") @@ -76,13 +84,21 @@ te_star <- efficiencies(fit_det, type = "meta") # Verify the fundamental identity: TE* = TE x TGR all.equal(te_star, te * tgr) + +## ----efficiencies-jlms-------------------------------------------------------- +te_jlms <- efficiencies(fit_det, type = "group", estimator = "jlms") +cor(te, te_jlms) + + ## ----tgr---------------------------------------------------------------------- tgr_by_group <- technology_gap_ratio(fit_det) lapply(tgr_by_group, summary) + ## ----tgr-summary-------------------------------------------------------------- tgr_summary(fit_det) + ## ----coefs-------------------------------------------------------------------- # Metafrontier coefficients coef(fit_det, which = "meta") @@ -90,6 +106,7 @@ coef(fit_det, which = "meta") # Group-specific coefficients coef(fit_det, which = "group") + ## ----model-info--------------------------------------------------------------- # Log-likelihood (sum of group log-likelihoods for deterministic) logLik(fit_det) @@ -100,18 +117,27 @@ nobs(fit_det) # AIC and BIC (available automatically via logLik method) AIC(fit_det) + ## ----plot-tgr, fig.height=4--------------------------------------------------- plot(fit_det, which = "tgr") + ## ----plot-eff, fig.height=4--------------------------------------------------- plot(fit_det, which = "efficiency") + ## ----plot-decomp, fig.height=4, fig.width=9----------------------------------- plot(fit_det, which = "decomposition") + ## ----poolability-------------------------------------------------------------- poolability_test(fit_det) + +## ----convergence-------------------------------------------------------------- +check_convergence(fit_det) + + ## ----distributions, eval=FALSE------------------------------------------------ # # Half-normal (default): u ~ |N(0, sigma_u^2)| # fit_hn <- metafrontier(log_y ~ log_x1 + log_x2, @@ -128,6 +154,7 @@ poolability_test(fit_det) # data = sim$data, group = "group", # dist = "exponential") + ## ----compare-truth------------------------------------------------------------ # True vs estimated metafrontier coefficients cbind( @@ -144,6 +171,7 @@ cbind(True = true_tgr, Estimated = est_tgr) cor(sim$data$true_te, fit_det$te_group) cor(sim$data$true_te_star, fit_det$te_meta) + ## ----panel-sfa, eval=FALSE---------------------------------------------------- # # Simulate panel data # panel_sim <- simulate_panel_metafrontier( @@ -164,6 +192,7 @@ cor(sim$data$true_te_star, fit_det$te_meta) # # eta > 0: inefficiency decreasing over time # # eta < 0: inefficiency increasing over time + ## ----bootstrap, eval=FALSE---------------------------------------------------- # sim <- simulate_metafrontier(n_groups = 2, n_per_group = 100, seed = 42) # fit <- metafrontier(log_y ~ log_x1 + log_x2, data = sim$data, @@ -183,6 +212,7 @@ cor(sim$data$true_te_star, fit_det$te_meta) # # Parametric bootstrap (resample from estimated error distributions) # boot_par <- boot_tgr(fit, R = 499, type = "parametric", seed = 1) + ## ----murphy-topel, eval=FALSE------------------------------------------------- # fit <- metafrontier(log_y ~ log_x1 + log_x2, data = sim$data, # group = "group", meta_type = "stochastic") @@ -196,6 +226,7 @@ cor(sim$data$true_te_star, fit_det$te_meta) # # Corrected confidence intervals # confint(fit, correction = "murphy-topel") + ## ----latent-class, eval=FALSE------------------------------------------------- # sim <- simulate_metafrontier(n_groups = 2, n_per_group = 100, seed = 42) # @@ -215,6 +246,7 @@ cor(sim$data$true_te_star, fit_det$te_meta) # ) # print(bic_table) # choose n_classes with lowest BIC + ## ----ddf, eval=FALSE---------------------------------------------------------- # sim <- simulate_metafrontier(n_groups = 2, n_per_group = 50, seed = 42) # # Use raw (non-log) data for DEA diff --git a/inst/doc/introduction.Rmd b/inst/doc/introduction.Rmd index ea1b0e4..71a8baf 100644 --- a/inst/doc/introduction.Rmd +++ b/inst/doc/introduction.Rmd @@ -19,16 +19,26 @@ knitr::opts_chunk$set( ## What is a metafrontier? In efficiency analysis, we often study firms that operate under -fundamentally different technologies. Steel producers using electric arc -furnaces (EAF) face a different production possibility set than those using -the blast furnace-basic oxygen furnace (BF-BOF) route. Hospitals in rural -areas face different constraints than urban ones. Banks in developing -economies operate under different regulatory and technological environments -than those in advanced economies. +different production environments. Steel producers using electric arc +furnaces (EAF) face a different feasible set of input-output combinations +than those using the blast furnace-basic oxygen furnace (BF-BOF) route. +Hospitals in rural areas face different constraints than urban ones. +Banks face different regulatory environments across jurisdictions. + +Following Battese, Rao, and O'Donnell (2004) and O'Donnell, Rao, and +Battese (2008), we conceive of a single industry **metatechnology** +$T^*$: the set of all input-output combinations that are technically +feasible in the industry. Each group of firms operates within a +**restricted subset** $T_j \subseteq T^*$ of this metatechnology, where +the restrictions arise from regulation, the physical environment, +resource endowments, or the cost of switching production systems. Groups +do not possess fundamentally different technologies; they face different +restrictions of a common metatechnology. Standard stochastic frontier analysis (SFA) or data envelopment analysis -(DEA) applied to the pooled sample implicitly assumes all firms share the -same technology -- an assumption that may be unrealistic. Estimating +(DEA) applied to the pooled sample implicitly assumes that all firms +have unrestricted access to the same technology set, an assumption +that may be unrealistic. Estimating separate frontiers for each group solves this problem but makes efficiency scores incomparable across groups: a firm that is 90\% efficient relative to a less advanced group frontier may actually be less productive than a @@ -111,10 +121,15 @@ The deterministic metafrontier is estimated in two stages: 1. **Stage 1**: Fit separate SFA models for each group via maximum likelihood. 2. **Stage 2**: Find metafrontier coefficients $\hat\beta^*$ by minimising - $$\sum_i \left[\ln f(x_i; \hat\beta^*) - \ln f(x_i; \hat\beta_j)\right]^2$$ + $$\sum_i \left|\ln f(x_i; \hat\beta^*) - \ln f(x_i; \hat\beta_j)\right|$$ subject to the constraint that the metafrontier envelops all group frontiers: $\ln f(x_i; \hat\beta^*) \ge \ln f(x_i; \hat\beta_j)$ for - all $i$ and $j$. + all $i$ and $j$. Since the envelopment constraints force the + deviations to be non-negative, this reduces to a linear programme + (`objective = "lp"`, the default). The alternative minimum sum of + squared deviations criterion is available via `objective = "qp"`; + both criteria are proposed by Battese, Rao, and O'Donnell (2004), + and the `methods` vignette discusses them in detail. This is the default method: @@ -198,6 +213,16 @@ te_star <- efficiencies(fit_det, type = "meta") all.equal(te_star, te * tgr) ``` +For SFA fits, technical efficiencies are computed with the Battese and +Coelli (1988) conditional expectation estimator by default +(`estimator = "bc88"`). The Jondrow et al. (1982) estimator is computed +and stored alongside it, so you can switch without refitting: + +```{r efficiencies-jlms} +te_jlms <- efficiencies(fit_det, type = "group", estimator = "jlms") +cor(te, te_jlms) +``` + ### Technology gap ratio The `technology_gap_ratio()` function returns TGR values grouped by @@ -277,9 +302,24 @@ statistically different from a single pooled frontier: poolability_test(fit_det) ``` -A significant result (small p-value) indicates that the technology groups -have genuinely different production technologies, justifying the -metafrontier approach. +A significant result (small p-value) indicates that the group frontiers +genuinely differ, that is, the groups face different restrictions of the +common metatechnology, justifying the metafrontier approach. + +### Convergence diagnostics + +Every estimation stage of a metafrontier fit can be inspected with +`check_convergence()`, which returns one row per stage (each group +frontier and the metafrontier itself) with the estimation method, the +optimiser's convergence code, and a logical convergence indicator: + +```{r convergence} +check_convergence(fit_det) +``` + +The `summary()` method also prints a convergence block, so estimation +problems are flagged even if you never call `check_convergence()` +directly. ## Inefficiency distributions @@ -455,6 +495,10 @@ head(data.frame( ## References +- Battese, G.E. and Coelli, T.J. (1988). Prediction of firm-level + technical efficiencies with a generalized frontier production function + and panel data. *Journal of Econometrics*, 38(3), 387--399. + - Battese, G.E., Rao, D.S.P. and O'Donnell, C.J. (2004). A metafrontier production function for estimation of technical efficiencies and technology gaps for firms operating under different technologies. @@ -464,6 +508,10 @@ head(data.frame( estimating the metafrontier production function based on a stochastic frontier framework. *Journal of Productivity Analysis*, 42(3), 241--254. +- Jondrow, J., Lovell, C.A.K., Materov, I.S. and Schmidt, P. (1982). On + the estimation of technical inefficiency in the stochastic frontier + production function model. *Journal of Econometrics*, 19(2--3), 233--238. + - O'Donnell, C.J., Rao, D.S.P. and Battese, G.E. (2008). Metafrontier frameworks for the study of firm-level efficiencies and technology ratios. *Empirical Economics*, 34(2), 231--255. diff --git a/inst/doc/introduction.html b/inst/doc/introduction.html index 589d279..7f5d28a 100644 --- a/inst/doc/introduction.html +++ b/inst/doc/introduction.html @@ -344,20 +344,29 @@

Introduction to metafrontier

What is a metafrontier?

In efficiency analysis, we often study firms that operate under -fundamentally different technologies. Steel producers using electric arc -furnaces (EAF) face a different production possibility set than those -using the blast furnace-basic oxygen furnace (BF-BOF) route. Hospitals -in rural areas face different constraints than urban ones. Banks in -developing economies operate under different regulatory and -technological environments than those in advanced economies.

+different production environments. Steel producers using electric arc +furnaces (EAF) face a different feasible set of input-output +combinations than those using the blast furnace-basic oxygen furnace +(BF-BOF) route. Hospitals in rural areas face different constraints than +urban ones. Banks face different regulatory environments across +jurisdictions.

+

Following Battese, Rao, and O’Donnell (2004) and O’Donnell, Rao, and +Battese (2008), we conceive of a single industry +metatechnology \(T^*\): the set of all input-output +combinations that are technically feasible in the industry. Each group +of firms operates within a restricted subset \(T_j \subseteq T^*\) of this metatechnology, +where the restrictions arise from regulation, the physical environment, +resource endowments, or the cost of switching production systems. Groups +do not possess fundamentally different technologies; they face different +restrictions of a common metatechnology.

Standard stochastic frontier analysis (SFA) or data envelopment -analysis (DEA) applied to the pooled sample implicitly assumes all firms -share the same technology – an assumption that may be unrealistic. -Estimating separate frontiers for each group solves this problem but -makes efficiency scores incomparable across groups: a firm that is 90% -efficient relative to a less advanced group frontier may actually be -less productive than a firm that is 70% efficient relative to a more -advanced frontier.

+analysis (DEA) applied to the pooled sample implicitly assumes that all +firms have unrestricted access to the same technology set, an assumption +that may be unrealistic. Estimating separate frontiers for each group +solves this problem but makes efficiency scores incomparable across +groups: a firm that is 90% efficient relative to a less advanced group +frontier may actually be less productive than a firm that is 70% +efficient relative to a more advanced frontier.

The metafrontier framework, introduced by Battese, Rao, and O’Donnell (2004) and extended by Huang, Huang, and Liu (2014) and O’Donnell, Rao, and Battese (2008), resolves this by:

@@ -431,21 +440,25 @@

Estimate the metafrontier

#> ------------------ #> Method: sfa #> Metafrontier: deterministic -#> Groups: G1, G2, G3 -#> Total obs: 600 -#> G1: 200 obs -#> G2: 200 obs -#> G3: 200 obs -#> -#> Group log-likelihoods: -#> G1: 35.49 -#> G2: 0.84652 -#> G3: -25.399 -#> -#> Mean TGR by group: -#> G1: 1 -#> G2: 0.7593 -#> G3: 0.6047
+#> Estimator: bc88 +#> Objective: lp +#> Groups: G1, G2, G3 +#> Total obs: 600 +#> G1: 200 obs +#> G2: 200 obs +#> G3: 200 obs +#> +#> Group log-likelihoods: +#> G1: 35.49 +#> G2: 0.84652 +#> G3: -25.399 +#> +#> Mean TGR by group: +#> G1: 1 +#> G2: 0.7593 +#> G3: 0.6047 +#> +#> Convergence: OK
@@ -455,11 +468,17 @@

Deterministic SFA metafrontier (Battese, Rao, and O’Donnell,
  1. Stage 1: Fit separate SFA models for each group via maximum likelihood.
    2. -
  2. Stage 2: Find metafrontier coefficients \(\hat\beta^*\) by minimising \[\sum_i \left[\ln f(x_i; \hat\beta^*) - \ln f(x_i; -\hat\beta_j)\right]^2\] subject to the constraint that the +
  3. Stage 2: Find metafrontier coefficients \(\hat\beta^*\) by minimising \[\sum_i \left|\ln f(x_i; \hat\beta^*) - \ln f(x_i; +\hat\beta_j)\right|\] subject to the constraint that the metafrontier envelops all group frontiers: \(\ln f(x_i; \hat\beta^*) \ge \ln f(x_i; \hat\beta_j)\) for all \(i\) and -\(j\).
    4. +\(j\). Since the envelopment +constraints force the deviations to be non-negative, this reduces to a +linear programme (objective = "lp", the default). The +alternative minimum sum of squared deviations criterion is available via +objective = "qp"; both criteria are proposed by Battese, +Rao, and O’Donnell (2004), and the methods vignette +discusses them in detail.

This is the default method:

fit_det <- metafrontier(
@@ -482,49 +501,58 @@ 
Deterministic SFA metafrontier (Battese, Rao, and O’Donnell,
 #> Metafrontier:  deterministic 
 #> 
 #> --- Group: G1 (n = 200) ---
-#>             Estimate Std. Error z value Pr(>|z|)    
-#> (Intercept) 1.025588   0.060881   16.85   <2e-16 ***
-#> log_x1      0.493508   0.009658   51.10   <2e-16 ***
-#> log_x2      0.294569   0.009805   30.04   <2e-16 ***
-#> ---
-#> Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
-#> Log-likelihood: 35.49 
-#> 
-#> --- Group: G2 (n = 200) ---
-#>             Estimate Std. Error z value Pr(>|z|)    
-#> (Intercept)  0.76703    0.06478   11.84   <2e-16 ***
-#> log_x1       0.48428    0.01239   39.10   <2e-16 ***
-#> log_x2       0.29703    0.01210   24.55   <2e-16 ***
-#> ---
-#> Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
-#> Log-likelihood: 0.84652 
-#> 
-#> --- Group: G3 (n = 200) ---
-#>             Estimate Std. Error z value Pr(>|z|)    
-#> (Intercept)  0.53665    0.05513   9.734   <2e-16 ***
-#> log_x1       0.49950    0.01238  40.352   <2e-16 ***
-#> log_x2       0.28205    0.01186  23.782   <2e-16 ***
-#> ---
-#> Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
-#> Log-likelihood: -25.399 
-#> 
-#> --- Metafrontier ---
-#>             Estimate
-#> (Intercept)   1.0256
-#> log_x1        0.4935
-#> log_x2        0.2946
+#>              Estimate Std. Error z value Pr(>|z|)    
+#> (Intercept)  1.025588   0.060881  16.846  < 2e-16 ***
+#> log_x1       0.493508   0.009658  51.097  < 2e-16 ***
+#> log_x2       0.294569   0.009805  30.042  < 2e-16 ***
+#> log_sigma_v -1.800325   0.155456 -11.581  < 2e-16 ***
+#> log_sigma_u -1.627386   0.313233  -5.195 2.04e-07 ***
+#> ---
+#> Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
+#> Log-likelihood: 35.49 
+#> 
+#> --- Group: G2 (n = 200) ---
+#>             Estimate Std. Error z value Pr(>|z|)    
+#> (Intercept)  0.76703    0.06478   11.84  < 2e-16 ***
+#> log_x1       0.48428    0.01239   39.10  < 2e-16 ***
+#> log_x2       0.29703    0.01210   24.55  < 2e-16 ***
+#> log_sigma_v -1.65583    0.16136  -10.26  < 2e-16 ***
+#> log_sigma_u -1.39987    0.28108   -4.98 6.35e-07 ***
+#> ---
+#> Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
+#> Log-likelihood: 0.84652 
+#> 
+#> --- Group: G3 (n = 200) ---
+#>             Estimate Std. Error z value Pr(>|z|)    
+#> (Intercept)  0.53665    0.05513   9.734   <2e-16 ***
+#> log_x1       0.49950    0.01238  40.352   <2e-16 ***
+#> log_x2       0.28205    0.01186  23.782   <2e-16 ***
+#> log_sigma_v -1.94321    0.14404 -13.490   <2e-16 ***
+#> log_sigma_u -0.89271    0.08650 -10.320   <2e-16 ***
+#> ---
+#> Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
+#> Log-likelihood: -25.399 
 #> 
-#> --- Efficiency Decomposition ---
-#>  Group Mean_TE Mean_TGR Mean_TE_star
-#>     G1  0.8571   1.0000       0.8571
-#>     G2  0.8249   0.7593       0.6263
-#>     G3  0.7401   0.6047       0.4475
+#> --- Metafrontier ---
+#>             Estimate
+#> (Intercept)   1.0256
+#> log_x1        0.4935
+#> log_x2        0.2946
 #> 
-#> --- Technology Gap Ratio Summary ---
-#>  Group   N   Mean     SD    Min     Q1 Median     Q3    Max
-#>     G1 200 1.0000 0.0000 1.0000 1.0000 1.0000 1.0000 1.0000
-#>     G2 200 0.7593 0.0099 0.7386 0.7518 0.7592 0.7679 0.7799
-#>     G3 200 0.6047 0.0125 0.5769 0.5947 0.6056 0.6143 0.6289
+#> --- Efficiency Decomposition --- +#> Group Mean_TE Mean_TGR Mean_TE_star +#> G1 0.8607 1.0000 0.8607 +#> G2 0.8300 0.7593 0.6302 +#> G3 0.7450 0.6047 0.4504 +#> +#> --- Technology Gap Ratio Summary --- +#> Group N Mean SD Min Q1 Median Q3 Max +#> G1 200 1.0000 0.0000 1.0000 1.0000 1.0000 1.0000 1.0000 +#> G2 200 0.7593 0.0099 0.7386 0.7518 0.7592 0.7679 0.7799 +#> G3 200 0.6047 0.0125 0.5769 0.5947 0.6056 0.6143 0.6289 +#> +#> --- Convergence --- +#> All estimation stages converged.

Stochastic metafrontier (Huang, Huang, and Liu, 2014)

@@ -556,52 +584,61 @@

Stochastic metafrontier (Huang, Huang, and Liu, 2014)

#> Metafrontier: stochastic #> #> --- Group: G1 (n = 200) --- -#> Estimate Std. Error z value Pr(>|z|) -#> (Intercept) 1.025588 0.060881 16.85 <2e-16 *** -#> log_x1 0.493508 0.009658 51.10 <2e-16 *** -#> log_x2 0.294569 0.009805 30.04 <2e-16 *** -#> --- -#> Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1 -#> Log-likelihood: 35.49 -#> -#> --- Group: G2 (n = 200) --- -#> Estimate Std. Error z value Pr(>|z|) -#> (Intercept) 0.76703 0.06478 11.84 <2e-16 *** -#> log_x1 0.48428 0.01239 39.10 <2e-16 *** -#> log_x2 0.29703 0.01210 24.55 <2e-16 *** -#> --- -#> Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1 -#> Log-likelihood: 0.84652 -#> -#> --- Group: G3 (n = 200) --- -#> Estimate Std. Error z value Pr(>|z|) -#> (Intercept) 0.53665 0.05513 9.734 <2e-16 *** -#> log_x1 0.49950 0.01238 40.352 <2e-16 *** -#> log_x2 0.28205 0.01186 23.782 <2e-16 *** -#> --- -#> Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1 -#> Log-likelihood: -25.399 -#> -#> --- Metafrontier --- -#> Estimate Std. Error z value Pr(>|z|) -#> (Intercept) 0.784379 0.186836 4.198 2.69e-05 *** -#> log_x1 0.493270 0.005918 83.349 < 2e-16 *** -#> log_x2 0.289361 0.005832 49.613 < 2e-16 *** -#> --- -#> Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1 -#> Log-likelihood: 96.292 -#> -#> --- Efficiency Decomposition --- -#> Group Mean_TE Mean_TGR Mean_TE_star -#> G1 0.8571 1.2894 1.1051 -#> G2 0.8249 0.9794 0.8078 -#> G3 0.7401 0.7797 0.5771 +#> Estimate Std. Error z value Pr(>|z|) +#> (Intercept) 1.025588 0.060881 16.846 < 2e-16 *** +#> log_x1 0.493508 0.009658 51.097 < 2e-16 *** +#> log_x2 0.294569 0.009805 30.042 < 2e-16 *** +#> log_sigma_v -1.800325 0.155456 -11.581 < 2e-16 *** +#> log_sigma_u -1.627386 0.313233 -5.195 2.04e-07 *** +#> --- +#> Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1 +#> Log-likelihood: 35.49 +#> +#> --- Group: G2 (n = 200) --- +#> Estimate Std. Error z value Pr(>|z|) +#> (Intercept) 0.76703 0.06478 11.84 < 2e-16 *** +#> log_x1 0.48428 0.01239 39.10 < 2e-16 *** +#> log_x2 0.29703 0.01210 24.55 < 2e-16 *** +#> log_sigma_v -1.65583 0.16136 -10.26 < 2e-16 *** +#> log_sigma_u -1.39987 0.28108 -4.98 6.35e-07 *** +#> --- +#> Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1 +#> Log-likelihood: 0.84652 +#> +#> --- Group: G3 (n = 200) --- +#> Estimate Std. Error z value Pr(>|z|) +#> (Intercept) 0.53665 0.05513 9.734 <2e-16 *** +#> log_x1 0.49950 0.01238 40.352 <2e-16 *** +#> log_x2 0.28205 0.01186 23.782 <2e-16 *** +#> log_sigma_v -1.94321 0.14404 -13.490 <2e-16 *** +#> log_sigma_u -0.89271 0.08650 -10.320 <2e-16 *** +#> --- +#> Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1 +#> Log-likelihood: -25.399 +#> +#> --- Metafrontier --- +#> Estimate Std. Error z value Pr(>|z|) +#> (Intercept) 0.784379 0.186836 4.198 2.69e-05 *** +#> log_x1 0.493270 0.005918 83.349 < 2e-16 *** +#> log_x2 0.289361 0.005832 49.613 < 2e-16 *** +#> --- +#> Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1 +#> Log-likelihood: 96.292 #> -#> --- Technology Gap Ratio Summary --- -#> Group N Mean SD Min Q1 Median Q3 Max -#> G1 200 1.2894 0.0099 1.2735 1.2808 1.2887 1.2973 1.3073 -#> G2 200 0.9794 0.0157 0.9428 0.9687 0.9796 0.9906 1.0185 -#> G3 200 0.7797 0.0111 0.7537 0.7717 0.7798 0.7876 0.8027
+#> --- Efficiency Decomposition --- +#> Group Mean_TE Mean_TGR Mean_TE_star +#> G1 0.8607 1.2894 1.1098 +#> G2 0.8300 0.9794 0.8129 +#> G3 0.7450 0.7797 0.5808 +#> +#> --- Technology Gap Ratio Summary --- +#> Group N Mean SD Min Q1 Median Q3 Max +#> G1 200 1.2894 0.0099 1.2735 1.2808 1.2887 1.2973 1.3073 +#> G2 200 0.9794 0.0157 0.9428 0.9687 0.9796 0.9906 1.0185 +#> G3 200 0.7797 0.0111 0.7537 0.7717 0.7798 0.7876 0.8027 +#> +#> --- Convergence --- +#> All estimation stages converged.

The stochastic metafrontier provides a variance-covariance matrix:

vcov(fit_sto)
@@ -640,7 +677,9 @@ 
DEA-based metafrontier

 #> Mean TGR by group:
 #>   G1: 0.9959
 #>   G2: 0.9221
-#>   G3: NA
+#> G3: NA +#> +#> Convergence: WARNING (group: G3, metafrontier)

The DEA metafrontier computes:

  1. Group-specific DEA efficiencies under variable returns to scale @@ -663,69 +702,77 @@

    Efficiency scores

    # Verify the fundamental identity: TE* = TE x TGR all.equal(te_star, te * tgr) #> [1] TRUE +

    For SFA fits, technical efficiencies are computed with the Battese +and Coelli (1988) conditional expectation estimator by default +(estimator = "bc88"). The Jondrow et al. (1982) estimator +is computed and stored alongside it, so you can switch without +refitting:

    +
    te_jlms <- efficiencies(fit_det, type = "group", estimator = "jlms")
+cor(te, te_jlms)
+#> [1] 0.9999314

    Technology gap ratio

    The technology_gap_ratio() function returns TGR values grouped by technology:

    -
    tgr_by_group <- technology_gap_ratio(fit_det)
-lapply(tgr_by_group, summary)
-#> $G1
-#>    Min. 1st Qu.  Median    Mean 3rd Qu.    Max. 
-#>       1       1       1       1       1       1 
-#> 
-#> $G2
-#>    Min. 1st Qu.  Median    Mean 3rd Qu.    Max. 
-#>  0.7386  0.7518  0.7592  0.7593  0.7679  0.7799 
-#> 
-#> $G3
-#>    Min. 1st Qu.  Median    Mean 3rd Qu.    Max. 
-#>  0.5769  0.5947  0.6056  0.6047  0.6143  0.6289
    +
    tgr_by_group <- technology_gap_ratio(fit_det)
+lapply(tgr_by_group, summary)
+#> $G1
+#>    Min. 1st Qu.  Median    Mean 3rd Qu.    Max. 
+#>       1       1       1       1       1       1 
+#> 
+#> $G2
+#>    Min. 1st Qu.  Median    Mean 3rd Qu.    Max. 
+#>  0.7386  0.7518  0.7592  0.7593  0.7679  0.7799 
+#> 
+#> $G3
+#>    Min. 1st Qu.  Median    Mean 3rd Qu.    Max. 
+#>  0.5769  0.5947  0.6056  0.6047  0.6143  0.6289

    For a formatted summary table:

    -
    tgr_summary(fit_det)
-#>   Group   N      Mean          SD       Min        Q1    Median        Q3
-#> 1    G1 200 1.0000000 0.000000000 1.0000000 1.0000000 1.0000000 1.0000000
-#> 2    G2 200 0.7592884 0.009947071 0.7385586 0.7517742 0.7592422 0.7679385
-#> 3    G3 200 0.6047017 0.012456784 0.5769063 0.5947118 0.6056158 0.6142562
-#>         Max
-#> 1 1.0000000
-#> 2 0.7798918
-#> 3 0.6289392
    +
    tgr_summary(fit_det)
+#>   Group   N      Mean          SD       Min        Q1    Median        Q3
+#> 1    G1 200 1.0000000 0.000000000 1.0000000 1.0000000 1.0000000 1.0000000
+#> 2    G2 200 0.7592884 0.009947071 0.7385586 0.7517742 0.7592422 0.7679385
+#> 3    G3 200 0.6047017 0.012456784 0.5769063 0.5947118 0.6056158 0.6142562
+#>         Max
+#> 1 1.0000000
+#> 2 0.7798918
+#> 3 0.6289392

    Coefficients

    -
    # Metafrontier coefficients
-coef(fit_det, which = "meta")
-#> (Intercept)      log_x1      log_x2 
-#>   1.0255883   0.4935078   0.2945688
-
-# Group-specific coefficients
-coef(fit_det, which = "group")
-#> $G1
-#> (Intercept)      log_x1      log_x2 
-#>   1.0255883   0.4935078   0.2945688 
-#> 
-#> $G2
-#> (Intercept)      log_x1      log_x2 
-#>   0.7670252   0.4842818   0.2970328 
-#> 
-#> $G3
-#> (Intercept)      log_x1      log_x2 
-#>   0.5366478   0.4994989   0.2820525
    +
    # Metafrontier coefficients
+coef(fit_det, which = "meta")
+#> (Intercept)      log_x1      log_x2 
+#>   1.0255883   0.4935078   0.2945688
+
+# Group-specific coefficients
+coef(fit_det, which = "group")
+#> $G1
+#> (Intercept)      log_x1      log_x2 
+#>   1.0255883   0.4935078   0.2945688 
+#> 
+#> $G2
+#> (Intercept)      log_x1      log_x2 
+#>   0.7670252   0.4842818   0.2970328 
+#> 
+#> $G3
+#> (Intercept)      log_x1      log_x2 
+#>   0.5366478   0.4994989   0.2820525

    Model information

    -
    # Log-likelihood (sum of group log-likelihoods for deterministic)
-logLik(fit_det)
-#> 'log Lik.' 10.9376 (df=3)
-
-# Number of observations
-nobs(fit_det)
-#> [1] 600
-
-# AIC and BIC (available automatically via logLik method)
-AIC(fit_det)
-#> [1] -15.87521
    +
    # Log-likelihood (sum of group log-likelihoods for deterministic)
+logLik(fit_det)
+#> 'log Lik.' 10.9376 (df=3)
+
+# Number of observations
+nobs(fit_det)
+#> [1] 600
+
+# AIC and BIC (available automatically via logLik method)
+AIC(fit_det)
+#> [1] -15.87521
    @@ -733,20 +780,20 @@

    Visualisation

    The package provides four built-in plot types:

    TGR distributions

    -
    plot(fit_det, which = "tgr")
    +
    plot(fit_det, which = "tgr")

    Efficiency scatter

    -
    plot(fit_det, which = "efficiency")
    -

    +
    plot(fit_det, which = "efficiency")
    +

    Points below the 45-degree line indicate a technology gap (TE* < TE). The vertical distance from the line reflects the TGR.

    Efficiency decomposition

    -
    plot(fit_det, which = "decomposition")
    -

    +
    plot(fit_det, which = "decomposition")
    +

    Side-by-side boxplots of TE, TGR, and TE* by group.

    @@ -756,15 +803,36 @@

    Hypothesis testing

    Poolability test

    The poolability test evaluates whether group-specific frontiers are statistically different from a single pooled frontier:

    -
    poolability_test(fit_det)
-#> 
-#>  Likelihood Ratio Test for Poolability of Group Frontiers
-#> 
-#> data:  metafrontier(formula = log_y ~ log_x1 + log_x2, data = sim$data,     group = "group", meta_type = "deterministic")
-#> LR = 504.71, df = 10, p-value < 2.2e-16
    -

    A significant result (small p-value) indicates that the technology -groups have genuinely different production technologies, justifying the -metafrontier approach.

    +
    poolability_test(fit_det)
+#> 
+#>  Likelihood Ratio Test for Poolability of Group Frontiers
+#> 
+#> data:  fit_det
+#> LR = 504.71, df = 10, p-value < 2.2e-16
    +

    A significant result (small p-value) indicates that the group +frontiers genuinely differ, that is, the groups face different +restrictions of the common metatechnology, justifying the metafrontier +approach.

    + +
    +

    Convergence diagnostics

    +

    Every estimation stage of a metafrontier fit can be inspected with +check_convergence(), which returns one row per stage (each +group frontier and the metafrontier itself) with the estimation method, +the optimiser’s convergence code, and a logical convergence +indicator:

    +
    check_convergence(fit_det)
+#> 
+#> Convergence of estimation stages
+#> --------------------------------
+#>         stage method code converged note
+#>     group: G1    MLE    0      TRUE     
+#>     group: G2    MLE    0      TRUE     
+#>     group: G3    MLE    0      TRUE     
+#>  metafrontier     LP    0      TRUE
    +

    The summary() method also prints a convergence block, so +estimation problems are flagged even if you never call +check_convergence() directly.

    @@ -772,95 +840,95 @@

    Inefficiency distributions

    The package supports three distributional assumptions for the one-sided inefficiency term \(u_i\) in SFA:

    -
    # Half-normal (default): u ~ |N(0, sigma_u^2)|
-fit_hn <- metafrontier(log_y ~ log_x1 + log_x2,
-                       data = sim$data, group = "group",
-                       dist = "hnormal")
-
-# Truncated normal: u ~ N+(mu, sigma_u^2)
-fit_tn <- metafrontier(log_y ~ log_x1 + log_x2,
-                       data = sim$data, group = "group",
-                       dist = "tnormal")
-
-# Exponential: u ~ Exp(1/sigma_u)
-fit_exp <- metafrontier(log_y ~ log_x1 + log_x2,
-                        data = sim$data, group = "group",
-                        dist = "exponential")
    +
    # Half-normal (default): u ~ |N(0, sigma_u^2)|
+fit_hn <- metafrontier(log_y ~ log_x1 + log_x2,
+                       data = sim$data, group = "group",
+                       dist = "hnormal")
+
+# Truncated normal: u ~ N+(mu, sigma_u^2)
+fit_tn <- metafrontier(log_y ~ log_x1 + log_x2,
+                       data = sim$data, group = "group",
+                       dist = "tnormal")
+
+# Exponential: u ~ Exp(1/sigma_u)
+fit_exp <- metafrontier(log_y ~ log_x1 + log_x2,
+                        data = sim$data, group = "group",
+                        dist = "exponential")

    Comparing true and estimated values

    Since we used simulated data, we can compare estimated values against the truth:

    -
    # True vs estimated metafrontier coefficients
-cbind(
-  True = sim$params$beta_meta,
-  Estimated = coef(fit_det, which = "meta")
-)
-#>             True Estimated
-#> (Intercept)  1.0 1.0255883
-#> log_x1       0.5 0.4935078
-#> log_x2       0.3 0.2945688
-
-# True vs estimated mean TGR by group
-true_tgr <- tapply(sim$data$true_tgr, sim$data$group, mean)
-est_tgr <- tapply(fit_det$tgr, fit_det$group_vec, mean)
-cbind(True = true_tgr, Estimated = est_tgr)
-#>         True Estimated
-#> G1 1.0000000 1.0000000
-#> G2 0.7788008 0.7592884
-#> G3 0.6065307 0.6047017
-
-# Correlation between true and estimated efficiency
-cor(sim$data$true_te, fit_det$te_group)
-#> [1] 0.80659
-cor(sim$data$true_te_star, fit_det$te_meta)
-#> [1] 0.9400828
    +
    # True vs estimated metafrontier coefficients
+cbind(
+  True = sim$params$beta_meta,
+  Estimated = coef(fit_det, which = "meta")
+)
+#>             True Estimated
+#> (Intercept)  1.0 1.0255883
+#> log_x1       0.5 0.4935078
+#> log_x2       0.3 0.2945688
+
+# True vs estimated mean TGR by group
+true_tgr <- tapply(sim$data$true_tgr, sim$data$group, mean)
+est_tgr <- tapply(fit_det$tgr, fit_det$group_vec, mean)
+cbind(True = true_tgr, Estimated = est_tgr)
+#>         True Estimated
+#> G1 1.0000000 1.0000000
+#> G2 0.7788008 0.7592884
+#> G3 0.6065307 0.6047017
+
+# Correlation between true and estimated efficiency
+cor(sim$data$true_te, fit_det$te_group)
+#> [1] 0.8049637
+cor(sim$data$true_te_star, fit_det$te_meta)
+#> [1] 0.9395109

    Panel SFA Metafrontier

    The package supports panel data via the Battese-Coelli (1992) and (1995) models. Use the panel argument:

    -
    # Simulate panel data
-panel_sim <- simulate_panel_metafrontier(
-  n_groups = 2, n_firms_per_group = 20, n_periods = 5, seed = 42
-)
-
-# BC92: time-varying inefficiency u_it = u_i * exp(-eta*(t-T))
-fit_panel <- metafrontier(
-  log_y ~ log_x1 + log_x2,
-  data = panel_sim$data,
-  group = "group",
-  panel = list(id = "firm", time = "year"),
-  panel_dist = "bc92"
-)
-summary(fit_panel)
-
-# The eta parameter captures time-varying inefficiency
-# eta > 0: inefficiency decreasing over time
-# eta < 0: inefficiency increasing over time
    +
    # Simulate panel data
+panel_sim <- simulate_panel_metafrontier(
+  n_groups = 2, n_firms_per_group = 20, n_periods = 5, seed = 42
+)
+
+# BC92: time-varying inefficiency u_it = u_i * exp(-eta*(t-T))
+fit_panel <- metafrontier(
+  log_y ~ log_x1 + log_x2,
+  data = panel_sim$data,
+  group = "group",
+  panel = list(id = "firm", time = "year"),
+  panel_dist = "bc92"
+)
+summary(fit_panel)
+
+# The eta parameter captures time-varying inefficiency
+# eta > 0: inefficiency decreasing over time
+# eta < 0: inefficiency increasing over time

    Bootstrap Confidence Intervals for TGR

    The boot_tgr() function provides parametric and nonparametric bootstrap confidence intervals for the technology gap ratio:

    -
    sim <- simulate_metafrontier(n_groups = 2, n_per_group = 100, seed = 42)
-fit <- metafrontier(log_y ~ log_x1 + log_x2, data = sim$data,
-                    group = "group", meta_type = "stochastic")
-
-# Nonparametric bootstrap (case resampling within groups)
-boot <- boot_tgr(fit, R = 499, type = "nonparametric", seed = 1)
-print(boot)
-
-# Observation-level CIs
-ci <- confint(boot)
-head(ci)
-
-# Group-level mean TGR CIs
-boot$ci_group
-
-# Parametric bootstrap (resample from estimated error distributions)
-boot_par <- boot_tgr(fit, R = 499, type = "parametric", seed = 1)
    +
    sim <- simulate_metafrontier(n_groups = 2, n_per_group = 100, seed = 42)
+fit <- metafrontier(log_y ~ log_x1 + log_x2, data = sim$data,
+                    group = "group", meta_type = "stochastic")
+
+# Nonparametric bootstrap (case resampling within groups)
+boot <- boot_tgr(fit, R = 499, type = "nonparametric", seed = 1)
+print(boot)
+
+# Observation-level CIs
+ci <- confint(boot)
+head(ci)
+
+# Group-level mean TGR CIs
+boot$ci_group
+
+# Parametric bootstrap (resample from estimated error distributions)
+boot_par <- boot_tgr(fit, R = 499, type = "parametric", seed = 1)

    Murphy-Topel Variance Correction

    @@ -868,66 +936,70 @@

    Murphy-Topel Variance Correction

    uses fitted values from Stage 1 as regressors. This “generated regressor” problem means naive standard errors understate uncertainty. The Murphy-Topel (1985) correction adjusts for this:

    -
    fit <- metafrontier(log_y ~ log_x1 + log_x2, data = sim$data,
-                    group = "group", meta_type = "stochastic")
-
-# Naive (uncorrected) standard errors
-vcov(fit)
-
-# Murphy-Topel corrected standard errors
-vcov(fit, correction = "murphy-topel")
-
-# Corrected confidence intervals
-confint(fit, correction = "murphy-topel")
    +
    fit <- metafrontier(log_y ~ log_x1 + log_x2, data = sim$data,
+                    group = "group", meta_type = "stochastic")
+
+# Naive (uncorrected) standard errors
+vcov(fit)
+
+# Murphy-Topel corrected standard errors
+vcov(fit, correction = "murphy-topel")
+
+# Corrected confidence intervals
+confint(fit, correction = "murphy-topel")

    Latent Class Metafrontier

    When group membership is unobserved, use latent_class_metafrontier():

    -
    sim <- simulate_metafrontier(n_groups = 2, n_per_group = 100, seed = 42)
-
-# Fit with 2 latent classes
-lc <- latent_class_metafrontier(
-  log_y ~ log_x1 + log_x2,
-  data = sim$data, n_classes = 2,
-  n_starts = 5, seed = 123
-)
-print(lc)
-summary(lc)
-
-# Select optimal number of classes via BIC
-bic_table <- select_n_classes(
-  log_y ~ log_x1 + log_x2, data = sim$data,
-  n_classes_range = 2:4, n_starts = 3, seed = 42
-)
-print(bic_table)  # choose n_classes with lowest BIC
    +
    sim <- simulate_metafrontier(n_groups = 2, n_per_group = 100, seed = 42)
+
+# Fit with 2 latent classes
+lc <- latent_class_metafrontier(
+  log_y ~ log_x1 + log_x2,
+  data = sim$data, n_classes = 2,
+  n_starts = 5, seed = 123
+)
+print(lc)
+summary(lc)
+
+# Select optimal number of classes via BIC
+bic_table <- select_n_classes(
+  log_y ~ log_x1 + log_x2, data = sim$data,
+  n_classes_range = 2:4, n_starts = 3, seed = 42
+)
+print(bic_table)  # choose n_classes with lowest BIC

    Directional Distance Functions (DDF)

    For additive efficiency decomposition, use DDF-based metafrontier:

    -
    sim <- simulate_metafrontier(n_groups = 2, n_per_group = 50, seed = 42)
-# Use raw (non-log) data for DEA
-sim$data$y <- exp(sim$data$log_y)
-sim$data$x1 <- exp(sim$data$log_x1)
-sim$data$x2 <- exp(sim$data$log_x2)
-
-fit_ddf <- metafrontier(
-  y ~ x1 + x2, data = sim$data, group = "group",
-  method = "dea", type = "directional", direction = "output"
-)
-summary(fit_ddf)
-
-# Additive decomposition: beta_meta = beta_group + ddf_tgr
-head(data.frame(
-  beta_meta = fit_ddf$beta_meta,
-  beta_group = fit_ddf$beta_group,
-  ddf_tgr = fit_ddf$ddf_tgr
-))
    +
    sim <- simulate_metafrontier(n_groups = 2, n_per_group = 50, seed = 42)
+# Use raw (non-log) data for DEA
+sim$data$y <- exp(sim$data$log_y)
+sim$data$x1 <- exp(sim$data$log_x1)
+sim$data$x2 <- exp(sim$data$log_x2)
+
+fit_ddf <- metafrontier(
+  y ~ x1 + x2, data = sim$data, group = "group",
+  method = "dea", type = "directional", direction = "output"
+)
+summary(fit_ddf)
+
+# Additive decomposition: beta_meta = beta_group + ddf_tgr
+head(data.frame(
+  beta_meta = fit_ddf$beta_meta,
+  beta_group = fit_ddf$beta_group,
+  ddf_tgr = fit_ddf$ddf_tgr
+))

    References

      +

    • Battese, G.E. and Coelli, T.J. (1988). Prediction of firm-level +technical efficiencies with a generalized frontier production function +and panel data. Journal of Econometrics, 38(3), +387–399.

    • Battese, G.E., Rao, D.S.P. and O’Donnell, C.J. (2004). A metafrontier production function for estimation of technical efficiencies and technology gaps for firms operating under different @@ -937,6 +1009,10 @@

      References

      to estimating the metafrontier production function based on a stochastic frontier framework. Journal of Productivity Analysis, 42(3), 241–254.

      • +

    • Jondrow, J., Lovell, C.A.K., Materov, I.S. and Schmidt, P. +(1982). On the estimation of technical inefficiency in the stochastic +frontier production function model. Journal of Econometrics, +19(2–3), 233–238.

    • O’Donnell, C.J., Rao, D.S.P. and Battese, G.E. (2008). Metafrontier frameworks for the study of firm-level efficiencies and technology ratios. Empirical Economics, 34(2), diff --git a/inst/doc/malmquist.R b/inst/doc/malmquist.R index 8480aae..e0e40a1 100644 --- a/inst/doc/malmquist.R +++ b/inst/doc/malmquist.R @@ -6,9 +6,11 @@ knitr::opts_chunk$set( fig.height = 5 ) + ## ----setup-------------------------------------------------------------------- library(metafrontier) + ## ----simulate-panel----------------------------------------------------------- set.seed(42) panels <- lapply(1:4, function(t) { @@ -29,29 +31,35 @@ panel_data <- do.call(rbind, panels) table(panel_data$group, panel_data$time) + ## ----malmquist---------------------------------------------------------------- malm <- malmquist_meta( log_y ~ log_x1 + log_x2, data = panel_data, group = "group", time = "time", + id = "id", orientation = "output", rts = "crs" ) malm + ## ----summary------------------------------------------------------------------ summary(malm) + ## ----results-table------------------------------------------------------------ head(malm$malmquist, 10) + ## ----verify-identity---------------------------------------------------------- m <- malm$malmquist complete <- complete.cases(m[, c("MPI", "TEC", "TGC", "TC")]) all.equal(m$MPI[complete], m$TEC[complete] * m$TGC[complete] * m$TC[complete]) + ## ----group-vs-meta------------------------------------------------------------ # Within-group: MPI_group = EC_group x TC_group head(malm$group_malmquist) @@ -59,21 +67,25 @@ head(malm$group_malmquist) # Metafrontier: MPI_meta = EC_meta x TC_meta head(malm$meta_malmquist) + ## ----tgr-dynamics------------------------------------------------------------- tgr_df <- malm$tgr # Mean TGR by group and period aggregate(cbind(TGR_from, TGR_to) ~ group, data = tgr_df, FUN = mean) + ## ----tgc-by-group------------------------------------------------------------- aggregate(TGC ~ group, data = tgr_df, FUN = mean) + ## ----vrs-comparison----------------------------------------------------------- malm_vrs <- malmquist_meta( log_y ~ log_x1 + log_x2, data = panel_data, group = "group", time = "time", + id = "id", rts = "vrs" ) @@ -85,6 +97,7 @@ data.frame( na.rm = TRUE) ) + ## ----produc-example, eval = FALSE--------------------------------------------- # library(plm) # data("Produc", package = "plm") @@ -94,10 +107,12 @@ data.frame( # data = Produc, # group = "region", # time = "year", +# id = "state", # rts = "crs" # ) # summary(malm_us) + ## ----utility-example, eval = FALSE-------------------------------------------- # library(sfaR) # data("utility", package = "sfaR") @@ -107,6 +122,7 @@ data.frame( # data = utility, # group = "regu", # time = "year", +# id = "firm", # rts = "vrs" # ) # summary(malm_util) diff --git a/inst/doc/malmquist.Rmd b/inst/doc/malmquist.Rmd index 4bd6306..f25678a 100644 --- a/inst/doc/malmquist.Rmd +++ b/inst/doc/malmquist.Rmd @@ -24,9 +24,10 @@ library(metafrontier) Standard Malmquist productivity indices measure productivity change over time by decomposing it into efficiency change and technical change. When -firms operate under different technologies, however, this decomposition -misses an important dimension: changes in the *technology gap* between a -group's frontier and the global best practice. +groups of firms face different restrictions of a common metatechnology, +however, this decomposition misses an important dimension: changes in +the *technology gap* between a group's frontier and the global best +practice. The **metafrontier Malmquist TFP index** of O'Donnell, Rao, and Battese (2008) extends the standard index with a three-way decomposition that @@ -97,6 +98,7 @@ malm <- malmquist_meta( data = panel_data, group = "group", time = "time", + id = "id", orientation = "output", rts = "crs" ) @@ -104,6 +106,10 @@ malm <- malmquist_meta( malm ``` +The `id` argument identifies firms across periods. Firms not observed +in both periods of a consecutive pair are dropped from that comparison, +and `malmquist_meta()` warns about how many observations were dropped. + ## Detailed results @@ -190,6 +196,7 @@ malm_vrs <- malmquist_meta( data = panel_data, group = "group", time = "time", + id = "id", rts = "vrs" ) @@ -218,13 +225,16 @@ malm_us <- malmquist_meta( data = Produc, group = "region", time = "year", + id = "state", rts = "crs" ) summary(malm_us) ``` Similarly, `sfaR::utility` provides electric utility data with a binary -`regu` variable (regulated vs. deregulated) over 1986--1996: +`regu` variable (retail-access vs. traditionally regulated states) over +1986--1996, where `regu = 1` indicates that the state had enacted +retail-access (restructuring) legislation: ```{r utility-example, eval = FALSE} library(sfaR) @@ -235,14 +245,59 @@ malm_util <- malmquist_meta( data = utility, group = "regu", time = "year", + id = "firm", rts = "vrs" ) summary(malm_util) ``` +## Caveats + +A few limitations should be kept in mind when interpreting the results. + +### Interpretation of the index + +The Malmquist index, and by extension its metafrontier version, is not +a proper index in the sense of O'Donnell (2012): it is not +multiplicatively complete, and its binary comparisons are not +transitive, so chained comparisons across several periods depend on the +path taken. Interpretation should therefore be confined to binary +period-to-period comparisons; avoid cumulating the indices into a +multi-period productivity level series. + +### Cross-period infeasibility + +Under `rts = "vrs"`, `"drs"`, `"irs"`, or `"fdh"`, the cross-period +distance functions (evaluating a period-$t$ observation against the +period-$s$ frontier) may have no feasible solution. Infeasible cases +are returned as `NA` (never `Inf`), counted, and reported, so summary +statistics over the remaining observations should be read with the +reduced sample in mind. Under `rts = "crs"` the programmes are always +feasible. + +### Firm matching + +Observations are matched across consecutive periods via the `id` +variable. Firms observed in only one period of a pair are dropped from +that comparison, and `malmquist_meta()` warns about the number of +dropped observations. With substantial attrition or entry, the index is +computed on the surviving matched sample only. + +### SFA-based index + +With `method = "sfa"`, the metafrontier at each period is formed as the +pointwise maximum of the fitted group frontiers, an approximation that +the function announces with a message. For exact decompositions, prefer +the default `method = "dea"`. + + ## References +- O'Donnell, C.J. (2012). An aggregate quantity framework for measuring + and decomposing productivity change. *Journal of Productivity + Analysis*, 38(3), 255--272. + - O'Donnell, C.J., Rao, D.S.P. and Battese, G.E. (2008). Metafrontier frameworks for the study of firm-level efficiencies and technology ratios. *Empirical Economics*, 34(2), 231--255. diff --git a/inst/doc/malmquist.html b/inst/doc/malmquist.html index 6e12373..ed01111 100644 --- a/inst/doc/malmquist.html +++ b/inst/doc/malmquist.html @@ -347,10 +347,10 @@

      Metafrontier Malmquist Productivity

      Motivation

      Standard Malmquist productivity indices measure productivity change over time by decomposing it into efficiency change and technical change. -When firms operate under different technologies, however, this -decomposition misses an important dimension: changes in the -technology gap between a group’s frontier and the global best -practice.

      +When groups of firms face different restrictions of a common +metatechnology, however, this decomposition misses an important +dimension: changes in the technology gap between a group’s +frontier and the global best practice.

      The metafrontier Malmquist TFP index of O’Donnell, Rao, and Battese (2008) extends the standard index with a three-way decomposition that separates within-group dynamics from cross-group @@ -416,25 +416,31 @@

      Computing the index

      data = panel_data, group = "group", time = "time", - orientation = "output", - rts = "crs" -) - -malm -#> -#> Metafrontier Malmquist TFP Index -#> ================================ -#> Orientation: output -#> RTS: crs -#> Groups: G1, G2 -#> Periods: 1 -> 2 -> 3 -> 4 -#> Observations: 300 -#> -#> Mean decomposition (M* = TEC x TGC x TC*): -#> MPI = 1.085 -#> TEC = 1.123 -#> TGC = 1.127 -#> TC* = 0.9818
    + id = "id", + orientation = "output", + rts = "crs" +) + +malm +#> +#> Metafrontier Malmquist TFP Index +#> ================================ +#> Method: dea +#> Orientation: output +#> RTS: crs +#> Groups: G1, G2 +#> Periods: 1 -> 2 -> 3 -> 4 +#> Observations: 300 +#> +#> Mean decomposition (M* = TEC x TGC x TC*): +#> MPI = 1.145 +#> TEC = 1.123 +#> TGC = 1.127 +#> TC* = 1.002 +

    The id argument identifies firms across periods. Firms +not observed in both periods of a consecutive pair are dropped from that +comparison, and malmquist_meta() warns about how many +observations were dropped.

    Detailed results

    @@ -447,56 +453,58 @@

    Detailed results

    #> #> Call: #> malmquist_meta(formula = log_y ~ log_x1 + log_x2, data = panel_data, -#> group = "group", time = "time", orientation = "output", rts = "crs") -#> -#> Orientation: output -#> RTS: crs -#> Groups: G1, G2 -#> Periods: 1 -> 2 -> 3 -> 4 -#> Observations: 300 -#> -#> Overall means: -#> MPI = 1.085 -#> TEC = 1.123 -#> TGC = 1.127 -#> TC* = 0.9818 -#> -#> --- Three-Way Decomposition by Group --- -#> M* = TEC x TGC x TC* -#> -#> Group: G1 (n = 150 ) -#> MPI TEC TGC TC -#> 1.0726 1.2388 0.9833 0.9874 -#> -#> Group: G2 (n = 150 ) -#> MPI TEC TGC TC -#> 1.0962 1.0082 1.2703 0.9766 -#> -#> --- By Period --- +#> group = "group", time = "time", id = "id", orientation = "output", +#> rts = "crs") +#> +#> Method: dea +#> Orientation: output +#> RTS: crs +#> Groups: G1, G2 +#> Periods: 1 -> 2 -> 3 -> 4 +#> Observations: 300 +#> +#> Overall means: +#> MPI = 1.145 +#> TEC = 1.123 +#> TGC = 1.127 +#> TC* = 1.002 +#> +#> --- Three-Way Decomposition by Group --- +#> M* = TEC x TGC x TC* +#> +#> Group: G1 (n = 150 ) +#> MPI TEC TGC TC +#> 1.1806 1.2388 0.9833 1.0273 +#> +#> Group: G2 (n = 150 ) +#> MPI TEC TGC TC +#> 1.1096 1.0082 1.2703 0.9767 #> -#> Period 1 -> 2 -#> MPI TEC TGC TC -#> 1.1697 1.0360 1.3314 0.9044 -#> -#> Period 2 -> 3 -#> MPI TEC TGC TC -#> 1.0470 1.5288 1.0757 0.6282 -#> -#> Period 3 -> 4 -#> MPI TEC TGC TC -#> 1.0364 0.8056 0.9732 1.4224 -#> -#> --- Technology Gap Ratios --- +#> --- By Period --- +#> +#> Period 1 -> 2 +#> MPI TEC TGC TC +#> 1.3082 1.0360 1.3314 0.9567 +#> +#> Period 2 -> 3 +#> MPI TEC TGC TC +#> 1.0250 1.5288 1.0757 0.6300 +#> +#> Period 3 -> 4 +#> MPI TEC TGC TC +#> 1.1021 0.8056 0.9732 1.4194 #> -#> Group: G1 -#> Mean TGR (from): 0.987 -#> Mean TGR (to): 0.9687 -#> Mean TGC: 0.9833 -#> -#> Group: G2 -#> Mean TGR (from): 0.7011 -#> Mean TGR (to): 0.8234 -#> Mean TGC: 1.27
    +#> --- Technology Gap Ratios --- +#> +#> Group: G1 +#> Mean TGR (from): 0.987 +#> Mean TGR (to): 0.9687 +#> Mean TGC: 0.9833 +#> +#> Group: G2 +#> Mean TGR (from): 0.7011 +#> Mean TGR (to): 0.8234 +#> Mean TGC: 1.27

    Interpreting the decomposition

    @@ -559,7 +567,7 @@

    Within-group vs metafrontier Malmquist

    # Within-group: MPI_group = EC_group x TC_group
 head(malm$group_malmquist)
 #>   id group period_from period_to MPI_group  EC_group  TC_group
-#> 1  1    G1           1         2        NA 2.7812965        NA
+#> 1  1    G1           1         2  6.164525 2.7812965 2.2164215
 #> 2  2    G1           1         2  1.757668 2.2260475 0.7895912
 #> 3  3    G1           1         2  0.556865 0.6482012 0.8590929
 #> 4  4    G1           1         2  1.018773 1.1385028 0.8948361
@@ -607,21 +615,24 @@ 
    Returns to scale assumptions
    
   data = panel_data,
   group = "group",
   time = "time",
-  rts = "vrs"
-)
-
-# Compare mean MPI under CRS vs VRS
-data.frame(
-  CRS = colMeans(malm$malmquist[, c("MPI", "TEC", "TGC", "TC")],
-                 na.rm = TRUE),
-  VRS = colMeans(malm_vrs$malmquist[, c("MPI", "TEC", "TGC", "TC")],
-                 na.rm = TRUE)
-)
-#>           CRS      VRS
-#> MPI 1.0847509 1.018219
-#> TEC 1.1234751 1.004931
-#> TGC 1.1267757 1.014285
-#> TC  0.9818377 1.005744
    + id = "id", + rts = "vrs" +) +#> Warning: 68 of 1200 cross-period DEA programs were infeasible (rts = "vrs"); +#> the affected TC and MPI values are NA and are excluded from reported means. + +# Compare mean MPI under CRS vs VRS +data.frame( + CRS = colMeans(malm$malmquist[, c("MPI", "TEC", "TGC", "TC")], + na.rm = TRUE), + VRS = colMeans(malm_vrs$malmquist[, c("MPI", "TEC", "TGC", "TC")], + na.rm = TRUE) +) +#> CRS VRS +#> MPI 1.145084 1.0121064 +#> TEC 1.123475 1.0049310 +#> TGC 1.126776 1.0142854 +#> TC 1.002026 0.9998827

    Using real-world panel data

    @@ -637,12 +648,15 @@

    Using real-world panel data

    data = Produc, group = "region", time = "year", - rts = "crs" -) -summary(malm_us)
    + id = "state", + rts = "crs" +) +summary(malm_us)

    Similarly, sfaR::utility provides electric utility data -with a binary regu variable (regulated vs. deregulated) -over 1986–1996:

    +with a binary regu variable (retail-access +vs. traditionally regulated states) over 1986–1996, where +regu = 1 indicates that the state had enacted retail-access +(restructuring) legislation:

    library(sfaR)
 data("utility", package = "sfaR")
 
@@ -651,13 +665,60 @@ 
    Using real-world panel data
    
   data = utility,
   group = "regu",
   time = "year",
-  rts = "vrs"
-)
-summary(malm_util)
    + id = "firm", + rts = "vrs" +) +summary(malm_util) + +
    +

    Caveats

    +

    A few limitations should be kept in mind when interpreting the +results.

    +
    +

    Interpretation of the index

    +

    The Malmquist index, and by extension its metafrontier version, is +not a proper index in the sense of O’Donnell (2012): it is not +multiplicatively complete, and its binary comparisons are not +transitive, so chained comparisons across several periods depend on the +path taken. Interpretation should therefore be confined to binary +period-to-period comparisons; avoid cumulating the indices into a +multi-period productivity level series.

    +
    +
    +

    Cross-period infeasibility

    +

    Under rts = "vrs", "drs", +"irs", or "fdh", the cross-period distance +functions (evaluating a period-\(t\) +observation against the period-\(s\) +frontier) may have no feasible solution. Infeasible cases are returned +as NA (never Inf), counted, and reported, so +summary statistics over the remaining observations should be read with +the reduced sample in mind. Under rts = "crs" the +programmes are always feasible.

    +
    +
    +

    Firm matching

    +

    Observations are matched across consecutive periods via the +id variable. Firms observed in only one period of a pair +are dropped from that comparison, and malmquist_meta() +warns about the number of dropped observations. With substantial +attrition or entry, the index is computed on the surviving matched +sample only.

    +
    +
    +

    SFA-based index

    +

    With method = "sfa", the metafrontier at each period is +formed as the pointwise maximum of the fitted group frontiers, an +approximation that the function announces with a message. For exact +decompositions, prefer the default method = "dea".

    +

    References

      +

    • O’Donnell, C.J. (2012). An aggregate quantity framework for +measuring and decomposing productivity change. Journal of +Productivity Analysis, 38(3), 255–272.

    • O’Donnell, C.J., Rao, D.S.P. and Battese, G.E. (2008). Metafrontier frameworks for the study of firm-level efficiencies and technology ratios. Empirical Economics, 34(2), diff --git a/inst/doc/methods.R b/inst/doc/methods.R index c610eca..8aa3abd 100644 --- a/inst/doc/methods.R +++ b/inst/doc/methods.R @@ -6,9 +6,11 @@ knitr::opts_chunk$set( fig.height = 5 ) + ## ----setup-------------------------------------------------------------------- library(metafrontier) + ## ----det-example-------------------------------------------------------------- sim <- simulate_metafrontier( n_groups = 2, n_per_group = 300, @@ -30,11 +32,29 @@ coef(fit_det, which = "meta") # Group coefficients for comparison coef(fit_det, which = "group") + ## ----verify-envelop----------------------------------------------------------- meta_b0 <- coef(fit_det, which = "meta")[1] group_b0 <- sapply(coef(fit_det, which = "group"), `[`, 1) meta_b0 >= group_b0 + +## ----det-qp------------------------------------------------------------------- +fit_qp <- metafrontier( + log_y ~ log_x1 + log_x2, + data = sim$data, + group = "group", + meta_type = "deterministic", + objective = "qp" +) + +# LP and QP criteria typically give very similar coefficients +cbind( + LP = coef(fit_det, which = "meta"), + QP = coef(fit_qp, which = "meta") +) + + ## ----sto-example-------------------------------------------------------------- fit_sto <- metafrontier( log_y ~ log_x1 + log_x2, @@ -45,6 +65,7 @@ fit_sto <- metafrontier( summary(fit_sto) + ## ----sto-inference------------------------------------------------------------ # Variance-covariance matrix vcov(fit_sto) @@ -52,10 +73,12 @@ vcov(fit_sto) # Log-likelihood of the metafrontier model logLik(fit_sto) + ## ----tgr-range---------------------------------------------------------------- tgr_vals <- efficiencies(fit_sto, type = "tgr") summary(tgr_vals) + ## ----dea-example-------------------------------------------------------------- # CRS metafrontier fit_crs <- metafrontier( @@ -81,6 +104,7 @@ cbind( VRS = tapply(fit_vrs$tgr, fit_vrs$group_vec, mean) ) + ## ----compare-methods---------------------------------------------------------- # Compare TGR estimates across methods tgr_det <- tapply(fit_det$tgr, fit_det$group_vec, mean) @@ -96,9 +120,11 @@ comparison <- data.frame( ) round(comparison, 4) + ## ----poolability-------------------------------------------------------------- poolability_test(fit_det) + ## ----monte-carlo, eval=FALSE-------------------------------------------------- # # Monte Carlo: check parameter recovery over 100 replications # set.seed(1) diff --git a/inst/doc/methods.Rmd b/inst/doc/methods.Rmd index 6d716ba..2f45be4 100644 --- a/inst/doc/methods.Rmd +++ b/inst/doc/methods.Rmd @@ -43,7 +43,12 @@ The group-specific technical efficiency is: $$TE_{ij} = \exp(-u_{ij}) \in (0, 1]$$ -estimated via the Jondrow et al. (1982) conditional mean estimator. +estimated by default via the Battese and Coelli (1988) conditional +expectation estimator $E[\exp(-u_{ij}) \mid \varepsilon_{ij}]$ +(`estimator = "bc88"`). The Jondrow et al. (1982) estimator +$\exp(-E[u_{ij} \mid \varepsilon_{ij}])$ is also computed and stored, and +`efficiencies(fit, estimator = "jlms")` switches between the two without +refitting. ### 1.2 The metafrontier @@ -53,9 +58,14 @@ that: $$x'\beta^* \ge x'\beta_j \quad \text{for all } x \text{ and all } j$$ -That is, the metafrontier weakly dominates all group frontiers. It -represents the production technology available to firms with unrestricted -access to all technologies. +That is, the metafrontier weakly dominates all group frontiers. It is +the boundary of the industry **metatechnology** $T^*$: the set of all +input-output combinations that are technically feasible in the industry +(Battese, Rao and O'Donnell, 2004; O'Donnell, Rao and Battese, 2008). +Each group frontier bounds a restricted subset $T_j \subseteq T^*$ of +this metatechnology, where the restrictions reflect regulation, the +physical environment, resource endowments, or the cost of switching +production systems. ### 1.3 The efficiency decomposition @@ -76,15 +86,36 @@ that input mix; values below 1 indicate a technology gap. ### 2.1 Estimation -After obtaining group estimates $\hat\beta_j$ in Stage 1, the metafrontier -parameters $\hat\beta^*$ are estimated by solving: +After obtaining group estimates $\hat\beta_j$ in Stage 1, the +metafrontier parameters $\hat\beta^*$ are chosen so that the metafrontier +lies as close as possible to the group frontiers while enveloping all of +them. Battese, Rao and O'Donnell (2004) propose two optimisation +criteria, both implemented in the package via the `objective` argument. -$$\min_{\beta^*} \sum_{j=1}^{J} \sum_{i=1}^{n_j} \left(x_{ij}'\beta^* - x_{ij}'\hat\beta_j\right)^2$$ +**Minimum sum of absolute deviations** (`objective = "lp"`, the default): + +$$\min_{\beta^*} \sum_{j=1}^{J} \sum_{i=1}^{n_j} \left|x_{ij}'\beta^* - x_{ij}'\hat\beta_j\right|$$ $$\text{subject to: } x_{ij}'\beta^* \ge x_{ij}'\hat\beta_j \quad \forall\, i, j$$ -This is a convex quadratic program. The `metafrontier` package solves it -using `constrOptim()` from base R, which implements an adaptive barrier -algorithm for linearly constrained optimisation. +Because the envelopment constraints force every deviation to be +non-negative, the absolute values can be dropped and the problem reduces +to a linear programme (O'Donnell, Rao and Battese, 2008, Eqs. 23-25). +This LP is the primary presentation in O'Donnell, Rao and Battese (2008) +and is the package default; it is solved with `lpSolveAPI`. + +**Minimum sum of squared deviations** (`objective = "qp"`): + +$$\min_{\beta^*} \sum_{j=1}^{J} \sum_{i=1}^{n_j} \left(x_{ij}'\beta^* - x_{ij}'\hat\beta_j\right)^2$$ + +subject to the same envelopment constraints. This is a convex quadratic +programme, solved exactly with `quadprog` when that package is +available, with an adaptive-barrier fallback via `constrOptim()` from +base R otherwise. + +The two criteria weight deviations differently (the squared criterion +penalises large gaps between the metafrontier and a group frontier more +heavily), but in practice they typically produce very similar +coefficients. ### 2.2 Properties @@ -129,6 +160,25 @@ group_b0 <- sapply(coef(fit_det, which = "group"), `[`, 1) meta_b0 >= group_b0 ``` +To use the minimum sum of squared deviations criterion instead, set +`objective = "qp"`: + +```{r det-qp} +fit_qp <- metafrontier( + log_y ~ log_x1 + log_x2, + data = sim$data, + group = "group", + meta_type = "deterministic", + objective = "qp" +) + +# LP and QP criteria typically give very similar coefficients +cbind( + LP = coef(fit_det, which = "meta"), + QP = coef(fit_qp, which = "meta") +) +``` + ## 3. Stochastic metafrontier (Huang, Huang, and Liu, 2014) @@ -349,8 +399,9 @@ on the pooled sample and $LL_j$ are the group-specific log-likelihoods. poolability_test(fit_det) ``` -A significant test (p < 0.05) confirms that the groups operate under -different technologies and the metafrontier decomposition is warranted. +A significant test (p < 0.05) confirms that the group frontiers differ, +that is, the groups face different restrictions of the common +metatechnology, and the metafrontier decomposition is warranted. ## 8. Simulation for Monte Carlo studies @@ -397,6 +448,10 @@ The `simulate_metafrontier()` function supports: ## References +- Battese, G.E. and Coelli, T.J. (1988). Prediction of firm-level + technical efficiencies with a generalized frontier production function + and panel data. *Journal of Econometrics*, 38(3), 387--399. + - Battese, G.E., Rao, D.S.P. and O'Donnell, C.J. (2004). A metafrontier production function for estimation of technical efficiencies and technology gaps for firms operating under different technologies. diff --git a/inst/doc/methods.html b/inst/doc/methods.html index 35e4b8d..abb6654 100644 --- a/inst/doc/methods.html +++ b/inst/doc/methods.html @@ -363,8 +363,13 @@

      1.1 Group-specific stochastic frontiers

      The group-specific technical efficiency is:

      \[TE_{ij} = \exp(-u_{ij}) \in (0, 1]\]

      -

      estimated via the Jondrow et al. (1982) conditional mean -estimator.

      +

      estimated by default via the Battese and Coelli (1988) conditional +expectation estimator \(E[\exp(-u_{ij}) \mid +\varepsilon_{ij}]\) (estimator = "bc88"). The +Jondrow et al. (1982) estimator \(\exp(-E[u_{ij} \mid \varepsilon_{ij}])\) is +also computed and stored, and +efficiencies(fit, estimator = "jlms") switches between the +two without refitting.

    1.2 The metafrontier

    @@ -372,9 +377,14 @@

    1.2 The metafrontier

    that:

    \[x'\beta^* \ge x'\beta_j \quad \text{for all } x \text{ and all } j\]

    -

    That is, the metafrontier weakly dominates all group frontiers. It -represents the production technology available to firms with -unrestricted access to all technologies.

    +

    That is, the metafrontier weakly dominates all group frontiers. It is +the boundary of the industry metatechnology \(T^*\): the set of all input-output +combinations that are technically feasible in the industry (Battese, Rao +and O’Donnell, 2004; O’Donnell, Rao and Battese, 2008). Each group +frontier bounds a restricted subset \(T_j +\subseteq T^*\) of this metatechnology, where the restrictions +reflect regulation, the physical environment, resource endowments, or +the cost of switching production systems.

    1.3 The efficiency decomposition

    @@ -397,16 +407,36 @@

    2. Deterministic metafrontier (Battese, Rao, and O’Donnell,

    2.1 Estimation

    After obtaining group estimates \(\hat\beta_j\) in Stage 1, the metafrontier -parameters \(\hat\beta^*\) are -estimated by solving:

    +parameters \(\hat\beta^*\) are chosen +so that the metafrontier lies as close as possible to the group +frontiers while enveloping all of them. Battese, Rao and O’Donnell +(2004) propose two optimisation criteria, both implemented in the +package via the objective argument.

    +

    Minimum sum of absolute deviations +(objective = "lp", the default):

    \[\min_{\beta^*} \sum_{j=1}^{J} -\sum_{i=1}^{n_j} \left(x_{ij}'\beta^* - -x_{ij}'\hat\beta_j\right)^2\] \[\text{subject to: } x_{ij}'\beta^* \ge +\sum_{i=1}^{n_j} \left|x_{ij}'\beta^* - +x_{ij}'\hat\beta_j\right|\] \[\text{subject to: } x_{ij}'\beta^* \ge x_{ij}'\hat\beta_j \quad \forall\, i, j\]

    -

    This is a convex quadratic program. The metafrontier -package solves it using constrOptim() from base R, which -implements an adaptive barrier algorithm for linearly constrained -optimisation.

    +

    Because the envelopment constraints force every deviation to be +non-negative, the absolute values can be dropped and the problem reduces +to a linear programme (O’Donnell, Rao and Battese, 2008, Eqs. 23-25). +This LP is the primary presentation in O’Donnell, Rao and Battese (2008) +and is the package default; it is solved with +lpSolveAPI.

    +

    Minimum sum of squared deviations +(objective = "qp"):

    +

    \[\min_{\beta^*} \sum_{j=1}^{J} +\sum_{i=1}^{n_j} \left(x_{ij}'\beta^* - +x_{ij}'\hat\beta_j\right)^2\]

    +

    subject to the same envelopment constraints. This is a convex +quadratic programme, solved exactly with quadprog when that +package is available, with an adaptive-barrier fallback via +constrOptim() from base R otherwise.

    +

    The two criteria weight deviations differently (the squared criterion +penalises large gaps between the metafrontier and a group frontier more +heavily), but in practice they typically produce very similar +coefficients.

    2.2 Properties

    @@ -457,6 +487,25 @@

    2.3 Example

    meta_b0 >= group_b0 #> G1.(Intercept) G2.(Intercept) #> TRUE TRUE
    +

    To use the minimum sum of squared deviations criterion instead, set +objective = "qp":

    +
    fit_qp <- metafrontier(
+  log_y ~ log_x1 + log_x2,
+  data = sim$data,
+  group = "group",
+  meta_type = "deterministic",
+  objective = "qp"
+)
+
+# LP and QP criteria typically give very similar coefficients
+cbind(
+  LP = coef(fit_det, which = "meta"),
+  QP = coef(fit_qp, which = "meta")
+)
+#>                    LP        QP
+#> (Intercept) 1.0416500 1.0416500
+#> log_x1      0.4950084 0.4950084
+#> log_x2      0.1926936 0.1926936

    @@ -518,72 +567,79 @@

    3.3 Caveat: the generated-regressor problem

    3.4 Example

    -
    fit_sto <- metafrontier(
-  log_y ~ log_x1 + log_x2,
-  data = sim$data,
-  group = "group",
-  meta_type = "stochastic"
-)
-
-summary(fit_sto)
-#> 
-#> Metafrontier Model Summary
-#> ==========================
-#> 
-#> Call:
-#> metafrontier(formula = log_y ~ log_x1 + log_x2, data = sim$data, 
-#>     group = "group", meta_type = "stochastic")
-#> 
-#> Method:        sfa 
-#> Metafrontier:  stochastic 
-#> 
-#> --- Group: G1 (n = 300) ---
-#>             Estimate Std. Error z value Pr(>|z|)    
-#> (Intercept) 1.041650   0.054009   19.29   <2e-16 ***
-#> log_x1      0.495008   0.009173   53.97   <2e-16 ***
-#> log_x2      0.192694   0.008907   21.64   <2e-16 ***
-#> ---
-#> Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
-#> Log-likelihood: 22.685 
-#> 
-#> --- Group: G2 (n = 300) ---
-#>             Estimate Std. Error z value Pr(>|z|)    
-#> (Intercept)  0.58144    0.05155   11.28   <2e-16 ***
-#> log_x1       0.52876    0.01019   51.88   <2e-16 ***
-#> log_x2       0.20155    0.01037   19.44   <2e-16 ***
-#> ---
-#> Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
-#> Log-likelihood: -36.696 
-#> 
-#> --- Metafrontier ---
-#>             Estimate Std. Error z value Pr(>|z|)    
-#> (Intercept) 0.813734   0.208469   3.903 9.49e-05 ***
-#> log_x1      0.513997   0.005155  99.716  < 2e-16 ***
-#> log_x2      0.197514   0.004989  39.588  < 2e-16 ***
-#> ---
-#> Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
-#> Log-likelihood: 181.35 
-#> 
-#> --- Efficiency Decomposition ---
-#>  Group Mean_TE Mean_TGR Mean_TE_star
-#>     G1  0.8433   1.1839       0.9984
-#>     G2  0.7328   0.8306       0.6087
-#> 
-#> --- Technology Gap Ratio Summary ---
-#>  Group   N   Mean     SD    Min     Q1 Median     Q3    Max
-#>     G1 300 1.1839 0.0320 1.1222 1.1576 1.1861 1.2087 1.2464
-#>     G2 300 0.8306 0.0181 0.7949 0.8148 0.8300 0.8445 0.8693
    -

    The stochastic metafrontier provides standard errors:

    -
    # Variance-covariance matrix
-vcov(fit_sto)
-#>               (Intercept)        log_x1        log_x2
-#> (Intercept)  4.345943e-02 -8.269764e-05 -6.986322e-05
-#> log_x1      -8.269764e-05  2.657002e-05  1.867196e-06
-#> log_x2      -6.986322e-05  1.867196e-06  2.489219e-05
+
    fit_sto <- metafrontier(
+  log_y ~ log_x1 + log_x2,
+  data = sim$data,
+  group = "group",
+  meta_type = "stochastic"
+)
 
-# Log-likelihood of the metafrontier model
-logLik(fit_sto)
-#> 'log Lik.' 181.3504 (df=3)
    
+summary(fit_sto)
+#> 
+#> Metafrontier Model Summary
+#> ==========================
+#> 
+#> Call:
+#> metafrontier(formula = log_y ~ log_x1 + log_x2, data = sim$data, 
+#>     group = "group", meta_type = "stochastic")
+#> 
+#> Method:        sfa 
+#> Metafrontier:  stochastic 
+#> 
+#> --- Group: G1 (n = 300) ---
+#>              Estimate Std. Error z value Pr(>|z|)    
+#> (Intercept)  1.041650   0.054009  19.287  < 2e-16 ***
+#> log_x1       0.495008   0.009173  53.966  < 2e-16 ***
+#> log_x2       0.192694   0.008907  21.635  < 2e-16 ***
+#> log_sigma_v -1.698990   0.114126 -14.887  < 2e-16 ***
+#> log_sigma_u -1.524665   0.228427  -6.675 2.48e-11 ***
+#> ---
+#> Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
+#> Log-likelihood: 22.685 
+#> 
+#> --- Group: G2 (n = 300) ---
+#>             Estimate Std. Error z value Pr(>|z|)    
+#> (Intercept)  0.58144    0.05155   11.28   <2e-16 ***
+#> log_x1       0.52876    0.01019   51.88   <2e-16 ***
+#> log_x2       0.20155    0.01037   19.44   <2e-16 ***
+#> log_sigma_v -2.00652    0.16307  -12.30   <2e-16 ***
+#> log_sigma_u -0.87260    0.08019  -10.88   <2e-16 ***
+#> ---
+#> Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
+#> Log-likelihood: -36.696 
+#> 
+#> --- Metafrontier ---
+#>             Estimate Std. Error z value Pr(>|z|)    
+#> (Intercept) 0.813734   0.208469   3.903 9.49e-05 ***
+#> log_x1      0.513997   0.005155  99.716  < 2e-16 ***
+#> log_x2      0.197514   0.004989  39.588  < 2e-16 ***
+#> ---
+#> Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
+#> Log-likelihood: 181.35 
+#> 
+#> --- Efficiency Decomposition ---
+#>  Group Mean_TE Mean_TGR Mean_TE_star
+#>     G1  0.8477   1.1839       1.0036
+#>     G2  0.7372   0.8306       0.6124
+#> 
+#> --- Technology Gap Ratio Summary ---
+#>  Group   N   Mean     SD    Min     Q1 Median     Q3    Max
+#>     G1 300 1.1839 0.0320 1.1222 1.1576 1.1861 1.2087 1.2464
+#>     G2 300 0.8306 0.0181 0.7949 0.8148 0.8300 0.8445 0.8693
+#> 
+#> --- Convergence ---
+#> All estimation stages converged.
    +

    The stochastic metafrontier provides standard errors:

    +
    # Variance-covariance matrix
+vcov(fit_sto)
+#>               (Intercept)        log_x1        log_x2
+#> (Intercept)  4.345943e-02 -8.269764e-05 -6.986322e-05
+#> log_x1      -8.269764e-05  2.657002e-05  1.867196e-06
+#> log_x2      -6.986322e-05  1.867196e-06  2.489219e-05
+
+# Log-likelihood of the metafrontier model
+logLik(fit_sto)
+#> 'log Lik.' 181.3504 (df=3)

    3.5 A note on TGR values

    @@ -592,10 +648,10 @@

    3.5 A note on TGR values

    the metafrontier need not strictly envelop all group frontiers. Values slightly above 1 can occur and are consistent with the stochastic framework.

    -
    tgr_vals <- efficiencies(fit_sto, type = "tgr")
-summary(tgr_vals)
-#>    Min. 1st Qu.  Median    Mean 3rd Qu.    Max. 
-#>  0.7949  0.8300  0.9958  1.0072  1.1861  1.2464
    +
    tgr_vals <- efficiencies(fit_sto, type = "tgr")
+summary(tgr_vals)
+#>    Min. 1st Qu.  Median    Mean 3rd Qu.    Max. 
+#>  0.7949  0.8300  0.9958  1.0072  1.1861  1.2464
    @@ -624,32 +680,32 @@

    4.2 Returns to scale

  2. "drs" / "irs" (decreasing / increasing returns)
    3. -
    # CRS metafrontier
-fit_crs <- metafrontier(
-  log_y ~ log_x1 + log_x2,
-  data = sim$data,
-  group = "group",
-  method = "dea",
-  rts = "crs"
-)
-
-# VRS metafrontier
-fit_vrs <- metafrontier(
-  log_y ~ log_x1 + log_x2,
-  data = sim$data,
-  group = "group",
-  method = "dea",
-  rts = "vrs"
-)
-
-# Compare mean TGR
-cbind(
-  CRS = tapply(fit_crs$tgr, fit_crs$group_vec, mean),
-  VRS = tapply(fit_vrs$tgr, fit_vrs$group_vec, mean)
-)
-#>          CRS       VRS
-#> G1 1.0000000 1.0000000
-#> G2 0.6014273 0.8180669
    +
    # CRS metafrontier
+fit_crs <- metafrontier(
+  log_y ~ log_x1 + log_x2,
+  data = sim$data,
+  group = "group",
+  method = "dea",
+  rts = "crs"
+)
+
+# VRS metafrontier
+fit_vrs <- metafrontier(
+  log_y ~ log_x1 + log_x2,
+  data = sim$data,
+  group = "group",
+  method = "dea",
+  rts = "vrs"
+)
+
+# Compare mean TGR
+cbind(
+  CRS = tapply(fit_crs$tgr, fit_crs$group_vec, mean),
+  VRS = tapply(fit_vrs$tgr, fit_vrs$group_vec, mean)
+)
+#>          CRS       VRS
+#> G1 1.0000000 1.0000000
+#> G2 0.6014273 0.8180669
    @@ -704,22 +760,22 @@

    5. Comparing methods

    -
    # Compare TGR estimates across methods
-tgr_det <- tapply(fit_det$tgr, fit_det$group_vec, mean)
-tgr_sto <- tapply(fit_sto$tgr, fit_sto$group_vec, mean)
-tgr_dea <- tapply(fit_crs$tgr, fit_crs$group_vec, mean)
-true_tgr <- tapply(sim$data$true_tgr, sim$data$group, mean)
-
-comparison <- data.frame(
-  True = true_tgr,
-  Deterministic = tgr_det,
-  Stochastic = tgr_sto,
-  DEA_CRS = tgr_dea
-)
-round(comparison, 4)
-#>      True Deterministic Stochastic DEA_CRS
-#> G1 1.0000         1.000     1.1839  1.0000
-#> G2 0.6703         0.702     0.8306  0.6014
    +
    # Compare TGR estimates across methods
+tgr_det <- tapply(fit_det$tgr, fit_det$group_vec, mean)
+tgr_sto <- tapply(fit_sto$tgr, fit_sto$group_vec, mean)
+tgr_dea <- tapply(fit_crs$tgr, fit_crs$group_vec, mean)
+true_tgr <- tapply(sim$data$true_tgr, sim$data$group, mean)
+
+comparison <- data.frame(
+  True = true_tgr,
+  Deterministic = tgr_det,
+  Stochastic = tgr_sto,
+  DEA_CRS = tgr_dea
+)
+round(comparison, 4)
+#>      True Deterministic Stochastic DEA_CRS
+#> G1 1.0000         1.000     1.1839  1.0000
+#> G2 0.6703         0.702     0.8306  0.6014

    6. Choosing a method: practical guidance

    @@ -774,44 +830,44 @@

    7. Testing for technology heterogeneity

    log-likelihood of a single frontier estimated on the pooled sample and \(LL_j\) are the group-specific log-likelihoods.

    -
    poolability_test(fit_det)
-#> 
-#>  Likelihood Ratio Test for Poolability of Group Frontiers
-#> 
-#> data:  metafrontier(formula = log_y ~ log_x1 + log_x2, data = sim$data,     group = "group", meta_type = "deterministic")
-#> LR = 442.35, df = 5, p-value < 2.2e-16
    -

    A significant test (p < 0.05) confirms that the groups operate -under different technologies and the metafrontier decomposition is -warranted.

    +
    poolability_test(fit_det)
+#> 
+#>  Likelihood Ratio Test for Poolability of Group Frontiers
+#> 
+#> data:  fit_det
+#> LR = 442.35, df = 5, p-value < 2.2e-16
    +

    A significant test (p < 0.05) confirms that the group frontiers +differ, that is, the groups face different restrictions of the common +metatechnology, and the metafrontier decomposition is warranted.

    8. Simulation for Monte Carlo studies

    The simulate_metafrontier() function generates data from a known DGP, enabling parameter recovery studies:

    -
    # Monte Carlo: check parameter recovery over 100 replications
-set.seed(1)
-n_rep <- 100
-beta_hat <- matrix(NA, n_rep, 3)
-
-for (r in seq_len(n_rep)) {
-  sim_r <- simulate_metafrontier(
-    n_groups = 2, n_per_group = 200,
-    tech_gap = c(0, 0.3),
-    sigma_u = c(0.2, 0.3),
-    sigma_v = 0.15
-  )
-  fit_r <- metafrontier(
-    log_y ~ log_x1 + log_x2,
-    data = sim_r$data,
-    group = "group",
-    meta_type = "deterministic"
-  )
-  beta_hat[r, ] <- coef(fit_r, which = "meta")
-}
-
-# Bias
-true_beta <- c(1.0, 0.5, 0.3)
-colMeans(beta_hat) - true_beta
    +
    # Monte Carlo: check parameter recovery over 100 replications
+set.seed(1)
+n_rep <- 100
+beta_hat <- matrix(NA, n_rep, 3)
+
+for (r in seq_len(n_rep)) {
+  sim_r <- simulate_metafrontier(
+    n_groups = 2, n_per_group = 200,
+    tech_gap = c(0, 0.3),
+    sigma_u = c(0.2, 0.3),
+    sigma_v = 0.15
+  )
+  fit_r <- metafrontier(
+    log_y ~ log_x1 + log_x2,
+    data = sim_r$data,
+    group = "group",
+    meta_type = "deterministic"
+  )
+  beta_hat[r, ] <- coef(fit_r, which = "meta")
+}
+
+# Bias
+true_beta <- c(1.0, 0.5, 0.3)
+colMeans(beta_hat) - true_beta

    The simulate_metafrontier() function supports:

    • Arbitrary number of groups (n_groups)
      • @@ -825,6 +881,10 @@

      8. Simulation for Monte Carlo studies

      References

        +

      • Battese, G.E. and Coelli, T.J. (1988). Prediction of firm-level +technical efficiencies with a generalized frontier production function +and panel data. Journal of Econometrics, 38(3), +387–399.

      • Battese, G.E., Rao, D.S.P. and O’Donnell, C.J. (2004). A metafrontier production function for estimation of technical efficiencies and technology gaps for firms operating under different diff --git a/man/as_metafrontier_model.Rd b/man/as_metafrontier_model.Rd index 1610f6c..57ce9c1 100644 --- a/man/as_metafrontier_model.Rd +++ b/man/as_metafrontier_model.Rd @@ -12,17 +12,34 @@ as_metafrontier_model(x, ...) \item{...}{additional arguments passed to methods.} } \value{ -A list with components: \code{coefficients}, \code{efficiency}, - \code{X}, \code{y}, \code{sigma_v}, \code{sigma_u}, \code{logLik}, - \code{hessian}, \code{n}, \code{dist}. +A list of class \code{"metafrontier_model"} with components: + \code{beta}, \code{te}, \code{X}, \code{y}, \code{sigma_v}, + \code{sigma_u}, \code{logLik}, \code{hessian}, \code{n}, + \code{dist}. } \description{ Generic function that extracts the components needed by \code{\link{metafrontier}} from a pre-fitted frontier model. -Methods are provided for \pkg{sfaR}, \pkg{frontier}, and -\pkg{Benchmarking} objects, as well as plain lists with the +Methods are provided for \pkg{sfaR} (\code{"sfacross"}), +\pkg{frontier} (\code{"frontier"}), and \pkg{Benchmarking} +(\code{"Farrell"}) objects, as well as plain lists with the required fields. } +\details{ +\code{metafrontier(models = ...)} calls this function internally on +each supplied model, so fitted \pkg{sfaR} or \pkg{frontier} objects +can be passed to \code{metafrontier()} directly. Manual conversion +is only needed for hand-built list models. Converting an object that +has already been converted is a no-op, so it is safe to pass +converted objects to \code{metafrontier()} as well. + +Note that \code{Benchmarking::dea()} (\code{"Farrell"}) objects do +not store the inputs, outputs, or frontier coefficients, so the +converted model carries only efficiency scores and cannot be used +with \code{metafrontier(models = ...)}; use the formula interface +with \code{method = "dea"} instead. Converting a Farrell object +therefore raises a warning. +} \examples{ # Using a named list: mod <- as_metafrontier_model(list( diff --git a/man/check_convergence.Rd b/man/check_convergence.Rd new file mode 100644 index 0000000..82e0658 --- /dev/null +++ b/man/check_convergence.Rd @@ -0,0 +1,63 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/diagnostics.R +\name{check_convergence} +\alias{check_convergence} +\alias{check_convergence.metafrontier} +\alias{check_convergence.lc_metafrontier} +\alias{check_convergence.malmquist_meta} +\title{Check Convergence of All Estimation Stages} +\usage{ +check_convergence(object, ...) + +\method{check_convergence}{metafrontier}(object, ...) + +\method{check_convergence}{lc_metafrontier}(object, ...) + +\method{check_convergence}{malmquist_meta}(object, ...) +} +\arguments{ +\item{object}{a fitted model object.} + +\item{...}{additional arguments passed to methods.} +} +\value{ +A data frame of class \code{"metafrontier_convergence"} + with one row per estimation stage and columns: + \describe{ + \item{stage}{stage label, e.g. \code{"group: G1"} or + \code{"metafrontier"}} + \item{method}{how the stage was estimated: \code{"MLE"}, + \code{"LP"}, \code{"QP"}, \code{"QP (barrier)"}, + \code{"DEA"}, or \code{"external"}} + \item{code}{the integer convergence code returned by the + optimiser (0 indicates success); \code{NA} for DEA stages + and externally fitted groups} + \item{converged}{logical convergence indicator; for DEA + stages \code{TRUE} unless any efficiency score is + \code{NA} (infeasible programme); \code{NA} for externally + fitted groups} + \item{note}{additional detail, e.g. the number of infeasible + DEA programmes} + } +} +\description{ +Reports the convergence status of every estimation stage of a +fitted metafrontier model: each group-level frontier and the +metafrontier itself. This makes it easy to verify that all +optimisers (MLE) and mathematical programmes (LP/QP) finished +successfully before interpreting technology gap ratios, +confidence intervals, or efficiency decompositions. +} +\details{ +For groups supplied via the \code{models} argument of +\code{\link{metafrontier}} the convergence status of the external +fitter is not tracked, and the corresponding rows carry +\code{NA} with an explanatory note. +} +\examples{ +sim <- simulate_metafrontier(n_groups = 2, n_per_group = 50, seed = 42) +fit <- metafrontier(log_y ~ log_x1 + log_x2, data = sim$data, + group = "group") +check_convergence(fit) + +} diff --git a/man/coef.metafrontier.Rd b/man/coef.metafrontier.Rd new file mode 100644 index 0000000..ecb4218 --- /dev/null +++ b/man/coef.metafrontier.Rd @@ -0,0 +1,42 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/methods.R +\name{coef.metafrontier} +\alias{coef.metafrontier} +\title{Extract Coefficients from a Metafrontier Model} +\usage{ +\method{coef}{metafrontier}(object, which = c("meta", "group"), extraPar = FALSE, ...) +} +\arguments{ +\item{object}{a \code{"metafrontier"} object.} + +\item{which}{character. \code{"meta"} (default) returns the +metafrontier coefficients; \code{"group"} returns a named list +of group-specific coefficient vectors.} + +\item{extraPar}{logical. If \code{TRUE}, auxiliary parameters are +included alongside the frontier coefficients. For +\code{which = "group"} the variance parameters are +back-transformed to their natural scale (\code{sigmaV}, +\code{sigmaU}), \code{mu} and \code{eta} are kept as estimated, +and heteroscedastic Z coefficients are labelled with their +column names. For \code{which = "meta"} the Stage 2 variance +parameters are appended for stochastic metafrontiers.} + +\item{...}{additional arguments (currently unused).} +} +\value{ +A named numeric vector (\code{which = "meta"}) or a named + list of numeric vectors (\code{which = "group"}). +} +\description{ +Extract Coefficients from a Metafrontier Model +} +\examples{ +sim <- simulate_metafrontier(n_groups = 2, n_per_group = 50, seed = 42) +fit <- metafrontier(log_y ~ log_x1 + log_x2, data = sim$data, + group = "group", meta_type = "stochastic") +coef(fit) +coef(fit, extraPar = TRUE) +coef(fit, which = "group", extraPar = TRUE) + +} diff --git a/man/efficiencies.Rd b/man/efficiencies.Rd index ccc74c8..e3ee0a2 100644 --- a/man/efficiencies.Rd +++ b/man/efficiencies.Rd @@ -7,7 +7,7 @@ \usage{ efficiencies(object, ...) -\method{efficiencies}{metafrontier}(object, type = c("meta", "group", "tgr"), ...) +\method{efficiencies}{metafrontier}(object, type = c("meta", "group", "tgr"), estimator = NULL, ...) } \arguments{ \item{object}{a fitted \code{"metafrontier"} object.} @@ -18,6 +18,17 @@ efficiencies(object, ...) \code{"group"} for efficiency relative to the group frontier, \code{"meta"} (default) for efficiency relative to the metafrontier, or \code{"tgr"} for the technology gap ratio.} + +\item{estimator}{optional character. Override the efficiency +estimator used at fit time: \code{"bc88"} for the Battese-Coelli +(1988) conditional expectation \eqn{E[\exp(-u)|\varepsilon]} or +\code{"jlms"} for \eqn{\exp(-E[u|\varepsilon])} (Jondrow et al., +1982). Both are stored on SFA fits, so no refitting is needed; +\code{type = "meta"} is recomputed as \eqn{TE \times TGR}. The +TGR itself does not depend on the estimator. Ignored (with a +warning) for DEA fits and externally fitted group models that do +not carry both estimators. Default \code{NULL} returns the +scores selected at fit time.} } \value{ A numeric vector of efficiency scores of length diff --git a/man/latent_class_metafrontier.Rd b/man/latent_class_metafrontier.Rd index ae08401..dfe0ce9 100644 --- a/man/latent_class_metafrontier.Rd +++ b/man/latent_class_metafrontier.Rd @@ -64,6 +64,12 @@ probabilities, class-specific frontier parameters, and the metafrontier. } \details{ +Latent class estimation is available for SFA-based metafrontiers +only: the EM posterior class probabilities require a parametric +observation-level likelihood, which DEA does not provide. For DEA +fits with observed groups, see \code{\link{poolability_test}}. + + The EM algorithm iterates between: \itemize{ \item \strong{E-step}: compute posterior class membership probabilities diff --git a/man/malmquist_meta.Rd b/man/malmquist_meta.Rd index 6edb126..00c1c61 100644 --- a/man/malmquist_meta.Rd +++ b/man/malmquist_meta.Rd @@ -9,10 +9,12 @@ malmquist_meta( data = NULL, group = NULL, time = NULL, + id = NULL, method = c("dea", "sfa"), dist = c("hnormal", "tnormal", "exponential"), + estimator = c("bc88", "jlms"), orientation = c("output", "input"), - rts = c("crs", "vrs", "drs", "irs"), + rts = c("crs", "vrs", "drs", "irs", "fdh"), control = list(), ... ) @@ -33,20 +35,35 @@ indicators.} that identifies time periods, or a vector of time indicators. Periods must be consecutive integers or sortable.} +\item{id}{optional. A character string naming the column in +\code{data} that identifies firms across periods, or a vector +of firm identifiers. When supplied, firms are matched across +consecutive periods by identifier within each group. When +\code{NULL} (default), firms are matched by row position within +each group, which is valid only for balanced panels sorted +identically in every period (see Details).} + \item{method}{character. \code{"dea"} (default) for DEA-based distance functions or \code{"sfa"} for SFA-based parametric -distance functions.} +distance functions (an approximation; see Details).} \item{dist}{character. Distribution of the inefficiency term when \code{method = "sfa"}: \code{"hnormal"} (default), \code{"tnormal"}, or \code{"exponential"}.} +\item{estimator}{character. Technical efficiency estimator used +when \code{method = "sfa"}: \code{"bc88"} (default) for the +Battese and Coelli (1988) estimator +\eqn{E[\exp(-u)|\varepsilon]}, or \code{"jlms"} for the Jondrow +et al. (1982) estimator \eqn{\exp(-E[u|\varepsilon])}. Passed to +the group SFA fitter.} + \item{orientation}{character. \code{"output"} (default) or \code{"input"}.} \item{rts}{character. Returns to scale assumption: -\code{"crs"} (default), \code{"vrs"}, \code{"drs"}, or -\code{"irs"}.} +\code{"crs"} (default), \code{"vrs"}, \code{"drs"}, +\code{"irs"}, or \code{"fdh"}.} \item{control}{a list of control parameters for the SFA optimiser.} @@ -61,7 +78,9 @@ An object of class \code{"malmquist_meta"}, a list \code{MPI} (metafrontier Malmquist TFP index), \code{TEC} (technical efficiency change), \code{TGC} (technology gap change), - \code{TC} (metafrontier technical change)} + \code{TC} (metafrontier technical change). The \code{id} + column holds the supplied firm identifiers when \code{id} + is given, and the within-group match position otherwise.} \item{group_malmquist}{data frame with the within-group Malmquist index decomposition: \code{MPI_group}, \code{EC_group}, \code{TC_group}} @@ -75,10 +94,17 @@ An object of class \code{"malmquist_meta"}, a list end period), and \code{TGC} (technology gap change, \code{TGR_to / TGR_from})} \item{call}{the matched function call} + \item{method}{the estimation method used (\code{"dea"} or + \code{"sfa"})} \item{orientation}{the orientation used} \item{rts}{the returns to scale assumption} \item{groups}{group labels} \item{periods}{time periods} + \item{n_infeasible}{total number of infeasible cross-period + DEA programs (always \code{0} for \code{method = "sfa"})} + \item{infeasible_by_period}{data frame with the number of + infeasible cross-period DEA programs per period pair + (\code{method = "dea"} only)} } } \description{ @@ -105,18 +131,54 @@ where: the shift of the global production possibility frontier } -Computation uses DEA-based distance functions. For each +\strong{Firm matching:} when \code{id} is supplied, firms are +matched across consecutive periods by identifier within each +technology group. Duplicated (id, period) combinations within a +group are an error. Observations without a within-group match in +the adjacent period, either because the panel is unbalanced or +because a firm switches group between periods, are dropped, and a +single consolidated warning reports the number dropped per period +pair. When \code{id} is \code{NULL}, firms are matched by row +position within each group; this is valid only for balanced +panels sorted identically in every period, so a message is +emitted as a reminder, and a warning is issued when group sizes +differ across a period pair (the unmatched observations are +dropped). Supplying \code{id} is recommended. + +\strong{DEA-based computation (\code{method = "dea"}):} for each consecutive pair of periods \eqn{(s, t)}, eight sets of LP -problems are solved: within-group and pooled efficiencies at -each period, plus cross-period evaluations for the geometric -mean formulation of technical change. - -\strong{Balanced panel assumption:} Firms are matched across -periods by position within each group. The data should contain -a balanced panel (the same firms observed in every period) with -consistent ordering. If group sizes differ across periods, -only the first \code{min(n_s, n_t)} firms per group are paired -and unmatched observations are silently dropped. +problems are solved: within-group and pooled efficiencies at each +period, plus cross-period evaluations for the geometric mean +formulation of technical change. Distances to the metafrontier +are exact distances to the pooled-data frontier, as in O'Donnell, +Rao and Battese (2008). + +\strong{SFA-based computation is an approximation +(\code{method = "sfa"}):} period-specific group SFA frontiers are +estimated, and each observation's metafrontier distance is +approximated by the pointwise maximum of the estimated group +frontier functions evaluated at its inputs; no enveloping +metafrontier is re-estimated. This coincides with the O'Donnell +et al. (2008) metafrontier wherever a single group frontier +dominates, but can understate the metafrontier where group +frontiers cross, which affects TGC and TC*. Prefer +\code{method = "dea"} when an exact decomposition is required. + +\strong{Infeasible cross-period programs:} under +\code{rts = "vrs"}, \code{"drs"}, \code{"irs"}, or \code{"fdh"}, +cross-period LPs can be genuinely infeasible because the +reference technology cannot reach the evaluated observation. Such +cases yield \code{NA} (never \code{Inf}), are excluded from the +reported means, and are counted in a single consolidated warning; +the counts are stored in the \code{n_infeasible} and +\code{infeasible_by_period} components. \code{rts = "crs"} avoids +the issue, as does the hyperbolic orientation available in +\code{\link{metafrontier}}. + +Note that the standard Malmquist index is not a \sQuote{proper} +(multiplicatively complete and transitive) TFP index in the sense +of O'Donnell (2012), so chained comparisons of index levels +across more than two periods should be avoided. } \examples{ # Simulate panel data for 2 groups, 3 time periods @@ -134,12 +196,13 @@ panels <- lapply(1:3, function(t) { }) panel_data <- do.call(rbind, panels) -# Compute metafrontier Malmquist index +# Compute metafrontier Malmquist index, matching firms by id malm <- malmquist_meta( log_y ~ log_x1 + log_x2, data = panel_data, group = "group", - time = "time" + time = "time", + id = "id" ) summary(malm) @@ -149,4 +212,9 @@ O'Donnell, C.J., Rao, D.S.P. and Battese, G.E. (2008). Metafrontier frameworks for the study of firm-level efficiencies and technology ratios. \emph{Empirical Economics}, 34(2), 231--255. \doi{10.1007/s00181-007-0119-4} + +O'Donnell, C.J. (2012). An aggregate quantity framework for +measuring and decomposing productivity change. +\emph{Journal of Productivity Analysis}, 38(3), 255--272. +\doi{10.1007/s11123-012-0275-1} } diff --git a/man/metafrontier-package.Rd b/man/metafrontier-package.Rd index 5511f8b..5dced0c 100644 --- a/man/metafrontier-package.Rd +++ b/man/metafrontier-package.Rd @@ -5,7 +5,7 @@ \alias{metafrontier-package} \title{metafrontier: Analysis of Metafrontier Models for Efficiency and Productivity} \description{ -Implements metafrontier production function models for estimating technical efficiencies and technology gaps for firms operating under different technologies. Supports both stochastic frontier analysis (SFA) and data envelopment analysis (DEA) based metafrontiers. Includes the deterministic metafrontier of Battese, Rao, and O'Donnell (2004) \doi{10.1023/B:PROD.0000012454.06094.29}, the stochastic metafrontier of Huang, Huang, and Liu (2014) \doi{10.1007/s11123-014-0402-2}, and the metafrontier Malmquist productivity index of O'Donnell, Rao, and Battese (2008) \doi{10.1007/s00181-007-0119-4}. Additional features include panel SFA with time-varying inefficiency, bootstrap confidence intervals for technology gap ratios, latent class metafrontier estimation via the EM algorithm, Murphy-Topel corrected standard errors, and 'ggplot2' visualisation methods. +Implements metafrontier production function models for estimating technical efficiencies and technology gaps for groups of firms that face different restrictions of a common underlying metatechnology (group-specific technologies in the sense of Battese, Rao, and O'Donnell, 2004). Supports both stochastic frontier analysis (SFA) and data envelopment analysis (DEA) based metafrontiers. Includes the deterministic metafrontier of Battese, Rao, and O'Donnell (2004) \doi{10.1023/B:PROD.0000012454.06094.29}, the stochastic metafrontier of Huang, Huang, and Liu (2014) \doi{10.1007/s11123-014-0402-2}, and the metafrontier Malmquist productivity index of O'Donnell, Rao, and Battese (2008) \doi{10.1007/s00181-007-0119-4}. The deterministic metafrontier can be identified by either the minimum sum of absolute deviations (LP) or the minimum sum of squared deviations (QP) criterion. Additional features include panel SFA with time-varying inefficiency, bootstrap confidence intervals for technology gap ratios, a DEA poolability permutation test, latent class metafrontier estimation via the EM algorithm, Murphy-Topel corrected standard errors, convergence diagnostics, import of pre-fitted models from external estimation engines ('sfaR', 'frontier', 'Benchmarking'), and 'ggplot2' visualisation methods. } \seealso{ Useful links: diff --git a/man/metafrontier.Rd b/man/metafrontier.Rd index 94ab89b..cc4e58b 100644 --- a/man/metafrontier.Rd +++ b/man/metafrontier.Rd @@ -12,13 +12,17 @@ metafrontier( meta_type = c("deterministic", "stochastic"), dist = c("hnormal", "tnormal", "exponential"), orientation = c("output", "input"), - rts = c("crs", "vrs", "drs", "irs"), + rts = c("crs", "vrs", "drs", "irs", "fdh"), models = NULL, panel = NULL, panel_dist = c("bc92", "bc95"), - type = c("radial", "directional"), + type = c("radial", "directional", "hyperbolic"), direction = c("proportional", "output", "input"), control = list(), + estimator = c("bc88", "jlms"), + objective = c("lp", "qp"), + engine = c("internal", "sfaR", "frontier", "Benchmarking"), + slack = FALSE, ... ) } @@ -57,13 +61,20 @@ Ignored when \code{method = "dea"}.} \item{rts}{character. Returns to scale for DEA: \code{"crs"} (constant, default), \code{"vrs"} (variable), \code{"drs"} -(decreasing), or \code{"irs"} (increasing). Ignored when +(decreasing), \code{"irs"} (increasing), or \code{"fdh"} (free +disposable hull, i.e. no convexity). Ignored when \code{method = "sfa"}.} \item{models}{an optional named list of pre-fitted group-specific -frontier models (objects from \pkg{sfaR}, \pkg{frontier}, or -\pkg{Benchmarking}). If provided, \code{formula}, \code{data}, -and \code{group} are ignored.} +frontier models (objects from \pkg{sfaR} or \pkg{frontier}, or +hand-built lists). Fitted model objects are converted +automatically via \code{\link{as_metafrontier_model}}, so no +manual conversion is required (pre-converting is harmless, the +conversion is idempotent). Farrell objects from +\pkg{Benchmarking} store neither coefficients nor data and +cannot be used here; use the formula interface with +\code{method = "dea"} instead. If \code{models} is provided, +\code{formula}, \code{data}, and \code{group} are ignored.} \item{panel}{an optional list with components \code{id} and \code{time} naming the panel identifier and time columns in @@ -76,12 +87,19 @@ or \code{"bc95"} (Battese and Coelli 1995, observation-specific mean). Only used when \code{panel} is non-NULL.} \item{type}{character. For DEA: \code{"radial"} (default) for -standard radial DEA or \code{"directional"} for directional -distance functions.} +standard radial DEA, \code{"directional"} for directional +distance functions, or \code{"hyperbolic"} for hyperbolic +(graph) efficiency, which contracts inputs and expands outputs +simultaneously.} -\item{direction}{character. Direction vector for DDF: -\code{"proportional"} (default), \code{"output"}, or -\code{"input"}. Only used when \code{type = "directional"}.} +\item{direction}{direction vector for DDF. Either a character +preset (\code{"proportional"} (default), \code{"output"}, or +\code{"input"}), a numeric vector of length m + s giving a +common direction (first m elements for inputs, last s for +outputs), or a numeric n x (m + s) matrix of firm-specific +directions. With numeric directions the ratio-based TGR is not +defined; the additive gap (\code{ddf_gap}) is reported instead. +Only used when \code{type = "directional"}.} \item{control}{a named list of control parameters passed to \code{\link[stats]{optim}}. Common options include @@ -89,6 +107,42 @@ distance functions.} \code{reltol} (relative convergence tolerance, default 1e-10), and \code{fnscale} (set to -1 internally for maximisation).} +\item{estimator}{character. Technical efficiency estimator for +SFA models: \code{"bc88"} (default) for the conditional +expectation \eqn{E[\exp(-u)|\varepsilon]} of Battese and Coelli +(1988), which is the consistent estimator of technical +efficiency, or \code{"jlms"} for +\eqn{\exp(-E[u|\varepsilon])} following Jondrow et al. (1982). +Both are stored on the fitted object; see +\code{\link{efficiencies}}. Ignored when \code{method = "dea"}.} + +\item{objective}{character. Identification criterion for the +deterministic metafrontier: \code{"lp"} (default) minimises the +sum of absolute deviations (a linear programme), \code{"qp"} +minimises the sum of squared deviations (a quadratic programme, +solved exactly via \pkg{quadprog} when available). Both criteria +are proposed in Battese, Rao, and O'Donnell (2004). Only used +when \code{method = "sfa"} and \code{meta_type = +"deterministic"}.} + +\item{engine}{character. Estimation backend for the group +frontiers: \code{"internal"} (default) uses the package's own +estimators; \code{"sfaR"} or \code{"frontier"} delegate the SFA +group frontiers to \code{\link[sfaR]{sfacross}} or +\code{\link[frontier]{sfa}} (cross-sectional, single-part +formulas only); \code{"Benchmarking"} delegates the DEA group +frontiers and the pooled metafrontier to +\code{\link[Benchmarking]{dea}} (radial only), using its +\code{XREF}/\code{YREF} external-reference facility for the +metafrontier stage. The metafrontier stage for SFA methods is +always estimated internally (the Murphy-Topel correction +requires the internal likelihood).} + +\item{slack}{logical. For radial DEA, compute second-stage input +and output slacks (with the radial score held fixed) against +both the group and the pooled reference sets. Default +\code{FALSE}.} + \item{...}{additional arguments passed to the group-level estimation functions.} } @@ -109,7 +163,15 @@ An object of class \code{"metafrontier"} (with subclass \item{groups}{group labels} \item{method}{estimation method used} \item{meta_type}{metafrontier type used} - \item{convergence}{convergence status} + \item{meta_convergence}{integer convergence code for the + metafrontier stage (0 = success; \code{\link[stats]{optim}} + codes for the stochastic metafrontier and the QP barrier + fallback; 0 for a successful LP or DEA solution). Each SFA + group model in \code{group_models} additionally carries its + own \code{convergence} code. Use + \code{\link{check_convergence}} to inspect all stages.} + \item{estimator, objective, engine, meta_solver}{the + estimation choices used for the fit} } } \description{ @@ -129,17 +191,33 @@ where \eqn{TE_i} is efficiency relative to the group frontier and \eqn{TGR_i} is the technology gap ratio measuring how close the group frontier is to the metafrontier. -The deterministic metafrontier (Battese, Rao, and O'Donnell, 2004) -is estimated by solving a linear program that minimises the total -envelope overshoot subject to the constraint that the metafrontier -envelops all group frontiers. BRO (2004) originally proposed a -constrained least-squares (QP) formulation; the LP yields the -tightest envelope and is solved via \pkg{lpSolveAPI}, with a QP -fallback via \code{constrOptim()} when the LP is infeasible. +The deterministic metafrontier is identified by one of the two +criteria proposed by Battese, Rao, and O'Donnell (2004), subject in +both cases to the constraint that the metafrontier envelops all +group frontiers: minimising the sum of absolute deviations, which +reduces to a linear programme because the envelope constraints +force every deviation to be non-negative (O'Donnell, Rao, and +Battese, 2008, Eqs. 23-25), or minimising the sum of squared +deviations, a convex quadratic programme. The LP +(\code{objective = "lp"}, the default) is solved via +\pkg{lpSolveAPI}; the QP (\code{objective = "qp"}) is solved +exactly via \pkg{quadprog} when available, with an adaptive-barrier +fallback via \code{constrOptim()}. The stochastic metafrontier (Huang, Huang, and Liu, 2014) replaces this with a second-stage SFA, providing a distributional framework for inference on the TGR. +\strong{Convergence and failure handling:} estimation stops with an +error only when no usable estimate exists (for example, when both +the BFGS and Nelder-Mead optimisers fail for a group frontier). +When an optimiser stops at a non-zero convergence code, the fitted +object is returned with a warning and the code is recorded; use +\code{\link{check_convergence}} or \code{summary()} to verify all +estimation stages before interpreting technology gap ratios, +confidence intervals, or productivity decompositions. Infeasible +DEA programmes yield \code{NA} efficiency scores, accompanied by a +warning and counted by \code{\link{check_convergence}}. + \strong{Note on standard errors (stochastic metafrontier):} The stochastic metafrontier is a two-stage estimator. Stage 2 treats the fitted group frontier values as data, so the reported standard diff --git a/man/poolability_test.Rd b/man/poolability_test.Rd index bcdb8d1..e22659a 100644 --- a/man/poolability_test.Rd +++ b/man/poolability_test.Rd @@ -4,19 +4,28 @@ \alias{poolability_test} \title{Test Poolability of Group Frontiers} \usage{ -poolability_test(object, ...) +poolability_test(object, B = 199, seed = NULL, ...) } \arguments{ \item{object}{a fitted \code{"metafrontier"} object with -\code{method = "sfa"}.} +\code{method = "sfa"} or \code{method = "dea"}.} + +\item{B}{integer. Number of permutation replicates for the DEA +permutation test (default 199). Ignored for SFA objects.} + +\item{seed}{integer or \code{NULL}. Random seed for the DEA +permutation test, for reproducibility. Ignored for SFA objects.} \item{...}{additional arguments (currently unused).} } \value{ A list of class \code{"htest"} with components: \describe{ - \item{statistic}{the LR test statistic} - \item{parameter}{degrees of freedom} + \item{statistic}{the test statistic (LR statistic for SFA; the + mean technology gap, \eqn{\bar{S} = \mathrm{mean}(1 - TGR)}, + for DEA)} + \item{parameter}{degrees of freedom (SFA) or the effective + number of permutation replicates (DEA)} \item{p.value}{p-value of the test} \item{method}{description of the test} } @@ -24,11 +33,12 @@ A list of class \code{"htest"} with components: \description{ Tests the null hypothesis that all groups share a common frontier (i.e., the metafrontier coincides with all group frontiers) against -the alternative that group-specific frontiers differ. Uses a -likelihood ratio test. +the alternative that group-specific frontiers differ. For SFA-based +metafrontiers a likelihood ratio test is used; for DEA-based +metafrontiers a permutation test is used. } \details{ -The LR statistic is: +\strong{Likelihood ratio test (SFA).} The LR statistic is: \deqn{LR = -2 [LL_{pooled} - \sum_j LL_j]} where \eqn{LL_{pooled}} is the log-likelihood of the pooled (single frontier) model and \eqn{LL_j} are the group-specific @@ -41,7 +51,27 @@ For \eqn{J} groups each with \eqn{p} frontier parameters plus distributional parameters, this equals \eqn{(J - 1) \times p_{total}} where \eqn{p_{total}} includes frontier coefficients, \eqn{\sigma_v}, and \eqn{\sigma_u} -(and \eqn{\mu} for truncated-normal). +(and \eqn{\mu} for truncated-normal). This test requires a +likelihood and is therefore only available for SFA-based +metafrontiers. + +\strong{Permutation test (DEA).} DEA has no likelihood, so the +poolability hypothesis is assessed by a permutation test. Under the +null of a single pooled technology, group labels are exchangeable: +reassigning observations to groups at random should not +systematically change the distance between the group frontiers and +the metafrontier. The observed statistic is the mean technology gap, +\eqn{S_{obs} = \mathrm{mean}(1 - TGR_i)}, and its null distribution +is approximated by refitting the metafrontier on \code{B} random +permutations of the group labels. The p-value is +\eqn{(1 + \#\{S_b \ge S_{obs}\}) / (B + 1)}, following the +aggregate-efficiency inference logic of Simar and Zelenyuk (2007). +The smoothed subsampling approach of Kneip, Simar, and Wilson (2016) +is the asymptotically rigorous alternative for testing hypotheses in +nonparametric production models; the permutation test offered here +is a computationally simple approximation. The default \code{B = 199} +is a pragmatic choice; p-values have resolution \eqn{1/(B + 1)}, so +increase \code{B} for finer resolution. } \examples{ set.seed(42) @@ -51,4 +81,22 @@ fit <- metafrontier(log_y ~ log_x1 + log_x2, data = sim$data, group = "group") poolability_test(fit) +\donttest{ +# DEA permutation test +fit_dea <- metafrontier(log_y ~ log_x1 + log_x2, + data = sim$data, group = "group", + method = "dea") +poolability_test(fit_dea, B = 99, seed = 1) +} + +} +\references{ +Simar, L. and Zelenyuk, V. (2007). Statistical inference for +aggregates of Farrell-type efficiencies. \emph{Journal of Applied +Econometrics}, 22(7), 1367--1394. \doi{10.1002/jae.991} + +Kneip, A., Simar, L. and Wilson, P.W. (2016). Testing hypotheses +in nonparametric models of production. \emph{Journal of Business & +Economic Statistics}, 34(3), 435--447. +\doi{10.1080/07350015.2015.1049747} } diff --git a/man/print.metafrontier.Rd b/man/print.metafrontier.Rd index eb63c88..d19ad86 100644 --- a/man/print.metafrontier.Rd +++ b/man/print.metafrontier.Rd @@ -15,7 +15,11 @@ Invisibly returns \code{x}. } \description{ -Print a Metafrontier Object +Prints a compact overview of a fitted metafrontier model: the +estimation method and metafrontier type, the efficiency estimator +and identification objective (where applicable), the groups and +their sample sizes, group log-likelihoods, mean technology gap +ratio by group, and a one-line convergence status. } \examples{ sim <- simulate_metafrontier(n_groups = 2, n_per_group = 50, seed = 42) diff --git a/man/select_n_classes.Rd b/man/select_n_classes.Rd index bac4d2a..a7a93ae 100644 --- a/man/select_n_classes.Rd +++ b/man/select_n_classes.Rd @@ -14,19 +14,22 @@ select_n_classes(formula, data, n_classes_range = 2:5, ...) \item{n_classes_range}{integer vector of class counts to try.} \item{...}{additional arguments passed to -\code{\link{latent_class_metafrontier}}.} +\code{\link{latent_class_metafrontier}}, notably \code{n_starts}.} } \value{ A data frame with columns \code{n_classes}, \code{BIC}, and \code{marginal_ll}. } \description{ -Select Number of Latent Classes via BIC -} -\details{ -Fits latent class metafrontier models for each value in -\code{n_classes_range} and returns BIC values. The optimal -number of classes minimises BIC. +Fits a latent class metafrontier model for each value in +\code{n_classes_range} and tabulates the Bayesian information +criterion (BIC) and marginal log-likelihood of each fit. The +optimal number of classes minimises BIC. Fits that fail are +silently dropped from the table. Because the EM algorithm can +converge to local optima, the ranking is sensitive to the number +of random starts: pass \code{n_starts} (forwarded to +\code{\link{latent_class_metafrontier}}) and increase it for a +more reliable comparison across class counts. } \examples{ \donttest{ diff --git a/man/simulate_metafrontier.Rd b/man/simulate_metafrontier.Rd index a0318df..6fa274b 100644 --- a/man/simulate_metafrontier.Rd +++ b/man/simulate_metafrontier.Rd @@ -12,7 +12,10 @@ simulate_metafrontier( tech_gap = NULL, sigma_u = NULL, sigma_v = 0.2, - seed = NULL + seed = NULL, + beta_groups = NULL, + input_means = NULL, + input_corr = NULL ) } \arguments{ @@ -26,12 +29,15 @@ groups. If a vector, must be of length \code{n_groups}.} \item{beta_meta}{numeric vector. Metafrontier coefficients (including intercept). Length must be \code{n_inputs + 1}. -Default: \code{c(1.0, 0.5, 0.3)}.} +Default: \code{c(1.0, seq(0.5, 0.2, length.out = n_inputs))}, +i.e. \code{c(1.0, 0.5, 0.2)} for the default two inputs. Ignored +when \code{beta_groups} is supplied.} \item{tech_gap}{numeric vector of length \code{n_groups}. The technology gap for each group, defined as the reduction in the intercept relative to the metafrontier. Default: evenly spaced -from 0 to 0.5.} +from 0 to 0.5. Ignored (with a warning) when \code{beta_groups} +is supplied.} \item{sigma_u}{numeric vector of length \code{n_groups}. Standard deviation of the half-normal inefficiency term for each group. @@ -42,6 +48,26 @@ term. Default: 0.2.} \item{seed}{integer or \code{NULL}. Random seed for reproducibility.} + +\item{beta_groups}{optional group-specific frontier coefficients, +including slopes: either an \code{n_groups} x \code{(n_inputs + 1)} +numeric matrix (one row per group) or a list of \code{n_groups} +numeric vectors of length \code{n_inputs + 1}. When supplied, it +replaces the intercept-shift construction based on +\code{tech_gap}; see Details. Default \code{NULL} (intercept-shift +design).} + +\item{input_means}{optional \code{n_groups} x \code{n_inputs} numeric +matrix of per-group mean log-input levels. When supplied, the +log-inputs for group \code{g} are drawn from a normal distribution +centred at \code{input_means[g, ]}; see Details. Default +\code{NULL} (identical uniform inputs across groups).} + +\item{input_corr}{optional \code{n_inputs} x \code{n_inputs} +correlation matrix for the log-inputs. When supplied, the +log-inputs are drawn from a multivariate normal distribution with +this correlation structure; see Details. Default \code{NULL} +(independent inputs).} } \value{ A list with components: @@ -53,8 +79,38 @@ A list with components: } \description{ Generates synthetic data from a known metafrontier data-generating -process. Useful for Monte Carlo simulations, package testing, and -teaching. +process. Each group frontier lies weakly below the metafrontier, +consistent with groups facing different restrictions of a common +metatechnology (Battese, Rao and O'Donnell, 2004). Useful for Monte +Carlo simulations, package testing, and teaching. +} +\details{ +By default the group frontiers share the metafrontier slopes and +differ only in their intercepts, so the true technology gap ratio +(TGR) is constant within each group and equals +\code{exp(-tech_gap[g])}. When \code{beta_groups} is supplied the +group frontiers may differ in their slopes, in which case no single +log-linear metafrontier envelops all groups: the tightest log-linear +envelope is then a pseudo-true quantity. The returned +\code{true_tgr} is instead computed observation by observation +against the pointwise maximum over the group frontiers, +\eqn{TGR_i = \exp(x_i^ op eta_g - \max_j x_i^ op eta_j)}, which is +guaranteed to lie in (0, 1]. The true group frontier for each firm +is \eqn{x_i^ op eta_g}, \code{true_te} is generated exactly as in the +default design, and \code{true_te_star = true_te * true_tgr}. In +this case \code{params$beta_meta} is \code{NULL} and +\code{params$beta_groups} holds the supplied coefficients. + +By default the log-inputs are drawn i.i.d. from a uniform +distribution on \code{[0, 5]}, identically across groups. Supplying +\code{input_means} and/or \code{input_corr} switches to normal +log-inputs with standard deviation \code{5 / sqrt(12)} (matching the +spread of the uniform draws), centred at \code{input_means[g, ]} +(2.5 for every group and input when \code{input_means} is +\code{NULL}). When \code{input_corr} is supplied the draws are +multivariate normal with that correlation matrix; when it is +\code{NULL} but \code{input_means} is given, the inputs are drawn +independently. } \examples{ sim <- simulate_metafrontier(n_groups = 3, n_per_group = 200, @@ -65,4 +121,10 @@ table(sim$data$group) # The true metafrontier coefficients sim$params$beta_meta +# Group-specific slopes: per-observation true TGR +sim2 <- simulate_metafrontier( + beta_groups = rbind(c(1.0, 0.5, 0.2), c(0.9, 0.6, 0.1)) +) +range(sim2$data$true_tgr) + } diff --git a/man/simulate_panel_metafrontier.Rd b/man/simulate_panel_metafrontier.Rd index beb6a22..d98a4c0 100644 --- a/man/simulate_panel_metafrontier.Rd +++ b/man/simulate_panel_metafrontier.Rd @@ -13,7 +13,8 @@ simulate_panel_metafrontier( sigma_u = 0.3, sigma_v = 0.2, eta = 0.05, - seed = NULL + seed = NULL, + attrition = 0 ) } \arguments{ @@ -34,6 +35,15 @@ simulate_panel_metafrontier( \item{eta}{numeric. Time-decay parameter for BC92.} \item{seed}{integer or NULL. Random seed.} + +\item{attrition}{numeric in [0, 0.5]. Probability that each +firm-period observation after a firm's first period is dropped +independently, producing an unbalanced panel. Every firm's first +period is always kept, so all firms remain in the data. The +attrition draws are made after all other random numbers, so +\code{attrition = 0} (the default) reproduces legacy balanced +datasets exactly for the same seed. The realised share of at-risk +observations dropped is stored in \code{params$attrition_share}.} } \value{ A list with components: @@ -41,7 +51,9 @@ A list with components: \item{data}{data frame with columns: \code{firm}, \code{year}, \code{group}, \code{log_y}, \code{log_x1}, \code{log_x2}, \code{true_te}, \code{true_u}, \code{true_v}} - \item{params}{list of true parameter values used in generation} + \item{params}{list of true parameter values used in generation, + including \code{attrition} and the realised + \code{attrition_share}} } } \description{ @@ -57,4 +69,8 @@ sim <- simulate_panel_metafrontier( head(sim$data) str(sim$params) +# An unbalanced panel with roughly 20\% attrition +sim_unbal <- simulate_panel_metafrontier(seed = 42, attrition = 0.2) +table(table(sim_unbal$data$firm)) + } diff --git a/man/summary.metafrontier.Rd b/man/summary.metafrontier.Rd index eab223c..9611635 100644 --- a/man/summary.metafrontier.Rd +++ b/man/summary.metafrontier.Rd @@ -12,10 +12,44 @@ \item{...}{additional arguments (currently unused).} } \value{ -An object of class \code{"summary.metafrontier"}. +An object of class \code{"summary.metafrontier"}: a list + with components + \describe{ + \item{call}{the matched call of the original fit} + \item{method}{estimation method (\code{"sfa"} or \code{"dea"})} + \item{meta_type}{metafrontier type (\code{"deterministic"} or + \code{"stochastic"})} + \item{groups}{character vector of group labels} + \item{nobs}{named vector of observation counts (total and per + group)} + \item{group_tables}{named list of coefficient matrices, one per + group, with columns \code{Estimate}, \code{Std. Error}, + \code{z value}, and \code{Pr(>|z|)} where standard errors are + available (empty list for DEA fits)} + \item{meta_table}{metafrontier coefficient matrix in the same + format, or \code{NULL} for DEA fits} + \item{tgr_summary}{data frame of TGR statistics by group, as + returned by \code{\link{tgr_summary}}} + \item{efficiency_summary}{data frame with mean TE, mean TGR, + and mean TE* by group} + \item{logLik_groups}{named vector of group log-likelihoods, or + \code{NULL}} + \item{meta_logLik}{Stage 2 log-likelihood of the stochastic + metafrontier, or \code{NULL}} + \item{convergence}{data frame with columns \code{stage}, + \code{code}, and \code{converged} recording the optimiser + status of each estimation stage, or \code{NULL} if + unavailable; see \code{\link{check_convergence}}} + } } \description{ -Summary of a Metafrontier Model +Computes group-level summaries of technical efficiency (TE), +technology gap ratio (TGR), and metafrontier efficiency (TE*), +full coefficient tables for each group frontier (including +variance parameters and, for BC92 panels, \code{eta}, all with +standard errors where a Hessian is available), the metafrontier +coefficient table (with Murphy-Topel corrected standard errors +where applicable), and a per-stage convergence table. } \examples{ sim <- simulate_metafrontier(n_groups = 2, n_per_group = 50, seed = 42) diff --git a/man/technology_gap_ratio.Rd b/man/technology_gap_ratio.Rd index a45858b..a2d253e 100644 --- a/man/technology_gap_ratio.Rd +++ b/man/technology_gap_ratio.Rd @@ -39,7 +39,11 @@ metafrontier need not envelop the group frontiers at every point. A TGR of 1 means the group frontier coincides with the metafrontier at that input mix. Values less than 1 indicate a -technology gap. +technology gap. Since each group technology is a restricted subset +of the common metatechnology (Battese, Rao and O'Donnell, 2004), +the gap reflects the restrictions a group faces (regulation, +environment, endowments) rather than a fundamentally different +technology. } \examples{ set.seed(42) diff --git a/man/tgr_summary.Rd b/man/tgr_summary.Rd index bd8f9bf..30ff5ab 100644 --- a/man/tgr_summary.Rd +++ b/man/tgr_summary.Rd @@ -16,5 +16,20 @@ A data frame with columns: Group, N, Mean, SD, Min, Q1, Median, Q3, Max. } \description{ -Prints a summary table of TGR statistics by group. +Prints a summary table of TGR statistics by group. The underlying +observation-level TGR values are the same as those returned by +\code{efficiencies(object, type = "tgr")}. +} +\examples{ +sim <- simulate_metafrontier(n_groups = 2, n_per_group = 50, + seed = 42) +fit <- metafrontier(log_y ~ log_x1 + log_x2, data = sim$data, + group = "group", method = "sfa", + meta_type = "deterministic") +tgr_summary(fit) + +} +\seealso{ +\code{\link{efficiencies.metafrontier}}, + \code{\link{technology_gap_ratio}}, \code{\link{boot_tgr}} } diff --git a/man/vcov.metafrontier.Rd b/man/vcov.metafrontier.Rd index db729e5..3aa7445 100644 --- a/man/vcov.metafrontier.Rd +++ b/man/vcov.metafrontier.Rd @@ -4,7 +4,13 @@ \alias{vcov.metafrontier} \title{Variance-Covariance Matrix for Metafrontier Coefficients} \usage{ -\method{vcov}{metafrontier}(object, correction = c("none", "murphy-topel"), ...) +\method{vcov}{metafrontier}( + object, + correction = c("none", "murphy-topel"), + which = c("meta", "group"), + extraPar = FALSE, + ... +) } \arguments{ \item{object}{a \code{"metafrontier"} object.} @@ -15,13 +21,38 @@ the Murphy and Topel (1985) correction for first-stage estimation uncertainty (the generated-regressor problem). Only available for stochastic metafrontiers.} +\item{which}{character. \code{"meta"} (default) returns the +metafrontier (Stage 2) variance-covariance matrix; +\code{"group"} returns a named list with one full +variance-covariance matrix per group (from the inverse negative +Hessian of the group MLE), with \code{NULL} entries for groups +without a stored Hessian.} + +\item{extraPar}{logical. If \code{TRUE} and \code{which = "meta"}, +the full Stage 2 matrix is returned, including the rows and +columns for the auxiliary parameters (raw MLE parameterisation, +e.g. \code{log_sigma_v}); the default returns only the block for +the frontier coefficients.} + \item{...}{additional arguments (currently unused).} } \value{ -A variance-covariance matrix, or \code{NULL} if unavailable. +A variance-covariance matrix (\code{which = "meta"}), a + named list of matrices (\code{which = "group"}), or \code{NULL} + if unavailable. } \description{ -Variance-Covariance Matrix for Metafrontier Coefficients +Returns the variance-covariance matrix of the Stage 2 +(metafrontier) coefficients, or, with \code{which = "group"}, the +per-group matrices from the Stage 1 maximum likelihood fits. +\code{NULL} is returned when no Stage 2 Hessian exists: the +deterministic metafrontier is fitted by LP/QP optimisation and has +no sampling variance in this framework, so \code{which = "meta"} +returns \code{NULL} with a warning; with \code{which = "group"}, +list entries are \code{NULL} for groups without a stored Hessian +(e.g. externally fitted models). DEA-based metafrontiers are +nonparametric and \code{vcov()} signals an error; use +\code{\link{boot_tgr}} for inference instead. } \examples{ sim <- simulate_metafrontier(n_groups = 2, n_per_group = 50, seed = 42) diff --git a/tests/testthat/test-bc88.R b/tests/testthat/test-bc88.R new file mode 100644 index 0000000..42703d0 --- /dev/null +++ b/tests/testthat/test-bc88.R @@ -0,0 +1,88 @@ +# Tests for the BC88 (Battese and Coelli, 1988) efficiency estimator + +.bc88_test_data <- function(n = 200, seed = 1) { + set.seed(seed) + x1 <- rnorm(n) + x2 <- rnorm(n) + u <- abs(rnorm(n, 0, 0.3)) + v <- rnorm(n, 0, 0.2) + data.frame(y = 1 + 0.5 * x1 + 0.3 * x2 + v - u, x1 = x1, x2 = x2) +} + +test_that("bc88 and jlms are both stored, bounded, and highly correlated", { + d <- .bc88_test_data() + f <- Formula::Formula(y ~ x1 + x2) + + gm <- metafrontier:::.fit_sfa_group(f, d, "hnormal", list()) + + expect_true(all(gm$efficiency_bc88 > 0 & gm$efficiency_bc88 < 1)) + expect_true(all(gm$efficiency_jlms > 0 & gm$efficiency_jlms < 1)) + expect_gt(cor(gm$efficiency_bc88, gm$efficiency_jlms), 0.99) +}) + +test_that("bc88 matches the textbook formula recomputed by hand", { + d <- .bc88_test_data() + f <- Formula::Formula(y ~ x1 + x2) + + gm <- metafrontier:::.fit_sfa_group(f, d, "hnormal", list()) + + # Half-normal conditional posterior of u given eps + sv <- gm$sigma_v + su <- gm$sigma_u + eps <- gm$residuals + s2 <- sv^2 + su^2 + mu_star <- -eps * su^2 / s2 + sigma_star <- sv * su / sqrt(s2) + + te_hand <- exp(-mu_star + 0.5 * sigma_star^2) * + pnorm(mu_star / sigma_star - sigma_star) / pnorm(mu_star / sigma_star) + + expect_equal(gm$efficiency_bc88, as.numeric(te_hand), tolerance = 1e-10) +}) + +test_that("bc88 and jlms agree with sfaR::sfacross", { + skip_if_not_installed("sfaR") + + d <- .bc88_test_data() + f <- Formula::Formula(y ~ x1 + x2) + + gm <- metafrontier:::.fit_sfa_group(f, d, "hnormal", list()) + sm <- sfaR::sfacross(y ~ x1 + x2, data = d, udist = "hnormal") + effs <- sfaR::efficiencies(sm) + + expect_gt(cor(gm$efficiency_bc88, effs$teBC), 0.999) + expect_lt(max(abs(gm$efficiency_bc88 - effs$teBC)), 1e-3) + expect_gt(cor(gm$efficiency_jlms, effs$teJLMS), 0.999) + expect_lt(max(abs(gm$efficiency_jlms - effs$teJLMS)), 1e-3) +}) + +test_that("estimator argument selects the efficiency vector, default bc88", { + d <- .bc88_test_data() + f <- Formula::Formula(y ~ x1 + x2) + + gm_def <- metafrontier:::.fit_sfa_group(f, d, "hnormal", list()) + gm_jlms <- metafrontier:::.fit_sfa_group(f, d, "hnormal", list(), + estimator = "jlms") + + expect_identical(gm_def$estimator, "bc88") + expect_identical(gm_def$efficiency, gm_def$efficiency_bc88) + expect_identical(gm_jlms$estimator, "jlms") + expect_identical(gm_jlms$efficiency, gm_jlms$efficiency_jlms) +}) + +test_that("bc88 is computed in all distribution branches", { + d <- .bc88_test_data() + set.seed(2) + d$z1 <- rnorm(nrow(d)) + f <- Formula::Formula(y ~ x1 + x2) + fz <- Formula::Formula(y ~ x1 + x2 | z1) + + for (dist in c("hnormal", "tnormal", "exponential")) { + gm <- metafrontier:::.fit_sfa_group(f, d, dist, list()) + expect_true(all(gm$efficiency_bc88 > 0 & gm$efficiency_bc88 <= 1), + label = paste("homoscedastic", dist)) + gmz <- metafrontier:::.fit_sfa_group(fz, d, dist, list()) + expect_true(all(gmz$efficiency_bc88 > 0 & gmz$efficiency_bc88 <= 1), + label = paste("heteroscedastic", dist)) + } +}) diff --git a/tests/testthat/test-dea-features.R b/tests/testthat/test-dea-features.R new file mode 100644 index 0000000..661bd92 --- /dev/null +++ b/tests/testthat/test-dea-features.R @@ -0,0 +1,371 @@ +# Tests for v0.3.0 DEA features: phi-bound fix, FDH, user-defined +# DDF directions, hyperbolic efficiency, and second-stage slacks + +# Small positive-valued production dataset shared across tests +.make_dea_feature_data <- function(n = 40, seed = 123) { + set.seed(seed) + x1 <- runif(n, 1, 10) + x2 <- runif(n, 1, 10) + grp <- rep(c("A", "B"), each = n / 2) + tech <- ifelse(grp == "A", 1, 0.8) + y <- tech * (x1^0.4 * x2^0.4) * runif(n, 0.6, 1) + data.frame(y = y, x1 = x1, x2 = x2, group = grp) +} + + +# ---- (i) phi lower bound fix ---- + +test_that("output-oriented LP solves for super-efficient DMUs (phi < 1)", { + # Reference technology: y = x under CRS. The evaluated point (1, 2) + # lies strictly above it, so phi* = 0.5 < 1. With the old lower + # bound phi >= 1 this LP was infeasible. + X_ref <- matrix(c(1, 2, 3, 4, 5), ncol = 1) + Y_ref <- matrix(c(1, 2, 3, 4, 5), ncol = 1) + + te <- metafrontier:::.dea_solve_lp(1, 2, X_ref, Y_ref, "output", "crs") + expect_false(is.na(te)) + expect_equal(te, 2, tolerance = 1e-8) # Farrell TE = 1/phi + + # The batch solver takes the same cross-period path + te_b <- metafrontier:::.dea_batch_fast(matrix(1, 1, 1), matrix(2, 1, 1), + "output", "crs", + X_ref = X_ref, Y_ref = Y_ref) + expect_equal(te_b, 2, tolerance = 1e-8) +}) + + +test_that("same-period output-oriented scores remain in (0, 1]", { + dat <- .make_dea_feature_data() + X <- cbind(dat$x1, dat$x2) + Y <- matrix(dat$y, ncol = 1) + + te <- metafrontier:::.dea_batch_fast(X, Y, "output", "crs") + expect_true(all(te > 0)) + expect_true(all(te <= 1 + 1e-8)) +}) + + +# ---- (ii) FDH ---- + +test_that("FDH radial efficiency dominates VRS in both orientations", { + skip_on_cran() + dat <- .make_dea_feature_data() + X <- cbind(dat$x1, dat$x2) + Y <- matrix(dat$y, ncol = 1) + + for (orient in c("input", "output")) { + e_fdh <- metafrontier:::.dea_batch_fast(X, Y, orient, "fdh") + e_vrs <- metafrontier:::.dea_batch_fast(X, Y, orient, "vrs") + expect_true(all(e_fdh >= e_vrs - 1e-8)) + expect_true(all(e_fdh > 0)) + expect_true(all(e_fdh <= 1 + 1e-8)) + } +}) + + +test_that("FDH metafrontier TGR lies in (0, 1]", { + skip_on_cran() + dat <- .make_dea_feature_data() + f <- Formula::Formula(y ~ x1 + x2) + gvec <- factor(dat$group) + glev <- levels(gvec) + + gm <- lapply(glev, function(g) { + metafrontier:::.fit_dea_group(f, dat[gvec == g, ], "input", "fdh") + }) + names(gm) <- glev + + res <- metafrontier:::.estimate_dea_metafrontier(f, dat, gvec, glev, gm, + "input", "fdh") + expect_true(all(res$tgr > 0)) + expect_true(all(res$tgr <= 1 + 1e-8)) +}) + + +test_that("FDH returns NA with a warning when no reference point dominates", { + # Cross-period evaluation: no reference point can produce y = 10 + expect_warning( + v <- metafrontier:::.dea_batch_fast(matrix(0.5, 1, 1), matrix(10, 1, 1), + "input", "fdh", + X_ref = matrix(1:3, ncol = 1), + Y_ref = matrix(1:3, ncol = 1)), + "No dominating FDH reference point" + ) + expect_true(is.na(v)) +}) + + +test_that("DDF with FDH (binary MIP) is no larger than the VRS beta", { + skip_on_cran() + dat <- .make_dea_feature_data(n = 20) + X <- cbind(dat$x1, dat$x2) + Y <- matrix(dat$y, ncol = 1) + + b_fdh <- metafrontier:::.dea_solve_ddf(X[1, ], Y[1, ], X, Y, + g_x = X[1, ], g_y = Y[1, ], + rts = "fdh") + b_vrs <- metafrontier:::.dea_solve_ddf(X[1, ], Y[1, ], X, Y, + g_x = X[1, ], g_y = Y[1, ], + rts = "vrs") + expect_true(b_fdh >= -1e-8) + expect_true(b_fdh <= b_vrs + 1e-8) +}) + + +# ---- (iii) user-defined DDF directions ---- + +test_that("numeric direction vector runs and reports additive gaps", { + skip_on_cran() + dat <- .make_dea_feature_data() + f <- Formula::Formula(y ~ x1 + x2) + gvec <- factor(dat$group) + glev <- levels(gvec) + gdir <- c(mean(dat$x1), mean(dat$x2), mean(dat$y)) + + gm <- lapply(glev, function(g) { + metafrontier:::.fit_ddf_group(f, dat[gvec == g, ], "crs", gdir) + }) + names(gm) <- glev + + res <- metafrontier:::.estimate_ddf_metafrontier(f, dat, gvec, glev, gm, + "crs", gdir) + + # te = 1/(1 + beta) is undefined for arbitrary numeric directions + expect_true(all(is.na(res$te_group))) + expect_true(all(is.na(res$te_meta))) + expect_true(all(is.na(res$tgr))) + + # Additive fields carry the results; the gap is non-negative because + # the pooled reference set is a superset + expect_length(res$beta_group, nrow(dat)) + expect_length(res$beta_meta, nrow(dat)) + expect_true(all(res$beta_meta >= res$beta_group - 1e-8)) + expect_equal(res$ddf_gap, res$beta_meta - res$beta_group) +}) + + +test_that("firm-specific direction matrix runs and matches common vector", { + skip_on_cran() + dat <- .make_dea_feature_data() + f <- Formula::Formula(y ~ x1 + x2) + gvec <- factor(dat$group) + glev <- levels(gvec) + n <- nrow(dat) + gdir <- c(mean(dat$x1), mean(dat$x2), mean(dat$y)) + dmat <- matrix(rep(gdir, n), n, 3, byrow = TRUE) + + gm <- lapply(glev, function(g) { + metafrontier:::.fit_ddf_group(f, dat[gvec == g, ], "crs", + dmat[gvec == g, , drop = FALSE]) + }) + names(gm) <- glev + + res_mat <- metafrontier:::.estimate_ddf_metafrontier(f, dat, gvec, glev, + gm, "crs", dmat) + + gm_vec <- lapply(glev, function(g) { + metafrontier:::.fit_ddf_group(f, dat[gvec == g, ], "crs", gdir) + }) + names(gm_vec) <- glev + res_vec <- metafrontier:::.estimate_ddf_metafrontier(f, dat, gvec, glev, + gm_vec, "crs", gdir) + + expect_equal(res_mat$beta_meta, res_vec$beta_meta, tolerance = 1e-10) + expect_equal(res_mat$beta_group, res_vec$beta_group, tolerance = 1e-10) +}) + + +test_that("character presets still populate te and the additive fields", { + dat <- .make_dea_feature_data(n = 20) + f <- Formula::Formula(y ~ x1 + x2) + gvec <- factor(dat$group) + glev <- levels(gvec) + + gm <- lapply(glev, function(g) { + metafrontier:::.fit_ddf_group(f, dat[gvec == g, ], "crs", "proportional") + }) + names(gm) <- glev + + res <- metafrontier:::.estimate_ddf_metafrontier(f, dat, gvec, glev, gm, + "crs", "proportional") + expect_false(any(is.na(res$te_meta))) + expect_false(any(is.na(res$tgr))) + expect_equal(res$ddf_gap, res$beta_meta - res$beta_group) + expect_true(all(res$ddf_gap >= -1e-8)) +}) + + +test_that("malformed numeric directions are rejected", { + X <- matrix(1:6, 3, 2) + Y <- matrix(1:3, 3, 1) + expect_error(metafrontier:::.ddf_direction_mats(c(1, 2), X, Y), + "length m \\+ s") + expect_error(metafrontier:::.ddf_direction_mats(matrix(1, 2, 3), X, Y), + "n x \\(m \\+ s\\)") + expect_error(metafrontier:::.ddf_direction_mats(c(-1, 1, 1), X, Y), + "non-negative") + expect_error(metafrontier:::.ddf_direction_mats(c(0, 0, 0), X, Y), + "at least one positive") +}) + + +# ---- (iv) hyperbolic efficiency ---- + +test_that("hyperbolic CRS closed form agrees with direct bisection", { + skip_on_cran() + dat <- .make_dea_feature_data(n = 20) + X <- cbind(dat$x1, dat$x2) + Y <- matrix(dat$y, ncol = 1) + n <- nrow(X) + + g_closed <- metafrontier:::.hyperbolic_batch(X, Y, "crs") + expect_true(all(g_closed > 0)) + expect_true(all(g_closed <= 1 + 1e-8)) + + # Independent bisection on CRS feasibility LPs: + # gamma feasible iff exists lambda >= 0 with + # X' lambda <= gamma * x_i and Y' lambda >= y_i / gamma + crs_feasible <- function(gamma, i) { + lp <- lpSolveAPI::make.lp(0, n) + lpSolveAPI::set.objfn(lp, rep(0, n)) + lpSolveAPI::lp.control(lp, sense = "min", verbose = "neutral") + for (mm in 1:2) { + lpSolveAPI::add.constraint(lp, X[, mm], "<=", gamma * X[i, mm]) + } + lpSolveAPI::add.constraint(lp, Y[, 1], ">=", Y[i, 1] / gamma) + lpSolveAPI::solve.lpExtPtr(lp) == 0 + } + + for (i in c(1, 5, 10, 15, 20)) { + lo <- 0 + hi <- 1 + for (iter in 1:40) { + if (hi - lo < 1e-9) break + mid <- (lo + hi) / 2 + if (crs_feasible(mid, i)) hi <- mid else lo <- mid + } + expect_equal(g_closed[i], hi, tolerance = 1e-6) + } +}) + + +test_that("hyperbolic metafrontier works under VRS with TGR <= 1", { + skip_on_cran() + dat <- .make_dea_feature_data() + f <- Formula::Formula(y ~ x1 + x2) + gvec <- factor(dat$group) + glev <- levels(gvec) + + gm <- lapply(glev, function(g) { + metafrontier:::.fit_hyperbolic_group(f, dat[gvec == g, ], "vrs") + }) + names(gm) <- glev + + res <- metafrontier:::.estimate_hyperbolic_metafrontier(f, dat, gvec, + glev, gm, "vrs") + + expect_true(all(res$te_group > 0)) + expect_true(all(res$te_group <= 1 + 1e-8)) + expect_true(all(res$te_meta > 0)) + expect_true(all(res$te_meta <= 1 + 1e-8)) + # Bisection tolerance (1e-8 per gamma) is amplified in the ratio + expect_true(all(res$tgr > 0)) + expect_true(all(res$tgr <= 1 + 1e-6)) + expect_identical(res$meta_convergence, 0L) + expect_null(res$meta_coef) +}) + + +test_that("hyperbolic FDH and VRS envelop CRS", { + skip_on_cran() + dat <- .make_dea_feature_data(n = 20) + X <- cbind(dat$x1, dat$x2) + Y <- matrix(dat$y, ncol = 1) + + g_crs <- metafrontier:::.hyperbolic_batch(X, Y, "crs") + g_vrs <- metafrontier:::.hyperbolic_batch(X, Y, "vrs") + g_fdh <- metafrontier:::.hyperbolic_batch(X, Y, "fdh") + + expect_true(all(g_vrs >= g_crs - 1e-6)) + expect_true(all(g_fdh >= g_vrs - 1e-6)) + expect_true(all(g_fdh <= 1 + 1e-8)) +}) + + +# ---- (v) slacks ---- + +test_that("slack = TRUE returns non-negative slack matrices of correct dims", { + skip_on_cran() + dat <- .make_dea_feature_data() + f <- Formula::Formula(y ~ x1 + x2) + gvec <- factor(dat$group) + glev <- levels(gvec) + + gm <- lapply(glev, function(g) { + metafrontier:::.fit_dea_group(f, dat[gvec == g, ], "input", "vrs", + slack = TRUE) + }) + names(gm) <- glev + + for (g in glev) { + n_g <- gm[[g]]$nobs + expect_identical(dim(gm[[g]]$slack_x), c(n_g, 2L)) + expect_identical(dim(gm[[g]]$slack_y), c(n_g, 1L)) + expect_true(all(gm[[g]]$slack_x >= 0)) + expect_true(all(gm[[g]]$slack_y >= 0)) + } + + res <- metafrontier:::.estimate_dea_metafrontier(f, dat, gvec, glev, gm, + "input", "vrs", + slack = TRUE) + expect_identical(dim(res$slack_x_meta), c(nrow(dat), 2L)) + expect_identical(dim(res$slack_y_meta), c(nrow(dat), 1L)) + expect_true(all(res$slack_x_meta >= 0)) + expect_true(all(res$slack_y_meta >= 0)) +}) + + +test_that("a radially efficient but dominated DMU shows positive slack", { + # Classic example: A = (1, 4), B = (4, 1), C = (2, 2) efficient; + # D = (1, 5) has theta* = 1 under VRS but slack of 1 in input 2 + X <- matrix(c(1, 4, 1, 2, + 4, 1, 5, 2), ncol = 2) + Y <- matrix(1, 4, 1) + + theta <- metafrontier:::.dea_batch_fast(X, Y, "input", "vrs") + expect_equal(theta[3], 1, tolerance = 1e-8) + + sl <- metafrontier:::.dea_slacks(X, Y, theta, "input", "vrs", X, Y) + expect_true(all(sl$slack_x >= 0)) + expect_true(all(sl$slack_y >= 0)) + expect_equal(sl$slack_x[3, 2], 1, tolerance = 1e-6) + expect_equal(sl$slack_x[3, 1], 0, tolerance = 1e-6) +}) + + +test_that("FDH slacks are measured against the dominating peer", { + X <- matrix(c(1, 4, 1, 2, + 4, 1, 5, 2), ncol = 2) + Y <- matrix(1, 4, 1) + + theta <- metafrontier:::.dea_batch_fast(X, Y, "input", "fdh") + sl <- metafrontier:::.dea_slacks(X, Y, theta, "input", "fdh", X, Y) + + expect_true(all(sl$slack_x >= 0)) + expect_true(all(sl$slack_y >= 0)) + # D = (1, 5) is dominated by peer A = (1, 4): slack of 1 in input 2 + expect_equal(sl$slack_x[3, 2], 1, tolerance = 1e-8) +}) + + +test_that("output-oriented slacks are non-negative", { + skip_on_cran() + X <- matrix(c(1, 4, 1, 2, + 4, 1, 5, 2), ncol = 2) + Y <- matrix(1, 4, 1) + + te <- metafrontier:::.dea_batch_fast(X, Y, "output", "vrs") + sl <- metafrontier:::.dea_slacks(X, Y, te, "output", "vrs", X, Y) + expect_true(all(sl$slack_x >= 0)) + expect_true(all(sl$slack_y >= 0)) +}) diff --git a/tests/testthat/test-diagnostics.R b/tests/testthat/test-diagnostics.R new file mode 100644 index 0000000..2fec7d8 --- /dev/null +++ b/tests/testthat/test-diagnostics.R @@ -0,0 +1,172 @@ +# Tests for convergence diagnostics and extended coef/vcov/summary methods + +sim_cs <- simulate_metafrontier(n_groups = 2, n_per_group = 40, seed = 42) +fit_det <- metafrontier(log_y ~ log_x1 + log_x2, data = sim_cs$data, + group = "group") +fit_stoch <- metafrontier(log_y ~ log_x1 + log_x2, data = sim_cs$data, + group = "group", meta_type = "stochastic") + +sim_panel <- simulate_panel_metafrontier(n_groups = 2, + n_firms_per_group = 20, + n_periods = 4, + eta = 0.05, seed = 123) +fit_panel <- metafrontier(log_y ~ log_x1 + log_x2, data = sim_panel$data, + group = "group", + panel = list(id = "firm", time = "year"), + panel_dist = "bc92") + + +test_that("check_convergence reports all stages for a deterministic SFA fit", { + conv <- check_convergence(fit_det) + + expect_s3_class(conv, "metafrontier_convergence") + expect_s3_class(conv, "data.frame") + expect_named(conv, c("stage", "method", "code", "converged", "note")) + expect_equal(nrow(conv), length(fit_det$groups) + 1L) + expect_equal(conv$stage, + c(paste0("group: ", fit_det$groups), "metafrontier")) + expect_true(all(conv$converged)) + expect_true(all(conv$method[seq_along(fit_det$groups)] == "MLE")) + expect_true(conv$method[nrow(conv)] %in% c("LP", "QP", "QP (barrier)")) + expect_true(is.integer(conv$code)) +}) + + +test_that("check_convergence on a stochastic fit reports MLE meta stage", { + conv <- check_convergence(fit_stoch) + expect_equal(conv$method[nrow(conv)], "MLE") + expect_true(all(conv$converged)) +}) + + +test_that("check_convergence on a DEA fit uses method DEA and NA codes", { + fit_dea <- metafrontier(log_y ~ log_x1 + log_x2, data = sim_cs$data, + group = "group", method = "dea", rts = "crs") + conv <- check_convergence(fit_dea) + + expect_true(all(conv$method == "DEA")) + expect_true(all(is.na(conv$code))) + expect_true(all(conv$converged)) + expect_true(all(conv$note == "")) +}) + + +test_that("check_convergence flags externally fitted groups", { + mods <- lapply(fit_det$group_models, function(gm) { + list(coefficients = gm$coefficients, efficiency = gm$efficiency, + X = gm$X, y = gm$y) + }) + fit_ext <- metafrontier(models = mods) + conv <- check_convergence(fit_ext) + + n_grp <- length(fit_ext$groups) + expect_true(all(conv$method[seq_len(n_grp)] == "external")) + expect_true(all(is.na(conv$code[seq_len(n_grp)]))) + expect_true(all(is.na(conv$converged[seq_len(n_grp)]))) + expect_match(conv$note[1], "fitted externally") + + expect_warning( + coef(fit_ext, which = "group", extraPar = TRUE), + "externally" + ) +}) + + +test_that("check_convergence.default errors clearly", { + expect_error(check_convergence(lm(dist ~ speed, data = cars)), + "not implemented") +}) + + +test_that("coef(..., extraPar = TRUE) exposes eta for a BC92 panel fit", { + cf <- coef(fit_panel, which = "group", extraPar = TRUE) + + expect_true(is.list(cf)) + expect_named(cf, fit_panel$groups) + for (g in fit_panel$groups) { + expect_true(all(c("sigmaV", "sigmaU", "eta") %in% names(cf[[g]]))) + expect_gt(unname(cf[[g]]["sigmaV"]), 0) + expect_gt(unname(cf[[g]]["sigmaU"]), 0) + } + + # Backward compatibility: default call unchanged + expect_identical(coef(fit_panel, which = "group"), fit_panel$group_coef) +}) + + +test_that("coef(..., extraPar = TRUE) appends stage-2 variances (meta)", { + cf_plain <- coef(fit_stoch) + cf_extra <- coef(fit_stoch, extraPar = TRUE) + + expect_gt(length(cf_extra), length(cf_plain)) + expect_true(all(c("sigmaV", "sigmaU") %in% names(cf_extra))) + expect_equal(cf_extra[seq_along(cf_plain)], cf_plain) + + # Deterministic metafrontier has no auxiliary parameters + expect_message(cf_det <- coef(fit_det, extraPar = TRUE), + "No auxiliary parameters") + expect_identical(cf_det, coef(fit_det)) +}) + + +test_that("vcov(..., extraPar = TRUE) returns the full stage-2 matrix", { + v <- vcov(fit_stoch) + v_full <- vcov(fit_stoch, extraPar = TRUE) + + expect_gt(nrow(v_full), nrow(v)) + expect_equal(unname(v_full[seq_len(nrow(v)), seq_len(ncol(v))]), + unname(v)) +}) + + +test_that("vcov(..., which = 'group') returns per-group matrices", { + v_g <- vcov(fit_stoch, which = "group") + + expect_true(is.list(v_g)) + expect_named(v_g, fit_stoch$groups) + for (g in fit_stoch$groups) { + gm <- fit_stoch$group_models[[g]] + expect_true(is.matrix(v_g[[g]])) + expect_equal(nrow(v_g[[g]]), length(gm$all_params)) + expect_true("log_sigma_v" %in% rownames(v_g[[g]])) + } +}) + + +test_that("summary of a BC92 fit shows eta with a standard error", { + s <- summary(fit_panel) + + for (g in fit_panel$groups) { + tab <- s$group_tables[[g]] + expect_true("eta" %in% rownames(tab)) + expect_true(is.finite(tab["eta", "Std. Error"])) + } + + expect_output(print(s), "eta") +}) + + +test_that("print methods report convergence status", { + expect_output(print(fit_det), "Convergence: OK") + expect_output(print(summary(fit_det)), + "All estimation stages converged") + expect_output(print(check_convergence(fit_det)), + "Convergence of estimation stages") + + # A non-converged stage triggers warnings in all three displays + fit_bad <- fit_det + fit_bad$group_models[[1]]$convergence <- 1L + expect_output(print(fit_bad), "Convergence: WARNING") + expect_output(print(summary(fit_bad)), "See \\?check_convergence") + expect_output(print(check_convergence(fit_bad)), + "did not converge") +}) + + +test_that("print shows Estimator and Objective lines when present", { + fit2 <- fit_det + if (is.null(fit2$estimator)) fit2$estimator <- "bc88" + if (is.null(fit2$objective)) fit2$objective <- "lp" + expect_output(print(fit2), "Estimator:\\s+bc88") + expect_output(print(fit2), "Objective:\\s+lp") +}) diff --git a/tests/testthat/test-frontier-equivalence.R b/tests/testthat/test-frontier-equivalence.R new file mode 100644 index 0000000..7dfdc1d --- /dev/null +++ b/tests/testthat/test-frontier-equivalence.R @@ -0,0 +1,26 @@ +# Equivalence check against frontier::sfa() +# The package's custom MLE should match frontier::sfa() slope and intercept +# estimates to within 1e-4 on the same simulated data. + +skip_if_not_installed("frontier") + +test_that("group SFA coefficients match frontier::sfa() to 1e-4", { + sim <- simulate_metafrontier(n_groups = 3, n_per_group = 150, + tech_gap = c(0, 0.3, 0.5), seed = 42) + dat <- sim$data + + fit_mf <- metafrontier(log_y ~ log_x1 + log_x2, data = dat, + group = "group", method = "sfa", + meta_type = "deterministic") + + for (g in c("G2", "G3")) { + dat_g <- dat[dat$group == g, , drop = FALSE] + f_g <- frontier::sfa(log_y ~ log_x1 + log_x2, data = dat_g) + + b_mf <- coef(fit_mf$group_models[[g]]) + b_fr <- coef(f_g)[names(b_mf)] + + expect_lt(max(abs(b_mf - b_fr)), 1e-4, + label = paste("max |coef diff| for group", g)) + } +}) diff --git a/tests/testthat/test-malmquist-id.R b/tests/testthat/test-malmquist-id.R new file mode 100644 index 0000000..8b76d49 --- /dev/null +++ b/tests/testthat/test-malmquist-id.R @@ -0,0 +1,188 @@ +# Tests for firm matching via `id`, infeasibility accounting, and +# method visibility in malmquist_meta(). + +# Deterministic positive-level panel: 2 groups x n_per_group firms x +# n_periods periods, suitable for DEA on levels. +make_id_panel <- function(n_per_group = 6, n_periods = 3) { + df <- expand.grid(firm = seq_len(2 * n_per_group), + time = seq_len(n_periods)) + df$group <- ifelse(df$firm <= n_per_group, "A", "B") + df$x1 <- 1 + 0.1 * (df$firm %% 5) + 0.05 * df$time + df$x2 <- 1.5 + 0.08 * (df$firm %% 7) + eff <- 0.6 + 0.4 * ((df$firm * 7) %% 10) / 10 + df$y <- eff * df$x1^0.4 * df$x2^0.3 * (1 + 0.1 * df$time) + df +} + +test_that("id gives order-invariant results on a balanced panel", { + pd <- make_id_panel() + + base <- suppressMessages( + malmquist_meta(y ~ x1 + x2, data = pd, + group = "group", time = "time") + ) + set.seed(1) + pd_scr <- pd[sample(nrow(pd)), ] + scr <- malmquist_meta(y ~ x1 + x2, data = pd_scr, + group = "group", time = "time", id = "firm") + + # Positional ids in the baseline are within-group positions; map + # them back to firm numbers (group A = 1..6, group B = 7..12). + base_m <- base$malmquist + base_m$firm <- base_m$id + ifelse(base_m$group == "B", 6L, 0L) + scr_m <- scr$malmquist + + base_m <- base_m[order(base_m$period_from, base_m$group, base_m$firm), ] + scr_m <- scr_m[order(scr_m$period_from, scr_m$group, scr_m$id), ] + + expect_equal(scr_m$id, base_m$firm) + expect_equal(scr_m$MPI, base_m$MPI, tolerance = 1e-8) + expect_equal(scr_m$TEC, base_m$TEC, tolerance = 1e-8) + expect_equal(scr_m$TGC, base_m$TGC, tolerance = 1e-8) + expect_equal(scr_m$TC, base_m$TC, tolerance = 1e-8) + + # Method visibility + expect_identical(scr$method, "dea") + expect_output(print(scr), "Method") +}) + +test_that("unbalanced panels drop unmatched firms with a consolidated warning", { + pd <- make_id_panel() + + # Make firms 3 (group A) and 9 (group B) strictly dominated (same + # inputs as firms 2 and 8, much lower output) so that dropping them + # leaves every DEA reference technology unchanged. + for (tt in unique(pd$time)) { + r3 <- pd$firm == 3 & pd$time == tt + r2 <- pd$firm == 2 & pd$time == tt + pd[r3, c("x1", "x2")] <- pd[r2, c("x1", "x2")] + pd$y[r3] <- 0.4 * pd$y[r2] + r9 <- pd$firm == 9 & pd$time == tt + r8 <- pd$firm == 8 & pd$time == tt + pd[r9, c("x1", "x2")] <- pd[r8, c("x1", "x2")] + pd$y[r9] <- 0.4 * pd$y[r8] + } + + bal <- malmquist_meta(y ~ x1 + x2, data = pd, + group = "group", time = "time", id = "firm") + + pd_unb <- pd[!(pd$firm == 3 & pd$time == 2) & + !(pd$firm == 9 & pd$time == 1), ] + # 3 dropped in total: firm 3 + firm 9 in pair 1 -> 2, firm 3 in 2 -> 3 + expect_warning( + unb <- malmquist_meta(y ~ x1 + x2, data = pd_unb, + group = "group", time = "time", id = "firm"), + "3 observation" + ) + + # The right firms are dropped + expect_false(any(unb$malmquist$id == 3)) + expect_false(any(unb$malmquist$id == 9 & unb$malmquist$period_from == 1)) + expect_true(any(unb$malmquist$id == 9 & unb$malmquist$period_from == 2)) + + # Retained firms match the balanced results exactly + key_b <- paste(bal$malmquist$id, bal$malmquist$period_from) + key_u <- paste(unb$malmquist$id, unb$malmquist$period_from) + expect_true(all(key_u %in% key_b)) + pos <- match(key_u, key_b) + expect_equal(unb$malmquist$MPI, bal$malmquist$MPI[pos], tolerance = 1e-8) + expect_equal(unb$malmquist$TC, bal$malmquist$TC[pos], tolerance = 1e-8) +}) + +test_that("duplicated (id, period) combinations within a group error", { + pd <- make_id_panel() + pd_dup <- rbind(pd, pd[pd$firm == 1 & pd$time == 1, ]) + expect_error( + malmquist_meta(y ~ x1 + x2, data = pd_dup, + group = "group", time = "time", id = "firm"), + "Duplicated" + ) + expect_error( + malmquist_meta(y ~ x1 + x2, data = pd_dup, + group = "group", time = "time", id = "firm"), + "period 1" + ) +}) + +test_that("id = NULL messages, and unequal group sizes warn", { + pd <- make_id_panel() + + expect_message( + malmquist_meta(y ~ x1 + x2, data = pd, + group = "group", time = "time"), + "row position" + ) + + pd_unb <- pd[!(pd$firm == 3 & pd$time == 2), ] + expect_warning( + suppressMessages( + malmquist_meta(y ~ x1 + x2, data = pd_unb, + group = "group", time = "time") + ), + "positional matching" + ) +}) + +test_that("infeasible cross-period programs are counted and warned under vrs", { + pd <- make_id_panel(n_per_group = 5, n_periods = 2) + + # Anchor firms (one per group) define the CRS frontier in both + # periods, so all cross-period CRS programs stay feasible. + pd[pd$firm == 1, c("x1", "x2", "y")] <- list(1, 1, 2) + pd[pd$firm == 6, c("x1", "x2", "y")] <- list(1, 1, 2) + # Tiny firm whose period-1 inputs undercut every period-2 + # observation: its period-1 cross-period VRS programs (group and + # meta) are genuinely infeasible. + pd[pd$firm == 2 & pd$time == 1, c("x1", "x2", "y")] <- + list(0.01, 0.01, 0.001) + pd[pd$firm == 2 & pd$time == 2, c("x1", "x2", "y")] <- + list(0.05, 0.05, 0.002) + + expect_warning( + malm_vrs <- malmquist_meta(y ~ x1 + x2, data = pd, + group = "group", time = "time", + id = "firm", rts = "vrs"), + "cross-period DEA programs were infeasible" + ) + expect_equal(malm_vrs$n_infeasible, 2L) + expect_true(any(is.na(malm_vrs$malmquist$TC))) + expect_true(is.data.frame(malm_vrs$infeasible_by_period)) + expect_equal(sum(malm_vrs$infeasible_by_period$n_infeasible), + malm_vrs$n_infeasible) + expect_output(print(malm_vrs), "Infeasible") + expect_output(print(summary(malm_vrs)), "Infeasible") + + # CRS on the same data has no infeasible programs and no NAs + expect_no_warning( + malm_crs <- malmquist_meta(y ~ x1 + x2, data = pd, + group = "group", time = "time", + id = "firm", rts = "crs") + ) + expect_identical(malm_crs$n_infeasible, 0L) + expect_false(any(is.na(malm_crs$malmquist$TC))) + expect_false(any(is.na(malm_crs$malmquist$MPI))) +}) + +test_that("sfa path notes the approximation and carries id through", { + set.seed(7) + n <- 12 + df <- expand.grid(firm = seq_len(2 * n), time = 1:2) + df$group <- ifelse(df$firm <= n, "A", "B") + df$log_x1 <- rnorm(nrow(df)) + df$log_x2 <- rnorm(nrow(df)) + df$log_y <- 1 + 0.4 * df$log_x1 + 0.3 * df$log_x2 + + 0.2 * (df$group == "B") + + rnorm(nrow(df), sd = 0.1) - abs(rnorm(nrow(df), sd = 0.3)) + + suppressWarnings( + expect_message( + malm <- malmquist_meta(log_y ~ log_x1 + log_x2, data = df, + group = "group", time = "time", + id = "firm", method = "sfa"), + "pointwise maximum" + ) + ) + expect_identical(malm$method, "sfa") + expect_true(all(malm$malmquist$id %in% df$firm)) + expect_output(print(malm), "pointwise-maximum") +}) diff --git a/tests/testthat/test-objective.R b/tests/testthat/test-objective.R new file mode 100644 index 0000000..84f5762 --- /dev/null +++ b/tests/testthat/test-objective.R @@ -0,0 +1,95 @@ +# Tests for the objective = c("lp", "qp") choice in the +# deterministic SFA metafrontier (Battese, Rao and O'Donnell 2004 +# propose both minimum absolute and minimum squared deviations). + +sim_obj <- simulate_metafrontier(seed = 42) +dat_obj <- sim_obj$data + +fit_lp_obj <- metafrontier(log_y ~ log_x1 + log_x2, + data = dat_obj, + group = "group", + method = "sfa", + meta_type = "deterministic") +X_obj <- model.matrix(log_y ~ log_x1 + log_x2, data = dat_obj) + +test_that("QP metafrontier satisfies envelope and TGR bounds", { + skip_if_not_installed("quadprog") + + qp <- metafrontier:::.deterministic_metafrontier_lp( + X_obj, fit_lp_obj$group_frontier, fit_lp_obj$group_vec, + fit_lp_obj$groups, fit_lp_obj$group_coef, ncol(X_obj), + objective = "qp" + ) + + expect_identical(qp$meta_solver, "qp") + + meta_frontier_qp <- as.numeric(X_obj %*% qp$meta_coef) + expect_true(all(meta_frontier_qp >= fit_lp_obj$group_frontier - 1e-6)) + + tgr_qp <- exp(fit_lp_obj$group_frontier - meta_frontier_qp) + expect_true(all(tgr_qp <= 1 + 1e-6)) + + # User-facing argument (added by a concurrent change); skip the + # assertions if metafrontier() does not honour 'objective' yet. + fit_qp <- tryCatch( + metafrontier(log_y ~ log_x1 + log_x2, + data = dat_obj, + group = "group", + method = "sfa", + meta_type = "deterministic", + objective = "qp"), + error = function(e) NULL + ) + if (!is.null(fit_qp) && identical(fit_qp$objective, "qp")) { + expect_identical(fit_qp$meta_solver, "qp") + expect_true(all(fit_qp$meta_frontier >= fit_qp$group_frontier - 1e-6)) + expect_true(all(fit_qp$tgr <= 1 + 1e-6)) + } +}) + +test_that("LP and QP objectives give similar TGR", { + skip_if_not_installed("quadprog") + + qp <- metafrontier:::.deterministic_metafrontier_lp( + X_obj, fit_lp_obj$group_frontier, fit_lp_obj$group_vec, + fit_lp_obj$groups, fit_lp_obj$group_coef, ncol(X_obj), + objective = "qp" + ) + + # Mirror the TGR construction of the deterministic pipeline + tgr_qp <- pmin(exp(fit_lp_obj$group_frontier - + as.numeric(X_obj %*% qp$meta_coef)), 1.0) + + max_diff <- max(abs(fit_lp_obj$tgr - tgr_qp)) + cat("\nMax abs TGR difference (LP vs QP):", format(max_diff), "\n") + + expect_lt(max_diff, 0.05) +}) + +test_that("rank-deficient X falls back to the barrier QP with a message", { + set.seed(99) + n <- 50 + x1 <- runif(n, 1, 2) + X_bad <- cbind("(Intercept)" = 1, x1 = x1, x1_dup = x1) + gf_bad <- 1 + 0.4 * x1 + rnorm(n, sd = 0.05) + gv_bad <- factor(rep(c("a", "b"), length.out = n)) + gc_bad <- list(a = c(1, 0.2, 0.2), b = c(1.1, 0.25, 0.15)) + + res <- NULL + expect_message( + res <- metafrontier:::.deterministic_metafrontier_lp( + X_bad, gf_bad, gv_bad, levels(gv_bad), gc_bad, ncol(X_bad), + objective = "qp" + ), + regexp = "constrOptim" + ) + + expect_identical(res$meta_solver, "qp-barrier") + expect_true(all(is.finite(res$meta_coef))) + expect_true(all(X_bad %*% res$meta_coef >= gf_bad - 1e-4)) +}) + +test_that("default fit records the LP solver and objective", { + expect_identical(fit_lp_obj$meta_solver, "lp") + expect_identical(fit_lp_obj$objective, "lp") +}) diff --git a/tests/testthat/test-panel-fixes.R b/tests/testthat/test-panel-fixes.R new file mode 100644 index 0000000..4d53e51 --- /dev/null +++ b/tests/testthat/test-panel-fixes.R @@ -0,0 +1,136 @@ +# Regression tests for panel SFA fixes: row order, NA handling, +# global-T decay anchoring, and unbalanced BC92 estimation + +.panel_test_group <- function(seed = 42, eta = 0.1, n_firms = 30, + n_periods = 5) { + sim <- simulate_panel_metafrontier( + n_groups = 2, n_firms_per_group = n_firms, + n_periods = n_periods, eta = eta, seed = seed + ) + g1 <- sim$data[sim$data$group == "G1", ] + # Firm IDs F1...F30: string sort order (F1, F10, F11, ...) differs + # from numeric order, which is what exposed the released row-order bug + g1$firm <- sub("^G1_", "", g1$firm) + list(data = g1, params = sim$params) +} + +.panel_formula <- function() Formula::Formula(log_y ~ log_x1 + log_x2) +.panel_info <- function() list(id = "firm", time = "year") + +test_that("panel fit is invariant to row order", { + g1 <- .panel_test_group()$data + set.seed(7) + g1_shuffled <- g1[sample(nrow(g1)), ] + + fit_sorted <- metafrontier:::.fit_sfa_panel_group( + .panel_formula(), g1, "hnormal", "bc92", .panel_info(), list() + ) + fit_shuffled <- metafrontier:::.fit_sfa_panel_group( + .panel_formula(), g1_shuffled, "hnormal", "bc92", .panel_info(), list() + ) + + expect_equal(fit_sorted$coefficients, fit_shuffled$coefficients, + tolerance = 1e-8) + + # Efficiency must agree per (firm, time) key, i.e. returned vectors + # are in input-row order for both fits + key_sorted <- paste(g1$firm, g1$year) + key_shuffled <- paste(g1_shuffled$firm, g1_shuffled$year) + expect_equal(fit_shuffled$efficiency, + fit_sorted$efficiency[match(key_shuffled, key_sorted)], + tolerance = 1e-8) +}) + +test_that("NA rows are dropped consistently across y, X and firm index", { + g1 <- .panel_test_group()$data + g1_na <- g1 + g1_na$log_x1[5] <- NA + + fit_na <- metafrontier:::.fit_sfa_panel_group( + .panel_formula(), g1_na, "hnormal", "bc92", .panel_info(), list() + ) + fit_dropped <- metafrontier:::.fit_sfa_panel_group( + .panel_formula(), g1[-5, ], "hnormal", "bc92", .panel_info(), list() + ) + + expect_length(fit_na$efficiency, nrow(g1) - 1) + expect_identical(as.character(fit_na$firms), as.character(g1$firm[-5])) + expect_equal(fit_na$efficiency, fit_dropped$efficiency, tolerance = 1e-10) + expect_equal(fit_na$coefficients, fit_dropped$coefficients, + tolerance = 1e-10) +}) + +test_that("unbalanced BC92 converges and recovers eta", { + gen <- .panel_test_group(seed = 456, eta = 0.1, n_firms = 50, + n_periods = 6) + g1 <- gen$data + set.seed(3) + g1_unbal <- g1[-sample(nrow(g1), 30), ] + + fit <- metafrontier:::.fit_sfa_panel_group( + .panel_formula(), g1_unbal, "hnormal", "bc92", .panel_info(), list() + ) + + expect_identical(fit$convergence, 0L) + expect_true(all(fit$efficiency > 0 & fit$efficiency <= 1)) + # Loose tolerance: eta is weakly identified in short panels + expect_lt(abs(fit$eta - gen$params$eta), 0.15) +}) + +test_that("BC92 decay is anchored at the global final period", { + g1 <- .panel_test_group(seed = 42, eta = 0.15)$data + # Remove firm F1's final period so its own last period < global T + g1_unbal <- g1[!(g1$firm == "F1" & g1$year == max(g1$year)), ] + + fit <- metafrontier:::.fit_sfa_panel_group( + .panel_formula(), g1_unbal, "hnormal", "bc92", .panel_info(), list() + ) + + # Recompute BC92 efficiency by hand with d_t = exp(-eta * (t - T)), + # T the GLOBAL final period; must match the stored values exactly + T_max <- max(g1_unbal$year) + sv <- fit$sigma_v + su <- fit$sigma_u + eta_hat <- fit$eta + idx_f1 <- which(fit$firms == "F1") + eps_f1 <- fit$residuals[idx_f1] + d_t <- exp(-eta_hat * (g1_unbal$year[g1_unbal$firm == "F1"] - T_max)) + + sigma_star2 <- 1 / (1 / su^2 + sum(d_t^2) / sv^2) + sigma_star <- sqrt(sigma_star2) + mu_star <- -sigma_star2 * sum(eps_f1 * d_t) / sv^2 + ratio <- mu_star / sigma_star + + te_bc88_hand <- pnorm(ratio - d_t * sigma_star) / pnorm(ratio) * + exp(-d_t * mu_star + 0.5 * d_t^2 * sigma_star2) + + expect_equal(fit$efficiency_bc88[idx_f1], te_bc88_hand, tolerance = 1e-10) + + # With eta_hat > 0 inefficiency decays over time, so F1's efficiency + # path must be monotone in the direction implied by the sign of eta + eff_path <- fit$efficiency_bc88[idx_f1][order(g1_unbal$year[g1_unbal$firm == "F1"])] + if (fit$eta > 0) { + expect_true(all(diff(eff_path) > 0)) + } else if (fit$eta < 0) { + expect_true(all(diff(eff_path) < 0)) + } +}) + +test_that("panel estimator argument works like the cross-sectional one", { + g1 <- .panel_test_group()$data + + fit_def <- metafrontier:::.fit_sfa_panel_group( + .panel_formula(), g1, "hnormal", "bc92", .panel_info(), list() + ) + fit_jlms <- metafrontier:::.fit_sfa_panel_group( + .panel_formula(), g1, "hnormal", "bc92", .panel_info(), list(), + estimator = "jlms" + ) + + expect_identical(fit_def$estimator, "bc88") + expect_identical(fit_def$efficiency, fit_def$efficiency_bc88) + expect_identical(fit_jlms$estimator, "jlms") + expect_identical(fit_jlms$efficiency, fit_jlms$efficiency_jlms) + expect_true(all(fit_def$efficiency_bc88 > 0 & fit_def$efficiency_bc88 <= 1)) + expect_gt(cor(fit_def$efficiency_bc88, fit_def$efficiency_jlms), 0.99) +}) diff --git a/tests/testthat/test-plots-interop.R b/tests/testthat/test-plots-interop.R new file mode 100644 index 0000000..d0ed827 --- /dev/null +++ b/tests/testthat/test-plots-interop.R @@ -0,0 +1,111 @@ +# Tests for revised plots (Figures 4 and 5) and model interoperability + +# ---------- Plot revisions ---------- + +test_that("autoplot.boot_tgr distribution shows CI bounds as vlines", { + skip_if_not_installed("ggplot2") + + sim <- simulate_metafrontier(n_groups = 2, n_per_group = 40, seed = 42) + fit <- metafrontier(log_y ~ log_x1 + log_x2, data = sim$data, + group = "group") + boot <- boot_tgr(fit, R = 20, seed = 1, progress = FALSE) + + p <- ggplot2::autoplot(boot, which = "distribution") + expect_s3_class(p, "gg") + + is_vline <- vapply(p$layers, function(l) inherits(l$geom, "GeomVline"), + logical(1)) + expect_true(any(is_vline)) + + # One dashed line per group and per CI bound + vline_data <- ggplot2::layer_data(p, which(is_vline)[1]) + expect_equal(nrow(vline_data), 2L * length(boot$groups)) +}) + +test_that("autoplot.malmquist_meta mpi_trend plots at end periods", { + skip_if_not_installed("ggplot2") + + psim <- simulate_panel_metafrontier(n_groups = 2, n_firms_per_group = 15, + n_periods = 3, seed = 7) + malm <- suppressWarnings(suppressMessages( + malmquist_meta(log_y ~ log_x1 + log_x2, data = psim$data, + group = "group", time = "year", method = "dea") + )) + + p <- ggplot2::autoplot(malm, which = "mpi_trend") + expect_s3_class(p, "gg") + + built <- ggplot2::ggplot_build(p) + xvals <- sort(unique(unlist(lapply(built$data[1:2], + function(d) d$x)))) + expect_equal(as.numeric(xvals), 2:3) + expect_match(p$labels$x, "change from previous period") +}) + +# ---------- as_metafrontier_model interoperability ---------- + +test_that("as_metafrontier_model is idempotent and feeds metafrontier()", { + mk_group <- function(dat) { + X <- model.matrix(~ log_x1 + log_x2, dat) + ols <- lm.fit(X, dat$log_y) + res <- ols$residuals + list(coefficients = ols$coefficients, + efficiency = exp(res - max(res)), + X = X, y = dat$log_y) + } + grps <- levels(test_data$group) + conv1 <- as_metafrontier_model(mk_group(test_data[test_data$group == + grps[1], ])) + conv2 <- as_metafrontier_model(mk_group(test_data[test_data$group == + grps[2], ])) + + expect_s3_class(conv1, "metafrontier_model") + # Converting twice is a no-op + expect_identical(as_metafrontier_model(conv1), conv1) + + fit <- metafrontier(models = list(A = conv1, B = conv2)) + expect_s3_class(fit, "metafrontier") + expect_equal(fit$groups, c("A", "B")) +}) + +test_that("frontier::sfa objects pass directly through metafrontier(models=)", { + skip_if_not_installed("frontier") + + grps <- levels(test_data$group) + fits <- lapply(grps, function(g) { + suppressWarnings( + frontier::sfa(log_y ~ log_x1 + log_x2, + data = test_data[test_data$group == g, ]) + ) + }) + names(fits) <- grps + + expect_s3_class(fits[[1]], "frontier") + + fit <- metafrontier(models = fits) + expect_s3_class(fit, "metafrontier") + expect_equal(unname(fit$nobs["total"]), nrow(test_data)) + expect_true(all(fit$tgr > 0 & fit$tgr <= 1)) +}) + +test_that("Farrell objects warn on conversion and error in metafrontier()", { + skip_if_not_installed("Benchmarking") + + X <- exp(as.matrix(test_data[, c("log_x1", "log_x2")])) + y <- matrix(exp(test_data$log_y), ncol = 1) + d <- Benchmarking::dea(X, y, RTS = "vrs") + + expect_warning(as_metafrontier_model(d), "cannot be used") + + expect_error( + suppressWarnings(metafrontier(models = list(A = d, B = d))), + "does not provide" + ) +}) + +test_that("unsupported classes get an informative error", { + expect_error( + as_metafrontier_model(structure(1, class = "no_such_model")), + "sfacross.*frontier.*Farrell" + ) +}) diff --git a/tests/testthat/test-poolability-dea.R b/tests/testthat/test-poolability-dea.R new file mode 100644 index 0000000..ef00aec --- /dev/null +++ b/tests/testthat/test-poolability-dea.R @@ -0,0 +1,110 @@ +# Test the DEA permutation poolability test and the data.name fix + +test_that("permutation test rejects poolability when groups differ", { + skip_on_cran() + + sim <- simulate_metafrontier(n_groups = 2, n_per_group = 60, + tech_gap = c(0, 0.6), seed = 1) + fit_dea <- metafrontier(log_y ~ log_x1 + log_x2, + data = sim$data, group = "group", + method = "dea", rts = "vrs") + + pt <- poolability_test(fit_dea, B = 99, seed = 123) + + expect_lt(pt$p.value, 0.05) +}) + + +test_that("permutation test does not reject under a pooled technology", { + skip_on_cran() + + # Sanity check under H0 with a fixed seed, not a power study + sim <- simulate_metafrontier(n_groups = 2, n_per_group = 60, + tech_gap = c(0, 0), seed = 2) + fit_dea <- metafrontier(log_y ~ log_x1 + log_x2, + data = sim$data, group = "group", + method = "dea", rts = "vrs") + + pt <- poolability_test(fit_dea, B = 99, seed = 123) + + expect_gt(pt$p.value, 0.05) +}) + + +test_that("permutation test returns a well-formed htest object", { + sim <- simulate_metafrontier(n_groups = 2, n_per_group = 25, + tech_gap = c(0, 0.4), seed = 7) + fit_dea <- metafrontier(log_y ~ log_x1 + log_x2, + data = sim$data, group = "group", + method = "dea", rts = "vrs") + + pt <- poolability_test(fit_dea, B = 49, seed = 9) + + expect_s3_class(pt, "htest") + expect_identical( + pt$method, + "Permutation test for poolability of group frontiers (DEA)" + ) + expect_named(pt$parameter, "B") + expect_lte(pt$parameter[["B"]], 49) + expect_named(pt$statistic, "mean technology gap") + expect_equal(pt$statistic[["mean technology gap"]], + mean(1 - fit_dea$tgr, na.rm = TRUE)) + expect_true(pt$p.value > 0 && pt$p.value <= 1) +}) + + +test_that("data.name is the symbol passed for DEA objects", { + sim <- simulate_metafrontier(n_groups = 2, n_per_group = 25, + tech_gap = c(0, 0.4), seed = 7) + fit_dea <- metafrontier(log_y ~ log_x1 + log_x2, + data = sim$data, group = "group", + method = "dea", rts = "vrs") + + pt <- poolability_test(fit_dea, B = 9, seed = 1) + + expect_identical(pt$data.name, "fit_dea") +}) + + +test_that("SFA objects still take the LR branch with fixed data.name", { + sim <- simulate_metafrontier(n_groups = 2, n_per_group = 60, + tech_gap = c(0, 0.4), seed = 5) + fit_sfa <- metafrontier(log_y ~ log_x1 + log_x2, + data = sim$data, group = "group", + method = "sfa") + + pt <- poolability_test(fit_sfa) + + expect_s3_class(pt, "htest") + expect_identical( + pt$method, + "Likelihood Ratio Test for Poolability of Group Frontiers" + ) + expect_named(pt$statistic, "LR") + expect_identical(pt$data.name, "fit_sfa") +}) + + +test_that("permutation test is reproducible with a fixed seed", { + skip_on_cran() + + sim <- simulate_metafrontier(n_groups = 2, n_per_group = 25, + tech_gap = c(0, 0.4), seed = 7) + fit_dea <- metafrontier(log_y ~ log_x1 + log_x2, + data = sim$data, group = "group", + method = "dea", rts = "vrs") + + pt1 <- poolability_test(fit_dea, B = 49, seed = 42) + pt2 <- poolability_test(fit_dea, B = 49, seed = 42) + + expect_identical(pt1$p.value, pt2$p.value) +}) + + +test_that("non-metafrontier objects give an informative error", { + expect_error( + poolability_test(list()), + "SFA- or DEA-based metafrontier" + ) +}) diff --git a/tests/testthat/test-simulate-dgp.R b/tests/testthat/test-simulate-dgp.R new file mode 100644 index 0000000..cd9b6ec --- /dev/null +++ b/tests/testthat/test-simulate-dgp.R @@ -0,0 +1,147 @@ +# DGP extensions: group-specific slopes, input distributions, attrition +# (v0.3.0). Legacy reference values were generated with +# the pre-0.3.0 implementation. + +test_that("simulate_metafrontier reproduces legacy output for seed 42", { + sim <- simulate_metafrontier(seed = 42) + + expect_equal(nrow(sim$data), 200L) + expect_equal(ncol(sim$data), 9L) + expect_equal(sim$data$log_x1[1], 4.574030217481777, tolerance = 1e-12) + expect_equal(sim$data$log_y[1], 3.553174757064474, tolerance = 1e-12) + expect_equal(sim$data$true_te[57], 0.801290099145637, tolerance = 1e-12) + expect_equal(sim$data$log_y[200], 1.470010450855711, tolerance = 1e-12) + expect_equal(sim$data$true_te_star[150], 0.401389206182210, + tolerance = 1e-12) +}) + +test_that("beta_groups with differing slopes gives per-observation TGR in (0, 1]", { + bg <- rbind(c(1.0, 0.5, 0.2), + c(0.9, 0.6, 0.1)) + sim <- simulate_metafrontier(n_groups = 2, n_per_group = 200, + beta_groups = bg, seed = 1) + + expect_true(all(sim$data$true_tgr > 0 & sim$data$true_tgr <= 1)) + + # TGR varies within each group when slopes differ + sds <- tapply(sim$data$true_tgr, sim$data$group, stats::sd) + expect_true(all(sds > 0)) + + # No single log-linear metafrontier: beta_meta is NULL, + # beta_groups is returned + expect_null(sim$params$beta_meta) + expect_equal(sim$params$beta_groups$G1, c(1.0, 0.5, 0.2)) + expect_equal(sim$params$beta_groups$G2, c(0.9, 0.6, 0.1)) + + # Decomposition identity still holds + expect_equal(sim$data$true_te_star, + sim$data$true_te * sim$data$true_tgr, + tolerance = 1e-10) +}) + +test_that("beta_groups replicating the intercept-only design gives exp(-gap)", { + bg <- rbind(c(1.0, 0.5, 0.2), + c(0.75, 0.5, 0.2)) + sim <- simulate_metafrontier(n_groups = 2, n_per_group = 100, + beta_groups = bg, seed = 7) + + tgr1 <- sim$data$true_tgr[sim$data$group == "G1"] + tgr2 <- sim$data$true_tgr[sim$data$group == "G2"] + expect_equal(tgr1, rep(1, 100), tolerance = 1e-10) + expect_equal(tgr2, rep(exp(-0.25), 100), tolerance = 1e-10) +}) + +test_that("beta_groups accepts a list and warns when tech_gap is also given", { + bg_list <- list(c(1.0, 0.5, 0.2), c(0.9, 0.6, 0.1)) + sim <- simulate_metafrontier(n_groups = 2, beta_groups = bg_list, seed = 2) + expect_equal(sim$params$beta_groups$G2, c(0.9, 0.6, 0.1)) + + expect_warning( + simulate_metafrontier(n_groups = 2, beta_groups = bg_list, + tech_gap = c(0, 0.3), seed = 2), + "tech_gap" + ) + expect_error( + simulate_metafrontier(n_groups = 2, + beta_groups = rbind(c(1, 0.5, 0.2)), + seed = 2), + "beta_groups" + ) +}) + +test_that("input_corr induces the target input correlation", { + R <- matrix(c(1, 0.6, + 0.6, 1), nrow = 2) + sim <- simulate_metafrontier(n_groups = 1, n_per_group = 2000, + input_corr = R, seed = 3) + + realised <- stats::cor(sim$data$log_x1, sim$data$log_x2) + expect_lt(abs(realised - 0.6), 0.15) + + # Spread roughly matches the legacy uniform draws + expect_lt(abs(stats::sd(sim$data$log_x1) - 5 / sqrt(12)), 0.15) +}) + +test_that("input_corr is validated", { + not_psd <- matrix(c(1, 2, + 2, 1), nrow = 2) + expect_error(simulate_metafrontier(input_corr = not_psd, seed = 1), + "positive definite") + not_sym <- matrix(c(1, 0.2, + 0.6, 1), nrow = 2) + expect_error(simulate_metafrontier(input_corr = not_sym, seed = 1), + "symmetric") +}) + +test_that("input_means centres per-group log-inputs", { + m <- rbind(c(1, 2), + c(3, 4)) + sim <- simulate_metafrontier(n_groups = 2, n_per_group = 500, + input_means = m, seed = 4) + + for (g in 1:2) { + d <- sim$data[sim$data$group == paste0("G", g), ] + expect_lt(abs(mean(d$log_x1) - m[g, 1]), 0.15) + expect_lt(abs(mean(d$log_x2) - m[g, 2]), 0.15) + } + + expect_error(simulate_metafrontier(n_groups = 2, + input_means = rbind(c(1, 2)), + seed = 4), + "input_means") +}) + +test_that("attrition = 0 reproduces the legacy balanced panel", { + sim <- simulate_panel_metafrontier(seed = 99) + + expect_equal(nrow(sim$data), 300L) + expect_equal(sim$data$log_y[1], 2.103142882313839, tolerance = 1e-12) + expect_equal(sim$data$log_y[300], 0.928893291616277, tolerance = 1e-12) + expect_equal(sim$data$true_tgr[250], 0.606530659712633, tolerance = 1e-12) + + sim0 <- simulate_panel_metafrontier(seed = 99, attrition = 0) + expect_identical(sim$data, sim0$data) + expect_equal(sim0$params$attrition_share, 0) +}) + +test_that("attrition yields an unbalanced panel with all firms in period 1", { + sim <- simulate_panel_metafrontier(seed = 123, attrition = 0.3) + d <- sim$data + n_firms <- 2 * 30 + + expect_lt(nrow(d), 300) + expect_equal(length(unique(d$firm)), n_firms) + expect_equal(sum(d$year == 1), n_firms) + + # Unbalanced: firms have differing numbers of periods + periods_per_firm <- table(d$firm) + expect_gt(length(unique(as.integer(periods_per_firm))), 1L) + + # Realised share stored and consistent with the rows dropped + expect_equal(sim$params$attrition_share, + (300 - nrow(d)) / (300 - n_firms)) + expect_gt(sim$params$attrition_share, 0) + + expect_error(simulate_panel_metafrontier(seed = 1, attrition = 0.9), + "attrition") +}) diff --git a/vignettes/introduction.Rmd b/vignettes/introduction.Rmd index ea1b0e4..71a8baf 100644 --- a/vignettes/introduction.Rmd +++ b/vignettes/introduction.Rmd @@ -19,16 +19,26 @@ knitr::opts_chunk$set( ## What is a metafrontier? In efficiency analysis, we often study firms that operate under -fundamentally different technologies. Steel producers using electric arc -furnaces (EAF) face a different production possibility set than those using -the blast furnace-basic oxygen furnace (BF-BOF) route. Hospitals in rural -areas face different constraints than urban ones. Banks in developing -economies operate under different regulatory and technological environments -than those in advanced economies. +different production environments. Steel producers using electric arc +furnaces (EAF) face a different feasible set of input-output combinations +than those using the blast furnace-basic oxygen furnace (BF-BOF) route. +Hospitals in rural areas face different constraints than urban ones. +Banks face different regulatory environments across jurisdictions. + +Following Battese, Rao, and O'Donnell (2004) and O'Donnell, Rao, and +Battese (2008), we conceive of a single industry **metatechnology** +$T^*$: the set of all input-output combinations that are technically +feasible in the industry. Each group of firms operates within a +**restricted subset** $T_j \subseteq T^*$ of this metatechnology, where +the restrictions arise from regulation, the physical environment, +resource endowments, or the cost of switching production systems. Groups +do not possess fundamentally different technologies; they face different +restrictions of a common metatechnology. Standard stochastic frontier analysis (SFA) or data envelopment analysis -(DEA) applied to the pooled sample implicitly assumes all firms share the -same technology -- an assumption that may be unrealistic. Estimating +(DEA) applied to the pooled sample implicitly assumes that all firms +have unrestricted access to the same technology set, an assumption +that may be unrealistic. Estimating separate frontiers for each group solves this problem but makes efficiency scores incomparable across groups: a firm that is 90\% efficient relative to a less advanced group frontier may actually be less productive than a @@ -111,10 +121,15 @@ The deterministic metafrontier is estimated in two stages: 1. **Stage 1**: Fit separate SFA models for each group via maximum likelihood. 2. **Stage 2**: Find metafrontier coefficients $\hat\beta^*$ by minimising - $$\sum_i \left[\ln f(x_i; \hat\beta^*) - \ln f(x_i; \hat\beta_j)\right]^2$$ + $$\sum_i \left|\ln f(x_i; \hat\beta^*) - \ln f(x_i; \hat\beta_j)\right|$$ subject to the constraint that the metafrontier envelops all group frontiers: $\ln f(x_i; \hat\beta^*) \ge \ln f(x_i; \hat\beta_j)$ for - all $i$ and $j$. + all $i$ and $j$. Since the envelopment constraints force the + deviations to be non-negative, this reduces to a linear programme + (`objective = "lp"`, the default). The alternative minimum sum of + squared deviations criterion is available via `objective = "qp"`; + both criteria are proposed by Battese, Rao, and O'Donnell (2004), + and the `methods` vignette discusses them in detail. This is the default method: @@ -198,6 +213,16 @@ te_star <- efficiencies(fit_det, type = "meta") all.equal(te_star, te * tgr) ``` +For SFA fits, technical efficiencies are computed with the Battese and +Coelli (1988) conditional expectation estimator by default +(`estimator = "bc88"`). The Jondrow et al. (1982) estimator is computed +and stored alongside it, so you can switch without refitting: + +```{r efficiencies-jlms} +te_jlms <- efficiencies(fit_det, type = "group", estimator = "jlms") +cor(te, te_jlms) +``` + ### Technology gap ratio The `technology_gap_ratio()` function returns TGR values grouped by @@ -277,9 +302,24 @@ statistically different from a single pooled frontier: poolability_test(fit_det) ``` -A significant result (small p-value) indicates that the technology groups -have genuinely different production technologies, justifying the -metafrontier approach. +A significant result (small p-value) indicates that the group frontiers +genuinely differ, that is, the groups face different restrictions of the +common metatechnology, justifying the metafrontier approach. + +### Convergence diagnostics + +Every estimation stage of a metafrontier fit can be inspected with +`check_convergence()`, which returns one row per stage (each group +frontier and the metafrontier itself) with the estimation method, the +optimiser's convergence code, and a logical convergence indicator: + +```{r convergence} +check_convergence(fit_det) +``` + +The `summary()` method also prints a convergence block, so estimation +problems are flagged even if you never call `check_convergence()` +directly. ## Inefficiency distributions @@ -455,6 +495,10 @@ head(data.frame( ## References +- Battese, G.E. and Coelli, T.J. (1988). Prediction of firm-level + technical efficiencies with a generalized frontier production function + and panel data. *Journal of Econometrics*, 38(3), 387--399. + - Battese, G.E., Rao, D.S.P. and O'Donnell, C.J. (2004). A metafrontier production function for estimation of technical efficiencies and technology gaps for firms operating under different technologies. @@ -464,6 +508,10 @@ head(data.frame( estimating the metafrontier production function based on a stochastic frontier framework. *Journal of Productivity Analysis*, 42(3), 241--254. +- Jondrow, J., Lovell, C.A.K., Materov, I.S. and Schmidt, P. (1982). On + the estimation of technical inefficiency in the stochastic frontier + production function model. *Journal of Econometrics*, 19(2--3), 233--238. + - O'Donnell, C.J., Rao, D.S.P. and Battese, G.E. (2008). Metafrontier frameworks for the study of firm-level efficiencies and technology ratios. *Empirical Economics*, 34(2), 231--255. diff --git a/vignettes/malmquist.Rmd b/vignettes/malmquist.Rmd index 4bd6306..f25678a 100644 --- a/vignettes/malmquist.Rmd +++ b/vignettes/malmquist.Rmd @@ -24,9 +24,10 @@ library(metafrontier) Standard Malmquist productivity indices measure productivity change over time by decomposing it into efficiency change and technical change. When -firms operate under different technologies, however, this decomposition -misses an important dimension: changes in the *technology gap* between a -group's frontier and the global best practice. +groups of firms face different restrictions of a common metatechnology, +however, this decomposition misses an important dimension: changes in +the *technology gap* between a group's frontier and the global best +practice. The **metafrontier Malmquist TFP index** of O'Donnell, Rao, and Battese (2008) extends the standard index with a three-way decomposition that @@ -97,6 +98,7 @@ malm <- malmquist_meta( data = panel_data, group = "group", time = "time", + id = "id", orientation = "output", rts = "crs" ) @@ -104,6 +106,10 @@ malm <- malmquist_meta( malm ``` +The `id` argument identifies firms across periods. Firms not observed +in both periods of a consecutive pair are dropped from that comparison, +and `malmquist_meta()` warns about how many observations were dropped. + ## Detailed results @@ -190,6 +196,7 @@ malm_vrs <- malmquist_meta( data = panel_data, group = "group", time = "time", + id = "id", rts = "vrs" ) @@ -218,13 +225,16 @@ malm_us <- malmquist_meta( data = Produc, group = "region", time = "year", + id = "state", rts = "crs" ) summary(malm_us) ``` Similarly, `sfaR::utility` provides electric utility data with a binary -`regu` variable (regulated vs. deregulated) over 1986--1996: +`regu` variable (retail-access vs. traditionally regulated states) over +1986--1996, where `regu = 1` indicates that the state had enacted +retail-access (restructuring) legislation: ```{r utility-example, eval = FALSE} library(sfaR) @@ -235,14 +245,59 @@ malm_util <- malmquist_meta( data = utility, group = "regu", time = "year", + id = "firm", rts = "vrs" ) summary(malm_util) ``` +## Caveats + +A few limitations should be kept in mind when interpreting the results. + +### Interpretation of the index + +The Malmquist index, and by extension its metafrontier version, is not +a proper index in the sense of O'Donnell (2012): it is not +multiplicatively complete, and its binary comparisons are not +transitive, so chained comparisons across several periods depend on the +path taken. Interpretation should therefore be confined to binary +period-to-period comparisons; avoid cumulating the indices into a +multi-period productivity level series. + +### Cross-period infeasibility + +Under `rts = "vrs"`, `"drs"`, `"irs"`, or `"fdh"`, the cross-period +distance functions (evaluating a period-$t$ observation against the +period-$s$ frontier) may have no feasible solution. Infeasible cases +are returned as `NA` (never `Inf`), counted, and reported, so summary +statistics over the remaining observations should be read with the +reduced sample in mind. Under `rts = "crs"` the programmes are always +feasible. + +### Firm matching + +Observations are matched across consecutive periods via the `id` +variable. Firms observed in only one period of a pair are dropped from +that comparison, and `malmquist_meta()` warns about the number of +dropped observations. With substantial attrition or entry, the index is +computed on the surviving matched sample only. + +### SFA-based index + +With `method = "sfa"`, the metafrontier at each period is formed as the +pointwise maximum of the fitted group frontiers, an approximation that +the function announces with a message. For exact decompositions, prefer +the default `method = "dea"`. + + ## References +- O'Donnell, C.J. (2012). An aggregate quantity framework for measuring + and decomposing productivity change. *Journal of Productivity + Analysis*, 38(3), 255--272. + - O'Donnell, C.J., Rao, D.S.P. and Battese, G.E. (2008). Metafrontier frameworks for the study of firm-level efficiencies and technology ratios. *Empirical Economics*, 34(2), 231--255. diff --git a/vignettes/methods.Rmd b/vignettes/methods.Rmd index 6d716ba..2f45be4 100644 --- a/vignettes/methods.Rmd +++ b/vignettes/methods.Rmd @@ -43,7 +43,12 @@ The group-specific technical efficiency is: $$TE_{ij} = \exp(-u_{ij}) \in (0, 1]$$ -estimated via the Jondrow et al. (1982) conditional mean estimator. +estimated by default via the Battese and Coelli (1988) conditional +expectation estimator $E[\exp(-u_{ij}) \mid \varepsilon_{ij}]$ +(`estimator = "bc88"`). The Jondrow et al. (1982) estimator +$\exp(-E[u_{ij} \mid \varepsilon_{ij}])$ is also computed and stored, and +`efficiencies(fit, estimator = "jlms")` switches between the two without +refitting. ### 1.2 The metafrontier @@ -53,9 +58,14 @@ that: $$x'\beta^* \ge x'\beta_j \quad \text{for all } x \text{ and all } j$$ -That is, the metafrontier weakly dominates all group frontiers. It -represents the production technology available to firms with unrestricted -access to all technologies. +That is, the metafrontier weakly dominates all group frontiers. It is +the boundary of the industry **metatechnology** $T^*$: the set of all +input-output combinations that are technically feasible in the industry +(Battese, Rao and O'Donnell, 2004; O'Donnell, Rao and Battese, 2008). +Each group frontier bounds a restricted subset $T_j \subseteq T^*$ of +this metatechnology, where the restrictions reflect regulation, the +physical environment, resource endowments, or the cost of switching +production systems. ### 1.3 The efficiency decomposition @@ -76,15 +86,36 @@ that input mix; values below 1 indicate a technology gap. ### 2.1 Estimation -After obtaining group estimates $\hat\beta_j$ in Stage 1, the metafrontier -parameters $\hat\beta^*$ are estimated by solving: +After obtaining group estimates $\hat\beta_j$ in Stage 1, the +metafrontier parameters $\hat\beta^*$ are chosen so that the metafrontier +lies as close as possible to the group frontiers while enveloping all of +them. Battese, Rao and O'Donnell (2004) propose two optimisation +criteria, both implemented in the package via the `objective` argument. -$$\min_{\beta^*} \sum_{j=1}^{J} \sum_{i=1}^{n_j} \left(x_{ij}'\beta^* - x_{ij}'\hat\beta_j\right)^2$$ +**Minimum sum of absolute deviations** (`objective = "lp"`, the default): + +$$\min_{\beta^*} \sum_{j=1}^{J} \sum_{i=1}^{n_j} \left|x_{ij}'\beta^* - x_{ij}'\hat\beta_j\right|$$ $$\text{subject to: } x_{ij}'\beta^* \ge x_{ij}'\hat\beta_j \quad \forall\, i, j$$ -This is a convex quadratic program. The `metafrontier` package solves it -using `constrOptim()` from base R, which implements an adaptive barrier -algorithm for linearly constrained optimisation. +Because the envelopment constraints force every deviation to be +non-negative, the absolute values can be dropped and the problem reduces +to a linear programme (O'Donnell, Rao and Battese, 2008, Eqs. 23-25). +This LP is the primary presentation in O'Donnell, Rao and Battese (2008) +and is the package default; it is solved with `lpSolveAPI`. + +**Minimum sum of squared deviations** (`objective = "qp"`): + +$$\min_{\beta^*} \sum_{j=1}^{J} \sum_{i=1}^{n_j} \left(x_{ij}'\beta^* - x_{ij}'\hat\beta_j\right)^2$$ + +subject to the same envelopment constraints. This is a convex quadratic +programme, solved exactly with `quadprog` when that package is +available, with an adaptive-barrier fallback via `constrOptim()` from +base R otherwise. + +The two criteria weight deviations differently (the squared criterion +penalises large gaps between the metafrontier and a group frontier more +heavily), but in practice they typically produce very similar +coefficients. ### 2.2 Properties @@ -129,6 +160,25 @@ group_b0 <- sapply(coef(fit_det, which = "group"), `[`, 1) meta_b0 >= group_b0 ``` +To use the minimum sum of squared deviations criterion instead, set +`objective = "qp"`: + +```{r det-qp} +fit_qp <- metafrontier( + log_y ~ log_x1 + log_x2, + data = sim$data, + group = "group", + meta_type = "deterministic", + objective = "qp" +) + +# LP and QP criteria typically give very similar coefficients +cbind( + LP = coef(fit_det, which = "meta"), + QP = coef(fit_qp, which = "meta") +) +``` + ## 3. Stochastic metafrontier (Huang, Huang, and Liu, 2014) @@ -349,8 +399,9 @@ on the pooled sample and $LL_j$ are the group-specific log-likelihoods. poolability_test(fit_det) ``` -A significant test (p < 0.05) confirms that the groups operate under -different technologies and the metafrontier decomposition is warranted. +A significant test (p < 0.05) confirms that the group frontiers differ, +that is, the groups face different restrictions of the common +metatechnology, and the metafrontier decomposition is warranted. ## 8. Simulation for Monte Carlo studies @@ -397,6 +448,10 @@ The `simulate_metafrontier()` function supports: ## References +- Battese, G.E. and Coelli, T.J. (1988). Prediction of firm-level + technical efficiencies with a generalized frontier production function + and panel data. *Journal of Econometrics*, 38(3), 387--399. + - Battese, G.E., Rao, D.S.P. and O'Donnell, C.J. (2004). A metafrontier production function for estimation of technical efficiencies and technology gaps for firms operating under different technologies.