Fix #84 change geo codes manually

NEWS.md

@@ -1,8 +1,9 @@
 # norgeo 2.4.2 (dev)
 - Get future data from API. Thank to @raniets for the request and proposed solution (#83)
 - Fix error on the date in `date_future()`
-- Alter geo codes manually when necessary (#84). This is based on the added
-  files in [config](https://github.com/helseprofil/config/tree/main/geo)
+- Fix geo codes manually when necessary (#84). This is done by sourcing
+  [geo-fix.R](https://github.com/helseprofil/config/tree/main/geo/geo-fix.R)
+  file. Use argument `fix = FALSE` to deactivate executing `geo-fix.R` file. 
 
 # norgeo 2.3.1
 - Replace `httr` package with `httr2` package.

R/track-change.R

@@ -6,6 +6,8 @@
 #' be used.
 #'
 #' @inheritParams get_code
+#' @param fix Default is TRUE. Use external codes to fix geo changes manually.
+#'   The codes is source from \href{https://github.com/helseprofil/config/blob/main/geo/geo-fix.R}{geo-fix.R} file.
 #' @return A dataset of class `data.table` consisting all older codes from
 #'   previous years until the selected year in `to` argument and what these
 #'   older codes were changed into. If the codes have not changed then the value
@@ -28,7 +30,8 @@ track_change <- function(type = c(
                          ),
                          from = NULL,
                          to = NULL,
-                         names = TRUE) {
+                         names = TRUE,
+                         fix = TRUE) {
   type <- match.arg(type)
   type <- grunnkrets_check(type, to)
 
@@ -51,15 +54,17 @@ track_change <- function(type = c(
   data.table::setkey(dataApi$dt, newCode, changeOccurred)
   ## When nothing changes
   dataApi$dt[oldCode == newCode, oldCode := NA]
-
   data.table::setnames(dataApi$dt, "newCode", "currentCode")
-
   DT <- data.table::copy(dataApi$dt[])
-  DT <- alter_manual(DT, to)
 
   if (!names)
     DT[, (granularityNames) := NULL]
 
+  if (!fix)
+    return(DT)
+
+  DT <- alter_manual(DT)
+
   return(DT)
 }
 
@@ -154,20 +159,14 @@ grunnkrets_check <- function(type, to = NULL){
 }
 
 ## Maually alter dataset especially when there are splitting codes ie. issue 84
-## Codes should be in config repo
-## Delete using is_delete_index() by finding row index in the dataset
-alter_manual <- function(DT, year){
+## Codes should be in config repo file
+alter_manual <- function(DT){
 
-  baseURL <- "https://raw.githubusercontent.com/helseprofil/config/main/geo/"
-  fileName <- paste0("geo-", year, ".R")
-  http <-paste0(baseURL, fileName)
+  http <- "https://raw.githubusercontent.com/helseprofil/config/main/geo/geo-fix.R"
 
   if (check_url(http)){
+    message("Run source file ", http)
     source(http, local = TRUE)
-    DT <- is_delete_index(DT, IDX)
-    IDV <- is_long_vector(IDX)
-    message("Deleted row(s):", IDV)
-    message("Source from ", http)
   }
 
   return(DT)
@@ -179,29 +178,3 @@ check_url <- function(http){
   suppressWarnings(try(close.connection(con),silent=TRUE))
   ifelse(is.null(check),TRUE,FALSE)
 }
-
-## Ref https://github.com/Rdatatable/data.table/issues/635#issuecomment-261473829
-is_delete_index <- function(dt, delidx){
-  # delidx - Row index to be deleted
-  keepIdx <- setdiff(dt[, .I], delidx)
-  cols = names(dt)
-  dtSub <- data.table::data.table(dt[[1]][keepIdx]) #subsetted table
-  data.table::setnames(dtSub, cols[1])
-
-  for (col in cols[2:length(cols)]){
-    dtSub[, (col) := dt[[col]][keepIdx]]
-    dt[, (col) := NULL]
-  }
-
-  return(dtSub)
-}
-
-## For paste of long vectors ie. many columnames,
-## to be nicely displayed in a message
-is_long_vector <- function(vec){
-  if (length(vec) > 1){
-    vec <- paste0('"', paste(vec, collapse = '", "'), '"')
-  }
-  return(vec)
-}
-

R/track-merge.R

@@ -17,7 +17,7 @@ from = NULL,
 to = NULL,
 names = TRUE) {
   type <- match.arg(type)
-  dt <- track_change(type, from, to)
+  dt <- track_change(type, from, to, fix = FALSE)
   data.table::setkey(dt, currentCode, changeOccurred)
   dt[!is.na(currentCode), merge := .N, by = data.table::rleid(changeOccurred, currentCode)]
   out <- dt[merge > 1]

R/track-split.R

@@ -17,7 +17,7 @@ track_split <- function(type = c(
                         to = NULL,
                         names = TRUE) {
   type <- match.arg(type)
-  dt <- track_change(type, from, to)
+  dt <- track_change(type, from, to, fix = FALSE)
   data.table::setkey(dt, oldCode, changeOccurred)
   dt[!is.na(oldCode), split := .N, by = data.table::rleid(changeOccurred, oldCode)]
   out <- dt[split > 1]

docs/pkgdown.yml

@@ -3,7 +3,7 @@ pkgdown: 2.0.7
 pkgdown_sha: ~
 articles:
   use-api: use-api.html
-last_built: 2023-09-07T14:51Z
+last_built: 2023-10-11T11:49Z
 urls:
   reference: https://helseprofil.github.io/norgeo/reference
   article: https://helseprofil.github.io/norgeo/articles

tests/testthat/test-alter-geo.R

@@ -1,8 +1,8 @@
 test_that("Alter geo manually", {
 
-  altOut <- readRDS(system.file("test-data", "alter-manual.rds", package = "norgeo"))
-  expect_equal(alter_manual(data.table::copy(chgDT), 9999), altOut)
-  expect_equal(is_delete_index(data.table::copy(chgDT), c(6, 7)), altOut)
+  ## altOut <- readRDS(system.file("test-data", "alter-manual.rds", package = "norgeo"))
+  ## expect_equal(alter_manual(data.table::copy(chgDT), 9999), altOut)
+  ## expect_equal(is_delete_index(data.table::copy(chgDT), c(6, 7)), altOut)
   expect_false(check_url("https://www.nothing.bla.bla"))
   expect_true(check_url("https://www.ap.no"))
 })

tests/testthat/test-track-change.R

@@ -2,8 +2,8 @@ test_that("Track change", {
   dtOut <- readRDS(system.file("test-data", "trackChangeFylke_2017_2018.rds", package = "norgeo"))
   dtKomm <- readRDS(system.file("test-data", "trackChangeKomm_2010_2015.rds", package = "norgeo"))
 
-  expect_equal(track_change("fylke", 2017, 2018, names = F), dtOut)
-  expect_equal(track_change("kommune", 2010, 2015, names = F), dtKomm)
+  expect_equal(track_change("fylke", 2017, 2018, names = F, fix = FALSE), dtOut)
+  expect_equal(track_change("kommune", 2010, 2015, names = F, fix = FALSE), dtKomm)
 })
 
 test_that("Track split", {