Dev auto indic links

DESCRIPTION

@@ -2,7 +2,7 @@ Package: rtauargus
 Type: Package
 Title: Using Tau-Argus from R
 Language: fr
-Version: 1.3.5
+Version: 1.3.6
 Depends: R (>= 4.1.0)
 Imports:
     purrr (>= 0.2),

R/format_template.R

@@ -215,6 +215,7 @@ format_template <- function(data,indicator_column,spanning_var_tot,field_columns
           FALSE
         }
       })
+
       spanning_description <- purrr::imap_dfr(
         tables_crossing_variables,
         ~ {
@@ -223,12 +224,13 @@ format_template <- function(data,indicator_column,spanning_var_tot,field_columns
             paste0("hrc_", tolower(names(.x)), "_", sapply(.x, function(col) length(unique(col)))),
             names(.x)
           )
-          # Extract variable names and formatted counts
-          variable_names <- names(formatted_counts) # Spanning variables
-          hrc_values <- formatted_counts            # Corresponding hrc values
+
+          nb_modalities <- sapply(.x, function(col) length(unique(col)))
+          variable_names <- paste0(names(nb_modalities),"_",nb_modalities) # Spanning variables
+          hrc_values <- paste0("hrc_", tolower(names(.x))) # Corresponding hrc values
           unique_modalities <- setNames(
             sapply(.x, function(col) unique(col), simplify = FALSE),
-            formatted_counts
+            hrc_values
           )
           # Create a dynamic data frame
           data.frame(

R/identify_hrc.R

@@ -48,24 +48,43 @@ identify_hrc <- function(df_metadata_long){
     table_name = df_spannings$table_name
   ) %>% unique()
   df_spannings <- df_spannings %>% select(-spanning_old)
-  if(all(is.na(df_spannings$hrc_indicator))){ # condition for hierarchies on indicators
-    df_indicators <- df_spannings
-    return(list(df_indicators,df_variable_info))
-  } else {
-    df_indicators <- df_spannings %>%
+
+  # Hierachies on indicators
+  if (any(!is.na(df_spannings$hrc_indicator))) {
+    df_hrc_indicator <- df_spannings %>%
       filter(!is.na(hrc_indicator)) %>%
-      dplyr::group_by(table_name) %>%
+      group_by(table_name) %>%
       summarise(
         field = last(field),
         hrc_field = last(hrc_field),
-        spanning = paste0(toupper(last(hrc_indicator)),"^h"),
+        spanning = paste0(toupper(last(hrc_indicator)), "^h"),
         hrc_spanning = last(hrc_indicator),
         indicator = last(indicator),
         hrc_indicator = last(hrc_indicator)
       ) %>%
       bind_rows(df_spannings, .) %>%
       arrange(table_name)
-    list_hrc_identified = list(df_indicators,df_variable_info)
-    return(list_hrc_identified)
+  } else {
+    df_hrc_indicator <- df_spannings
+  }
+  # Hierarchies on fields
+  if (any(!is.na(df_spannings$hrc_field))) {
+    df_hrc_field <- df_hrc_indicator %>%
+      filter(!is.na(hrc_field)) %>%
+      group_by(table_name) %>%
+      summarise(
+        field = last(hrc_field),
+        hrc_field = last(hrc_field),
+        spanning = paste0(toupper(last(hrc_field)), "^h"),
+        hrc_spanning = last(hrc_field),
+        indicator = last(indicator),
+        hrc_indicator = last(hrc_indicator)
+      ) %>%
+      bind_rows(df_hrc_indicator, .) %>%
+      arrange(table_name)
+  } else {
+    df_hrc_field <- df_hrc_indicator
   }
+
+  list(df_hrc_field,df_variable_info)
 }

R/identify_hrc_with_eq.R

@@ -100,7 +100,7 @@ identify_hrc_with_eq <- function(df_metadata_long,df_eq_indicator){
     dplyr::filter(!is.na(rhs)) %>%
     dplyr::mutate(
       total = trimws(as.character(total)),
-      rhs   = trimws(as.character(rhs))
+      rhs = trimws(as.character(rhs))
     ) %>%
     dplyr::distinct() %>%
     left_join(alt_map, by = c("eq_name", "total")) %>%
@@ -152,6 +152,27 @@ identify_hrc_with_eq <- function(df_metadata_long,df_eq_indicator){
       hrc_indicator = ifelse(indicator %in% unique(equations_long$var), NA, hrc_indicator)
     )
 
+  if (any(!is.na(df_spannings$hrc_field))) {
+    df_spannings <- df_spannings %>%
+      mutate(
+        field = ifelse(is.na(hrc_field), field, toupper(hrc_field)))
+
+    spanning_field_rows <- df_spannings %>%
+      filter(!is.na(hrc_field)) %>%
+      group_by(table_name) %>%
+      summarise(
+        field = last(hrc_field),
+        hrc_field = last(hrc_field),
+        spanning = paste0(toupper(last(hrc_field)), "^h"),
+        hrc_spanning = last(hrc_spanning),
+        indicator = last(indicator),
+        hrc_indicator = last(hrc_indicator)
+      )
+
+    df_spannings <- bind_rows(df_spannings, spanning_field_rows) %>%
+      arrange(table_name)
+  }
+
   df_spannings_eq <- df_spannings %>%
     mutate(across(dplyr::where(is.character), ~ gsub("[^[:alnum:]_]", "", .))) %>%
     left_join(equations_long_full, by = c("indicator" = "var"))
@@ -399,7 +420,7 @@ regroup_tables <- function(df_group, spanning_combination_group) {
     df_group |>
       filter(table_name %in% tables_complete) |>
       left_join(spanning_by_table |> select(table_name, spanning_key), by = "table_name") |>
-      group_by(across(-c(table_name, side, var_mapped, indicator))) |>
+      group_by(across(-c(table_name, side, var_mapped, indicator, eq_name))) |>
       summarise(
         table_name = paste(sort(unique(table_name)), collapse = "."),
         indicator = last(unit),

R/wide_to_long.R

@@ -30,6 +30,7 @@
 #'
 wide_to_long <- function(df_metadata){
   df_metadata_long <- df_metadata %>%
+    mutate(across(where(is.character), ~dplyr::na_if(.x, ""))) %>%
     pivot_longer(cols = starts_with("spanning"),
                  names_to = "spanning_name",
                  values_to = "spanning") %>%

tests/testthat/test_analyse_metadata.R

@@ -94,6 +94,65 @@ test_that("hierarchies on indicators", {
 }
 )
 
+# check that the hierarchies on fields are handled properly --------------------
+answer <- data.frame(
+  cluster = "hrc_geo.to_pizza",
+  table_name = "T1.T2.T3",
+  field = "france_entreprises_2023",
+  indicator = "to_pizza",
+  spanning_1 = "size",
+  spanning_2 = "HRC_GEO^h",
+  hrc_spanning_1 = NA_character_,
+  hrc_spanning_2 = "hrc_geo"
+)
+
+test_that("hierarchies on fields", {
+
+  meta <- data.frame(
+    table_name = paste0("T", 1:3),
+    field = c("france_entreprises_2023","metro_entreprises_2023","dom_entreprises_2023"),
+    hrc_field = "hrc_geo",
+    indicator = "to_pizza",
+    hrc_indicator = NA_character_,
+    spanning_1 = "size",
+    hrc_spanning_1 = NA_character_
+  )
+
+  expect_equal(analyse_metadata(meta),answer)
+}
+)
+
+# check that the hierarchies on fields and on indicators -----------------------
+answer <- data.frame(
+  cluster = "hrc_geo.hrc_salades",
+  table_name = "T1.T2.T3",
+  field = "france_entreprises_2023",
+  indicator = "SALADES",
+  spanning_1 = "size",
+  spanning_2 = "HRC_SALADES^h",
+  spanning_3 = "HRC_GEO^h",
+  hrc_spanning_1 = NA_character_,
+  hrc_spanning_2 = "hrc_salades",
+  hrc_spanning_3 = "hrc_geo"
+)
+
+test_that("hierarchies on fields and indicators", {
+
+  meta <- data.frame(
+    table_name = paste0("T", 1:3),
+    field = c("france_entreprises_2023","metro_entreprises_2023","dom_entreprises_2023"),
+    hrc_field = "hrc_geo",
+    indicator = c("to_batavia","to_arugula","to_lettuce"),
+    hrc_indicator = "hrc_salades",
+    spanning_1 = "size",
+    hrc_spanning_1 = NA_character_
+  )
+
+  expect_equal(analyse_metadata(meta),answer)
+}
+)
+
+
 ############################################################### TABLE INCLUSIONS
 # two tables included in each other
 answer <- data.frame(
@@ -394,3 +453,83 @@ test_that("pas_meme_var_crois_2", {
 }
 )
 
+# Two equations linked by one indicator ----------------------------------------
+meta <- metadata_pizza_lettuce |>
+  filter(hrc_indicator == "hrc_lettuce")
+
+meta <- bind_rows(
+  meta,
+  meta |>
+    dplyr::slice(1:2) |>
+    mutate(indicator = c("to_bat1", "to_bat2"),
+           table_name = c("T1", "T2"))
+) |>
+  mutate(hrc_indicator = NA_character_)
+
+df_eq_lettuce_included <- data.frame(
+  eq_name = c("eq1","eq2"),
+  eq_indicator = c("to_lettuce = to_batavia + to_arugula",
+                   "to_batavia = to_bat1 + to_bat2"),
+  unit = c("EUR","EUR"),
+  stringsAsFactors = FALSE
+)
+
+answer <- data.frame(
+  cluster = rep("france_entreprises_2023.EUR"),
+  table_name = c("T1.T11.T7.T9","T10.T12.T2.T8"),
+  field = rep("france_entreprises_2023"),
+  indicator = c("to_batavia","to_batavia"),
+  spanning_1 = c("HRC_NAF","HRC_NAF"),
+  spanning_2 = c("size","cj"),
+  spanning_3 = c("EQ1_EQ2^h","EQ1_EQ2^h"),
+  hrc_spanning_1 = c("hrc_naf","hrc_naf"),
+  hrc_spanning_2 = NA_character_,
+  hrc_spanning_3 = c("hrc_EQ1_EQ2.totcode.to_batavia","hrc_EQ1_EQ2.totcode.to_batavia")
+)
+
+test_that("eqs_linked_by_one_indicator", {
+  expect_warning(
+    expect_equal(
+      analyse_metadata(df_metadata = meta,df_eq_indicator = df_eq_lettuce_included),
+      answer
+    ),
+    "hrc_indicator column will be ignored"
+  )
+
+}
+)
+
+# the hrc on fields are handled properly ---------------------------------------
+answer <- data.frame(
+  cluster = "hrc_geo.EUR",
+  table_name = "T1.T2.T3",
+  field = "hrc_geo",
+  indicator = "to_lettuce",
+  spanning_1 = "HRC_GEOh",
+  spanning_2 = "size",
+  spanning_3 = "EQ1^h",
+  hrc_spanning_1 = NA_character_,
+  hrc_spanning_2 = NA_character_,
+  hrc_spanning_3 = "hrc_EQ1.totcode.to_lettuce"
+)
+
+test_that("hierarchies on fields with eq on indicators", {
+
+  meta <- data.frame(
+    table_name = paste0("T", 1:3),
+    field = c("france_entreprises_2023","metro_entreprises_2023","dom_entreprises_2023"),
+    hrc_field = "hrc_geo",
+    indicator = c("to_lettuce","to_batavia","to_arugula"),
+    hrc_indicator = NA_character_,
+    spanning_1 = "size",
+    hrc_spanning_1 = NA_character_
+  )
+  expect_warning(
+    expect_equal(analyse_metadata(meta,df_eq_lettuce_1),answer),
+    "hrc_indicator column will be ignored"
+  )
+}
+)
+
+
+