ODAPbackend/test_smooth.R at master · TTRustam/ODAPbackend · GitHub

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
library(DemoTools)
library(tidyverse)
library(LifeIneq)
library(testthat)
library(scales)
library(covr)
source("R/readers.R")
source("R/list_utils.R")
source("R/graduation.R")

# single
data_in <- read_csv("inst/extdata/single_hmd_spain.csv") %>%
  dplyr::select(-1)
# abriged
data_in <- read_csv("inst/extdata/abridged_hmd_spain.csv") %>%
  dplyr::select(-1)
# 5-year
data_in <- read_csv("inst/extdata/five_hmd_spain.csv") %>%
  dplyr::select(-1)

# argumets used in graduation function
argums <- expand_grid(
  variable = c("Deaths", "Exposures"),
  age_out  = c("single", "abridged", "5-year"),
  fine_method = c(
    "auto",
    "none",
    "sprague",
    "beers(ord)",
    "beers(mod)",
    "grabill",
    "pclm",
    "mono",
    "uniform"
  ),
  rough_method = c(
    "auto",
    "none",
    "Carrier-Farrag",
    "KKN",
    "Arriaga",
    "United Nations",
    "Strong",
    "Zigzag"
  ),
  u5m               = 1.05,
  constrain_infants = TRUE,
  Sex = "t",
  by_args = "Year"
)

# save results
x      <- vector(mode   = "list",
                 length = nrow(argums))
# for trycatch
errors <- vector("numeric")

# Loop through each row in argums
for (i in 1:nrow(argums)) {
  x[[i]] <- tryCatch(
    {
      smooth_flexible(
        data_in,
        variable          = argums$variable[i],
        age_out           = argums$age_out[i],
        fine_method       = argums$fine_method[i],
        rough_method      = argums$rough_method[i],
        u5m               = argums$u5m[i],
        constrain_infants = argums$constrain_infants[i],
        Sex               = argums$Sex[i],
        by_args           = argums$by_args[i]
      )
    },
    error = function(e) {
      # Store the index and error message in the `errors` list
      errors[[i]] <- paste("Error at index", i, ":", e$message)
      NA  # Return NA for this entry in `x`
    }
  )
}

# name the resulting list
nms <- argums %>%
  unite("x", everything(), sep = ", ") %>%
  pull(x)
# add element number to names
nms <- str_c(1:nrow(argums), nms, sep = ", ")

# set the names
x <- x %>%
  set_names(nms)

# lets see which names are resulting in problems
# some of the rough_method
z <- x %>%
  keep(~ is.logical(.)) %>%
  names() %>%
  as.data.frame() %>%
  separate_wider_delim('.',
                       delim = ", ",
                       names_sep = "_",
                       too_few = "align_start") %>%
  set_names(c("element", names(argums)))

# lest confirm
tst <- data_in %>%
  filter(Sex == "Male")

# turn to proper 5 year data
tst <- tst %>%
  mutate(Age = .data$Age - .data$Age %% 5) |>
  group_by(Age)  |>
  summarize(Deaths = sum(Deaths))

# negatives again
smooth_age_5(Value  = tst$Deaths,
             Age    = tst$Age,
             method = "Arriaga")

smooth_age_5(Value  = tst$Deaths,
             Age    = tst$Age,
             method = "Strong")

# check auto auto works good
names(x)[1]
x[[1]]$figures$`1_2012`$figure
x[[1]]$figures$`2_2012`$figure
x[[1]]$figures$`2_2012`$figure

# generic methods not too much Carrier-Farrag single
names(x)[3]
x[[3]]$figures$`1_2012`$figure
x[[3]]$figures$`2_2012`$figure
x[[3]]$figures$`2_2012`$figure
# so now we know that generic rough_methods
# may cause negative values with smooth_age_5
# KKN, Arriaga, Strong, UN, so far