diff --git a/DESCRIPTION b/DESCRIPTION index 6e584f6..85ebabe 100644 --- a/DESCRIPTION +++ b/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), diff --git a/R/format_template.R b/R/format_template.R index ba48d0c..7d598a8 100644 --- a/R/format_template.R +++ b/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( diff --git a/R/identify_hrc.R b/R/identify_hrc.R index 5638ebc..0f1bc3b 100644 --- a/R/identify_hrc.R +++ b/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) } diff --git a/R/identify_hrc_with_eq.R b/R/identify_hrc_with_eq.R index 0bc342a..fb148e1 100644 --- a/R/identify_hrc_with_eq.R +++ b/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), diff --git a/R/wide_to_long.R b/R/wide_to_long.R index ea0b4cc..e41ab40 100644 --- a/R/wide_to_long.R +++ b/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") %>% diff --git a/tests/testthat/test_analyse_metadata.R b/tests/testthat/test_analyse_metadata.R index 61fbc67..3c230d9 100644 --- a/tests/testthat/test_analyse_metadata.R +++ b/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" + ) +} +) + + +