From 591f84f5f1062f7f4cb2008ed33d33b1bae1e3f0 Mon Sep 17 00:00:00 2001 From: Laura Marshall Date: Thu, 27 Feb 2025 10:45:12 +0000 Subject: [PATCH 1/3] Closes #149 Now models can be passed to summarize_ds_models as a list rather than individually --- DESCRIPTION | 2 +- NEWS.md | 1 + R/summarize_ds_models.R | 34 ++++++++++++++++++++++++--------- man/summarize_ds_models.Rd | 8 +++++++- tests/testthat/test_ds.R | 4 ++-- tests/testthat/test_summarize.R | 33 +++++++++++++++++++++++++------- 6 files changed, 62 insertions(+), 20 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 98aeef6..abe74b0 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -16,7 +16,7 @@ Description: A simple way of fitting detection functions to distance sampling Horvitz-Thompson-like estimator) if survey area information is provided. See Miller et al. (2019) for more information on methods and for example analyses. -Version: 2.0.0.9002 +Version: 2.0.0.9003 URL: https://github.com/DistanceDevelopment/Distance/ BugReports: https://github.com/DistanceDevelopment/Distance/issues Language: en-GB diff --git a/NEWS.md b/NEWS.md index fcd15ce..3397245 100644 --- a/NEWS.md +++ b/NEWS.md @@ -2,6 +2,7 @@ * Fixes issue with print dht2 when multipliers are a data.frame (Issue #179) * Fixes bug when including a uniform with no adjustment terms in the summarize_ds_models function (Issue #180) +* Users to pass a list of models to summarize_ds_models rather than passing them individually. (Issue #) # Distance 2.0.0 diff --git a/R/summarize_ds_models.R b/R/summarize_ds_models.R index d4e261f..cb05f88 100644 --- a/R/summarize_ds_models.R +++ b/R/summarize_ds_models.R @@ -26,15 +26,31 @@ #' model_hr <- ds(tee.data,4, key="hr") #' summarize_ds_models(model_hr, model_hn, output="plain") #'} -summarize_ds_models <- function(..., sort="AIC", output="latex", delta_only=TRUE){ - - # get the models - models <- list(...) - - # get the model names - model_names <- setdiff(as.character(match.call(expand.dots=TRUE)), - as.character(match.call(expand.dots=FALSE))) - +summarize_ds_models <- function(..., models=list(), sort="AIC", output="latex", delta_only=TRUE){ + # Check to see if the user supplied the model list via the ... + tmp <- list(...) + if(length(tmp) > 0){ + # Check if its a list of models - incase the user has passed in via ... instead of models argument + if(is(tmp[[1]], "list")){ + models <- tmp[[1]] + } + } + # Check if user is supplying via new models argument or not + if(length(models) == 0){ + warning("Passing models via ... will be depricated in the next release, please pass models in a list using the models argument.", immediate. = TRUE, call. = FALSE) + # get the models from ... + models <- tmp + # get the model names + model_names <- setdiff(as.character(match.call(expand.dots=TRUE)), + as.character(match.call(expand.dots=FALSE))) + }else{ + # get the model names + model_names <- names(models) + # if it's an unnamed list, give generic names to them + if(is.null(model_names)){ + model_names <- paste("model ", 1:length(models), sep = "") + } + } ## checking # can't compare models with different truncations diff --git a/man/summarize_ds_models.Rd b/man/summarize_ds_models.Rd index e1f9e49..27dffbf 100644 --- a/man/summarize_ds_models.Rd +++ b/man/summarize_ds_models.Rd @@ -4,7 +4,13 @@ \alias{summarize_ds_models} \title{Make a table of summary statistics for detection function models} \usage{ -summarize_ds_models(..., sort = "AIC", output = "latex", delta_only = TRUE) +summarize_ds_models( + ..., + models = list(), + sort = "AIC", + output = "latex", + delta_only = TRUE +) } \arguments{ \item{...}{models to be summarised} diff --git a/tests/testthat/test_ds.R b/tests/testthat/test_ds.R index 09eca95..7ce90f3 100644 --- a/tests/testthat/test_ds.R +++ b/tests/testthat/test_ds.R @@ -156,8 +156,8 @@ test_that("Uniform does work after all",{ x1 <- ds(ducknest, key="unif", adjustment = NULL) x2 <- ds(ducknest, key="unif", nadj = 1) x3 <- ds(ducknest, key="hn", adjustment = NULL) - tmp <- summarize_ds_models(x1, x2, x3, - delta_only = FALSE) + tmp <- suppressWarnings(summarize_ds_models(x1, x2, x3, + delta_only = FALSE)) expect_is(tmp, "data.frame") expect_equal(nrow(tmp), 3) }) diff --git a/tests/testthat/test_summarize.R b/tests/testthat/test_summarize.R index 467eeff..3b41f5d 100644 --- a/tests/testthat/test_summarize.R +++ b/tests/testthat/test_summarize.R @@ -28,14 +28,14 @@ test_that("Error on different truncation distance", { ", header=FALSE) names(out) <- c("Model", "Key function", "Formula", "C-vM p-value", "$\\hat{P_a}$", "se($\\hat{P_a}$)", "$\\Delta$AIC") - expect_equal(summarize_ds_models(t4, t42, t4hr), out, fixed=TRUE, tol=par.tol) + expect_equal(suppressWarnings(summarize_ds_models(t4, t42, t4hr)), out, fixed=TRUE, tol=par.tol) # right truncation different - expect_error(summarize_ds_models(t3, t4)) + expect_error(suppressWarnings(summarize_ds_models(t3, t4))) # left - expect_error(summarize_ds_models(t4, t14)) + expect_error(suppressWarnings(summarize_ds_models(t4, t14))) # both - expect_error(summarize_ds_models(t3, t4, t41)) + expect_error(suppressWarnings(summarize_ds_models(t3, t4, t41))) }) @@ -57,13 +57,32 @@ test_that("Binning",{ names(out) <- c("Model", "Key function", "Formula", "$\\chi^2$ $p$-value", "$\\hat{P_a}$", "se($\\hat{P_a}$)", "$\\Delta$AIC") - expect_equal(summarize_ds_models(cp1, cp11), out, fixed=TRUE, tol=par.tol) + expect_equal(suppressWarnings(summarize_ds_models(cp1, cp11)), out, fixed=TRUE, tol=par.tol) # different bins - expect_error(summarize_ds_models(cp1, cp11, cp2)) + expect_error(suppressWarnings(summarize_ds_models(cp1, cp11, cp2))) # mixing binned and unbinned ncp <- suppressMessages(ds(egdata, key="hn", order=0)) - expect_error(summarize_ds_models(cp1, ncp)) + expect_error(suppressWarnings(summarize_ds_models(cp1, ncp))) }) + +test_that("Passing in models via a list",{ + skip_on_cran() + data(book.tee.data) + tee.data <- subset(book.tee.data$book.tee.dataframe, observer==1) + ds.model <- ds(tee.data, 4) + ds.model.cos <- ds(tee.data, 4, adjustment="cos", order=2) + ds.model.hr <- ds(tee.data, 4, key = "hr", nadj = 0) + + expect_warning(test1 <- summarize_ds_models(ds.model, ds.model.cos, ds.model.hr), "Passing models via ... will be depricated in the next release, please pass models in a list using the models argument.") + + test2 <- summarize_ds_models(models = list(ds.model, ds.model.cos, ds.model.hr)) + + expect_identical(test1[,2:7], test2[,2:7]) + + test3 <- summarize_ds_models(list(ds.model, ds.model.cos, ds.model.hr)) + + expect_identical(test1[,2:7], test3[,2:7]) +}) From f569476af26d3ba87f8818e470ac3f1bdfe00d6d Mon Sep 17 00:00:00 2001 From: Laura Marshall Date: Thu, 27 Feb 2025 13:06:31 +0000 Subject: [PATCH 2/3] docs and testing summarize_ds_models --- NEWS.md | 2 +- R/summarize_ds_models.R | 4 +++- man/summarize_ds_models.Rd | 5 ++++- tests/testthat/test_summarize.R | 4 ++++ 4 files changed, 12 insertions(+), 3 deletions(-) diff --git a/NEWS.md b/NEWS.md index 3397245..7842a9a 100644 --- a/NEWS.md +++ b/NEWS.md @@ -2,7 +2,7 @@ * Fixes issue with print dht2 when multipliers are a data.frame (Issue #179) * Fixes bug when including a uniform with no adjustment terms in the summarize_ds_models function (Issue #180) -* Users to pass a list of models to summarize_ds_models rather than passing them individually. (Issue #) +* Users to pass a list of models to summarize_ds_models rather than passing them individually. (Issue #149) # Distance 2.0.0 diff --git a/R/summarize_ds_models.R b/R/summarize_ds_models.R index cb05f88..56558b4 100644 --- a/R/summarize_ds_models.R +++ b/R/summarize_ds_models.R @@ -9,7 +9,9 @@ #' the resulting `data.frame` in R, you may wish to rename the columns for #' ease of access. #' -#' @param ... models to be summarised +#' @param ... models to be summarised (to be deprecated) +#' @param models a named list of models to be summarised. If the list is not +#' named then default names of 'model 1', 'model 2' etc. are used. #' @param sort column to sort by (default `"AIC"`) #' @param output should the output be given in `"latex"` compatible format #' or as `"plain"` text? diff --git a/man/summarize_ds_models.Rd b/man/summarize_ds_models.Rd index 27dffbf..b92975a 100644 --- a/man/summarize_ds_models.Rd +++ b/man/summarize_ds_models.Rd @@ -13,7 +13,10 @@ summarize_ds_models( ) } \arguments{ -\item{...}{models to be summarised} +\item{...}{models to be summarised (to be deprecated)} + +\item{models}{a named list of models to be summarised. If the list is not +named then default names of 'model 1', 'model 2' etc. are used.} \item{sort}{column to sort by (default \code{"AIC"})} diff --git a/tests/testthat/test_summarize.R b/tests/testthat/test_summarize.R index 3b41f5d..aab6d94 100644 --- a/tests/testthat/test_summarize.R +++ b/tests/testthat/test_summarize.R @@ -85,4 +85,8 @@ test_that("Passing in models via a list",{ test3 <- summarize_ds_models(list(ds.model, ds.model.cos, ds.model.hr)) expect_identical(test1[,2:7], test3[,2:7]) + expect_identical(test3[,1], c("\\texttt{model 1}", "\\texttt{model 2}", "\\texttt{model 3}")) + + test4 <- summarize_ds_models(list(m1 = ds.model, m2 = ds.model.cos, m3 = ds.model.hr)) + expect_identical(test4[,1], c("\\texttt{m1}", "\\texttt{m2}", "\\texttt{m3}")) }) From d194aba00ef9b4d6768297ede0ae6b5d9117a9c2 Mon Sep 17 00:00:00 2001 From: Laura Marshall Date: Thu, 27 Feb 2025 13:07:35 +0000 Subject: [PATCH 3/3] Truncation for binned data Ensure that the truncation distance for binned data is not larger than the largest cutpoint. --- DESCRIPTION | 2 +- NEWS.md | 1 + R/get_truncation.R | 10 ++++++++++ tests/testthat/test_ds.R | 6 ++++++ 4 files changed, 18 insertions(+), 1 deletion(-) diff --git a/DESCRIPTION b/DESCRIPTION index abe74b0..e59676a 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -16,7 +16,7 @@ Description: A simple way of fitting detection functions to distance sampling Horvitz-Thompson-like estimator) if survey area information is provided. See Miller et al. (2019) for more information on methods and for example analyses. -Version: 2.0.0.9003 +Version: 2.0.0.9004 URL: https://github.com/DistanceDevelopment/Distance/ BugReports: https://github.com/DistanceDevelopment/Distance/issues Language: en-GB diff --git a/NEWS.md b/NEWS.md index 7842a9a..eb66c9c 100644 --- a/NEWS.md +++ b/NEWS.md @@ -3,6 +3,7 @@ * Fixes issue with print dht2 when multipliers are a data.frame (Issue #179) * Fixes bug when including a uniform with no adjustment terms in the summarize_ds_models function (Issue #180) * Users to pass a list of models to summarize_ds_models rather than passing them individually. (Issue #149) +* Truncation distances greater than the largest cutpoint value for binned data are no longer permitted as these cause fitting issues. (Issue #175) # Distance 2.0.0 diff --git a/R/get_truncation.R b/R/get_truncation.R index 37dc525..7662029 100644 --- a/R/get_truncation.R +++ b/R/get_truncation.R @@ -54,5 +54,15 @@ get_truncation <- function(truncation, cutpoints, data){ stop("Truncation must be supplied as a single number/string or a list with elements \"left\" and \"right\".") } } + + # Final check that truncation is not greater than largest cutpoint + if(!is.null(cutpoints)){ + if(width > cutpoints[length(cutpoints)]){ + warning(paste("Truncation width is greater than the largest bin distance, re-setting truncation to be largest cutpoint value: ", cutpoints[length(cutpoints)], sep = ""), immediate. = TRUE, call. = FALSE) + # Make truncation largest cutpoint + width <- cutpoints[length(cutpoints)] + } + } + list(left=left, width=width) } diff --git a/tests/testthat/test_ds.R b/tests/testthat/test_ds.R index 7ce90f3..2d830ab 100644 --- a/tests/testthat/test_ds.R +++ b/tests/testthat/test_ds.R @@ -56,6 +56,12 @@ test_that("binning works", { # first cutpoint not zero when no left truncation expect_error(ds(egdata,4,cutpoints=c(2,3,4)), "The first cutpoint must be 0 or the left truncation distance!") + + expect_warning(ds.obj <- ds(egdata,list(left = 2, right = 5),cutpoints=c(2,3,4)), + "Truncation width is greater than the largest bin distance, re-setting truncation to be largest cutpoint value: 4") + + # Check that the width has been modified correctly + expect_equal(ds.obj$ddf$meta.data$width, 4) tst_distances <- data.frame(distance = c(0, 0, 0, 10, 50, 70, 110)) expect_equal(as.vector(table(create_bins(tst_distances,