From c0238dc1a5a2da2842dfa08f2833aed30479617d Mon Sep 17 00:00:00 2001 From: jrwishart Date: Tue, 6 Dec 2022 13:50:57 +1100 Subject: [PATCH 1/4] DS-4148 Update assign calls for weighted models * Remove the assignment of .design to the global environment * Instead assign the design variable to the formula environment so the eval code used with the extractAIC method in survey can find it. --- R/regression.R | 6 ++---- 1 file changed, 2 insertions(+), 4 deletions(-) diff --git a/R/regression.R b/R/regression.R index b5ee4232..7de80b73 100644 --- a/R/regression.R +++ b/R/regression.R @@ -1194,7 +1194,7 @@ fitModel <- function(.formula, .estimation.data, .weights, type, robust.se, subs model$df <- NA else { - assign(".design", .design, envir=.GlobalEnv) + assign(".design", .design, environment(.formula)) aic <- try(extractAIC(model), silent = TRUE) if (any("try-error" %in% class(aic))) { @@ -1203,7 +1203,6 @@ fitModel <- function(.formula, .estimation.data, .weights, type, robust.se, subs "some aspect of the analysis. ") aic <- rep(NA, 2) } - remove(".design", envir=.GlobalEnv) model$df <- aic[1] model$aic <- aic[2] } @@ -1241,9 +1240,8 @@ fitModel <- function(.formula, .estimation.data, .weights, type, robust.se, subs family = poisson()), "Quasi-Poisson" = svyglm(.formula, .design, subset = non.outlier.data_GQ9KqD7YOf, family = quasipoisson())) - assign(".design", .design, envir=.GlobalEnv) + assign(".design", .design, envir = environment(.formula)) aic <- extractAIC(model) - remove(".design", envir=.GlobalEnv) model$df <- aic[1] model$aic <- aic[2] } From 998b8c0713d30eb06d2da7b74f8dec4763df0fd1 Mon Sep 17 00:00:00 2001 From: jrwishart Date: Tue, 6 Dec 2022 13:56:14 +1100 Subject: [PATCH 2/4] DS-4148 Version bump --- DESCRIPTION | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/DESCRIPTION b/DESCRIPTION index c5b2805e..baf55ddf 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,7 +1,7 @@ Package: flipRegression Type: Package Title: Estimates standard regression models -Version: 1.3.50 +Version: 1.3.51 Author: Displayr Maintainer: Displayr Description: Regression models according to the flip Project From 28a07aa34e1ed5fb5358834d282fc749e1f6c1ae Mon Sep 17 00:00:00 2001 From: jrwishart Date: Tue, 6 Dec 2022 17:28:18 +1100 Subject: [PATCH 3/4] DS-4148 Update assignment calls for Ordered Logit --- R/regression.R | 17 ++++++++++------- tests/testthat/test-automatedoutlierremoval.R | 18 +++++++++--------- 2 files changed, 19 insertions(+), 16 deletions(-) diff --git a/R/regression.R b/R/regression.R index 7de80b73..2388dced 100644 --- a/R/regression.R +++ b/R/regression.R @@ -1494,6 +1494,7 @@ fitOrderedLogit <- function(.formula, .estimation.data, weights, non.outlier.dat # predictor. class(out) <- c("svyolr", "polr") # Retain the design and formula for later use + assign(".design", .design, envir = environment(.formula)) out$formula <- .formula out$design <- .design out @@ -1524,8 +1525,8 @@ findAppropriateStartingValueForOrderedLogit <- function(.formula, .estimation.da first.level <- levels(y)[1] cut.point <- substr(first.level, 4L, nchar(first.level)) q1 <- which(levels(.estimation.data[[outcome.name]]) == cut.point) - logit <- function(p) log(p/(1 - p)) - spacing <- logit((1L:q)/(q + 1L)) + logit <- function(p) log(p / (1 - p)) + spacing <- logit((1L:q) / (q + 1L)) gammas <- -coefs[1L] + spacing - spacing[q1] c(coefs[-1L], gammas) } @@ -1697,11 +1698,13 @@ findNonOutlierObservations <- function(data, outlier.prop.to.remove, model, type { if (!is.null(weights)) { - assign(".design", model$design, envir=.GlobalEnv) - assign(".formula", model$formula, envir=.GlobalEnv) + assign(".design", model$design, envir = sys.frame()) + assign(".formula", model$formula, envir = sys.frame()) model.residuals <- resids(model, method = "latent") - remove(".design", envir=.GlobalEnv) - remove(".formula", envir=.GlobalEnv) + if (identical(sys.frame(), .GlobalEnv)) { + remove(".design", envir = sys.frame()) + remove(".formula", envir = sys.frame()) + } } else model.residuals <- resids(model, method = "latent") } @@ -2435,7 +2438,7 @@ reduceOutputSize <- function(fit) ## remove environment attribute to reduce size attr(fit$terms, ".Environment") <- c() attr(original$terms, ".Environment") <- c() - attr(original$formula, ".Environment") <- c() + #attr(original$formula, ".Environment") <- c() attr(attr(original$model, "terms"), ".Environment") <- c() attr(fit$summary$formula, ".Environment") <- c() attr(fit$summary$terms, ".Environment") <- c() diff --git a/tests/testthat/test-automatedoutlierremoval.R b/tests/testthat/test-automatedoutlierremoval.R index 5e081ca3..7ba619f6 100644 --- a/tests/testthat/test-automatedoutlierremoval.R +++ b/tests/testthat/test-automatedoutlierremoval.R @@ -85,9 +85,9 @@ test_that("Weighted Ordered Logit (svyolr)", { expect_error(regression <- Regression(bank.formula[["Ordered Logit"]], data = small.bank, weights = weight, type = "Ordered Logit", outlier.prop.to.remove = 0), NA) - non.outlier.data <- flipRegression:::findNonOutlierObservations(data = small.bank, outlier.prop.to.remove = 0.1, - model = regression$original, type = "Ordered Logit", - weights = small.bank$weight, seed = 12321) + non.outlier.data <- findNonOutlierObservations(data = small.bank, outlier.prop.to.remove = 0.1, + model = regression$original, type = "Ordered Logit", + weights = small.bank$weight, seed = 12321) expected.error.message <- paste0("Removing outliers has removed all the observations in the outcome variable with", " level(s): 7. If possible, this issue could be solved by merging the categories ", "of the outcome variable or reducing the Automated Outlier removal setting.") @@ -224,12 +224,12 @@ test_that("Consistent structure with automated outlier removal", { expect_false(identical(automated.removal.linear$coef, basic.linear$coef)) expect_equal(basic.linear$coef, lm(bank.formula[["Linear"]], data = small.bank)$coefficients) n.data <- nrow(basic.linear$estimation.data) - computed.subset <- flipRegression:::findNonOutlierObservations(data = basic.linear$estimation.data, - model = lm(bank.formula[["Linear"]], - data = basic.linear$estimation.data), - outlier.prop.to.remove = proportion, - type = "Linear", - weights = NULL) + computed.subset <- findNonOutlierObservations(data = basic.linear$estimation.data, + model = lm(bank.formula[["Linear"]], + data = basic.linear$estimation.data), + outlier.prop.to.remove = proportion, + type = "Linear", + weights = NULL) expect_equal(computed.subset, automated.removal.linear$non.outlier.data) manually.computed.subset <- rank(abs(basic.linear$original$residuals)) <= ceiling(n.data * (1 - proportion)) expect_equivalent(computed.subset, manually.computed.subset) From 18ae352fa49d60afdba6850dab8eb45df2c41739 Mon Sep 17 00:00:00 2001 From: jrwishart Date: Tue, 6 Dec 2022 18:23:01 +1100 Subject: [PATCH 4/4] DS-4148 Use survey version 4.1-1 --- .travis.yml | 1 - DESCRIPTION | 3 +-- 2 files changed, 1 insertion(+), 3 deletions(-) diff --git a/.travis.yml b/.travis.yml index b5478f8e..47838506 100644 --- a/.travis.yml +++ b/.travis.yml @@ -28,7 +28,6 @@ r_packages: r_github_packages: - Displayr/flipDevTools - - CRAN/survey@4.0 - Displayr/flipExampleData script: diff --git a/DESCRIPTION b/DESCRIPTION index baf55ddf..db6e56b7 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -27,14 +27,13 @@ Imports: car, rhtmlHeatmap, stats, sure, - survey, + survey (>= 4.1.1), verbs, xml2 Suggests: flipExampleData, testthat, robustbase Remotes: - cran/survey@4.0, Displayr/flipU, Displayr/flipFormat, Displayr/flipData,