diff --git a/DESCRIPTION b/DESCRIPTION index 6f342f9..aaf7b59 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,7 +1,7 @@ Package: NVIdb Title: Tools to facilitate the use of NVI's databases -Version: 0.8.0 -Date: 2022-10-25 +Version: 0.9.0 +Date: 2023-01-16 Authors@R: c(person(given = "Petter", family = "Hopp", @@ -32,16 +32,18 @@ Imports: utils, checkmate, data.table, + DBI, dplyr, getPass, keyring, knitr, magrittr, - poorman (>= 0.2.3), + odbc, remotes, rlang, rmarkdown, RODBC, + RPostgreSQL, R.rsp, shiny, snakecase, @@ -63,7 +65,7 @@ LazyData: true Encoding: UTF-8 Language: en-GB Roxygen: list(markdown = FALSE) -RoxygenNote: 7.1.2 +RoxygenNote: 7.2.3 VignetteBuilder: knitr, R.rsp diff --git a/NAMESPACE b/NAMESPACE index abe101e..42112e4 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -23,6 +23,7 @@ export(copy_Prodtilskudd) export(copy_kommune_fylke) export(copy_poststed) export(copy_prodnr_2_current_prodnr) +export(cut_slash) export(exclude_from_PJSdata) export(get_PAT) export(login) @@ -38,12 +39,14 @@ export(read_MT_omrader) export(read_PJS_codes_2_text) export(read_Pkode_2_text) export(read_Prodtilskudd) +export(read_eos_data) export(read_kommune_fylke) export(read_leveransereg) export(read_poststed) export(read_prodnr_2_coordinates) export(read_prodnr_2_current_prodnr) export(read_sonetilhorighet) +export(read_varekode) export(remove_PAT) export(remove_credentials) export(set_PAT) diff --git a/NEWS b/NEWS index 1c7cac4..95e4dfa 100644 --- a/NEWS +++ b/NEWS @@ -1,32 +1,56 @@ +NVIdb 0.9.0 - (2023-01-16) +---------------------------------------- + +New features: + +- Created `read_eos_data` for reading one or more years from EOS data for one surveillance programme from exported csv-files. + +- Created `read_varekode` for reading the formatted varekoderegister or the raw data to update the formatted varekoderegister. + +- `login`, `login_by_credentials` and `login_by_input` now accept the argument `dbinterface` with the R-package names "RODBC", "odbc" or, "RPostgreSQL" as input. + +- Created `cut_slash` to remove ending slash from path. This is useful if pathnames should be created using `base::file.path`. + + +Bug fixes: + +- Fixed `add_PJS_code_description` when argument `backwards` = "TRUE" for R > 4.2. + + +Other changes: + +- Corrected argument checking of `pkode_year` in `read_Prodtilskudd` and `copy_Prodtilskudd`. + + NVIdb 0.8.0 - (2022-10-25) -------------------------- New features: -- build_query_outbreak builds a query for retrieving outbreak data from PJS. Potential inputs are period, hensiktkode, utbrudd_id, analyttkode and metodekode. +- `build_query_outbreak` builds a query for retrieving outbreak data from PJS. Potential inputs arguments are `period`, `hensiktkode`, `utbrudd_id`, `analyttkode` and `metodekode`. -- set_disease_selection_parameters creates a list object with selection parameters from input arguments or by sourcing an R script that sets the input values (a "purpose" file). +- `set_disease_selection_parameters` creates a list object with selection parameters from input arguments or by sourcing an R script that sets the input values (a "purpose" file). -- read_Pkode_2_text now reads translation table for Pkoder from 1995 to current year as default. Column names are changed in accord with standard conventions. Use keep_old_names = TRUE to keep old names. +- `read_Pkode_2_text` now reads translation table for Pkoder from 1995 to current year as default. Column names are changed in accord with standard conventions. Use `keep_old_names` = "TRUE" to keep old names. -- add_PJS_code_description can now perform backward translation from PJS description text to PJS-code. Use 'backward = TRUE'. Backward translation only works when the description text is unique per code. Case is ignored for backward translation. +- `add_PJS_code_description` can now perform backward translation from PJS description text to PJS-code. Use `backward` = "TRUE". Backward translation only works when the description text is unique per code. Case is ignored for backward translation. -- add_PJS_code_description, choose_PJS_levels, and standardize_PJS_data now handles the levels subundersokelse and subresultat. +- `add_PJS_code_description`, `choose_PJS_levels`, and `standardize_PJS_data` now handles the levels subundersokelse and subresultat. -- set_dir_NVI now accepts abbreviated input for datasource. The abbreviation must be unique. +- `set_dir_NVI` now accepts abbreviated input for `datasource`. The abbreviation must be unique. -- add-functions (add_kommune_fylke, add_MT_omrader, add_PJS_code_description, add_poststed and add_produsent_properties) now accepts abbreviated input for position. The abbreviation must be unique. +- add-functions (`add_kommune_fylke`, `add_MT_omrader`, `add_PJS_code_description`, `add_poststed` and `add_produsent_properties`) now accepts abbreviated input for `position`. The abbreviation must be unique. Bug fixes: -- add_produsent_properties replaces add_produsent. add_produsent_properties now correctly adds geo-coordinates also when information on geo-coordinates is missing. +- `add_produsent_properties` replaces `add_produsent`. `add_produsent_properties` now correctly adds geo-coordinates also when information on geo-coordinates is missing. -- copy-functions (copy_kommune_fylke, copy_MT_omrader, copy_PJS_code_2_text, copy_Pkode_2_text, copy_poststed, copy_prodnr_2_current_prodnr, and copy_Prodtilskudd), now accepts "from_path" and "to_path" that ends with "\\". +- copy-functions (`copy_kommune_fylke`, `copy_MT_omrader`, `copy_PJS_code_2_text`, `copy_Pkode_2_text`, `copy_poststed`, `copy_prodnr_2_current_prodnr`, and `copy_Prodtilskudd`), now accepts `from_path` and `to_path` that ends with "\\". -- read-functions (read_kommune_fylke, read_leveransereg, read_MT_omrader, read_PJS_code_2_text, read_Pkode_2_text, read_poststed, read_prodnr_2_coordinates, read_prodnr_2_current_prodnr, read_Prodtilskudd, and read_sonetilhorighet), now accepts "from_path" that ends with "\\". +- read-functions (`read_kommune_fylke`, `read_leveransereg`, `read_MT_omrader`, `read_PJS_code_2_text`, `read_Pkode_2_text`, `read_poststed`, `read_prodnr_2_coordinates`, `read_prodnr_2_current_prodnr`, `read_Prodtilskudd`, and `read_sonetilhorighet`), now accepts `from_path` that ends with "\\". -- exclude_from_PJSdata now returns correct data frame if quality = "include". +- `exclude_from_PJSdata` now returns correct data frame if `quality` = "include". Other changes: @@ -44,9 +68,9 @@ Other changes: BREAKING CHANGES: -- add_produsent is deprecated, use add_produsent_properties instead. See NVIdb-deprecated (help("NVIdb-deprecated")). +- `add_produsent` is deprecated, use `add_produsent_properties` instead. See NVIdb-deprecated (help("NVIdb-deprecated")). -- Default translation table read by read_Pkode_2_text has new default column names. Use keep_old_names = TRUE to keep old names. +- Default translation table read by `read_Pkode_2_text` has new default column names. Use `keep_old_names` = "TRUE" to keep old names. NVIdb 0.7.1 - (2022-08-24) @@ -54,7 +78,7 @@ NVIdb 0.7.1 - (2022-08-24) Bug fixes: -- fixed problem with installation when build_vignette = TRUE. +- fixed problem with installation when `build_vignette` = "TRUE". NVIdb 0.7.0 - (2022-03-14) diff --git a/R/add_PJS_code_description.R b/R/add_PJS_code_description.R index 74c600e..014d176 100644 --- a/R/add_PJS_code_description.R +++ b/R/add_PJS_code_description.R @@ -272,7 +272,7 @@ add_PJS_code_description <- function(data, # Transforms code_colname in data to lower case. data$code_colname_org_case <- data[, code_colname[i]] - data[, code_colname[i]] <- tolower(data[, code_colname[i]]) + data[, code_colname[i]] <- sapply(data[, code_colname[i]], FUN = tolower) } # code_2_description <- translation_table[base::which(translation_table$type == PJS_variable_type[i] & is.na(translation_table$utgatt_dato)), ] diff --git a/R/copy_Prodtilskudd.R b/R/copy_Prodtilskudd.R index 3ca9e5f..6eddf27 100644 --- a/R/copy_Prodtilskudd.R +++ b/R/copy_Prodtilskudd.R @@ -25,12 +25,12 @@ copy_Prodtilskudd <- function(from_path = paste0(set_dir_NVI("Prodtilskudd"), "F checkmate::assert_directory_exists(to_path, access = "r", add = checks) } checkmate::assert_subset(Pkode_month, choices = c("both", "last", "01", "03", "05", "07", "10", "12"), add = checks) - NVIcheckmate::assert(checkmate::check_integerish(as.numeric(Pkode_year[which(!grepl('[:alpha:]', Pkode_year))]), + checkmate::assert(checkmate::check_integerish(as.numeric(Pkode_year[grep('[[:alpha:]]', Pkode_year, invert = TRUE)]), lower = 1995, upper = as.numeric(format(Sys.Date(), "%Y")), any.missing = FALSE, + all.missing = FALSE, unique = TRUE), - # checkmate::check_character(Pkode_year, min.chars = 4, min.len = 1, any.missing = FALSE), checkmate::check_choice(Pkode_year, choices = c("last")), add = checks) diff --git a/R/login.R b/R/login.R index de2bb6d..b2de649 100644 --- a/R/login.R +++ b/R/login.R @@ -49,7 +49,10 @@ #' \code{\link{set_credentials_EOS}}, no input is needed. #' #' The login functions returns an open ODBC-channel to the database service. -#' The database can then be queried by using functions in the package \code{RODBC}. +#' The database can then be queried by using functions in the package used for +#' data base interface. The data base interface must be one of \code{odbc}, +#' \code{RODBC} or, \code{RPostgreSQL}. The default is given in NVIconfig and is +#' \code{RODBC} for "SQL server" and \code{RPostgreSQL} for "PostgreSQL". #' #' When the session is finished, the script shall close the ODBC-channel by #' \code{odbcClose("myodbcchannel")} or \code{odbcCloseAll}. @@ -62,6 +65,8 @@ #' @param dbserver Name of database server. #' @param dbport Port. #' @param dbprotocol Protocol to be used. +#' @param dbinterface The R-package that is used for interface towards the data +#' base. #' @param dbtext used in login with input. Gives the possibility of showing #' another name than the dbservice in the windows asking for username and #' password. @@ -75,7 +80,7 @@ #' require(RODBC) #' journal_rapp <- login_PJS() #' # Reads hensiktregistret from PJS -#' hensikter <- sqlQuery(journal_rapp, +#' hensikter <- sqlQuery(journal_rapp, #' "select * from v_hensikt", #' as.is = TRUE, #' stringsAsFactors = FALSE) @@ -88,7 +93,8 @@ login <- function(dbservice, db = NULL, dbserver = NULL, dbport = NULL, - dbprotocol = NULL) { + dbprotocol = NULL, + dbinterface = NULL) { # ARGUMENT CHECKING ---- # Object to store check-results @@ -100,7 +106,7 @@ login <- function(dbservice, # Identifies if predefined connection parameters are needed - if (is.null(dbdriver) | is.null(db) | is.null(dbserver) | is.null(dbport) | is.null(dbprotocol)) { + if (is.null(dbdriver) | is.null(db) | is.null(dbserver) | is.null(dbport) | is.null(dbprotocol) | is.null(dbinterface)) { # Identify if NVIconfig are installed and parameters for dbservice exists. NVIcheckmate::assert_package(x = "NVIconfig", comment = paste0("Parameters for logging into the database '", @@ -122,6 +128,7 @@ login <- function(dbservice, if (is.null(dbserver)) {dbserver <- connect[, "dbserver"]} if (is.null(dbport)) {dbport <- connect[, "dbport"]} if (is.null(dbprotocol)) {dbprotocol <- connect[, "dbprotocol"]} + if (is.null(dbinterface)) {dbinterface <- connect[, "dbinterface"]} } } @@ -135,6 +142,8 @@ login <- function(dbservice, checkmate::assert_character(dbport, len = 1, any.missing = FALSE, add = checks) # dbprotocol checkmate::assert_character(dbprotocol, min.chars = 1, len = 1, any.missing = FALSE, add = checks) + # dbinterface + checkmate::assert_choice(dbinterface, choices = c("odbc", "RODBC", "RPostgreSQL"), add = checks) # Report check-results checkmate::reportAssertions(checks) @@ -186,7 +195,8 @@ login <- function(dbservice, db, dbserver, dbport, - dbprotocol) + dbprotocol, + dbinterface) } else { # If credentials are missing from the user profile login_by_input(dbservice, @@ -204,32 +214,28 @@ login <- function(dbservice, #' @export #' @rdname login -login_PJS <- function() { +login_PJS <- function(dbinterface = NULL) { + # ARGUMENT CHECKING ---- + # Object to store check-results + checks <- checkmate::makeAssertCollection() + + # dbinterface + checkmate::assert_choice(dbinterface, choices = c("odbc", "RPostgreSQL", "RODBC"), null.ok = TRUE, add = checks) + + # Report check-results + checkmate::reportAssertions(checks) + # Set service to PJS dbservice <- "PJS" - # # Check if credentials for PJS is stored in the user profile - # # 1. keyring package is missing - # # Use of require is avoided as loading packages should be avoided in package functions - # # This implies that there is no check if keyring is correctly installed - # if (!is.element("keyring", utils::installed.packages()[, 1])) { - # login_by_input(dbservice) - # } else { - # if (!is.element(tolower(dbservice), tolower(keyring::key_list()[, 1]))) { - # # 2. Credentials for PJS are missing from the user profile - # login_by_input(dbservice) - # } else { - # login_by_credentials(dbservice) - # } - # } # Use check for saved credentials to chose between login_by_input and login_by_credentials if (isTRUE(NVIcheckmate::check_credentials(dbservice))) { # If credentials are saved for the user profile - login_by_credentials(dbservice) + login_by_credentials(dbservice, dbinterface = dbinterface) } else { # If credentials are missing from the user profile - login_by_input(dbservice) + login_by_input(dbservice, dbinterface = dbinterface) } } @@ -237,31 +243,27 @@ login_PJS <- function() { #' @export #' @rdname login -login_EOS <- function() { +login_EOS <- function(dbinterface = NULL) { + # ARGUMENT CHECKING ---- + # Object to store check-results + checks <- checkmate::makeAssertCollection() + + # dbinterface + checkmate::assert_choice(dbinterface, choices = c("odbc", "RPostgreSQL", "RODBC"), null.ok = TRUE, add = checks) + + # Report check-results + checkmate::reportAssertions(checks) + # Set service to EOS dbservice <- "EOS" - # # Check if credentials for EOS is stored in the user profile - # # 1. keyring package is missing - # # Use of require is avoided as loading packages should be avoided in package functions - # # This implies that there is no check if keyring is correctly installed - # if (!is.element("keyring", utils::installed.packages()[, 1])) { - # login_by_input(dbservice) - # } else { - # if (!is.element(tolower(dbservice), tolower(keyring::key_list()[, 1]))) { - # # 2. Credentials for PJS are missing from the user profile - # login_by_input(dbservice) - # } else { - # login_by_credentials(dbservice) - # } - # } # Use check for saved credentials to chose between login_by_input and login_by_credentials if (isTRUE(NVIcheckmate::check_credentials(dbservice))) { # If credentials are saved for the user profile - login_by_credentials(dbservice) + login_by_credentials(dbservice, dbinterface = dbinterface) } else { # If credentials are missing from the user profile - login_by_input(dbservice) + login_by_input(dbservice, dbinterface = dbinterface) } } diff --git a/R/login_by_credentials.R b/R/login_by_credentials.R index eaa3afd..143d54f 100644 --- a/R/login_by_credentials.R +++ b/R/login_by_credentials.R @@ -6,7 +6,8 @@ login_by_credentials <- function(dbservice, db = NULL, dbserver = NULL, dbport = NULL, - dbprotocol = NULL) { + dbprotocol = NULL, + dbinterface = NULL) { # ARGUMENT CHECKING ---- # Object to store check-results @@ -18,7 +19,7 @@ login_by_credentials <- function(dbservice, # Identifies if predefined connection parameters are needed - if (is.null(dbdriver) | is.null(db) | is.null(dbserver) | is.null(dbport) | is.null(dbprotocol)) { + if (is.null(dbdriver) | is.null(db) | is.null(dbserver) | is.null(dbport) | is.null(dbprotocol) | is.null(dbinterface)) { # Identify if NVIconfig are installed and parameters for dbservice exists. NVIcheckmate::assert_package(x = "NVIconfig", comment = paste0("Parameters for logging into the database '", @@ -27,7 +28,9 @@ login_by_credentials <- function(dbservice, add = checks) if (isTRUE(NVIcheckmate::check_package(x = "NVIconfig"))) { - NVIcheckmate::assert_choice_character(x = dbservice, choices = NVIconfig:::dbconnect$dbservice, ignore.case = TRUE, + NVIcheckmate::assert_choice_character(x = dbservice, + choices = NVIconfig:::dbconnect$dbservice, + ignore.case = TRUE, comment = paste0("Predefined parameters for logging into the database '", dbservice, "' is not available in your version of NVIconfig"), @@ -40,6 +43,7 @@ login_by_credentials <- function(dbservice, if (is.null(dbserver)) {dbserver <- connect[, "dbserver"]} if (is.null(dbport)) {dbport <- connect[, "dbport"]} if (is.null(dbprotocol)) {dbprotocol <- connect[, "dbprotocol"]} + if (is.null(dbinterface)) {dbinterface <- connect[, "dbinterface"]} } } @@ -49,16 +53,18 @@ login_by_credentials <- function(dbservice, # # if predefined connection parameters don't exist for dbservice # # TO DO: include possibility for extra message in assert_character # if (x_msg != TRUE) { - # dbdriver - checkmate::assert_character(dbdriver, min.chars = 1, len = 1, any.missing = FALSE, add = checks) - # db - checkmate::assert_character(db, min.chars = 1, len = 1, any.missing = FALSE, add = checks) - # dbserver - checkmate::assert_character(dbserver, min.chars = 1, len = 1, any.missing = FALSE, add = checks) - # dbport - checkmate::assert_character(dbport, len = 1, any.missing = FALSE, add = checks) - # dbprotocol - checkmate::assert_character(dbprotocol, min.chars = 1, len = 1, any.missing = FALSE, add = checks) + # dbdriver + checkmate::assert_character(dbdriver, min.chars = 1, len = 1, any.missing = FALSE, add = checks) + # db + checkmate::assert_character(db, min.chars = 1, len = 1, any.missing = FALSE, add = checks) + # dbserver + checkmate::assert_character(dbserver, min.chars = 1, len = 1, any.missing = FALSE, add = checks) + # dbport + checkmate::assert_character(dbport, len = 1, any.missing = FALSE, add = checks) + # dbprotocol + checkmate::assert_character(dbprotocol, min.chars = 1, len = 1, any.missing = FALSE, add = checks) + # dbinterface + checkmate::assert_choice(dbinterface, choices = c("odbc", "RODBC", "RPostgreSQL"), add = checks) # } # credentials @@ -94,16 +100,39 @@ login_by_credentials <- function(dbservice, # This is used in Connect-statement below to ensure correct spelling when fetching User ID and Password dbservice <- keyring::key_list()[which(tolower(keyring::key_list()[, 1]) == tolower(dbservice)), 1] - # Connects to journal_rapp using ODBC - odbcConnection <- RODBC::odbcDriverConnect(paste0("DRIVER=", dbdriver, - ";Database=", db, - ";Server=", dbserver, - ";Port=", dbport, - ";PROTOCOL=", dbprotocol, - ";UID=", as.character(keyring::key_list(dbservice)[2]), - ";PWD=", keyring::key_get(dbservice, as.character(keyring::key_list(dbservice)[2])))) + if (dbinterface == "odbc") { + # Connects to journal_rapp using ODBC + connection <- DBI::dbConnect(drv = odbc::odbc(), + Driver = dbdriver, + Server = dbserver, + port = dbport, + Database = db, + UID = as.character(keyring::key_list(dbservice)[2]), + PWD = keyring::key_get(dbservice, as.character(keyring::key_list(dbservice)[2]))) + } + + if (dbinterface == "RODBC") { + # Connects to journal_rapp using ODBC + connection <- RODBC::odbcDriverConnect(paste0("DRIVER=", dbdriver, + ";Database=", db, + ";Server=", dbserver, + ";Port=", dbport, + ";PROTOCOL=", dbprotocol, + ";UID=", as.character(keyring::key_list(dbservice)[2]), + ";PWD=", keyring::key_get(dbservice, as.character(keyring::key_list(dbservice)[2])))) + } + + if (dbinterface == "RPostgreSQL") { + # Connects to journal_rapp using ODBC + connection <- RPostgreSQL::dbConnect(drv = DBI::dbDriver(dbdriver), + host = dbserver, + port = dbport, + dbname = db, + user = as.character(keyring::key_list(dbservice)[2]), + password = keyring::key_get(dbservice, as.character(keyring::key_list(dbservice)[2]))) + } - return(odbcConnection) + return(connection) } @@ -112,27 +141,26 @@ login_by_credentials <- function(dbservice, #' @export #' @rdname login -login_by_credentials_PJS <- function() { +login_by_credentials_PJS <- function(dbinterface = NULL) { # ARGUMENT CHECKING ---- # Object to store check-results checks <- checkmate::makeAssertCollection() - # Identify if NVIconfig are installed. NVIcheckmate::assert_package(x = "NVIconfig", add = checks) - - # credentials NVIcheckmate::assert_credentials(x = "PJS", add = checks) + # dbinterface + checkmate::assert_choice(dbinterface, choices = c("odbc", "RPostgreSQL", "RODBC"), null.ok = TRUE, add = checks) # Report check-results checkmate::reportAssertions(checks) - odbcConnection <- NVIdb::login_by_credentials(dbservice = "PJS") + connection <- NVIdb::login_by_credentials(dbservice = "PJS", dbinterface = dbinterface) - return(odbcConnection) + return(connection) } @@ -140,24 +168,23 @@ login_by_credentials_PJS <- function() { #' @export #' @rdname login -login_by_credentials_EOS <- function() { +login_by_credentials_EOS <- function(dbinterface = NULL) { # ARGUMENT CHECKING ---- # Object to store check-results checks <- checkmate::makeAssertCollection() - # Identify if NVIconfig are installed. NVIcheckmate::assert_package(x = "NVIconfig", add = checks) - - # credentials NVIcheckmate::assert_credentials(x = "EOS", add = checks) - + # dbinterface + checkmate::assert_choice(dbinterface, choices = c("odbc", "RPostgreSQL", "RODBC"), null.ok = TRUE, add = checks) + # Report check-results checkmate::reportAssertions(checks) - odbcConnection <- NVIdb::login_by_credentials(dbservice = "EOS") + connection <- NVIdb::login_by_credentials(dbservice = "EOS", dbinterface = dbinterface) - return(odbcConnection) + return(connection) } diff --git a/R/login_by_input.R b/R/login_by_input.R index f9577ca..d4f4409 100644 --- a/R/login_by_input.R +++ b/R/login_by_input.R @@ -7,32 +7,97 @@ login_by_input <- function(dbservice, dbserver = NULL, dbport = NULL, dbprotocol = NULL, + dbinterface = NULL, dbtext = NULL) { - # Error handling - # 1. Parameters for db-connection is missing - if ((is.null(dbdriver) | is.null(db) | is.null(dbserver) | is.null(dbport) | is.null(dbprotocol)) & - !tolower(dbservice) %in% tolower(NVIconfig:::dbconnect$dbservice)) { - stop(paste("Parameters for connection to", - dbservice, - "are missing and predefined parameters are not available")) - } - - # Identifies connection parameters for predefined dbservices - # Uses the predefined parameters only for parameters with NULL-value - if (is.null(dbdriver) | is.null(db) | is.null(dbserver) | is.null(dbport) | is.null(dbprotocol)) { - connect <- NVIconfig:::dbconnect[tolower(dbservice), ] - if (is.null(dbdriver)) {dbdriver <- connect[, "dbdriver"]} - if (is.null(db)) {db <- connect[, "db"]} - if (is.null(dbserver)) {dbserver <- connect[, "dbserver"]} - if (is.null(dbport)) {dbport <- connect[, "dbport"]} - if (is.null(dbprotocol)) {dbprotocol <- connect[, "dbprotocol"]} + # ARGUMENT CHECKING ---- + # Object to store check-results + checks <- checkmate::makeAssertCollection() + + # Perform checks + # dbservice + checkmate::assert_character(dbservice, min.chars = 1, len = 1, any.missing = FALSE, add = checks) + + + # # Error handling + # # 1. Parameters for db-connection is missing + # if ((is.null(dbdriver) | is.null(db) | is.null(dbserver) | is.null(dbport) | is.null(dbprotocol) | is.null(dbinterface)) & + # !tolower(dbservice) %in% tolower(NVIconfig:::dbconnect$dbservice)) { + # stop(paste("Parameters for connection to", + # dbservice, + # "are missing and predefined parameters are not available")) + # } + # Identifies if predefined connection parameters are needed + if (is.null(dbdriver) | is.null(db) | is.null(dbserver) | is.null(dbport) | is.null(dbprotocol) | is.null(dbinterface)) { + # Identify if NVIconfig are installed and parameters for dbservice exists. + NVIcheckmate::assert_package(x = "NVIconfig", + comment = paste0("Parameters for logging into the database '", + dbservice, + "' is lacking and NVIconfig with predefined parameters is not installed"), + add = checks) + + if (isTRUE(NVIcheckmate::check_package(x = "NVIconfig"))) { + NVIcheckmate::assert_choice_character(x = dbservice, choices = NVIconfig:::dbconnect$dbservice, ignore.case = TRUE, + comment = paste0("Predefined parameters for logging into the database '", + dbservice, + "' is not available in your version of NVIconfig"), + add = checks) + + # Uses the predefined parameters only for parameters with NULL-value + connect <- NVIconfig:::dbconnect[tolower(dbservice), ] + if (is.null(dbdriver)) {dbdriver <- connect[, "dbdriver"]} + if (is.null(db)) {db <- connect[, "db"]} + if (is.null(dbserver)) {dbserver <- connect[, "dbserver"]} + if (is.null(dbport)) {dbport <- connect[, "dbport"]} + if (is.null(dbprotocol)) {dbprotocol <- connect[, "dbprotocol"]} + if (is.null(dbinterface)) {dbinterface <- connect[, "dbinterface"]} + } } + + # dbdriver + checkmate::assert_character(dbdriver, min.chars = 1, len = 1, any.missing = FALSE, add = checks) + # db + checkmate::assert_character(db, min.chars = 1, len = 1, any.missing = FALSE, add = checks) + # dbserver + checkmate::assert_character(dbserver, min.chars = 1, len = 1, any.missing = FALSE, add = checks) + # dbport + checkmate::assert_character(dbport, len = 1, any.missing = FALSE, add = checks) + # dbprotocol + checkmate::assert_character(dbprotocol, min.chars = 1, len = 1, any.missing = FALSE, add = checks) + # dbinterface + checkmate::assert_choice(dbinterface, choices = c("odbc", "RODBC", "RPostgreSQL"), add = checks) + + # Report check-results + checkmate::reportAssertions(checks) + + # # Identifies connection parameters for predefined dbservices + # # Uses the predefined parameters only for parameters with NULL-value + # if (is.null(dbdriver) | is.null(db) | is.null(dbserver) | is.null(dbport) | is.null(dbprotocol) | is.null(dbinterface)) { + # connect <- NVIconfig:::dbconnect[tolower(dbservice), ] + # if (is.null(dbdriver)) {dbdriver <- connect[, "dbdriver"]} + # if (is.null(db)) {db <- connect[, "db"]} + # if (is.null(dbserver)) {dbserver <- connect[, "dbserver"]} + # if (is.null(dbport)) {dbport <- connect[, "dbport"]} + # if (is.null(dbprotocol)) {dbprotocol <- connect[, "dbprotocol"]} + # if (is.null(dbinterface)) {dbinterface <- connect[, "dbinterface"]} + # } if (is.null(dbtext)) {dbtext <- dbservice} # Connects to database service using ODBC - odbcConnection <- RODBC::odbcDriverConnect(paste0("DRIVER=", dbdriver, + if (dbinterface == "odbc") { + # Connects to journal_rapp using ODBC + connection <- DBI::dbConnect(drv = odbc::odbc(), + Driver = dbdriver, + Server = dbserver, + port = dbport, + Database = db, + UID = svDialogs::dlgInput(message = paste("Oppgi brukernavn for", dbtext))$res, + PWD = getPass::getPass(msg = paste("Oppgi passord for", dbtext))) + } + + if (dbinterface == "RODBC") { + connection <- RODBC::odbcDriverConnect(paste0("DRIVER=", dbdriver, ";Database=", db, ";Server=", dbserver, ";Port=", dbport, @@ -42,18 +107,39 @@ login_by_input <- function(dbservice, ";PWD=", getPass::getPass(msg = paste("Oppgi passord for", dbtext))) ) - - return(odbcConnection) + } + + if (dbinterface == "RPostgreSQL") { + # Connects to journal_rapp using ODBC + connection <- RPostgreSQL::dbConnect(drv = DBI::dbDriver(dbdriver), + host = dbserver, + port = dbport, + dbname = db, + user = svDialogs::dlgInput(message = paste("Oppgi brukernavn for", dbtext))$res, + password = getPass::getPass(msg = paste("Oppgi passord for", dbtext))) + } + + return(connection) } #' @export #' @rdname login -login_by_input_PJS <- function() { +login_by_input_PJS <- function(dbinterface = NULL) { + # ARGUMENT CHECKING ---- + # Object to store check-results + checks <- checkmate::makeAssertCollection() + + # dbinterface + checkmate::assert_choice(dbinterface, choices = c("odbc", "RPostgreSQL", "RODBC"), null.ok = TRUE, add = checks) + + # Report check-results + checkmate::reportAssertions(checks) + # Oppretterknytning mot journal_rapp - odbcConnection <- login_by_input(dbservice = "PJS") + odbcConnection <- login_by_input(dbservice = "PJS", dbinterface = dbinterface) return(odbcConnection) } @@ -62,10 +148,20 @@ login_by_input_PJS <- function() { #' @export #' @rdname login -login_by_input_EOS <- function() { - +login_by_input_EOS <- function(dbinterface = NULL) { + + # ARGUMENT CHECKING ---- + # Object to store check-results + checks <- checkmate::makeAssertCollection() + + # dbinterface + checkmate::assert_choice(dbinterface, choices = c("odbc", "RPostgreSQL", "RODBC"), null.ok = TRUE, add = checks) + + # Report check-results + checkmate::reportAssertions(checks) + # Oppretterknytning mot EOS - odbcConnection <- login_by_input(dbservice = "EOS") + odbcConnection <- login_by_input(dbservice = "EOS", dbinterface = dbinterface) return(odbcConnection) } diff --git a/R/read_Pkode_2_text.R b/R/read_Pkode_2_text.R index 8987ece..5dca771 100644 --- a/R/read_Pkode_2_text.R +++ b/R/read_Pkode_2_text.R @@ -64,7 +64,7 @@ read_Pkode_2_text <- function(filename = "Produksjonstilskuddskoder2_UTF8.csv", options = list(colClasses = colclasses, fileEncoding = "UTF-8")) if (isTRUE(keep_old_names)) { - standard_names <- c("soknadaar", "telledato", "art", "Pkode", + standard_names <- c("soknadaar", "telledato", "Pkodeart", "Pkode", "beskrivelse", "enhet", "unike_dyr", "sortering") if (isTRUE(checkmate::check_subset(x = standard_names, choices = colnames(Pkoder)))) { @@ -73,6 +73,8 @@ read_Pkode_2_text <- function(filename = "Produksjonstilskuddskoder2_UTF8.csv", "Beskrivelse", "Enhet", "Seleksjon", "Sortering", base::setdiff(colnames(Pkoder), standard_names)) Pkoder$Telledato <- format(as.Date(Pkoder$Telledato), "%d.%m") + Pkoder[which(Pkoder$Art == "Svin"), "Art"] <- "Gris" + Pkoder$Enhet <- snakecase::to_sentence_case(Pkoder$Enhet) } } return(Pkoder) diff --git a/R/read_Prodtilskudd.R b/R/read_Prodtilskudd.R index a1894bd..2d6716e 100644 --- a/R/read_Prodtilskudd.R +++ b/R/read_Prodtilskudd.R @@ -53,10 +53,11 @@ read_Prodtilskudd <- function(from_path = paste0(set_dir_NVI("Prodtilskudd"), "F # Pkode_month checkmate::assert_subset(Pkode_month, choices = c("both", "last", "01", "03", "05", "07", "10", "12"), add = checks) # Pkode_year - checkmate::assert(checkmate::check_integerish(as.numeric(Pkode_year[which(!grepl('[:alpha:]', Pkode_year))]), + checkmate::assert(checkmate::check_integerish(as.numeric(Pkode_year[grep('[[:alpha:]]', Pkode_year, invert = TRUE)]), lower = 1995, upper = as.numeric(format(Sys.Date(), "%Y")), any.missing = FALSE, + all.missing = FALSE, unique = TRUE), # checkmate::check_character(Pkode_year, min.chars = 4, min.len = 1, any.missing = FALSE), checkmate::check_choice(Pkode_year, choices = c("last")), diff --git a/R/read_eos_data.R b/R/read_eos_data.R new file mode 100644 index 0000000..5801a31 --- /dev/null +++ b/R/read_eos_data.R @@ -0,0 +1,106 @@ +#' @title Read EOS data from RaData +#' @description Reads EOS data from RaData. Includes historical data if these exists. +#' It is possible to limit the data to one or more years. +#' @details read_eos_data uses \code{data.table::fread} to read the data with the +#' settings \code{showProgress = FALSE} and \code{data.table = FALSE}. Other +#' arguments can be passed to \code{data.table::fread} if necessary. +#' +#' @param from_path Path for raw data from eos_data +#' @param eos_table The name of the table with eos raw data +#' @param year The years to be included in the result. Can be both numeric +#' or character. Defaults to \code{NULL}, i.e. no selection. +#' @param colClasses The class of the columns, as in utils::read.table, Defaults to +#' \code{"character"}. +#' @param encoding The encoding. Defaults to \code{"UTF-8"}. +#' @param \dots Other arguments to be passed to \code{data.table::fread}. +#' +#' @return A data frame with data from EOS. +#' +#' @author Petter Hopp Petter.Hopp@@vetinst.no +#' @export +#### Function for reading EOS data from RaData. Also reads historic data if file exists +# eos_table er det samme som TABLE_NAME i EOS-databasen +# (Se all_views_eos.csv i RaData-mappen) +read_eos_data <- function(eos_table, + from_path = paste0(set_dir_NVI("EOS"), "RaData"), + year = NULL, + colClasses = "character", + encoding = "UTF-8", + ...) { + + # PREPARE ARGUMENTS BEFORE ARGUMENT CHECKING + # Removing ending "/" and "\\" from pathnames + from_path <- sub("/+$|\\\\+$", "", from_path) + # Change any character year to numeric + if (!is.null(year)) {year <- as.numeric(year)} + + # ARGUMENT CHECKING ---- + # Object to store check-results + checks <- checkmate::makeAssertCollection() + # Perform checks + ## eos_table + checkmate::assert_string(eos_table, min.chars = 1, add = checks) + ## from_path / filename + checkmate::assert_file_exists(file.path(from_path, paste0(eos_table, ".csv")), access = "r", add = checks) + ## year + checkmate::assert_integerish(year, + lower = 1995, + upper = as.numeric(format(Sys.Date(), "%Y")), + any.missing = FALSE, + all.missing = FALSE, + unique = TRUE, + null.ok = TRUE, + add = checks) + ## colClasses + checkmate::assert_character(colClasses, min.chars = 1, min.len = 1, + any.missing = FALSE, + all.missing = FALSE, + null.ok = TRUE, + add = checks) + + ## encoding + checkmate::assert_subset(encoding, choices = c("UTF-8", "latin1"), add = checks) + + # Report check-results + checkmate::reportAssertions(checks) + + + # Import of data from csv-files retrieved from EOS + # EOS inneholder data fra siste og foregående år og antas å være i kontinuerlig endring + eos_data <- data.table::fread(file = file.path(from_path, paste0(eos_table, ".csv")), + colClasses = colClasses, + encoding = encoding, + showProgress = FALSE, + data.table = FALSE, + ...) + + column_names <- colnames(eos_data) + colnames(eos_data) <- tolower(column_names) + + # Import av historiske data fra EOS + # EOS-historikkfiler oppdateres 1 x årlig. Data hentes ut etter oppdatering og lagres i csv-filer + # Hentes derfor fra csv-filen for bruk i OK-statistikken + if (file.exists(file.path(from_path, paste0(eos_table, "_historikk.csv")))) { + eos_data_historikk <- data.table::fread(file = file.path(from_path, paste0(eos_table, "_historikk.csv")), + colClasses = colClasses, + encoding = encoding, + showProgress = FALSE, + data.table = FALSE, + ...) + + # Fjerner år fa historikktabellen som også ligger i driftstabellen. Setter deretter sammen tabellene + first_year_in_eos_data <- min(substr(eos_data$saksnr, 1, 4)) + colnames(eos_data_historikk) <- tolower(column_names) + eos_data_historikk <- subset(eos_data_historikk, substr(eos_data_historikk$saksnr, 1, 4) < first_year_in_eos_data) + eos_data <- rbind(eos_data, eos_data_historikk) + } + + if (!is.null(year)) { + eos_data <- subset(eos_data, substr(eos_data$saksnr, 1, 4) %in% year) + } + + colnames(eos_data) <- column_names + return(eos_data) +} + +# \ No newline at end of file diff --git a/R/read_sonetilhorighet.R b/R/read_sonetilhorighet.R index a167fd3..57535f2 100644 --- a/R/read_sonetilhorighet.R +++ b/R/read_sonetilhorighet.R @@ -19,7 +19,8 @@ read_sonetilhorighet <- function(filename = "sonetilhorighet.txt", df1 <- read_csv_file(filename = filename, from_path = from_path, options = list(colClasses = c("LokNr" = "character"), - fileEncoding = "UTF-8")) + fileEncoding = "UTF-8"), + sep = "\t") return(df1) } diff --git a/R/read_varekode.R b/R/read_varekode.R new file mode 100644 index 0000000..48041af --- /dev/null +++ b/R/read_varekode.R @@ -0,0 +1,175 @@ +#' @title Manage translation table for varekoder til leveransregisteret +#' @description Read the translation table for varekoder til leveransregisteret. +#' @details The translation table for varekoder comprises the variables: +#' the leveranseaar, varekode, vare (descriptive text), dyreslag, +#' vareart, dyrekategori, and varekategorikode. The register covers 2016 +#' and later. +#' +#' \code{read_varekoder} with the argument \code{type = "formatted"} +#' reads the formatted "varekoder.csv" into a data frame. The standard +#' settings will read the file from NVI's internal network. If changing +#' the from_path, the function can be used to read the translation file +#' from other directories. This can be useful if having a stand alone +#' app with no connection the NVI's internal network. In other cases, +#' it should be avoided. +#' +#' \code{read_varekoder} with the argument \code{type = "raw"} reads +#' the raw data as supplied from Landbruksdirektoratet into a data frame. +#' Thereafter, these can be used to generate the formatted version. +#' The standard settings will read the file from NVI's internal network +#' and changing the path should be avoided. +#' +#' @param filename Name of the translation table, defaults to "varekoder.csv". +#' The input is only used when \code{data_source = "formatted"}. +#' @param from_path Path for the translation table for varekoder. +#' @param year Year(s) for fetching the varekoderegister. +#' @param data_source Reads formatted data or raw data. deafult is formatted. +#' +#' @return \code{read_varekoder} A data frame with the translation table for +#' varekoder to descriptive text and metadata. +#' +#' @author Petter Hopp Petter.Hopp@@vetinst.no +#' @importFrom rlang .data +#' @export +#' @examples +#' \dontrun{ +#' # Reading from standard directory at NVI's network +#' varekoder <- read_varekode() +#' } +#' +read_varekode <- function(filename = "varekoder.csv", + from_path = paste0(set_dir_NVI("LevReg")), + year = NULL, + data_source = "formatted") { + + # PREPARE ARGUMENTS BEFORE ARGUMENT CHECKING ---- + from_path <- sub("/+$|\\\\+$", "", from_path) + + # ARGUMENT CHECKING ---- + # Object to store check-results + checks <- checkmate::makeAssertCollection() + # Perform checks + checkmate::assert_character(from_path, len = 1, min.chars = 1, add = checks) + checkmate::assert_directory_exists(from_path, access = "r", add = checks) + if (data_source == "formatted") { + checkmate::assert_character(filename, len = 1, min.chars = 1, null.ok = FALSE, add = checks) + checkmate::assert_file_exists(x = file.path(from_path, "FormaterteData", filename), access = "r", add = checks) + } else { + checkmate::assert_character(filename, len = 1, min.chars = 1, null.ok = TRUE, add = checks) + } + checkmate::assert_subset(data_source, + choices = c("formatted", "raw"), + add = checks) + if (data_source == "formatted") { + checkmate::assert(checkmate::check_integerish(as.numeric(year[grep("[[:alpha:]]", year, invert = TRUE)]), + lower = 1995, + upper = as.numeric(format(Sys.Date(), "%Y")), + any.missing = FALSE, + all.missing = FALSE, + unique = TRUE, + null.ok = FALSE), + checkmate::check_choice(year, choices = c("last"), null.ok = TRUE), + add = checks) + } else { + checkmate::assert(checkmate::check_integerish(as.numeric(year[grep("[[:alpha:]]", year, invert = TRUE)]), + lower = 1995, + upper = as.numeric(format(Sys.Date(), "%Y")), + len = 1, + any.missing = FALSE, + all.missing = FALSE, + unique = TRUE, + null.ok = FALSE), + checkmate::check_choice(year, choices = c("last"), null.ok = TRUE), + add = checks) + } + # Report check-results + checkmate::reportAssertions(checks) + + # IMPORT VAREKODEREGISTER FORMATTED DATA ---- + if (data_source == "formatted") { + + from_path <- file.path(from_path, "FormaterteData") + + # READ DATA ---- + df1 <- read_csv_file(filename = filename, + from_path = from_path, + options = list(colClasses = c("varekode" = "character"), + fileEncoding = "UTF-8")) + + if (!is.null(year)) { + if (year[1] == "last") {year <- max(df1$leveranseaar)} + df1 <- df1[which(df1$leveranseaar %in% as.numeric(year)), ] + } + } + + # IMPORT VAREKODEREGISTER RAW DATA ---- + if (data_source == "raw") { + sub_path <- "RaData" + # Generate data frame listing all versions of the varekoderegister + filnavn <- list.files(path = file.path(from_path, sub_path), recursive = TRUE, pattern = "varekode", ignore.case = TRUE) + filnavn <- as.data.frame(filnavn) + # Find start and end date that the register is valid for + filnavn$fra_dato <- as.Date(paste0(substr(filnavn$filnavn, 1, 6), "01"), format = "%Y%m%d") + filnavn$til_dato <- as.Date(cut(as.Date(paste0(substr(filnavn$filnavn, 8, 13), "01"), format = "%Y%m%d") + 32, "month")) - 1 + filnavn$n_days <- as.numeric(filnavn$til_dato - filnavn$fra_dato + 1) + filnavn$aar <- as.numeric(format(filnavn$til_dato, "%Y")) + # Order in decending order by date + filnavn <- filnavn %>% + dplyr::group_by(.data$aar) %>% + dplyr::mutate(max_n_days = max(.data$n_days)) %>% + dplyr::ungroup() %>% + dplyr::arrange(dplyr::desc(.data$fra_dato), dplyr::desc(.data$til_dato)) + + # filnavn <- filnavn[c(2:dim(filnavn)[1]), ] + # Select varekoder for time period + # Selects from year + if (year != "last") { + # rownr <- which(filnavn[, "n_days"] >= 365 & filnavn[, "aar"] %in% as.numeric(year)) + rownr <- which(filnavn[, "n_days"] == filnavn[, "max_n_days"] & filnavn[, "aar"] == as.numeric(year)) + } + # Selects from the years covering the last 12 months + if (year == "last") { + if (filnavn[1, "n_days"] >= 365) {rownr <- 1} + if (filnavn[1, "n_days"] < 365) {rownr <- c(1, 2)} + } + + # # Select varekode raw data for import + # if (exists("df1")) {rm(df1)} + for (i in rownr) { + # i <- 3 + check_header <- readLines(con = paste0(set_dir_NVI("LevReg"), "RaData/", filnavn[i, "filnavn"]), n = 1) + # "vare" in first line, then header = TRUE + header <- grepl("vare", check_header, ignore.case = TRUE) + # identify delimiter + if (grepl(";", check_header)) {delimiter <- ";"} + if (grepl(",", check_header)) {delimiter <- ","} + + tempdf <- utils::read.delim(paste0(set_dir_NVI("LevReg"), sub_path, "/", filnavn[i, "filnavn"]), + header = header, + sep = delimiter) + + # if no national characters (represented by "å"), then read again using UTF-8 encoding + if (isFALSE(any(grepl("\u00E5", tempdf[, 2], ignore.case = TRUE)))) { + if (isTRUE(any(grepl("", tempdf[, 2], ignore.case = TRUE)))) { + file_encoding <- "latin1" + } else { + file_encoding <- "UTF-8" + } + tempdf <- utils::read.delim(paste0(set_dir_NVI("LevReg"), sub_path, "/", filnavn[i, "filnavn"]), + header = header, + sep = delimiter, + fileEncoding = file_encoding) + } + if (dim(tempdf)[2] > 3) {tempdf <- tempdf[, c(1:3)]} + colnames(tempdf) <- c("varekode", "vare", "dyreslag") + if (exists("df1")) { + df1 <- rbind(df1, tempdf) + } else { + df1 <- tempdf + } + df1 <- unique(df1) + } + } + + return(df1) +} diff --git a/R/standardize_PJSdata.R b/R/standardize_PJSdata.R index d85599e..643a035 100644 --- a/R/standardize_PJSdata.R +++ b/R/standardize_PJSdata.R @@ -27,7 +27,7 @@ #' @examples #' \dontrun{ #' # Standardizing sak_m_res -#' sak_m_res <- standardize_PJSdata(PJSdata = sak_m_res) +#' sak_m_res <- standardize_PJSdata(PJSdata = sak_m_res) #' } #' standardize_PJSdata <- function(PJSdata, dbsource = "v2_sak_m_res") { diff --git a/R/utils.R b/R/utils.R index 455a253..c280f81 100644 --- a/R/utils.R +++ b/R/utils.R @@ -28,13 +28,13 @@ #' @keywords internal copy_file_if_updated <- function(filename, from_path, to_path) { - + # Check if from_path and to_path ends in "/". If not, "/" is added. from_path <- sub("/+$|\\\\+$", "", from_path) to_path <- sub("/+$|\\\\+$", "", to_path) # if (!endsWith(from_path, "/")) { from_path <- paste0(from_path, "/") } # if (!endsWith(to_path, "/")) { to_path <- paste0(to_path, "/") } - + # Get creation date of source file if (dir.exists(from_path)) { files <- list.files(from_path, pattern = filename, ignore.case = TRUE) @@ -42,7 +42,7 @@ copy_file_if_updated <- function(filename, from_path, to_path) { source_file_created <- file.mtime(file.path(from_path, filename)) } } - + # Get creation date of target file target_file_created <- 0 if (dir.exists(to_path)) { @@ -55,14 +55,14 @@ copy_file_if_updated <- function(filename, from_path, to_path) { } } } - + # Copies the source file if source file is newer if (source_file_created > target_file_created) { file.copy(from = file.path(from_path, filename), to = to_path, overwrite = TRUE, copy.date = TRUE) - + } } @@ -106,38 +106,38 @@ add_new_column <- function(data, overwrite = FALSE, impute_old_when_missing = FALSE, n_columns_at_once = 1) { - + # Transforms the data to a data.frame and removes other classes # I'm afraid that this might be dependent on packages making the alternative classes (i.e. dplyr) must be loaded # if it is dplyr that makes is.data.frame to work for these classes if (is.data.frame(data) & length(class(data)) > 1) { data <- as.data.frame(data) } - + # Add row to keep original sort order of data data$original_sort_order <- seq_len(nrow(data)) - - + + for (i in 1:length(ID_column)) { - + # First and last column in the translation table if a code should be translated to more than one variable at once # This used in add_MT_area to add several MT area desciptions based on komnr first_to_colnum <- (1 + (n_columns_at_once * (i - 1))) last_to_colnum <- i * n_columns_at_once - + # Make a subset with only the codes that is relevant for the actual variable translation_table <- translation_tables[[i]] code_2_new_text <- translation_table[, c(ID_column_translation_table[i], to_column_translation_table[c(first_to_colnum:last_to_colnum)])] - + # Changes the name of the new column in the translation table to the name wanted in the df # Rename ID_column_translation_table[i] in translation table to ID_column_name_zz # that is supposed to be unique and thereby avoid column name conflicts colnames(code_2_new_text) <- c("ID_column_name_zz", new_colname[c(first_to_colnum:last_to_colnum)]) - + # If new variable names already exists in data frame and overwrite = TRUE # Identifies all columns with common names in data and in new columns to add existing_names <- intersect(colnames(data), new_colname[c(first_to_colnum:last_to_colnum)]) - + # Replace position = keep with right if overwrite = FALSE if (!overwrite | length(existing_names) == 0) {position <- gsub("keep", "right", position)} if (length(existing_names) > 0 & overwrite) { @@ -151,11 +151,11 @@ add_new_column <- function(data, } # Finds the column number for the code variable code_colnum <- which(colnames(data) == ID_column[i]) - + # Trim trailing spaces from the coded variable # This may be necessary for data taken from PJS before merging data[, ID_column[i]] <- trimws(data[, ID_column[i]]) - + # joins the dataset with the code description data <- merge(data, code_2_new_text, @@ -163,13 +163,13 @@ add_new_column <- function(data, # by.y = ID_column_translation_table[i], by.y = "ID_column_name_zz", all.x = TRUE) - + # Imputes with values in code variable in old dataset in the case that no merge was performed # Only if impute_old_when_missing = TRUE if (impute_old_when_missing) { data[which(is.na(data[, new_colname])), new_colname] <- data[which(is.na(data[, new_colname])), ID_column] } - + # Rearrange columns # Merge places the by-columns first and the new columns last in the data frame # 1. Put by-column back to original place (= code_colnum). If code_colnum == 1, the column is already correct placed @@ -180,10 +180,10 @@ add_new_column <- function(data, } # 2. Move the new columns to their new position. # The new position is specified by the parameter position = c("first", "left", "right", "last") - + # Identifies column number of first new column new_colnum <- which(colnames(data) == new_colname[first_to_colnum]) - + # position == "right" Move column with description to the right of the column with code if (position == "right") { # If already to the right, no need to do any change @@ -228,14 +228,14 @@ add_new_column <- function(data, (keep_colnum):(new_colnum - 1))] } } - + } - - + + # Sorts data in original order and removes sort key data <- data[order(data$original_sort_order), ] data$original_sort_order <- NULL - + return(data) } @@ -263,13 +263,15 @@ add_new_column <- function(data, #' @keywords internal read_csv_file <- function(filename, from_path, options = NULL, ...) { - + # Removes trailing "/" and "\\". from_path <- sub("/+$|\\\\+$", "", from_path) # # Check if from_path ends in "/". If not, "/" is added. # if (!endsWith(from_path, "/")) { from_path <- paste0(from_path, "/") } - - + + # if (is.null(sep)) {sep <- ";"} + # if (!exists("dec")) {dec <- ","} + if (is.null(options)) { options <- list(colClasses = NA, fileEncoding = "UTF-8", stringsAsFactors = FALSE) } else { @@ -281,15 +283,24 @@ read_csv_file <- function(filename, from_path, options = NULL, ...) { if (dir.exists(from_path)) { if (file.exists(file.path(from_path, filename))) { df <- data.table::fread(file = file.path(from_path, filename), - colClasses = options$colClasses, - encoding = options$fileEncoding, - stringsAsFactors = options$stringsAsFactors, - showProgress = FALSE, - ...) + colClasses = options$colClasses, + encoding = options$fileEncoding, + stringsAsFactors = options$stringsAsFactors, + showProgress = FALSE, + data.table = FALSE, + ...) + # df <- utils::read.table(file = file.path(from_path, filename), + # colClasses = options$colClasses, + # fileEncoding = options$fileEncoding, + # stringsAsFactors = options$stringsAsFactors, + # sep = sep, + # dec = dec, + # header = TRUE, + # ...) } } - - return(as.data.frame(df)) + return(df) + # return(as.data.frame(df)) } ### ---- @@ -322,20 +333,20 @@ read_csv_file <- function(filename, from_path, options = NULL, ...) { set_name_vector <- function(colname_vector) { # Existing names to the vector name name <- names(colname_vector) - + # vector values to unnamed vector column <- unname(colname_vector) - + # Check if any elements are named if (!is.null(name)) { # if some elements are named, move element value to unnamed elements for (i in 1:length(name)) { if (name[i] == "") {name[i] <- column[i]} } - + # if no elements are named, set element values as names } else {name <- column } - + return(stats::setNames(colname_vector, name)) } @@ -368,3 +379,27 @@ set_name_vector <- function(colname_vector) { #' @noRd find_n_th_word <- function(x, position) {strsplit(x, " ")[[1]][position]} + + +### cut_slash ---- +#' @title Cut away ending slash from string +#' @description Removes ending slash or backslash from string. +#' This is used to clean pathnames so that elements in a path +#' can be combined using \code{file.path} in stead of \code{\link{paste0}}. +#' +#' @param x Object with character strings. +#' +#' @return Object without ending slash in character strings. +#' +#' @author Petter Hopp Petter.Hopp@@vetinst.no +#' @export +#' @examples +#' # Remove from string +#' cut_slash("C:/temp/") +#' cut_slash("C:\\temp\\") +#' cut_slash(c("C:/temp/", "C:\\temp\\")) +#' cut_slash(list("C:/temp/", "C:\\temp\\")) +cut_slash <- function(x) { + x <- gsub("/+$|\\\\+$", "", x) + return(x) +} diff --git a/R/zzz.R b/R/zzz.R index de2f3c7..b474afb 100644 --- a/R/zzz.R +++ b/R/zzz.R @@ -1,4 +1,4 @@ -# Give a startup message if NVIconfig less than v0.2.0 is not installed +# Give a startup message if NVIconfig less than required version is not installed #' @title Check if an argument is an installed package of required version @@ -8,40 +8,15 @@ #' #' @param x Object to check. #' @param version The required version of the installed package. May be \code{NULL}. -#' @return If package of required version is installed, then TRUE, else aerror message +#' @return If package of required version is installed, then TRUE, else an error message #' @noRd -# check_package <- function(x, version = NULL) { -# # ARGUMENT CHECKING ---- -# # Object to store check-results -# checks <- checkmate::makeAssertCollection() -# # Perform checks -# checkmate::assert_character(x, len = 1, min.char = 2) -# checkmate::assert_character(version, len = 1, null.ok = TRUE) -# # Report check-results -# checkmate::reportAssertions(checks) -# -# # PERFORM CHECK -# # if the package is not installed -# if (!nchar(system.file(package = x))) { -# res <- paste0("The package '", x, "' is not installed") -# } else { -# # Check if the required version is installed -# installed_version <- utils::packageDescription(x)$Version -# if (utils::compareVersion(installed_version, version) == -1) { -# res <- paste0("The package '", x, "' version '", installed_version, "' is installed, while version '", version, "' is required.") -# } else { -# res <- TRUE -# } -# } -# } - # Do after loading NVIdb .onAttach <- function(libname, pkgname) { # check if "NVIconfig" is installed - msg <- NVIcheckmate::check_package(x = "NVIconfig", version = "0.4.0") + msg <- NVIcheckmate::check_package(x = "NVIconfig", version = "0.5.0") # Print a startup message if not required version is installed if (!isTRUE(msg)) { @@ -56,5 +31,4 @@ } invisible() - } diff --git a/README.md b/README.md index d154223..b4cc0d9 100644 --- a/README.md +++ b/README.md @@ -116,7 +116,7 @@ other changes. ## Copyright and license -Copyright (c) 2019 - 2022 Norwegian Veterinary Institute. +Copyright (c) 2019 - 2023 Norwegian Veterinary Institute. Licensed under the BSD\_3\_clause License. See [License](https://github.com/NorwegianVeterinaryInstitute/NVIdb/blob/main/LICENSE) for details. diff --git a/man-roxygen/position.R b/man-roxygen/position.R index 44b2b78..59399ed 100644 --- a/man-roxygen/position.R +++ b/man-roxygen/position.R @@ -2,4 +2,4 @@ #' #' @param position [\code{character(1)}]. The position for the new columns, can #' be one of c("first", "left", "right", "last", "keep"). The input can be -#' abbreviated, but must be unique, i.e. c("f", "le". "r", "la", "k"). +#' abbreviated, but must be unique, i.e. c("f", "le", "r", "la", "k"). diff --git a/man/add_MT_omrader.Rd b/man/add_MT_omrader.Rd index 11b48ad..4bbde96 100644 --- a/man/add_MT_omrader.Rd +++ b/man/add_MT_omrader.Rd @@ -42,7 +42,7 @@ should have other names, \code{new_column} can be input as a named vector, see e \item{position}{[\code{character(1)}]. The position for the new columns, can be one of c("first", "left", "right", "last", "keep"). The input can be -abbreviated, but must be unique, i.e. c("f", "le". "r", "la", "k").} +abbreviated, but must be unique, i.e. c("f", "le", "r", "la", "k").} \item{overwrite}{[\code{logical(1)}]. When the new column(s) already exist, the content in the existing column(s) is replaced by new data if diff --git a/man/add_kommune_fylke.Rd b/man/add_kommune_fylke.Rd index 53fa6e3..ec9ee37 100644 --- a/man/add_kommune_fylke.Rd +++ b/man/add_kommune_fylke.Rd @@ -41,7 +41,7 @@ read_kommune_fylke( \item{position}{[\code{character(1)}]. The position for the new columns, can be one of c("first", "left", "right", "last", "keep"). The input can be -abbreviated, but must be unique, i.e. c("f", "le". "r", "la", "k").} +abbreviated, but must be unique, i.e. c("f", "le", "r", "la", "k").} \item{overwrite}{[\code{logical(1)}]. When the new column(s) already exist, the content in the existing column(s) is replaced by new data if diff --git a/man/add_lokalitet.Rd b/man/add_lokalitet.Rd index 7db1330..c1635dd 100644 --- a/man/add_lokalitet.Rd +++ b/man/add_lokalitet.Rd @@ -33,7 +33,7 @@ data frame should have other names, \code{new_column} can be input as a named ve \item{position}{[\code{character(1)}]. The position for the new columns, can be one of c("first", "left", "right", "last", "keep"). The input can be -abbreviated, but must be unique, i.e. c("f", "le". "r", "la", "k").} +abbreviated, but must be unique, i.e. c("f", "le", "r", "la", "k").} \item{overwrite}{[\code{logical(1)}]. When the new column(s) already exist, the content in the existing column(s) is replaced by new data if diff --git a/man/add_poststed.Rd b/man/add_poststed.Rd index 78086b8..7d7bb6a 100644 --- a/man/add_poststed.Rd +++ b/man/add_poststed.Rd @@ -38,7 +38,7 @@ read_poststed( \item{position}{[\code{character(1)}]. The position for the new columns, can be one of c("first", "left", "right", "last", "keep"). The input can be -abbreviated, but must be unique, i.e. c("f", "le". "r", "la", "k").} +abbreviated, but must be unique, i.e. c("f", "le", "r", "la", "k").} \item{overwrite}{[\code{logical(1)}]. When the new column(s) already exist, the content in the existing column(s) is replaced by new data if diff --git a/man/add_produsent_properties.Rd b/man/add_produsent_properties.Rd index 5f07b28..c975e85 100644 --- a/man/add_produsent_properties.Rd +++ b/man/add_produsent_properties.Rd @@ -49,7 +49,7 @@ should have other names, \code{new_column} can be input as a named vector, see e \item{position}{[\code{character(1)}]. The position for the new columns, can be one of c("first", "left", "right", "last", "keep"). The input can be -abbreviated, but must be unique, i.e. c("f", "le". "r", "la", "k").} +abbreviated, but must be unique, i.e. c("f", "le", "r", "la", "k").} \item{overwrite}{[\code{logical(1)}]. When the new column(s) already exist, the content in the existing column(s) is replaced by new data if diff --git a/man/cut_slash.Rd b/man/cut_slash.Rd new file mode 100644 index 0000000..67f62c3 --- /dev/null +++ b/man/cut_slash.Rd @@ -0,0 +1,29 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/utils.R +\name{cut_slash} +\alias{cut_slash} +\title{Cut away ending slash from string} +\usage{ +cut_slash(x) +} +\arguments{ +\item{x}{Object with character strings.} +} +\value{ +Object without ending slash in character strings. +} +\description{ +Removes ending slash or backslash from string. + This is used to clean pathnames so that elements in a path + can be combined using \code{file.path} in stead of \code{\link{paste0}}. +} +\examples{ +# Remove from string +cut_slash("C:/temp/") +cut_slash("C:\\\\temp\\\\") +cut_slash(c("C:/temp/", "C:\\\\temp\\\\")) +cut_slash(list("C:/temp/", "C:\\\\temp\\\\")) +} +\author{ +Petter Hopp Petter.Hopp@vetinst.no +} diff --git a/man/login.Rd b/man/login.Rd index eaa2fda..dacad44 100644 --- a/man/login.Rd +++ b/man/login.Rd @@ -19,12 +19,13 @@ login( db = NULL, dbserver = NULL, dbport = NULL, - dbprotocol = NULL + dbprotocol = NULL, + dbinterface = NULL ) -login_PJS() +login_PJS(dbinterface = NULL) -login_EOS() +login_EOS(dbinterface = NULL) login_by_credentials( dbservice, @@ -32,12 +33,13 @@ login_by_credentials( db = NULL, dbserver = NULL, dbport = NULL, - dbprotocol = NULL + dbprotocol = NULL, + dbinterface = NULL ) -login_by_credentials_PJS() +login_by_credentials_PJS(dbinterface = NULL) -login_by_credentials_EOS() +login_by_credentials_EOS(dbinterface = NULL) login_by_input( dbservice, @@ -46,12 +48,13 @@ login_by_input( dbserver = NULL, dbport = NULL, dbprotocol = NULL, + dbinterface = NULL, dbtext = NULL ) -login_by_input_PJS() +login_by_input_PJS(dbinterface = NULL) -login_by_input_EOS() +login_by_input_EOS(dbinterface = NULL) } \arguments{ \item{dbservice}{Name of the database service, for example "PJS" or "EOS". @@ -68,6 +71,9 @@ can be chosen freely, but must be the same as used in \code{\link{set_credential \item{dbprotocol}{Protocol to be used.} +\item{dbinterface}{The R-package that is used for interface towards the data +base.} + \item{dbtext}{used in login with input. Gives the possibility of showing another name than the dbservice in the windows asking for username and password.} @@ -128,7 +134,10 @@ The NVI has access to several database services. These functions log \code{\link{set_credentials_EOS}}, no input is needed. The login functions returns an open ODBC-channel to the database service. - The database can then be queried by using functions in the package \code{RODBC}. + The database can then be queried by using functions in the package used for + data base interface. The data base interface must be one of \code{odbc}, + \code{RODBC} or, \code{RPostgreSQL}. The default is given in NVIconfig and is + \code{RODBC} for "SQL server" and \code{RPostgreSQL} for "PostgreSQL". When the session is finished, the script shall close the ODBC-channel by \code{odbcClose("myodbcchannel")} or \code{odbcCloseAll}. @@ -138,7 +147,7 @@ The NVI has access to several database services. These functions log require(RODBC) journal_rapp <- login_PJS() # Reads hensiktregistret from PJS - hensikter <- sqlQuery(journal_rapp, +hensikter <- sqlQuery(journal_rapp, "select * from v_hensikt", as.is = TRUE, stringsAsFactors = FALSE) diff --git a/man/read_eos_data.Rd b/man/read_eos_data.Rd new file mode 100644 index 0000000..04dc01d --- /dev/null +++ b/man/read_eos_data.Rd @@ -0,0 +1,45 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/read_eos_data.R +\name{read_eos_data} +\alias{read_eos_data} +\title{Read EOS data from RaData} +\usage{ +read_eos_data( + eos_table, + from_path = paste0(set_dir_NVI("EOS"), "RaData"), + year = NULL, + colClasses = "character", + encoding = "UTF-8", + ... +) +} +\arguments{ +\item{eos_table}{The name of the table with eos raw data} + +\item{from_path}{Path for raw data from eos_data} + +\item{year}{The years to be included in the result. Can be both numeric +or character. Defaults to \code{NULL}, i.e. no selection.} + +\item{colClasses}{The class of the columns, as in utils::read.table, Defaults to +\code{"character"}.} + +\item{encoding}{The encoding. Defaults to \code{"UTF-8"}.} + +\item{\dots}{Other arguments to be passed to \code{data.table::fread}.} +} +\value{ +A data frame with data from EOS. +} +\description{ +Reads EOS data from RaData. Includes historical data if these exists. + It is possible to limit the data to one or more years. +} +\details{ +read_eos_data uses \code{data.table::fread} to read the data with the + settings \code{showProgress = FALSE} and \code{data.table = FALSE}. Other + arguments can be passed to \code{data.table::fread} if necessary. +} +\author{ +Petter Hopp Petter.Hopp@vetinst.no +} diff --git a/man/read_varekode.Rd b/man/read_varekode.Rd new file mode 100644 index 0000000..e09c9d6 --- /dev/null +++ b/man/read_varekode.Rd @@ -0,0 +1,60 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/read_varekode.R +\name{read_varekode} +\alias{read_varekode} +\title{Manage translation table for varekoder til leveransregisteret} +\usage{ +read_varekode( + filename = "varekoder.csv", + from_path = paste0(set_dir_NVI("LevReg")), + year = NULL, + data_source = "formatted" +) +} +\arguments{ +\item{filename}{Name of the translation table, defaults to "varekoder.csv". +The input is only used when \code{data_source = "formatted"}.} + +\item{from_path}{Path for the translation table for varekoder.} + +\item{year}{Year(s) for fetching the varekoderegister.} + +\item{data_source}{Reads formatted data or raw data. deafult is formatted.} +} +\value{ +\code{read_varekoder} A data frame with the translation table for + varekoder to descriptive text and metadata. +} +\description{ +Read the translation table for varekoder til leveransregisteret. +} +\details{ +The translation table for varekoder comprises the variables: + the leveranseaar, varekode, vare (descriptive text), dyreslag, + vareart, dyrekategori, and varekategorikode. The register covers 2016 + and later. + + \code{read_varekoder} with the argument \code{type = "formatted"} + reads the formatted "varekoder.csv" into a data frame. The standard + settings will read the file from NVI's internal network. If changing + the from_path, the function can be used to read the translation file + from other directories. This can be useful if having a stand alone + app with no connection the NVI's internal network. In other cases, + it should be avoided. + + \code{read_varekoder} with the argument \code{type = "raw"} reads + the raw data as supplied from Landbruksdirektoratet into a data frame. + Thereafter, these can be used to generate the formatted version. + The standard settings will read the file from NVI's internal network + and changing the path should be avoided. +} +\examples{ +\dontrun{ +# Reading from standard directory at NVI's network +varekoder <- read_varekode() +} + +} +\author{ +Petter Hopp Petter.Hopp@vetinst.no +} diff --git a/man/standardize_PJSdata.Rd b/man/standardize_PJSdata.Rd index ee4cce5..b5fe466 100644 --- a/man/standardize_PJSdata.Rd +++ b/man/standardize_PJSdata.Rd @@ -36,7 +36,7 @@ The function performs the following standardizing of data extracted from PJS: \examples{ \dontrun{ # Standardizing sak_m_res - sak_m_res <- standardize_PJSdata(PJSdata = sak_m_res) +sak_m_res <- standardize_PJSdata(PJSdata = sak_m_res) } } diff --git a/notes/develop.R b/notes/develop.R index 385e7d5..e4432d1 100644 --- a/notes/develop.R +++ b/notes/develop.R @@ -16,22 +16,29 @@ pkg <- stringi::stri_extract_last_words(pkg_path) # CREATE PACKAGE SKELETON ---- -# create_NVIpkg_skeleton(license_keyword = "CC BY 4.0") +# create_NVIpkg_skeleton(license_keyword = "BSD_3_clause") # BSD_3_clause # CC BY 4.0 +# INCREASE PACKAGE VERSION IN DESCRIPTION AND NEWS ---- +# NVIpackager::increase_NVIpkg_version(pkg = pkg, +# pkg_path = pkg_path, +# type = "develop", +# document = FALSE) # DOCUMENTATION AND STYLING ---- -# update_loge should be run if a logo has been created (or updated). Thereafter use "readme = TRUE" +# update_logo should be run if a logo has been created (or updated). Thereafter run "document_NVIpkg" with "readme = TRUE". # update_logo(pkg = pkg, pkg_path = pkg_path) # Creates new help files # Should be run before git push when documentation for functions have been changed NVIpackager::document_NVIpkg(pkg = pkg, pkg_path = pkg_path, - style = TRUE, + style = FALSE, contributing = FALSE, readme = FALSE, manual = "update", scope = c("spaces", "line_breaks")) +# filename <- "xxxx.R" +# styler::style_file(path = file.path(pkg_path, "R", filename), scope = I(c("spaces"))) # spelling::spell_check_package(vignettes = TRUE, use_wordlist = TRUE) diff --git a/notes/get_holiday.R b/notes/get_holiday.R new file mode 100644 index 0000000..279eaf1 --- /dev/null +++ b/notes/get_holiday.R @@ -0,0 +1,109 @@ +library(dplyr) +year <- 2023 + +# date +# Date. +# +# day_of_week +# Integer. 1 = Monday, 7 = Sunday +# +# mon_to_fri +# Integer. 1 between Monday and Friday, 0 between Saturday and Sunday +# +# sat_to_sun +# Integer. 1 between Saturday and Sunday, 0 between Monday and Friday +# +# public_holiday +# Integer. 1 if public holiday (helligdag), 0 if not public holiday +# +# freeday +# Integer. 1 if public holiday (helligdag) or sat_to_sun==1, 0 otherwise +# +# workday +# Integer. 1 if freeday==0, 0 if freeday==1 + + +get_holidays <- function (year, + type = "all", + trapped_days = "exclude", + invert = FALSE) { + + ### ARGUMENT CHECKING ---- + # Object to store check-results + checks <- checkmate::makeAssertCollection() + + # Perform checks + datasource <- NVIcheckmate::match_arg(x = type, + choices = c("easter", "holiday", "work", + "trapped", "weekend", "public", "sunday", "saturday", + "non-moveable", "pentacost"), + several.ok = FALSE, + ignore.case = TRUE, + add = checks) + + # Report check-results + checkmate::reportAssertions(checks) + + ### NATIONAL HOLIDAYS ---- + # Calculate Easter day + # reference + K <- floor(year/100) + M <- 15 + floor((3 * K + 3)/4) - floor((8 * K + 13)/25) + S <- 2 - floor((3 * K + 3)/4) + A <- year %% 19 + D <- (19*A+M) %% 30 + R <- floor((D+A/11)/29) + OG <- 21 + D - R + SZ <- 7 - ((year + floor(year/4)+S) %% 7) + OE <- 7 - ((OG-SZ) %% 7) + + easterday <- as.Date(paste0(year, "-03-01")) - 1 + OG + OE +easter <- rep(easterday, 4) + c(-3, -2, 0, 1) +pentacost <- rep(easterday, 3) + c(39, 49, 50) +non_moveable <- as.Date(paste0(year, c("-01-01", "-05-01", "-05-17", "-12-25", "-12-26"))) + +### CATEGORISE INTO HOLIDAYS ---- +dates <- as.data.frame(matrix(data = c(as.Date(paste0(year, "-01-01")):as.Date(paste0(year, "-12-31"))), + dimnames = list(NULL, "date"))) +dates$date <- as.Date(dates$date, origin = "1970-01-01") +dates <- dates %>% +dplyr::mutate(weekday = lubridate::wday(.data$date, week_start=1)) %>% +dplyr::mutate(holiday = dplyr::case_when(.data$weekday %in% c(6, 7) ~ as.character(.data$weekday), +TRUE ~ "0" )) %>% +dplyr::mutate(holiday = dplyr::case_when(.data$date %in% easter ~ "e", +.data$date %in% pentacost ~ "p", +.data$date %in% non_moveable ~ "n", +TRUE ~ holiday)) %>% +dplyr::mutate(behind = dplyr::lag(holiday, 1)) %>% +dplyr::mutate(ahead = dplyr::lead(holiday, 1)) %>% +dplyr::mutate(holiday = dplyr::case_when(.data$ahead != 0 & .data$behind != 0 & .data$holiday == 0 ~ "t", +TRUE ~ holiday)) + +if ("easter" %in% type) { +data[which(data$holiday == "e") , "select"] <- 1 +} +if ("moving" %in% type) { +data[which(data$holiday %in% c("e", "p")) , "select"] <- 1 +} +if ("public" %in% type) { +data[which(data$holiday %in% c("e", "p", "n")), "select"] <- 1 +} +if ("sunday" %in% type) { +data[which(data$weekday == 7) , "select"] <- 1 +} +if ("saturday" %in% type) { +data[which(data$weekday == 6), "select"] <- 1 +} +if ("work" %in% type) { +data[which(data$holiday %in% c("0", "t")), "select"] <- 1 +} +if ("holiday" %in% type) { +data[which(data$holiday %in% c("e", "p", "n", "6", "7")) , "select"] <- 1 +} +if ("trapped" %in% type) { +data[which(data$holiday %in% c("t")), "select"] <- 1 +} +if ("raw" == type) { +data[, "select"] <- 1 +} +} diff --git a/tests/testthat/test_Pkode_2_text.R b/tests/testthat/test_Pkode_2_text.R index 8d094b6..a729a60 100644 --- a/tests/testthat/test_Pkode_2_text.R +++ b/tests/testthat/test_Pkode_2_text.R @@ -34,7 +34,7 @@ test_that("Read Produksjonstilskuddskoder", { # read file Pkoder <- read_Pkode_2_text(filename = "Produksjonstilskuddskoder2_UTF8.csv") - expect_subset(x = c("soknadaar", "soknadmnd", "telledato", "art", "Pkode", "beskrivelse", + expect_subset(x = c("soknadaar", "soknadmnd", "telledato", "Pkode", "Pkodetype", "Pkodeart", "beskrivelse", "enhet", "unike_dyr", "sortering"), choices = colnames(Pkoder)) diff --git a/tests/testthat/test_Prodtilskudd.R b/tests/testthat/test_Prodtilskudd.R index 22c52c2..16f268f 100644 --- a/tests/testthat/test_Prodtilskudd.R +++ b/tests/testthat/test_Prodtilskudd.R @@ -1,4 +1,3 @@ -context("Prodtilskudd") library(NVIdb) library(testthat) @@ -45,6 +44,75 @@ test_that("Read Prodtilskudd", { expect_equal(dim(Pkoder), c(55803, 89)) # check correct version expect_equal(as.vector(unique(Pkoder[, "S\u00F8knads\u00E5r"])), 2019) - expect_equal(as.vector(unique(Pkoder$Telledato)), as.integer(as.Date(c("2019-10-01", "2019-03-01")))) + expect_equal(as.vector(as.integer(as.Date(unique(Pkoder$Telledato)))), as.integer(as.Date(c("2019-10-01", "2019-03-01")))) }) + +test_that("errors for copy_Prodtilskudd", { + + linewidth <- options("width") + options(width = 80) + + expect_error(copy_Prodtilskudd(from_path = "wrong_path", to_path = "./", Pkode_year = "last", Pkode_month = "10"), + regexp = "Directory 'wrong_path' does not exist.", + fixed = TRUE) + + expect_error(copy_Prodtilskudd(from_path = tempdir(), to_path = "wrong_path", Pkode_year = "last", Pkode_month = "10"), + regexp = "Directory 'wrong_path' does not exist.") + + expect_error(copy_Prodtilskudd(from_path = tempdir(), to_path = "./", Pkode_year = "1990", Pkode_month = "10"), + regexp = "Element 1 is not >= 1995", + fixed = TRUE) + + expect_error(copy_Prodtilskudd(from_path = tempdir(), to_path = "./", Pkode_year = "first", Pkode_month = "10"), + regexp = "{'last'}, but is 'first'", + fixed = TRUE) + + expect_error(copy_Prodtilskudd(from_path = tempdir(), to_path = "./", Pkode_year = NULL, Pkode_month = "10"), + regexp = "Must be a subset of {'last'}", + fixed = TRUE) + + expect_error(copy_Prodtilskudd(from_path = tempdir(), to_path = "./", Pkode_year = 2020, Pkode_month = "xx"), + regexp = "Variable 'Pkode_month': Must be a subset of", + fixed = TRUE) + + options(width = unlist(linewidth)) +}) + + + +test_that("errors for read_Prodtilskudd", { + + linewidth <- options("width") + options(width = 80) + + expect_error(read_Prodtilskudd(from_path = file.path(tempdir(), "rubbish")), + regexp = "rubbish' does not", + fixed = TRUE) + + expect_error(read_Prodtilskudd(from_path = paste0(set_dir_NVI("Prodtilskudd"), "FormaterteData/"), + Pkode_year = 1990, + Pkode_month = "both"), + regexp = "Element 1 is not >= 1995", + fixed = TRUE) + + expect_error(read_Prodtilskudd(from_path = paste0(set_dir_NVI("Prodtilskudd"), "FormaterteData/"), + Pkode_year = "first", + Pkode_month = "both"), + regexp = "{'last'}, but is 'first'", + fixed = TRUE) + + expect_error(read_Prodtilskudd(from_path = paste0(set_dir_NVI("Prodtilskudd"), "FormaterteData/"), + Pkode_year = NULL, + Pkode_month = "both"), + regexp = "Must be a subset of {'last'}", + fixed = TRUE) + + expect_error(read_Prodtilskudd(from_path = paste0(set_dir_NVI("Prodtilskudd"), "FormaterteData/"), + Pkode_year = 2020, + Pkode_month = "xx"), + regexp = "Variable 'Pkode_month': Must be a subset of", + fixed = TRUE) + + options(width = unlist(linewidth)) +}) diff --git a/tests/testthat/test_build_query_outbreak.R b/tests/testthat/test_build_query_outbreak.R index 3d6d8d4..d36fc68 100644 --- a/tests/testthat/test_build_query_outbreak.R +++ b/tests/testthat/test_build_query_outbreak.R @@ -54,7 +54,7 @@ test_that("build query HPAI outbreak", { correct_result <- paste("SELECT *", "FROM v2_sak_m_res", - "WHERE aar >= 2020 AND", + "WHERE aar >= 2020 AND aar <= 2022 AND", "(hensiktkode IN ('0100101007', '0100102003', '0100103003', '0200130001', '0200130', '0200130002') OR", "utbrudd_id = '22' OR", "metodekode IN ('070027', '070127', '070130', '070137', '070138', '070149',", @@ -72,7 +72,7 @@ test_that("build query HPAI outbreak", { "ON (v_sakskonklusjon.aar = sak.aar AND", "v_sakskonklusjon.ansvarlig_seksjon = sak.ansvarlig_seksjon AND", "v_sakskonklusjon.innsendelsesnummer = sak.innsendelsesnummer)", - "WHERE sak.aar >= 2020 AND (analyttkode LIKE '01150101%')") + "WHERE sak.aar >= 2020 AND sak.aar <= 2022 AND (analyttkode LIKE '01150101%')") expect_equivalent(query["selection_sakskonklusjon"], correct_result) @@ -87,7 +87,7 @@ test_that("build query P. ovis outbreak", { correct_result <- paste("SELECT *", "FROM v2_sak_m_res", - "WHERE aar >= 2019 AND", + "WHERE aar >= 2019 AND aar <= 2022 AND", "(hensiktkode IN ('0100101044', '0100101023', '0100102007', '0100102',", "'0100103007', '0100103', '0200152', '0200147') OR", "konkl_analyttkode LIKE '0302060104050102%' OR analyttkode_funn LIKE '0302060104050102%')") @@ -101,7 +101,7 @@ test_that("build query P. ovis outbreak", { "ON (v_sakskonklusjon.aar = sak.aar AND", "v_sakskonklusjon.ansvarlig_seksjon = sak.ansvarlig_seksjon AND", "v_sakskonklusjon.innsendelsesnummer = sak.innsendelsesnummer)", - "WHERE sak.aar >= 2019 AND (analyttkode LIKE '0302060104050102%')") + "WHERE sak.aar >= 2019 AND sak.aar <= 2022 AND (analyttkode LIKE '0302060104050102%')") expect_equivalent(query["selection_sakskonklusjon"], correct_result) @@ -115,7 +115,7 @@ test_that("build query maedi outbreak", { correct_result <- paste("SELECT *", "FROM v2_sak_m_res", - "WHERE aar >= 2019 AND", + "WHERE aar >= 2019 AND aar <= 2022 AND", "(hensiktkode IN ('0100104020', '0100104054', '0100105007', '0100105008', '0100106007',", "'0700605', '0400101', '0400109001', '0200113', '0200135', '0200141', '0200163'))") @@ -128,7 +128,7 @@ test_that("build query maedi outbreak", { "ON (v_sakskonklusjon.aar = sak.aar AND", "v_sakskonklusjon.ansvarlig_seksjon = sak.ansvarlig_seksjon AND", "v_sakskonklusjon.innsendelsesnummer = sak.innsendelsesnummer)", - "WHERE sak.aar >= 2019") + "WHERE sak.aar >= 2019 AND sak.aar <= 2022") expect_equivalent(query["selection_sakskonklusjon"], correct_result) diff --git a/tests/testthat/test_cut_slash.R b/tests/testthat/test_cut_slash.R new file mode 100644 index 0000000..0fb91f1 --- /dev/null +++ b/tests/testthat/test_cut_slash.R @@ -0,0 +1,12 @@ +library(NVIdb) +library(testthat) + +test_that("cut_slash", { +expect_equal(cut_slash("C:/temp/"), "C:/temp") + +expect_equal(cut_slash("C:\\temp\\"), "C:\\temp") + +expect_equal(cut_slash(c("C:/temp/", "C:\\temp\\")), c("C:/temp", "C:\\temp")) + +expect_equal(cut_slash(list("C:/temp/", "C:\\temp\\")), c("C:/temp", "C:\\temp")) +}) diff --git a/tests/testthat/test_login.R b/tests/testthat/test_login.R index 5ef600e..57d21ca 100644 --- a/tests/testthat/test_login.R +++ b/tests/testthat/test_login.R @@ -13,7 +13,10 @@ test_that("Log in to db services", { expect_true(as.vector(odbc_connected) >= 1) RODBC::odbcClose(odbc_connected) - }) + odbc_connected <- login_by_credentials_PJS() + expect_true(as.vector(odbc_connected) >= 1) + RODBC::odbcClose(odbc_connected) +}) test_that("Errors or warnings for login", { @@ -28,7 +31,8 @@ test_that("Errors or warnings for login", { db = "y", dbserver = "z", dbport = "x", - dbprotocol = "y"), + dbprotocol = "y", + dbinterface = NULL), regexpr = "ODBC connection failed") options(width = unlist(linewidth)) diff --git a/tests/testthat/test_lokalitet_properties.R b/tests/testthat/test_lokalitet_properties.R index a503dbb..a7e711c 100644 --- a/tests/testthat/test_lokalitet_properties.R +++ b/tests/testthat/test_lokalitet_properties.R @@ -38,6 +38,8 @@ test_that("Correct merging of lokalitet and sone", { correct_result <- cbind(lokaliteter, as.data.frame(c("5,244133012708", "5,06988301405342", "20,3290669999275", "23,2844499984564"), stringsAsFactors = FALSE), as.data.frame(c("59,8665000008897", "61,758017000812", "69,6618500000011", "70,2409500000325"), stringsAsFactors = FALSE) + # as.data.frame(c(5.244133012708, 5.06988301405342, 20.3290669999275, 23.2844499984564), stringsAsFactors = FALSE), + # as.data.frame(c(59.8665000008897, 61.758017000812, 69.6618500000011, 70.2409500000325), stringsAsFactors = FALSE) ) colnames(correct_result) <- c("eier_lokalitetnr", "longitude", "latitude") diff --git a/tests/testthat/test_read_eos_data.R b/tests/testthat/test_read_eos_data.R new file mode 100644 index 0000000..9199f0f --- /dev/null +++ b/tests/testthat/test_read_eos_data.R @@ -0,0 +1,50 @@ +library(NVIdb) +library(testthat) +library(checkmate) + + +test_that("read eos_data", { + # skip if no connection to 'FAG' have been established + skip_if_not(dir.exists(set_dir_NVI("FAG"))) + + # Read data with saksnr + campylobacter <- read_eos_data(eos_table = "proveresultat_campylobacter", + from_path = paste0(set_dir_NVI("EOS"), "RaData/")) + expect_equal(min(substr(campylobacter$saksnr, 1, 4)), "2016") + + checkmate::expect_choice(as.numeric(max(substr(campylobacter$saksnr, 1, 4))), + choices = c((as.numeric(format(Sys.Date(), "%Y")) - 1), as.numeric(format(Sys.Date(), "%Y")))) + + # Read data with Saksnr + ila <- read_eos_data(eos_table = "proveresultat_ila", + from_path = paste0(set_dir_NVI("EOS"), "RaData/"), + year = c(2017:2019)) + expect_equal(min(substr(ila$Saksnr, 1, 4)), "2017") + + expect_equal(max(substr(ila$Saksnr, 1, 4)), "2019") + + ila <- read_eos_data(eos_table = "proveresultat_ila", + from_path = paste0(set_dir_NVI("EOS"), "RaData/"), + year = as.numeric(format(Sys.Date(), "%Y")) - 1) + expect_equal(as.numeric(min(substr(ila$Saksnr, 1, 4))), as.numeric(format(Sys.Date(), "%Y")) - 1) + + expect_equal(as.numeric(max(substr(ila$Saksnr, 1, 4))), as.numeric(format(Sys.Date(), "%Y")) - 1) + +}) + + +test_that("errors for read_eos_data", { + + linewidth <- options("width") + options(width = 80) + + expect_error(read_eos_data(eos_table = NA, from_path = tempdir()), + regexp = "Variable 'eos_table': May not be NA") + + expect_error(read_eos_data(eos_table = "filename.csv", from_path = tempdir()), + regexp = "File\n * does not exist:", + fixed = TRUE) + + options(width = unlist(linewidth)) +}) + diff --git a/tests/testthat/test_set_name_vector.R b/tests/testthat/test_set_name_vector.R new file mode 100644 index 0000000..6a255b1 --- /dev/null +++ b/tests/testthat/test_set_name_vector.R @@ -0,0 +1,25 @@ +library(NVIdb) +library(testthat) + +test_that("utils: set_name_vector", { + + +# Make example data +x <- c("År", "MT regionnr", "MT region", "MT avdelingsnr", "MT avdeling") + +y <- NVIdb:::set_name_vector(x) +expect_equal(unname(y), names(y)) + + +x <- c("Aar" = "År", "MT_regionnr" = "MT regionnr", "MT region", "MT avdelingsnr", "MT avdeling") +y <- NVIdb:::set_name_vector(x) +expect_equal(names(y), + c("Aar", "MT_regionnr", "MT region", "MT avdelingsnr", "MT avdeling")) + +x <- c("Aar" = "År", "MT_regionnr" = "MT regionnr", "MT region" = "MT region", + "MT avdelingsnr" = "MT avdelingsnr", "MT avdeling" = "MT avdeling") +y <- NVIdb:::set_name_vector(x) +expect_equal(names(y), + c("Aar", "MT_regionnr", "MT region", "MT avdelingsnr", "MT avdeling")) + +}) diff --git a/tests/testthat/test_standardize_columns.R b/tests/testthat/test_standardize_columns.R index b6d130b..a4800aa 100644 --- a/tests/testthat/test_standardize_columns.R +++ b/tests/testthat/test_standardize_columns.R @@ -42,9 +42,9 @@ test_that("Standardize colnames from EOS scrapie", { "mottatt_dato" = "2019-02-27 00:00:00", "uttaks_dato_inns" = "2019-02-26 00:00:00", "fodselsdato" = NA, "skrottnr" = "210861", "aar" = "2019", "ansvarlig_seksjon" = "04", "innsendelsesnummer" = "6832", "saksnr" = "2019-04-6832/SC 1437", - "eier_type" = "PROD", "eier_navn" = "EO", "eier_nummer" = "###########", "annen_aktør_type" = "AUTO", "annen_aktør_navn" = "Slakthuset Eidsmo Dullum AS avd Oppdal", - "id_nr" = "60203", "art" = "Sau", "kjennelse" = "Ikke påvist", "sist_oppdatert" = "2020-10-06 01:30:03.427", "annen_aktør_nr" = "123", - "rekvirent_type" = "MTA", "rekvirent_nr" = "M22110", "rekvirent" = "Glåmdal og Østerdal", "avvik_i_registrering" = "0", "antall_und_prover" = "1")) + "eier_type" = "PROD", "eier_navn" = "EO", "eier_nummer" = "###########", "annen_akt\u00F8r_type" = "AUTO", "annen_akt\u00F8r_navn" = "Slakthuset Eidsmo Dullum AS avd Oppdal", + "id_nr" = "60203", "art" = "Sau", "kjennelse" = "Ikke p\u00E5vist", "sist_oppdatert" = "2020-10-06 01:30:03.427", "annen_akt\u00F8r_nr" = "123", + "rekvirent_type" = "MTA", "rekvirent_nr" = "M22110", "rekvirent" = "Gl\u00E5mdal og \u00D8sterdal", "avvik_i_registrering" = "0", "antall_und_prover" = "1")) # Make a vector with correct column names after translation @@ -86,7 +86,7 @@ test_that("colClasses for csv-files", { colclasses <- standardize_columns(data = paste0(set_dir_NVI("Prodtilskudd"), "StotteData/Produksjonstilskuddskoder2_UTF8.csv"), property = "colclasses") # Make a vector with correct column names after translation - correct_result <- c("art" = "character", "beskrivelse" = "character", "enhet" = "character", "Pkode_maaned" = "character", "telledato" = "character") + correct_result <- c("beskrivelse" = "character", "enhet" = "character", "soknadmnd" = "character", "telledato" = "character") # Compare Add fylke, current fylkenr and current fylke with correct result expect_equivalent(colclasses, @@ -181,7 +181,7 @@ test_that("Standardize English collabels", { # Make a vector with correct column names after translation - correct_result <- c("Søknadsår", "Gjeldende produsentnr", "Producer no.", "Producer no.", "Organisation number", + correct_result <- c("S\u00F8knads\u00E5r", "Gjeldende produsentnr", "Producer no.", "Producer no.", "Organisation number", "Municipality no.", "Municipality") # Compare Add fylke, current fylkenr and current fylke with correct result @@ -197,7 +197,7 @@ test_that("Column order", { # Generate column labels # Example with produksjonstilskudd in English df <- as.data.frame(cbind("soknadaar" = "2020", "gjeldende_prodnr8" = "30303030", "Orgnr" = 99999999, - "prodnr10" = "3030303030", "Fjørfe" = 1, "prodnr8" = "30303030", + "prodnr10" = "3030303030", "Fj\u00F8rfe" = 1, "prodnr8" = "30303030", "orgnr" = "988888888", "komnr" = "3030", "kommune" = "Nesbyen")) diff --git a/tests/testthat/test_varekode.R b/tests/testthat/test_varekode.R new file mode 100644 index 0000000..3df41c0 --- /dev/null +++ b/tests/testthat/test_varekode.R @@ -0,0 +1,83 @@ +library(NVIdb) +library(testthat) +library(checkmate) + +test_that("Read varekode", { + # skip if no connection to 'FAG' have been established + skip_if_not(dir.exists(set_dir_NVI("FAG"))) + + # read file + varekoder <- read_varekode(filename = "varekoder.csv", + data_source = "formatted", + year = c(2020:2021)) + + expect_subset(x = c("leveranseaar", "varekode", "vare", "dyreslag", "varetype", "vareart", "dyrekategori", "varekategorikode"), + choices = colnames(varekoder)) + + expect_equal(unique(varekoder$leveranseaar), + c(2020, 2021)) + + varekoder <- read_varekode(filename = "varekoder.csv", + data_source = "formatted", + year = c("2020", "2021")) + + expect_equal(unique(varekoder$leveranseaar), + c(2020, 2021)) + + varekoder <- read_varekode(year = 2020, data_source = "raw") + + expect_subset(x = c("varekode", "vare", "dyreslag"), + choices = colnames(varekoder)) + + expect_subset(x = c("STORFE", "GRIS", "HEST", "VILT", "ULL", "H\u00D8NS"), + choices = varekoder$dyreslag) + + # Test of source file in UTF-8 + varekoder <- read_varekode(year = 2019, data_source = "raw") + + expect_subset(x = c("STORFE", "GRIS", "HEST", "VILT", "ULL", "H\u00D8NS"), + choices = varekoder$dyreslag) + + +}) + +test_that("errors for read_varekode", { + + linewidth <- options("width") + options(width = 80) + + expect_error(read_varekode(filename = NULL, + from_path = set_dir_NVI("LevReg"), + data_source = "formatted"), + regexp = "Variable 'filename': Must be of type 'character', not 'NULL'", + fixed = TRUE) + + expect_error(read_varekode(filename = "filename.csv", + from_path = set_dir_NVI("LevReg"), + data_source = "formatted"), + regexp = "File\n * does not exist:", + fixed = TRUE) + + expect_error(read_varekode(filename = "varekoder.csv", + from_path = set_dir_NVI("LevReg"), + data_source = "prepared", + year = "2020"), + regexp = "Variable 'data_source': Must be a subset of {'formatted','raw'}", + fixed = TRUE) + + expect_error(read_varekode(filename = "varekoder.csv", + from_path = set_dir_NVI("LevReg"), + data_source = "formatted", + year = 1990), + regexp = "Element 1 is not >= 1995", + fixed = TRUE) + + expect_error(read_varekode(filename = "filename.csv", + from_path = set_dir_NVI("LevReg"), + data_source = "formatted", + year = "first"), + regexp = "Must be element of set {'last'}", + fixed = TRUE) + + options(width = unlist(linewidth)) +}) diff --git a/vignettes/Contribute_to_NVIdb.Rmd b/vignettes/Contribute_to_NVIdb.Rmd index c6fe21f..ae4f1af 100644 --- a/vignettes/Contribute_to_NVIdb.Rmd +++ b/vignettes/Contribute_to_NVIdb.Rmd @@ -13,10 +13,8 @@ vignette: > %\VignetteEngine{knitr::rmarkdown} %\VignetteIndexEntry{Contribute to NVIdb} %\VignetteEncoding - --- - ```{r, include = FALSE} NVIpkg <- params$NVIpkg NVIpkg_inline <- paste0("`", NVIpkg, "`") @@ -25,7 +23,6 @@ knitr::opts_chunk$set( collapse = TRUE, comment = "#>" ) - ```