From da0a8c8bacbbf8b888922c97d34315db8c49bc85 Mon Sep 17 00:00:00 2001 From: Mauricio 'Pacha' Vargas Sepulveda Date: Tue, 16 Jul 2024 19:16:16 -0400 Subject: [PATCH 01/16] initial step halving refactor --- R/cpp11.R | 8 +++ R/fenegbin.R | 1 + R/internals.R | 9 ++- src/04_linear_algebra.cpp | 99 +++++++++++++++++++++++++++++++++ src/cpp11.cpp | 16 ++++++ tests/testthat/test-apes-bias.R | 2 +- tests/testthat/test-errors.R | 2 +- tests/testthat/test-feglm.R | 71 +++++++++++++++++++++++ tests/testthat/test-felm.R | 2 +- tests/testthat/test-fepoisson.R | 4 ++ 10 files changed, 209 insertions(+), 5 deletions(-) create mode 100644 tests/testthat/test-feglm.R diff --git a/R/cpp11.R b/R/cpp11.R index 8bf0895..827df57 100644 --- a/R/cpp11.R +++ b/R/cpp11.R @@ -72,6 +72,14 @@ solve_eta2_ <- function(yadj, myadj, offset, eta) { .Call(`_capybara_solve_eta2_`, yadj, myadj, offset, eta) } +linkinv_ <- function(eta_r, family) { + .Call(`_capybara_linkinv_`, eta_r, family) +} + +dev_resids_ <- function(y_r, mu_r, theta, wt_r, family) { + .Call(`_capybara_dev_resids_`, y_r, mu_r, theta, wt_r, family) +} + kendall_cor_ <- function(m) { .Call(`_capybara_kendall_cor_`, m) } diff --git a/R/fenegbin.R b/R/fenegbin.R index 3211a96..f7726eb 100644 --- a/R/fenegbin.R +++ b/R/fenegbin.R @@ -131,6 +131,7 @@ fenegbin <- function( dev.old <- dev theta.old <- theta family <- negative.binomial(theta, link) + family$theta <- theta fit <- feglm_fit_(beta, eta, y, X, wt, k.list, family, control) beta <- fit[["coefficients"]] eta <- fit[["eta"]] diff --git a/R/internals.R b/R/internals.R index 68279b5..9d2098c 100644 --- a/R/internals.R +++ b/R/internals.R @@ -94,8 +94,13 @@ feglm_fit_ <- function(beta, eta, y, X, wt, k.list, family, control) { # beta <- beta.old + rho * beta.upd eta <- update_beta_eta_(eta.old, eta.upd, rho) beta <- update_beta_eta_(beta.old, beta.upd, rho) - mu <- family[["linkinv"]](eta) - dev <- sum(family[["dev.resids"]](y, mu, wt)) + # mu <- family[["linkinv"]](eta) + mu <- linkinv_(eta, family$family) + # dev <- sum(family[["dev.resids"]](y, mu, wt)) + if (is.integer(y)) { y <- as.double(y) } + dev <- dev_resids_(y, mu, + ifelse(is.null(family$theta), 0.0, family$theta), + wt, family$family) dev.crit <- is.finite(dev) val.crit <- family[["valideta"]](eta) && family[["validmu"]](mu) imp.crit <- (dev - dev.old) / (0.1 + abs(dev)) <= -dev.tol diff --git a/src/04_linear_algebra.cpp b/src/04_linear_algebra.cpp index 07d1619..f3d368d 100644 --- a/src/04_linear_algebra.cpp +++ b/src/04_linear_algebra.cpp @@ -193,3 +193,102 @@ update_beta_eta_(const doubles &old, const doubles &upd, const double ¶m) { return as_doubles(Yadj - Myadj + Offset - Eta); } + +std::string tidy_family(const std::string &family) { + // tidy family param + std::string fam = family; + + // 1. put all in lowercase + std::transform(fam.begin(), fam.end(), fam.begin(), + [](unsigned char c) { return std::tolower(c); }); + + // 2. remove numbers + fam.erase(std::remove_if(fam.begin(), fam.end(), ::isdigit), fam.end()); + + // 3. remove parentheses and everything inside + size_t pos = fam.find("("); + if (pos != std::string::npos) { + fam.erase(pos, fam.size()); + } + + // 4. replace spaces and dots + std::replace(fam.begin(), fam.end(), ' ', '_'); + std::replace(fam.begin(), fam.end(), '.', '_'); + + // 5. trim + fam.erase(std::remove_if(fam.begin(), fam.end(), ::isspace), fam.end()); + + return fam; +} + +[[cpp11::register]] doubles linkinv_(const doubles &eta_r, + const std::string &family) { + Col eta = as_Col(eta_r); + Col res(eta.n_elem); + + std::string fam = tidy_family(family); + + if (fam == "gaussian") { + res = eta; + } else if (fam == "poisson") { + res = exp(eta); + } else if (fam == "binomial") { + // res = exp(eta) / (1.0 + exp(eta)); + res = 1.0 / (1.0 + exp(-eta)); + } else if (fam == "gamma") { + res = 1.0 / eta; + } else if (fam == "inverse_gaussian") { + res = 1.0 / sqrt(eta); + } else if (fam == "negative_binomial") { + res = exp(eta); + } else { + stop("Unknown family"); + } + + return as_doubles(res); +} + +[[cpp11::register]] double dev_resids_(const doubles &y_r, const doubles &mu_r, + const double &theta, const doubles &wt_r, + const std::string &family) { + Col y = as_Col(y_r); + Col mu = as_Col(mu_r); + Col wt = as_Col(wt_r); + double res; + + std::string fam = tidy_family(family); + + if (fam == "gaussian") { + res = accu(wt % square(y - mu)); + } else if (fam == "poisson") { + uvec p = find(y > 0.0); + Col r = mu % wt; + r(p) = y(p) % log(y(p) / mu(p)) - (y(p) - mu(p)); + res = 2.0 * accu(r); + } else if (fam == "binomial") { + uvec p = find(y != 0.0); + uvec q = find(y != 1.0); + Col r = y / mu; + Col s = (1.0 - y) / (1.0 - mu); + r(p) = log(r(p)); + s(q) = log(s(q)); + res = 2.0 * accu(wt % (y % r + (1.0 - y) % s)); + } else if (fam == "gamma") { + uvec p = find(y == 0.0); + Col r = y / mu; + r.elem(p).fill(1.0); + res = -2.0 * accu(wt % (log(r) - (y - mu) / mu)); + } else if (fam == "inverse_gaussian") { + res = accu(wt % square(y - mu) / (y % square(mu))); + } else if (fam == "negative_binomial") { + uvec p = find(y < 1.0); + Col r = y; + r.elem(p).fill(1.0); + res = 2.0 * accu( + wt % (y % log(r / mu) - (y + theta) % log((y + theta) / (mu + theta)))); + } else { + stop("Unknown family"); + } + + return res; +} diff --git a/src/cpp11.cpp b/src/cpp11.cpp index 2c74811..f91b505 100644 --- a/src/cpp11.cpp +++ b/src/cpp11.cpp @@ -131,6 +131,20 @@ extern "C" SEXP _capybara_solve_eta2_(SEXP yadj, SEXP myadj, SEXP offset, SEXP e return cpp11::as_sexp(solve_eta2_(cpp11::as_cpp>(yadj), cpp11::as_cpp &>>(myadj), cpp11::as_cpp>(offset), cpp11::as_cpp>(eta))); END_CPP11 } +// 04_linear_algebra.cpp +doubles linkinv_(const doubles & eta_r, const std::string & family); +extern "C" SEXP _capybara_linkinv_(SEXP eta_r, SEXP family) { + BEGIN_CPP11 + return cpp11::as_sexp(linkinv_(cpp11::as_cpp>(eta_r), cpp11::as_cpp>(family))); + END_CPP11 +} +// 04_linear_algebra.cpp +double dev_resids_(const doubles & y_r, const doubles & mu_r, const double & theta, const doubles & wt_r, const std::string & family); +extern "C" SEXP _capybara_dev_resids_(SEXP y_r, SEXP mu_r, SEXP theta, SEXP wt_r, SEXP family) { + BEGIN_CPP11 + return cpp11::as_sexp(dev_resids_(cpp11::as_cpp>(y_r), cpp11::as_cpp>(mu_r), cpp11::as_cpp>(theta), cpp11::as_cpp>(wt_r), cpp11::as_cpp>(family))); + END_CPP11 +} // 05_kendall_correlation.cpp double kendall_cor_(const doubles_matrix<> & m); extern "C" SEXP _capybara_kendall_cor_(SEXP m) { @@ -150,6 +164,7 @@ extern "C" { static const R_CallMethodDef CallEntries[] = { {"_capybara_center_variables_", (DL_FUNC) &_capybara_center_variables_, 7}, {"_capybara_crossprod_", (DL_FUNC) &_capybara_crossprod_, 4}, + {"_capybara_dev_resids_", (DL_FUNC) &_capybara_dev_resids_, 5}, {"_capybara_gamma_", (DL_FUNC) &_capybara_gamma_, 6}, {"_capybara_get_alpha_", (DL_FUNC) &_capybara_get_alpha_, 3}, {"_capybara_group_sums_", (DL_FUNC) &_capybara_group_sums_, 3}, @@ -158,6 +173,7 @@ static const R_CallMethodDef CallEntries[] = { {"_capybara_group_sums_var_", (DL_FUNC) &_capybara_group_sums_var_, 2}, {"_capybara_inv_", (DL_FUNC) &_capybara_inv_, 1}, {"_capybara_kendall_cor_", (DL_FUNC) &_capybara_kendall_cor_, 1}, + {"_capybara_linkinv_", (DL_FUNC) &_capybara_linkinv_, 2}, {"_capybara_pkendall_", (DL_FUNC) &_capybara_pkendall_, 2}, {"_capybara_rank_", (DL_FUNC) &_capybara_rank_, 1}, {"_capybara_sandwich_", (DL_FUNC) &_capybara_sandwich_, 2}, diff --git a/tests/testthat/test-apes-bias.R b/tests/testthat/test-apes-bias.R index d410c9e..0381d6f 100644 --- a/tests/testthat/test-apes-bias.R +++ b/tests/testthat/test-apes-bias.R @@ -1,4 +1,4 @@ -test_that("apes works", { +test_that("apes/bias works", { trade_short <- trade_panel[trade_panel$year %in% 2002L:2006L, ] trade_short$trade <- ifelse(trade_short$trade > 100, 1L, 0L) diff --git a/tests/testthat/test-errors.R b/tests/testthat/test-errors.R index f404e9e..cbc307b 100644 --- a/tests/testthat/test-errors.R +++ b/tests/testthat/test-errors.R @@ -1,4 +1,4 @@ -test_that("multiplication works", { +test_that("error conditions", { trade_panel_2002 <- trade_panel[trade_panel$year == 2002, ] trade_panel_2002$trade_100 <- ifelse(trade_panel_2002$trade >= 100, 1, 0) trade_panel_2002$trade_200_100 <- as.factor(ifelse(trade_panel_2002$trade >= 200, 1, diff --git a/tests/testthat/test-feglm.R b/tests/testthat/test-feglm.R new file mode 100644 index 0000000..0195876 --- /dev/null +++ b/tests/testthat/test-feglm.R @@ -0,0 +1,71 @@ +test_that("feglm is similar to glm", { + # Gaussian ---- + + # same as felm + + # Binomial ---- + + mod <- feglm( + am ~ wt + mpg| cyl, + mtcars, + family = binomial() + ) + + mod_base <- glm( + am ~ wt + mpg + as.factor(cyl), + mtcars, + family = binomial() + ) + + expect_equal(unname(round(coef(mod) - coef(mod_base)[2:3], 3)), rep(0, 2)) + + fe <- unname(drop(fixed_effects(mod)$cyl)) + fe_base <- coef(mod_base)[c(1, 4, 5)] + fe_base <- unname(fe_base + c(0, rep(fe_base[1], 2))) + + expect_equal(round(fe - fe_base, 2), rep(0, 3)) + + # Gamma ---- + + mod <- feglm( + mpg ~ wt + am | cyl, + mtcars, + family = Gamma() + ) + + mod_base <- glm( + mpg ~ wt + am + as.factor(cyl), + mtcars, + family = Gamma() + ) + + expect_equal(unname(round(coef(mod) - coef(mod_base)[2:3], 3)), rep(0, 2)) + + fe <- unname(drop(fixed_effects(mod)$cyl)) + fe_base <- coef(mod_base)[c(1, 4, 5)] + fe_base <- unname(fe_base + c(0, rep(fe_base[1], 2))) + + expect_equal(round(fe - fe_base, 2), rep(0, 3)) + + # Inverse Gaussian ---- + + mod <- feglm( + mpg ~ wt + am | cyl, + mtcars, + family = inverse.gaussian() + ) + + mod_base <- glm( + mpg ~ wt + am + as.factor(cyl), + mtcars, + family = inverse.gaussian() + ) + + expect_equal(unname(round(coef(mod) - coef(mod_base)[2:3], 3)), rep(0, 2)) + + fe <- unname(drop(fixed_effects(mod)$cyl)) + fe_base <- coef(mod_base)[c(1, 4, 5)] + fe_base <- unname(fe_base + c(0, rep(fe_base[1], 2))) + + expect_equal(round(fe - fe_base, 2), rep(0, 3)) +}) diff --git a/tests/testthat/test-felm.R b/tests/testthat/test-felm.R index 25b1a77..a9ce4c8 100644 --- a/tests/testthat/test-felm.R +++ b/tests/testthat/test-felm.R @@ -2,7 +2,7 @@ test_that("felm works", { m1 <- felm(mpg ~ wt | cyl, mtcars) m2 <- lm(mpg ~ wt + as.factor(cyl), mtcars) - expect_equal(coef(m1), coef(m2)[2]) + expect_equal(round(coef(m1), 5), round(coef(m2)[2], 5)) expect_gt(length(fitted(m1)), 0) expect_gt(length(predict(m1)), 0) expect_gt(length(coef(m1)), 0) diff --git a/tests/testthat/test-fepoisson.R b/tests/testthat/test-fepoisson.R index c4500e7..bd64287 100644 --- a/tests/testthat/test-fepoisson.R +++ b/tests/testthat/test-fepoisson.R @@ -9,6 +9,10 @@ test_that("fepoisson is similar to fixest", { # trade_panel, # cluster = ~pair # ) + + coef_mod_fixest <- c(-0.8409273, 0.2474765, 0.4374432, -0.2224899) + + expect_equal(unname(round(coef(mod) - coef_mod_fixest, 5)), rep(0, 4)) summary_mod <- summary(mod, type = "clustered") From 9719356848aa4c48e05a339f3e6cf944f527c7bf Mon Sep 17 00:00:00 2001 From: Mauricio 'Pacha' Vargas Sepulveda Date: Tue, 16 Jul 2024 19:38:34 -0400 Subject: [PATCH 02/16] continuing step halving refactor --- R/cpp11.R | 8 +++++++ R/internals.R | 2 +- src/04_linear_algebra.cpp | 50 +++++++++++++++++++++++++++++++++++++++ src/cpp11.cpp | 16 +++++++++++++ 4 files changed, 75 insertions(+), 1 deletion(-) diff --git a/R/cpp11.R b/R/cpp11.R index 827df57..b7ce478 100644 --- a/R/cpp11.R +++ b/R/cpp11.R @@ -80,6 +80,14 @@ dev_resids_ <- function(y_r, mu_r, theta, wt_r, family) { .Call(`_capybara_dev_resids_`, y_r, mu_r, theta, wt_r, family) } +valideta_ <- function(eta_r, family) { + .Call(`_capybara_valideta_`, eta_r, family) +} + +validmu_ <- function(mu_r, family) { + .Call(`_capybara_validmu_`, mu_r, family) +} + kendall_cor_ <- function(m) { .Call(`_capybara_kendall_cor_`, m) } diff --git a/R/internals.R b/R/internals.R index 9d2098c..ba463ac 100644 --- a/R/internals.R +++ b/R/internals.R @@ -102,7 +102,7 @@ feglm_fit_ <- function(beta, eta, y, X, wt, k.list, family, control) { ifelse(is.null(family$theta), 0.0, family$theta), wt, family$family) dev.crit <- is.finite(dev) - val.crit <- family[["valideta"]](eta) && family[["validmu"]](mu) + val.crit <- valideta_(eta, family$family) && validmu_(mu, family$family) imp.crit <- (dev - dev.old) / (0.1 + abs(dev)) <= -dev.tol if (dev.crit && val.crit && imp.crit) break rho <- rho * 0.5 diff --git a/src/04_linear_algebra.cpp b/src/04_linear_algebra.cpp index f3d368d..e2fd4aa 100644 --- a/src/04_linear_algebra.cpp +++ b/src/04_linear_algebra.cpp @@ -292,3 +292,53 @@ std::string tidy_family(const std::string &family) { return res; } + +[[cpp11::register]] bool valideta_(const doubles &eta_r, + const std::string &family) { + Col eta = as_Col(eta_r); + std::string fam = tidy_family(family); + bool res; + + if (fam == "gaussian") { + res = true; + } else if (fam == "poisson") { + res = true; + } else if (fam == "binomial") { + res = true; + } else if (fam == "gamma") { + res = is_finite(eta) && all(eta != 0); + } else if (fam == "inverse_gaussian") { + res = is_finite(eta) && all(eta > 0); + } else if (fam == "negative_binomial") { + res = true; + } else { + stop("Unknown family"); + } + + return res; +} + +[[cpp11::register]] bool validmu_(const doubles &mu_r, + const std::string &family) { + Col mu = as_Col(mu_r); + std::string fam = tidy_family(family); + bool res; + + if (fam == "gaussian") { + res = true; + } else if (fam == "poisson") { + res = is_finite(mu) && all(mu > 0); + } else if (fam == "binomial") { + res = is_finite(mu) && all(mu > 0) && all(mu < 1); + } else if (fam == "gamma") { + res = is_finite(mu) && all(mu > 0); + } else if (fam == "inverse_gaussian") { + res = true; + } else if (fam == "negative_binomial") { + return all(mu > 0); + } else { + stop("Unknown family"); + } + + return res; +} diff --git a/src/cpp11.cpp b/src/cpp11.cpp index f91b505..8c975d4 100644 --- a/src/cpp11.cpp +++ b/src/cpp11.cpp @@ -145,6 +145,20 @@ extern "C" SEXP _capybara_dev_resids_(SEXP y_r, SEXP mu_r, SEXP theta, SEXP wt_r return cpp11::as_sexp(dev_resids_(cpp11::as_cpp>(y_r), cpp11::as_cpp>(mu_r), cpp11::as_cpp>(theta), cpp11::as_cpp>(wt_r), cpp11::as_cpp>(family))); END_CPP11 } +// 04_linear_algebra.cpp +bool valideta_(const doubles & eta_r, const std::string & family); +extern "C" SEXP _capybara_valideta_(SEXP eta_r, SEXP family) { + BEGIN_CPP11 + return cpp11::as_sexp(valideta_(cpp11::as_cpp>(eta_r), cpp11::as_cpp>(family))); + END_CPP11 +} +// 04_linear_algebra.cpp +bool validmu_(const doubles & mu_r, const std::string & family); +extern "C" SEXP _capybara_validmu_(SEXP mu_r, SEXP family) { + BEGIN_CPP11 + return cpp11::as_sexp(validmu_(cpp11::as_cpp>(mu_r), cpp11::as_cpp>(family))); + END_CPP11 +} // 05_kendall_correlation.cpp double kendall_cor_(const doubles_matrix<> & m); extern "C" SEXP _capybara_kendall_cor_(SEXP m) { @@ -184,6 +198,8 @@ static const R_CallMethodDef CallEntries[] = { {"_capybara_solve_y_", (DL_FUNC) &_capybara_solve_y_, 2}, {"_capybara_update_beta_eta_", (DL_FUNC) &_capybara_update_beta_eta_, 3}, {"_capybara_update_nu_", (DL_FUNC) &_capybara_update_nu_, 3}, + {"_capybara_valideta_", (DL_FUNC) &_capybara_valideta_, 2}, + {"_capybara_validmu_", (DL_FUNC) &_capybara_validmu_, 2}, {NULL, NULL, 0} }; } From ea9c13dca15ef8b4c2b24167e43f17a749793a4d Mon Sep 17 00:00:00 2001 From: Mauricio 'Pacha' Vargas Sepulveda Date: Wed, 17 Jul 2024 15:13:04 -0400 Subject: [PATCH 03/16] partial refactor to avoid too many R/C++ copies with glm --- R/cpp11.R | 28 +- R/internals.R | 261 +++++++------- src/01_center_variables.cpp | 32 +- src/04_linear_algebra.cpp | 186 +--------- src/05_glm_fit.cpp | 336 ++++++++++++++++++ ...elation.cpp => 06_kendall_correlation.cpp} | 0 src/cpp11.cpp | 96 ++--- 7 files changed, 506 insertions(+), 433 deletions(-) create mode 100644 src/05_glm_fit.cpp rename src/{05_kendall_correlation.cpp => 06_kendall_correlation.cpp} (100%) diff --git a/R/cpp11.R b/R/cpp11.R index b7ce478..466254c 100644 --- a/R/cpp11.R +++ b/R/cpp11.R @@ -1,9 +1,5 @@ # Generated by cpp11: do not edit by hand -center_variables_ <- function(V_r, v_sum_r, w_r, klist, tol, maxiter, sum_v) { - .Call(`_capybara_center_variables_`, V_r, v_sum_r, w_r, klist, tol, maxiter, sum_v) -} - get_alpha_ <- function(p_r, klist, tol) { .Call(`_capybara_get_alpha_`, p_r, klist, tol) } @@ -60,32 +56,12 @@ update_nu_ <- function(y, mu, mu_eta) { .Call(`_capybara_update_nu_`, y, mu, mu_eta) } -solve_beta_ <- function(mx, mnu, wtilde, weighted) { - .Call(`_capybara_solve_beta_`, mx, mnu, wtilde, weighted) -} - -solve_eta_ <- function(mx, mnu, nu, beta) { - .Call(`_capybara_solve_eta_`, mx, mnu, nu, beta) -} - solve_eta2_ <- function(yadj, myadj, offset, eta) { .Call(`_capybara_solve_eta2_`, yadj, myadj, offset, eta) } -linkinv_ <- function(eta_r, family) { - .Call(`_capybara_linkinv_`, eta_r, family) -} - -dev_resids_ <- function(y_r, mu_r, theta, wt_r, family) { - .Call(`_capybara_dev_resids_`, y_r, mu_r, theta, wt_r, family) -} - -valideta_ <- function(eta_r, family) { - .Call(`_capybara_valideta_`, eta_r, family) -} - -validmu_ <- function(mu_r, family) { - .Call(`_capybara_validmu_`, mu_r, family) +feglm_fit_ <- function(beta_r, eta_r, y_r, x_r, nt_r, wt_r, theta, family, control, k_list) { + .Call(`_capybara_feglm_fit_`, beta_r, eta_r, y_r, x_r, nt_r, wt_r, theta, family, control, k_list) } kendall_cor_ <- function(m) { diff --git a/R/internals.R b/R/internals.R index ba463ac..8753256 100644 --- a/R/internals.R +++ b/R/internals.R @@ -13,7 +13,6 @@ check_factor_ <- function(x) { felm_fit_ <- function(y, X, wt, k.list, control) { # Extract control arguments center.tol <- control[["center.tol"]] - epsilon <- max(1.0e-07, .Machine[["double.eps"]]) keep.mx <- control[["keep.mx"]] # Generate temporary variables @@ -41,138 +40,134 @@ felm_fit_ <- function(y, X, wt, k.list, control) { # Fitting algorithm (similar to glm.fit) ---- -feglm_fit_ <- function(beta, eta, y, X, wt, k.list, family, control) { - # Extract control arguments - center.tol <- control[["center.tol"]] - dev.tol <- control[["dev.tol"]] - epsilon <- max(min(1.0e-07, dev.tol / 1000.0), .Machine[["double.eps"]]) - iter.max <- control[["iter.max"]] - trace <- control[["trace"]] - keep.mx <- control[["keep.mx"]] - - # Compute initial quantities for the maximization routine - nt <- length(y) - mu <- family[["linkinv"]](eta) - dev <- sum(family[["dev.resids"]](y, mu, wt)) - null.dev <- sum(family[["dev.resids"]](y, mean(y), wt)) - - # Generate temporary variables - Mnu <- as.matrix(numeric(nt)) - MX <- X - - # Start maximization of the log-likelihood - conv <- FALSE - for (iter in seq.int(iter.max)) { - # Store \eta, \beta, and deviance of the previous iteration - eta.old <- eta - beta.old <- beta - dev.old <- dev - - # Compute weights and dependent variable - mu.eta <- family[["mu.eta"]](eta) - w <- (wt * mu.eta^2) / family[["variance"]](mu) - nu <- (y - mu) / mu.eta - - # Centering variables - Mnu <- center_variables_(Mnu, nu, w, k.list, center.tol, 10000L, TRUE) - MX <- center_variables_(MX, NA_real_, w, k.list, center.tol, 10000L, FALSE) - - # Compute update step and update eta - # beta.upd <- as.vector(qr.solve(MX * w.tilde, Mnu * w.tilde, epsilon)) - # eta.upd <- nu - as.vector(Mnu - MX %*% beta.upd) - beta.upd <- solve_beta_(MX, Mnu, w, TRUE) - eta.upd <- solve_eta_(MX, Mnu, nu, beta.upd) - - # Step-halving with three checks - # 1. finite deviance - # 2. valid \eta and \mu - # 3. improvement as in glm2 - rho <- 1.0 - - for (inner.iter in seq.int(50L)) { - # eta <- eta.old + rho * eta.upd - # beta <- beta.old + rho * beta.upd - eta <- update_beta_eta_(eta.old, eta.upd, rho) - beta <- update_beta_eta_(beta.old, beta.upd, rho) - # mu <- family[["linkinv"]](eta) - mu <- linkinv_(eta, family$family) - # dev <- sum(family[["dev.resids"]](y, mu, wt)) - if (is.integer(y)) { y <- as.double(y) } - dev <- dev_resids_(y, mu, - ifelse(is.null(family$theta), 0.0, family$theta), - wt, family$family) - dev.crit <- is.finite(dev) - val.crit <- valideta_(eta, family$family) && validmu_(mu, family$family) - imp.crit <- (dev - dev.old) / (0.1 + abs(dev)) <= -dev.tol - if (dev.crit && val.crit && imp.crit) break - rho <- rho * 0.5 - } - - # Check if step-halving failed (deviance and invalid \eta or \mu) - if (!dev.crit || !val.crit) { - stop("Inner loop failed; cannot correct step size.", call. = FALSE) - } - - # Stop if we do not improve - if (!imp.crit) { - eta <- eta.old - beta <- beta.old - dev <- dev.old - mu <- family[["linkinv"]](eta) - } - - # Progress information - if (trace) { - cat( - "Deviance=", format(dev, digits = 5L, nsmall = 2L), "Iterations -", - iter, "\n" - ) - cat("Estimates=", format(beta, digits = 3L, nsmall = 2L), "\n") - } - - # Check convergence - dev.crit <- abs(dev - dev.old) / (0.1 + abs(dev)) - if (trace) cat("Stopping criterion=", dev.crit, "\n") - if (dev.crit < dev.tol) { - if (trace) cat("Convergence\n") - conv <- TRUE - break - } - - # Update starting guesses for acceleration - Mnu <- Mnu - nu - } - - # Information if convergence failed - if (!conv && trace) cat("Algorithm did not converge.\n") - - # Update weights and dependent variable - mu.eta <- family[["mu.eta"]](eta) - w <- (wt * mu.eta^2) / family[["variance"]](mu) - - # Center variables - MX <- center_variables_(X, NA_real_, w, k.list, center.tol, 10000L, FALSE) - # Recompute Hessian - H <- crossprod_(MX, w, TRUE, TRUE) - - # Generate result list - reslist <- list( - coefficients = beta, - eta = eta, - weights = wt, - Hessian = H, - deviance = dev, - null.deviance = null.dev, - conv = conv, - iter = iter - ) - - # Update result list - if (keep.mx) reslist[["MX"]] <- MX - - # Return result list - reslist -} +# feglm_fit_ <- function(beta, eta, y, X, wt, k.list, family, control) { +# # Extract control arguments +# center.tol <- control[["center.tol"]] +# dev.tol <- control[["dev.tol"]] +# iter.max <- control[["iter.max"]] +# keep.mx <- control[["keep.mx"]] + +# # Compute initial quantities for the maximization routine +# nt <- length(y) +# mu <- family[["linkinv"]](eta) +# dev <- sum(family[["dev.resids"]](y, mu, wt)) +# null.dev <- sum(family[["dev.resids"]](y, mean(y), wt)) + +# # Generate temporary variables +# Mnu <- as.matrix(numeric(nt)) +# MX <- X + +# # Start maximization of the log-likelihood +# conv <- FALSE +# for (iter in seq.int(iter.max)) { +# # Store \eta, \beta, and deviance of the previous iteration +# eta.old <- eta +# beta.old <- beta +# dev.old <- dev + +# # Compute weights and dependent variable +# mu.eta <- family[["mu.eta"]](eta) +# w <- (wt * mu.eta^2) / family[["variance"]](mu) +# nu <- (y - mu) / mu.eta + +# # Centering variables +# Mnu <- center_variables_(Mnu, nu, w, k.list, center.tol, 10000L, TRUE) +# MX <- center_variables_(MX, NA_real_, w, k.list, center.tol, 10000L, FALSE) + +# # Compute update step and update eta + +# # Step-halving with three checks +# # 1. finite deviance +# # 2. valid \eta and \mu +# # 3. improvement as in glm2 + +# # if (is.integer(y)) y <- as.double(y) +# # theta <- ifelse(is.null(family[["theta"]]), 0.0, family[["theta"]]) +# # sh <- step_halving_( +# # MX, Mnu, nu, w, eta.old, beta.old, y, wt, +# # theta, family[["family"]], dev.old, dev.tol +# # ) + +# # dev <- sh[["dev"]] +# # eta <- sh[["eta"]] +# # beta <- sh[["beta"]] +# # mu <- sh[["mu"]] +# # imp.crit <- sh[["imp.crit"]] +# # sh <- NULL + +# beta.upd <- solve_beta_(MX, Mnu, w, TRUE) +# # print(beta.upd) +# eta.upd <- solve_eta_(MX, Mnu, nu, beta.upd) + +# rho <- 1.0 + +# for (inner.iter in seq.int(50L)) { +# eta <- update_beta_eta_(eta.old, eta.upd, rho) +# beta <- update_beta_eta_(beta.old, beta.upd, rho) +# mu <- family[["linkinv"]](eta) +# dev <- sum(family[["dev.resids"]](y, mu, wt)) +# dev.crit <- is.finite(dev) +# val.crit <- family[["valideta"]](eta) && family[["validmu"]](mu) +# imp.crit <- (dev - dev.old) / (0.1 + abs(dev)) <= -dev.tol +# # print(c(dev.crit, val.crit, imp.crit)) +# if (dev.crit && val.crit && imp.crit) break +# rho <- rho * 0.5 +# } + +# # Check if step-halving failed (deviance and invalid \eta or \mu) +# if (!dev.crit || !val.crit) { +# stop("Inner loop failed; cannot correct step size.", call. = FALSE) +# } + +# # Stop if we do not improve +# if (!imp.crit) { +# eta <- eta.old +# beta <- beta.old +# dev <- dev.old +# mu <- family[["linkinv"]](eta) +# } + +# # Check convergence +# dev.crit <- abs(dev - dev.old) / (0.1 + abs(dev)) +# if (dev.crit < dev.tol) { +# conv <- TRUE +# break +# } + +# # Update starting guesses for acceleration +# Mnu <- Mnu - nu +# } + +# # Information if convergence failed +# if (!conv) cat("Algorithm did not converge.\n") + +# # Update weights and dependent variable +# mu.eta <- family[["mu.eta"]](eta) +# w <- (wt * mu.eta^2) / family[["variance"]](mu) + +# # Center variables +# MX <- center_variables_(X, NA_real_, w, k.list, center.tol, 10000L, FALSE) +# # Recompute Hessian +# H <- crossprod_(MX, w, TRUE, TRUE) + +# # Generate result list +# reslist <- list( +# coefficients = beta, +# eta = eta, +# weights = wt, +# Hessian = H, +# deviance = dev, +# null.deviance = null.dev, +# conv = conv, +# iter = iter +# ) + +# # Update result list +# if (keep.mx) reslist[["MX"]] <- MX + +# # Return result list +# reslist +# } # Efficient offset algorithm to update the linear predictor ---- diff --git a/src/01_center_variables.cpp b/src/01_center_variables.cpp index 66250d1..21d63ad 100644 --- a/src/01_center_variables.cpp +++ b/src/01_center_variables.cpp @@ -1,20 +1,9 @@ #include "00_main.h" // Method of alternating projections (Halperin) -[[cpp11::register]] doubles_matrix<> -center_variables_(const doubles_matrix<> &V_r, const doubles &v_sum_r, - const doubles &w_r, const list &klist, const double &tol, - const int &maxiter, const bool &sum_v) { - // Type conversion - Mat V = as_Mat(V_r); - Mat w = as_Mat(w_r); - - if (sum_v) { - Mat v_sum = as_Mat(v_sum_r); - V.each_col() += v_sum; - v_sum.reset(); - } - +Mat center_variables_(const Mat &V, const Col &w, + const list &klist, const double &tol, + const int &maxiter) { // Auxiliary variables (fixed) const int N = V.n_rows; const int P = V.n_cols; @@ -24,6 +13,7 @@ center_variables_(const doubles_matrix<> &V_r, const doubles &v_sum_r, // Auxiliary variables (storage) int iter, j, k, p, J; double delta, meanj; + Mat C(N, P); Mat x(N, 1); Mat x0(N, 1); @@ -31,9 +21,6 @@ center_variables_(const doubles_matrix<> &V_r, const doubles &v_sum_r, field> group_indices(K); field group_weights(K); - // #ifdef _OPENMP - // #pragma omp parallel for private(indices, j, J) schedule(static) - // #endif for (k = 0; k < K; ++k) { list jlist = klist[k]; J = jlist.size(); @@ -46,9 +33,6 @@ center_variables_(const doubles_matrix<> &V_r, const doubles &v_sum_r, } // Halperin projections - // #ifdef _OPENMP - // #pragma omp parallel for private(x, x0, iter, j, k, J, meanj, delta) schedule(static) - // #endif for (p = 0; p < P; ++p) { // Center each variable x = V.col(p); @@ -56,6 +40,7 @@ center_variables_(const doubles_matrix<> &V_r, const doubles &v_sum_r, if ((iter % 1000) == 0) { check_user_interrupt(); } + // Store centered vector from the last iteration x0 = x; @@ -72,15 +57,14 @@ center_variables_(const doubles_matrix<> &V_r, const doubles &v_sum_r, } // Break loop if convergence is reached - delta = - accu(abs(x - x0) / (1.0 + abs(x0)) % w) * inv_sw; + delta = accu(abs(x - x0) / (1.0 + abs(x0)) % w) * inv_sw; if (delta < tol) { break; } } - V.col(p) = x; + C.col(p) = x; } // Return matrix with centered variables - return as_doubles_matrix(V); + return C; } diff --git a/src/04_linear_algebra.cpp b/src/04_linear_algebra.cpp index e2fd4aa..82d5101 100644 --- a/src/04_linear_algebra.cpp +++ b/src/04_linear_algebra.cpp @@ -138,48 +138,27 @@ update_beta_eta_(const doubles &old, const doubles &upd, const double ¶m) { return res; } -[[cpp11::register]] doubles solve_beta_(const doubles_matrix<> &mx, - const doubles_matrix<> &mnu, - const doubles &wtilde, - const bool &weighted) { - Mat X = as_Mat(mx); - Mat Y = as_Mat(mnu); - - // Weight the X and Y matrices - if (weighted) { - Mat w = as_Mat(wtilde); - w = sqrt(w); - X = X.each_col() % w; // element-wise multiplication - Y = Y.each_col() % w; - } - - // Solve the system X * beta = Y - - // QR decomposition +Col solve_beta_(const Mat &MX, const Mat &MNU, + const Col &w) { + Col wtilde = sqrt(w); Mat Q, R; - bool computable = qr_econ(Q, R, X); + bool computable = qr_econ(Q, R, MX.each_col() % wtilde); if (!computable) { stop("QR decomposition failed"); } else { // backsolve - return as_doubles(solve(R, Q.t() * Y)); + return solve(R, Q.t() * (MNU.each_col() % wtilde)); } } // eta.upd <- nu - as.vector(Mnu - MX %*% beta.upd) -[[cpp11::register]] doubles solve_eta_(const doubles_matrix<> &mx, - const doubles_matrix<> &mnu, - const doubles &nu, const doubles &beta) { - Mat MX = as_Mat(mx); - Mat MNU = as_Mat(mnu); - Mat Nu = as_Mat(nu); - Mat Beta = as_Mat(beta); - - return as_doubles(Nu - (MNU - MX * Beta)); +Col solve_eta_(const Mat &MX, const Mat &MNU, + const Col &nu, const Col &beta) { + return nu - MNU + MX * beta; } // eta.upd <- yadj - as.vector(Myadj) + offset - eta @@ -193,152 +172,3 @@ update_beta_eta_(const doubles &old, const doubles &upd, const double ¶m) { return as_doubles(Yadj - Myadj + Offset - Eta); } - -std::string tidy_family(const std::string &family) { - // tidy family param - std::string fam = family; - - // 1. put all in lowercase - std::transform(fam.begin(), fam.end(), fam.begin(), - [](unsigned char c) { return std::tolower(c); }); - - // 2. remove numbers - fam.erase(std::remove_if(fam.begin(), fam.end(), ::isdigit), fam.end()); - - // 3. remove parentheses and everything inside - size_t pos = fam.find("("); - if (pos != std::string::npos) { - fam.erase(pos, fam.size()); - } - - // 4. replace spaces and dots - std::replace(fam.begin(), fam.end(), ' ', '_'); - std::replace(fam.begin(), fam.end(), '.', '_'); - - // 5. trim - fam.erase(std::remove_if(fam.begin(), fam.end(), ::isspace), fam.end()); - - return fam; -} - -[[cpp11::register]] doubles linkinv_(const doubles &eta_r, - const std::string &family) { - Col eta = as_Col(eta_r); - Col res(eta.n_elem); - - std::string fam = tidy_family(family); - - if (fam == "gaussian") { - res = eta; - } else if (fam == "poisson") { - res = exp(eta); - } else if (fam == "binomial") { - // res = exp(eta) / (1.0 + exp(eta)); - res = 1.0 / (1.0 + exp(-eta)); - } else if (fam == "gamma") { - res = 1.0 / eta; - } else if (fam == "inverse_gaussian") { - res = 1.0 / sqrt(eta); - } else if (fam == "negative_binomial") { - res = exp(eta); - } else { - stop("Unknown family"); - } - - return as_doubles(res); -} - -[[cpp11::register]] double dev_resids_(const doubles &y_r, const doubles &mu_r, - const double &theta, const doubles &wt_r, - const std::string &family) { - Col y = as_Col(y_r); - Col mu = as_Col(mu_r); - Col wt = as_Col(wt_r); - double res; - - std::string fam = tidy_family(family); - - if (fam == "gaussian") { - res = accu(wt % square(y - mu)); - } else if (fam == "poisson") { - uvec p = find(y > 0.0); - Col r = mu % wt; - r(p) = y(p) % log(y(p) / mu(p)) - (y(p) - mu(p)); - res = 2.0 * accu(r); - } else if (fam == "binomial") { - uvec p = find(y != 0.0); - uvec q = find(y != 1.0); - Col r = y / mu; - Col s = (1.0 - y) / (1.0 - mu); - r(p) = log(r(p)); - s(q) = log(s(q)); - res = 2.0 * accu(wt % (y % r + (1.0 - y) % s)); - } else if (fam == "gamma") { - uvec p = find(y == 0.0); - Col r = y / mu; - r.elem(p).fill(1.0); - res = -2.0 * accu(wt % (log(r) - (y - mu) / mu)); - } else if (fam == "inverse_gaussian") { - res = accu(wt % square(y - mu) / (y % square(mu))); - } else if (fam == "negative_binomial") { - uvec p = find(y < 1.0); - Col r = y; - r.elem(p).fill(1.0); - res = 2.0 * accu( - wt % (y % log(r / mu) - (y + theta) % log((y + theta) / (mu + theta)))); - } else { - stop("Unknown family"); - } - - return res; -} - -[[cpp11::register]] bool valideta_(const doubles &eta_r, - const std::string &family) { - Col eta = as_Col(eta_r); - std::string fam = tidy_family(family); - bool res; - - if (fam == "gaussian") { - res = true; - } else if (fam == "poisson") { - res = true; - } else if (fam == "binomial") { - res = true; - } else if (fam == "gamma") { - res = is_finite(eta) && all(eta != 0); - } else if (fam == "inverse_gaussian") { - res = is_finite(eta) && all(eta > 0); - } else if (fam == "negative_binomial") { - res = true; - } else { - stop("Unknown family"); - } - - return res; -} - -[[cpp11::register]] bool validmu_(const doubles &mu_r, - const std::string &family) { - Col mu = as_Col(mu_r); - std::string fam = tidy_family(family); - bool res; - - if (fam == "gaussian") { - res = true; - } else if (fam == "poisson") { - res = is_finite(mu) && all(mu > 0); - } else if (fam == "binomial") { - res = is_finite(mu) && all(mu > 0) && all(mu < 1); - } else if (fam == "gamma") { - res = is_finite(mu) && all(mu > 0); - } else if (fam == "inverse_gaussian") { - res = true; - } else if (fam == "negative_binomial") { - return all(mu > 0); - } else { - stop("Unknown family"); - } - - return res; -} diff --git a/src/05_glm_fit.cpp b/src/05_glm_fit.cpp new file mode 100644 index 0000000..0ebd6ed --- /dev/null +++ b/src/05_glm_fit.cpp @@ -0,0 +1,336 @@ +#include "00_main.h" + +std::string tidy_family_(const std::string &family) { + // tidy family param + std::string fam = family; + + // 1. put all in lowercase + std::transform(fam.begin(), fam.end(), fam.begin(), + [](unsigned char c) { return std::tolower(c); }); + + // 2. remove numbers + fam.erase(std::remove_if(fam.begin(), fam.end(), ::isdigit), fam.end()); + + // 3. remove parentheses and everything inside + size_t pos = fam.find("("); + if (pos != std::string::npos) { + fam.erase(pos, fam.size()); + } + + // 4. replace spaces and dots + std::replace(fam.begin(), fam.end(), ' ', '_'); + std::replace(fam.begin(), fam.end(), '.', '_'); + + // 5. trim + fam.erase(std::remove_if(fam.begin(), fam.end(), ::isspace), fam.end()); + + return fam; +} + +Col link_inv_(const Col &eta, const std::string &fam) { + Col res(eta.n_elem); + + if (fam == "gaussian") { + res = eta; + } else if (fam == "poisson") { + res = exp(eta); + } else if (fam == "binomial") { + // res = exp(eta) / (1.0 + exp(eta)); + res = 1.0 / (1.0 + exp(-eta)); + } else if (fam == "gamma") { + res = 1.0 / eta; + } else if (fam == "inverse_gaussian") { + res = 1.0 / sqrt(eta); + } else if (fam == "negative_binomial") { + res = exp(eta); + } else { + stop("Unknown family"); + } + + return res; +} + +double dev_resids_(const Col &y, const Col &mu, + const double &theta, const Col &wt, + const std::string &fam) { + double res; + + if (fam == "gaussian") { + res = accu(wt % square(y - mu)); + } else if (fam == "poisson") { + uvec p = find(y > 0.0); + Col r = mu % wt; + r(p) = y(p) % log(y(p) / mu(p)) - (y(p) - mu(p)); + res = 2.0 * accu(r); + } else if (fam == "binomial") { + uvec p = find(y != 0.0); + uvec q = find(y != 1.0); + Col r = y / mu; + Col s = (1.0 - y) / (1.0 - mu); + r(p) = log(r(p)); + s(q) = log(s(q)); + res = 2.0 * accu(wt % (y % r + (1.0 - y) % s)); + } else if (fam == "gamma") { + uvec p = find(y == 0.0); + Col r = y / mu; + r.elem(p).fill(1.0); + res = -2.0 * accu(wt % (log(r) - (y - mu) / mu)); + } else if (fam == "inverse_gaussian") { + res = accu(wt % square(y - mu) / (y % square(mu))); + } else if (fam == "negative_binomial") { + uvec p = find(y < 1.0); + Col r = y; + r.elem(p).fill(1.0); + res = 2.0 * accu( + wt % (y % log(r / mu) - (y + theta) % log((y + theta) / (mu + theta)))); + } else { + stop("Unknown family"); + } + + return res; +} + +bool valid_eta_(const Col &eta, const std::string &fam) { + bool res; + + if (fam == "gaussian") { + res = true; + } else if (fam == "poisson") { + res = true; + } else if (fam == "binomial") { + res = true; + } else if (fam == "gamma") { + res = is_finite(eta) && all(eta != 0.0); + } else if (fam == "inverse_gaussian") { + res = is_finite(eta) && all(eta > 0.0); + } else if (fam == "negative_binomial") { + res = true; + } else { + stop("Unknown family"); + } + + return res; +} + +bool valid_mu_(const Col &mu, const std::string &fam) { + bool res; + + if (fam == "gaussian") { + res = true; + } else if (fam == "poisson") { + res = is_finite(mu) && all(mu > 0.0); + } else if (fam == "binomial") { + res = is_finite(mu) && all(mu > 0.0 && mu < 1.0); + } else if (fam == "gamma") { + res = is_finite(mu) && all(mu > 0.0); + } else if (fam == "inverse_gaussian") { + res = true; + } else if (fam == "negative_binomial") { + return all(mu > 0.0); + } else { + stop("Unknown family"); + } + + return res; +} + +// inverse link mu = g^-1 (eta), then mu_eta = d mu / d eta + +Col mu_eta_(Col &eta, const std::string &fam) { + Col res(eta.n_elem); + + if (fam == "gaussian") { + res.ones(); + } else if (fam == "poisson") { + res = exp(eta); + } else if (fam == "binomial") { + res = 1.0 / (2.0 + exp(eta) + exp(-eta)); + } else if (fam == "gamma") { + res = -1.0 / square(eta); + } else if (fam == "inverse_gaussian") { + res = 1.0 / (2.0 * pow(eta, 1.5)); + } else if (fam == "negative_binomial") { + res = exp(eta); + } else { + stop("Unknown family"); + } + + return res; +} + +Col variance_(const Col &mu, + const double &theta, const std::string &fam) { + Col res(mu.n_elem); + + if (fam == "gaussian") { + res.ones(); + } else if (fam == "poisson") { + res = mu; + } else if (fam == "binomial") { + res = mu % (1.0 - mu); + } else if (fam == "gamma") { + res = square(mu); + } else if (fam == "inverse_gaussian") { + res = pow(mu, 3.0); + } else if (fam == "negative_binomial") { + res = mu + square(mu) / theta; + } else { + stop("Unknown family"); + } +} + +[[cpp11::register]] list feglm_fit_( + const doubles &beta_r, const doubles &eta_r, const doubles &y_r, + const doubles_matrix<> &x_r, const doubles &nt_r, const doubles &wt_r, + const double &theta, const std::string &family, const list &control, + const list &k_list) { + // Type conversion + + Col beta = as_Col(beta_r); + Col eta = as_Col(eta_r); + Col y = as_Col(y_r); + Mat MX = as_Mat(x_r); + Mat MNU = as_Mat(nt_r); + Col wt = as_Col(wt_r); + + // Auxiliary variables (storage) + + double dev = 0.0; + + // Auxiliary variables (fixed) + + std::string fam = tidy_family_(family); + double center_tol = as_cpp(control["center_tol"]); + double dev_tol = as_cpp(control["dev.tol"]); + int iter; + int max_iter = as_cpp(control["max.iter"]); + int max_center_iter = 10000; + bool keep_mx = as_cpp(control["keep.mx"]); + + // Maximize the log-likelihood + + bool conv = false; + + for (iter = 0; iter < max_iter; ++iter) { + // Auxiliary variables (fixed) + + int inner_iter, max_inner_iter = 50; + const int n = y.n_elem; + const int k = beta.n_elem; + bool dev_crit, val_crit, imp_crit; + double dev_old; + + // Auxiliary variables (storage) + + double rho = 1.0; + Col mu(n), eta_upd(n), beta_upd(k), eta_old(n), beta_old(k); + Col mu_eta(n), w(n), nu(n); + + // Store eta, beta, and deviance of the previous iteration + + eta_old = eta; + beta_old = beta; + dev_old = dev; + + // Compute weights and dependent variable + + mu_eta = mu_eta_(eta, fam); + w = (wt % square(mu_eta)) / variance_(mu, theta, fam); + nu = (y - mu) / mu_eta; + + // Center variables + + Mnu = center_variables_(Mnu.each_col() + nu, w, k_list, center_tol, + max_center_iter); + MX = center_variables_(MX, w, k_list, center_tol, max_center_iter); + + // Compute update step and update eta + + // Step-halving with three checks: + // 1. finite deviance + // 2. valid eta and mu + // 3. improvement as in glm2 + + beta_upd = solve_beta_(MX, MNU, w); + eta_upd = solve_eta_(MX, MNU, nu, beta_upd); + + for (inner_iter = 0; inner_iter < max_inner_iter; ++inner_iter) { + eta = eta_old + (rho * eta_upd); + beta = beta_old + (rho * beta_upd); + mu = link_inv_(eta, fam); + dev = accu(dev_resids_(y, mu, theta, wt, fam)); + dev_crit = is_finite(dev); + val_crit = valid_eta_(eta, fam) && valid_mu_(mu, fam); + imp_crit = ((dev - dev_old) / (0.1 + abs(dev))) <= -dev_tol; + if (dev_crit && val_crit && imp_crit) { + break; + } + rho *= 0.5; + } + + // Check if step-halving failed (deviance and invalid eta or mu) + + if (dev_crit == false || val_crit == false) { + stop("Inner loop failed; cannot correct step size."); + } + + // If step halving does not improve the deviance + + if (imp_crit == false) { + eta = eta_old; + beta = beta_old; + dev = dev_old; + mu = link_inv_(eta, fam); + } + + // Check convergence + + dev_crit = abs(dev - dev_old) / (0.1 + abs(dev)); + if (dev_crit < dev_tol) { + conv = true; + break; + } + + // Update starting guesses for acceleration + + MNU = MNU - nu; + } + + // Information if convergence failed + + if (conv == false) { + stop("Algorithm did not converge."); + } + + // Update weights and dependent variable + + mu_eta = mu_eta_(eta, fam); + w = (wt % square(mu_eta)) / variance_(mu, theta, fam); + + // Center variables + + MX = center_variables_(X, w, k_list, center_tol, max_center_iter); + + // Recompute Hessian + + H = crossprod_(MX, w, true, true); + + // Generate result list + + writable::list out(8); + + out.push_back({"coefficients"_nm = as_doubles(beta)}); + out.push_back({"eta"_nm = as_doubles(eta)}); + out.push_back({"weights"_nm = as_doubles(wt)}); + out.push_back({"Hessian"_nm = as_doubles_matrix(H)}); + out.push_back({"deviance"_nm = dev}); + out.push_back({"null.deviance"_nm = null.dev}); + out.push_back({"conv"_nm = conv}); + out.push_back({"iter"_nm = iter}); + + if (keep_mx == true) { + out.push_back({"MX"_nm = as_doubles_matrix(MX)}); + } + + return out; +} diff --git a/src/05_kendall_correlation.cpp b/src/06_kendall_correlation.cpp similarity index 100% rename from src/05_kendall_correlation.cpp rename to src/06_kendall_correlation.cpp diff --git a/src/cpp11.cpp b/src/cpp11.cpp index 8c975d4..3d51f78 100644 --- a/src/cpp11.cpp +++ b/src/cpp11.cpp @@ -5,13 +5,6 @@ #include "cpp11/declarations.hpp" #include -// 01_center_variables.cpp -doubles_matrix<> center_variables_(const doubles_matrix<> & V_r, const doubles & v_sum_r, const doubles & w_r, const list & klist, const double & tol, const int & maxiter, const bool & sum_v); -extern "C" SEXP _capybara_center_variables_(SEXP V_r, SEXP v_sum_r, SEXP w_r, SEXP klist, SEXP tol, SEXP maxiter, SEXP sum_v) { - BEGIN_CPP11 - return cpp11::as_sexp(center_variables_(cpp11::as_cpp &>>(V_r), cpp11::as_cpp>(v_sum_r), cpp11::as_cpp>(w_r), cpp11::as_cpp>(klist), cpp11::as_cpp>(tol), cpp11::as_cpp>(maxiter), cpp11::as_cpp>(sum_v))); - END_CPP11 -} // 02_get_alpha.cpp list get_alpha_(const doubles_matrix<> & p_r, const list & klist, const double & tol); extern "C" SEXP _capybara_get_alpha_(SEXP p_r, SEXP klist, SEXP tol) { @@ -111,62 +104,27 @@ extern "C" SEXP _capybara_update_nu_(SEXP y, SEXP mu, SEXP mu_eta) { END_CPP11 } // 04_linear_algebra.cpp -doubles solve_beta_(const doubles_matrix<> & mx, const doubles_matrix<> & mnu, const doubles & wtilde, const bool & weighted); -extern "C" SEXP _capybara_solve_beta_(SEXP mx, SEXP mnu, SEXP wtilde, SEXP weighted) { - BEGIN_CPP11 - return cpp11::as_sexp(solve_beta_(cpp11::as_cpp &>>(mx), cpp11::as_cpp &>>(mnu), cpp11::as_cpp>(wtilde), cpp11::as_cpp>(weighted))); - END_CPP11 -} -// 04_linear_algebra.cpp -doubles solve_eta_(const doubles_matrix<> & mx, const doubles_matrix<> & mnu, const doubles & nu, const doubles & beta); -extern "C" SEXP _capybara_solve_eta_(SEXP mx, SEXP mnu, SEXP nu, SEXP beta) { - BEGIN_CPP11 - return cpp11::as_sexp(solve_eta_(cpp11::as_cpp &>>(mx), cpp11::as_cpp &>>(mnu), cpp11::as_cpp>(nu), cpp11::as_cpp>(beta))); - END_CPP11 -} -// 04_linear_algebra.cpp doubles solve_eta2_(const doubles & yadj, const doubles_matrix<> & myadj, const doubles & offset, const doubles & eta); extern "C" SEXP _capybara_solve_eta2_(SEXP yadj, SEXP myadj, SEXP offset, SEXP eta) { BEGIN_CPP11 return cpp11::as_sexp(solve_eta2_(cpp11::as_cpp>(yadj), cpp11::as_cpp &>>(myadj), cpp11::as_cpp>(offset), cpp11::as_cpp>(eta))); END_CPP11 } -// 04_linear_algebra.cpp -doubles linkinv_(const doubles & eta_r, const std::string & family); -extern "C" SEXP _capybara_linkinv_(SEXP eta_r, SEXP family) { - BEGIN_CPP11 - return cpp11::as_sexp(linkinv_(cpp11::as_cpp>(eta_r), cpp11::as_cpp>(family))); - END_CPP11 -} -// 04_linear_algebra.cpp -double dev_resids_(const doubles & y_r, const doubles & mu_r, const double & theta, const doubles & wt_r, const std::string & family); -extern "C" SEXP _capybara_dev_resids_(SEXP y_r, SEXP mu_r, SEXP theta, SEXP wt_r, SEXP family) { - BEGIN_CPP11 - return cpp11::as_sexp(dev_resids_(cpp11::as_cpp>(y_r), cpp11::as_cpp>(mu_r), cpp11::as_cpp>(theta), cpp11::as_cpp>(wt_r), cpp11::as_cpp>(family))); - END_CPP11 -} -// 04_linear_algebra.cpp -bool valideta_(const doubles & eta_r, const std::string & family); -extern "C" SEXP _capybara_valideta_(SEXP eta_r, SEXP family) { - BEGIN_CPP11 - return cpp11::as_sexp(valideta_(cpp11::as_cpp>(eta_r), cpp11::as_cpp>(family))); - END_CPP11 -} -// 04_linear_algebra.cpp -bool validmu_(const doubles & mu_r, const std::string & family); -extern "C" SEXP _capybara_validmu_(SEXP mu_r, SEXP family) { +// 05_glm_fit.cpp +list feglm_fit_(const doubles & beta_r, const doubles & eta_r, const doubles & y_r, const doubles_matrix<> & x_r, const doubles & nt_r, const doubles & wt_r, const double & theta, const std::string & family, const list & control, const list & k_list); +extern "C" SEXP _capybara_feglm_fit_(SEXP beta_r, SEXP eta_r, SEXP y_r, SEXP x_r, SEXP nt_r, SEXP wt_r, SEXP theta, SEXP family, SEXP control, SEXP k_list) { BEGIN_CPP11 - return cpp11::as_sexp(validmu_(cpp11::as_cpp>(mu_r), cpp11::as_cpp>(family))); + return cpp11::as_sexp(feglm_fit_(cpp11::as_cpp>(beta_r), cpp11::as_cpp>(eta_r), cpp11::as_cpp>(y_r), cpp11::as_cpp &>>(x_r), cpp11::as_cpp>(nt_r), cpp11::as_cpp>(wt_r), cpp11::as_cpp>(theta), cpp11::as_cpp>(family), cpp11::as_cpp>(control), cpp11::as_cpp>(k_list))); END_CPP11 } -// 05_kendall_correlation.cpp +// 06_kendall_correlation.cpp double kendall_cor_(const doubles_matrix<> & m); extern "C" SEXP _capybara_kendall_cor_(SEXP m) { BEGIN_CPP11 return cpp11::as_sexp(kendall_cor_(cpp11::as_cpp &>>(m))); END_CPP11 } -// 05_kendall_correlation.cpp +// 06_kendall_correlation.cpp doubles pkendall_(doubles Q, int n); extern "C" SEXP _capybara_pkendall_(SEXP Q, SEXP n) { BEGIN_CPP11 @@ -176,30 +134,24 @@ extern "C" SEXP _capybara_pkendall_(SEXP Q, SEXP n) { extern "C" { static const R_CallMethodDef CallEntries[] = { - {"_capybara_center_variables_", (DL_FUNC) &_capybara_center_variables_, 7}, - {"_capybara_crossprod_", (DL_FUNC) &_capybara_crossprod_, 4}, - {"_capybara_dev_resids_", (DL_FUNC) &_capybara_dev_resids_, 5}, - {"_capybara_gamma_", (DL_FUNC) &_capybara_gamma_, 6}, - {"_capybara_get_alpha_", (DL_FUNC) &_capybara_get_alpha_, 3}, - {"_capybara_group_sums_", (DL_FUNC) &_capybara_group_sums_, 3}, - {"_capybara_group_sums_cov_", (DL_FUNC) &_capybara_group_sums_cov_, 3}, - {"_capybara_group_sums_spectral_", (DL_FUNC) &_capybara_group_sums_spectral_, 5}, - {"_capybara_group_sums_var_", (DL_FUNC) &_capybara_group_sums_var_, 2}, - {"_capybara_inv_", (DL_FUNC) &_capybara_inv_, 1}, - {"_capybara_kendall_cor_", (DL_FUNC) &_capybara_kendall_cor_, 1}, - {"_capybara_linkinv_", (DL_FUNC) &_capybara_linkinv_, 2}, - {"_capybara_pkendall_", (DL_FUNC) &_capybara_pkendall_, 2}, - {"_capybara_rank_", (DL_FUNC) &_capybara_rank_, 1}, - {"_capybara_sandwich_", (DL_FUNC) &_capybara_sandwich_, 2}, - {"_capybara_solve_beta_", (DL_FUNC) &_capybara_solve_beta_, 4}, - {"_capybara_solve_bias_", (DL_FUNC) &_capybara_solve_bias_, 4}, - {"_capybara_solve_eta2_", (DL_FUNC) &_capybara_solve_eta2_, 4}, - {"_capybara_solve_eta_", (DL_FUNC) &_capybara_solve_eta_, 4}, - {"_capybara_solve_y_", (DL_FUNC) &_capybara_solve_y_, 2}, - {"_capybara_update_beta_eta_", (DL_FUNC) &_capybara_update_beta_eta_, 3}, - {"_capybara_update_nu_", (DL_FUNC) &_capybara_update_nu_, 3}, - {"_capybara_valideta_", (DL_FUNC) &_capybara_valideta_, 2}, - {"_capybara_validmu_", (DL_FUNC) &_capybara_validmu_, 2}, + {"_capybara_crossprod_", (DL_FUNC) &_capybara_crossprod_, 4}, + {"_capybara_feglm_fit_", (DL_FUNC) &_capybara_feglm_fit_, 10}, + {"_capybara_gamma_", (DL_FUNC) &_capybara_gamma_, 6}, + {"_capybara_get_alpha_", (DL_FUNC) &_capybara_get_alpha_, 3}, + {"_capybara_group_sums_", (DL_FUNC) &_capybara_group_sums_, 3}, + {"_capybara_group_sums_cov_", (DL_FUNC) &_capybara_group_sums_cov_, 3}, + {"_capybara_group_sums_spectral_", (DL_FUNC) &_capybara_group_sums_spectral_, 5}, + {"_capybara_group_sums_var_", (DL_FUNC) &_capybara_group_sums_var_, 2}, + {"_capybara_inv_", (DL_FUNC) &_capybara_inv_, 1}, + {"_capybara_kendall_cor_", (DL_FUNC) &_capybara_kendall_cor_, 1}, + {"_capybara_pkendall_", (DL_FUNC) &_capybara_pkendall_, 2}, + {"_capybara_rank_", (DL_FUNC) &_capybara_rank_, 1}, + {"_capybara_sandwich_", (DL_FUNC) &_capybara_sandwich_, 2}, + {"_capybara_solve_bias_", (DL_FUNC) &_capybara_solve_bias_, 4}, + {"_capybara_solve_eta2_", (DL_FUNC) &_capybara_solve_eta2_, 4}, + {"_capybara_solve_y_", (DL_FUNC) &_capybara_solve_y_, 2}, + {"_capybara_update_beta_eta_", (DL_FUNC) &_capybara_update_beta_eta_, 3}, + {"_capybara_update_nu_", (DL_FUNC) &_capybara_update_nu_, 3}, {NULL, NULL, 0} }; } From 5c76485b1bffcdca859de68e791dba13e9c0a53b Mon Sep 17 00:00:00 2001 From: Mauricio 'Pacha' Vargas Sepulveda Date: Wed, 17 Jul 2024 18:35:25 -0400 Subject: [PATCH 04/16] feglm_fit refactor halfway there --- R/cpp11.R | 8 +--- R/feglm.R | 42 +++++++++---------- R/feglm_control.R | 38 +++++++++--------- R/fenegbin.R | 52 ++++++++++++------------ R/fepoisson.R | 30 ++------------ R/helpers.R | 4 +- R/internals.R | 4 +- src/00_main.h | 16 ++++++++ src/04_linear_algebra.cpp | 30 ++++++-------- src/05_glm_fit.cpp | 60 ++++++++++++++++------------ src/cpp11.cpp | 14 ++----- tests/testthat/test-linear_algebra.R | 43 -------------------- 12 files changed, 142 insertions(+), 199 deletions(-) diff --git a/R/cpp11.R b/R/cpp11.R index 466254c..ba89c4a 100644 --- a/R/cpp11.R +++ b/R/cpp11.R @@ -20,10 +20,6 @@ group_sums_cov_ <- function(M_r, N_r, jlist) { .Call(`_capybara_group_sums_cov_`, M_r, N_r, jlist) } -crossprod_ <- function(x, w, weighted, root_weights) { - .Call(`_capybara_crossprod_`, x, w, weighted, root_weights) -} - gamma_ <- function(mx, hessian, j, ppsi, v, nt_full) { .Call(`_capybara_gamma_`, mx, hessian, j, ppsi, v, nt_full) } @@ -60,8 +56,8 @@ solve_eta2_ <- function(yadj, myadj, offset, eta) { .Call(`_capybara_solve_eta2_`, yadj, myadj, offset, eta) } -feglm_fit_ <- function(beta_r, eta_r, y_r, x_r, nt_r, wt_r, theta, family, control, k_list) { - .Call(`_capybara_feglm_fit_`, beta_r, eta_r, y_r, x_r, nt_r, wt_r, theta, family, control, k_list) +feglm_fit_ <- function(beta_r, eta_r, y_r, x_r, nt, wt_r, theta, family, control, k_list) { + .Call(`_capybara_feglm_fit_`, beta_r, eta_r, y_r, x_r, nt, wt_r, theta, family, control, k_list) } kendall_cor_ <- function(m) { diff --git a/R/feglm.R b/R/feglm.R index 60fe7e6..49c34e6 100644 --- a/R/feglm.R +++ b/R/feglm.R @@ -21,10 +21,10 @@ #' details of family functions. #' @param weights an optional string with the name of the 'prior weights' #' variable in \code{data}. -#' @param beta.start an optional vector of starting values for the structural +#' @param beta_start an optional vector of starting values for the structural #' parameters in the linear predictor. Default is #' \eqn{\boldsymbol{\beta} = \mathbf{0}}{\beta = 0}. -#' @param eta.start an optional vector of starting values for the linear +#' @param eta_start an optional vector of starting values for the linear #' predictor. #' @param control a named list of parameters for controlling the fitting #' process. See \code{\link{feglm_control}} for details. @@ -68,8 +68,8 @@ feglm <- function( data = NULL, family = gaussian(), weights = NULL, - beta.start = NULL, - eta.start = NULL, + beta_start = NULL, + eta_start = NULL, control = NULL) { # Check validity of formula ---- check_formula_(formula) @@ -96,24 +96,24 @@ feglm <- function( check_response_(data, lhs, family) # Get names of the fixed effects variables and sort ---- - k.vars <- attr(terms(formula, rhs = 2L), "term.labels") - k <- length(k.vars) + k_vars <- attr(terms(formula, rhs = 2L), "term.labels") + k <- length(k_vars) # Generate temporary variable ---- tmp.var <- temp_var_(data) # Drop observations that do not contribute to the log likelihood ---- - data <- drop_by_link_type_(data, lhs, family, tmp.var, k.vars, control) + data <- drop_by_link_type_(data, lhs, family, tmp.var, k_vars, control) # Transform fixed effects and clusters to factors ---- - data <- transform_fe_(data, formula, k.vars) + data <- transform_fe_(data, formula, k_vars) # Determine the number of dropped observations ---- nt <- nrow(data) nobs <- nobs_(nobs.full, nobs.na, nt) # Extract model response and regressor matrix ---- - nms.sp <- NA + nms_sp <- NA p <- NA model_response_(data, formula) @@ -131,18 +131,20 @@ feglm <- function( check_weights_(wt) # Compute and check starting guesses ---- - start_guesses_(beta.start, eta.start, y, X, beta, nt, wt, p, family) + start_guesses_(beta_start, eta_start, y, X, beta, nt, wt, p, family) # Get names and number of levels in each fixed effects category ---- - nms.fe <- lapply(select(data, all_of(k.vars)), levels) - lvls.k <- vapply(nms.fe, length, integer(1)) + nms_fe <- lapply(select(data, all_of(k_vars)), levels) + lvls_k <- vapply(nms_fe, length, integer(1)) # Generate auxiliary list of indexes for different sub panels ---- - k.list <- get_index_list_(k.vars, data) + k_list <- get_index_list_(k_vars, data) # Fit generalized linear model ---- + if (is.integer(y)) { y <- as.numeric(y) } + if (is.integer(nt)) { nt <- as.numeric(nt) } fit <- feglm_fit_( - beta, eta, y, X, wt, k.list, family, control + beta, eta, y, X, nt, wt, 0.0, family[["family"]], control, k_list ) y <- NULL @@ -150,18 +152,18 @@ feglm <- function( eta <- NULL # Add names to beta, Hessian, and MX (if provided) ---- - names(fit[["coefficients"]]) <- nms.sp - if (control[["keep.mx"]]) { - colnames(fit[["MX"]]) <- nms.sp + names(fit[["coefficients"]]) <- nms_sp + if (control[["keep_mx"]]) { + colnames(fit[["MX"]]) <- nms_sp } - dimnames(fit[["Hessian"]]) <- list(nms.sp, nms.sp) + dimnames(fit[["Hessian"]]) <- list(nms_sp, nms_sp) # Generate result list ---- reslist <- c( fit, list( nobs = nobs, - lvls.k = lvls.k, - nms.fe = nms.fe, + lvls_k = lvls_k, + nms_fe = nms_fe, formula = formula, data = data, family = family, diff --git a/R/feglm_control.R b/R/feglm_control.R index 838baef..d145efd 100644 --- a/R/feglm_control.R +++ b/R/feglm_control.R @@ -3,28 +3,28 @@ #' @description Set and change parameters used for fitting \code{\link{feglm}}. #' Termination conditions are similar to \code{\link[stats]{glm}}. #' -#' @param dev.tol tolerance level for the first stopping condition of the +#' @param dev_tol tolerance level for the first stopping condition of the #' maximization routine. The stopping condition is based on the relative change #' of the deviance in iteration \eqn{r} and can be expressed as follows: #' \eqn{|dev_{r} - dev_{r - 1}| / (0.1 + |dev_{r}|) < tol}{|dev - devold| / #' (0.1 + |dev|) < tol}. The default is \code{1.0e-08}. -#' @param center.tol tolerance level for the stopping condition of the centering +#' @param center_tol tolerance level for the stopping condition of the centering #' algorithm. The stopping condition is based on the relative change of the #' centered variable similar to the \code{'lfe'} package. The default is #' \code{1.0e-08}. -#' @param iter.max unsigned integer indicating the maximum number of iterations +#' @param iter_max unsigned integer indicating the maximum number of iterations #' in the maximization routine. The default is \code{25L}. #' @param limit unsigned integer indicating the maximum number of iterations of #' \code{\link[MASS]{theta.ml}}. The default is \code{10L}. #' @param trace logical indicating if output should be produced in each #' iteration. Default is \code{FALSE}. -#' @param drop.pc logical indicating to drop observations that are perfectly +#' @param drop_pc logical indicating to drop observations that are perfectly #' classified/separated and hence do not contribute to the log-likelihood. This #' option is useful to reduce the computational costs of the maximization #' problem and improves the numerical stability of the algorithm. Note that #' dropping perfectly separated observations does not affect the estimates. #' The default is \code{TRUE}. -#' @param keep.mx logical indicating if the centered regressor matrix should be +#' @param keep_mx logical indicating if the centered regressor matrix should be #' stored. The centered regressor matrix is required for some covariance #' estimators, bias corrections, and average partial effects. This option saves #' some computation time at the cost of memory. The default is \code{TRUE}. @@ -33,24 +33,24 @@ #' #' @seealso \code{\link{feglm}} feglm_control <- function( - dev.tol = 1.0e-08, - center.tol = 1.0e-08, - iter.max = 25L, + dev_tol = 1.0e-08, + center_tol = 1.0e-08, + iter_max = 25L, limit = 10L, trace = FALSE, - drop.pc = TRUE, - keep.mx = TRUE) { + drop_pc = TRUE, + keep_mx = TRUE) { # Check validity of tolerance parameters - if (dev.tol <= 0.0 || center.tol <= 0.0) { + if (dev_tol <= 0.0 || center_tol <= 0.0) { stop( "All tolerance parameters should be greater than zero.", call. = FALSE ) } - # Check validity of 'iter.max' - iter.max <- as.integer(iter.max) - if (iter.max < 1L) { + # Check validity of 'iter_max' + iter_max <- as.integer(iter_max) + if (iter_max < 1L) { stop( "Maximum number of iterations should be at least one.", call. = FALSE @@ -65,12 +65,12 @@ feglm_control <- function( # Return list with control parameters list( - dev.tol = dev.tol, - center.tol = center.tol, - iter.max = iter.max, + dev_tol = dev_tol, + center_tol = center_tol, + iter_max = iter_max, limit = limit, trace = as.logical(trace), - drop.pc = as.logical(drop.pc), - keep.mx = as.logical(keep.mx) + drop_pc = as.logical(drop_pc), + keep_mx = as.logical(keep_mx) ) } diff --git a/R/fenegbin.R b/R/fenegbin.R index f7726eb..832f830 100644 --- a/R/fenegbin.R +++ b/R/fenegbin.R @@ -2,7 +2,7 @@ #' effects #' @description A routine that uses the same internals as \code{\link{feglm}}. #' @inheritParams feglm -#' @param init.theta an optional initial value for the theta parameter (see +#' @param init_theta an optional initial value for the theta parameter (see #' \code{\link[MASS]{glm.nb}}). #' @param link the link function. Must be one of \code{"log"}, \code{"sqrt"}, or #' \code{"identity"}. @@ -22,9 +22,9 @@ fenegbin <- function( formula = NULL, data = NULL, weights = NULL, - beta.start = NULL, - eta.start = NULL, - init.theta = NULL, + beta_start = NULL, + eta_start = NULL, + init_theta = NULL, link = c("log", "identity", "sqrt"), control = NULL) { # Check validity of formula ---- @@ -49,31 +49,31 @@ fenegbin <- function( model_frame_(data, formula, weights) # Check starting guess of theta ---- - family <- init_theta_(init.theta, link) - rm(init.theta) + family <- init_theta_(init_theta, link) + rm(init_theta) # Ensure that model response is in line with the chosen model ---- check_response_(data, lhs, family) # Get names of the fixed effects variables and sort ---- - k.vars <- attr(terms(formula, rhs = 2L), "term.labels") - k <- length(k.vars) + k_vars <- attr(terms(formula, rhs = 2L), "term.labels") + k <- length(k_vars) # Generate temporary variable ---- tmp.var <- temp_var_(data) # Drop observations that do not contribute to the log likelihood ---- - data <- drop_by_link_type_(data, lhs, family, tmp.var, k.vars, control) + data <- drop_by_link_type_(data, lhs, family, tmp.var, k_vars, control) # Transform fixed effects and clusters to factors ---- - data <- transform_fe_(data, formula, k.vars) + data <- transform_fe_(data, formula, k_vars) # Determine the number of dropped observations ---- nt <- nrow(data) nobs <- nobs_(nobs.full, nobs.na, nt) # Extract model response and regressor matrix ---- - nms.sp <- NA + nms_sp <- NA p <- NA model_response_(data, formula) @@ -91,24 +91,24 @@ fenegbin <- function( check_weights_(wt) # Compute and check starting guesses ---- - start_guesses_(beta.start, eta.start, y, X, beta, nt, wt, p, family) + start_guesses_(beta_start, eta_start, y, X, beta, nt, wt, p, family) # Get names and number of levels in each fixed effects category ---- - nms.fe <- lapply(select(data, all_of(k.vars)), levels) - lvls.k <- vapply(nms.fe, length, integer(1)) + nms_fe <- lapply(select(data, all_of(k_vars)), levels) + lvls_k <- vapply(nms_fe, length, integer(1)) # Generate auxiliary list of indexes for different sub panels ---- - k.list <- get_index_list_(k.vars, data) + k.list <- get_index_list_(k_vars, data) # Extract control arguments ---- - tol <- control[["dev.tol"]] + tol <- control[["dev_tol"]] limit <- control[["limit"]] - iter.max <- control[["iter.max"]] + iter_max <- control[["iter_max"]] trace <- control[["trace"]] # Initial negative binomial fit ---- fit <- feglm_fit_( - beta, eta, y, X, wt, k.list, family, control + beta, eta, y, X, nt, wt, theta, family[["family"]], control, k_list ) beta <- fit[["coefficients"]] @@ -126,12 +126,12 @@ fenegbin <- function( # Alternate between fitting glm and \theta ---- conv <- FALSE - for (iter in seq.int(iter.max)) { + for (iter in seq.int(iter_max)) { # Fit negative binomial model dev.old <- dev theta.old <- theta family <- negative.binomial(theta, link) - family$theta <- theta + family[["theta"]] <- theta fit <- feglm_fit_(beta, eta, y, X, wt, k.list, family, control) beta <- fit[["coefficients"]] eta <- fit[["eta"]] @@ -173,11 +173,11 @@ fenegbin <- function( if (!conv && trace) cat("Algorithm did not converge.\n") # Add names to beta, Hessian, and MX (if provided) ---- - names(fit[["coefficients"]]) <- nms.sp - if (control[["keep.mx"]]) { - colnames(fit[["MX"]]) <- nms.sp + names(fit[["coefficients"]]) <- nms_sp + if (control[["keep_mx"]]) { + colnames(fit[["MX"]]) <- nms_sp } - dimnames(fit[["Hessian"]]) <- list(nms.sp, nms.sp) + dimnames(fit[["Hessian"]]) <- list(nms_sp, nms_sp) # Generate result list ---- reslist <- c( @@ -186,8 +186,8 @@ fenegbin <- function( iter.outer = iter, conv.outer = conv, nobs = nobs, - lvls.k = lvls.k, - nms.fe = nms.fe, + lvls_k = lvls_k, + nms_fe = nms_fe, formula = formula, data = data, family = family, diff --git a/R/fepoisson.R b/R/fepoisson.R index 3a9ad24..0c6a03e 100644 --- a/R/fepoisson.R +++ b/R/fepoisson.R @@ -18,35 +18,11 @@ fepoisson <- function( formula = NULL, data = NULL, weights = NULL, - beta.start = NULL, - eta.start = NULL, + beta_start = NULL, + eta_start = NULL, control = NULL) { feglm( formula = formula, data = data, weights = weights, family = poisson(), - beta.start = beta.start, eta.start = eta.start, control = control + beta_start = beta_start, eta_start = eta_start, control = control ) } - -# fequasipoisson <- function( -# formula = NULL, -# data = NULL, -# weights = NULL, -# beta.start = NULL, -# eta.start = NULL, -# control = NULL) { -# # Fit the model using standard Poisson assumptions -# fit <- feglm( -# formula = formula, data = data, weights = weights, family = poisson(), -# beta.start = beta.start, eta.start = eta.start, control = control -# ) - -# # Estimate the dispersion parameter (phi) -# fitted_values <- predict(object, type = "response") -# residuals <- unlist(object$data[, 1], use.names = FALSE) - fitted_values -# phi <- sum((residuals^2) / fitted_values) / fit$df.residual? - -# # Adjust model diagnostics for Quasi Poisson -# fit$std.errors <- sqrt(phi) * fit$std.errors - -# return(fit) -# } diff --git a/R/helpers.R b/R/helpers.R index 308ce71..7ddd2a9 100644 --- a/R/helpers.R +++ b/R/helpers.R @@ -218,13 +218,13 @@ nobs_ <- function(nobs.full, nobs.na, nt) { model_response_ <- function(data, formula) { y <- data[[1L]] X <- model.matrix(formula, data, rhs = 1L)[, -1L, drop = FALSE] - nms.sp <- attr(X, "dimnames")[[2L]] + nms_sp <- attr(X, "dimnames")[[2L]] attr(X, "dimnames") <- NULL p <- ncol(X) assign("y", y, envir = parent.frame()) assign("X", X, envir = parent.frame()) - assign("nms.sp", nms.sp, envir = parent.frame()) + assign("nms_sp", nms_sp, envir = parent.frame()) assign("p", p, envir = parent.frame()) } diff --git a/R/internals.R b/R/internals.R index 8753256..c55b241 100644 --- a/R/internals.R +++ b/R/internals.R @@ -301,12 +301,12 @@ get_score_matrix_ <- function(object) { # Extract regressor matrix X <- model.matrix(formula, data, rhs = 1L)[, -1L, drop = FALSE] - nms.sp <- attr(X, "dimnames")[[2L]] + nms_sp <- attr(X, "dimnames")[[2L]] attr(X, "dimnames") <- NULL # Center variables MX <- center_variables_(X, NA_real_, w, k.list, control[["center.tol"]], 10000L, FALSE) - colnames(MX) <- nms.sp + colnames(MX) <- nms_sp } # Return score matrix diff --git a/src/00_main.h b/src/00_main.h index cf902ac..926b2dd 100644 --- a/src/00_main.h +++ b/src/00_main.h @@ -11,3 +11,19 @@ using namespace arma; using namespace cpp11; + +// used across the scripts + +Mat center_variables_(const Mat &V, const Col &w, + const list &klist, const double &tol, + const int &maxiter); + +Col solve_beta_(const Mat &MX, const Mat &MNU, + const Col &w); + +Col solve_eta_(const Mat &MX, const Mat &MNU, + const Col &nu, const Col &beta); + +Mat crossprod_(const Mat &X, const Col &w, const int &n, + const int &p, const bool &weighted, + const bool &root_weights); diff --git a/src/04_linear_algebra.cpp b/src/04_linear_algebra.cpp index 82d5101..ad9ca62 100644 --- a/src/04_linear_algebra.cpp +++ b/src/04_linear_algebra.cpp @@ -3,30 +3,24 @@ // Y <- crossprod(X) // Y <- t(X) %*% X -[[cpp11::register]] doubles_matrix<> crossprod_(const doubles_matrix<> &x, - const doubles &w, - const bool &weighted, - const bool &root_weights) { - Mat X = as_Mat(x); - int P = X.n_cols; - - Mat res(P, P); +Mat crossprod_(const Mat &X, const Col &w, const int &n, + const int &p, const bool &weighted, + const bool &root_weights) { + Mat res(p, p); - if (!weighted) { + if (weighted == false) { res = X.t() * X; } else { - Mat W = as_Mat(w); - - if (root_weights) { - W = sqrt(W); + Mat Y(n, p); + if (root_weights == false) { + Y = X.each_col() % w; + } else { + Y = X.each_col() % sqrt(w); } - - X = X.each_col() % W; - - res = X.t() * X; + res = Y.t() * Y; } - return as_doubles_matrix(res); + return res; } // WinvJ < -solve(object[["Hessian"]] / nt.full, J) diff --git a/src/05_glm_fit.cpp b/src/05_glm_fit.cpp index 0ebd6ed..9a43ce5 100644 --- a/src/05_glm_fit.cpp +++ b/src/05_glm_fit.cpp @@ -177,11 +177,13 @@ Col variance_(const Col &mu, } else { stop("Unknown family"); } + + return res; } [[cpp11::register]] list feglm_fit_( const doubles &beta_r, const doubles &eta_r, const doubles &y_r, - const doubles_matrix<> &x_r, const doubles &nt_r, const doubles &wt_r, + const doubles_matrix<> &x_r, const double &nt, const doubles &wt_r, const double &theta, const std::string &family, const list &control, const list &k_list) { // Type conversion @@ -190,32 +192,41 @@ Col variance_(const Col &mu, Col eta = as_Col(eta_r); Col y = as_Col(y_r); Mat MX = as_Mat(x_r); - Mat MNU = as_Mat(nt_r); + Mat MNU(y.n_elem, 1, fill::ones); + MNU = nt * MNU; Col wt = as_Col(wt_r); - // Auxiliary variables (storage) - - double dev = 0.0; - // Auxiliary variables (fixed) std::string fam = tidy_family_(family); double center_tol = as_cpp(control["center_tol"]); - double dev_tol = as_cpp(control["dev.tol"]); + double dev_tol = as_cpp(control["dev_tol"]); int iter; - int max_iter = as_cpp(control["max.iter"]); - int max_center_iter = 10000; - bool keep_mx = as_cpp(control["keep.mx"]); + int iter_max = as_cpp(control["iter_max"]); + int iter_center_max = 10000; + bool keep_mx = as_cpp(control["keep_mx"]); + + // Auxiliary variables (storage) + + Col mu = link_inv_(eta, fam); + Col ymean(y.n_elem, fill::ones); + ymean = mean(y) * ymean; + double dev = dev_resids_(y, mu, theta, wt, fam); + double null_dev = dev_resids_(y, ymean, theta, wt, fam); + + const int n = y.n_elem; + const int p = MX.n_cols; + Col mu_eta(n), nu(n); + Mat H(p, p), w(n, 1); // Maximize the log-likelihood bool conv = false; - for (iter = 0; iter < max_iter; ++iter) { + for (iter = 0; iter < iter_max; ++iter) { // Auxiliary variables (fixed) - int inner_iter, max_inner_iter = 50; - const int n = y.n_elem; + int iter_inner, iter_inner_max = 50; const int k = beta.n_elem; bool dev_crit, val_crit, imp_crit; double dev_old; @@ -223,12 +234,11 @@ Col variance_(const Col &mu, // Auxiliary variables (storage) double rho = 1.0; - Col mu(n), eta_upd(n), beta_upd(k), eta_old(n), beta_old(k); - Col mu_eta(n), w(n), nu(n); + Col eta_upd(n), beta_upd(k), eta_old(n), beta_old(k); - // Store eta, beta, and deviance of the previous iteration + // Store eta, beta, and deviance of the previous iteration - eta_old = eta; + eta_old = eta; beta_old = beta; dev_old = dev; @@ -240,9 +250,9 @@ Col variance_(const Col &mu, // Center variables - Mnu = center_variables_(Mnu.each_col() + nu, w, k_list, center_tol, - max_center_iter); - MX = center_variables_(MX, w, k_list, center_tol, max_center_iter); + MNU = center_variables_(MNU.each_col() + nu, w, k_list, center_tol, + iter_center_max); + MX = center_variables_(MX, w, k_list, center_tol, iter_center_max); // Compute update step and update eta @@ -254,11 +264,11 @@ Col variance_(const Col &mu, beta_upd = solve_beta_(MX, MNU, w); eta_upd = solve_eta_(MX, MNU, nu, beta_upd); - for (inner_iter = 0; inner_iter < max_inner_iter; ++inner_iter) { + for (iter_inner = 0; iter_inner < iter_inner_max; ++iter_inner) { eta = eta_old + (rho * eta_upd); beta = beta_old + (rho * beta_upd); mu = link_inv_(eta, fam); - dev = accu(dev_resids_(y, mu, theta, wt, fam)); + dev = dev_resids_(y, mu, theta, wt, fam); dev_crit = is_finite(dev); val_crit = valid_eta_(eta, fam) && valid_mu_(mu, fam); imp_crit = ((dev - dev_old) / (0.1 + abs(dev))) <= -dev_tol; @@ -309,11 +319,11 @@ Col variance_(const Col &mu, // Center variables - MX = center_variables_(X, w, k_list, center_tol, max_center_iter); + MX = center_variables_(MX, w, k_list, center_tol, iter_center_max); // Recompute Hessian - H = crossprod_(MX, w, true, true); + H = crossprod_(MX, w, n, p, true, true); // Generate result list @@ -324,7 +334,7 @@ Col variance_(const Col &mu, out.push_back({"weights"_nm = as_doubles(wt)}); out.push_back({"Hessian"_nm = as_doubles_matrix(H)}); out.push_back({"deviance"_nm = dev}); - out.push_back({"null.deviance"_nm = null.dev}); + out.push_back({"null.deviance"_nm = null_dev}); out.push_back({"conv"_nm = conv}); out.push_back({"iter"_nm = iter}); diff --git a/src/cpp11.cpp b/src/cpp11.cpp index 3d51f78..93f3dee 100644 --- a/src/cpp11.cpp +++ b/src/cpp11.cpp @@ -41,13 +41,6 @@ extern "C" SEXP _capybara_group_sums_cov_(SEXP M_r, SEXP N_r, SEXP jlist) { END_CPP11 } // 04_linear_algebra.cpp -doubles_matrix<> crossprod_(const doubles_matrix<> & x, const doubles & w, const bool & weighted, const bool & root_weights); -extern "C" SEXP _capybara_crossprod_(SEXP x, SEXP w, SEXP weighted, SEXP root_weights) { - BEGIN_CPP11 - return cpp11::as_sexp(crossprod_(cpp11::as_cpp &>>(x), cpp11::as_cpp>(w), cpp11::as_cpp>(weighted), cpp11::as_cpp>(root_weights))); - END_CPP11 -} -// 04_linear_algebra.cpp doubles_matrix<> gamma_(const doubles_matrix<> & mx, const doubles_matrix<> & hessian, const doubles_matrix<> & j, const doubles_matrix<> & ppsi, const doubles & v, const SEXP & nt_full); extern "C" SEXP _capybara_gamma_(SEXP mx, SEXP hessian, SEXP j, SEXP ppsi, SEXP v, SEXP nt_full) { BEGIN_CPP11 @@ -111,10 +104,10 @@ extern "C" SEXP _capybara_solve_eta2_(SEXP yadj, SEXP myadj, SEXP offset, SEXP e END_CPP11 } // 05_glm_fit.cpp -list feglm_fit_(const doubles & beta_r, const doubles & eta_r, const doubles & y_r, const doubles_matrix<> & x_r, const doubles & nt_r, const doubles & wt_r, const double & theta, const std::string & family, const list & control, const list & k_list); -extern "C" SEXP _capybara_feglm_fit_(SEXP beta_r, SEXP eta_r, SEXP y_r, SEXP x_r, SEXP nt_r, SEXP wt_r, SEXP theta, SEXP family, SEXP control, SEXP k_list) { +list feglm_fit_(const doubles & beta_r, const doubles & eta_r, const doubles & y_r, const doubles_matrix<> & x_r, const double & nt, const doubles & wt_r, const double & theta, const std::string & family, const list & control, const list & k_list); +extern "C" SEXP _capybara_feglm_fit_(SEXP beta_r, SEXP eta_r, SEXP y_r, SEXP x_r, SEXP nt, SEXP wt_r, SEXP theta, SEXP family, SEXP control, SEXP k_list) { BEGIN_CPP11 - return cpp11::as_sexp(feglm_fit_(cpp11::as_cpp>(beta_r), cpp11::as_cpp>(eta_r), cpp11::as_cpp>(y_r), cpp11::as_cpp &>>(x_r), cpp11::as_cpp>(nt_r), cpp11::as_cpp>(wt_r), cpp11::as_cpp>(theta), cpp11::as_cpp>(family), cpp11::as_cpp>(control), cpp11::as_cpp>(k_list))); + return cpp11::as_sexp(feglm_fit_(cpp11::as_cpp>(beta_r), cpp11::as_cpp>(eta_r), cpp11::as_cpp>(y_r), cpp11::as_cpp &>>(x_r), cpp11::as_cpp>(nt), cpp11::as_cpp>(wt_r), cpp11::as_cpp>(theta), cpp11::as_cpp>(family), cpp11::as_cpp>(control), cpp11::as_cpp>(k_list))); END_CPP11 } // 06_kendall_correlation.cpp @@ -134,7 +127,6 @@ extern "C" SEXP _capybara_pkendall_(SEXP Q, SEXP n) { extern "C" { static const R_CallMethodDef CallEntries[] = { - {"_capybara_crossprod_", (DL_FUNC) &_capybara_crossprod_, 4}, {"_capybara_feglm_fit_", (DL_FUNC) &_capybara_feglm_fit_, 10}, {"_capybara_gamma_", (DL_FUNC) &_capybara_gamma_, 6}, {"_capybara_get_alpha_", (DL_FUNC) &_capybara_get_alpha_, 3}, diff --git a/tests/testthat/test-linear_algebra.R b/tests/testthat/test-linear_algebra.R index 8a2b453..4424410 100644 --- a/tests/testthat/test-linear_algebra.R +++ b/tests/testthat/test-linear_algebra.R @@ -17,46 +17,3 @@ test_that("inv_ works", { A <- matrix(c(1, 0, 0, 1, 1, 0), nrow = 2, ncol = 3, byrow = TRUE) expect_error(inv_(A)) }) - -test_that("crossprod_ works", { - set.seed(123) - A <- matrix(rnorm(4), nrow = 2) - w <- c(1,1) - - expect_equal(crossprod(A), crossprod_(A, w, T, T)) - expect_equal(crossprod(A), crossprod_(A, NA_real_, F, F)) - - w <- c(1,2) - - # Multiply A by w column-wise - B <- matrix(NA_real_, nrow = nrow(A), ncol = ncol(A)) - - for (j in 1:ncol(A)) { - B[, j] <- A[, j] * w - } - - expect_equal(crossprod(B), crossprod_(A, w, T, F)) - - for (j in 1:ncol(A)) { - B[, j] <- A[, j] * sqrt(w) - } - - expect_equal(crossprod(B), crossprod_(A, w, T, T)) -}) - -test_that("backsolve_ works", { - A <- matrix(c(1, 0, 0, 1, 1, 0, 0, 1, 1), nrow = 3, ncol = 3, byrow = TRUE) - b <- c(6.50, 7.50, 8.50) - - expect_equal(solve(A,b), solve_beta_(A, b, NA_real_, FALSE)) - - # With weights - # Multiply each column of A by w pair-wise - # Multiply each b by w pair-wise - - w <- c(1, 2, 3) - AW <- A * w - bw <- b * w - - expect_equal(solve(AW, bw), solve_beta_(A, b, w, TRUE)) -}) From c57fe5e444db286abc6363c06f10be7e3f7387d2 Mon Sep 17 00:00:00 2001 From: Mauricio 'Pacha' Vargas Sepulveda Date: Fri, 19 Jul 2024 14:29:55 -0400 Subject: [PATCH 05/16] lm ok, glm not ok --- R/apes.R | 6 +- R/bias_corr.R | 2 +- R/feglm_offset.R | 91 +++++++++ R/helpers.R | 148 +++++++++++---- R/internals.R | 325 -------------------------------- dev/glmfit.r | 129 +++++++++++++ src/05_glm_fit.cpp | 71 ++++--- tests/testthat/test-errors.R | 4 +- tests/testthat/test-feglm.R | 6 +- tests/testthat/test-felm.R | 25 ++- tests/testthat/test-fepoisson.R | 15 ++ 11 files changed, 419 insertions(+), 403 deletions(-) create mode 100644 R/feglm_offset.R delete mode 100644 R/internals.R create mode 100644 dev/glmfit.r diff --git a/R/apes.R b/R/apes.R index e4c09f4..ab22065 100644 --- a/R/apes.R +++ b/R/apes.R @@ -297,19 +297,19 @@ apes <- function( # Compute covariance matrix Gamma <- gamma_(MX, object[["Hessian"]], J, PPsi, v, nt.full) - V <- crossprod_(Gamma, NA_real_, FALSE, FALSE) + V <- crossprod(Gamma) if (adj > 0.0) { # Simplify covariance if sampling assumptions are imposed if (sampling.fe == "independence") { V <- V + adj * group_sums_var_(Delta, k.list[[1L]]) if (k > 1L) { - V <- V + adj * (group_sums_var_(Delta, k.list[[2L]]) - crossprod_(Delta, NA_real_, FALSE, FALSE)) + V <- V + adj * (group_sums_var_(Delta, k.list[[2L]]) - crossprod(Delta)) } if (panel.structure == "network") { if (k > 2L) { V <- V + adj * (group_sums_var_(Delta, k.list[[3L]]) - - crossprod_(Delta, NA_real_, FALSE, FALSE)) + crossprod(Delta)) } } } diff --git a/R/bias_corr.R b/R/bias_corr.R index a728833..55e350a 100644 --- a/R/bias_corr.R +++ b/R/bias_corr.R @@ -201,7 +201,7 @@ bias_corr <- function( colnames(MX) <- nms.sp # Update Hessian - H <- crossprod_(MX, w, TRUE, TRUE) + H <- crossprod(MX * sqrt(w)) dimnames(H) <- list(nms.sp, nms.sp) # Update result list diff --git a/R/feglm_offset.R b/R/feglm_offset.R new file mode 100644 index 0000000..7ffdc6a --- /dev/null +++ b/R/feglm_offset.R @@ -0,0 +1,91 @@ +# Efficient offset algorithm to update the linear predictor ---- + +feglm_offset_ <- function(object, offset) { + # Check validity of 'object' + if (!inherits(object, "feglm")) { + stop("'feglm_offset_' called on a non-'feglm' object.") + } + + # Extract required quantities from result list + control <- object[["control"]] + data <- object[["data"]] + wt <- object[["weights"]] + family <- object[["family"]] + formula <- object[["formula"]] + lvls.k <- object[["lvls.k"]] + nt <- object[["nobs"]][["nobs"]] + k.vars <- names(lvls.k) + + # Extract dependent variable + y <- data[[1L]] + + # Extract control arguments + center.tol <- control[["center.tol"]] + dev.tol <- control[["dev.tol"]] + iter.max <- control[["iter.max"]] + + # Generate auxiliary list of indexes to project out the fixed effects + k.list <- get_index_list_(k.vars, data) + + # Compute starting guess for \eta + if (family[["family"]] == "binomial") { + eta <- rep(family[["linkfun"]](sum(wt * (y + 0.5) / 2.0) / sum(wt)), nt) + } else if (family[["family"]] %in% c("Gamma", "inverse.gaussian")) { + eta <- rep(family[["linkfun"]](sum(wt * y) / sum(wt)), nt) + } else { + eta <- rep(family[["linkfun"]](sum(wt * (y + 0.1)) / sum(wt)), nt) + } + + # Compute initial quantities for the maximization routine + mu <- family[["linkinv"]](eta) + dev <- sum(family[["dev.resids"]](y, mu, wt)) + Myadj <- as.matrix(numeric(nt)) + + # Start maximization of the log-likelihood + for (iter in seq.int(iter.max)) { + # Store \eta, \beta, and deviance of the previous iteration + eta.old <- eta + dev.old <- dev + + # Compute weights and dependent variable + mu.eta <- family[["mu.eta"]](eta) + w <- (wt * mu.eta^2) / family[["variance"]](mu) + yadj <- (y - mu) / mu.eta + eta - offset + + # Centering dependent variable and compute \eta update + Myadj <- center_variables_(Myadj, yadj, w, k.list, center.tol, 10000L, TRUE) + eta.upd <- yadj - drop(Myadj) + offset - eta + # eta.upd <- solve_eta2_(yadj, Myadj, offset, eta) + + # Step-halving with three checks + # 1. finite deviance + # 2. valid \eta and \mu + # 3. improvement as in glm2 + rho <- 1.0 + for (inner.iter in seq.int(50L)) { + eta <- eta.old + rho * eta.upd + # eta <- update_beta_eta_(eta.old, eta.upd, rho) + mu <- family[["linkinv"]](eta) + dev <- sum(family[["dev.resids"]](y, mu, wt)) + dev.crit <- is.finite(dev) + val.crit <- family[["valideta"]](eta) && family[["validmu"]](mu) + imp.crit <- (dev - dev.old) / (0.1 + abs(dev)) <= -dev.tol + if (dev.crit && val.crit && imp.crit) break + rho <- rho / 2.0 + } + + # Check if step-halving failed + if (!dev.crit || !val.crit) { + stop("Inner loop failed; cannot correct step size.", call. = FALSE) + } + + # Check termination condition + if (abs(dev - dev.old) / (0.1 + abs(dev)) < dev.tol) break + + # Update starting guesses for acceleration + Myadj <- Myadj - yadj + } + + # Return eta + eta +} diff --git a/R/helpers.R b/R/helpers.R index 7ddd2a9..886d5af 100644 --- a/R/helpers.R +++ b/R/helpers.R @@ -10,6 +10,36 @@ check_factor_ <- function(x) { # Higher-order partial derivatives ---- +second_order_derivative_ <- function(eta, f, family) { + link <- family[["link"]] + linkinv_eta <- family[["linkinv"]](eta) + + if (link == "logit") { + return(f * (1.0 - 2.0 * linkinv_eta)) + } else if (link == "probit") { + return(-eta * f) + } else if (link == "cloglog") { + return(f * (1.0 - exp(eta))) + } else { + return(-2.0 * eta / (1.0 + eta^2) * f) + } +} + +third_order_derivative_ <- function(eta, f, family) { + link <- family[["link"]] + linkinv_eta <- family[["linkinv"]](eta) + + if (link == "logit") { + return(f * ((1.0 - 2.0 * linkinv_eta)^2 - 2.0 * f)) + } else if (link == "probit") { + return((eta^2 - 1.0) * f) + } else if (link == "cloglog") { + return(f * (1.0 - exp(eta)) * (2.0 - exp(eta)) - f) + } else { + return((6.0 * eta^2 - 2.0) / (1.0 + eta^2)^2 * f) + } +} + partial_mu_eta_ <- function(eta, family, order) { # Safeguard eta if necessary if (family[["link"]] != "logit") { @@ -19,27 +49,9 @@ partial_mu_eta_ <- function(eta, family, order) { f <- family[["mu.eta"]](eta) if (order == 2L) { - # Second-order derivative - if (family[["link"]] == "logit") { - f * (1.0 - 2.0 * family[["linkinv"]](eta)) - } else if (family[["link"]] == "probit") { - -eta * f - } else if (family[["link"]] == "cloglog") { - f * (1.0 - exp(eta)) - } else { - -2.0 * eta / (1.0 + eta^2) * f - } + return(second_order_derivative_(eta, f, family)) } else { - # Third-order derivative - if (family[["link"]] == "logit") { - f * ((1.0 - 2.0 * family[["linkinv"]](eta))^2 - 2.0 * f) - } else if (family[["link"]] == "probit") { - (eta^2 - 1.0) * f - } else if (family[["link"]] == "cloglog") { - f * (1.0 - exp(eta)) * (2.0 - exp(eta)) - f - } else { - (6.0 * eta^2 - 2.0) / (1.0 + eta^2)^2 * f - } + return(third_order_derivative_(eta, f, family)) } } @@ -167,7 +179,7 @@ check_response_ <- function(data, lhs, family) { drop_by_link_type_ <- function(data, lhs, family, tmp.var, k.vars, control) { if (family[["family"]] %in% c("binomial", "poisson")) { - if (control[["drop.pc"]]) { + if (control[["drop_pc"]]) { repeat { # Drop observations that do not contribute to the log-likelihood ncheck <- nrow(data) @@ -247,7 +259,7 @@ init_theta_ <- function(init.theta, link) { if (is.null(init.theta)) { family <- poisson(link) } else { - # Validity of input argument (beta.start) + # Validity of input argument (beta_start) if (length(init.theta) != 1L) { stop("'init.theta' has to be a scalar.", call. = FALSE) } else if (init.theta <= 0.0) { @@ -260,23 +272,23 @@ init_theta_ <- function(init.theta, link) { } start_guesses_ <- function( - beta.start, eta.start, y, X, beta, nt, wt, p, family) { - if (!is.null(beta.start) || !is.null(eta.start)) { - # If both are specified, ignore eta.start - if (!is.null(beta.start) && !is.null(eta.start)) { + beta_start, eta_start, y, X, beta, nt, wt, p, family) { + if (!is.null(beta_start) || !is.null(eta_start)) { + # If both are specified, ignore eta_start + if (!is.null(beta_start) && !is.null(eta_start)) { warning( - "'beta.start' and 'eta.start' are specified. Ignoring 'eta.start'.", + "'beta_start' and 'eta_start' are specified. Ignoring 'eta_start'.", call. = FALSE ) } # Compute and check starting guesses - if (!is.null(beta.start)) { - # Validity of input argument (beta.start) - if (length(beta.start) != p) { + if (!is.null(beta_start)) { + # Validity of input argument (beta_start) + if (length(beta_start) != p) { stop( paste( - "Length of 'beta.start' has to be equal to the number of", + "Length of 'beta_start' has to be equal to the number of", "structural parameters." ), call. = FALSE @@ -284,14 +296,14 @@ start_guesses_ <- function( } # Set starting guesses - beta <- beta.start + beta <- beta_start eta <- solve_y_(X, beta) } else { - # Validity of input argument (eta.start) - if (length(eta.start) != nt) { + # Validity of input argument (eta_start) + if (length(eta_start) != nt) { stop( paste( - "Length of 'eta.start' has to be equal to the number of", + "Length of 'eta_start' has to be equal to the number of", "observations." ), call. = FALSE @@ -300,7 +312,7 @@ start_guesses_ <- function( # Set starting guesses beta <- numeric(p) - eta <- eta.start + eta <- eta_start } } else { # Compute starting guesses if not user specified @@ -317,3 +329,67 @@ start_guesses_ <- function( assign("beta", beta, envir = parent.frame()) assign("eta", eta, envir = parent.frame()) } + +# Generate auxiliary list of indexes for different sub panels ---- + +get_index_list_ <- function(k.vars, data) { + indexes <- seq.int(0L, nrow(data) - 1L) + lapply(k.vars, function(x, indexes, data) { + split(indexes, data[[x]]) + }, indexes = indexes, data = data) +} + +# Compute score matrix ---- + +get_score_matrix_ <- function(object) { + # Extract required quantities from result list + control <- object[["control"]] + data <- object[["data"]] + eta <- object[["eta"]] + wt <- object[["weights"]] + family <- object[["family"]] + + # Update weights and dependent variable + y <- data[[1L]] + mu <- family[["linkinv"]](eta) + mu.eta <- family[["mu.eta"]](eta) + w <- (wt * mu.eta^2) / family[["variance"]](mu) + # nu <- (y - mu) / mu.eta + nu <- update_nu_(y, mu, mu.eta) + + # Center regressor matrix (if required) + if (control[["keep_mx"]]) { + MX <- object[["MX"]] + } else { + # Extract additional required quantities from result list + formula <- object[["formula"]] + k.vars <- names(object[["lvls.k"]]) + + # Generate auxiliary list of indexes to project out the fixed effects + k.list <- get_index_list_(k.vars, data) + + # Extract regressor matrix + X <- model.matrix(formula, data, rhs = 1L)[, -1L, drop = FALSE] + nms_sp <- attr(X, "dimnames")[[2L]] + attr(X, "dimnames") <- NULL + + # Center variables + MX <- center_variables_(X, NA_real_, w, k.list, control[["center.tol"]], 10000L, FALSE) + colnames(MX) <- nms_sp + } + + # Return score matrix + MX * (nu * w) +} + +# Suitable name for a temporary variable ---- + +temp_var_ <- function(data) { + repeat { + tmp.var <- paste0(sample(letters, 5L, replace = TRUE), collapse = "") + if (!(tmp.var %in% colnames(data))) { + break + } + } + tmp.var +} diff --git a/R/internals.R b/R/internals.R deleted file mode 100644 index c55b241..0000000 --- a/R/internals.R +++ /dev/null @@ -1,325 +0,0 @@ -# Transform factor ---- - -check_factor_ <- function(x) { - if (is.factor(x)) { - droplevels(x) - } else { - factor(x) - } -} - -# Fitting algorithm (similar to lm.fit) ---- - -felm_fit_ <- function(y, X, wt, k.list, control) { - # Extract control arguments - center.tol <- control[["center.tol"]] - keep.mx <- control[["keep.mx"]] - - # Generate temporary variables - nt <- length(y) - MX <- X - - # Centering variables - MX <- center_variables_(MX, NA_real_, wt, k.list, center.tol, 10000L, FALSE) - - # Compute the OLS estimate - # beta <- as.vector(qr.solve(MX, y, epsilon)) - beta <- solve_beta_(MX, y, NA_real_, FALSE) - - # Generate result list - reslist <- list( - coefficients = beta - ) - - # Update result list - if (keep.mx) reslist[["MX"]] <- MX - - # Return result list - reslist -} - -# Fitting algorithm (similar to glm.fit) ---- - -# feglm_fit_ <- function(beta, eta, y, X, wt, k.list, family, control) { -# # Extract control arguments -# center.tol <- control[["center.tol"]] -# dev.tol <- control[["dev.tol"]] -# iter.max <- control[["iter.max"]] -# keep.mx <- control[["keep.mx"]] - -# # Compute initial quantities for the maximization routine -# nt <- length(y) -# mu <- family[["linkinv"]](eta) -# dev <- sum(family[["dev.resids"]](y, mu, wt)) -# null.dev <- sum(family[["dev.resids"]](y, mean(y), wt)) - -# # Generate temporary variables -# Mnu <- as.matrix(numeric(nt)) -# MX <- X - -# # Start maximization of the log-likelihood -# conv <- FALSE -# for (iter in seq.int(iter.max)) { -# # Store \eta, \beta, and deviance of the previous iteration -# eta.old <- eta -# beta.old <- beta -# dev.old <- dev - -# # Compute weights and dependent variable -# mu.eta <- family[["mu.eta"]](eta) -# w <- (wt * mu.eta^2) / family[["variance"]](mu) -# nu <- (y - mu) / mu.eta - -# # Centering variables -# Mnu <- center_variables_(Mnu, nu, w, k.list, center.tol, 10000L, TRUE) -# MX <- center_variables_(MX, NA_real_, w, k.list, center.tol, 10000L, FALSE) - -# # Compute update step and update eta - -# # Step-halving with three checks -# # 1. finite deviance -# # 2. valid \eta and \mu -# # 3. improvement as in glm2 - -# # if (is.integer(y)) y <- as.double(y) -# # theta <- ifelse(is.null(family[["theta"]]), 0.0, family[["theta"]]) -# # sh <- step_halving_( -# # MX, Mnu, nu, w, eta.old, beta.old, y, wt, -# # theta, family[["family"]], dev.old, dev.tol -# # ) - -# # dev <- sh[["dev"]] -# # eta <- sh[["eta"]] -# # beta <- sh[["beta"]] -# # mu <- sh[["mu"]] -# # imp.crit <- sh[["imp.crit"]] -# # sh <- NULL - -# beta.upd <- solve_beta_(MX, Mnu, w, TRUE) -# # print(beta.upd) -# eta.upd <- solve_eta_(MX, Mnu, nu, beta.upd) - -# rho <- 1.0 - -# for (inner.iter in seq.int(50L)) { -# eta <- update_beta_eta_(eta.old, eta.upd, rho) -# beta <- update_beta_eta_(beta.old, beta.upd, rho) -# mu <- family[["linkinv"]](eta) -# dev <- sum(family[["dev.resids"]](y, mu, wt)) -# dev.crit <- is.finite(dev) -# val.crit <- family[["valideta"]](eta) && family[["validmu"]](mu) -# imp.crit <- (dev - dev.old) / (0.1 + abs(dev)) <= -dev.tol -# # print(c(dev.crit, val.crit, imp.crit)) -# if (dev.crit && val.crit && imp.crit) break -# rho <- rho * 0.5 -# } - -# # Check if step-halving failed (deviance and invalid \eta or \mu) -# if (!dev.crit || !val.crit) { -# stop("Inner loop failed; cannot correct step size.", call. = FALSE) -# } - -# # Stop if we do not improve -# if (!imp.crit) { -# eta <- eta.old -# beta <- beta.old -# dev <- dev.old -# mu <- family[["linkinv"]](eta) -# } - -# # Check convergence -# dev.crit <- abs(dev - dev.old) / (0.1 + abs(dev)) -# if (dev.crit < dev.tol) { -# conv <- TRUE -# break -# } - -# # Update starting guesses for acceleration -# Mnu <- Mnu - nu -# } - -# # Information if convergence failed -# if (!conv) cat("Algorithm did not converge.\n") - -# # Update weights and dependent variable -# mu.eta <- family[["mu.eta"]](eta) -# w <- (wt * mu.eta^2) / family[["variance"]](mu) - -# # Center variables -# MX <- center_variables_(X, NA_real_, w, k.list, center.tol, 10000L, FALSE) -# # Recompute Hessian -# H <- crossprod_(MX, w, TRUE, TRUE) - -# # Generate result list -# reslist <- list( -# coefficients = beta, -# eta = eta, -# weights = wt, -# Hessian = H, -# deviance = dev, -# null.deviance = null.dev, -# conv = conv, -# iter = iter -# ) - -# # Update result list -# if (keep.mx) reslist[["MX"]] <- MX - -# # Return result list -# reslist -# } - -# Efficient offset algorithm to update the linear predictor ---- - -feglm_offset_ <- function(object, offset) { - # Check validity of 'object' - if (!inherits(object, "feglm")) { - stop("'feglm_offset_' called on a non-'feglm' object.") - } - - # Extract required quantities from result list - control <- object[["control"]] - data <- object[["data"]] - wt <- object[["weights"]] - family <- object[["family"]] - formula <- object[["formula"]] - lvls.k <- object[["lvls.k"]] - nt <- object[["nobs"]][["nobs"]] - k.vars <- names(lvls.k) - - # Extract dependent variable - y <- data[[1L]] - - # Extract control arguments - center.tol <- control[["center.tol"]] - dev.tol <- control[["dev.tol"]] - iter.max <- control[["iter.max"]] - - # Generate auxiliary list of indexes to project out the fixed effects - k.list <- get_index_list_(k.vars, data) - - # Compute starting guess for \eta - if (family[["family"]] == "binomial") { - eta <- rep(family[["linkfun"]](sum(wt * (y + 0.5) / 2.0) / sum(wt)), nt) - } else if (family[["family"]] %in% c("Gamma", "inverse.gaussian")) { - eta <- rep(family[["linkfun"]](sum(wt * y) / sum(wt)), nt) - } else { - eta <- rep(family[["linkfun"]](sum(wt * (y + 0.1)) / sum(wt)), nt) - } - - # Compute initial quantities for the maximization routine - mu <- family[["linkinv"]](eta) - dev <- sum(family[["dev.resids"]](y, mu, wt)) - Myadj <- as.matrix(numeric(nt)) - - # Start maximization of the log-likelihood - for (iter in seq.int(iter.max)) { - # Store \eta, \beta, and deviance of the previous iteration - eta.old <- eta - dev.old <- dev - - # Compute weights and dependent variable - mu.eta <- family[["mu.eta"]](eta) - w <- (wt * mu.eta^2) / family[["variance"]](mu) - yadj <- (y - mu) / mu.eta + eta - offset - - # Centering dependent variable and compute \eta update - Myadj <- center_variables_(Myadj, yadj, w, k.list, center.tol, 10000L, TRUE) - # eta.upd <- yadj - drop(Myadj) + offset - eta - eta.upd <- solve_eta2_(yadj, Myadj, offset, eta) - - # Step-halving with three checks - # 1. finite deviance - # 2. valid \eta and \mu - # 3. improvement as in glm2 - rho <- 1.0 - for (inner.iter in seq.int(50L)) { - # eta <- eta.old + rho * eta.upd - eta <- update_beta_eta_(eta.old, eta.upd, rho) - mu <- family[["linkinv"]](eta) - dev <- sum(family[["dev.resids"]](y, mu, wt)) - dev.crit <- is.finite(dev) - val.crit <- family[["valideta"]](eta) && family[["validmu"]](mu) - imp.crit <- (dev - dev.old) / (0.1 + abs(dev)) <= -dev.tol - if (dev.crit && val.crit && imp.crit) break - rho <- rho / 2.0 - } - - # Check if step-halving failed - if (!dev.crit || !val.crit) { - stop("Inner loop failed; cannot correct step size.", call. = FALSE) - } - - # Check termination condition - if (abs(dev - dev.old) / (0.1 + abs(dev)) < dev.tol) break - - # Update starting guesses for acceleration - Myadj <- Myadj - yadj - } - - # Return \eta - eta -} - -# Generate auxiliary list of indexes for different sub panels ---- - -get_index_list_ <- function(k.vars, data) { - indexes <- seq.int(0L, nrow(data) - 1L) - lapply(k.vars, function(x, indexes, data) { - split(indexes, data[[x]]) - }, indexes = indexes, data = data) -} - -# Compute score matrix ---- - -get_score_matrix_ <- function(object) { - # Extract required quantities from result list - control <- object[["control"]] - data <- object[["data"]] - eta <- object[["eta"]] - wt <- object[["weights"]] - family <- object[["family"]] - - # Update weights and dependent variable - y <- data[[1L]] - mu <- family[["linkinv"]](eta) - mu.eta <- family[["mu.eta"]](eta) - w <- (wt * mu.eta^2) / family[["variance"]](mu) - # nu <- (y - mu) / mu.eta - nu <- update_nu_(y, mu, mu.eta) - - # Center regressor matrix (if required) - if (control[["keep.mx"]]) { - MX <- object[["MX"]] - } else { - # Extract additional required quantities from result list - formula <- object[["formula"]] - k.vars <- names(object[["lvls.k"]]) - - # Generate auxiliary list of indexes to project out the fixed effects - k.list <- get_index_list_(k.vars, data) - - # Extract regressor matrix - X <- model.matrix(formula, data, rhs = 1L)[, -1L, drop = FALSE] - nms_sp <- attr(X, "dimnames")[[2L]] - attr(X, "dimnames") <- NULL - - # Center variables - MX <- center_variables_(X, NA_real_, w, k.list, control[["center.tol"]], 10000L, FALSE) - colnames(MX) <- nms_sp - } - - # Return score matrix - MX * (nu * w) -} - -# Returns suitable name for a temporary variable -temp_var_ <- function(data) { - repeat { - tmp.var <- paste0(sample(letters, 5L, replace = TRUE), collapse = "") - if (!(tmp.var %in% colnames(data))) { - break - } - } - tmp.var -} diff --git a/dev/glmfit.r b/dev/glmfit.r new file mode 100644 index 0000000..5967848 --- /dev/null +++ b/dev/glmfit.r @@ -0,0 +1,129 @@ +# Fitting algorithm (similar to glm.fit) ---- + +feglm_fit_ <- function(beta, eta, y, X, wt, k.list, family, control) { + # Extract control arguments + center.tol <- control[["center.tol"]] + dev.tol <- control[["dev.tol"]] + epsilon <- max(min(1.0e-07, dev.tol / 1000.0), .Machine[["double.eps"]]) + iter.max <- control[["iter.max"]] + trace <- control[["trace"]] + keep.mx <- control[["keep.mx"]] + + # Compute initial quantities for the maximization routine + nt <- length(y) + mu <- family[["linkinv"]](eta) + dev <- sum(family[["dev.resids"]](y, mu, wt)) + null.dev <- sum(family[["dev.resids"]](y, mean(y), wt)) + + # Generate temporary variables + Mnu <- as.matrix(numeric(nt)) + MX <- X + + # Start maximization of the log-likelihood + conv <- FALSE + for (iter in seq.int(iter.max)) { + # Store \eta, \beta, and deviance of the previous iteration + eta.old <- eta + beta.old <- beta + dev.old <- dev + + # Compute weights and dependent variable + mu.eta <- family[["mu.eta"]](eta) + w <- (wt * mu.eta^2) / family[["variance"]](mu) + nu <- (y - mu) / mu.eta + + # Centering variables + Mnu <- center_variables_(Mnu, nu, w, k.list, center.tol, 10000L, TRUE) + MX <- center_variables_(MX, NA_real_, w, k.list, center.tol, 10000L, FALSE) + + # Compute update step and update eta + # beta.upd <- as.vector(qr.solve(MX * w.tilde, Mnu * w.tilde, epsilon)) + # eta.upd <- nu - as.vector(Mnu - MX %*% beta.upd) + beta.upd <- solve_beta_(MX, Mnu, w, TRUE) + eta.upd <- solve_eta_(MX, Mnu, nu, beta.upd) + + # Step-halving with three checks + # 1. finite deviance + # 2. valid \eta and \mu + # 3. improvement as in glm2 + rho <- 1.0 + + for (inner.iter in seq.int(50L)) { + # eta <- eta.old + rho * eta.upd + # beta <- beta.old + rho * beta.upd + eta <- update_beta_eta_(eta.old, eta.upd, rho) + beta <- update_beta_eta_(beta.old, beta.upd, rho) + mu <- family[["linkinv"]](eta) + dev <- sum(family[["dev.resids"]](y, mu, wt)) + dev.crit <- is.finite(dev) + val.crit <- family[["valideta"]](eta) && family[["validmu"]](mu) + imp.crit <- (dev - dev.old) / (0.1 + abs(dev)) <= -dev.tol + if (dev.crit && val.crit && imp.crit) break + rho <- rho * 0.5 + } + + # Check if step-halving failed (deviance and invalid \eta or \mu) + if (!dev.crit || !val.crit) { + stop("Inner loop failed; cannot correct step size.", call. = FALSE) + } + + # Stop if we do not improve + if (!imp.crit) { + eta <- eta.old + beta <- beta.old + dev <- dev.old + mu <- family[["linkinv"]](eta) + } + + # Progress information + if (trace) { + cat( + "Deviance=", format(dev, digits = 5L, nsmall = 2L), "Iterations -", + iter, "\n" + ) + cat("Estimates=", format(beta, digits = 3L, nsmall = 2L), "\n") + } + + # Check convergence + dev.crit <- abs(dev - dev.old) / (0.1 + abs(dev)) + if (trace) cat("Stopping criterion=", dev.crit, "\n") + if (dev.crit < dev.tol) { + if (trace) cat("Convergence\n") + conv <- TRUE + break + } + + # Update starting guesses for acceleration + Mnu <- Mnu - nu + } + + # Information if convergence failed + if (!conv && trace) cat("Algorithm did not converge.\n") + + # Update weights and dependent variable + mu.eta <- family[["mu.eta"]](eta) + w <- (wt * mu.eta^2) / family[["variance"]](mu) + + # Center variables + MX <- center_variables_(X, NA_real_, w, k.list, center.tol, 10000L, FALSE) + # Recompute Hessian + H <- crossprod_(MX, w, TRUE, TRUE) + + # Generate result list + reslist <- list( + coefficients = beta, + eta = eta, + weights = wt, + Hessian = H, + deviance = dev, + null.deviance = null.dev, + conv = conv, + iter = iter + ) + + # Update result list + if (keep.mx) reslist[["MX"]] <- MX + + # Return result list + reslist +} diff --git a/src/05_glm_fit.cpp b/src/05_glm_fit.cpp index 9a43ce5..5765654 100644 --- a/src/05_glm_fit.cpp +++ b/src/05_glm_fit.cpp @@ -27,12 +27,28 @@ std::string tidy_family_(const std::string &family) { return fam; } +// Pairwise-maximum function +// Col pmax_(const Col &x, const Col &y) { +// Col res(x.n_elem); + +// // for (int i = 0; i < x.n_elem; ++i) { +// // res(i) = std::max(x(i), y(i)); +// // } + +// std::transform(x.begin(), x.end(), y.begin(), res.begin(), +// [](double a, double b) { return std::max(a, b); }); + +// return res; +// } + Col link_inv_(const Col &eta, const std::string &fam) { Col res(eta.n_elem); if (fam == "gaussian") { res = eta; } else if (fam == "poisson") { + // Col epsilon = 1e-7 * ones>(eta.n_elem); + // res = pmax_(exp(eta), epsilon); res = exp(eta); } else if (fam == "binomial") { // res = exp(eta) / (1.0 + exp(eta)); @@ -60,7 +76,7 @@ double dev_resids_(const Col &y, const Col &mu, } else if (fam == "poisson") { uvec p = find(y > 0.0); Col r = mu % wt; - r(p) = y(p) % log(y(p) / mu(p)) - (y(p) - mu(p)); + r(p) = wt(p) % (y(p) % log(y(p) / mu(p)) - (y(p) - mu(p))); res = 2.0 * accu(r); } else if (fam == "binomial") { uvec p = find(y != 0.0); @@ -192,8 +208,8 @@ Col variance_(const Col &mu, Col eta = as_Col(eta_r); Col y = as_Col(y_r); Mat MX = as_Mat(x_r); + // Mat MNU = nt * Mat(y.n_elem, 1, fill::ones); Mat MNU(y.n_elem, 1, fill::ones); - MNU = nt * MNU; Col wt = as_Col(wt_r); // Auxiliary variables (fixed) @@ -201,16 +217,18 @@ Col variance_(const Col &mu, std::string fam = tidy_family_(family); double center_tol = as_cpp(control["center_tol"]); double dev_tol = as_cpp(control["dev_tol"]); + // std::cout << "dev_tol: " << dev_tol << std::endl; int iter; int iter_max = as_cpp(control["iter_max"]); int iter_center_max = 10000; bool keep_mx = as_cpp(control["keep_mx"]); + int iter_inner, iter_inner_max = 50; + const int k = beta.n_elem; // Auxiliary variables (storage) Col mu = link_inv_(eta, fam); - Col ymean(y.n_elem, fill::ones); - ymean = mean(y) * ymean; + Col ymean = mean(y) * Col(y.n_elem, fill::ones); double dev = dev_resids_(y, mu, theta, wt, fam); double null_dev = dev_resids_(y, ymean, theta, wt, fam); @@ -218,29 +236,20 @@ Col variance_(const Col &mu, const int p = MX.n_cols; Col mu_eta(n), nu(n); Mat H(p, p), w(n, 1); - - // Maximize the log-likelihood - bool conv = false; - for (iter = 0; iter < iter_max; ++iter) { - // Auxiliary variables (fixed) - - int iter_inner, iter_inner_max = 50; - const int k = beta.n_elem; - bool dev_crit, val_crit, imp_crit; - double dev_old; - - // Auxiliary variables (storage) - - double rho = 1.0; - Col eta_upd(n), beta_upd(k), eta_old(n), beta_old(k); + bool dev_crit, val_crit, imp_crit; + double dev_old, dev_crit_ratio, rho; + Col eta_upd(n), beta_upd(k), eta_old(n), beta_old(k); - // Store eta, beta, and deviance of the previous iteration + // Maximize the log-likelihood - eta_old = eta; - beta_old = beta; - dev_old = dev; + for (iter = 0; iter < iter_max; ++iter) { + std::cout << "iter: " << iter << std::endl; + std::cout << "dev: " << dev << std::endl; + rho = 1.0; + dev_crit = false, val_crit = false, imp_crit = false; + eta_old = eta, beta_old = beta, dev_old = dev; // Compute weights and dependent variable @@ -250,8 +259,7 @@ Col variance_(const Col &mu, // Center variables - MNU = center_variables_(MNU.each_col() + nu, w, k_list, center_tol, - iter_center_max); + MNU = center_variables_(MNU + nu, w, k_list, center_tol, iter_center_max); MX = center_variables_(MX, w, k_list, center_tol, iter_center_max); // Compute update step and update eta @@ -270,9 +278,10 @@ Col variance_(const Col &mu, mu = link_inv_(eta, fam); dev = dev_resids_(y, mu, theta, wt, fam); dev_crit = is_finite(dev); - val_crit = valid_eta_(eta, fam) && valid_mu_(mu, fam); - imp_crit = ((dev - dev_old) / (0.1 + abs(dev))) <= -dev_tol; - if (dev_crit && val_crit && imp_crit) { + val_crit = (valid_eta_(eta, fam) && valid_mu_(mu, fam)); + imp_crit = ((dev - dev_old) / (0.1 + abs(dev)) <= -1.0 * dev_tol); + + if (dev_crit == true && val_crit == true && imp_crit == true) { break; } rho *= 0.5; @@ -295,8 +304,8 @@ Col variance_(const Col &mu, // Check convergence - dev_crit = abs(dev - dev_old) / (0.1 + abs(dev)); - if (dev_crit < dev_tol) { + dev_crit_ratio = abs(dev - dev_old) / (0.1 + abs(dev)); + if (dev_crit_ratio < dev_tol) { conv = true; break; } @@ -319,7 +328,7 @@ Col variance_(const Col &mu, // Center variables - MX = center_variables_(MX, w, k_list, center_tol, iter_center_max); + MX = center_variables_(as_Mat(x_r), w, k_list, center_tol, iter_center_max); // Recompute Hessian diff --git a/tests/testthat/test-errors.R b/tests/testthat/test-errors.R index cbc307b..5d5e566 100644 --- a/tests/testthat/test-errors.R +++ b/tests/testthat/test-errors.R @@ -51,7 +51,7 @@ test_that("error conditions", { fepoisson( trade ~ log_dist | rta, data = trade_panel_2002, - control = list(dev.tol = -1.0) + control = list(dev_tol = -1.0) ), "greater than zero" ) @@ -60,7 +60,7 @@ test_that("error conditions", { fepoisson( trade ~ log_dist | rta, data = trade_panel_2002, - control = list(iter.max = 0) + control = list(iter_max = 0) ), "at least one" ) diff --git a/tests/testthat/test-feglm.R b/tests/testthat/test-feglm.R index 0195876..66902d4 100644 --- a/tests/testthat/test-feglm.R +++ b/tests/testthat/test-feglm.R @@ -1,7 +1,11 @@ test_that("feglm is similar to glm", { # Gaussian ---- - # same as felm + # see felm + + # Poisson + + # see fepoisson # Binomial ---- diff --git a/tests/testthat/test-felm.R b/tests/testthat/test-felm.R index a9ce4c8..a28a4eb 100644 --- a/tests/testthat/test-felm.R +++ b/tests/testthat/test-felm.R @@ -1,10 +1,27 @@ test_that("felm works", { + load_all() m1 <- felm(mpg ~ wt | cyl, mtcars) m2 <- lm(mpg ~ wt + as.factor(cyl), mtcars) expect_equal(round(coef(m1), 5), round(coef(m2)[2], 5)) - expect_gt(length(fitted(m1)), 0) - expect_gt(length(predict(m1)), 0) - expect_gt(length(coef(m1)), 0) - expect_gt(length(coef(summary(m1))), 0) + + n <- nrow(mtcars) + expect_equal(length(fitted(m1)), n) + expect_equal(length(predict(m1)), n) + expect_equal(length(coef(m1)), 1) + expect_equal(length(coef(summary(m1))), 4) + + m1 <- felm(mpg ~ wt + qsec | cyl, mtcars) + m2 <- lm(mpg ~ wt + qsec + as.factor(cyl), mtcars) + + expect_equal(round(coef(m1), 5), round(coef(m2)[c(2,3)], 5)) + + m1 <- felm(mpg ~ wt + qsec | cyl + am, mtcars) + m2 <- lm(mpg ~ wt + qsec + as.factor(cyl) + as.factor(am), mtcars) + + expect_equal(round(coef(m1), 5), round(coef(m2)[c(2, 3)], 5)) + + m1 <- felm(mpg ~ wt + qsec | cyl + am | carb, mtcars) + + expect_equal(round(coef(m1), 5), round(coef(m2)[c(2, 3)], 5)) }) diff --git a/tests/testthat/test-fepoisson.R b/tests/testthat/test-fepoisson.R index bd64287..fcbec49 100644 --- a/tests/testthat/test-fepoisson.R +++ b/tests/testthat/test-fepoisson.R @@ -1,4 +1,19 @@ test_that("fepoisson is similar to fixest", { + # mod <- fepoisson( + # mpg ~ hp + wt | cyl, + # mtcars + # ) + + # mod <- fepoisson( + # mpg ~ hp + wt | cyl + am, + # mtcars + # ) + + # mod <- fepoisson( + # mpg ~ hp + wt + drat | cyl + am | carb, + # mtcars + # ) + mod <- fepoisson( trade ~ log_dist + lang + cntg + clny | exp_year + imp_year | pair, trade_panel From bf803ab694bed9cd09b6f7b3df5d71ff0c2ad854 Mon Sep 17 00:00:00 2001 From: Mauricio 'Pacha' Vargas Sepulveda Date: Fri, 19 Jul 2024 20:54:27 -0400 Subject: [PATCH 06/16] fix inner ratio for glm iteration stops --- R/cpp11.R | 4 +-- R/feglm.R | 3 +- src/04_linear_algebra.cpp | 10 +------ src/05_glm_fit.cpp | 52 ++++++++++++++++----------------- src/cpp11.cpp | 40 ++++++++++++------------- tests/testthat/test-fepoisson.R | 15 ---------- 6 files changed, 50 insertions(+), 74 deletions(-) diff --git a/R/cpp11.R b/R/cpp11.R index ba89c4a..ac2998a 100644 --- a/R/cpp11.R +++ b/R/cpp11.R @@ -56,8 +56,8 @@ solve_eta2_ <- function(yadj, myadj, offset, eta) { .Call(`_capybara_solve_eta2_`, yadj, myadj, offset, eta) } -feglm_fit_ <- function(beta_r, eta_r, y_r, x_r, nt, wt_r, theta, family, control, k_list) { - .Call(`_capybara_feglm_fit_`, beta_r, eta_r, y_r, x_r, nt, wt_r, theta, family, control, k_list) +feglm_fit_ <- function(beta_r, eta_r, y_r, x_r, wt_r, theta, family, control, k_list) { + .Call(`_capybara_feglm_fit_`, beta_r, eta_r, y_r, x_r, wt_r, theta, family, control, k_list) } kendall_cor_ <- function(m) { diff --git a/R/feglm.R b/R/feglm.R index 49c34e6..cd5140b 100644 --- a/R/feglm.R +++ b/R/feglm.R @@ -142,9 +142,8 @@ feglm <- function( # Fit generalized linear model ---- if (is.integer(y)) { y <- as.numeric(y) } - if (is.integer(nt)) { nt <- as.numeric(nt) } fit <- feglm_fit_( - beta, eta, y, X, nt, wt, 0.0, family[["family"]], control, k_list + beta, eta, y, X, wt, 0.0, family[["family"]], control, k_list ) y <- NULL diff --git a/src/04_linear_algebra.cpp b/src/04_linear_algebra.cpp index ad9ca62..f38b8de 100644 --- a/src/04_linear_algebra.cpp +++ b/src/04_linear_algebra.cpp @@ -142,17 +142,9 @@ Col solve_beta_(const Mat &MX, const Mat &MNU, if (!computable) { stop("QR decomposition failed"); - } else { - // backsolve - return solve(R, Q.t() * (MNU.each_col() % wtilde)); } -} - -// eta.upd <- nu - as.vector(Mnu - MX %*% beta.upd) -Col solve_eta_(const Mat &MX, const Mat &MNU, - const Col &nu, const Col &beta) { - return nu - MNU + MX * beta; + return solve(R, Q.t() * (MNU.each_col() % wtilde)); } // eta.upd <- yadj - as.vector(Myadj) + offset - eta diff --git a/src/05_glm_fit.cpp b/src/05_glm_fit.cpp index 5765654..0172b4e 100644 --- a/src/05_glm_fit.cpp +++ b/src/05_glm_fit.cpp @@ -47,9 +47,9 @@ Col link_inv_(const Col &eta, const std::string &fam) { if (fam == "gaussian") { res = eta; } else if (fam == "poisson") { - // Col epsilon = 1e-7 * ones>(eta.n_elem); - // res = pmax_(exp(eta), epsilon); res = exp(eta); + // Col epsilon = 2.220446e-16 * ones>(eta.n_elem); + // res = pmax_(exp(eta), epsilon); } else if (fam == "binomial") { // res = exp(eta) / (1.0 + exp(eta)); res = 1.0 / (1.0 + exp(-eta)); @@ -74,10 +74,10 @@ double dev_resids_(const Col &y, const Col &mu, if (fam == "gaussian") { res = accu(wt % square(y - mu)); } else if (fam == "poisson") { - uvec p = find(y > 0.0); + uvec p = find(y > 0); Col r = mu % wt; r(p) = wt(p) % (y(p) % log(y(p) / mu(p)) - (y(p) - mu(p))); - res = 2.0 * accu(r); + res = 2 * accu(r); } else if (fam == "binomial") { uvec p = find(y != 0.0); uvec q = find(y != 1.0); @@ -134,7 +134,7 @@ bool valid_mu_(const Col &mu, const std::string &fam) { if (fam == "gaussian") { res = true; } else if (fam == "poisson") { - res = is_finite(mu) && all(mu > 0.0); + res = is_finite(mu) && all(mu > 0); } else if (fam == "binomial") { res = is_finite(mu) && all(mu > 0.0 && mu < 1.0); } else if (fam == "gamma") { @@ -159,6 +159,8 @@ Col mu_eta_(Col &eta, const std::string &fam) { res.ones(); } else if (fam == "poisson") { res = exp(eta); + // Col epsilon = 2.220446e-16 * ones>(eta.n_elem); + // res = pmax_(exp(eta), epsilon); } else if (fam == "binomial") { res = 1.0 / (2.0 + exp(eta) + exp(-eta)); } else if (fam == "gamma") { @@ -174,8 +176,8 @@ Col mu_eta_(Col &eta, const std::string &fam) { return res; } -Col variance_(const Col &mu, - const double &theta, const std::string &fam) { +Col variance_(const Col &mu, const double &theta, + const std::string &fam) { Col res(mu.n_elem); if (fam == "gaussian") { @@ -197,19 +199,20 @@ Col variance_(const Col &mu, return res; } -[[cpp11::register]] list feglm_fit_( - const doubles &beta_r, const doubles &eta_r, const doubles &y_r, - const doubles_matrix<> &x_r, const double &nt, const doubles &wt_r, - const double &theta, const std::string &family, const list &control, - const list &k_list) { +[[cpp11::register]] list feglm_fit_(const doubles &beta_r, const doubles &eta_r, + const doubles &y_r, + const doubles_matrix<> &x_r, + const doubles &wt_r, + const double &theta, + const std::string &family, + const list &control, const list &k_list) { // Type conversion Col beta = as_Col(beta_r); Col eta = as_Col(eta_r); Col y = as_Col(y_r); Mat MX = as_Mat(x_r); - // Mat MNU = nt * Mat(y.n_elem, 1, fill::ones); - Mat MNU(y.n_elem, 1, fill::ones); + Mat MNU = Mat(y.n_elem, 1, fill::zeros); Col wt = as_Col(wt_r); // Auxiliary variables (fixed) @@ -217,9 +220,7 @@ Col variance_(const Col &mu, std::string fam = tidy_family_(family); double center_tol = as_cpp(control["center_tol"]); double dev_tol = as_cpp(control["dev_tol"]); - // std::cout << "dev_tol: " << dev_tol << std::endl; - int iter; - int iter_max = as_cpp(control["iter_max"]); + int iter, iter_max = as_cpp(control["iter_max"]); int iter_center_max = 10000; bool keep_mx = as_cpp(control["keep_mx"]); int iter_inner, iter_inner_max = 50; @@ -231,7 +232,7 @@ Col variance_(const Col &mu, Col ymean = mean(y) * Col(y.n_elem, fill::ones); double dev = dev_resids_(y, mu, theta, wt, fam); double null_dev = dev_resids_(y, ymean, theta, wt, fam); - + const int n = y.n_elem; const int p = MX.n_cols; Col mu_eta(n), nu(n); @@ -239,16 +240,13 @@ Col variance_(const Col &mu, bool conv = false; bool dev_crit, val_crit, imp_crit; - double dev_old, dev_crit_ratio, rho; + double dev_old, dev_crit_ratio, dev_crit_ratio_inner, rho; Col eta_upd(n), beta_upd(k), eta_old(n), beta_old(k); // Maximize the log-likelihood for (iter = 0; iter < iter_max; ++iter) { - std::cout << "iter: " << iter << std::endl; - std::cout << "dev: " << dev << std::endl; rho = 1.0; - dev_crit = false, val_crit = false, imp_crit = false; eta_old = eta, beta_old = beta, dev_old = dev; // Compute weights and dependent variable @@ -256,12 +254,12 @@ Col variance_(const Col &mu, mu_eta = mu_eta_(eta, fam); w = (wt % square(mu_eta)) / variance_(mu, theta, fam); nu = (y - mu) / mu_eta; - + // Center variables MNU = center_variables_(MNU + nu, w, k_list, center_tol, iter_center_max); MX = center_variables_(MX, w, k_list, center_tol, iter_center_max); - + // Compute update step and update eta // Step-halving with three checks: @@ -270,20 +268,22 @@ Col variance_(const Col &mu, // 3. improvement as in glm2 beta_upd = solve_beta_(MX, MNU, w); - eta_upd = solve_eta_(MX, MNU, nu, beta_upd); + eta_upd = nu - MNU + MX * beta_upd; for (iter_inner = 0; iter_inner < iter_inner_max; ++iter_inner) { eta = eta_old + (rho * eta_upd); beta = beta_old + (rho * beta_upd); mu = link_inv_(eta, fam); dev = dev_resids_(y, mu, theta, wt, fam); + dev_crit_ratio_inner = (dev - dev_old) / (0.1 + abs(dev_old)); dev_crit = is_finite(dev); val_crit = (valid_eta_(eta, fam) && valid_mu_(mu, fam)); - imp_crit = ((dev - dev_old) / (0.1 + abs(dev)) <= -1.0 * dev_tol); + imp_crit = (dev_crit_ratio_inner <= -1.0 * dev_tol); if (dev_crit == true && val_crit == true && imp_crit == true) { break; } + rho *= 0.5; } diff --git a/src/cpp11.cpp b/src/cpp11.cpp index 93f3dee..8218434 100644 --- a/src/cpp11.cpp +++ b/src/cpp11.cpp @@ -104,10 +104,10 @@ extern "C" SEXP _capybara_solve_eta2_(SEXP yadj, SEXP myadj, SEXP offset, SEXP e END_CPP11 } // 05_glm_fit.cpp -list feglm_fit_(const doubles & beta_r, const doubles & eta_r, const doubles & y_r, const doubles_matrix<> & x_r, const double & nt, const doubles & wt_r, const double & theta, const std::string & family, const list & control, const list & k_list); -extern "C" SEXP _capybara_feglm_fit_(SEXP beta_r, SEXP eta_r, SEXP y_r, SEXP x_r, SEXP nt, SEXP wt_r, SEXP theta, SEXP family, SEXP control, SEXP k_list) { +list feglm_fit_(const doubles & beta_r, const doubles & eta_r, const doubles & y_r, const doubles_matrix<> & x_r, const doubles & wt_r, const double & theta, const std::string & family, const list & control, const list & k_list); +extern "C" SEXP _capybara_feglm_fit_(SEXP beta_r, SEXP eta_r, SEXP y_r, SEXP x_r, SEXP wt_r, SEXP theta, SEXP family, SEXP control, SEXP k_list) { BEGIN_CPP11 - return cpp11::as_sexp(feglm_fit_(cpp11::as_cpp>(beta_r), cpp11::as_cpp>(eta_r), cpp11::as_cpp>(y_r), cpp11::as_cpp &>>(x_r), cpp11::as_cpp>(nt), cpp11::as_cpp>(wt_r), cpp11::as_cpp>(theta), cpp11::as_cpp>(family), cpp11::as_cpp>(control), cpp11::as_cpp>(k_list))); + return cpp11::as_sexp(feglm_fit_(cpp11::as_cpp>(beta_r), cpp11::as_cpp>(eta_r), cpp11::as_cpp>(y_r), cpp11::as_cpp &>>(x_r), cpp11::as_cpp>(wt_r), cpp11::as_cpp>(theta), cpp11::as_cpp>(family), cpp11::as_cpp>(control), cpp11::as_cpp>(k_list))); END_CPP11 } // 06_kendall_correlation.cpp @@ -127,23 +127,23 @@ extern "C" SEXP _capybara_pkendall_(SEXP Q, SEXP n) { extern "C" { static const R_CallMethodDef CallEntries[] = { - {"_capybara_feglm_fit_", (DL_FUNC) &_capybara_feglm_fit_, 10}, - {"_capybara_gamma_", (DL_FUNC) &_capybara_gamma_, 6}, - {"_capybara_get_alpha_", (DL_FUNC) &_capybara_get_alpha_, 3}, - {"_capybara_group_sums_", (DL_FUNC) &_capybara_group_sums_, 3}, - {"_capybara_group_sums_cov_", (DL_FUNC) &_capybara_group_sums_cov_, 3}, - {"_capybara_group_sums_spectral_", (DL_FUNC) &_capybara_group_sums_spectral_, 5}, - {"_capybara_group_sums_var_", (DL_FUNC) &_capybara_group_sums_var_, 2}, - {"_capybara_inv_", (DL_FUNC) &_capybara_inv_, 1}, - {"_capybara_kendall_cor_", (DL_FUNC) &_capybara_kendall_cor_, 1}, - {"_capybara_pkendall_", (DL_FUNC) &_capybara_pkendall_, 2}, - {"_capybara_rank_", (DL_FUNC) &_capybara_rank_, 1}, - {"_capybara_sandwich_", (DL_FUNC) &_capybara_sandwich_, 2}, - {"_capybara_solve_bias_", (DL_FUNC) &_capybara_solve_bias_, 4}, - {"_capybara_solve_eta2_", (DL_FUNC) &_capybara_solve_eta2_, 4}, - {"_capybara_solve_y_", (DL_FUNC) &_capybara_solve_y_, 2}, - {"_capybara_update_beta_eta_", (DL_FUNC) &_capybara_update_beta_eta_, 3}, - {"_capybara_update_nu_", (DL_FUNC) &_capybara_update_nu_, 3}, + {"_capybara_feglm_fit_", (DL_FUNC) &_capybara_feglm_fit_, 9}, + {"_capybara_gamma_", (DL_FUNC) &_capybara_gamma_, 6}, + {"_capybara_get_alpha_", (DL_FUNC) &_capybara_get_alpha_, 3}, + {"_capybara_group_sums_", (DL_FUNC) &_capybara_group_sums_, 3}, + {"_capybara_group_sums_cov_", (DL_FUNC) &_capybara_group_sums_cov_, 3}, + {"_capybara_group_sums_spectral_", (DL_FUNC) &_capybara_group_sums_spectral_, 5}, + {"_capybara_group_sums_var_", (DL_FUNC) &_capybara_group_sums_var_, 2}, + {"_capybara_inv_", (DL_FUNC) &_capybara_inv_, 1}, + {"_capybara_kendall_cor_", (DL_FUNC) &_capybara_kendall_cor_, 1}, + {"_capybara_pkendall_", (DL_FUNC) &_capybara_pkendall_, 2}, + {"_capybara_rank_", (DL_FUNC) &_capybara_rank_, 1}, + {"_capybara_sandwich_", (DL_FUNC) &_capybara_sandwich_, 2}, + {"_capybara_solve_bias_", (DL_FUNC) &_capybara_solve_bias_, 4}, + {"_capybara_solve_eta2_", (DL_FUNC) &_capybara_solve_eta2_, 4}, + {"_capybara_solve_y_", (DL_FUNC) &_capybara_solve_y_, 2}, + {"_capybara_update_beta_eta_", (DL_FUNC) &_capybara_update_beta_eta_, 3}, + {"_capybara_update_nu_", (DL_FUNC) &_capybara_update_nu_, 3}, {NULL, NULL, 0} }; } diff --git a/tests/testthat/test-fepoisson.R b/tests/testthat/test-fepoisson.R index fcbec49..bd64287 100644 --- a/tests/testthat/test-fepoisson.R +++ b/tests/testthat/test-fepoisson.R @@ -1,19 +1,4 @@ test_that("fepoisson is similar to fixest", { - # mod <- fepoisson( - # mpg ~ hp + wt | cyl, - # mtcars - # ) - - # mod <- fepoisson( - # mpg ~ hp + wt | cyl + am, - # mtcars - # ) - - # mod <- fepoisson( - # mpg ~ hp + wt + drat | cyl + am | carb, - # mtcars - # ) - mod <- fepoisson( trade ~ log_dist + lang + cntg + clny | exp_year + imp_year | pair, trade_panel From 512db873a38d98fe586eb51d1d0b662cfdb9f074 Mon Sep 17 00:00:00 2001 From: Mauricio 'Pacha' Vargas Sepulveda Date: Fri, 19 Jul 2024 22:34:20 -0400 Subject: [PATCH 07/16] fix fenegbin --- R/fenegbin.R | 25 +++++++++++++------------ 1 file changed, 13 insertions(+), 12 deletions(-) diff --git a/R/fenegbin.R b/R/fenegbin.R index 832f830..b7f3da5 100644 --- a/R/fenegbin.R +++ b/R/fenegbin.R @@ -98,7 +98,7 @@ fenegbin <- function( lvls_k <- vapply(nms_fe, length, integer(1)) # Generate auxiliary list of indexes for different sub panels ---- - k.list <- get_index_list_(k_vars, data) + k_list <- get_index_list_(k_vars, data) # Extract control arguments ---- tol <- control[["dev_tol"]] @@ -107,13 +107,7 @@ fenegbin <- function( trace <- control[["trace"]] # Initial negative binomial fit ---- - fit <- feglm_fit_( - beta, eta, y, X, nt, wt, theta, family[["family"]], control, k_list - ) - beta <- fit[["coefficients"]] - eta <- fit[["eta"]] - dev <- fit[["deviance"]] theta <- suppressWarnings( theta.ml( y = y, @@ -124,6 +118,14 @@ fenegbin <- function( ) ) + fit <- feglm_fit_( + beta, eta, y, X, wt, theta, family[["family"]], control, k_list + ) + + beta <- fit[["coefficients"]] + eta <- fit[["eta"]] + dev <- fit[["deviance"]] + # Alternate between fitting glm and \theta ---- conv <- FALSE for (iter in seq.int(iter_max)) { @@ -131,11 +133,6 @@ fenegbin <- function( dev.old <- dev theta.old <- theta family <- negative.binomial(theta, link) - family[["theta"]] <- theta - fit <- feglm_fit_(beta, eta, y, X, wt, k.list, family, control) - beta <- fit[["coefficients"]] - eta <- fit[["eta"]] - dev <- fit[["deviance"]] theta <- suppressWarnings( theta.ml( y = y, @@ -145,6 +142,10 @@ fenegbin <- function( trace = trace ) ) + fit <- feglm_fit_(beta, eta, y, X, wt, theta, family[["family"]], control, k_list) + beta <- fit[["coefficients"]] + eta <- fit[["eta"]] + dev <- fit[["deviance"]] # Progress information if (trace) { From 4d41597586d1a601fde020016227da8449b8394a Mon Sep 17 00:00:00 2001 From: Mauricio 'Pacha' Vargas Sepulveda Date: Sat, 20 Jul 2024 14:29:47 -0400 Subject: [PATCH 08/16] correct fixed_effects() with C++ changes --- R/fixed_effects.R | 29 +++++++++++++++-------------- tests/testthat/test-fepoisson.R | 21 +++++++++------------ 2 files changed, 24 insertions(+), 26 deletions(-) diff --git a/R/fixed_effects.R b/R/fixed_effects.R index ffcbd07..1009e8a 100644 --- a/R/fixed_effects.R +++ b/R/fixed_effects.R @@ -4,7 +4,7 @@ #' function has to be applied to our solution to get meaningful estimates of #' the fixed effects. #' @param object an object of class \code{"feglm"}. -#' @param alpha.tol tolerance level for the stopping condition. The algorithm is +#' @param alpha_tol tolerance level for the stopping condition. The algorithm is #' stopped at iteration \eqn{i} if \eqn{||\boldsymbol{\alpha}_{i} - #' \boldsymbol{\alpha}_{i - 1}||_{2} < tol ||\boldsymbol{\alpha}_{i - 1}|| #' {2}}{||\Delta \alpha|| < tol ||\alpha_old||}. Default is \code{1.0e-08}. @@ -23,7 +23,7 @@ #' #' fixed_effects(mod) #' @export -fixed_effects <- function(object = NULL, alpha.tol = 1.0e-08) { +fixed_effects <- function(object = NULL, alpha_tol = 1.0e-08) { # Check validity of 'object' if (is.null(object)) { stop("'object' has to be specified.", call. = FALSE) @@ -39,31 +39,32 @@ fixed_effects <- function(object = NULL, alpha.tol = 1.0e-08) { beta <- object[["coefficients"]] data <- object[["data"]] formula <- object[["formula"]] - lvls.k <- object[["lvls.k"]] - nms.fe <- object[["nms.fe"]] - k.vars <- names(lvls.k) - k <- length(lvls.k) + lvls_k <- object[["lvls_k"]] + nms_fe <- object[["nms_fe"]] + k_vars <- names(lvls_k) + k <- length(lvls_k) eta <- object[["eta"]] # Extract regressor matrix X <- model.matrix(formula, data, rhs = 1L)[, -1L, drop = FALSE] - nms.sp <- attr(X, "dimnames")[[2L]] + nms_sp <- attr(X, "dimnames")[[2L]] attr(X, "dimnames") <- NULL # Generate auxiliary list of indexes for different sub panels - k.list <- get_index_list_(k.vars, data) + k_list <- get_index_list_(k_vars, data) # Recover fixed effects by alternating the solutions of normal equations - pie <- eta - solve_y_(X, beta) - fe.list <- as.list(get_alpha_(pie, k.list, alpha.tol)) + # pie <- eta - solve_y_(X, beta) + pie <- eta - X %*% beta + fe_list <- as.list(get_alpha_(pie, k_list, alpha_tol)) # Assign names to the different fixed effects categories for (i in seq.int(k)) { - colnames(fe.list[[i]]) <- k.vars[i] - rownames(fe.list[[i]]) <- nms.fe[[i]] + colnames(fe_list[[i]]) <- k_vars[i] + rownames(fe_list[[i]]) <- nms_fe[[i]] } - names(fe.list) <- k.vars + names(fe_list) <- k_vars # Return list of estimated fixed effects - fe.list + fe_list } diff --git a/tests/testthat/test-fepoisson.R b/tests/testthat/test-fepoisson.R index bd64287..838c0b8 100644 --- a/tests/testthat/test-fepoisson.R +++ b/tests/testthat/test-fepoisson.R @@ -28,26 +28,23 @@ test_that("fepoisson is similar to fixest", { expect_visible(summary(mod, type = "cluster")) fes <- fixed_effects(mod) - + n <- unname(mod[["nobs"]]["nobs"]) + p <- dim(mod[["MX"]])[2] + expect_equal(length(fes), 2) + expect_equal(length(fitted(mod)), n) + expect_equal(length(predict(mod)), n) + expect_equal(length(coef(mod)), p) expect_equal(length(fes), 2) + expect_equal(round(fes[["exp_year"]][1:3], 3), c(10.195, 11.081, 11.260)) + expect_equal(round(fes[["imp_year"]][1:3], 3), c(0.226, -0.254, 1.115)) smod <- summary(mod) - expect_gt(length(fitted(mod)), 0) - expect_gt(length(predict(mod)), 0) - expect_gt(length(coef(mod)), 0) - expect_gt(length(coef(smod)), 0) - + expect_equal(length(coef(smod)[, 1]), p) expect_output(summary_formula_(smod)) expect_output(summary_family_(smod)) expect_output(summary_estimates_(smod, 3)) expect_output(summary_r2_(smod, 3)) expect_output(summary_nobs_(smod)) expect_output(summary_fisher_(smod)) - - fe <- fixed_effects(mod) - - expect_equal(length(fe), 2) - expect_equal(round(fe$exp_year[1:3], 3), c(10.195, 11.081, 11.260)) - expect_equal(round(fe$imp_year[1:3], 3), c(0.226, -0.254, 1.115)) }) From 2849790787a5052d097317d2655f978b52dcb306 Mon Sep 17 00:00:00 2001 From: Mauricio 'Pacha' Vargas Sepulveda Date: Sat, 20 Jul 2024 15:35:24 -0400 Subject: [PATCH 09/16] remove functions with large overhead --- .gitignore | 1 + R/bias_corr.R | 4 +- R/cpp11.R | 36 ------- R/feglm_offset.R | 2 - R/fixed_effects.R | 1 - R/helpers.R | 16 ++- src/04_linear_algebra.cpp | 150 ++++++--------------------- src/cpp11.cpp | 72 ------------- tests/testthat/test-linear_algebra.R | 19 ---- 9 files changed, 43 insertions(+), 258 deletions(-) delete mode 100644 tests/testthat/test-linear_algebra.R diff --git a/.gitignore b/.gitignore index 90e6405..d66d03b 100644 --- a/.gitignore +++ b/.gitignore @@ -10,5 +10,6 @@ src/*.dll inst/doc dev/1-s2.0-S0014292116300630-mmc1 dev/armadillo-codes +dev/*.rds README.html pkgdown diff --git a/R/bias_corr.R b/R/bias_corr.R index 55e350a..8f42bdb 100644 --- a/R/bias_corr.R +++ b/R/bias_corr.R @@ -180,11 +180,11 @@ bias_corr <- function( } # Compute bias-corrected structural parameters - beta <- solve_bias_(beta.uncorr, object[["Hessian"]], nt, -b) + beta <- beta.uncorr - solve(object[["Hessian"]] / nt, b) names(beta) <- nms.sp # Update \eta and first- and second-order derivatives - eta <- feglm_offset_(object, solve_y_(X, beta)) + eta <- feglm_offset_(object, X %*% beta) mu <- family[["linkinv"]](eta) mu.eta <- family[["mu.eta"]](eta) v <- wt * (y - mu) diff --git a/R/cpp11.R b/R/cpp11.R index ac2998a..2eb72a2 100644 --- a/R/cpp11.R +++ b/R/cpp11.R @@ -20,42 +20,6 @@ group_sums_cov_ <- function(M_r, N_r, jlist) { .Call(`_capybara_group_sums_cov_`, M_r, N_r, jlist) } -gamma_ <- function(mx, hessian, j, ppsi, v, nt_full) { - .Call(`_capybara_gamma_`, mx, hessian, j, ppsi, v, nt_full) -} - -inv_ <- function(h) { - .Call(`_capybara_inv_`, h) -} - -rank_ <- function(x) { - .Call(`_capybara_rank_`, x) -} - -solve_bias_ <- function(beta_uncorr, hessian, nt, b) { - .Call(`_capybara_solve_bias_`, beta_uncorr, hessian, nt, b) -} - -solve_y_ <- function(a, x) { - .Call(`_capybara_solve_y_`, a, x) -} - -sandwich_ <- function(a, b) { - .Call(`_capybara_sandwich_`, a, b) -} - -update_beta_eta_ <- function(old, upd, param) { - .Call(`_capybara_update_beta_eta_`, old, upd, param) -} - -update_nu_ <- function(y, mu, mu_eta) { - .Call(`_capybara_update_nu_`, y, mu, mu_eta) -} - -solve_eta2_ <- function(yadj, myadj, offset, eta) { - .Call(`_capybara_solve_eta2_`, yadj, myadj, offset, eta) -} - feglm_fit_ <- function(beta_r, eta_r, y_r, x_r, wt_r, theta, family, control, k_list) { .Call(`_capybara_feglm_fit_`, beta_r, eta_r, y_r, x_r, wt_r, theta, family, control, k_list) } diff --git a/R/feglm_offset.R b/R/feglm_offset.R index 7ffdc6a..b6af87e 100644 --- a/R/feglm_offset.R +++ b/R/feglm_offset.R @@ -55,7 +55,6 @@ feglm_offset_ <- function(object, offset) { # Centering dependent variable and compute \eta update Myadj <- center_variables_(Myadj, yadj, w, k.list, center.tol, 10000L, TRUE) eta.upd <- yadj - drop(Myadj) + offset - eta - # eta.upd <- solve_eta2_(yadj, Myadj, offset, eta) # Step-halving with three checks # 1. finite deviance @@ -64,7 +63,6 @@ feglm_offset_ <- function(object, offset) { rho <- 1.0 for (inner.iter in seq.int(50L)) { eta <- eta.old + rho * eta.upd - # eta <- update_beta_eta_(eta.old, eta.upd, rho) mu <- family[["linkinv"]](eta) dev <- sum(family[["dev.resids"]](y, mu, wt)) dev.crit <- is.finite(dev) diff --git a/R/fixed_effects.R b/R/fixed_effects.R index 1009e8a..b127902 100644 --- a/R/fixed_effects.R +++ b/R/fixed_effects.R @@ -54,7 +54,6 @@ fixed_effects <- function(object = NULL, alpha_tol = 1.0e-08) { k_list <- get_index_list_(k_vars, data) # Recover fixed effects by alternating the solutions of normal equations - # pie <- eta - solve_y_(X, beta) pie <- eta - X %*% beta fe_list <- as.list(get_alpha_(pie, k_list, alpha_tol)) diff --git a/R/helpers.R b/R/helpers.R index 886d5af..ea13420 100644 --- a/R/helpers.R +++ b/R/helpers.R @@ -241,7 +241,7 @@ model_response_ <- function(data, formula) { } check_linear_dependence_ <- function(X, p) { - if (rank_(X) < p) { + if (qr(X)$rank < p) { stop("Linear dependent terms detected.", call. = FALSE) } } @@ -297,7 +297,7 @@ start_guesses_ <- function( # Set starting guesses beta <- beta_start - eta <- solve_y_(X, beta) + eta <- X %*% beta } else { # Validity of input argument (eta_start) if (length(eta_start) != nt) { @@ -354,9 +354,8 @@ get_score_matrix_ <- function(object) { mu <- family[["linkinv"]](eta) mu.eta <- family[["mu.eta"]](eta) w <- (wt * mu.eta^2) / family[["variance"]](mu) - # nu <- (y - mu) / mu.eta - nu <- update_nu_(y, mu, mu.eta) - + nu <- (y - mu) / mu.eta + # Center regressor matrix (if required) if (control[["keep_mx"]]) { MX <- object[["MX"]] @@ -393,3 +392,10 @@ temp_var_ <- function(data) { } tmp.var } + +# Gamma computation (APES) ---- + +gamma_ <- function(MX, H, J, PPsi, v, nt) { + inv_nt <- 1.0 / nt + (MX %*% solve(H * inv_nt, J) - PPsi) * v * inv_nt +} diff --git a/src/04_linear_algebra.cpp b/src/04_linear_algebra.cpp index f38b8de..a6480b3 100644 --- a/src/04_linear_algebra.cpp +++ b/src/04_linear_algebra.cpp @@ -1,5 +1,34 @@ #include "00_main.h" +// WinvJ < -solve(object[["Hessian"]] / nt.full, J) +// Gamma < -(MX %*% WinvJ - PPsi) * v / nt.full + +// [[cpp11::register]] doubles_matrix<> +// gamma_(const doubles_matrix<> &mx, const doubles_matrix<> &hessian, +// const doubles_matrix<> &j, const doubles_matrix<> &ppsi, +// const doubles &v, const SEXP &nt_full) { +// double inv_N = 1.0 / as_cpp(nt_full); + +// Mat res = +// (as_Mat(mx) * solve(as_Mat(hessian) * inv_N, as_Mat(j))) - as_Mat(ppsi); +// res = (res.each_col() % as_Mat(v)) * inv_N; + +// return as_doubles_matrix(res); +// } + +// solve(H) + +// [[cpp11::register]] doubles_matrix<> inv_(const doubles_matrix<> &h) { +// Mat H = inv(as_Mat(h)); +// return as_doubles_matrix(H); +// } + +// qr(X)$rank + +// [[cpp11::register]] int rank_(const doubles_matrix<> &x) { +// return arma::rank(as_Mat(x)); // SVD +// } + // Y <- crossprod(X) // Y <- t(X) %*% X @@ -23,115 +52,6 @@ Mat crossprod_(const Mat &X, const Col &w, const int &n, return res; } -// WinvJ < -solve(object[["Hessian"]] / nt.full, J) -// Gamma < -(MX %*% WinvJ - PPsi) * v / nt.full -// V < -crossprod(Gamma) - -[[cpp11::register]] doubles_matrix<> -gamma_(const doubles_matrix<> &mx, const doubles_matrix<> &hessian, - const doubles_matrix<> &j, const doubles_matrix<> &ppsi, - const doubles &v, const SEXP &nt_full) { - Mat MX = as_Mat(mx); - Mat H = as_Mat(hessian); - Mat J = as_Mat(j); - Mat PPsi = as_Mat(ppsi); - Mat V = as_Mat(v); - - double inv_N = 1.0 / as_cpp(nt_full); - - Mat res = (MX * solve(H * inv_N, J)) - PPsi; - res = (res.each_col() % V) * inv_N; - - return as_doubles_matrix(res); -} - -// solve(H) - -[[cpp11::register]] doubles_matrix<> inv_(const doubles_matrix<> &h) { - Mat H = inv(as_Mat(h)); - return as_doubles_matrix(H); -} - -// qr(X)$rank - -[[cpp11::register]] int rank_(const doubles_matrix<> &x) { - Mat X = as_Mat(x); - return arma::rank(X); // SVD -} - -// Beta_uncorr - solve(H / nt, B) - -[[cpp11::register]] doubles solve_bias_(const doubles &beta_uncorr, - const doubles_matrix<> &hessian, - const double &nt, const doubles &b) { - Mat Beta_uncorr = as_Mat(beta_uncorr); - Mat H = as_Mat(hessian); - Mat B = as_Mat(b); - - double inv_nt = 1.0 / nt; - - return as_doubles(Beta_uncorr - solve(H * inv_nt, B)); -} - -// A %*% x - -[[cpp11::register]] doubles solve_y_(const doubles_matrix<> &a, - const doubles &x) { - Mat A = as_Mat(a); - Mat X = as_Mat(x); - - return as_doubles(A * X); -} - -// A %*% B %*% A - -[[cpp11::register]] doubles_matrix<> sandwich_(const doubles_matrix<> &a, - const doubles_matrix<> &b) { - Mat A = as_Mat(a); - Mat B = as_Mat(b); - - Mat res = A * (B * A); - return as_doubles_matrix(res); -} - -// eta <- eta.old + rho * eta.upd - -[[cpp11::register]] doubles -update_beta_eta_(const doubles &old, const doubles &upd, const double ¶m) { - int N = old.size(); - writable::doubles res(N); - - double *old_data = REAL(old); - double *upd_data = REAL(upd); - -#ifdef _OPENMP -#pragma omp parallel for schedule(static) -#endif - for (int n = 0; n < N; ++n) { - res[n] = old_data[n] + (upd_data[n] * param); - } - - return res; -} - -// nu <- (y - mu) / mu.eta - -[[cpp11::register]] doubles update_nu_(const SEXP &y, const SEXP &mu, - const SEXP &mu_eta) { - int n = Rf_length(y); - writable::doubles res(n); - - double *y_data = REAL(y); - double *mu_data = REAL(mu); - double *mu_eta_data = REAL(mu_eta); - - for (int i = 0; i < n; ++i) { - res[i] = (y_data[i] - mu_data[i]) / mu_eta_data[i]; - } - - return res; -} - Col solve_beta_(const Mat &MX, const Mat &MNU, const Col &w) { Col wtilde = sqrt(w); @@ -146,15 +66,3 @@ Col solve_beta_(const Mat &MX, const Mat &MNU, return solve(R, Q.t() * (MNU.each_col() % wtilde)); } - -// eta.upd <- yadj - as.vector(Myadj) + offset - eta - -[[cpp11::register]] doubles solve_eta2_(const doubles &yadj, const doubles_matrix<> &myadj, - const doubles &offset, const doubles &eta) { - Mat Yadj = as_Mat(yadj); - Mat Myadj = as_Mat(myadj); - Mat Offset = as_Mat(offset); - Mat Eta = as_Mat(eta); - - return as_doubles(Yadj - Myadj + Offset - Eta); -} diff --git a/src/cpp11.cpp b/src/cpp11.cpp index 8218434..0beb056 100644 --- a/src/cpp11.cpp +++ b/src/cpp11.cpp @@ -40,69 +40,6 @@ extern "C" SEXP _capybara_group_sums_cov_(SEXP M_r, SEXP N_r, SEXP jlist) { return cpp11::as_sexp(group_sums_cov_(cpp11::as_cpp &>>(M_r), cpp11::as_cpp &>>(N_r), cpp11::as_cpp>(jlist))); END_CPP11 } -// 04_linear_algebra.cpp -doubles_matrix<> gamma_(const doubles_matrix<> & mx, const doubles_matrix<> & hessian, const doubles_matrix<> & j, const doubles_matrix<> & ppsi, const doubles & v, const SEXP & nt_full); -extern "C" SEXP _capybara_gamma_(SEXP mx, SEXP hessian, SEXP j, SEXP ppsi, SEXP v, SEXP nt_full) { - BEGIN_CPP11 - return cpp11::as_sexp(gamma_(cpp11::as_cpp &>>(mx), cpp11::as_cpp &>>(hessian), cpp11::as_cpp &>>(j), cpp11::as_cpp &>>(ppsi), cpp11::as_cpp>(v), cpp11::as_cpp>(nt_full))); - END_CPP11 -} -// 04_linear_algebra.cpp -doubles_matrix<> inv_(const doubles_matrix<> & h); -extern "C" SEXP _capybara_inv_(SEXP h) { - BEGIN_CPP11 - return cpp11::as_sexp(inv_(cpp11::as_cpp &>>(h))); - END_CPP11 -} -// 04_linear_algebra.cpp -int rank_(const doubles_matrix<> & x); -extern "C" SEXP _capybara_rank_(SEXP x) { - BEGIN_CPP11 - return cpp11::as_sexp(rank_(cpp11::as_cpp &>>(x))); - END_CPP11 -} -// 04_linear_algebra.cpp -doubles solve_bias_(const doubles & beta_uncorr, const doubles_matrix<> & hessian, const double & nt, const doubles & b); -extern "C" SEXP _capybara_solve_bias_(SEXP beta_uncorr, SEXP hessian, SEXP nt, SEXP b) { - BEGIN_CPP11 - return cpp11::as_sexp(solve_bias_(cpp11::as_cpp>(beta_uncorr), cpp11::as_cpp &>>(hessian), cpp11::as_cpp>(nt), cpp11::as_cpp>(b))); - END_CPP11 -} -// 04_linear_algebra.cpp -doubles solve_y_(const doubles_matrix<> & a, const doubles & x); -extern "C" SEXP _capybara_solve_y_(SEXP a, SEXP x) { - BEGIN_CPP11 - return cpp11::as_sexp(solve_y_(cpp11::as_cpp &>>(a), cpp11::as_cpp>(x))); - END_CPP11 -} -// 04_linear_algebra.cpp -doubles_matrix<> sandwich_(const doubles_matrix<> & a, const doubles_matrix<> & b); -extern "C" SEXP _capybara_sandwich_(SEXP a, SEXP b) { - BEGIN_CPP11 - return cpp11::as_sexp(sandwich_(cpp11::as_cpp &>>(a), cpp11::as_cpp &>>(b))); - END_CPP11 -} -// 04_linear_algebra.cpp -doubles update_beta_eta_(const doubles & old, const doubles & upd, const double & param); -extern "C" SEXP _capybara_update_beta_eta_(SEXP old, SEXP upd, SEXP param) { - BEGIN_CPP11 - return cpp11::as_sexp(update_beta_eta_(cpp11::as_cpp>(old), cpp11::as_cpp>(upd), cpp11::as_cpp>(param))); - END_CPP11 -} -// 04_linear_algebra.cpp -doubles update_nu_(const SEXP & y, const SEXP & mu, const SEXP & mu_eta); -extern "C" SEXP _capybara_update_nu_(SEXP y, SEXP mu, SEXP mu_eta) { - BEGIN_CPP11 - return cpp11::as_sexp(update_nu_(cpp11::as_cpp>(y), cpp11::as_cpp>(mu), cpp11::as_cpp>(mu_eta))); - END_CPP11 -} -// 04_linear_algebra.cpp -doubles solve_eta2_(const doubles & yadj, const doubles_matrix<> & myadj, const doubles & offset, const doubles & eta); -extern "C" SEXP _capybara_solve_eta2_(SEXP yadj, SEXP myadj, SEXP offset, SEXP eta) { - BEGIN_CPP11 - return cpp11::as_sexp(solve_eta2_(cpp11::as_cpp>(yadj), cpp11::as_cpp &>>(myadj), cpp11::as_cpp>(offset), cpp11::as_cpp>(eta))); - END_CPP11 -} // 05_glm_fit.cpp list feglm_fit_(const doubles & beta_r, const doubles & eta_r, const doubles & y_r, const doubles_matrix<> & x_r, const doubles & wt_r, const double & theta, const std::string & family, const list & control, const list & k_list); extern "C" SEXP _capybara_feglm_fit_(SEXP beta_r, SEXP eta_r, SEXP y_r, SEXP x_r, SEXP wt_r, SEXP theta, SEXP family, SEXP control, SEXP k_list) { @@ -128,22 +65,13 @@ extern "C" SEXP _capybara_pkendall_(SEXP Q, SEXP n) { extern "C" { static const R_CallMethodDef CallEntries[] = { {"_capybara_feglm_fit_", (DL_FUNC) &_capybara_feglm_fit_, 9}, - {"_capybara_gamma_", (DL_FUNC) &_capybara_gamma_, 6}, {"_capybara_get_alpha_", (DL_FUNC) &_capybara_get_alpha_, 3}, {"_capybara_group_sums_", (DL_FUNC) &_capybara_group_sums_, 3}, {"_capybara_group_sums_cov_", (DL_FUNC) &_capybara_group_sums_cov_, 3}, {"_capybara_group_sums_spectral_", (DL_FUNC) &_capybara_group_sums_spectral_, 5}, {"_capybara_group_sums_var_", (DL_FUNC) &_capybara_group_sums_var_, 2}, - {"_capybara_inv_", (DL_FUNC) &_capybara_inv_, 1}, {"_capybara_kendall_cor_", (DL_FUNC) &_capybara_kendall_cor_, 1}, {"_capybara_pkendall_", (DL_FUNC) &_capybara_pkendall_, 2}, - {"_capybara_rank_", (DL_FUNC) &_capybara_rank_, 1}, - {"_capybara_sandwich_", (DL_FUNC) &_capybara_sandwich_, 2}, - {"_capybara_solve_bias_", (DL_FUNC) &_capybara_solve_bias_, 4}, - {"_capybara_solve_eta2_", (DL_FUNC) &_capybara_solve_eta2_, 4}, - {"_capybara_solve_y_", (DL_FUNC) &_capybara_solve_y_, 2}, - {"_capybara_update_beta_eta_", (DL_FUNC) &_capybara_update_beta_eta_, 3}, - {"_capybara_update_nu_", (DL_FUNC) &_capybara_update_nu_, 3}, {NULL, NULL, 0} }; } diff --git a/tests/testthat/test-linear_algebra.R b/tests/testthat/test-linear_algebra.R deleted file mode 100644 index 4424410..0000000 --- a/tests/testthat/test-linear_algebra.R +++ /dev/null @@ -1,19 +0,0 @@ -test_that("solve_bias_ works", { - A <- matrix(c(1, 0, 0, 1), nrow = 2, ncol = 2) - x <- c(2, 2) - expect_equal(as.vector(A %*% x), solve_y_(A, x)) - expect_equal(x - solve(A, x), solve_bias_(x, A, 1, x)) -}) - -test_that("inv_ works", { - A <- matrix(c(1, 0, 0, 1, 1, 0, 0, 1, 1), nrow = 3, ncol = 3, byrow = TRUE) - expect_equal(solve(A), inv_(A)) - - # non-invertible matrix - A <- matrix(c(1, 0, 0, 1, 0, 0, 0, 1, 1), nrow = 3, ncol = 3, byrow = TRUE) - expect_error(inv_(A)) - - # non-square matrix - A <- matrix(c(1, 0, 0, 1, 1, 0), nrow = 2, ncol = 3, byrow = TRUE) - expect_error(inv_(A)) -}) From c59b7469c559910e1698b297628c69c6ed3cbd1f Mon Sep 17 00:00:00 2001 From: Mauricio 'Pacha' Vargas Sepulveda Date: Sat, 20 Jul 2024 22:36:41 -0400 Subject: [PATCH 10/16] mimic logit from base R --- src/05_glm_fit.cpp | 99 ++++++++++++++++++++++++++++--------- tests/testthat/test-feglm.R | 2 +- 2 files changed, 78 insertions(+), 23 deletions(-) diff --git a/src/05_glm_fit.cpp b/src/05_glm_fit.cpp index 0172b4e..ef3e125 100644 --- a/src/05_glm_fit.cpp +++ b/src/05_glm_fit.cpp @@ -41,18 +41,80 @@ std::string tidy_family_(const std::string &family) { // return res; // } +// static const double THRESH = 30.; +// static const double MTHRESH = -30.; +// static const double DBL_EPSILON = std::numeric_limits::epsilon(); +// static const double INVEPS = 1 / DBL_EPSILON; + +// Col link_inv_logit_(const Col &x) { +// Col res(x.n_elem); + +// uword i, n = x.n_elem; +// for (i = 0; i < n; ++i) { +// if (x(i) < MTHRESH) { +// res(i) = DBL_EPSILON; +// } else if (x(i) > THRESH) { +// res(i) = INVEPS; +// } else { +// double y = exp(x(i)); +// res(i) = y / (1 + y); +// } +// } + +// return res; +// } + +Col link_inv_logit_(const Col &x) { + Col y = exp(x); + return y / (1 + y); +} + +// Adapted from binomial_dev_resids() +// in R base it can be found in src/library/stats/src/family.c +// unfortunately the functions that work with a SEXP won't work with a Col<> +Col dev_resids_logit_(const Col &y, const Col &mu) { + Col res(y.n_elem, fill::zeros); + + uvec p = find(y != 0); + res(p) = y(p) % log(y(p) / mu(p)); + + return res; +} + +// Col mu_eta_logit_(const Col &x) { +// Col res(x.n_elem); + +// uword i, n = x.n_elem; + +// for (i = 0; i < n; ++i) { +// double opexp = 1 + exp(x(i)); + +// if ((x(i) > THRESH) || (x(i) < MTHRESH)){ +// res(i) = DBL_EPSILON; +// } else { +// res(i) = exp(x(i)) / (opexp * opexp); +// } +// } + +// return res; +// } + +Col mu_eta_logit_(const Col &x) { + Col y = exp(x); + return y / square(1 + y); +} + Col link_inv_(const Col &eta, const std::string &fam) { Col res(eta.n_elem); if (fam == "gaussian") { res = eta; } else if (fam == "poisson") { - res = exp(eta); // Col epsilon = 2.220446e-16 * ones>(eta.n_elem); // res = pmax_(exp(eta), epsilon); + res = exp(eta); } else if (fam == "binomial") { - // res = exp(eta) / (1.0 + exp(eta)); - res = 1.0 / (1.0 + exp(-eta)); + res = link_inv_logit_(eta); } else if (fam == "gamma") { res = 1.0 / eta; } else if (fam == "inverse_gaussian") { @@ -79,13 +141,8 @@ double dev_resids_(const Col &y, const Col &mu, r(p) = wt(p) % (y(p) % log(y(p) / mu(p)) - (y(p) - mu(p))); res = 2 * accu(r); } else if (fam == "binomial") { - uvec p = find(y != 0.0); - uvec q = find(y != 1.0); - Col r = y / mu; - Col s = (1.0 - y) / (1.0 - mu); - r(p) = log(r(p)); - s(q) = log(s(q)); - res = 2.0 * accu(wt % (y % r + (1.0 - y) % s)); + res = 2 * accu(wt % (dev_resids_logit_(y, mu) + + dev_resids_logit_(1 - y, 1 - mu))); } else if (fam == "gamma") { uvec p = find(y == 0.0); Col r = y / mu; @@ -94,11 +151,11 @@ double dev_resids_(const Col &y, const Col &mu, } else if (fam == "inverse_gaussian") { res = accu(wt % square(y - mu) / (y % square(mu))); } else if (fam == "negative_binomial") { - uvec p = find(y < 1.0); + uvec p = find(y < 1); Col r = y; r.elem(p).fill(1.0); - res = 2.0 * accu( - wt % (y % log(r / mu) - (y + theta) % log((y + theta) / (mu + theta)))); + res = 2 * accu(wt % (y % log(r / mu) - + (y + theta) % log((y + theta) / (mu + theta)))); } else { stop("Unknown family"); } @@ -136,7 +193,7 @@ bool valid_mu_(const Col &mu, const std::string &fam) { } else if (fam == "poisson") { res = is_finite(mu) && all(mu > 0); } else if (fam == "binomial") { - res = is_finite(mu) && all(mu > 0.0 && mu < 1.0); + res = is_finite(mu) && all(mu > 0 && mu < 1); } else if (fam == "gamma") { res = is_finite(mu) && all(mu > 0.0); } else if (fam == "inverse_gaussian") { @@ -150,7 +207,7 @@ bool valid_mu_(const Col &mu, const std::string &fam) { return res; } -// inverse link mu = g^-1 (eta), then mu_eta = d mu / d eta +// mu_eta = d link_inv / d eta = d mu / d eta Col mu_eta_(Col &eta, const std::string &fam) { Col res(eta.n_elem); @@ -159,14 +216,12 @@ Col mu_eta_(Col &eta, const std::string &fam) { res.ones(); } else if (fam == "poisson") { res = exp(eta); - // Col epsilon = 2.220446e-16 * ones>(eta.n_elem); - // res = pmax_(exp(eta), epsilon); } else if (fam == "binomial") { - res = 1.0 / (2.0 + exp(eta) + exp(-eta)); + res = mu_eta_logit_(eta); } else if (fam == "gamma") { - res = -1.0 / square(eta); + res = -1 / square(eta); } else if (fam == "inverse_gaussian") { - res = 1.0 / (2.0 * pow(eta, 1.5)); + res = -1 / (2 * pow(eta, 1.5)); } else if (fam == "negative_binomial") { res = exp(eta); } else { @@ -185,7 +240,7 @@ Col variance_(const Col &mu, const double &theta, } else if (fam == "poisson") { res = mu; } else if (fam == "binomial") { - res = mu % (1.0 - mu); + res = mu % (1 - mu); } else if (fam == "gamma") { res = square(mu); } else if (fam == "inverse_gaussian") { @@ -278,7 +333,7 @@ Col variance_(const Col &mu, const double &theta, dev_crit_ratio_inner = (dev - dev_old) / (0.1 + abs(dev_old)); dev_crit = is_finite(dev); val_crit = (valid_eta_(eta, fam) && valid_mu_(mu, fam)); - imp_crit = (dev_crit_ratio_inner <= -1.0 * dev_tol); + imp_crit = (dev_crit_ratio_inner <= -dev_tol); if (dev_crit == true && val_crit == true && imp_crit == true) { break; diff --git a/tests/testthat/test-feglm.R b/tests/testthat/test-feglm.R index 66902d4..7de742f 100644 --- a/tests/testthat/test-feglm.R +++ b/tests/testthat/test-feglm.R @@ -10,7 +10,7 @@ test_that("feglm is similar to glm", { # Binomial ---- mod <- feglm( - am ~ wt + mpg| cyl, + am ~ wt + mpg | cyl, mtcars, family = binomial() ) From d936d51c1755ff88b84ac80159b75a102086417a Mon Sep 17 00:00:00 2001 From: Mauricio 'Pacha' Vargas Sepulveda Date: Sun, 21 Jul 2024 12:57:36 -0400 Subject: [PATCH 11/16] refactor deviance --- src/05_glm_fit.cpp | 73 ++++++++++++++++++++++++++++++++-------------- 1 file changed, 51 insertions(+), 22 deletions(-) diff --git a/src/05_glm_fit.cpp b/src/05_glm_fit.cpp index ef3e125..7516bbe 100644 --- a/src/05_glm_fit.cpp +++ b/src/05_glm_fit.cpp @@ -69,16 +69,56 @@ Col link_inv_logit_(const Col &x) { return y / (1 + y); } +double dev_resids_poisson_(const Col &y, const Col &mu, + const Col &wt) { + Col r = mu % wt; + + uvec p = find(y > 0); + r(p) = wt(p) % (y(p) % log(y(p) / mu(p)) - (y(p) - mu(p))); + + return 2 * accu(r); +} + // Adapted from binomial_dev_resids() // in R base it can be found in src/library/stats/src/family.c // unfortunately the functions that work with a SEXP won't work with a Col<> -Col dev_resids_logit_(const Col &y, const Col &mu) { - Col res(y.n_elem, fill::zeros); +double dev_resids_logit_(const Col &y, const Col &mu, const Col &wt) { + Col r(y.n_elem, fill::zeros); + Col s(y.n_elem, fill::zeros); - uvec p = find(y != 0); - res(p) = y(p) % log(y(p) / mu(p)); + uvec p = find(y == 1); + uvec q = find(y == 0); + r(p) = y(p) % log(y(p) / mu(p)); + s(q) = (1 - y(q)) % log((1 - y(q)) / (1 - mu(q))); - return res; + return 2 * accu(wt % (r + s)); +} + +double dev_resids_gamma_(const Col &y, const Col &mu, + const Col &wt) { + Col r = y / mu; + + uvec p = find(y == 0); + r.elem(p).fill(1.0); + r = wt % (log(r) - (y - mu) / mu); + + return -2 * accu(r); +} + +double dev_resids_invgaussian_(const Col &y, const Col &mu, + const Col &wt) { + return accu(wt % square(y - mu) / (y % square(mu))); +} + +double dev_resids_negbin_(const Col &y, const Col &mu, + const double &theta, const Col &wt) { + Col r = y; + + uvec p = find(y < 1); + r.elem(p).fill(1.0); + r = wt % (y % log(r / mu) - (y + theta) % log((y + theta) / (mu + theta))); + + return 2 * accu(r); } // Col mu_eta_logit_(const Col &x) { @@ -136,26 +176,15 @@ double dev_resids_(const Col &y, const Col &mu, if (fam == "gaussian") { res = accu(wt % square(y - mu)); } else if (fam == "poisson") { - uvec p = find(y > 0); - Col r = mu % wt; - r(p) = wt(p) % (y(p) % log(y(p) / mu(p)) - (y(p) - mu(p))); - res = 2 * accu(r); + res = dev_resids_poisson_(y, mu, wt); } else if (fam == "binomial") { - res = 2 * accu(wt % (dev_resids_logit_(y, mu) + - dev_resids_logit_(1 - y, 1 - mu))); + res = dev_resids_logit_(y, mu, wt); } else if (fam == "gamma") { - uvec p = find(y == 0.0); - Col r = y / mu; - r.elem(p).fill(1.0); - res = -2.0 * accu(wt % (log(r) - (y - mu) / mu)); + res = dev_resids_gamma_(y, mu, wt); } else if (fam == "inverse_gaussian") { - res = accu(wt % square(y - mu) / (y % square(mu))); + res = dev_resids_invgaussian_(y, mu, wt); } else if (fam == "negative_binomial") { - uvec p = find(y < 1); - Col r = y; - r.elem(p).fill(1.0); - res = 2 * accu(wt % (y % log(r / mu) - - (y + theta) % log((y + theta) / (mu + theta)))); + res = dev_resids_negbin_(y, mu, theta, wt); } else { stop("Unknown family"); } @@ -333,7 +362,7 @@ Col variance_(const Col &mu, const double &theta, dev_crit_ratio_inner = (dev - dev_old) / (0.1 + abs(dev_old)); dev_crit = is_finite(dev); val_crit = (valid_eta_(eta, fam) && valid_mu_(mu, fam)); - imp_crit = (dev_crit_ratio_inner <= -dev_tol); + imp_crit = (dev_crit_ratio_inner < -dev_tol); if (dev_crit == true && val_crit == true && imp_crit == true) { break; From d71d64ec76a2d9cf5763b87404d6118414f9927b Mon Sep 17 00:00:00 2001 From: Mauricio 'Pacha' Vargas Sepulveda Date: Sun, 21 Jul 2024 16:35:51 -0400 Subject: [PATCH 12/16] simplify notation for step halving --- src/05_glm_fit.cpp | 17 +++++++++++------ 1 file changed, 11 insertions(+), 6 deletions(-) diff --git a/src/05_glm_fit.cpp b/src/05_glm_fit.cpp index 7516bbe..b83ffe8 100644 --- a/src/05_glm_fit.cpp +++ b/src/05_glm_fit.cpp @@ -324,7 +324,7 @@ Col variance_(const Col &mu, const double &theta, bool conv = false; bool dev_crit, val_crit, imp_crit; - double dev_old, dev_crit_ratio, dev_crit_ratio_inner, rho; + double dev_old, dev_ratio, dev_ratio_inner, rho; Col eta_upd(n), beta_upd(k), eta_old(n), beta_old(k); // Maximize the log-likelihood @@ -359,16 +359,21 @@ Col variance_(const Col &mu, const double &theta, beta = beta_old + (rho * beta_upd); mu = link_inv_(eta, fam); dev = dev_resids_(y, mu, theta, wt, fam); - dev_crit_ratio_inner = (dev - dev_old) / (0.1 + abs(dev_old)); + dev_ratio_inner = (dev - dev_old) / (0.1 + abs(dev_old)); + + std::cout << "dev: " << dev << std::endl; + std::cout << "dev_ratio_inner: " << dev_ratio_inner << std::endl; + std::cout << "dev_tol: " << dev_tol << std::endl; + dev_crit = is_finite(dev); val_crit = (valid_eta_(eta, fam) && valid_mu_(mu, fam)); - imp_crit = (dev_crit_ratio_inner < -dev_tol); + imp_crit = (dev_ratio_inner <= -dev_tol); if (dev_crit == true && val_crit == true && imp_crit == true) { break; } - rho *= 0.5; + rho = 0.5; } // Check if step-halving failed (deviance and invalid eta or mu) @@ -388,8 +393,8 @@ Col variance_(const Col &mu, const double &theta, // Check convergence - dev_crit_ratio = abs(dev - dev_old) / (0.1 + abs(dev)); - if (dev_crit_ratio < dev_tol) { + dev_ratio = abs(dev - dev_old) / (0.1 + abs(dev)); + if (dev_ratio < dev_tol) { conv = true; break; } From 062176a5cce02375317846bb9db6a76d8edca382 Mon Sep 17 00:00:00 2001 From: Mauricio 'Pacha' Vargas Sepulveda Date: Sun, 21 Jul 2024 19:17:31 -0400 Subject: [PATCH 13/16] fix logit convergence issue --- src/05_glm_fit.cpp | 136 ++++++++++++++++++++++----------------------- 1 file changed, 65 insertions(+), 71 deletions(-) diff --git a/src/05_glm_fit.cpp b/src/05_glm_fit.cpp index b83ffe8..032e045 100644 --- a/src/05_glm_fit.cpp +++ b/src/05_glm_fit.cpp @@ -27,48 +27,36 @@ std::string tidy_family_(const std::string &family) { return fam; } -// Pairwise-maximum function -// Col pmax_(const Col &x, const Col &y) { -// Col res(x.n_elem); - -// // for (int i = 0; i < x.n_elem; ++i) { -// // res(i) = std::max(x(i), y(i)); -// // } - -// std::transform(x.begin(), x.end(), y.begin(), res.begin(), -// [](double a, double b) { return std::max(a, b); }); - -// return res; -// } - -// static const double THRESH = 30.; -// static const double MTHRESH = -30.; -// static const double DBL_EPSILON = std::numeric_limits::epsilon(); -// static const double INVEPS = 1 / DBL_EPSILON; - -// Col link_inv_logit_(const Col &x) { -// Col res(x.n_elem); - -// uword i, n = x.n_elem; -// for (i = 0; i < n; ++i) { -// if (x(i) < MTHRESH) { -// res(i) = DBL_EPSILON; -// } else if (x(i) > THRESH) { -// res(i) = INVEPS; -// } else { -// double y = exp(x(i)); -// res(i) = y / (1 + y); -// } -// } - -// return res; -// } +Col link_inv_gaussian_(const Col &x) { + return x; +} + +Col link_inv_poisson_(const Col &x) { + return exp(x); +} Col link_inv_logit_(const Col &x) { Col y = exp(x); return y / (1 + y); } +Col link_inv_gamma_(const Col &x) { + return 1 / x; +} + +Col link_inv_invgaussian_(const Col &x) { + return 1 / sqrt(x); +} + +Col link_inv_negbin_(const Col &x) { + return exp(x); +} + +double dev_resids_gaussian_(const Col &y, const Col &mu, + const Col &wt) { + return accu(wt % square(y - mu)); +} + double dev_resids_poisson_(const Col &y, const Col &mu, const Col &wt) { Col r = mu % wt; @@ -121,46 +109,46 @@ double dev_resids_negbin_(const Col &y, const Col &mu, return 2 * accu(r); } -// Col mu_eta_logit_(const Col &x) { -// Col res(x.n_elem); - -// uword i, n = x.n_elem; - -// for (i = 0; i < n; ++i) { -// double opexp = 1 + exp(x(i)); - -// if ((x(i) > THRESH) || (x(i) < MTHRESH)){ -// res(i) = DBL_EPSILON; -// } else { -// res(i) = exp(x(i)) / (opexp * opexp); -// } -// } +Col mu_eta_gaussian_(const Col &x) { + return ones>(x.n_elem); +} -// return res; -// } +Col mu_eta_poisson_(const Col &x) { + return exp(x); +} Col mu_eta_logit_(const Col &x) { Col y = exp(x); return y / square(1 + y); } +Col mu_eta_gamma_(const Col &x) { + return -1 / square(x); +} + +Col mu_eta_invgaussian_(const Col &x) { + return -1 / (2 * pow(x, 1.5)); +} + +Col mu_eta_negbin_(const Col &x) { + return exp(x); +} + Col link_inv_(const Col &eta, const std::string &fam) { Col res(eta.n_elem); if (fam == "gaussian") { - res = eta; + res = link_inv_gaussian_(eta); } else if (fam == "poisson") { - // Col epsilon = 2.220446e-16 * ones>(eta.n_elem); - // res = pmax_(exp(eta), epsilon); - res = exp(eta); + res = link_inv_poisson_(eta); } else if (fam == "binomial") { res = link_inv_logit_(eta); } else if (fam == "gamma") { - res = 1.0 / eta; + res = link_inv_gamma_(eta); } else if (fam == "inverse_gaussian") { - res = 1.0 / sqrt(eta); + res = link_inv_invgaussian_(eta); } else if (fam == "negative_binomial") { - res = exp(eta); + res = link_inv_negbin_(eta); } else { stop("Unknown family"); } @@ -174,7 +162,7 @@ double dev_resids_(const Col &y, const Col &mu, double res; if (fam == "gaussian") { - res = accu(wt % square(y - mu)); + res = dev_resids_gaussian_(y, mu, wt); } else if (fam == "poisson") { res = dev_resids_poisson_(y, mu, wt); } else if (fam == "binomial") { @@ -242,17 +230,17 @@ Col mu_eta_(Col &eta, const std::string &fam) { Col res(eta.n_elem); if (fam == "gaussian") { - res.ones(); + res = mu_eta_gaussian_(eta); } else if (fam == "poisson") { - res = exp(eta); + res = mu_eta_poisson_(eta); } else if (fam == "binomial") { res = mu_eta_logit_(eta); } else if (fam == "gamma") { - res = -1 / square(eta); + res = mu_eta_gamma_(eta); } else if (fam == "inverse_gaussian") { - res = -1 / (2 * pow(eta, 1.5)); + res = mu_eta_invgaussian_(eta); } else if (fam == "negative_binomial") { - res = exp(eta); + res = mu_eta_negbin_(eta); } else { stop("Unknown family"); } @@ -359,21 +347,26 @@ Col variance_(const Col &mu, const double &theta, beta = beta_old + (rho * beta_upd); mu = link_inv_(eta, fam); dev = dev_resids_(y, mu, theta, wt, fam); - dev_ratio_inner = (dev - dev_old) / (0.1 + abs(dev_old)); + dev_ratio_inner = (dev - dev_old) / (0.1 + fabs(dev_old)); - std::cout << "dev: " << dev << std::endl; - std::cout << "dev_ratio_inner: " << dev_ratio_inner << std::endl; - std::cout << "dev_tol: " << dev_tol << std::endl; + // std::cout << "iter: " << iter << std::endl; + // std::cout << "iter_inner: " << iter_inner << std::endl; + // std::cout << "beta old: " << beta_old.t() << std::endl; + // std::cout << "beta: " << beta.t() << std::endl; + // std::cout << "dev: " << dev << std::endl; + // std::cout << "dev_ratio_inner: " << dev_ratio_inner << std::endl; + // std::cout << "dev_tol: " << dev_tol << std::endl; dev_crit = is_finite(dev); val_crit = (valid_eta_(eta, fam) && valid_mu_(mu, fam)); imp_crit = (dev_ratio_inner <= -dev_tol); if (dev_crit == true && val_crit == true && imp_crit == true) { + // std::cout << "ok" << std::endl; break; } - rho = 0.5; + rho *= 0.5; } // Check if step-halving failed (deviance and invalid eta or mu) @@ -393,7 +386,8 @@ Col variance_(const Col &mu, const double &theta, // Check convergence - dev_ratio = abs(dev - dev_old) / (0.1 + abs(dev)); + dev_ratio = fabs(dev - dev_old) / (0.1 + fabs(dev)); + if (dev_ratio < dev_tol) { conv = true; break; From f1ad80c6f9d785fbfd6bf9bfa906ed5cd671f37a Mon Sep 17 00:00:00 2001 From: Mauricio 'Pacha' Vargas Sepulveda Date: Sun, 21 Jul 2024 19:54:45 -0400 Subject: [PATCH 14/16] streamline code --- R/apes.R | 108 ++++++++++++++++---------------- R/bias_corr.R | 22 +++---- R/feglm.R | 10 +-- R/feglm_offset.R | 8 +-- R/felm.R | 2 +- R/fenegbin.R | 10 +-- R/generics_glance.R | 14 ++--- R/generics_print.R | 6 +- R/generics_summary.R | 8 +-- R/helpers.R | 26 ++++---- src/05_glm_fit.cpp | 94 ++++++++++++++++----------- tests/testthat/test-apes-bias.R | 3 + tests/testthat/test-errors.R | 4 +- 13 files changed, 173 insertions(+), 142 deletions(-) diff --git a/R/apes.R b/R/apes.R index ab22065..2885da4 100644 --- a/R/apes.R +++ b/R/apes.R @@ -13,27 +13,27 @@ #' #' @param object an object of class \code{"bias_corr"} or \code{"feglm"}; #' currently restricted to \code{\link[stats]{binomial}}. -#' @param n.pop unsigned integer indicating a finite population correction for +#' @param n_pop unsigned integer indicating a finite population correction for #' the estimation of the covariance matrix of the average partial effects #' proposed by Cruz-Gonzalez, Fernández-Val, and Weidner (2017). The correction #' factor is computed as follows: -#' \eqn{(n^{\ast} - n) / (n^{\ast} - 1)}{(n.pop - n) / (n.pop - 1)}, -#' where \eqn{n^{\ast}}{n.pop} and \eqn{n}{n} are the sizes of the entire +#' \eqn{(n^{\ast} - n) / (n^{\ast} - 1)}{(n_pop - n) / (n_pop - 1)}, +#' where \eqn{n^{\ast}}{n_pop} and \eqn{n}{n} are the sizes of the entire #' population and the full sample size. Default is \code{NULL}, which refers to #' a factor of zero and a covariance obtained by the delta method. -#' @param panel.structure a string equal to \code{"classic"} or \code{"network"} +#' @param panel_structure a string equal to \code{"classic"} or \code{"network"} #' which determines the structure of the panel used. \code{"classic"} denotes #' panel structures where for example the same cross-sectional units are #' observed several times (this includes pseudo panels). \code{"network"} #' denotes panel structures where for example bilateral trade flows are #' observed for several time periods. Default is \code{"classic"}. -#' @param sampling.fe a string equal to \code{"independence"} or +#' @param sampling_fe a string equal to \code{"independence"} or #' \code{"unrestricted"} which imposes sampling assumptions about the #' unobserved effects. \code{"independence"} imposes that all unobserved #' effects are independent sequences. \code{"unrestricted"} does not impose any #' sampling assumptions. Note that this option only affects the optional finite #' population correction. Default is \code{"independence"}. -#' @param weak.exo logical indicating if some of the regressors are assumed to +#' @param weak_exo logical indicating if some of the regressors are assumed to #' be weakly exogenous (e.g. predetermined). If object is of class #' \code{"bias_corr"}, the option will be automatically set to \code{TRUE} if #' the chosen bandwidth parameter is larger than zero. Note that this option @@ -83,10 +83,10 @@ #' @export apes <- function( object = NULL, - n.pop = NULL, - panel.structure = c("classic", "network"), - sampling.fe = c("independence", "unrestricted"), - weak.exo = FALSE) { + n_pop = NULL, + panel_structure = c("classic", "network"), + sampling_fe = c("independence", "unrestricted"), + weak_exo = FALSE) { # Check validity of 'object' if (is.null(object)) { stop("'object' has to be specified.", call. = FALSE) @@ -95,22 +95,22 @@ apes <- function( } # Extract prior information if available or check validity of - # 'panel.structure' + # 'panel_structure' bias_corr <- inherits(object, "bias_corr") if (bias_corr) { - panel.structure <- object[["panel.structure"]] + panel_structure <- object[["panel_structure"]] L <- object[["bandwidth"]] if (L > 0L) { - weak.exo <- TRUE + weak_exo <- TRUE } else { - weak.exo <- FALSE + weak_exo <- FALSE } } else { - panel.structure <- match.arg(panel.structure) + panel_structure <- match.arg(panel_structure) } - # Check validity of 'sampling.fe' - sampling.fe <- match.arg(sampling.fe) + # Check validity of 'sampling_fe' + sampling_fe <- match.arg(sampling_fe) # Extract model information beta <- object[["coefficients"]] @@ -119,11 +119,11 @@ apes <- function( eps <- .Machine[["double.eps"]] family <- object[["family"]] formula <- object[["formula"]] - lvls.k <- object[["lvls.k"]] + lvls_k <- object[["lvls_k"]] nt <- object[["nobs"]][["nobs"]] - nt.full <- object[["nobs"]][["nobs.full"]] - k <- length(lvls.k) - k.vars <- names(lvls.k) + nt.full <- object[["nobs"]][["nobs_full"]] + k <- length(lvls_k) + k_vars <- names(lvls_k) p <- length(beta) # Check if binary choice model @@ -134,11 +134,11 @@ apes <- function( } # Check if provided object matches requested panel structure - if (panel.structure == "classic") { + if (panel_structure == "classic") { if (!(k %in% c(1L, 2L))) { stop( paste( - "panel.structure == 'classic' expects a one- or two-way fixed", + "panel_structure == 'classic' expects a one- or two-way fixed", "effects model." ), call. = FALSE @@ -148,7 +148,7 @@ apes <- function( if (!(k %in% c(2L, 3L))) { stop( paste( - "panel.structure == 'network' expects a two- or three-way fixed", + "panel_structure == 'network' expects a two- or three-way fixed", "effects model." ), call. = FALSE @@ -156,11 +156,11 @@ apes <- function( } } - # Check validity of 'n.pop' + # Check validity of 'n_pop' # Note: Default option is no adjustment i.e. only delta method covariance - if (!is.null(n.pop)) { - n.pop <- as.integer(n.pop) - if (n.pop < nt.full) { + if (!is.null(n_pop)) { + n_pop <- as.integer(n_pop) + if (n_pop < nt.full) { warning( paste( "Size of the entire population is lower than the full sample size.", @@ -170,7 +170,7 @@ apes <- function( ) adj <- 0.0 } else { - adj <- (n.pop - nt.full) / (n.pop - 1L) + adj <- (n_pop - nt.full) / (n_pop - 1L) } } else { adj <- 0.0 @@ -187,7 +187,7 @@ apes <- function( binary <- apply(X, 2L, function(x) all(x %in% c(0.0, 1.0))) # Generate auxiliary list of indexes for different sub panels - k.list <- get_index_list_(k.vars, data) + k_list <- get_index_list_(k_vars, data) # Compute derivatives and weights eta <- object[["eta"]] @@ -205,10 +205,10 @@ apes <- function( } # Center regressor matrix (if required) - if (control[["keep.mx"]]) { + if (control[["keep_mx"]]) { MX <- object[["MX"]] } else { - MX <- center_variables_(X, NA_real_, w, k.list, control[["center.tol"]], 100000L, FALSE) + MX <- center_variables_(X, NA_real_, w, k_list, control[["center_tol"]], 100000L, FALSE) } # Compute average partial effects, derivatives, and Jacobian @@ -243,7 +243,7 @@ apes <- function( # Compute projection and residual projection of \Psi Psi <- -Delta1 / w - MPsi <- center_variables_(Psi, NA_real_, w, k.list, control[["center.tol"]], 100000L, FALSE) + MPsi <- center_variables_(Psi, NA_real_, w, k_list, control[["center_tol"]], 100000L, FALSE) PPsi <- Psi - MPsi rm(Delta1, Psi) @@ -264,28 +264,28 @@ apes <- function( } # Compute bias terms for requested bias correction - if (panel.structure == "classic") { + if (panel_structure == "classic") { # Compute \hat{B} and \hat{D} - b <- group_sums_(Delta2 + PPsi * z, w, k.list[[1L]]) / (2.0 * nt) + b <- group_sums_(Delta2 + PPsi * z, w, k_list[[1L]]) / (2.0 * nt) if (k > 1L) { - b <- (b + group_sums_(Delta2 + PPsi * z, w, k.list[[2L]])) / (2.0 * nt) + b <- (b + group_sums_(Delta2 + PPsi * z, w, k_list[[2L]])) / (2.0 * nt) } # Compute spectral density part of \hat{B} if (L > 0L) { - b <- (b - group_sums_spectral_(MPsi * w, v, w, L, k.list[[1L]])) / nt + b <- (b - group_sums_spectral_(MPsi * w, v, w, L, k_list[[1L]])) / nt } } else { # Compute \hat{D}_{1}, \hat{D}_{2}, and \hat{B} - b <- group_sums_(Delta2 + PPsi * z, w, k.list[[1L]]) / (2.0 * nt) - b <- (b + group_sums_(Delta2 + PPsi * z, w, k.list[[2L]])) / (2.0 * nt) + b <- group_sums_(Delta2 + PPsi * z, w, k_list[[1L]]) / (2.0 * nt) + b <- (b + group_sums_(Delta2 + PPsi * z, w, k_list[[2L]])) / (2.0 * nt) if (k > 2L) { - b <- (b + group_sums_(Delta2 + PPsi * z, w, k.list[[3L]])) / (2.0 * nt) + b <- (b + group_sums_(Delta2 + PPsi * z, w, k_list[[3L]])) / (2.0 * nt) } # Compute spectral density part of \hat{B} if (k > 2L && L > 0L) { - b <- (b - group_sums_spectral_(MPsi * w, v, w, L, k.list[[3L]])) / nt + b <- (b - group_sums_spectral_(MPsi * w, v, w, L, k_list[[3L]])) / nt } } rm(Delta2) @@ -296,33 +296,33 @@ apes <- function( rm(eta, w, z, MPsi) # Compute covariance matrix - Gamma <- gamma_(MX, object[["Hessian"]], J, PPsi, v, nt.full) + Gamma <- gamma_(MX, object[["hessian"]], J, PPsi, v, nt.full) V <- crossprod(Gamma) if (adj > 0.0) { # Simplify covariance if sampling assumptions are imposed - if (sampling.fe == "independence") { - V <- V + adj * group_sums_var_(Delta, k.list[[1L]]) + if (sampling_fe == "independence") { + V <- V + adj * group_sums_var_(Delta, k_list[[1L]]) if (k > 1L) { - V <- V + adj * (group_sums_var_(Delta, k.list[[2L]]) - crossprod(Delta)) + V <- V + adj * (group_sums_var_(Delta, k_list[[2L]]) - crossprod(Delta)) } - if (panel.structure == "network") { + if (panel_structure == "network") { if (k > 2L) { - V <- V + adj * (group_sums_var_(Delta, k.list[[3L]]) - + V <- V + adj * (group_sums_var_(Delta, k_list[[3L]]) - crossprod(Delta)) } } } # Add covariance in case of weak exogeneity - if (weak.exo) { - if (panel.structure == "classic") { - C <- group_sums_cov_(Delta, Gamma, k.list[[1L]]) + if (weak_exo) { + if (panel_structure == "classic") { + C <- group_sums_cov_(Delta, Gamma, k_list[[1L]]) V <- V + adj * (C + t(C)) rm(C) } else { if (k > 2L) { - C <- group_sums_cov_(Delta, Gamma, k.list[[3L]]) + C <- group_sums_cov_(Delta, Gamma, k_list[[3L]]) V <- V + adj * (C + t(C)) rm(C) } @@ -338,9 +338,9 @@ apes <- function( reslist <- list( delta = delta, vcov = V, - panel.structure = panel.structure, - sampling.fe = sampling.fe, - weak.exo = weak.exo + panel_structure = panel_structure, + sampling_fe = sampling_fe, + weak_exo = weak_exo ) # Update result list diff --git a/R/bias_corr.R b/R/bias_corr.R index 8f42bdb..46d8dc6 100644 --- a/R/bias_corr.R +++ b/R/bias_corr.R @@ -77,11 +77,11 @@ bias_corr <- function( eps <- .Machine[["double.eps"]] family <- object[["family"]] formula <- object[["formula"]] - lvls.k <- object[["lvls.k"]] + lvls_k <- object[["lvls_k"]] nms.sp <- names(beta.uncorr) nt <- object[["nobs"]][["nobs"]] - k.vars <- names(lvls.k) - k <- length(lvls.k) + k.vars <- names(lvls_k) + k <- length(lvls_k) # Check if binary choice model if (family[["family"]] != "binomial") { @@ -92,7 +92,7 @@ bias_corr <- function( } # Check if the number of FEs is > 3 - if (length(lvls.k) > 3) { + if (length(lvls_k) > 3) { stop( "bias_corr() only supports models with up to three-way fixed effects.", call. = FALSE @@ -147,10 +147,10 @@ bias_corr <- function( } # Center regressor matrix (if required) - if (control[["keep.mx"]]) { + if (control[["keep_mx"]]) { MX <- object[["MX"]] } else { - MX <- center_variables_(X, NA_real_, w, k.list, control[["center.tol"]], 100000L, FALSE) + MX <- center_variables_(X, NA_real_, w, k.list, control[["center_tol"]], 100000L, FALSE) } # Compute bias terms for requested bias correction @@ -180,7 +180,7 @@ bias_corr <- function( } # Compute bias-corrected structural parameters - beta <- beta.uncorr - solve(object[["Hessian"]] / nt, b) + beta <- beta.uncorr - solve(object[["hessian"]] / nt, b) names(beta) <- nms.sp # Update \eta and first- and second-order derivatives @@ -197,18 +197,18 @@ bias_corr <- function( } # Update centered regressor matrix - MX <- center_variables_(X, NA_real_, w, k.list, control[["center.tol"]], 100000L, FALSE) + MX <- center_variables_(X, NA_real_, w, k.list, control[["center_tol"]], 100000L, FALSE) colnames(MX) <- nms.sp - # Update Hessian + # Update hessian H <- crossprod(MX * sqrt(w)) dimnames(H) <- list(nms.sp, nms.sp) # Update result list object[["coefficients"]] <- beta object[["eta"]] <- eta - if (control[["keep.mx"]]) object[["MX"]] <- MX - object[["Hessian"]] <- H + if (control[["keep_mx"]]) object[["MX"]] <- MX + object[["hessian"]] <- H object[["coefficients.uncorr"]] <- beta.uncorr object[["bias.term"]] <- b object[["panel.structure"]] <- panel.structure diff --git a/R/feglm.R b/R/feglm.R index cd5140b..d030568 100644 --- a/R/feglm.R +++ b/R/feglm.R @@ -88,8 +88,8 @@ feglm <- function( # Generate model.frame lhs <- NA # just to avoid global variable warning - nobs.na <- NA - nobs.full <- NA + nobs_na <- NA + nobs_full <- NA model_frame_(data, formula, weights) # Ensure that model response is in line with the chosen model ---- @@ -110,7 +110,7 @@ feglm <- function( # Determine the number of dropped observations ---- nt <- nrow(data) - nobs <- nobs_(nobs.full, nobs.na, nt) + nobs <- nobs_(nobs_full, nobs_na, nt) # Extract model response and regressor matrix ---- nms_sp <- NA @@ -150,12 +150,12 @@ feglm <- function( X <- NULL eta <- NULL - # Add names to beta, Hessian, and MX (if provided) ---- + # Add names to beta, hessian, and MX (if provided) ---- names(fit[["coefficients"]]) <- nms_sp if (control[["keep_mx"]]) { colnames(fit[["MX"]]) <- nms_sp } - dimnames(fit[["Hessian"]]) <- list(nms_sp, nms_sp) + dimnames(fit[["hessian"]]) <- list(nms_sp, nms_sp) # Generate result list ---- reslist <- c( diff --git a/R/feglm_offset.R b/R/feglm_offset.R index b6af87e..c7ad81e 100644 --- a/R/feglm_offset.R +++ b/R/feglm_offset.R @@ -12,15 +12,15 @@ feglm_offset_ <- function(object, offset) { wt <- object[["weights"]] family <- object[["family"]] formula <- object[["formula"]] - lvls.k <- object[["lvls.k"]] + lvls_k <- object[["lvls_k"]] nt <- object[["nobs"]][["nobs"]] - k.vars <- names(lvls.k) + k.vars <- names(lvls_k) # Extract dependent variable y <- data[[1L]] # Extract control arguments - center.tol <- control[["center.tol"]] + center_tol <- control[["center_tol"]] dev.tol <- control[["dev.tol"]] iter.max <- control[["iter.max"]] @@ -53,7 +53,7 @@ feglm_offset_ <- function(object, offset) { yadj <- (y - mu) / mu.eta + eta - offset # Centering dependent variable and compute \eta update - Myadj <- center_variables_(Myadj, yadj, w, k.list, center.tol, 10000L, TRUE) + Myadj <- center_variables_(Myadj, yadj, w, k.list, center_tol, 10000L, TRUE) eta.upd <- yadj - drop(Myadj) + offset - eta # Step-halving with three checks diff --git a/R/felm.R b/R/felm.R index 8eecdba..c939d0b 100644 --- a/R/felm.R +++ b/R/felm.R @@ -35,7 +35,7 @@ felm <- function(formula = NULL, data = NULL, weights = NULL) { names(reslist)[which(names(reslist) == "eta")] <- "fitted.values" - # reslist[["Hessian"]] <- NULL + # reslist[["hessian"]] <- NULL reslist[["family"]] <- NULL reslist[["deviance"]] <- NULL diff --git a/R/fenegbin.R b/R/fenegbin.R index b7f3da5..7f690eb 100644 --- a/R/fenegbin.R +++ b/R/fenegbin.R @@ -44,8 +44,8 @@ fenegbin <- function( # Generate model.frame lhs <- NA # just to avoid global variable warning - nobs.na <- NA - nobs.full <- NA + nobs_na <- NA + nobs_full <- NA model_frame_(data, formula, weights) # Check starting guess of theta ---- @@ -70,7 +70,7 @@ fenegbin <- function( # Determine the number of dropped observations ---- nt <- nrow(data) - nobs <- nobs_(nobs.full, nobs.na, nt) + nobs <- nobs_(nobs_full, nobs_na, nt) # Extract model response and regressor matrix ---- nms_sp <- NA @@ -173,12 +173,12 @@ fenegbin <- function( # Information if convergence failed ---- if (!conv && trace) cat("Algorithm did not converge.\n") - # Add names to beta, Hessian, and MX (if provided) ---- + # Add names to beta, hessian, and MX (if provided) ---- names(fit[["coefficients"]]) <- nms_sp if (control[["keep_mx"]]) { colnames(fit[["MX"]]) <- nms_sp } - dimnames(fit[["Hessian"]]) <- list(nms_sp, nms_sp) + dimnames(fit[["hessian"]]) <- list(nms_sp, nms_sp) # Generate result list ---- reslist <- c( diff --git a/R/generics_glance.R b/R/generics_glance.R index 3c80200..7dbdf70 100644 --- a/R/generics_glance.R +++ b/R/generics_glance.R @@ -9,10 +9,10 @@ glance.feglm <- function(x, ...) { summary(x), data.frame( deviance = deviance, - null.deviance = null.deviance, - nobs.full = nobs["nobs.full"], - nobs.na = nobs["nobs.na"], - nobs.pc = nobs["nobs.pc"], + null_deviance = null_deviance, + nobs_full = nobs["nobs_full"], + nobs_na = nobs["nobs_na"], + nobs_pc = nobs["nobs_pc"], nobs = nobs["nobs"] ) ) @@ -29,9 +29,9 @@ glance.felm <- function(x, ...) { tibble( r.squared = r.squared, adj.r.squared = adj.r.squared, - nobs.full = nobs["nobs.full"], - nobs.na = nobs["nobs.na"], - nobs.pc = nobs["nobs.pc"], + nobs_full = nobs["nobs_full"], + nobs_na = nobs["nobs_na"], + nobs_pc = nobs["nobs_pc"], nobs = nobs["nobs"] ) ) diff --git a/R/generics_print.R b/R/generics_print.R index 5d6823e..257c16b 100644 --- a/R/generics_print.R +++ b/R/generics_print.R @@ -137,8 +137,8 @@ summary_nobs_ <- function(x) { cat( "\nNumber of observations:", paste0("Full ", x[["nobs"]][["nobs"]], ";"), - paste0("Missing ", x[["nobs"]][["nobs.na"]], ";"), - paste0("Perfect classification ", x[["nobs"]][["nobs.pc"]]), "\n" + paste0("Missing ", x[["nobs"]][["nobs_na"]], ";"), + paste0("Perfect classification ", x[["nobs"]][["nobs_pc"]]), "\n" ) } @@ -171,7 +171,7 @@ print.feglm <- function(x, digits = max(3L, getOption("digits") - 3L), ...) { cat( sub("\\(.*\\)", "", x[["family"]][["family"]]), " - ", x[["family"]][["link"]], " link", - ", l= [", paste0(x[["lvls.k"]], collapse = ", "), "]\n\n", + ", l= [", paste0(x[["lvls_k"]], collapse = ", "), "]\n\n", sep = "" ) print(x[["coefficients"]], digits = digits) diff --git a/R/generics_summary.R b/R/generics_summary.R index ed8fe7c..7469acd 100644 --- a/R/generics_summary.R +++ b/R/generics_summary.R @@ -37,10 +37,10 @@ summary.feglm <- function( res <- list( cm = cm, deviance = object[["deviance"]], - null.deviance = object[["null.deviance"]], + null_deviance = object[["null_deviance"]], iter = object[["iter"]], nobs = object[["nobs"]], - lvls.k = object[["lvls.k"]], + lvls_k = object[["lvls_k"]], formula = object[["formula"]], family = object[["family"]] ) @@ -87,7 +87,7 @@ summary.felm <- function( e_sq <- (y - object[["fitted.values"]])^2 tss <- sum(w * ydemeaned_sq) rss <- sum(w * e_sq) - n <- unname(object[["nobs"]]["nobs.full"]) + n <- unname(object[["nobs"]]["nobs_full"]) k <- length(object[["coefficients"]]) + sum(vapply(object[["nms.fe"]], length, integer(1))) @@ -95,7 +95,7 @@ summary.felm <- function( res <- list( cm = cm, nobs = object[["nobs"]], - lvls.k = object[["lvls.k"]], + lvls_k = object[["lvls_k"]], formula = object[["formula"]], r.squared = 1 - (rss / tss), adj.r.squared = 1 - (rss / tss) * ((n - 1) / (n - k)) diff --git a/R/helpers.R b/R/helpers.R index ea13420..2fbc9fe 100644 --- a/R/helpers.R +++ b/R/helpers.R @@ -104,6 +104,10 @@ check_family_ <- function(family) { } else if (startsWith(family[["family"]], "Negative Binomial")) { stop("Please use 'fenegbin' instead.", call. = FALSE) } + + if (family[["family"]] == "binomial" && family[["link"]] != "logit") { + stop("The current version only supports logit in the binomial family.", call. = FALSE) + } } update_formula_ <- function(formula) { @@ -124,17 +128,17 @@ model_frame_ <- function(data, formula, weights) { lhs <- names(data)[[1L]] - nobs.full <- nrow(data) + nobs_full <- nrow(data) data <- na.omit(data) - nobs.na <- nobs.full - nrow(data) - nobs.full <- nrow(data) + nobs_na <- nobs_full - nrow(data) + nobs_full <- nrow(data) assign("data", data, envir = parent.frame()) assign("lhs", lhs, envir = parent.frame()) - assign("nobs.na", nobs.na, envir = parent.frame()) - assign("nobs.full", nobs.full, envir = parent.frame()) + assign("nobs_na", nobs_na, envir = parent.frame()) + assign("nobs_full", nobs_full, envir = parent.frame()) } check_response_ <- function(data, lhs, family) { @@ -218,11 +222,11 @@ transform_fe_ <- function(data, formula, k.vars) { data } -nobs_ <- function(nobs.full, nobs.na, nt) { +nobs_ <- function(nobs_full, nobs_na, nt) { c( - nobs.full = nobs.full, - nobs.na = nobs.na, - nobs.pc = nobs.full - nt, + nobs_full = nobs_full, + nobs_na = nobs_na, + nobs_pc = nobs_full - nt, nobs = nt ) } @@ -362,7 +366,7 @@ get_score_matrix_ <- function(object) { } else { # Extract additional required quantities from result list formula <- object[["formula"]] - k.vars <- names(object[["lvls.k"]]) + k.vars <- names(object[["lvls_k"]]) # Generate auxiliary list of indexes to project out the fixed effects k.list <- get_index_list_(k.vars, data) @@ -373,7 +377,7 @@ get_score_matrix_ <- function(object) { attr(X, "dimnames") <- NULL # Center variables - MX <- center_variables_(X, NA_real_, w, k.list, control[["center.tol"]], 10000L, FALSE) + MX <- center_variables_(X, NA_real_, w, k.list, control[["center_tol"]], 10000L, FALSE) colnames(MX) <- nms_sp } diff --git a/src/05_glm_fit.cpp b/src/05_glm_fit.cpp index 032e045..0353f2f 100644 --- a/src/05_glm_fit.cpp +++ b/src/05_glm_fit.cpp @@ -27,29 +27,29 @@ std::string tidy_family_(const std::string &family) { return fam; } -Col link_inv_gaussian_(const Col &x) { - return x; +Col link_inv_gaussian_(const Col &eta) { + return eta; } -Col link_inv_poisson_(const Col &x) { - return exp(x); +Col link_inv_poisson_(const Col &eta) { + return exp(eta); } -Col link_inv_logit_(const Col &x) { - Col y = exp(x); - return y / (1 + y); +Col link_inv_logit_(const Col &eta) { + Col expeta = exp(eta); + return expeta / (1 + expeta); } -Col link_inv_gamma_(const Col &x) { - return 1 / x; +Col link_inv_gamma_(const Col &eta) { + return 1 / eta; } -Col link_inv_invgaussian_(const Col &x) { - return 1 / sqrt(x); +Col link_inv_invgaussian_(const Col &eta) { + return 1 / sqrt(eta); } -Col link_inv_negbin_(const Col &x) { - return exp(x); +Col link_inv_negbin_(const Col &eta) { + return exp(eta); } double dev_resids_gaussian_(const Col &y, const Col &mu, @@ -109,29 +109,53 @@ double dev_resids_negbin_(const Col &y, const Col &mu, return 2 * accu(r); } -Col mu_eta_gaussian_(const Col &x) { - return ones>(x.n_elem); +Col mu_eta_gaussian_(const Col &eta) { + return ones>(eta.n_elem); } -Col mu_eta_poisson_(const Col &x) { - return exp(x); +Col mu_eta_poisson_(const Col &eta) { + return exp(eta); } -Col mu_eta_logit_(const Col &x) { - Col y = exp(x); - return y / square(1 + y); +Col mu_eta_logit_(const Col &eta) { + Col expeta = exp(eta); + return expeta / square(1 + expeta); } -Col mu_eta_gamma_(const Col &x) { - return -1 / square(x); +Col mu_eta_gamma_(const Col &eta) { + return -1 / square(eta); } -Col mu_eta_invgaussian_(const Col &x) { - return -1 / (2 * pow(x, 1.5)); +Col mu_eta_invgaussian_(const Col &eta) { + return -1 / (2 * pow(eta, 1.5)); } -Col mu_eta_negbin_(const Col &x) { - return exp(x); +Col mu_eta_negbin_(const Col &eta) { + return exp(eta); +} + +Col variance_gaussian_(const Col &mu) { + return ones>(mu.n_elem); +} + +Col variance_poisson_(const Col &mu) { + return mu; +} + +Col variance_binomial_(const Col &mu) { + return mu % (1 - mu); +} + +Col variance_gamma_(const Col &mu) { + return square(mu); +} + +Col variance_invgaussian_(const Col &mu) { + return pow(mu, 3.0); +} + +Col variance_negbin_(const Col &mu, const double &theta) { + return mu + square(mu) / theta; } Col link_inv_(const Col &eta, const std::string &fam) { @@ -253,17 +277,17 @@ Col variance_(const Col &mu, const double &theta, Col res(mu.n_elem); if (fam == "gaussian") { - res.ones(); + res = variance_gaussian_(mu); } else if (fam == "poisson") { - res = mu; + res = variance_poisson_(mu); } else if (fam == "binomial") { - res = mu % (1 - mu); + res = variance_binomial_(mu); } else if (fam == "gamma") { - res = square(mu); + res = variance_gamma_(mu); } else if (fam == "inverse_gaussian") { - res = pow(mu, 3.0); + res = variance_invgaussian_(mu); } else if (fam == "negative_binomial") { - res = mu + square(mu) / theta; + res = variance_negbin_(mu, theta); } else { stop("Unknown family"); } @@ -419,14 +443,14 @@ Col variance_(const Col &mu, const double &theta, // Generate result list - writable::list out(8); + writable::list out; out.push_back({"coefficients"_nm = as_doubles(beta)}); out.push_back({"eta"_nm = as_doubles(eta)}); out.push_back({"weights"_nm = as_doubles(wt)}); - out.push_back({"Hessian"_nm = as_doubles_matrix(H)}); + out.push_back({"hessian"_nm = as_doubles_matrix(H)}); out.push_back({"deviance"_nm = dev}); - out.push_back({"null.deviance"_nm = null_dev}); + out.push_back({"null_deviance"_nm = null_dev}); out.push_back({"conv"_nm = conv}); out.push_back({"iter"_nm = iter}); diff --git a/tests/testthat/test-apes-bias.R b/tests/testthat/test-apes-bias.R index 0381d6f..e99002b 100644 --- a/tests/testthat/test-apes-bias.R +++ b/tests/testthat/test-apes-bias.R @@ -4,6 +4,9 @@ test_that("apes/bias works", { mod <- feglm(trade ~ lang | year, trade_short, family = binomial()) + # names(mod) + # length(mod) + expect_output(print(mod)) expect_gt(length(coef(apes(mod))), 0) diff --git a/tests/testthat/test-errors.R b/tests/testthat/test-errors.R index 5d5e566..72d0611 100644 --- a/tests/testthat/test-errors.R +++ b/tests/testthat/test-errors.R @@ -30,7 +30,7 @@ test_that("error conditions", { data = trade_panel_2002, family = binomial() ), - panel.structure = "classic" + panel_structure = "classic" ), "two-way" ) @@ -41,7 +41,7 @@ test_that("error conditions", { data = trade_panel_2002, family = binomial() ), - panel.structure = "network" + panel_structure = "network" ), "three-way" ) From 1cb54e7a21f18f1cbf3ad56ccc51a1657fefa85a Mon Sep 17 00:00:00 2001 From: Mauricio 'Pacha' Vargas Sepulveda Date: Sun, 21 Jul 2024 23:42:47 -0400 Subject: [PATCH 15/16] v0.6.0 avoids multiple R <-> C++ data copies --- DESCRIPTION | 2 +- NEWS.md | 8 + R/apes.R | 4 +- R/bias_corr.R | 4 +- R/cpp11.R | 4 + R/feglm_offset.R | 24 +-- R/helpers.R | 4 +- README.Rmd | 22 +-- README.md | 29 +-- dev/07_helpers.cpp | 19 ++ dev/benchmarks_tests_agtpa.R | 43 ++--- ...enchmarks_tests_agtpa_capybara_only copy.R | 180 ------------------ dev/benchmarks_tests_agtpa_capybara_only.R | 2 +- dev/test-helpers.R | 18 ++ docs/404.html | 2 +- docs/CODE_OF_CONDUCT.html | 2 +- docs/CONTRIBUTING.html | 2 +- docs/LICENSE.html | 2 +- docs/articles/index.html | 2 +- docs/articles/intro.html | 2 +- docs/authors.html | 6 +- docs/index.html | 115 +++++------ docs/news/index.html | 7 +- docs/pkgdown.yml | 2 +- docs/reference/apes.html | 31 ++- docs/reference/bias_corr.html | 6 +- docs/reference/capybara-package.html | 2 +- docs/reference/feglm.html | 14 +- docs/reference/feglm_control.html | 22 +-- docs/reference/felm.html | 6 +- docs/reference/fenegbin.html | 16 +- docs/reference/fepoisson.html | 12 +- docs/reference/fixed_effects.html | 6 +- docs/reference/index.html | 2 +- docs/reference/kendall_cor.html | 2 +- docs/reference/kendall_cor_test.html | 2 +- docs/reference/pipe.html | 2 +- docs/reference/reexports.html | 2 +- docs/reference/trade_panel.html | 2 +- docs/reference/vcov.feglm.html | 18 +- docs/reference/vcov.felm.html | 24 +-- man/apes.Rd | 20 +- man/feglm.Rd | 8 +- man/feglm_control.Rd | 20 +- man/fenegbin.Rd | 12 +- man/fepoisson.Rd | 8 +- man/fixed_effects.Rd | 4 +- man/vcov.feglm.Rd | 4 +- man/vcov.felm.Rd | 8 +- src/01_center_variables.cpp | 8 + src/05_glm_fit.cpp | 2 +- src/cpp11.cpp | 8 + 52 files changed, 330 insertions(+), 446 deletions(-) create mode 100644 dev/07_helpers.cpp delete mode 100644 dev/benchmarks_tests_agtpa_capybara_only copy.R create mode 100644 dev/test-helpers.R diff --git a/DESCRIPTION b/DESCRIPTION index f325983..afd1596 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -2,7 +2,7 @@ Package: capybara Type: Package Title: Fast and Memory Efficient Fitting of Linear Models With High-Dimensional Fixed Effects -Version: 0.5.2 +Version: 0.6.0 Authors@R: c( person( given = "Mauricio", diff --git a/NEWS.md b/NEWS.md index 8d5b44f..75468e8 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,3 +1,11 @@ +# capybara 0.6.0 + +* Moves all the heavy computation to C++ using Armadillo and it exports the + results to R. Previously, there were multiple data copies between R and C++ + that added overhead to the computations. +* For a future release, I may rewrite the offset and APES computation to C++, + but with those the overhead is minimal. + # capybara 0.5.2 * Uses an O(n log(n)) algorithm to compute the Kendall correlation for the diff --git a/R/apes.R b/R/apes.R index 2885da4..5e2b44a 100644 --- a/R/apes.R +++ b/R/apes.R @@ -208,7 +208,7 @@ apes <- function( if (control[["keep_mx"]]) { MX <- object[["MX"]] } else { - MX <- center_variables_(X, NA_real_, w, k_list, control[["center_tol"]], 100000L, FALSE) + MX <- center_variables_r_(X, w, k_list, control[["center_tol"]], 10000L) } # Compute average partial effects, derivatives, and Jacobian @@ -243,7 +243,7 @@ apes <- function( # Compute projection and residual projection of \Psi Psi <- -Delta1 / w - MPsi <- center_variables_(Psi, NA_real_, w, k_list, control[["center_tol"]], 100000L, FALSE) + MPsi <- center_variables_r_(Psi, w, k_list, control[["center_tol"]], 10000L) PPsi <- Psi - MPsi rm(Delta1, Psi) diff --git a/R/bias_corr.R b/R/bias_corr.R index 46d8dc6..5c412a6 100644 --- a/R/bias_corr.R +++ b/R/bias_corr.R @@ -150,7 +150,7 @@ bias_corr <- function( if (control[["keep_mx"]]) { MX <- object[["MX"]] } else { - MX <- center_variables_(X, NA_real_, w, k.list, control[["center_tol"]], 100000L, FALSE) + MX <- center_variables_(X, w, k.list, control[["center_tol"]], 10000L) } # Compute bias terms for requested bias correction @@ -197,7 +197,7 @@ bias_corr <- function( } # Update centered regressor matrix - MX <- center_variables_(X, NA_real_, w, k.list, control[["center_tol"]], 100000L, FALSE) + MX <- center_variables_r_(X, w, k.list, control[["center_tol"]], 10000L) colnames(MX) <- nms.sp # Update hessian diff --git a/R/cpp11.R b/R/cpp11.R index 2eb72a2..cfa7e4a 100644 --- a/R/cpp11.R +++ b/R/cpp11.R @@ -1,5 +1,9 @@ # Generated by cpp11: do not edit by hand +center_variables_r_ <- function(V_r, w_r, klist, tol, maxiter) { + .Call(`_capybara_center_variables_r_`, V_r, w_r, klist, tol, maxiter) +} + get_alpha_ <- function(p_r, klist, tol) { .Call(`_capybara_get_alpha_`, p_r, klist, tol) } diff --git a/R/feglm_offset.R b/R/feglm_offset.R index c7ad81e..6108b20 100644 --- a/R/feglm_offset.R +++ b/R/feglm_offset.R @@ -14,18 +14,18 @@ feglm_offset_ <- function(object, offset) { formula <- object[["formula"]] lvls_k <- object[["lvls_k"]] nt <- object[["nobs"]][["nobs"]] - k.vars <- names(lvls_k) + k_vars <- names(lvls_k) # Extract dependent variable y <- data[[1L]] # Extract control arguments center_tol <- control[["center_tol"]] - dev.tol <- control[["dev.tol"]] - iter.max <- control[["iter.max"]] + dev_tol <- control[["dev_tol"]] + iter_max <- control[["iter_max"]] # Generate auxiliary list of indexes to project out the fixed effects - k.list <- get_index_list_(k.vars, data) + k_list <- get_index_list_(k_vars, data) # Compute starting guess for \eta if (family[["family"]] == "binomial") { @@ -42,10 +42,10 @@ feglm_offset_ <- function(object, offset) { Myadj <- as.matrix(numeric(nt)) # Start maximization of the log-likelihood - for (iter in seq.int(iter.max)) { + for (iter in seq.int(iter_max)) { # Store \eta, \beta, and deviance of the previous iteration - eta.old <- eta - dev.old <- dev + eta_old <- eta + dev_old <- dev # Compute weights and dependent variable mu.eta <- family[["mu.eta"]](eta) @@ -53,8 +53,8 @@ feglm_offset_ <- function(object, offset) { yadj <- (y - mu) / mu.eta + eta - offset # Centering dependent variable and compute \eta update - Myadj <- center_variables_(Myadj, yadj, w, k.list, center_tol, 10000L, TRUE) - eta.upd <- yadj - drop(Myadj) + offset - eta + Myadj <- center_variables_r_(Myadj + yadj, w, k_list, center_tol, 10000L) + eta_upd <- yadj - drop(Myadj) + offset - eta # Step-halving with three checks # 1. finite deviance @@ -62,12 +62,12 @@ feglm_offset_ <- function(object, offset) { # 3. improvement as in glm2 rho <- 1.0 for (inner.iter in seq.int(50L)) { - eta <- eta.old + rho * eta.upd + eta <- eta_old + rho * eta_upd mu <- family[["linkinv"]](eta) dev <- sum(family[["dev.resids"]](y, mu, wt)) dev.crit <- is.finite(dev) val.crit <- family[["valideta"]](eta) && family[["validmu"]](mu) - imp.crit <- (dev - dev.old) / (0.1 + abs(dev)) <= -dev.tol + imp.crit <- (dev - dev_old) / (0.1 + abs(dev)) <= -dev_tol if (dev.crit && val.crit && imp.crit) break rho <- rho / 2.0 } @@ -78,7 +78,7 @@ feglm_offset_ <- function(object, offset) { } # Check termination condition - if (abs(dev - dev.old) / (0.1 + abs(dev)) < dev.tol) break + if (abs(dev - dev_old) / (0.1 + abs(dev)) < dev_tol) break # Update starting guesses for acceleration Myadj <- Myadj - yadj diff --git a/R/helpers.R b/R/helpers.R index 2fbc9fe..6b2d696 100644 --- a/R/helpers.R +++ b/R/helpers.R @@ -106,7 +106,9 @@ check_family_ <- function(family) { } if (family[["family"]] == "binomial" && family[["link"]] != "logit") { - stop("The current version only supports logit in the binomial family.", call. = FALSE) + stop("The current version only supports logit in the binomial family. + This is because I had to rewrite the links in C++ to use those with Armadillo. + Send me a Pull Request or open an issue if you need Probit.", call. = FALSE) } } diff --git a/README.Rmd b/README.Rmd index 7b03922..fcf6918 100644 --- a/README.Rmd +++ b/README.Rmd @@ -121,27 +121,27 @@ to test with testthat. Median time for the different models in the book [An Advanced Guide to Trade Policy Analysis](https://www.wto.org/english/res_e/publications_e/advancedguide2016_e.htm). -|package | PPML| Trade Diversion| Endogeneity| Reverse Causality| Non-linear/Phasing Effects| Globalization| -|:------------|-------:|---------------:|-----------:|-----------------:|--------------------------:|-------------:| -|Alpaca | 261ms| 2s | 2s | 2s | 3s | 6s | -|Base R | 2m | 2m | 23m | 24m | 23m | 25m | -|**Capybara** | 364ms| 3s | 1s | 2s | 2s | 4s | -|Fixest | 69ms| 488ms| 125ms| 148ms| 251ms| 497ms| +| package | PPML | Trade Diversion | Endogeneity | Reverse Causality | Non-linear/Phasing Effects | Globalization | +|:------------|-------:|-----------------:|------------:|-----------------:|----------------------------:|--------------:| +| Alpaca | 0.4s | 2.6s | 1.6s | 2.0s | 3.1s | 5.3s | +| Base R | 120.0s | 2.0m | 1380.0s | 1440.0s | 1380.0s | 1500.0s | +| **Capybara**| 0.3s | 2.2s | 1.4s | 1.7s | 2.1s | 3.9s | +| Fixest | 0.1s | 0.5s | 0.1s | 0.2s | 0.3s | 0.5s | Memory allocation for the same models |package | PPML| Trade Diversion| Endogeneity| Reverse Causality| Non-linear/Phasing Effects| Globalization| |:------------|-------:|---------------:|-----------:|-----------------:|--------------------------:|-------------:| -|Alpaca | 306MB| 341MB| 306MB| 336MB| 395MB| 541MB| -|Base R | 3GB| 3GB| 12GB| 12GB| 12GB| 12GB| -|**Capybara** | 211MB| 235MB| 243MB| 250MB| 265MB| 302MB| -|Fixest | 44MB| 36MB| 27MB| 32MB| 41MB| 63MB| +|Alpaca | 307MB | 341MB | 306MB | 336MB | 395MB | 541MB | +|Base R | 3000MB | 3000MB | 12000MB | 12000GB | 12000GB | 12000MB | +|**Capybara** | 29MB | 34MB | 21MB | 24MB | 30MB | 47MB | +|Fixest | 44MB | 36MB | 27MB | 32MB | 41MB | 63MB | # Debugging *This debugging is about code quality, not about statistical quality.* *There is a full set of numerical tests for testthat to check the math.* -*In this section of the test, I can write pi = 3 and if there are no memory +*In this section of the test, I could write "pi = 3" and if there are no memory leaks, it will pass the test.* I run `r_valgrind "dev/test_get_alpha.r"` or the corresponding test from the diff --git a/README.md b/README.md index 7155b6a..344079d 100644 --- a/README.md +++ b/README.md @@ -117,27 +117,27 @@ Median time for the different models in the book [An Advanced Guide to Trade Policy Analysis](https://www.wto.org/english/res_e/publications_e/advancedguide2016_e.htm). -| package | PPML | Trade Diversion | Endogeneity | Reverse Causality | Non-linear/Phasing Effects | Globalization | -| :----------- | ------: | --------------: | ----------: | ----------------: | -------------------------: | ------------: | -| Alpaca | 346.4ms | 2.52s | 1.51s | 1.9s | 2.96s | 5.57s | -| Base R | 1.5m | 1.53m | 23.43m | 23.52m | 23.16m | 24.85m | -| **Capybara** | 440ms | 2.86s | 1.92s | 2.29s | 2.96s | 4.46s | -| Fixest | 64.9ms | 503ms | 106.14ms | 145.04ms | 243.61ms | 524.7ms | +| package | PPML | Trade Diversion | Endogeneity | Reverse Causality | Non-linear/Phasing Effects | Globalization | +| :----------- | -----: | --------------: | ----------: | ----------------: | -------------------------: | ------------: | +| Alpaca | 0.4s | 2.6s | 1.6s | 2.0s | 3.1s | 5.3s | +| Base R | 120.0s | 2.0m | 1380.0s | 1440.0s | 1380.0s | 1500.0s | +| **Capybara** | 0.3s | 2.2s | 1.4s | 1.7s | 2.1s | 3.9s | +| Fixest | 0.1s | 0.5s | 0.1s | 0.2s | 0.3s | 0.5s | Memory allocation for the same models | package | PPML | Trade Diversion | Endogeneity | Reverse Causality | Non-linear/Phasing Effects | Globalization | | :----------- | -----: | --------------: | ----------: | ----------------: | -------------------------: | ------------: | -| Alpaca | 306MB | 340.8MB | 306.4MB | 335.9MB | 394.6MB | 541.3MB | -| Base R | 2.7GB | 2.6GB | 11.9GB | 11.92GB | 11.95GB | 11.97GB | -| **Capybara** | 210MB | 235MB | 241MB | 249MB | 263MB | 299MB | -| Fixest | 44.4MB | 36.4MB | 27.9MB | 32.2MB | 40.9MB | 62.7MB | +| Alpaca | 307MB | 341MB | 306MB | 336MB | 395MB | 541MB | +| Base R | 3000MB | 3000MB | 12000MB | 12000GB | 12000GB | 12000MB | +| **Capybara** | 29MB | 34MB | 21MB | 24MB | 30MB | 47MB | +| Fixest | 44MB | 36MB | 27MB | 32MB | 41MB | 63MB | # Debugging *This debugging is about code quality, not about statistical quality.* *There is a full set of numerical tests for testthat to check the math.* -*In this section of the test, I can write pi = 3 and if there are no +*In this section of the test, I could write “pi = 3” and if there are no memory leaks, it will pass the test.* I run `r_valgrind "dev/test_get_alpha.r"` or the corresponding test from @@ -219,3 +219,10 @@ leaks. When you are ready testing, you need to remove `-UDEGUG` from `src/Makevars`. + +## Code of Conduct + +Please note that the capybara project is released with a [Contributor +Code of +Conduct](https://contributor-covenant.org/version/2/1/CODE_OF_CONDUCT.html). +By contributing to this project, you agree to abide by its terms. diff --git a/dev/07_helpers.cpp b/dev/07_helpers.cpp new file mode 100644 index 0000000..fa49b96 --- /dev/null +++ b/dev/07_helpers.cpp @@ -0,0 +1,19 @@ +#include "00_main.h" + +// Generate auxiliary list of indexes for different sub panels + +[[cpp11::register]] list get_index_list_(const strings &k_vars, + const data_frame &data) { + writable::integers indexes(data.nrow()); + std::iota(indexes.begin(), indexes.end(), 0); + + writable::list out; + + auto split = cpp11::package("base")["split"]; + + for (const auto &k_var : k_vars) { + out.push_back(split(indexes, data[k_var])); + } + + return out; +} diff --git a/dev/benchmarks_tests_agtpa.R b/dev/benchmarks_tests_agtpa.R index c1a1ce0..abf1a49 100644 --- a/dev/benchmarks_tests_agtpa.R +++ b/dev/benchmarks_tests_agtpa.R @@ -42,9 +42,6 @@ form2 <- trade ~ log_dist + cntg + lang + clny + d <- filter(ch1_application3, importer != exporter) bench_ppml <- mark( - # round(glm(form, family = stats::quasipoisson(link = "log"), data = d)$coefficients["rta"], 3), - round(capybara::fepoisson(form2, data = d)$coefficients["rta"], 3), - round(fixest::fepois(form2, data = d)$coefficients["rta"], 3), round(alpaca::feglm(form2, data = d, family = poisson())$coefficients["rta"], 3) ) @@ -63,9 +60,6 @@ form2 <- trade ~ log_dist + cntg + lang + clny + d <- ch1_application3 bench_trade_diversion <- mark( - # round(glm(form, family = stats::quasipoisson(link = "log"), data = d)$coefficients["rta"], 3), - round(capybara::fepoisson(form2, data = d)$coefficients["rta"], 3), - round(fixest::fepois(form2, data = d)$coefficients["rta"], 3), round(alpaca::feglm(form2, data = d, family = poisson())$coefficients["rta"], 3) ) @@ -81,9 +75,6 @@ form2 <- trade ~ rta | exp_year + imp_year + pair_id_2 d <- filter(ch1_application3, sum_trade > 0) bench_endogeneity <- mark( - # round(glm(form, family = stats::quasipoisson(link = "log"), data = d)$coefficients["rta"], 3), - round(capybara::fepoisson(form2, data = d)$coefficients["rta"], 3), - round(fixest::fepois(form2, data = d)$coefficients["rta"], 3), round(alpaca::feglm(form2, data = d, family = poisson())$coefficients["rta"], 3) ) @@ -99,9 +90,6 @@ form2 <- trade ~ rta + rta_lead4 | exp_year + imp_year + pair_id_2 d <- filter(ch1_application3, sum_trade > 0) bench_reverse_causality <- mark( - # round(glm(form, family = stats::quasipoisson(link = "log"), data = d)$coefficients["rta"], 3), - round(capybara::fepoisson(form2, data = d)$coefficients["rta"], 3), - round(fixest::fepois(form2, data = d)$coefficients["rta"], 3), round(alpaca::feglm(form2, data = d, family = poisson())$coefficients["rta"], 3) ) @@ -120,9 +108,6 @@ form2 <- trade ~ rta + rta_lag4 + rta_lag8 + rta_lag12 | d <- filter(ch1_application3, sum_trade > 0) bench_phasing <- mark( - # round(glm(form, family = stats::quasipoisson(link = "log"), data = d)$coefficients["rta"], 3), - round(capybara::fepoisson(form2, data = d)$coefficients["rta"], 3), - round(fixest::fepois(form2, data = d)$coefficients["rta"], 3), round(alpaca::feglm(form2, data = d, family = poisson())$coefficients["rta"], 3) ) @@ -145,9 +130,6 @@ form2 <- trade ~ rta + rta_lag4 + rta_lag8 + rta_lag12 + d <- filter(ch1_application3, sum_trade > 0) bench_globalization <- mark( - # round(glm(form, family = stats::quasipoisson(link = "log"), data = d)$coefficients["rta"], 3), - round(capybara::fepoisson(form2, data = d)$coefficients["rta"], 3), - round(fixest::fepois(form2, data = d)$coefficients["rta"], 3), round(alpaca::feglm(form2, data = d, family = poisson())$coefficients["rta"], 3) ) @@ -176,14 +158,15 @@ bench_globalization <- readRDS("dev/bench_globalization.rds") bench_ppml %>% # mutate(package = c("Base R", "**Capybara**", "Fixest", "Alpaca")) %>% - mutate(package = c("**Capybara**", "Fixest", "Alpaca")) %>% + mutate(package = c("Alpaca")) %>% + # mutate(package = c("**Capybara**", "Fixest", "Alpaca")) %>% mutate(model = "PPML") %>% select(model, package, median) %>% pivot_wider(names_from = model, values_from = median) %>% left_join( bench_trade_diversion %>% # mutate(package = c("Base R", "**Capybara**", "Fixest", "Alpaca")) %>% - mutate(package = c("**Capybara**", "Fixest", "Alpaca")) %>% + mutate(package = c("Alpaca")) %>% mutate(model = "Trade Diversion") %>% select(model, package, median) %>% pivot_wider(names_from = model, values_from = median) @@ -191,7 +174,7 @@ bench_ppml %>% left_join( bench_endogeneity %>% # mutate(package = c("Base R", "**Capybara**", "Fixest", "Alpaca")) %>% - mutate(package = c("**Capybara**", "Fixest", "Alpaca")) %>% + mutate(package = c("Alpaca")) %>% mutate(model = "Endogeneity") %>% select(model, package, median) %>% pivot_wider(names_from = model, values_from = median) @@ -199,7 +182,7 @@ bench_ppml %>% left_join( bench_reverse_causality %>% # mutate(package = c("Base R", "**Capybara**", "Fixest", "Alpaca")) %>% - mutate(package = c("**Capybara**", "Fixest", "Alpaca")) %>% + mutate(package = c("Alpaca")) %>% mutate(model = "Reverse Causality") %>% select(model, package, median) %>% pivot_wider(names_from = model, values_from = median) @@ -207,7 +190,7 @@ bench_ppml %>% left_join( bench_phasing %>% # mutate(package = c("Base R", "**Capybara**", "Fixest", "Alpaca")) %>% - mutate(package = c("**Capybara**", "Fixest", "Alpaca")) %>% + mutate(package = c("Alpaca")) %>% mutate(model = "Non-linear/Phasing Effects") %>% select(model, package, median) %>% pivot_wider(names_from = model, values_from = median) @@ -215,7 +198,7 @@ bench_ppml %>% left_join( bench_globalization %>% # mutate(package = c("Base R", "**Capybara**", "Fixest", "Alpaca")) %>% - mutate(package = c("**Capybara**", "Fixest", "Alpaca")) %>% + mutate(package = c("Alpaca")) %>% mutate(model = "Globalization") %>% select(model, package, median) %>% pivot_wider(names_from = model, values_from = median) @@ -225,14 +208,14 @@ bench_ppml %>% bench_ppml %>% # mutate(package = c("Base R", "**Capybara**", "Fixest", "Alpaca")) %>% - mutate(package = c("**Capybara**", "Fixest", "Alpaca")) %>% + mutate(package = c("Alpaca")) %>% mutate(model = "PPML") %>% select(model, package, mem_alloc) %>% pivot_wider(names_from = model, values_from = mem_alloc) %>% left_join( bench_trade_diversion %>% # mutate(package = c("Base R", "**Capybara**", "Fixest", "Alpaca")) %>% - mutate(package = c("**Capybara**", "Fixest", "Alpaca")) %>% + mutate(package = c("Alpaca")) %>% mutate(model = "Trade Diversion") %>% select(model, package, mem_alloc) %>% pivot_wider(names_from = model, values_from = mem_alloc) @@ -240,7 +223,7 @@ bench_ppml %>% left_join( bench_endogeneity %>% # mutate(package = c("Base R", "**Capybara**", "Fixest", "Alpaca")) %>% - mutate(package = c("**Capybara**", "Fixest", "Alpaca")) %>% + mutate(package = c("Alpaca")) %>% mutate(model = "Endogeneity") %>% select(model, package, mem_alloc) %>% pivot_wider(names_from = model, values_from = mem_alloc) @@ -248,7 +231,7 @@ bench_ppml %>% left_join( bench_reverse_causality %>% # mutate(package = c("Base R", "**Capybara**", "Fixest", "Alpaca")) %>% - mutate(package = c("**Capybara**", "Fixest", "Alpaca")) %>% + mutate(package = c("Alpaca")) %>% mutate(model = "Reverse Causality") %>% select(model, package, mem_alloc) %>% pivot_wider(names_from = model, values_from = mem_alloc) @@ -256,7 +239,7 @@ bench_ppml %>% left_join( bench_phasing %>% # mutate(package = c("Base R", "**Capybara**", "Fixest", "Alpaca")) %>% - mutate(package = c("**Capybara**", "Fixest", "Alpaca")) %>% + mutate(package = c("Alpaca")) %>% mutate(model = "Non-linear/Phasing Effects") %>% select(model, package, mem_alloc) %>% pivot_wider(names_from = model, values_from = mem_alloc) @@ -264,7 +247,7 @@ bench_ppml %>% left_join( bench_globalization %>% # mutate(package = c("Base R", "**Capybara**", "Fixest", "Alpaca")) %>% - mutate(package = c("**Capybara**", "Fixest", "Alpaca")) %>% + mutate(package = c("Alpaca")) %>% mutate(model = "Globalization") %>% select(model, package, mem_alloc) %>% pivot_wider(names_from = model, values_from = mem_alloc) diff --git a/dev/benchmarks_tests_agtpa_capybara_only copy.R b/dev/benchmarks_tests_agtpa_capybara_only copy.R deleted file mode 100644 index 1a546f3..0000000 --- a/dev/benchmarks_tests_agtpa_capybara_only copy.R +++ /dev/null @@ -1,180 +0,0 @@ -# this is not just about speed/memory, but also about obtaining the same -# slopes as in base R - -load_all() -library(dplyr) -library(tidyr) -library(janitor) -library(bench) - -rm(list = ls()) -gc() - -# data ---- - -ch1_application3 <- tradepolicy::agtpa_applications %>% - clean_names() %>% - filter(year %in% seq(1986, 2006, 4)) %>% - mutate( - exp_year = paste0(exporter, year), - imp_year = paste0(importer, year), - year = paste0("intl_border_", year), - log_trade = log(trade), - log_dist = log(dist), - intl_brdr = ifelse(exporter == importer, pair_id, "inter"), - intl_brdr_2 = ifelse(exporter == importer, 0, 1), - pair_id_2 = ifelse(exporter == importer, "0-intra", pair_id) - ) %>% - spread(year, intl_brdr_2, fill = 0) - -ch1_application3 <- ch1_application3 %>% - group_by(pair_id) %>% - mutate(sum_trade = sum(trade)) %>% - ungroup() - -# ppml ---- - -form <- trade ~ 0 + log_dist + cntg + lang + clny + - rta + exp_year + imp_year - -form2 <- trade ~ log_dist + cntg + lang + clny + - rta | exp_year + imp_year - -d <- filter(ch1_application3, importer != exporter) - -bench_ppml <- mark( - fepoisson(form2, data = d)$coefficients["rta"] -) - -formula = form2 -data = d -weights = NULL -beta.start = NULL -eta.start = NULL -control = NULL -family <- poisson() - -check_formula_(formula) -check_data_(data) -check_family_(family) -control <- check_control_(control) -formula <- update_formula_(formula) -lhs <- NA # just to avoid global variable warning -nobs.na <- NA -nobs.full <- NA -model_frame_(data, formula, weights) -check_response_(data, lhs, family) -k.vars <- attr(terms(formula, rhs = 2L), "term.labels") -k <- length(k.vars) -tmp.var <- temp_var_(data) -data <- drop_by_link_type_(data, lhs, family, tmp.var, k.vars, control) -data <- transform_fe_(data, formula, k.vars) -nt <- nrow(data) -nobs <- nobs_(nobs.full, nobs.na, nt) -nms.sp <- NA -p <- NA -model_response_(data, formula) - -p - -qr_(X, FALSE)$rank -out <- qr(X) -dim(out$qr) - -bench_ppml$median -bench_ppml$mem_alloc - -# rm(d) - -# trade diversion ---- - -form <- trade ~ 0 + log_dist + cntg + lang + clny + - rta + exp_year + imp_year + intl_brdr - -form2 <- trade ~ log_dist + cntg + lang + clny + - rta | exp_year + imp_year + intl_brdr - -d <- ch1_application3 - -bench_trade_diversion <- mark( - round(fepoisson(form2, data = d)$coefficients["rta"], 3) -) - -bench_trade_diversion$median -bench_trade_diversion$mem_alloc - -# rm(d) - -# endogeneity ---- - -# form <- trade ~ 0 + rta + exp_year + imp_year + pair_id_2 -# form2 <- trade ~ rta | exp_year + imp_year + pair_id_2 - -# d <- filter(ch1_application3, sum_trade > 0) - -# bench_endogeneity <- mark( -# round(fepoisson(form2, data = d)$coefficients["rta"], 3), -# iterations = 1000L -# ) - -bench_endogeneity - -# rm(d) - -# reverse causality ---- - -# form <- trade ~ 0 + rta + rta_lead4 + exp_year + imp_year + pair_id_2 -# form2 <- trade ~ rta + rta_lead4 | exp_year + imp_year + pair_id_2 - -# d <- filter(ch1_application3, sum_trade > 0) - -# bench_reverse_causality <- mark( -# round(fepoisson(form2, data = d)$coefficients["rta"], 3) -# ) - -# bench_reverse_causality - -# rm(d) - -# non-linear/phasing effects ---- - -# form <- trade ~ 0 + rta + rta_lag4 + rta_lag8 + rta_lag12 + -# exp_year + imp_year + pair_id_2 - -# form2 <- trade ~ rta + rta_lag4 + rta_lag8 + rta_lag12 | -# exp_year + imp_year + pair_id_2 - -# d <- filter(ch1_application3, sum_trade > 0) - -# bench_phasing <- mark( -# round(fepoisson(form2, data = d)$coefficients["rta"], 3) -# ) - -# bench_phasing - -# rm(d) - -# globalization ---- - -form <- trade ~ 0 + rta + rta_lag4 + rta_lag8 + rta_lag12 + - intl_border_1986 + intl_border_1990 + intl_border_1994 + - intl_border_1998 + intl_border_2002 + - exp_year + imp_year + pair_id_2 - -form2 <- trade ~ rta + rta_lag4 + rta_lag8 + rta_lag12 + - intl_border_1986 + intl_border_1990 + intl_border_1994 + - intl_border_1998 + intl_border_2002 | - exp_year + imp_year + pair_id_2 - -d <- filter(ch1_application3, sum_trade > 0) - -bench_globalization <- mark( - round(fepoisson(form2, data = d)$coefficients["rta"], 3) -) - -bench_globalization - -rm(d, form, ch1_application3) - -rm(list = ls()) -gc() diff --git a/dev/benchmarks_tests_agtpa_capybara_only.R b/dev/benchmarks_tests_agtpa_capybara_only.R index 236574f..21c7d2e 100644 --- a/dev/benchmarks_tests_agtpa_capybara_only.R +++ b/dev/benchmarks_tests_agtpa_capybara_only.R @@ -1,7 +1,7 @@ # this is not just about speed/memory, but also about obtaining the same # slopes as in base R -library(capybara) +library(alpaca) library(dplyr) library(tidyr) library(janitor) diff --git a/dev/test-helpers.R b/dev/test-helpers.R new file mode 100644 index 0000000..04729f8 --- /dev/null +++ b/dev/test-helpers.R @@ -0,0 +1,18 @@ +test_that("multiplication works", { + # get_index_list_r_ <- function(k.vars, data) { + # indexes <- seq.int(0L, nrow(data) - 1L) + # lapply(k.vars, function(x, indexes, data) { + # split(indexes, data[[x]]) + # }, indexes = indexes, data = data) + # } + + # expect_equal( + # get_index_list_(names(mtcars), mtcars), + # get_index_list_r_(names(mtcars), mtcars) + # ) + + # expect_equal( + # get_index_list_(names(iris), iris), + # get_index_list_r_(names(iris), iris) + # ) +}) diff --git a/docs/404.html b/docs/404.html index 6b35323..a945fa2 100644 --- a/docs/404.html +++ b/docs/404.html @@ -39,7 +39,7 @@ capybara - 0.5.2 + 0.6.0 diff --git a/docs/CODE_OF_CONDUCT.html b/docs/CODE_OF_CONDUCT.html index dab6e73..4590326 100644 --- a/docs/CODE_OF_CONDUCT.html +++ b/docs/CODE_OF_CONDUCT.html @@ -17,7 +17,7 @@ capybara - 0.5.2 + 0.6.0 diff --git a/docs/CONTRIBUTING.html b/docs/CONTRIBUTING.html index a8e0609..6184ced 100644 --- a/docs/CONTRIBUTING.html +++ b/docs/CONTRIBUTING.html @@ -17,7 +17,7 @@ capybara - 0.5.2 + 0.6.0 diff --git a/docs/LICENSE.html b/docs/LICENSE.html index e2305ab..4f37ea2 100644 --- a/docs/LICENSE.html +++ b/docs/LICENSE.html @@ -17,7 +17,7 @@ capybara - 0.5.2 + 0.6.0 diff --git a/docs/articles/index.html b/docs/articles/index.html index 9eabf7e..bc96bc8 100644 --- a/docs/articles/index.html +++ b/docs/articles/index.html @@ -17,7 +17,7 @@ capybara - 0.5.2 + 0.6.0 diff --git a/docs/articles/intro.html b/docs/articles/intro.html index 9ef0b0b..0496226 100644 --- a/docs/articles/intro.html +++ b/docs/articles/intro.html @@ -40,7 +40,7 @@ capybara - 0.5.2 + 0.6.0 diff --git a/docs/authors.html b/docs/authors.html index d61c09d..a177fc8 100644 --- a/docs/authors.html +++ b/docs/authors.html @@ -17,7 +17,7 @@ capybara - 0.5.2 + 0.6.0 @@ -74,14 +74,14 @@

Citation

Vargas Sepulveda M (2024). capybara: Fast and Memory Efficient Fitting of Linear Models With High-Dimensional Fixed Effects. -R package version 0.5.2, https://github.com/pachadotdev/capybara, https://pacha.dev/capybara/. +R package version 0.6.0, https://github.com/pachadotdev/capybara, https://pacha.dev/capybara/. 

@Manual{,
   title = {capybara: Fast and Memory Efficient Fitting of Linear Models With High-Dimensional
 Fixed Effects},
   author = {Mauricio {Vargas Sepulveda}},
   year = {2024},
-  note = {R package version 0.5.2, https://github.com/pachadotdev/capybara},
+  note = {R package version 0.6.0, https://github.com/pachadotdev/capybara},
   url = {https://pacha.dev/capybara/},
 }
diff --git a/docs/index.html b/docs/index.html index dbb9e93..c951618 100644 --- a/docs/index.html +++ b/docs/index.html @@ -46,7 +46,7 @@ capybara - 0.5.2 + 0.6.0 @@ -140,13 +140,13 @@

BenchmarksAn Advanced Guide to Trade Policy Analysis.

------++++++ @@ -160,39 +160,39 @@

Benchmarks

- - - - - - + + + + + + - - - - - - + + + + + + - - - - - - + + + + + + - - - - - - + + + + + +
packageAlpaca346.4ms2.52s1.51s1.9s2.96s5.57s0.4s2.6s1.6s2.0s3.1s5.3s
Base R1.5m1.53m23.43m23.52m23.16m24.85m120.0s2.0m1380.0s1440.0s1380.0s1500.0s
Capybara440ms2.86s1.92s2.29s2.96s4.46s0.3s2.2s1.4s1.7s2.1s3.9s
Fixest64.9ms503ms106.14ms145.04ms243.61ms524.7ms0.1s0.5s0.1s0.2s0.3s0.5s
@@ -219,39 +219,39 @@

Benchmarks Alpaca +307MB +341MB 306MB -340.8MB -306.4MB -335.9MB -394.6MB -541.3MB +336MB +395MB +541MB Base R -2.7GB -2.6GB -11.9GB -11.92GB -11.95GB -11.97GB +3000MB +3000MB +12000MB +12000GB +12000GB +12000MB Capybara -210MB -235MB -241MB -249MB -263MB -299MB +29MB +34MB +21MB +24MB +30MB +47MB Fixest -44.4MB -36.4MB -27.9MB -32.2MB -40.9MB -62.7MB +44MB +36MB +27MB +32MB +41MB +63MB @@ -260,7 +260,7 @@

Benchmarks

Debugging

-

This debugging is about code quality, not about statistical quality. There is a full set of numerical tests for testthat to check the math. In this section of the test, I can write pi = 3 and if there are no memory leaks, it will pass the test.

+

This debugging is about code quality, not about statistical quality. There is a full set of numerical tests for testthat to check the math. In this section of the test, I could write “pi = 3” and if there are no memory leaks, it will pass the test.

I run r_valgrind "dev/test_get_alpha.r" or the corresponding test from the project’s root in a new terminal (bash).

This works because I previously defined this in .bashrc, to make it work you need to run source ~/.bashrc or reboot:

function r_debug_symbols () {
@@ -328,6 +328,11 @@ 
Debugging
+
Code of Conduct
+

+
Please note that the capybara project is released with a Contributor Code of Conduct. By contributing to this project, you agree to abide by its terms.

+
diff --git a/docs/news/index.html b/docs/news/index.html index b0accd0..8d7cdfe 100644 --- a/docs/news/index.html +++ b/docs/news/index.html @@ -17,7 +17,7 @@ capybara - 0.5.2 + 0.6.0 @@ -57,6 +57,11 @@

Changelog

Source: NEWS.md +
+

capybara 0.6.0

+
  • Moves all the heavy computation to C++ using Armadillo and it exports the results to R. Previously, there were multiple data copies between R and C++ that added overhead to the computations.
    • +
  • For a future release, I may rewrite the offset and APES computation to C++, but with those the overhead is minimal.
    • +

capybara 0.5.2

  • Uses an O(n log(n)) algorithm to compute the Kendall correlation for the pseudo-R2 in the Poisson model.
diff --git a/docs/pkgdown.yml b/docs/pkgdown.yml index 82a9933..b16a896 100644 --- a/docs/pkgdown.yml +++ b/docs/pkgdown.yml @@ -3,5 +3,5 @@ pkgdown: 2.0.7 pkgdown_sha: ~ articles: intro: intro.html -last_built: 2024-07-16T00:21Z +last_built: 2024-07-22T03:41Z diff --git a/docs/reference/apes.html b/docs/reference/apes.html index bec9e49..6032919 100644 --- a/docs/reference/apes.html +++ b/docs/reference/apes.html @@ -26,7 +26,7 @@ capybara - 0.5.2 + 0.6.0 @@ -82,10 +82,10 @@

Compute average partial effects after fitting binary choice models 
apes(
   object = NULL,
-  n.pop = NULL,
-  panel.structure = c("classic", "network"),
-  sampling.fe = c("independence", "unrestricted"),
-  weak.exo = FALSE
+  n_pop = NULL,
+  panel_structure = c("classic", "network"),
+  sampling_fe = c("independence", "unrestricted"),
+  weak_exo = FALSE
 )
@@ -96,7 +96,7 @@

Arguments

currently restricted to binomial.

-
n.pop
+
n_pop

unsigned integer indicating a finite population correction for the estimation of the covariance matrix of the average partial effects proposed by Cruz-Gonzalez, Fernández-Val, and Weidner (2017). The correction @@ -107,7 +107,7 @@

Arguments

a factor of zero and a covariance obtained by the delta method.

-
panel.structure
+
panel_structure

a string equal to "classic" or "network" which determines the structure of the panel used. "classic" denotes panel structures where for example the same cross-sectional units are @@ -116,7 +116,7 @@

Arguments

observed for several time periods. Default is "classic".

-
sampling.fe
+
sampling_fe

a string equal to "independence" or "unrestricted" which imposes sampling assumptions about the unobserved effects. "independence" imposes that all unobserved @@ -125,7 +125,7 @@

Arguments

population correction. Default is "independence".

-
weak.exo
+
weak_exo

logical indicating if some of the regressors are assumed to be weakly exogenous (e.g. predetermined). If object is of class "bias_corr", the option will be automatically set to TRUE if @@ -178,7 +178,7 @@

Examples

summary(mod_ape) #> Estimates: #> Estimate Std. Error z value Pr(>|z|) -#> lang 0.05594 0.01512 3.699 0.000217 *** +#> lang 0.05594 0.01513 3.698 0.000218 *** #> --- #> Signif. codes: 0 ‘***’ 0.001 ‘**’ 0.01 ‘*’ 0.05 ‘.’ 0.1 ‘ ’ 1 @@ -186,7 +186,7 @@

Examples

mod_bc <- bias_corr(mod) summary(mod_bc) #> Formula: trade ~ lang | year -#> <environment: 0x6194fd0f13a0> +#> <environment: 0x5fa3c5f54f50> #> #> Family: Binomial #> @@ -194,7 +194,7 @@

Examples

#> #> | | Estimate | Std. Error | z value | Pr(>|z|) | #> |------|----------|------------|---------|------------| -#> | lang | 0.2393 | 0.0634 | 3.7724 | 0.0002 *** | +#> | lang | 0.2394 | 0.0634 | 3.7740 | 0.0002 *** | #> #> Significance codes: *** 99.9%; ** 99%; * 95%; . 90% #> @@ -204,12 +204,9 @@

Examples

# Compute bias-corrected average partial effects mod_ape_bc <- apes(mod_bc) +#> Error in if (panel_structure == "classic") { if (!(k %in% c(1L, 2L))) { stop(paste("panel_structure == 'classic' expects a one- or two-way fixed", "effects model."), call. = FALSE) }} else { if (!(k %in% c(2L, 3L))) { stop(paste("panel_structure == 'network' expects a two- or three-way fixed", "effects model."), call. = FALSE) }}: argument is of length zero summary(mod_ape_bc) -#> Estimates: -#> Estimate Std. Error z value Pr(>|z|) -#> lang 0.05593 0.01512 3.698 0.000217 *** -#> --- -#> Signif. codes: 0 ‘***’ 0.001 ‘**’ 0.01 ‘*’ 0.05 ‘.’ 0.1 ‘ ’ 1 +#> Error in eval(expr, envir, enclos): object 'mod_ape_bc' not found diff --git a/docs/reference/bias_corr.html b/docs/reference/bias_corr.html index fba8378..2c72fce 100644 --- a/docs/reference/bias_corr.html +++ b/docs/reference/bias_corr.html @@ -24,7 +24,7 @@ capybara - 0.5.2 + 0.6.0 @@ -146,7 +146,7 @@

Examples

mod_bc <- bias_corr(mod) summary(mod_bc) #> Formula: trade ~ lang | year -#> <environment: 0x6194fd0d1c00> +#> <environment: 0x5fa3c58f51f0> #> #> Family: Binomial #> @@ -154,7 +154,7 @@

Examples

#> #> | | Estimate | Std. Error | z value | Pr(>|z|) | #> |------|----------|------------|---------|------------| -#> | lang | 0.2393 | 0.0634 | 3.7724 | 0.0002 *** | +#> | lang | 0.2394 | 0.0634 | 3.7740 | 0.0002 *** | #> #> Significance codes: *** 99.9%; ** 99%; * 95%; . 90% #> diff --git a/docs/reference/capybara-package.html b/docs/reference/capybara-package.html index 471542f..280f8cc 100644 --- a/docs/reference/capybara-package.html +++ b/docs/reference/capybara-package.html @@ -26,7 +26,7 @@ capybara - 0.5.2 + 0.6.0 diff --git a/docs/reference/feglm.html b/docs/reference/feglm.html index c395427..908094d 100644 --- a/docs/reference/feglm.html +++ b/docs/reference/feglm.html @@ -22,7 +22,7 @@ capybara - 0.5.2 + 0.6.0 @@ -78,8 +78,8 @@

GLM fitting with high-dimensional k-way fixed effects

data = NULL, family = gaussian(), weights = NULL, - beta.start = NULL, - eta.start = NULL, + beta_start = NULL, + eta_start = NULL, control = NULL ) @@ -111,13 +111,13 @@

Arguments

variable in data.

-
beta.start
+
beta_start

an optional vector of starting values for the structural parameters in the linear predictor. Default is \(\boldsymbol{\beta} = \mathbf{0}\).

-
eta.start
+
eta_start

an optional vector of starting values for the linear predictor.

@@ -162,7 +162,7 @@

Examples

summary(mod) #> Formula: trade ~ log_dist + lang + cntg + clny | exp_year + imp_year -#> <environment: 0x6194fe4f6ed0> +#> <environment: 0x5fa3c55b9a20> #> #> Family: Poisson #> @@ -192,7 +192,7 @@

Examples

summary(mod, type = "clustered") #> Formula: trade ~ log_dist + lang + cntg + clny | exp_year + imp_year | #> pair -#> <environment: 0x6194fe4f6ed0> +#> <environment: 0x5fa3c55b9a20> #> #> Family: Poisson #> diff --git a/docs/reference/feglm_control.html b/docs/reference/feglm_control.html index 7ee1cec..ec24887 100644 --- a/docs/reference/feglm_control.html +++ b/docs/reference/feglm_control.html @@ -18,7 +18,7 @@ capybara - 0.5.2 + 0.6.0 @@ -66,33 +66,33 @@

Set feglm Control Parameters

feglm_control(
-  dev.tol = 1e-08,
-  center.tol = 1e-08,
-  iter.max = 25L,
+  dev_tol = 1e-08,
+  center_tol = 1e-08,
+  iter_max = 25L,
   limit = 10L,
   trace = FALSE,
-  drop.pc = TRUE,
-  keep.mx = TRUE
+  drop_pc = TRUE,
+  keep_mx = TRUE
 )

Arguments

-
dev.tol
+
dev_tol

tolerance level for the first stopping condition of the maximization routine. The stopping condition is based on the relative change of the deviance in iteration \(r\) and can be expressed as follows: \(|dev_{r} - dev_{r - 1}| / (0.1 + |dev_{r}|) < tol\). The default is 1.0e-08.

-
center.tol
+
center_tol

tolerance level for the stopping condition of the centering algorithm. The stopping condition is based on the relative change of the centered variable similar to the 'lfe' package. The default is 1.0e-08.

-
iter.max
+
iter_max

unsigned integer indicating the maximum number of iterations in the maximization routine. The default is 25L.

@@ -107,7 +107,7 @@

Arguments

iteration. Default is FALSE.

-
drop.pc
+
drop_pc

logical indicating to drop observations that are perfectly classified/separated and hence do not contribute to the log-likelihood. This option is useful to reduce the computational costs of the maximization @@ -116,7 +116,7 @@

Arguments

The default is TRUE.

-
keep.mx
+
keep_mx

logical indicating if the centered regressor matrix should be stored. The centered regressor matrix is required for some covariance estimators, bias corrections, and average partial effects. This option saves diff --git a/docs/reference/felm.html b/docs/reference/felm.html index 53de5a3..ad1d1c1 100644 --- a/docs/reference/felm.html +++ b/docs/reference/felm.html @@ -18,7 +18,7 @@ capybara - 0.5.2 + 0.6.0

@@ -116,7 +116,7 @@

Examples

summary(mod) #> Formula: log(trade) ~ log_dist + lang + cntg + clny | exp_year + imp_year -#> <environment: 0x6194fe51d928> +#> <environment: 0x5fa3c75f1ab0> #> #> Estimates: #> @@ -130,7 +130,7 @@

Examples

#> Significance codes: *** 99.9%; ** 99%; * 95%; . 90% #> #> R-squared : 0.2761 -#> Adj. R-squared: 0.2541 +#> Adj. R-squared: 0.276 #> #> Number of observations: Full 28152; Missing 0; Perfect classification 0 diff --git a/docs/reference/fenegbin.html b/docs/reference/fenegbin.html index 5170cfd..a665741 100644 --- a/docs/reference/fenegbin.html +++ b/docs/reference/fenegbin.html @@ -19,7 +19,7 @@ capybara - 0.5.2 + 0.6.0 @@ -70,9 +70,9 @@

Negative Binomial model fitting with high-dimensional k-way fixed formula = NULL, data = NULL, weights = NULL, - beta.start = NULL, - eta.start = NULL, - init.theta = NULL, + beta_start = NULL, + eta_start = NULL, + init_theta = NULL, link = c("log", "identity", "sqrt"), control = NULL ) @@ -98,18 +98,18 @@

Arguments

variable in data.

-
beta.start
+
beta_start

an optional vector of starting values for the structural parameters in the linear predictor. Default is \(\boldsymbol{\beta} = \mathbf{0}\).

-
eta.start
+
eta_start

an optional vector of starting values for the linear predictor.

-
init.theta
+
init_theta

an optional initial value for the theta parameter (see glm.nb).

@@ -141,7 +141,7 @@

Examples

summary(mod) #> Formula: trade ~ log_dist + lang + cntg + clny | exp_year + imp_year -#> <environment: 0x6194fec80d60> +#> <environment: 0x5fa3c7540330> #> #> Family: Negative Binomial(1.1839) #> diff --git a/docs/reference/fepoisson.html b/docs/reference/fepoisson.html index 13dc8c5..2c38a99 100644 --- a/docs/reference/fepoisson.html +++ b/docs/reference/fepoisson.html @@ -18,7 +18,7 @@ capybara - 0.5.2 + 0.6.0 @@ -69,8 +69,8 @@

Poisson model fitting high-dimensional with k-way fixed effects

formula = NULL, data = NULL, weights = NULL, - beta.start = NULL, - eta.start = NULL, + beta_start = NULL, + eta_start = NULL, control = NULL ) @@ -95,13 +95,13 @@

Arguments

variable in data.

-
beta.start
+
beta_start

an optional vector of starting values for the structural parameters in the linear predictor. Default is \(\boldsymbol{\beta} = \mathbf{0}\).

-
eta.start
+
eta_start

an optional vector of starting values for the linear predictor.

@@ -128,7 +128,7 @@

Examples

summary(mod) #> Formula: trade ~ log_dist + lang + cntg + clny | exp_year + imp_year -#> <environment: 0x6194fe9e6d30> +#> <environment: 0x5fa3c48bf728> #> #> Family: Poisson #> diff --git a/docs/reference/fixed_effects.html b/docs/reference/fixed_effects.html index 0d3223f..91f2078 100644 --- a/docs/reference/fixed_effects.html +++ b/docs/reference/fixed_effects.html @@ -20,7 +20,7 @@ capybara - 0.5.2 + 0.6.0 @@ -69,7 +69,7 @@

Recover the estimates of the fixed effects after fitting (G)LMs

- 
fixed_effects(object = NULL, alpha.tol = 1e-08)
+ 
fixed_effects(object = NULL, alpha_tol = 1e-08)
@@ -78,7 +78,7 @@

Arguments

an object of class "feglm".

-
alpha.tol
+
alpha_tol

tolerance level for the stopping condition. The algorithm is stopped at iteration \(i\) if \(||\boldsymbol{\alpha}_{i} - \boldsymbol{\alpha}_{i - 1}||_{2} < tol ||\boldsymbol{\alpha}_{i - 1}|| diff --git a/docs/reference/index.html b/docs/reference/index.html index 2c38e11..80d9012 100644 --- a/docs/reference/index.html +++ b/docs/reference/index.html @@ -17,7 +17,7 @@ capybara - 0.5.2 + 0.6.0

diff --git a/docs/reference/kendall_cor.html b/docs/reference/kendall_cor.html index 2b5cabd..4220891 100644 --- a/docs/reference/kendall_cor.html +++ b/docs/reference/kendall_cor.html @@ -28,7 +28,7 @@ capybara - 0.5.2 + 0.6.0 diff --git a/docs/reference/kendall_cor_test.html b/docs/reference/kendall_cor_test.html index f66fc93..930dc2c 100644 --- a/docs/reference/kendall_cor_test.html +++ b/docs/reference/kendall_cor_test.html @@ -19,7 +19,7 @@ capybara - 0.5.2 + 0.6.0 diff --git a/docs/reference/pipe.html b/docs/reference/pipe.html index 5a26aaa..3dba9cf 100644 --- a/docs/reference/pipe.html +++ b/docs/reference/pipe.html @@ -17,7 +17,7 @@ capybara - 0.5.2 + 0.6.0 diff --git a/docs/reference/reexports.html b/docs/reference/reexports.html index 03ef988..a4b7b03 100644 --- a/docs/reference/reexports.html +++ b/docs/reference/reexports.html @@ -24,7 +24,7 @@ capybara - 0.5.2 + 0.6.0 diff --git a/docs/reference/trade_panel.html b/docs/reference/trade_panel.html index bbde894..2415b96 100644 --- a/docs/reference/trade_panel.html +++ b/docs/reference/trade_panel.html @@ -17,7 +17,7 @@ capybara - 0.5.2 + 0.6.0 diff --git a/docs/reference/vcov.feglm.html b/docs/reference/vcov.feglm.html index 3907120..3782ca5 100644 --- a/docs/reference/vcov.feglm.html +++ b/docs/reference/vcov.feglm.html @@ -1,7 +1,7 @@ Covariance matrix for GLMs — vcov.feglm • capybara @@ -19,7 +19,7 @@ capybara - 0.5.2 + 0.6.0 @@ -63,7 +63,7 @@

Covariance matrix for GLMs

Covariance matrix for the estimator of the structural parameters from objects returned by feglm. The covariance is computed -from the Hessian, the scores, or a combination of both after convergence.

+from the hessian, the scores, or a combination of both after convergence.

@@ -83,7 +83,7 @@

Arguments

type

the type of covariance estimate required. "hessian" refers -to the inverse of the negative expected Hessian after convergence and is the +to the inverse of the negative expected hessian after convergence and is the default option. "outer.product" is the outer-product-of-the-gradient estimator. "sandwich" is the sandwich estimator (sometimes also referred as robust estimator), and "clustered" computes a clustered @@ -121,11 +121,11 @@

Examples

) round(vcov(mod, type = "clustered"), 5) -#> [,1] [,2] [,3] [,4] -#> [1,] 0.00068 0.00005 0.00106 -0.00063 -#> [2,] 0.00005 0.00388 -0.00118 -0.00193 -#> [3,] 0.00106 -0.00118 0.00452 -0.00013 -#> [4,] -0.00063 -0.00193 -0.00013 0.00854 +#> log_dist lang cntg clny +#> log_dist 0.00068 0.00005 0.00106 -0.00063 +#> lang 0.00005 0.00388 -0.00118 -0.00193 +#> cntg 0.00106 -0.00118 0.00452 -0.00013 +#> clny -0.00063 -0.00193 -0.00013 0.00854
diff --git a/docs/reference/vcov.felm.html b/docs/reference/vcov.felm.html index fb77315..ba886b4 100644 --- a/docs/reference/vcov.felm.html +++ b/docs/reference/vcov.felm.html @@ -1,7 +1,7 @@ Covariance matrix for LMs — vcov.felm • capybara @@ -19,7 +19,7 @@ capybara - 0.5.2 + 0.6.0 @@ -62,8 +62,8 @@

Covariance matrix for LMs

Covariance matrix for the estimator of the structural parameters -from objects returned by feglm. The covariance is computed -from the Hessian, the scores, or a combination of both after convergence.

+from objects returned by felm. The covariance is computed +from the hessian, the scores, or a combination of both after convergence.

@@ -78,12 +78,12 @@

Covariance matrix for LMs

Arguments

object
-

an object of class "feglm".

+

an object of class "felm".

type

the type of covariance estimate required. "hessian" refers -to the inverse of the negative expected Hessian after convergence and is the +to the inverse of the negative expected hessian after convergence and is the default option. "outer.product" is the outer-product-of-the-gradient estimator. "sandwich" is the sandwich estimator (sometimes also referred as robust estimator), and "clustered" computes a clustered @@ -121,11 +121,11 @@

Examples

) round(vcov(mod, type = "clustered"), 5) -#> [,1] [,2] [,3] [,4] -#> [1,] 0.00068 0.00005 0.00106 -0.00063 -#> [2,] 0.00005 0.00388 -0.00118 -0.00193 -#> [3,] 0.00106 -0.00118 0.00452 -0.00013 -#> [4,] -0.00063 -0.00193 -0.00013 0.00854 +#> log_dist lang cntg clny +#> log_dist 0.00068 0.00005 0.00106 -0.00063 +#> lang 0.00005 0.00388 -0.00118 -0.00193 +#> cntg 0.00106 -0.00118 0.00452 -0.00013 +#> clny -0.00063 -0.00193 -0.00013 0.00854
diff --git a/man/apes.Rd b/man/apes.Rd index 2e2cd7d..ad61f9a 100644 --- a/man/apes.Rd +++ b/man/apes.Rd @@ -7,40 +7,40 @@ with a 1,2,3-way error component} \usage{ apes( object = NULL, - n.pop = NULL, - panel.structure = c("classic", "network"), - sampling.fe = c("independence", "unrestricted"), - weak.exo = FALSE + n_pop = NULL, + panel_structure = c("classic", "network"), + sampling_fe = c("independence", "unrestricted"), + weak_exo = FALSE ) } \arguments{ \item{object}{an object of class \code{"bias_corr"} or \code{"feglm"}; currently restricted to \code{\link[stats]{binomial}}.} -\item{n.pop}{unsigned integer indicating a finite population correction for +\item{n_pop}{unsigned integer indicating a finite population correction for the estimation of the covariance matrix of the average partial effects proposed by Cruz-Gonzalez, Fernández-Val, and Weidner (2017). The correction factor is computed as follows: -\eqn{(n^{\ast} - n) / (n^{\ast} - 1)}{(n.pop - n) / (n.pop - 1)}, -where \eqn{n^{\ast}}{n.pop} and \eqn{n}{n} are the sizes of the entire +\eqn{(n^{\ast} - n) / (n^{\ast} - 1)}{(n_pop - n) / (n_pop - 1)}, +where \eqn{n^{\ast}}{n_pop} and \eqn{n}{n} are the sizes of the entire population and the full sample size. Default is \code{NULL}, which refers to a factor of zero and a covariance obtained by the delta method.} -\item{panel.structure}{a string equal to \code{"classic"} or \code{"network"} +\item{panel_structure}{a string equal to \code{"classic"} or \code{"network"} which determines the structure of the panel used. \code{"classic"} denotes panel structures where for example the same cross-sectional units are observed several times (this includes pseudo panels). \code{"network"} denotes panel structures where for example bilateral trade flows are observed for several time periods. Default is \code{"classic"}.} -\item{sampling.fe}{a string equal to \code{"independence"} or +\item{sampling_fe}{a string equal to \code{"independence"} or \code{"unrestricted"} which imposes sampling assumptions about the unobserved effects. \code{"independence"} imposes that all unobserved effects are independent sequences. \code{"unrestricted"} does not impose any sampling assumptions. Note that this option only affects the optional finite population correction. Default is \code{"independence"}.} -\item{weak.exo}{logical indicating if some of the regressors are assumed to +\item{weak_exo}{logical indicating if some of the regressors are assumed to be weakly exogenous (e.g. predetermined). If object is of class \code{"bias_corr"}, the option will be automatically set to \code{TRUE} if the chosen bandwidth parameter is larger than zero. Note that this option diff --git a/man/feglm.Rd b/man/feglm.Rd index aed0168..f8c376d 100644 --- a/man/feglm.Rd +++ b/man/feglm.Rd @@ -9,8 +9,8 @@ feglm( data = NULL, family = gaussian(), weights = NULL, - beta.start = NULL, - eta.start = NULL, + beta_start = NULL, + eta_start = NULL, control = NULL ) } @@ -32,11 +32,11 @@ details of family functions.} \item{weights}{an optional string with the name of the 'prior weights' variable in \code{data}.} -\item{beta.start}{an optional vector of starting values for the structural +\item{beta_start}{an optional vector of starting values for the structural parameters in the linear predictor. Default is \eqn{\boldsymbol{\beta} = \mathbf{0}}{\beta = 0}.} -\item{eta.start}{an optional vector of starting values for the linear +\item{eta_start}{an optional vector of starting values for the linear predictor.} \item{control}{a named list of parameters for controlling the fitting diff --git a/man/feglm_control.Rd b/man/feglm_control.Rd index 1afece9..b5d7c89 100644 --- a/man/feglm_control.Rd +++ b/man/feglm_control.Rd @@ -5,28 +5,28 @@ \title{Set \code{feglm} Control Parameters} \usage{ feglm_control( - dev.tol = 1e-08, - center.tol = 1e-08, - iter.max = 25L, + dev_tol = 1e-08, + center_tol = 1e-08, + iter_max = 25L, limit = 10L, trace = FALSE, - drop.pc = TRUE, - keep.mx = TRUE + drop_pc = TRUE, + keep_mx = TRUE ) } \arguments{ -\item{dev.tol}{tolerance level for the first stopping condition of the +\item{dev_tol}{tolerance level for the first stopping condition of the maximization routine. The stopping condition is based on the relative change of the deviance in iteration \eqn{r} and can be expressed as follows: \eqn{|dev_{r} - dev_{r - 1}| / (0.1 + |dev_{r}|) < tol}{|dev - devold| / (0.1 + |dev|) < tol}. The default is \code{1.0e-08}.} -\item{center.tol}{tolerance level for the stopping condition of the centering +\item{center_tol}{tolerance level for the stopping condition of the centering algorithm. The stopping condition is based on the relative change of the centered variable similar to the \code{'lfe'} package. The default is \code{1.0e-08}.} -\item{iter.max}{unsigned integer indicating the maximum number of iterations +\item{iter_max}{unsigned integer indicating the maximum number of iterations in the maximization routine. The default is \code{25L}.} \item{limit}{unsigned integer indicating the maximum number of iterations of @@ -35,14 +35,14 @@ in the maximization routine. The default is \code{25L}.} \item{trace}{logical indicating if output should be produced in each iteration. Default is \code{FALSE}.} -\item{drop.pc}{logical indicating to drop observations that are perfectly +\item{drop_pc}{logical indicating to drop observations that are perfectly classified/separated and hence do not contribute to the log-likelihood. This option is useful to reduce the computational costs of the maximization problem and improves the numerical stability of the algorithm. Note that dropping perfectly separated observations does not affect the estimates. The default is \code{TRUE}.} -\item{keep.mx}{logical indicating if the centered regressor matrix should be +\item{keep_mx}{logical indicating if the centered regressor matrix should be stored. The centered regressor matrix is required for some covariance estimators, bias corrections, and average partial effects. This option saves some computation time at the cost of memory. The default is \code{TRUE}.} diff --git a/man/fenegbin.Rd b/man/fenegbin.Rd index 273d85c..8ff9039 100644 --- a/man/fenegbin.Rd +++ b/man/fenegbin.Rd @@ -9,9 +9,9 @@ fenegbin( formula = NULL, data = NULL, weights = NULL, - beta.start = NULL, - eta.start = NULL, - init.theta = NULL, + beta_start = NULL, + eta_start = NULL, + init_theta = NULL, link = c("log", "identity", "sqrt"), control = NULL ) @@ -29,14 +29,14 @@ in the model.} \item{weights}{an optional string with the name of the 'prior weights' variable in \code{data}.} -\item{beta.start}{an optional vector of starting values for the structural +\item{beta_start}{an optional vector of starting values for the structural parameters in the linear predictor. Default is \eqn{\boldsymbol{\beta} = \mathbf{0}}{\beta = 0}.} -\item{eta.start}{an optional vector of starting values for the linear +\item{eta_start}{an optional vector of starting values for the linear predictor.} -\item{init.theta}{an optional initial value for the theta parameter (see +\item{init_theta}{an optional initial value for the theta parameter (see \code{\link[MASS]{glm.nb}}).} \item{link}{the link function. Must be one of \code{"log"}, \code{"sqrt"}, or diff --git a/man/fepoisson.Rd b/man/fepoisson.Rd index 37924a0..392ca8f 100644 --- a/man/fepoisson.Rd +++ b/man/fepoisson.Rd @@ -8,8 +8,8 @@ fepoisson( formula = NULL, data = NULL, weights = NULL, - beta.start = NULL, - eta.start = NULL, + beta_start = NULL, + eta_start = NULL, control = NULL ) } @@ -26,11 +26,11 @@ in the model.} \item{weights}{an optional string with the name of the 'prior weights' variable in \code{data}.} -\item{beta.start}{an optional vector of starting values for the structural +\item{beta_start}{an optional vector of starting values for the structural parameters in the linear predictor. Default is \eqn{\boldsymbol{\beta} = \mathbf{0}}{\beta = 0}.} -\item{eta.start}{an optional vector of starting values for the linear +\item{eta_start}{an optional vector of starting values for the linear predictor.} \item{control}{a named list of parameters for controlling the fitting diff --git a/man/fixed_effects.Rd b/man/fixed_effects.Rd index 1e625b5..92dca22 100644 --- a/man/fixed_effects.Rd +++ b/man/fixed_effects.Rd @@ -4,12 +4,12 @@ \alias{fixed_effects} \title{Recover the estimates of the fixed effects after fitting (G)LMs} \usage{ -fixed_effects(object = NULL, alpha.tol = 1e-08) +fixed_effects(object = NULL, alpha_tol = 1e-08) } \arguments{ \item{object}{an object of class \code{"feglm"}.} -\item{alpha.tol}{tolerance level for the stopping condition. The algorithm is +\item{alpha_tol}{tolerance level for the stopping condition. The algorithm is stopped at iteration \eqn{i} if \eqn{||\boldsymbol{\alpha}_{i} - \boldsymbol{\alpha}_{i - 1}||_{2} < tol ||\boldsymbol{\alpha}_{i - 1}|| {2}}{||\Delta \alpha|| < tol ||\alpha_old||}. Default is \code{1.0e-08}.} diff --git a/man/vcov.feglm.Rd b/man/vcov.feglm.Rd index d81d66f..9e56b20 100644 --- a/man/vcov.feglm.Rd +++ b/man/vcov.feglm.Rd @@ -14,7 +14,7 @@ \item{object}{an object of class \code{"feglm"}.} \item{type}{the type of covariance estimate required. \code{"hessian"} refers -to the inverse of the negative expected Hessian after convergence and is the +to the inverse of the negative expected hessian after convergence and is the default option. \code{"outer.product"} is the outer-product-of-the-gradient estimator. \code{"sandwich"} is the sandwich estimator (sometimes also referred as robust estimator), and \code{"clustered"} computes a clustered @@ -30,7 +30,7 @@ A named matrix of covariance estimates. \description{ Covariance matrix for the estimator of the structural parameters from objects returned by \code{\link{feglm}}. The covariance is computed -from the Hessian, the scores, or a combination of both after convergence. +from the hessian, the scores, or a combination of both after convergence. } \examples{ mod <- fepoisson( diff --git a/man/vcov.felm.Rd b/man/vcov.felm.Rd index e97c1de..9b3ac9a 100644 --- a/man/vcov.felm.Rd +++ b/man/vcov.felm.Rd @@ -11,10 +11,10 @@ ) } \arguments{ -\item{object}{an object of class \code{"feglm"}.} +\item{object}{an object of class \code{"felm"}.} \item{type}{the type of covariance estimate required. \code{"hessian"} refers -to the inverse of the negative expected Hessian after convergence and is the +to the inverse of the negative expected hessian after convergence and is the default option. \code{"outer.product"} is the outer-product-of-the-gradient estimator. \code{"sandwich"} is the sandwich estimator (sometimes also referred as robust estimator), and \code{"clustered"} computes a clustered @@ -29,8 +29,8 @@ A named matrix of covariance estimates. } \description{ Covariance matrix for the estimator of the structural parameters -from objects returned by \code{\link{feglm}}. The covariance is computed -from the Hessian, the scores, or a combination of both after convergence. +from objects returned by \code{\link{felm}}. The covariance is computed +from the hessian, the scores, or a combination of both after convergence. } \examples{ mod <- fepoisson( diff --git a/src/01_center_variables.cpp b/src/01_center_variables.cpp index 21d63ad..492c169 100644 --- a/src/01_center_variables.cpp +++ b/src/01_center_variables.cpp @@ -68,3 +68,11 @@ Mat center_variables_(const Mat &V, const Col &w, // Return matrix with centered variables return C; } + +[[cpp11::register]] doubles_matrix<> center_variables_r_( + const doubles_matrix<> &V_r, const doubles &w_r, + const list &klist, const double &tol, const int &maxiter) { + return as_doubles_matrix( + center_variables_(as_Mat(V_r), as_Mat(w_r), klist, tol, maxiter) + ); +} diff --git a/src/05_glm_fit.cpp b/src/05_glm_fit.cpp index 0353f2f..e608f21 100644 --- a/src/05_glm_fit.cpp +++ b/src/05_glm_fit.cpp @@ -452,7 +452,7 @@ Col variance_(const Col &mu, const double &theta, out.push_back({"deviance"_nm = dev}); out.push_back({"null_deviance"_nm = null_dev}); out.push_back({"conv"_nm = conv}); - out.push_back({"iter"_nm = iter}); + out.push_back({"iter"_nm = iter + 1}); if (keep_mx == true) { out.push_back({"MX"_nm = as_doubles_matrix(MX)}); diff --git a/src/cpp11.cpp b/src/cpp11.cpp index 0beb056..069099b 100644 --- a/src/cpp11.cpp +++ b/src/cpp11.cpp @@ -5,6 +5,13 @@ #include "cpp11/declarations.hpp" #include +// 01_center_variables.cpp +doubles_matrix<> center_variables_r_(const doubles_matrix<> & V_r, const doubles & w_r, const list & klist, const double & tol, const int & maxiter); +extern "C" SEXP _capybara_center_variables_r_(SEXP V_r, SEXP w_r, SEXP klist, SEXP tol, SEXP maxiter) { + BEGIN_CPP11 + return cpp11::as_sexp(center_variables_r_(cpp11::as_cpp &>>(V_r), cpp11::as_cpp>(w_r), cpp11::as_cpp>(klist), cpp11::as_cpp>(tol), cpp11::as_cpp>(maxiter))); + END_CPP11 +} // 02_get_alpha.cpp list get_alpha_(const doubles_matrix<> & p_r, const list & klist, const double & tol); extern "C" SEXP _capybara_get_alpha_(SEXP p_r, SEXP klist, SEXP tol) { @@ -64,6 +71,7 @@ extern "C" SEXP _capybara_pkendall_(SEXP Q, SEXP n) { extern "C" { static const R_CallMethodDef CallEntries[] = { + {"_capybara_center_variables_r_", (DL_FUNC) &_capybara_center_variables_r_, 5}, {"_capybara_feglm_fit_", (DL_FUNC) &_capybara_feglm_fit_, 9}, {"_capybara_get_alpha_", (DL_FUNC) &_capybara_get_alpha_, 3}, {"_capybara_group_sums_", (DL_FUNC) &_capybara_group_sums_, 3}, From 0f91f2c3907dd1f20c2204d4a1d8e79b90891431 Mon Sep 17 00:00:00 2001 From: Mauricio 'Pacha' Vargas Sepulveda Date: Mon, 22 Jul 2024 20:53:54 -0400 Subject: [PATCH 16/16] refactored apes() and bias_corr() --- NAMESPACE | 2 +- NEWS.md | 3 +- R/bias_corr.R | 62 +++++------ R/capybara-package.R | 2 +- R/cpp11.R | 4 + R/feglm.R | 22 ++-- R/feglm_control.R | 2 +- R/feglm_offset.R | 54 +--------- R/helpers.R | 2 +- README.Rmd | 4 +- README.md | 4 +- dev/benchmarks_tests_agtpa_capybara_only.R | 2 +- dev/test-offset.R | 18 ++++ docs/index.html | 16 +-- docs/news/index.html | 2 +- docs/pkgdown.yml | 2 +- docs/reference/apes.html | 9 +- docs/reference/bias_corr.html | 6 +- docs/reference/feglm.html | 4 +- docs/reference/feglm_control.html | 2 +- docs/reference/felm.html | 2 +- docs/reference/fenegbin.html | 2 +- docs/reference/fepoisson.html | 2 +- man/bias_corr.Rd | 4 +- man/feglm_control.Rd | 2 +- src/00_main.h | 17 +++ src/05_glm_fit.cpp | 21 ++-- src/06_glm_offset_fit.cpp | 101 ++++++++++++++++++ ...elation.cpp => 07_kendall_correlation.cpp} | 0 src/cpp11.cpp | 8 ++ tests/testthat/test-apes-bias.R | 24 +++-- tests/testthat/test-felm.R | 1 - tests/testthat/test-fepoisson.R | 5 +- 33 files changed, 254 insertions(+), 157 deletions(-) create mode 100644 dev/test-offset.R create mode 100644 src/06_glm_offset_fit.cpp rename src/{06_kendall_correlation.cpp => 07_kendall_correlation.cpp} (100%) diff --git a/NAMESPACE b/NAMESPACE index bba62c5..6dbe056 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -73,8 +73,8 @@ importFrom(stats,rgamma) importFrom(stats,rlogis) importFrom(stats,rnorm) importFrom(stats,rpois) -importFrom(stats,sd) importFrom(stats,terms) +importFrom(stats,var) importFrom(stats,vcov) importFrom(utils,combn) useDynLib(capybara, .registration = TRUE) diff --git a/NEWS.md b/NEWS.md index 75468e8..1c31911 100644 --- a/NEWS.md +++ b/NEWS.md @@ -3,8 +3,7 @@ * Moves all the heavy computation to C++ using Armadillo and it exports the results to R. Previously, there were multiple data copies between R and C++ that added overhead to the computations. -* For a future release, I may rewrite the offset and APES computation to C++, - but with those the overhead is minimal. +* The previous versions returned MX by default, now it has to be specified. # capybara 0.5.2 diff --git a/R/bias_corr.R b/R/bias_corr.R index 5c412a6..1fa900a 100644 --- a/R/bias_corr.R +++ b/R/bias_corr.R @@ -16,7 +16,7 @@ #' weakly exogenous regressors, e.g. lagged outcome variables, we suggest to #' choose a bandwidth between one and four. Note that the order of factors to #' be partialed out is important for bandwidths larger than zero. -#' @param panel.structure a string equal to \code{"classic"} or \code{"network"} +#' @param panel_structure a string equal to \code{"classic"} or \code{"network"} #' which determines the structure of the panel used. \code{"classic"} denotes #' panel structures where for example the same cross-sectional units are #' observed several times (this includes pseudo panels). \code{"network"} @@ -59,7 +59,7 @@ bias_corr <- function( object = NULL, L = 0L, - panel.structure = c("classic", "network")) { + panel_structure = c("classic", "network")) { # Check validity of 'object' if (is.null(object)) { stop("'object' has to be specified.", call. = FALSE) @@ -67,20 +67,20 @@ bias_corr <- function( stop("'bias_corr' called on a non-'feglm' object.", call. = FALSE) } - # Check validity of 'panel.structure' - panel.structure <- match.arg(panel.structure) + # Check validity of 'panel_structure' + panel_structure <- match.arg(panel_structure) # Extract model information - beta.uncorr <- object[["coefficients"]] + beta_uncorr <- object[["coefficients"]] control <- object[["control"]] data <- object[["data"]] eps <- .Machine[["double.eps"]] family <- object[["family"]] formula <- object[["formula"]] lvls_k <- object[["lvls_k"]] - nms.sp <- names(beta.uncorr) + nms.sp <- names(beta_uncorr) nt <- object[["nobs"]][["nobs"]] - k.vars <- names(lvls_k) + k_vars <- names(lvls_k) k <- length(lvls_k) # Check if binary choice model @@ -100,11 +100,11 @@ bias_corr <- function( } # Check if provided object matches requested panel structure - if (panel.structure == "classic") { + if (panel_structure == "classic") { if (!(k %in% c(1L, 2L))) { stop( paste( - "panel.structure == 'classic' expects a one- or two-way fixed", + "panel_structure == 'classic' expects a one- or two-way fixed", "effect model." ), call. = FALSE @@ -114,7 +114,7 @@ bias_corr <- function( if (!(k %in% c(2L, 3L))) { stop( paste( - "panel.structure == 'network' expects a two- or three-way fixed", + "panel_structure == 'network' expects a two- or three-way fixed", "effects model." ), call. = FALSE @@ -129,17 +129,17 @@ bias_corr <- function( wt <- object[["weights"]] # Generate auxiliary list of indexes for different sub panels - k.list <- get_index_list_(k.vars, data) + k_list <- get_index_list_(k_vars, data) # Compute derivatives and weights eta <- object[["eta"]] mu <- family[["linkinv"]](eta) - mu.eta <- family[["mu.eta"]](eta) + mu_eta <- family[["mu.eta"]](eta) v <- wt * (y - mu) - w <- wt * mu.eta + w <- wt * mu_eta z <- wt * partial_mu_eta_(eta, family, 2L) if (family[["link"]] != "logit") { - h <- mu.eta / family[["variance"]](mu) + h <- mu_eta / family[["variance"]](mu) v <- h * v w <- h * w z <- h * z @@ -150,54 +150,54 @@ bias_corr <- function( if (control[["keep_mx"]]) { MX <- object[["MX"]] } else { - MX <- center_variables_(X, w, k.list, control[["center_tol"]], 10000L) + MX <- center_variables_r_(X, w, k_list, control[["center_tol"]], 10000L) } # Compute bias terms for requested bias correction - if (panel.structure == "classic") { + if (panel_structure == "classic") { # Compute \hat{B} and \hat{D} - b <- as.vector(group_sums_(MX * z, w, k.list[[1L]])) / 2.0 / nt + b <- as.vector(group_sums_(MX * z, w, k_list[[1L]])) / 2.0 / nt if (k > 1L) { - b <- b + as.vector(group_sums_(MX * z, w, k.list[[2L]])) / 2.0 / nt + b <- b + as.vector(group_sums_(MX * z, w, k_list[[2L]])) / 2.0 / nt } # Compute spectral density part of \hat{B} if (L > 0L) { - b <- (b + group_sums_spectral_(MX * w, v, w, L, k.list[[1L]])) / nt + b <- (b + group_sums_spectral_(MX * w, v, w, L, k_list[[1L]])) / nt } } else { # Compute \hat{D}_{1}, \hat{D}_{2}, and \hat{B} - b <- group_sums_(MX * z, w, k.list[[1L]]) / (2.0 * nt) - b <- (b + group_sums_(MX * z, w, k.list[[2L]])) / (2.0 * nt) + b <- group_sums_(MX * z, w, k_list[[1L]]) / (2.0 * nt) + b <- (b + group_sums_(MX * z, w, k_list[[2L]])) / (2.0 * nt) if (k > 2L) { - b <- (b + group_sums_(MX * z, w, k.list[[3L]])) / (2.0 * nt) + b <- (b + group_sums_(MX * z, w, k_list[[3L]])) / (2.0 * nt) } # Compute spectral density part of \hat{B} if (k > 2L && L > 0L) { - b <- (b + group_sums_spectral_(MX * w, v, w, L, k.list[[3L]])) / nt + b <- (b + group_sums_spectral_(MX * w, v, w, L, k_list[[3L]])) / nt } } # Compute bias-corrected structural parameters - beta <- beta.uncorr - solve(object[["hessian"]] / nt, b) + beta <- beta_uncorr - solve(object[["hessian"]] / nt, b) names(beta) <- nms.sp # Update \eta and first- and second-order derivatives eta <- feglm_offset_(object, X %*% beta) mu <- family[["linkinv"]](eta) - mu.eta <- family[["mu.eta"]](eta) + mu_eta <- family[["mu.eta"]](eta) v <- wt * (y - mu) - w <- wt * mu.eta + w <- wt * mu_eta if (family[["link"]] != "logit") { - h <- mu.eta / family[["variance"]](mu) + h <- mu_eta / family[["variance"]](mu) v <- h * v w <- h * w rm(h) } # Update centered regressor matrix - MX <- center_variables_r_(X, w, k.list, control[["center_tol"]], 10000L) + MX <- center_variables_r_(X, w, k_list, control[["center_tol"]], 10000L) colnames(MX) <- nms.sp # Update hessian @@ -209,9 +209,9 @@ bias_corr <- function( object[["eta"]] <- eta if (control[["keep_mx"]]) object[["MX"]] <- MX object[["hessian"]] <- H - object[["coefficients.uncorr"]] <- beta.uncorr - object[["bias.term"]] <- b - object[["panel.structure"]] <- panel.structure + object[["coefficients_uncorr"]] <- beta_uncorr + object[["bias_term"]] <- b + object[["panel_structure"]] <- panel_structure object[["bandwidth"]] <- L # Add additional class to result list diff --git a/R/capybara-package.R b/R/capybara-package.R index 3bd6236..1981179 100644 --- a/R/capybara-package.R +++ b/R/capybara-package.R @@ -18,7 +18,7 @@ #' @importFrom MASS negative.binomial theta.ml #' @importFrom rlang sym := #' @importFrom stats as.formula binomial model.matrix na.omit gaussian poisson -#' pnorm printCoefmat rgamma rlogis rnorm rpois terms vcov predict sd +#' pnorm printCoefmat rgamma rlogis rnorm rpois terms vcov predict var #' complete.cases #' @importFrom utils combn #' @useDynLib capybara, .registration = TRUE diff --git a/R/cpp11.R b/R/cpp11.R index cfa7e4a..68b05aa 100644 --- a/R/cpp11.R +++ b/R/cpp11.R @@ -28,6 +28,10 @@ feglm_fit_ <- function(beta_r, eta_r, y_r, x_r, wt_r, theta, family, control, k_ .Call(`_capybara_feglm_fit_`, beta_r, eta_r, y_r, x_r, wt_r, theta, family, control, k_list) } +feglm_offset_fit_ <- function(eta_r, y_r, offset_r, wt_r, family, control, k_list) { + .Call(`_capybara_feglm_offset_fit_`, eta_r, y_r, offset_r, wt_r, family, control, k_list) +} + kendall_cor_ <- function(m) { .Call(`_capybara_kendall_cor_`, m) } diff --git a/R/feglm.R b/R/feglm.R index d030568..37dce94 100644 --- a/R/feglm.R +++ b/R/feglm.R @@ -157,19 +157,15 @@ feglm <- function( } dimnames(fit[["hessian"]]) <- list(nms_sp, nms_sp) - # Generate result list ---- - reslist <- c( - fit, list( - nobs = nobs, - lvls_k = lvls_k, - nms_fe = nms_fe, - formula = formula, - data = data, - family = family, - control = control - ) - ) + # Add to fit list ---- + fit[["nobs"]] <- nobs + fit[["lvls_k"]] <- lvls_k + fit[["nms_fe"]] <- nms_fe + fit[["formula"]] <- formula + fit[["data"]] <- data + fit[["family"]] <- family + fit[["control"]] <- control # Return result list ---- - structure(reslist, class = "feglm") + structure(fit, class = "feglm") } diff --git a/R/feglm_control.R b/R/feglm_control.R index d145efd..31288f9 100644 --- a/R/feglm_control.R +++ b/R/feglm_control.R @@ -39,7 +39,7 @@ feglm_control <- function( limit = 10L, trace = FALSE, drop_pc = TRUE, - keep_mx = TRUE) { + keep_mx = FALSE) { # Check validity of tolerance parameters if (dev_tol <= 0.0 || center_tol <= 0.0) { stop( diff --git a/R/feglm_offset.R b/R/feglm_offset.R index 6108b20..b46ca70 100644 --- a/R/feglm_offset.R +++ b/R/feglm_offset.R @@ -27,7 +27,7 @@ feglm_offset_ <- function(object, offset) { # Generate auxiliary list of indexes to project out the fixed effects k_list <- get_index_list_(k_vars, data) - # Compute starting guess for \eta + # Compute starting guess for eta if (family[["family"]] == "binomial") { eta <- rep(family[["linkfun"]](sum(wt * (y + 0.5) / 2.0) / sum(wt)), nt) } else if (family[["family"]] %in% c("Gamma", "inverse.gaussian")) { @@ -36,54 +36,8 @@ feglm_offset_ <- function(object, offset) { eta <- rep(family[["linkfun"]](sum(wt * (y + 0.1)) / sum(wt)), nt) } - # Compute initial quantities for the maximization routine - mu <- family[["linkinv"]](eta) - dev <- sum(family[["dev.resids"]](y, mu, wt)) - Myadj <- as.matrix(numeric(nt)) - - # Start maximization of the log-likelihood - for (iter in seq.int(iter_max)) { - # Store \eta, \beta, and deviance of the previous iteration - eta_old <- eta - dev_old <- dev - - # Compute weights and dependent variable - mu.eta <- family[["mu.eta"]](eta) - w <- (wt * mu.eta^2) / family[["variance"]](mu) - yadj <- (y - mu) / mu.eta + eta - offset - - # Centering dependent variable and compute \eta update - Myadj <- center_variables_r_(Myadj + yadj, w, k_list, center_tol, 10000L) - eta_upd <- yadj - drop(Myadj) + offset - eta - - # Step-halving with three checks - # 1. finite deviance - # 2. valid \eta and \mu - # 3. improvement as in glm2 - rho <- 1.0 - for (inner.iter in seq.int(50L)) { - eta <- eta_old + rho * eta_upd - mu <- family[["linkinv"]](eta) - dev <- sum(family[["dev.resids"]](y, mu, wt)) - dev.crit <- is.finite(dev) - val.crit <- family[["valideta"]](eta) && family[["validmu"]](mu) - imp.crit <- (dev - dev_old) / (0.1 + abs(dev)) <= -dev_tol - if (dev.crit && val.crit && imp.crit) break - rho <- rho / 2.0 - } - - # Check if step-halving failed - if (!dev.crit || !val.crit) { - stop("Inner loop failed; cannot correct step size.", call. = FALSE) - } - - # Check termination condition - if (abs(dev - dev_old) / (0.1 + abs(dev)) < dev_tol) break - - # Update starting guesses for acceleration - Myadj <- Myadj - yadj - } - # Return eta - eta + if (is.integer(y)) { y <- as.numeric(y) } + feglm_offset_fit_(eta, y, offset, wt, family[["family"]], control, + k_list) } diff --git a/R/helpers.R b/R/helpers.R index 6b2d696..57bde2d 100644 --- a/R/helpers.R +++ b/R/helpers.R @@ -379,7 +379,7 @@ get_score_matrix_ <- function(object) { attr(X, "dimnames") <- NULL # Center variables - MX <- center_variables_(X, NA_real_, w, k.list, control[["center_tol"]], 10000L, FALSE) + MX <- center_variables_r_(X, w, k.list, control[["center_tol"]], 10000L) colnames(MX) <- nms_sp } diff --git a/README.Rmd b/README.Rmd index fcf6918..15a7f69 100644 --- a/README.Rmd +++ b/README.Rmd @@ -125,7 +125,7 @@ Median time for the different models in the book |:------------|-------:|-----------------:|------------:|-----------------:|----------------------------:|--------------:| | Alpaca | 0.4s | 2.6s | 1.6s | 2.0s | 3.1s | 5.3s | | Base R | 120.0s | 2.0m | 1380.0s | 1440.0s | 1380.0s | 1500.0s | -| **Capybara**| 0.3s | 2.2s | 1.4s | 1.7s | 2.1s | 3.9s | +| **Capybara**| 0.3s | 2.0s | 1.2s | 1.4s | 1.7s | 3.4s | | Fixest | 0.1s | 0.5s | 0.1s | 0.2s | 0.3s | 0.5s | Memory allocation for the same models @@ -134,7 +134,7 @@ Memory allocation for the same models |:------------|-------:|---------------:|-----------:|-----------------:|--------------------------:|-------------:| |Alpaca | 307MB | 341MB | 306MB | 336MB | 395MB | 541MB | |Base R | 3000MB | 3000MB | 12000MB | 12000GB | 12000GB | 12000MB | -|**Capybara** | 29MB | 34MB | 21MB | 24MB | 30MB | 47MB | +|**Capybara** | 27MB | 32MB | 20MB | 23MB | 29MB | 43MB | |Fixest | 44MB | 36MB | 27MB | 32MB | 41MB | 63MB | # Debugging diff --git a/README.md b/README.md index 344079d..64db857 100644 --- a/README.md +++ b/README.md @@ -121,7 +121,7 @@ Analysis](https://www.wto.org/english/res_e/publications_e/advancedguide2016_e.h | :----------- | -----: | --------------: | ----------: | ----------------: | -------------------------: | ------------: | | Alpaca | 0.4s | 2.6s | 1.6s | 2.0s | 3.1s | 5.3s | | Base R | 120.0s | 2.0m | 1380.0s | 1440.0s | 1380.0s | 1500.0s | -| **Capybara** | 0.3s | 2.2s | 1.4s | 1.7s | 2.1s | 3.9s | +| **Capybara** | 0.3s | 2.0s | 1.2s | 1.4s | 1.7s | 3.4s | | Fixest | 0.1s | 0.5s | 0.1s | 0.2s | 0.3s | 0.5s | Memory allocation for the same models @@ -130,7 +130,7 @@ Memory allocation for the same models | :----------- | -----: | --------------: | ----------: | ----------------: | -------------------------: | ------------: | | Alpaca | 307MB | 341MB | 306MB | 336MB | 395MB | 541MB | | Base R | 3000MB | 3000MB | 12000MB | 12000GB | 12000GB | 12000MB | -| **Capybara** | 29MB | 34MB | 21MB | 24MB | 30MB | 47MB | +| **Capybara** | 27MB | 32MB | 20MB | 23MB | 29MB | 43MB | | Fixest | 44MB | 36MB | 27MB | 32MB | 41MB | 63MB | # Debugging diff --git a/dev/benchmarks_tests_agtpa_capybara_only.R b/dev/benchmarks_tests_agtpa_capybara_only.R index 21c7d2e..236574f 100644 --- a/dev/benchmarks_tests_agtpa_capybara_only.R +++ b/dev/benchmarks_tests_agtpa_capybara_only.R @@ -1,7 +1,7 @@ # this is not just about speed/memory, but also about obtaining the same # slopes as in base R -library(alpaca) +library(capybara) library(dplyr) library(tidyr) library(janitor) diff --git a/dev/test-offset.R b/dev/test-offset.R new file mode 100644 index 0000000..e833619 --- /dev/null +++ b/dev/test-offset.R @@ -0,0 +1,18 @@ +test_that("offset works", { + m1 <- feglm(mpg ~ wt | cyl, data = mtcars, family = poisson()) + y <- predict(m1, type = "response") + o1 <- feglm_offset_(m1, y) + + # m2 <- alpaca::feglm(mpg ~ wt | cyl, data = mtcars, family = poisson()) + # o2 <- drop(alpaca:::feglmOffset(m2, y) + # datapasta::vector_paste(round(o2, 4)) + o2 <- c( + 3.018703, 3.011154, 3.056387, 3.001613, 2.979713, 2.995091, 2.976723, + 3.026537, 3.027809, 2.995612, 2.995612, 2.999650, 3.006936, 3.005836, + 2.977558, 2.974679, 2.975975, 3.094682, 3.062526, 3.053450, 3.029361, + 2.956144, 2.958109, 2.949010, 2.948902, 3.049442, 3.041447, 3.066858, + 2.964431, 2.992499, 2.955002, 3.018302 + ) + + expect_equal(round(o1, 4), round(o2, 4)) +}) diff --git a/docs/index.html b/docs/index.html index c951618..4b687da 100644 --- a/docs/index.html +++ b/docs/index.html @@ -179,11 +179,11 @@

Benchmarks Capybara 0.3s -2.2s +2.0s +1.2s 1.4s 1.7s -2.1s -3.9s +3.4s Fixest @@ -237,12 +237,12 @@

Benchmarks Capybara +27MB +32MB +20MB +23MB 29MB -34MB -21MB -24MB -30MB -47MB +43MB Fixest diff --git a/docs/news/index.html b/docs/news/index.html index 8d7cdfe..1330cb0 100644 --- a/docs/news/index.html +++ b/docs/news/index.html @@ -60,7 +60,7 @@

Changelog

capybara 0.6.0

  • Moves all the heavy computation to C++ using Armadillo and it exports the results to R. Previously, there were multiple data copies between R and C++ that added overhead to the computations.
    • -
  • For a future release, I may rewrite the offset and APES computation to C++, but with those the overhead is minimal.
    • +
  • The previous versions returned MX by default, now it has to be specified.

capybara 0.5.2

diff --git a/docs/pkgdown.yml b/docs/pkgdown.yml index b16a896..1065a4d 100644 --- a/docs/pkgdown.yml +++ b/docs/pkgdown.yml @@ -3,5 +3,5 @@ pkgdown: 2.0.7 pkgdown_sha: ~ articles: intro: intro.html -last_built: 2024-07-22T03:41Z +last_built: 2024-07-23T00:52Z diff --git a/docs/reference/apes.html b/docs/reference/apes.html index 6032919..194abc6 100644 --- a/docs/reference/apes.html +++ b/docs/reference/apes.html @@ -186,7 +186,7 @@

Examples

mod_bc <- bias_corr(mod) summary(mod_bc) #> Formula: trade ~ lang | year -#> <environment: 0x5fa3c5f54f50> +#> <environment: 0x579102d4cff0> #> #> Family: Binomial #> @@ -204,9 +204,12 @@

Examples

# Compute bias-corrected average partial effects mod_ape_bc <- apes(mod_bc) -#> Error in if (panel_structure == "classic") { if (!(k %in% c(1L, 2L))) { stop(paste("panel_structure == 'classic' expects a one- or two-way fixed", "effects model."), call. = FALSE) }} else { if (!(k %in% c(2L, 3L))) { stop(paste("panel_structure == 'network' expects a two- or three-way fixed", "effects model."), call. = FALSE) }}: argument is of length zero summary(mod_ape_bc) -#> Error in eval(expr, envir, enclos): object 'mod_ape_bc' not found +#> Estimates: +#> Estimate Std. Error z value Pr(>|z|) +#> lang 0.05596 0.01513 3.699 0.000216 *** +#> --- +#> Signif. codes: 0 ‘***’ 0.001 ‘**’ 0.01 ‘*’ 0.05 ‘.’ 0.1 ‘ ’ 1
diff --git a/docs/reference/bias_corr.html b/docs/reference/bias_corr.html index 2c72fce..4dc5d37 100644 --- a/docs/reference/bias_corr.html +++ b/docs/reference/bias_corr.html @@ -76,7 +76,7 @@

Asymptotic bias correction after fitting binary choice models with a
- 
bias_corr(object = NULL, L = 0L, panel.structure = c("classic", "network"))
+ 
bias_corr(object = NULL, L = 0L, panel_structure = c("classic", "network"))
@@ -95,7 +95,7 @@

Arguments

be partialed out is important for bandwidths larger than zero.

-
panel.structure
+
panel_structure

a string equal to "classic" or "network" which determines the structure of the panel used. "classic" denotes panel structures where for example the same cross-sectional units are @@ -146,7 +146,7 @@

Examples

mod_bc <- bias_corr(mod) summary(mod_bc) #> Formula: trade ~ lang | year -#> <environment: 0x5fa3c58f51f0> +#> <environment: 0x579100916318> #> #> Family: Binomial #> diff --git a/docs/reference/feglm.html b/docs/reference/feglm.html index 908094d..09beb95 100644 --- a/docs/reference/feglm.html +++ b/docs/reference/feglm.html @@ -162,7 +162,7 @@

Examples

summary(mod) #> Formula: trade ~ log_dist + lang + cntg + clny | exp_year + imp_year -#> <environment: 0x5fa3c55b9a20> +#> <environment: 0x5791016e2240> #> #> Family: Poisson #> @@ -192,7 +192,7 @@

Examples

summary(mod, type = "clustered") #> Formula: trade ~ log_dist + lang + cntg + clny | exp_year + imp_year | #> pair -#> <environment: 0x5fa3c55b9a20> +#> <environment: 0x5791016e2240> #> #> Family: Poisson #> diff --git a/docs/reference/feglm_control.html b/docs/reference/feglm_control.html index ec24887..8f375a0 100644 --- a/docs/reference/feglm_control.html +++ b/docs/reference/feglm_control.html @@ -72,7 +72,7 @@

Set feglm Control Parameters

limit = 10L, trace = FALSE, drop_pc = TRUE, - keep_mx = TRUE + keep_mx = FALSE )
diff --git a/docs/reference/felm.html b/docs/reference/felm.html index ad1d1c1..82d4ea1 100644 --- a/docs/reference/felm.html +++ b/docs/reference/felm.html @@ -116,7 +116,7 @@

Examples

summary(mod) #> Formula: log(trade) ~ log_dist + lang + cntg + clny | exp_year + imp_year -#> <environment: 0x5fa3c75f1ab0> +#> <environment: 0x5791041ea358> #> #> Estimates: #> diff --git a/docs/reference/fenegbin.html b/docs/reference/fenegbin.html index a665741..be195d6 100644 --- a/docs/reference/fenegbin.html +++ b/docs/reference/fenegbin.html @@ -141,7 +141,7 @@

Examples

summary(mod) #> Formula: trade ~ log_dist + lang + cntg + clny | exp_year + imp_year -#> <environment: 0x5fa3c7540330> +#> <environment: 0x57910411c3a0> #> #> Family: Negative Binomial(1.1839) #> diff --git a/docs/reference/fepoisson.html b/docs/reference/fepoisson.html index 2c38a99..89fea9f 100644 --- a/docs/reference/fepoisson.html +++ b/docs/reference/fepoisson.html @@ -128,7 +128,7 @@

Examples

summary(mod) #> Formula: trade ~ log_dist + lang + cntg + clny | exp_year + imp_year -#> <environment: 0x5fa3c48bf728> +#> <environment: 0x579101725c50> #> #> Family: Poisson #> diff --git a/man/bias_corr.Rd b/man/bias_corr.Rd index 9026431..7825153 100644 --- a/man/bias_corr.Rd +++ b/man/bias_corr.Rd @@ -5,7 +5,7 @@ \title{Asymptotic bias correction after fitting binary choice models with a 1,2,3-way error component} \usage{ -bias_corr(object = NULL, L = 0L, panel.structure = c("classic", "network")) +bias_corr(object = NULL, L = 0L, panel_structure = c("classic", "network")) } \arguments{ \item{object}{an object of class \code{"feglm"}.} @@ -18,7 +18,7 @@ weakly exogenous regressors, e.g. lagged outcome variables, we suggest to choose a bandwidth between one and four. Note that the order of factors to be partialed out is important for bandwidths larger than zero.} -\item{panel.structure}{a string equal to \code{"classic"} or \code{"network"} +\item{panel_structure}{a string equal to \code{"classic"} or \code{"network"} which determines the structure of the panel used. \code{"classic"} denotes panel structures where for example the same cross-sectional units are observed several times (this includes pseudo panels). \code{"network"} diff --git a/man/feglm_control.Rd b/man/feglm_control.Rd index b5d7c89..9838e19 100644 --- a/man/feglm_control.Rd +++ b/man/feglm_control.Rd @@ -11,7 +11,7 @@ feglm_control( limit = 10L, trace = FALSE, drop_pc = TRUE, - keep_mx = TRUE + keep_mx = FALSE ) } \arguments{ diff --git a/src/00_main.h b/src/00_main.h index 926b2dd..d4153b2 100644 --- a/src/00_main.h +++ b/src/00_main.h @@ -27,3 +27,20 @@ Col solve_eta_(const Mat &MX, const Mat &MNU, Mat crossprod_(const Mat &X, const Col &w, const int &n, const int &p, const bool &weighted, const bool &root_weights); + +std::string tidy_family_(const std::string &family); + +Col link_inv_(const Col &eta, const std::string &fam); + +double dev_resids_(const Col &y, const Col &mu, + const double &theta, const Col &wt, + const std::string &fam); + +Col mu_eta_(Col &eta, const std::string &fam); + +Col variance_(const Col &mu, const double &theta, + const std::string &fam); + +bool valid_eta_(const Col &eta, const std::string &fam); + +bool valid_mu_(const Col &mu, const std::string &fam); diff --git a/src/05_glm_fit.cpp b/src/05_glm_fit.cpp index e608f21..9973818 100644 --- a/src/05_glm_fit.cpp +++ b/src/05_glm_fit.cpp @@ -371,22 +371,13 @@ Col variance_(const Col &mu, const double &theta, beta = beta_old + (rho * beta_upd); mu = link_inv_(eta, fam); dev = dev_resids_(y, mu, theta, wt, fam); - dev_ratio_inner = (dev - dev_old) / (0.1 + fabs(dev_old)); - - // std::cout << "iter: " << iter << std::endl; - // std::cout << "iter_inner: " << iter_inner << std::endl; - // std::cout << "beta old: " << beta_old.t() << std::endl; - // std::cout << "beta: " << beta.t() << std::endl; - // std::cout << "dev: " << dev << std::endl; - // std::cout << "dev_ratio_inner: " << dev_ratio_inner << std::endl; - // std::cout << "dev_tol: " << dev_tol << std::endl; + dev_ratio_inner = (dev - dev_old) / (0.1 + fabs(dev)); dev_crit = is_finite(dev); val_crit = (valid_eta_(eta, fam) && valid_mu_(mu, fam)); imp_crit = (dev_ratio_inner <= -dev_tol); if (dev_crit == true && val_crit == true && imp_crit == true) { - // std::cout << "ok" << std::endl; break; } @@ -433,10 +424,6 @@ Col variance_(const Col &mu, const double &theta, mu_eta = mu_eta_(eta, fam); w = (wt % square(mu_eta)) / variance_(mu, theta, fam); - // Center variables - - MX = center_variables_(as_Mat(x_r), w, k_list, center_tol, iter_center_max); - // Recompute Hessian H = crossprod_(MX, w, n, p, true, true); @@ -455,7 +442,11 @@ Col variance_(const Col &mu, const double &theta, out.push_back({"iter"_nm = iter + 1}); if (keep_mx == true) { - out.push_back({"MX"_nm = as_doubles_matrix(MX)}); + out.push_back({ + "MX"_nm = as_doubles_matrix( + center_variables_(as_Mat(x_r), w, k_list, center_tol, iter_center_max) + ) + }); } return out; diff --git a/src/06_glm_offset_fit.cpp b/src/06_glm_offset_fit.cpp new file mode 100644 index 0000000..51e7077 --- /dev/null +++ b/src/06_glm_offset_fit.cpp @@ -0,0 +1,101 @@ +#include "00_main.h" + +[[cpp11::register]] doubles feglm_offset_fit_( + const doubles &eta_r, const doubles &y_r, const doubles &offset_r, + const doubles &wt_r, const std::string &family, const list &control, + const list &k_list) { + // Type conversion + + Col eta = as_Col(eta_r); + Col y = as_Col(y_r); + Col offset = as_Col(offset_r); + Mat Myadj = Mat(y.n_elem, 1, fill::zeros); + Col wt = as_Col(wt_r); + + // Auxiliary variables (fixed) + + std::string fam = tidy_family_(family); + double center_tol = as_cpp(control["center_tol"]); + double dev_tol = as_cpp(control["dev_tol"]); + int iter, iter_max = as_cpp(control["iter_max"]); + int iter_center_max = 10000; + int iter_inner, iter_inner_max = 50; + + // Auxiliary variables (storage) + + Col mu = link_inv_(eta, fam); + double dev = dev_resids_(y, mu, 0.0, wt, fam); + + const int n = y.n_elem; + Col mu_eta(n), yadj(n); + Mat w(n, 1); + bool conv = false; + + bool dev_crit, val_crit, imp_crit; + double dev_old, dev_ratio, dev_ratio_inner, rho; + Col eta_upd(n), eta_old(n); + + // Maximize the log-likelihood + + for (iter = 0; iter < iter_max; ++iter) { + rho = 1.0; + eta_old = eta, dev_old = dev; + + // Compute weights and dependent variable + + mu_eta = mu_eta_(eta, fam); + w = (wt % square(mu_eta)) / variance_(mu, 0.0, fam); + yadj = (y - mu) / mu_eta + eta - offset; + + // Center variables + + Myadj = center_variables_(Myadj + yadj, w, k_list, center_tol, iter_center_max); + + // Compute update step and update eta + + // Step-halving with three checks: + // 1. finite deviance + // 2. valid eta and mu + // 3. improvement as in glm2 + + eta_upd = yadj - Myadj + offset - eta; + + for (iter_inner = 0; iter_inner < iter_inner_max; ++iter_inner) { + eta = eta_old + (rho * eta_upd); + mu = link_inv_(eta, fam); + dev = dev_resids_(y, mu, 0.0, wt, fam); + dev_ratio_inner = (dev - dev_old) / (0.1 + fabs(dev_old)); + + dev_crit = is_finite(dev); + val_crit = (valid_eta_(eta, fam) && valid_mu_(mu, fam)); + imp_crit = (dev_ratio_inner <= -dev_tol); + + if (dev_crit == true && val_crit == true && imp_crit == true) { + break; + } + + rho *= 0.5; + } + + // Check if step-halving failed (deviance and invalid eta or mu) + + if (dev_crit == false || val_crit == false) { + stop("Inner loop failed; cannot correct step size."); + } + + // Check convergence + + dev_ratio = fabs(dev - dev_old) / (0.1 + fabs(dev)); + + if (dev_ratio < dev_tol) { + conv = true; + break; + } + + // Update starting guesses for acceleration + + Myadj = Myadj - yadj; + } + + return as_doubles(eta); +} diff --git a/src/06_kendall_correlation.cpp b/src/07_kendall_correlation.cpp similarity index 100% rename from src/06_kendall_correlation.cpp rename to src/07_kendall_correlation.cpp diff --git a/src/cpp11.cpp b/src/cpp11.cpp index 069099b..5d10912 100644 --- a/src/cpp11.cpp +++ b/src/cpp11.cpp @@ -54,6 +54,13 @@ extern "C" SEXP _capybara_feglm_fit_(SEXP beta_r, SEXP eta_r, SEXP y_r, SEXP x_r return cpp11::as_sexp(feglm_fit_(cpp11::as_cpp>(beta_r), cpp11::as_cpp>(eta_r), cpp11::as_cpp>(y_r), cpp11::as_cpp &>>(x_r), cpp11::as_cpp>(wt_r), cpp11::as_cpp>(theta), cpp11::as_cpp>(family), cpp11::as_cpp>(control), cpp11::as_cpp>(k_list))); END_CPP11 } +// 06_glm_offset_fit.cpp +doubles feglm_offset_fit_(const doubles & eta_r, const doubles & y_r, const doubles & offset_r, const doubles & wt_r, const std::string & family, const list & control, const list & k_list); +extern "C" SEXP _capybara_feglm_offset_fit_(SEXP eta_r, SEXP y_r, SEXP offset_r, SEXP wt_r, SEXP family, SEXP control, SEXP k_list) { + BEGIN_CPP11 + return cpp11::as_sexp(feglm_offset_fit_(cpp11::as_cpp>(eta_r), cpp11::as_cpp>(y_r), cpp11::as_cpp>(offset_r), cpp11::as_cpp>(wt_r), cpp11::as_cpp>(family), cpp11::as_cpp>(control), cpp11::as_cpp>(k_list))); + END_CPP11 +} // 06_kendall_correlation.cpp double kendall_cor_(const doubles_matrix<> & m); extern "C" SEXP _capybara_kendall_cor_(SEXP m) { @@ -73,6 +80,7 @@ extern "C" { static const R_CallMethodDef CallEntries[] = { {"_capybara_center_variables_r_", (DL_FUNC) &_capybara_center_variables_r_, 5}, {"_capybara_feglm_fit_", (DL_FUNC) &_capybara_feglm_fit_, 9}, + {"_capybara_feglm_offset_fit_", (DL_FUNC) &_capybara_feglm_offset_fit_, 7}, {"_capybara_get_alpha_", (DL_FUNC) &_capybara_get_alpha_, 3}, {"_capybara_group_sums_", (DL_FUNC) &_capybara_group_sums_, 3}, {"_capybara_group_sums_cov_", (DL_FUNC) &_capybara_group_sums_cov_, 3}, diff --git a/tests/testthat/test-apes-bias.R b/tests/testthat/test-apes-bias.R index e99002b..4ab15f7 100644 --- a/tests/testthat/test-apes-bias.R +++ b/tests/testthat/test-apes-bias.R @@ -2,15 +2,23 @@ test_that("apes/bias works", { trade_short <- trade_panel[trade_panel$year %in% 2002L:2006L, ] trade_short$trade <- ifelse(trade_short$trade > 100, 1L, 0L) - mod <- feglm(trade ~ lang | year, trade_short, family = binomial()) + mod1 <- feglm(trade ~ lang | year, trade_short, family = binomial()) + apes1 <- apes(mod1) + bias1 <- bias_corr(mod1) - # names(mod) - # length(mod) + # mod2 <- alpaca::feglm(trade ~ lang | year, trade_short, family = binomial()) + # apes2 <- alpaca::getAPEs(mod2) + # bias2 <- alpaca::biasCorr(mod2) + apes2 <- c("lang" = 0.05594) + bias2 <- c("lang" = 0.23390) - expect_output(print(mod)) + expect_output(print(mod1)) - expect_gt(length(coef(apes(mod))), 0) - expect_gt(length(coef(summary(apes(mod)))), 0) - expect_gt(length(coef(bias_corr(mod))), 0) - expect_gt(length(coef(summary(bias_corr(mod)))), 0) + expect_equal(length(coef(apes1)), 1) + expect_equal(round(coef(apes1), 5), apes2) + expect_equal(length(coef(summary(apes(mod1)))), 4) + + expect_equal(length(coef(bias1)), 1) + expect_equal(round(coef(bias1), 1), round(bias2, 1)) + expect_equal(length(coef(summary(bias1))), 4) }) diff --git a/tests/testthat/test-felm.R b/tests/testthat/test-felm.R index a28a4eb..8aa0991 100644 --- a/tests/testthat/test-felm.R +++ b/tests/testthat/test-felm.R @@ -1,5 +1,4 @@ test_that("felm works", { - load_all() m1 <- felm(mpg ~ wt | cyl, mtcars) m2 <- lm(mpg ~ wt + as.factor(cyl), mtcars) diff --git a/tests/testthat/test-fepoisson.R b/tests/testthat/test-fepoisson.R index 838c0b8..582dd66 100644 --- a/tests/testthat/test-fepoisson.R +++ b/tests/testthat/test-fepoisson.R @@ -29,18 +29,17 @@ test_that("fepoisson is similar to fixest", { fes <- fixed_effects(mod) n <- unname(mod[["nobs"]]["nobs"]) - p <- dim(mod[["MX"]])[2] expect_equal(length(fes), 2) expect_equal(length(fitted(mod)), n) expect_equal(length(predict(mod)), n) - expect_equal(length(coef(mod)), p) + expect_equal(length(coef(mod)), 4) expect_equal(length(fes), 2) expect_equal(round(fes[["exp_year"]][1:3], 3), c(10.195, 11.081, 11.260)) expect_equal(round(fes[["imp_year"]][1:3], 3), c(0.226, -0.254, 1.115)) smod <- summary(mod) - expect_equal(length(coef(smod)[, 1]), p) + expect_equal(length(coef(smod)[, 1]), 4) expect_output(summary_formula_(smod)) expect_output(summary_family_(smod)) expect_output(summary_estimates_(smod, 3))