WIP: add lower limit to bandwith estimate for method='kde'

[jan-glx]

Currently, ggpointdensity fails with an unhelpful error message when a bandwidth estimate is zero. For example:

library(ggplot2)
#> Warning: package 'ggplot2' was built under R version 4.2.3
library(ggpointdensity)

df <- data.frame(x = sample(seq_len(1),100000, replace = TRUE), y = sample(seq_len(1000),100000, replace = TRUE))

ggplot(df, aes(x, y)) + geom_pointdensity() +scale_x_log10() + scale_y_log10()
#> geom_pointdensity using method='kde2d' due to large number of points (>20k)
#> Warning in value[[3L]](cond): Computation failed in `stat_pointdensity()`:
#> bandwidths must be strictly positive
#> Error in `geom_pointdensity()`:
#> ! Problem while computing stat.
#> ℹ Error occurred in the 1st layer.
#> Caused by error in `value[[3L]]()`:
#> ! object 'new_data_frame' not found
#> Backtrace:
#>      ▆
#>   1. ├─base::tryCatch(...)
#>   2. │ └─base (local) tryCatchList(expr, classes, parentenv, handlers)
#>   3. │   ├─base (local) tryCatchOne(...)
#>   4. │   │ └─base (local) doTryCatch(return(expr), name, parentenv, handler)
#>   5. │   └─base (local) tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
#>   6. │     └─base (local) tryCatchOne(expr, names, parentenv, handlers[[1L]])
#>   7. │       └─base (local) doTryCatch(return(expr), name, parentenv, handler)
#>   8. ├─base::withCallingHandlers(...)
#>   9. ├─base::saveRDS(...)
#>  10. ├─base::do.call(...)
#>  11. ├─base (local) `<fn>`(...)
#>  12. ├─global `<fn>`(input = base::quote("full-husky_reprex.R"))
#>  13. │ └─rmarkdown::render(input, quiet = TRUE, envir = globalenv(), encoding = "UTF-8")
#>  14. │   └─knitr::knit(knit_input, knit_output, envir = envir, quiet = quiet)
#>  15. │     └─knitr:::process_file(text, output)
#>  16. │       ├─base::withCallingHandlers(...)
#>  17. │       ├─knitr:::process_group(group)
#>  18. │       └─knitr:::process_group.block(group)
#>  19. │         └─knitr:::call_block(x)
#>  20. │           └─knitr:::block_exec(params)
#>  21. │             └─knitr:::eng_r(options)
#>  22. │               ├─knitr:::in_input_dir(...)
#>  23. │               │ └─knitr:::in_dir(input_dir(), expr)
#>  24. │               └─knitr (local) evaluate(...)
#>  25. │                 └─evaluate::evaluate(...)
#>  26. │                   └─evaluate:::evaluate_call(...)
#>  27. │                     ├─evaluate (local) handle(...)
#>  28. │                     │ └─base::try(f, silent = TRUE)
#>  29. │                     │   └─base::tryCatch(...)
#>  30. │                     │     └─base (local) tryCatchList(expr, classes, parentenv, handlers)
#>  31. │                     │       └─base (local) tryCatchOne(expr, names, parentenv, handlers[[1L]])
#>  32. │                     │         └─base (local) doTryCatch(return(expr), name, parentenv, handler)
#>  33. │                     ├─base::withCallingHandlers(...)
#>  34. │                     ├─base::withVisible(value_fun(ev$value, ev$visible))
#>  35. │                     └─knitr (local) value_fun(ev$value, ev$visible)
#>  36. │                       └─knitr (local) fun(x, options = options)
#>  37. │                         ├─base::withVisible(knit_print(x, ...))
#>  38. │                         ├─knitr::knit_print(x, ...)
#>  39. │                         └─knitr:::knit_print.default(x, ...)
#>  40. │                           └─evaluate (local) normal_print(x)
#>  41. │                             ├─base::print(x)
#>  42. │                             └─ggplot2:::print.ggplot(x)
#>  43. │                               ├─ggplot2::ggplot_build(x)
#>  44. │                               └─ggplot2:::ggplot_build.ggplot(x)
#>  45. │                                 └─ggplot2:::by_layer(...)
#>  46. │                                   ├─rlang::try_fetch(...)
#>  47. │                                   │ ├─base::tryCatch(...)
#>  48. │                                   │ │ └─base (local) tryCatchList(expr, classes, parentenv, handlers)
#>  49. │                                   │ │   └─base (local) tryCatchOne(expr, names, parentenv, handlers[[1L]])
#>  50. │                                   │ │     └─base (local) doTryCatch(return(expr), name, parentenv, handler)
#>  51. │                                   │ └─base::withCallingHandlers(...)
#>  52. │                                   └─ggplot2 (local) f(l = layers[[i]], d = data[[i]])
#>  53. │                                     └─l$compute_statistic(d, layout)
#>  54. │                                       └─ggplot2 (local) compute_statistic(..., self = self)
#>  55. │                                         └─self$stat$compute_layer(data, self$computed_stat_params, layout)
#>  56. │                                           └─ggpointdensity (local) compute_layer(..., self = self)
#>  57. │                                             └─ggplot2:::dapply(...)
#>  58. │                                               └─ggplot2 (local) apply_fun(df)
#>  59. │                                                 └─ggpointdensity (local) fun(x, ...)
#>  60. │                                                   └─base::tryCatch(...)
#>  61. │                                                     └─base (local) tryCatchList(expr, classes, parentenv, handlers)
#>  62. │                                                       └─base (local) tryCatchOne(expr, names, parentenv, handlers[[1L]])
#>  63. │                                                         └─value[[3L]](cond)
#>  64. └─base::.handleSimpleError(...)
#>  65.   └─rlang (local) h(simpleError(msg, call))
#>  66.     └─handlers[[1L]](cnd)
#>  67.       └─cli::cli_abort(...)
#>  68.         └─rlang::abort(...)

^{Created on 2023-06-19 with reprex v2.0.2}

Session info

sessionInfo()
#> R version 4.2.2 (2022-10-31 ucrt)
#> Platform: x86_64-w64-mingw32/x64 (64-bit)
#> Running under: Windows 10 x64 (build 22621)
#> 
#> Matrix products: default
#> 
#> locale:
#> [1] LC_COLLATE=English_United States.utf8 
#> [2] LC_CTYPE=English_United States.utf8   
#> [3] LC_MONETARY=English_United States.utf8
#> [4] LC_NUMERIC=C                          
#> [5] LC_TIME=English_United States.utf8    
#> 
#> attached base packages:
#> [1] stats     graphics  grDevices utils     datasets  methods   base     
#> 
#> other attached packages:
#> [1] ggpointdensity_0.1.0 ggplot2_3.4.2       
#> 
#> loaded via a namespace (and not attached):
#>  [1] compiler_4.2.2   pillar_1.9.0     highr_0.9        tools_4.2.2     
#>  [5] digest_0.6.30    evaluate_0.18    lifecycle_1.0.3  tibble_3.2.1    
#>  [9] gtable_0.3.3     pkgconfig_2.0.3  rlang_1.1.1      reprex_2.0.2    
#> [13] DBI_1.1.3        cli_3.6.1        rstudioapi_0.14  yaml_2.3.6      
#> [17] xfun_0.34        fastmap_1.1.0    withr_2.5.0      stringr_1.4.1   
#> [21] dplyr_1.0.10     knitr_1.40       generics_0.1.3   fs_1.5.2        
#> [25] vctrs_0.6.2      grid_4.2.2       tidyselect_1.2.0 glue_1.6.2      
#> [29] R6_2.5.1         fansi_1.0.4      rmarkdown_2.17   magrittr_2.0.3  
#> [33] MASS_7.3-58.1    scales_1.2.1     htmltools_0.5.3  assertthat_0.2.1
#> [37] colorspace_2.1-0 utf8_1.2.3       stringi_1.7.8    munsell_0.5.0

This PR limits bandwidth estimates to sqrt(.Maschine$double.eps) and thus produces a usefull plot in this example:

library(ggplot2)
library(ggpointdensity)

df <- data.frame(x = sample(seq_len(1),100000, replace = TRUE), y = sample(seq_len(1000),100000, replace = TRUE))

ggplot(df, aes(x, y)) + geom_pointdensity() +scale_x_log10() + scale_y_log10()
#> geom_pointdensity using method='kde2d' due to large number of points (>20k)

^{Created on 2023-06-19 by the reprex package (v2.0.1)}

[LKremer]

Thanks, looks good! :) And sorry for the delay.