diff --git a/DESCRIPTION b/DESCRIPTION index aea21cd5..32a12333 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,6 +1,6 @@ Package: stoner Title: Support for building VIMC Montagu Touchstones, using dettl. -Version: 0.0.5 +Version: 0.0.7 Authors@R: person(given = "Wes", family = "Hinsley", @@ -18,7 +18,7 @@ Imports: Language: en-GB RoxygenNote: 6.1.1 Roxygen: list(markdown = TRUE) -Suggests: +Suggests: knitr, rmarkdown VignetteBuilder: knitr diff --git a/NEWS.md b/NEWS.md index 0af45eb2..c221f56f 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,3 +1,11 @@ +## 0.0.7 + +Support for burden_estimate_country_expectation.csv and burden_estimate_outcome_expectation.csv metadata + +## 0.0.6 + +Support for responsibility.csv metadata + ## 0.0.5 Support for burden_estimate_expectations.csv metadata diff --git a/R/burden_estimate_country_expectation.R b/R/burden_estimate_country_expectation.R new file mode 100644 index 00000000..cd1fe9d5 --- /dev/null +++ b/R/burden_estimate_country_expectation.R @@ -0,0 +1,105 @@ +############################################################################### + +extract_burden_estimate_country_expectation <- function(path, con) { + e <- list() + + e$bece_csv <- read_meta(path, + "burden_estimate_country_expectation.csv") + + e$countries <- db_get(con, "country", "id", + unique(unlist(split_semi(e$bece_csv$countries))), "id") + + e +} + +test_extract_burden_estimate_country_expectation <- function(e) { + expect_true(all(unique(unlist(split_semi(e$bece_csv$countries))) %in% + e$countries$id), label = "All expectation countries recognised") + + expect_equal(sort(names(e$bece_csv)), + c("countries", "modelling_group", "scenarios", "touchstone"), + label = "Correct columns in expectation country csv") + + expect_equal(0, sum(unlist(lapply(split_semi(e$bece_csv$countries), + function(x) any(duplicated(x))))), + label = "No duplicate expectation countries in any scenario") + +} + +############################################################################### + +transform_burden_estimate_country_expectation <- function(e, t_so_far) { + + get_responsibility_sets <- function(modelling_group, touchstone, e) { + rsets <- e$responsibility_set[ + e$responsibility_set$modelling_group == modelling_group & + e$responsibility_set$touchstone == touchstone, ] + + if (nrow(rsets) > 1) { + stop(sprintf("Error - multiple responsibility-sets for %s %s", + modelling_group, touchstone)) + } + rsets$id + } + + get_expectations_wildcard<- function(e, row, rset) { + unique(e$responsibility[e$responsibility$responsibility_set == rset, ]$expectations) + } + + get_expectations_scenario <- function(e, row, rset) { + scenarios <- data_frame(scenario = split_semi(row$scenarios)[[1]]) + scenarios$id <- e$scenario$id[match( + scenarios[['scenario']], e$scenario$scenario_description)] + + unique(e$responsibility[e$responsibility$responsibility_set == rset & + e$responsibility$scenario %in% scenarios$id, ]$expectations) + } + + transform_bece_expec <- function(df, row, expecs) { + for (expec in expecs) { + if (expec %in% df$burden_estimate_expectation) { + stop("Expectation already found for %s", expec) + } + } + + countries <- split_semi(row$countries)[[1]] + + df <- rbind(df, data_frame( + burden_estimate_expectation = rep(expecs, each = length(countries)), + country = rep(countries, length(expecs)) + ) + ) + df + } + + bece_df <- data_frame(burden_estimate_expectation = NA, country = NA) + + for (r in seq_len(nrow(e$bece_csv))) { + row <- e$bece_csv[r, ] + rset <- get_responsibility_sets(row$modelling_group, row$touchstone, e) + + if (row$scenarios == '*') { + expecs <- get_expectations_wildcard(e, row, rset) + } else { + expecs <- get_expectations_scenario(e, row, rset) + } + bece_df <- transform_bece_expec(bece_df, row, expecs) + } + + list(burden_estimate_country_expectation = bece_df) + +} + +test_transform_burden_estimate_country_expectation <- function(t) { + bece <- t$burden_estimate_country_expectation + bece$mash <- paste(bece$burden_estimate_expectation, bece$country, sep = '#') + expect_false(any(duplicated(bece$mash)), + label = "No duplicate burden estimate expectation countries") +} + +############################################################################### + +load_burden_estimate_country_expectation <- function(transformed_data, con) { + to_edit <- add_return_edits("burden_estimate_expectation_country", + transformed_data, con) +} diff --git a/R/extract.R b/R/extract.R index 35c9842b..a2e01f65 100644 --- a/R/extract.R +++ b/R/extract.R @@ -16,6 +16,8 @@ extract <- function(path, con) { extract_scenario_description(path, con), extract_touchstone_demographic_dataset(path, con), extract_touchstone_country(path, con), - extract_burden_estimate_expectation(path, con) + extract_burden_estimate_expectation(path, con), + extract_responsibility(path, con), + extract_burden_estimate_country_expectation(path, con) ) } diff --git a/R/load.R b/R/load.R index fa90e021..374cc3ba 100644 --- a/R/load.R +++ b/R/load.R @@ -25,4 +25,7 @@ load <- function(transformed_data, con, load_touchstone_demographic_dataset(transformed_data, con) load_touchstone_countries(transformed_data, con) + load_burden_estimate_expectation(transformed_data, con) + load_responsibility(transformed_data, con) + load_burden_estimate_country_expectation(transformed_data, con) } diff --git a/R/responsibility.R b/R/responsibility.R new file mode 100644 index 00000000..440c3b19 --- /dev/null +++ b/R/responsibility.R @@ -0,0 +1,240 @@ +############################################################################### + +extract_responsibility <- function(path, con) { + e <- list() + + e[['responsibility_csv']] <- read_meta(path, "responsibility.csv") + + e[['responsibility']] <- DBI::dbGetQuery(con, sprintf(" + SELECT responsibility.id as id, responsibility_set, + responsibility.scenario as scenario, + current_burden_estimate_set, + current_stochastic_burden_estimate_set, + is_open, expectations, touchstone + FROM responsibility + JOIN scenario + ON responsibility.scenario = scenario.id + WHERE scenario.touchstone IN %s", + sql_in(unique(e$responsibility_csv$touchstone)))) + + e[['responsibility_next_id']] <- next_id(con, "responsibility", "id") + + e[['scenario']] <- db_get(con, "scenario", "touchstone", + e$responsibility_csv$touchstone) + + e[['scenario_next_id']] <- next_id(con, "scenario") + + + e[['responsibility_set']] <- db_get(con, "responsibility_set", "touchstone", + e$responsibility_csv$touchstone) + + e[['responsibility_set_next_id']] <- next_id(con, "scenario") + + e + +} + +test_extract_responsibility <- function(e) { + expect_equal(sort(names(e$responsibility_csv)), + c("modelling_group", "scenario", "touchstone")) +} + +############################################################################### + +transform_responsibility <- function(e, t) { + + transform_responsibility_set <- function(e) { + responsibility_set <- data_frame( + modelling_group = e$responsibility_csv$modelling_group, + touchstone = e$responsibility_csv$touchstone) + + responsibility_set$id <- mash_id(responsibility_set, e$responsibility_set, + c("modelling_group", "touchstone")) + responsibility_set$already_exists_db <- !is.na(responsibility_set$id) + responsibility_set$status <- e$responsibility_set$status[ + match(responsibility_set$id, e$responsibility_set$id)] + + responsibility_set$status[is.na(responsibility_set$id)] <- "incomplete" + + fill_in_keys(responsibility_set, e$responsibility_set_next_id) + } + + transform_scenario <- function(e) { + all_scenarios <- strsplit(e$responsibility_csv$scenario, ";") + + scenario <- data_frame( + touchstone = rep(e$responsibility_csv$touchstone, + times = lengths(all_scenarios)), + scenario_description = unlist(all_scenarios)) + + scenario$mash <- paste(scenario$scenario_description, + scenario$touchstone, sep = '#') + scenario <- scenario[!duplicated(scenario$mash), ] + scenario$mash <- NULL + scenario$id <- mash_id(scenario, e$scenario, + c("touchstone", "scenario_description")) + scenario$already_exists_db <- !is.na(scenario$id) + scenario$focal_coverage_set <- e$scenario$focal_coverage_set[ + match(scenario$id, e$scenario$id)] + + fill_in_keys(scenario, e$scenario_next_id) + + } + + transform_responsibility_table <- function(e, t) { + + # Build the responsibility table itself. + # Cols: id, responsiblity_set, scenario (numerical), + # current_burden_stimate_Set, current_stochastic_burden_estimate_set, + # is_open, expectation + + # The CSV provides us with touchstone,modelling_group,scenario (desc) + # (scenario is semi-colon separated. + + modelling_groups <- e$responsibility_csv$modelling_group + touchstones <- e$responsibility_csv$touchstone + all_scenarios <- strsplit(e$responsibility_csv$scenario, ";") + + responsibility <- data_frame( + touchstone = rep(touchstones, times = lengths(all_scenarios)), + modelling_group = rep(modelling_groups, times = lengths(all_scenarios)), + scenario_description = unlist(all_scenarios)) + + # Convert scenario_description into numerical id. + + responsibility$scenario <- mash_id(responsibility, t$scenario, + c("touchstone", "scenario_description")) + + # Responsibility_set was previously calculated, and is modelling_group & + # touchstone specific. + + responsibility$responsibility_set <- + mash_id(responsibility, t$responsibility_set, + c("modelling_group", "touchstone")) + + # Expectations we have to work harder with. The expectations may + # be in t_so_far$burden_estimate_expectation, or they may be + # in the database. + + new_exps <- t$burden_estimate_expectation + new_exps <- new_exps[!new_exps$already_exists_db, ] + new_exps$already_exists_db <- NULL + all_expectations <- rbind(e$burden_estimate_expectation, + new_exps) + + # e$expections_csv contains touchstone, modelling_group and + # scenario cols - scenario might be wild-card (*) for all + # scenarios. + responsibility$expectations <- NA + + for (r in seq_len(nrow(responsibility))) { + resp <- responsibility[r, ] + + matches <- e$expectations_csv[ + e$expectations_csv$modelling_group == resp$modelling_group & + e$expectations_csv$touchstone == resp$touchstone, + ] + + # Single row (either wildcard (*) or multi-scenarios) + + if (nrow(matches) == 1) { + if ((!matches$scenario == "*") && + (!resp$scenario %in% unlist(strsplit(matches$scenario)))) { + stop(sprintf("No expectation for %s, %s, %s", + resp$modelling_group, resp$touchstone, + resp$scenario_description)) + } + + responsibility$expectations[r] <- + all_expectations$id[ + all_expectations$description == matches$description] + + # Multiple rows. Should be one matching row/entry. + + } else { + all_scenarios <- strsplit(matches$scenario, ";") + index <- which(unlist(lapply(all_scenarios, + function(x) resp$scenario_description %in% x))) + + if (length(index) != 1) { + stop(sprintf("Error finding expectation for %s %s %s", + resp$modelling_group, resp$touchstone, + resp$scenario_description)) + } + + responsibility$expectations[r] <- + all_expectations$id[ + all_expectations$description == matches$description[index]] + } + } + + # Fetch matching ids from database, verifying against any + # changes of expectation + + responsibility$id <- mash_id(responsibility, e$responsibility, + c("responsibility_set", "scenario", "expectations")) + + # Fetch matching current_burden_estimate_set from database + + responsibility$current_burden_estimate_set <- + mash_id(responsibility, e$responsibility, "id", + "current_burden_estimate_set") + + # Fetch matching current_stochastic_burden_estimate_set from database + + responsibility$current_stochastic_burden_estimate_set <- + mash_id(responsibility, e$responsibility, "id", + "current_stochastic_burden_estimate_set") + + # Fetch is_open status from database, or assume newly added + # responsiblities are open. + + responsibility$is_open <- + mash_id(responsibility, e$responsibility, "id", "is_open") + responsibility$is_open[is.na(responsibility$id)] <- TRUE + + # Allocate new ids for any NAs. Editing not really possible + # with responsibilities. Perhaps we need to support deletion + # for in-preparation touchstones. + + responsibility$touchstone <- NULL + responsibility$scenario_description <- NULL + responsibility$modelling_group <- NULL + + fill_in_keys(responsibility, e$responsibility_next_id) + + } + + t$responsibility_set <- transform_responsibility_set(e) + t$scenario <- transform_scenario(e) + t[['responsibility']] <- transform_responsibility_table(e, t) + + t +} + +test_transform_responsibility <- function(t) { + expect_false(any(is.na(t$scenario$id))) + expect_false(any(is.na(t$responsibility$id))) + expect_false(any(is.na(t$responsibility_set$id))) +} + +############################################################################### + +load_responsibility <- function(transformed_data, con) { + + load_scenario <- function(transformed_data, con) { + to_edit <- add_return_edits("scenario", transformed_data, con) + } + + load_responsibility_set <- function(transformed_data, con) { + to_edit <- add_return_edits("responsibility_set", transformed_data, con) + } + + load_responsibility_table <- function(transformed_data, con) { + to_edit <- add_return_edits("responsibility", transformed_data, con) + } + + load_scenario(transformed_data, con) + load_responsibility_set(transformed_data, con) + load_responsibility_table(transformed_data, con) +} diff --git a/R/scenario_description.R b/R/scenario_description.R index c045bfdf..09a500a1 100644 --- a/R/scenario_description.R +++ b/R/scenario_description.R @@ -34,14 +34,7 @@ test_transform_scenario_description <- function(transformed_data) { load_scenario_description <- function(transformed_data, con, allow_overwrite_scenario_description = FALSE) { - - sds <- transformed_data[['scenario_description']] - ids_found <- db_get(con, "scenario_description", "id", sds$id, "id")$id - - to_add <- sds[!sds$id %in% ids_found, ] - to_edit <- sds[sds$id %in% ids_found, ] - - DBI::dbWriteTable(con, "scenario_description", to_add, append = TRUE) + to_edit <- add_return_edits("scenario_description", transformed_data, con) # For each row in to_edit, do an SQL update, as long as there is no # non in-preparation touchstone that refers to this scenario description. diff --git a/R/test_extract.R b/R/test_extract.R index 83cf2aa4..351530b5 100644 --- a/R/test_extract.R +++ b/R/test_extract.R @@ -18,5 +18,7 @@ test_extract <- function(extracted_data) { test_extract_touchstone_demographic_dataset(extracted_data) test_extract_touchstone_country(extracted_data) test_extract_burden_estimate_expectation(extracted_data) + test_extract_responsibility(extracted_data) + test_extract_burden_estimate_country_expectation(extracted_data) } diff --git a/R/test_transform.R b/R/test_transform.R index 72ce1fe0..8c084376 100644 --- a/R/test_transform.R +++ b/R/test_transform.R @@ -20,4 +20,6 @@ test_transform <- function(transformed_data) { test_transform_touchstone_demographic_dataset(transformed_data) test_transform_touchstone_country(transformed_data) test_transform_burden_estimate_expectation(transformed_data) + test_transform_responsibility(transformed_data) + test_transform_burden_estimate_country_expectation(transformed_data) } diff --git a/R/touchstone.R b/R/touchstone.R index 5e503ef0..8f7e43e1 100644 --- a/R/touchstone.R +++ b/R/touchstone.R @@ -78,13 +78,7 @@ test_transform_touchstone <- function(transformed_data) { ############################################################################### load_touchstone_name <- function(transformed_data, con) { - tnames <- transformed_data[['touchstone_name']] - ids_found <- db_get(con, "touchstone_name", "id", tnames$id, "id")$id - - to_add <- tnames[!tnames$id %in% ids_found, ] - to_edit <- tnames[tnames$id %in% ids_found, ] - - DBI::dbWriteTable(con, "touchstone_name", to_add, append = TRUE) + to_edit <- add_return_edits("touchstone_name", transformed_data, con) # For each row in to_edit, do an SQL update, as long as all versions # of this touchstone have status "in-preparation". @@ -122,13 +116,7 @@ load_touchstone_name <- function(transformed_data, con) { } load_touchstone <- function(transformed_data, con) { - touchstone <- transformed_data[['touchstone']] - ids_found <- db_get(con, "touchstone", "id", touchstone$id, "id")$id - - to_add <- touchstone[!touchstone$id %in% ids_found, ] - to_edit <- touchstone[touchstone$id %in% ids_found, ] - - DBI::dbWriteTable(con, "touchstone", to_add, append = TRUE) + to_edit <- add_return_edits("touchstone", transformed_data, con) # For each row in to_edit, do an SQL update, as long as the status # is in-preparation. diff --git a/R/touchstone_countries.R b/R/touchstone_countries.R index 1cb9605c..6f4b8f07 100644 --- a/R/touchstone_countries.R +++ b/R/touchstone_countries.R @@ -5,8 +5,12 @@ extract_touchstone_country <- function(path, con) { e$touchstone_countries_csv <- read_meta(path, "touchstone_countries.csv") - all_diseases <- unique(unlist(strsplit(e$touchstone_countries_csv$diseases, ";"))) - all_countries <- unique(unlist(strsplit(e$touchstone_countries_csv$countries, ";"))) + all_diseases <- unique(unlist( + split_semi(e$touchstone_countries_csv$diseases))) + + all_countries <- unique(unlist( + split_semi(e$touchstone_countries_csv$countries))) + all_touchstones <- unique(e$touchstone_countries_csv$touchstone) e$disease <- DBI::dbGetQuery(con, sprintf(" @@ -15,23 +19,29 @@ extract_touchstone_country <- function(path, con) { e$country <- DBI::dbGetQuery(con, sprintf(" SELECT * FROM country WHERE id IN %s", sql_in(all_countries))) - e$touchstone_country <- DBI::dbGetQuery(con, sprintf(" + e[['touchstone_country']] <- DBI::dbGetQuery(con, sprintf(" SELECT * FROM touchstone_country WHERE touchstone IN %s", sql_in(all_touchstones))) - e$touchstone_country_touchstones <- DBI::dbGetQuery(con, sprintf(" + e[['touchstone_country_touchstones']] <- DBI::dbGetQuery(con, sprintf(" SELECT id FROM touchstone WHERE id IN %s", sql_in(all_touchstones))) + e[['touchstone_country_db']] <- DBI::dbGetQuery(con, sprintf(" + SELECT * FROM touchstone_country + WHERE touchstone IN %s", sql_in(all_touchstones))) + + e[['touchstone_country_next_id']] <- next_id(con, "touchstone_country") + e } test_extract_touchstone_country <- function(e) { - expect_true(all(unique(unlist(strsplit(e$touchstone_countries_csv$countries, ";"))) - %in% e$country$id), + expect_true(all(unique(unlist( + split_semi(e$touchstone_countries_csv$countries))) %in% e$country$id), label = "All countries in touchstone_country are recognised") - expect_true(all(unique(unlist(strsplit(e$touchstone_countries_csv$diseases, ";"))) - %in% e$disease$id), + expect_true(all(unique(unlist( + split_semi(e$touchstone_countries_csv$diseases))) %in% e$disease$id), label = "All diseases in touchstone_country are recognised") all_touchstones <- unique(c(e$touchstone_country_touchstones$id, @@ -48,30 +58,28 @@ transform_touchstone_country <- function(e) { # CSV Format: touchstone,disease1;disease2,country1;country2;country3 - disease <- strsplit(e$touchstone_countries_csv$diseases, ";") + disease <- split_semi(e$touchstone_countries_csv$diseases) if (any(lengths(disease) < 1)) { stop("Empty disease column in touchstone_country") } - countries <- rep(strsplit(e$touchstone_countries_csv$countries, ";"), + countries <- rep(split_semi(e$touchstone_countries_csv$countries), lengths(disease)) touchstone <- lapply(1:length(disease), function(x) - rep(e$touchstone_countries_csv$touchstone[x], length(disease[[x]]))) + rep(e$touchstone_countries_csv$touchstone[x], + length(disease[[x]]))) touchstone_country <- data_frame( touchstone = rep(unlist(touchstone), lengths(countries)), disease = rep(unlist(disease), lengths(countries)), country = unlist(countries)) - touchstone_country_db <- DBI::dbGetQuery(con, sprintf(" - SELECT * FROM touchstone_country - WHERE touchstone IN %s", sql_in(unique(touchstone_country$touchstone)))) - - touchstone_country_db$mash <- paste(touchstone_country_db$touchstone, - touchstone_country_db$disease, - touchstone_country_db$country, sep = '#') + e$touchstone_country_db$mash <- paste(e$touchstone_country_db$touchstone, + e$touchstone_country_db$disease, + e$touchstone_country_db$country, + sep = '#') touchstone_country$mash <- paste(touchstone_country$touchstone, touchstone_country$disease, @@ -81,18 +89,14 @@ transform_touchstone_country <- function(e) { stop("Duplicated entries in touchstone_country.csv") } - touchstone_country$id <- touchstone_country_db$id[match( - touchstone_country$mash, touchstone_country_db$mash)] + touchstone_country$id <- e$touchstone_country_db$id[match( + touchstone_country$mash, e$touchstone_country_db$mash)] touchstone_country$mash <- NULL touchstone_country$already_exists_db <- !is.na(touchstone_country$id) - if (any(is.na(touchstone_country$id))) { - which_nas <- which(is.na(touchstone_country$id)) - nid <- next_id(con, "touchstone_country", "id") - touchstone_country$id[which_nas] <- seq(from = nid, by = 1, - length.out = length(which_nas)) - } + touchstone_country <- fill_in_keys(touchstone_country, + e$touchstone_country_next_id) list(touchstone_country = touchstone_country) } diff --git a/R/touchstone_demographic_dataset.R b/R/touchstone_demographic_dataset.R index 8ef26310..58bc9a1e 100644 --- a/R/touchstone_demographic_dataset.R +++ b/R/touchstone_demographic_dataset.R @@ -174,15 +174,8 @@ test_transform_touchstone_demographic_dataset <- function(transformed_data) { ############################################################################### load_touchstone_demographic_dataset <- function(transformed_data, con) { - - tdd <- transformed_data[['touchstone_demographic_dataset']] - ids_found <- db_get(con, "touchstone_demographic_dataset", "id", tdd$id, "id")$id - - to_add <- tdd[!tdd$id %in% ids_found, ] - to_edit <- tdd[tdd$id %in% ids_found, ] - - if (nrow(to_add) > 0) - DBI::dbWriteTable(con, "touchstone_demographic_dataset", to_add, append = TRUE) + to_edit <- add_return_edits("touchstone_demographic_dataset", + transformed_data, con) # For each row in to_edit, do an SQL update, as long as the touchstone # being referred to is in the in-preparation state. diff --git a/R/transform.R b/R/transform.R index 7dbb58f9..ea2abf5e 100644 --- a/R/transform.R +++ b/R/transform.R @@ -19,13 +19,17 @@ transform <- function(extracted_data) { ) t <- c(t, transform_burden_estimate_expectation(extracted_data, t)) + t <- c(t, transform_responsibility(extracted_data, t)) + t <- c(t, transform_burden_estimate_country_expectation(extracted_data, t)) # Remove all rows that shouldn't be added/edited. (ie, database # already contains identical rows). for (table in names(t)) { - t[[table]] <- t[[table]][!t[[table]]$already_exists_db, ] - t[[table]]$already_exists_db <- NULL + if ("already_exists_db" %in% names(t[[table]])) { + t[[table]] <- t[[table]][!t[[table]]$already_exists_db, ] + t[[table]]$already_exists_db <- NULL + } } t diff --git a/R/utils.R b/R/utils.R index 97774fe4..2775d86e 100644 --- a/R/utils.R +++ b/R/utils.R @@ -11,6 +11,10 @@ data_frame <- function(...) { data.frame(stringsAsFactors = FALSE, ...) } +split_semi <- function(string) { + strsplit(string, ";") +} + sql_in_char <- function(strings) { paste0("('", paste(strings, collapse = "','"), "')") } @@ -33,7 +37,7 @@ db_get <- function(con, table, id_field = NULL, id_values = NULL, select = "*") DBI::dbGetQuery(con, sql) } -next_id <- function(con, table, id_field) { +next_id <- function(con, table, id_field = "id") { 1L + as.numeric(DBI::dbGetQuery(con, sprintf("SELECT max(%s) FROM %s", id_field, table))) } @@ -102,32 +106,17 @@ copy_unique_flag <- function(extracted_data, tab) { t } -# For each row in csv_table, does it exist in db_table? -# If so, set id_field in csv_table to the matching id in db_table. -# If not, assign new key for that row. - -fill_in_keys <- function(csv_table, db_table, id_field, next_id) { - - db_table$mash <- mash(db_table[, names(db_table) != id_field]) - csv_table$mash <- mash(csv_table) - - # Copy existing keys - - csv_table[[id_field]] <- db_table[[id_field]][match(csv_table$mash, db_table$mash)] - - csv_table <- csv_table[, names(csv_table) != 'mash'] - - csv_table$already_in_db <- !is.na(csv_table$id) - - # For any NAs, assign new keys, starting at next_id - - which_nas <- which(is.na(csv_table[[id_field]])) +# For each row in csv_table, if id_field is NA, then set it to +# next available key. - csv_table[[id_field]][which_nas] <- seq(from = next_id, by = 1, - length.out = length(which_nas)) +fill_in_keys <- function(table, next_id, id_field = "id") { - csv_table + which_nas <- which(is.na(table[[id_field]])) + table[[id_field]][which_nas] <- seq( + from = next_id, + by = 1, length.out = length(which_nas)) + table } # Add any rows in transformed_data[[table_name]] to the data where the id diff --git a/vignettes/stoner.Rmd b/vignettes/stoner.Rmd index f4c75d9f..77f230b5 100644 --- a/vignettes/stoner.Rmd +++ b/vignettes/stoner.Rmd @@ -21,7 +21,7 @@ knitr::opts_chunk$set( links together the coverage, demography, responsibilities and outputs for a particularly set of runs that VIMC modellers are asked to perform. Once a touchstone is opened, it is designed to be fixed, so having downloaded input data from a particular touchstone, if a modelling group chooses to download the input data again, they will always get the same result. This ensures reproducibility, -but as a side effect, it means that if there is even a minor error that we discover in a touchstone, we will open a new version +but as a side effect, it means that if there is even a minor error that we discover in a touchstone, we will open a new version of that touchstone, so that any results made using the erroneous touchstone are still well audited and reproducible. This comes at a cost of creating new touchstones, or new versions quite often, including a significant period of development @@ -30,13 +30,13 @@ perform CSV reading and SQL updates has often been tangled. [dettl](https://gith separation of such imports into cleanly bounded extract, transform and load stages, with unit testing of each stage; this is our state of the art we use for the [montagu-imports](https://github.com/vimc/montagu-imports) repository. This clarifies things greatly, but at times, at the cost of brevity, where writing a single SQL query in the three stages with tests can -feel somewhat strenuous, compared to the simplicity of the actual task. +feel somewhat strenuous, compared to the simplicity of the actual task. `stoner` is in principle very similar to a [dettl](https://github.com/vimc/dettl) import; it has extract, transform and load -phases, and tests on the extract and load phases. But it is specifically designed for a particular set of tasks, and relying -on specific metadata, in order to do the specific tasks of incrementally building a touchstone. The aim is that the montagu-import -for creating a new touchstone (or making edits to a touchstone that is in preparation), will consist of single-line functions for -extract, transform and load, which stoner will take care of. The tests in the import will consist of a single-line call to stoner's +phases, and tests on the extract and load phases. But it is specifically designed for a particular set of tasks, and relying +on specific metadata, in order to do the specific tasks of incrementally building a touchstone. The aim is that the montagu-import +for creating a new touchstone (or making edits to a touchstone that is in preparation), will consist of single-line functions for +extract, transform and load, which stoner will take care of. The tests in the import will consist of a single-line call to stoner's tests, followed by tests that are specific to the metadata in the import. The review of a montagu-import that uses stoner, will therefore be a case of looking at the metadata, and the tests that are @@ -49,8 +49,8 @@ specific to the metadata, and all of the reproducible work will be separately re ### extract The extract phase is called as `stoner::extract(path, con)`; the arguments are the path to the particular montagu-import, and a -database connection. Within `path`, stoner expects a folder called `meta` to exist, containing the metadata for the import. -Various CSV files are expected to be read from there, as part of the extraction. and stoner will then query the database to +database connection. Within `path`, stoner expects a folder called `meta` to exist, containing the metadata for the import. +Various CSV files are expected to be read from there, as part of the extraction. and stoner will then query the database to find table data, in order to distinguish between existing rows (perhaps to be edited) and new rows to be added. #### touchstone and touchstone_name @@ -77,7 +77,7 @@ find table data, in order to distinguish between existing rows (perhaps to be ed ### test-extract -Tests are carried out for each part of the touchstone, as follows. All items +Tests are carried out for each part of the touchstone, as follows. All items referred to will be in the `extracted_data` list, unless otherwise specified. #### touchstone and touchstone_name @@ -107,8 +107,8 @@ referred to will be in the `extracted_data` list, unless otherwise specified. The transform stage involves processing the `extracted_data` and returning a list of data.frames that are have the right names, and correct columns to be appended to tables in the Montagu database. -During the transform, some tables will have an extra column `already_exists_db` added, to indicate -that the entire row matches exactly with one in the database. At the end of the transform, any rows +During the transform, some tables will have an extra column `already_exists_db` added, to indicate +that the entire row matches exactly with one in the database. At the end of the transform, any rows that have this column set will be dropped if the rows are exactly the same as the database content, or kept for potential editing, which we'll discuss in the load section. @@ -126,7 +126,7 @@ new, or have matching ids but differ in some other column to the database: #### touchstone_demographic_dataset - * Flag any entries in `touchstone_demographic_dataset_csv` that have an exact match of + * Flag any entries in `touchstone_demographic_dataset_csv` that have an exact match of (touchstone, demographic_dataset) in the database; these will be removed after the end of the transform stage. * Lookup existing `id` from the `touchstone_demographic_dataset` database table, for any @@ -147,7 +147,7 @@ and it will perform the following standard tests on all transformed data - if th does not require them all to exist. #### touchstone and touchstone_name - + * Test that in `touchstone`, `id` is in the format `touchstone_name`-`version` * Test that all touchstones have valid status. (open, in-preparation, finished) @@ -163,19 +163,19 @@ All the useful tests are already done in the test_extract stage. ### load The montagu-import using stoner msut use a custom load, not an automatic one, since the first line of the -load should be `stoner::load(transformed_data, con)`. +load should be `stoner::load(transformed_data, con)`. #### touchstone_name - - * `touchstone_name` is uploaded first, since `touchstone` may refer to it. + + * `touchstone_name` is uploaded first, since `touchstone` may refer to it. * Rows with new ids are trivially appended. - * Rows with the same id but differing other columns will be edited in-place, provided that + * Rows with the same id but differing other columns will be edited in-place, provided that if any touchstone refers to the touchstone_name id, that touchstone must have status `in-preparation`. #### touchstone * Rows with new ids are trivially appended. - * Rows with the same id but differing other columns will be edited in-place, provided that + * Rows with the same id but differing other columns will be edited in-place, provided that the status of that touchstone is `in-preparation`. #### scenario_description @@ -210,6 +210,6 @@ for both future and historic touchstones. Usually, this would not be permitted, but since this is purely for the purpose of readability and clarity, and because it causes no data changes, the default behaviour of forbidding such changes on open or finished -touchstones can be relaxed by using this longer form of `stoner::load` :- +touchstones can be relaxed by using this longer form of `stoner::load` :- `stoner::load(transformed_data, con, allow_overwrite_scenario_description = TRUE)`