diff --git a/.gitignore b/.gitignore index a5b5694..d04eadd 100644 --- a/.gitignore +++ b/.gitignore @@ -20,7 +20,6 @@ # RStudio files .Rproj.user/ - # produced vignettes vignettes/*.html vignettes/*.pdf @@ -40,7 +39,3 @@ vignettes/*.pdf # R Environment Variables .Renviron -# Directories that shouldn't be syncronized -nosync/ -Meta -.Ruserdata diff --git a/CONTRIBUTING.md b/CONTRIBUTING.md index 5a1f9ad..5a0d20f 100644 --- a/CONTRIBUTING.md +++ b/CONTRIBUTING.md @@ -83,7 +83,7 @@ NVIverse packages NVIrpackages Public -Keeps a table of the R-Packages in +Keeps a table of the R packages in NVIverse @@ -157,9 +157,11 @@ development guidelines below. ## Development guidelines -If you want to contribute code, you are welcome to do so. Please try to -adhere to some principles and style convention used for -`NVIverse`-packages. +If you want to contribute code, you are welcome to do so. You will find +a description of the code conventions, which have been used, in the +vignette “NVIverse code conventions” in the package `NVIpackager`. A +summary of the principles and style convention used for +`NVIverse`-packages is given below. - Please limit the number of package dependencies for `NVIdb`. The use of base functions is much appreciated. diff --git a/DESCRIPTION b/DESCRIPTION index 9e72632..b537d0e 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,7 +1,7 @@ Package: NVIdb Title: Tools to facilitate the use of NVI's databases -Version: 0.10.1 -Date: 2023-05-31 +Version: 0.11.0 +Date: 2024-01-24 Authors@R: c(person(given = "Petter", family = "Hopp", @@ -34,29 +34,27 @@ Imports: DBI, dplyr, keyring, - knitr, magrittr, odbc, - remotes, - rlang, - rmarkdown, RODBC, RPostgreSQL, - R.rsp, - shiny, snakecase, stats, - svDialogs, utils, - NVIcheckmate (>= 0.4.0), - NVIrpackages + NVIcheckmate (>= 0.7.0) Suggests: covr, + desc, devtools, + knitr, + R.rsp, + remotes, + rmarkdown, spelling, testthat, tibble, - NVIpackager + NVIpackager, + NVIrpackages Remotes: NorwegianVeterinaryInstitute/NVIcheckmate, NorwegianVeterinaryInstitute/NVIrpackages, diff --git a/LICENSE b/LICENSE index 5b29a59..370bee2 100644 --- a/LICENSE +++ b/LICENSE @@ -1,6 +1,6 @@ BSD 3-Clause License -Copyright (c) 2021, Norwegian Veterinary Institute +Copyright (c) 2021 - 2024 Norwegian Veterinary Institute All rights reserved. Redistribution and use in source and binary forms, with or without diff --git a/NAMESPACE b/NAMESPACE index b727706..eea3359 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -49,6 +49,8 @@ export(read_sonetilhorighet) export(read_varekode) export(remove_PAT) export(remove_credentials) +export(retrieve_PJSdata) +export(select_PJSdata_for_value) export(set_PAT) export(set_credentials) export(set_credentials_EOS) @@ -58,5 +60,5 @@ export(set_disease_parameters) export(standardize_PJSdata) export(standardize_columns) export(standardize_eos_data) +export(transform_code_combinations) importFrom(magrittr,"%>%") -importFrom(rlang,.data) diff --git a/NEWS b/NEWS index f6d42f6..47f6041 100644 --- a/NEWS +++ b/NEWS @@ -1,24 +1,49 @@ -NVIdb 0.10.1 - (2023-05-31) +NVIdb 0.11.0 - (2024-01-24) ---------------------------------------- New features: -- add_PJS_code_description is extended so that analytt and kjennelse at sakskonklusjon-level can be translated when using the arguments `PJS_variable_type` = "auto" and `new_column` = "auto". +- Created `retrieve_PJS_data` to retrieve and standardisation of PJSdata. + +- Created `transform_code_values` to easy transform few code combinations into other values. + +- Created `select_PJSdata_for_values` to perform inclusion/exclusion of rows in PJSdata based on coded values. For codes ending with "%", sub levels are included. + +- `read_Prodtilskudd` now accepts the argument `exctracted_date`. + +- The PJS- and EOS-wrappers for the login functions `login`, `login_by_credentials` and `login_by_input` now accepts arguments to be passed to the parent functions. Thereby, one may change login information for the databases PJS and EOS by modifying the scripts until a new version of the package `NVIconfig` is available and installed. Bug fixes: -- +- Corrected `read_varekode` so accepts old source files in latin1. Other changes: -- Improved help by standardising argument description for a few functions. +- Modified help for several functions. + +- Modified `set_disease_parameters` to make the name of the input arguments easier to comprehend. New arguments are `analytt2delete`, `include_missing_art` and `selection_parameters`. The argument `selection_parameters` accepts both a "purpose" file and a list (as generated by as `set_disease_parameters`) as input. BREAKING CHANGES: -- +- In `set_disease_parameters` the arguments `missing_art` and `file` is deprecated. These are replaced by `include_missing_art` and `selection_parameters`, respectively. If using the old arguments, the input will be transferred to the new arguments. + +- `set_PAT`, `get_PAT`, and `remove_PAT` was deprecated.These should be replaced by corresponding functions in package `gitcreds`. + + +NVIdb 0.10.1 - (2023-05-31) +---------------------------------------- + +New features: + +- `add_PJS_code_description` is extended so that analytt and kjennelse at sakskonklusjon-level can be translated when using the arguments `PJS_variable_type` = "auto" and `new_column` = "auto". + + +Other changes: + +- Improved help by standardising argument description for a few functions. NVIdb 0.10.0 - (2023-04-18) @@ -26,16 +51,16 @@ NVIdb 0.10.0 - (2023-04-18) New features: -- Created standardize_eos_data for standardisation of column names etc. in eos-data. +- Created `standardize_eos_data` for standardisation of column names etc. in eos-data. -- set_dir_NVI now accepts argument `slash`. set `slash = FALSE` to remove ending slash. +- `set_dir_NVI` now accepts argument `slash`. set `slash = FALSE` to remove ending slash. -- add_PJS_code_description now accepts the argument `impute_old_when_missing`. +- `add_PJS_code_description` now accepts the argument `impute_old_when_missing`. Bug fixes: -- add_PJS_code_description now performs back translation also in the case that the code has expired ("utg\u00E5tt"). +- `add_PJS_code_description` now performs back translation also in the case that the code has expired ("utg\u00E5tt"). Other changes: diff --git a/R/NVIdb-deprecated.R b/R/NVIdb-deprecated.R index 9300700..7c51391 100644 --- a/R/NVIdb-deprecated.R +++ b/R/NVIdb-deprecated.R @@ -3,7 +3,8 @@ #' versions of NVIdb only, and may be defunct as soon as the next release. #' When possible, alternative functions are mentioned. Help pages for #' deprecated functions are available at \code{help("-deprecated")}. -#' @details \code{add_produsent} was deprecated 2022-05-02 as other properties +#' @details \code{add_produsent} was deprecated from v0.8.0 released 2022-08-25 +#' as other properties #' than 'gjeldende_prodnr8' could not be included without breaking backward #' compatibility. Use \code{add_produsent_properties} instead and ensure #' to set the parameter \code{impute_old_when_missing = TRUE} when translating @@ -11,6 +12,10 @@ #' \code{impute_old_when_missing = FALSE} when translating from "prodnr8" to #' other properties. #' +#' \code{set_PAT}, \code{get_PAT}, and \code{remove_PAT} was deprecated from +#' v0.11.0 released 2023-09-22. The functions were never taken into use. +#' Functions from the much better package \code{gitcreds} should be used instead. +#' #' @param \dots (arguments) #' @return (results) #' @name NVIdb-deprecated @@ -20,6 +25,9 @@ #' #' @examples #' \dontrun{ -#' add_produsent(...) ### -- use \code{\link{add_produsent_properties}} instead +#' add_produsent(...) ### -- use \code{\link{add_produsent_properties}} instead. +#' set_PAT(...) ### -- use \code{\link{gitcreds::gitcreds_set}} instead. +#' get_PAT(...) ### -- use \code{\link{gitcreds::gitcreds_get}} instead. +#' remove_PAT(...) ### -- use \code{\link{gitcreds::gitcreds_delete}} instead. #' } NULL diff --git a/R/add_MT_omrader.R b/R/add_MT_omrader.R index 0b10577..0e8c203 100644 --- a/R/add_MT_omrader.R +++ b/R/add_MT_omrader.R @@ -155,4 +155,3 @@ add_MT_omrader <- function(data, # To avoid checking of the variable kommune_fylke as default input argument in the function utils::globalVariables("komnr_2_MT_omrader") - diff --git a/R/add_PJS_code_description.R b/R/add_PJS_code_description.R index ca2fe3d..bdc1b69 100644 --- a/R/add_PJS_code_description.R +++ b/R/add_PJS_code_description.R @@ -1,28 +1,28 @@ #' @title Manage translation of PJS codes to descriptive text -#' @description Functions to adds a column with descriptive text for a column -#' with PJS codes in a data frame with PJS data. You may also use backwards -#' translation from descriptive text to PJS code. In addition there are +#' @description Functions to adds a column with descriptive text for a column +#' with PJS codes in a data frame with PJS data. You may also use backwards +#' translation from descriptive text to PJS code. In addition there are #' functions to read and copy an updated version of the PJS code registers. #' @details Export of data from PJS will produce data frames in which many columns -#' have coded data. These need to be translated into descriptive text to +#' have coded data. These need to be translated into descriptive text to #' increase readability. #' -#' \code{add_PJS_code_description} can be used to translate the codes into -#' descriptive text. In a data frame with coded values, the function can -#' return a data frame with the descriptive text in a new column. As default, -#' the descriptive text is input in a new column to the right of the column +#' \code{add_PJS_code_description} can be used to translate the codes into +#' descriptive text. In a data frame with coded values, the function can +#' return a data frame with the descriptive text in a new column. As default, +#' the descriptive text is input in a new column to the right of the column #' with codes. #' -#' \code{add_PJS_code_description} uses the pre made translation table -#' "PJS_codes_2_text.csv". The data need to be loaded by +#' \code{add_PJS_code_description} uses the pre made translation table +#' "PJS_codes_2_text.csv". The data need to be loaded by #' \code{read_PJS_codes_2_text} before running \code{add_PJS_code_description}, -#' see example. The file "PJS_codes_2_text.csv" is normally updated every night +#' see example. The file "PJS_codes_2_text.csv" is normally updated every night #' from PJS. #' -#' Currently, the translation table has PJS codes and the corresponding -#' description for the PJS variable types given in the first column in the table +#' Currently, the translation table has PJS codes and the corresponding +#' description for the PJS variable types given in the first column in the table #' below. The standardized PJS column name is given in the column "code colname" for -#' which the "PJS variable type" will translate into descriptive text. The standard +#' which the "PJS variable type" will translate into descriptive text. The standard #' new column name is given in the column "new column". #' #' \tabular{llll}{ @@ -59,81 +59,81 @@ #' } #' #' If \code{code_colname} is a vector of standardized PJS column names -#' and a subset of "code column" in the table above, you may facilitate -#' coding by setting \code{PJS_variable_type = "auto"} and/or -#' \code{new_colname = "auto"}. Then the \code{PJS_variable_type} will be -#' automatically set according to the table above (for "artkode" -#' \code{PJS_variable_type = "art"} will be chosen). Likewise, the +#' and a subset of "code column" in the table above, you may facilitate +#' coding by setting \code{PJS_variable_type = "auto"} and/or +#' \code{new_colname = "auto"}. Then the \code{PJS_variable_type} will be +#' automatically set according to the table above (for "artkode" +#' \code{PJS_variable_type = "art"} will be chosen). Likewise, the #' \code{new_column} will be automatically set according to the table above. #' #' \code{position} is used to give the position if the new columns in the -#' data frame. For \code{position = "right"} the new variables are placed -#' to the right of the code_variable. Likewise, for \code{position = "left"} -#' the new variables are placed to the left of the code_variable. If -#' \code{position = "first"} or \code{position = "last"} the new columns are -#' placed first or last, respectively, in the data frame. A special case -#' occurs for \code{position = "keep"} which only has meaning when the new -#' column has the same name as an existing column and overwrite = TRUE. In -#' these cases, the existing column will be overwritten with new data and +#' data frame. For \code{position = "right"} the new variables are placed +#' to the right of the code_variable. Likewise, for \code{position = "left"} +#' the new variables are placed to the left of the code_variable. If +#' \code{position = "first"} or \code{position = "last"} the new columns are +#' placed first or last, respectively, in the data frame. A special case +#' occurs for \code{position = "keep"} which only has meaning when the new +#' column has the same name as an existing column and overwrite = TRUE. In +#' these cases, the existing column will be overwritten with new data and #' have the same position. #' -#' \code{backward = TRUE} can be used to translate from descriptive text and -#' back to PJS codes. This intended for cases where the PJS code has been lost -#' (for example in EOS data) or when data from other sources should be translated -#' to codes to be able to use the code hierarchy for further processing of the -#' data. Back translation ignores case. Be aware that the back translation is +#' \code{backward = TRUE} can be used to translate from descriptive text and +#' back to PJS codes. This intended for cases where the PJS code has been lost +#' (for example in EOS data) or when data from other sources should be translated +#' to codes to be able to use the code hierarchy for further processing of the +#' data. Back translation ignores case. Be aware that the back translation is #' most useful for short descriptive text strings, as longer strings may have been -#' shortened and the risk of misspelling and encoding problems is larger. For some -#' descriptive text strings, there are no unique translation. In these cases, +#' shortened and the risk of misspelling and encoding problems is larger. For some +#' descriptive text strings, there are no unique translation. In these cases, #' the code value is left empty. #' -#' \code{read_PJS_codes_2_text} reads the file "PJS_codes_2_text.csv" into a -#' data frame that can be used by \code{add_PJS_code_description}. In standard -#' setting will the file read in the latest updated file from NVI's internal -#' network. If changing the \code{from_path}, the function can be used to read +#' \code{read_PJS_codes_2_text} reads the file "PJS_codes_2_text.csv" into a +#' data frame that can be used by \code{add_PJS_code_description}. In standard +#' setting will the file read in the latest updated file from NVI's internal +#' network. If changing the \code{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. #' -#' PJS_codes_2_text.csv has the following columns: c("type", "kode", "navn", -#' "utgatt_dato"), where "type" is the PJS variable type as listed above (for -#' example hensikt), "kode" is the variable with the PJS code, "navn" is the text -#' describing the code, and "utgatt_dato" is the date for last date that the +#' PJS_codes_2_text.csv has the following columns: c("type", "kode", "navn", +#' "utgatt_dato"), where "type" is the PJS variable type as listed above (for +#' example hensikt), "kode" is the variable with the PJS code, "navn" is the text +#' describing the code, and "utgatt_dato" is the date for last date that the #' code was valid (NA if still valid). If translation tables are needed for -#' other PJS variables, a data frame with the same column definition can be +#' other PJS variables, a data frame with the same column definition can be #' constructed to translate new variables. #' -#' \code{copy_PJS_codes_2_text} copies the file pjsCodeDescriptions.csv to +#' \code{copy_PJS_codes_2_text} copies the file pjsCodeDescriptions.csv to #' a given directory. #' #' @param data [\code{data.frame}] \cr #' PJS data with at least one column that have codes for a PJS variable. #' @param translation_table [\code{data.frame}] \cr -#' Table with the code and the description for PJS variables. Defaults to +#' Table with the code and the description for PJS variables. Defaults to #' "PJS_codes_2_text". #' @param PJS_variable_type [\code{character}] \cr -#' One or more PJS variables, for example "hensikt". See details for a list -#' of all PJS variables included in the pre made translation table -#' "pjscode_2_descriptions.csv". If more than one code type should be translated, -#' they can be given in the vector. You may also use argument -#' \code{PJS_variable_type = "auto"}, if \code{code_colname} have standardized +#' One or more PJS variables, for example "hensikt". See details for a list +#' of all PJS variables included in the pre made translation table +#' "pjscode_2_descriptions.csv". If more than one code type should be translated, +#' they can be given in the vector. You may also use argument +#' \code{PJS_variable_type = "auto"}, if \code{code_colname} have standardized #' PJS column names only, see details. #' @param code_colname [\code{character}] \cr -#' The name of the column with codes that should be translated. If several codes +#' The name of the column with codes that should be translated. If several codes #' should be translated, a vector with the names of the coded variables should be given. #' @param new_column [\code{character}] \cr -#' The name of the new column with the text describing the code. If several -#' codes should be translated, a vector with the new column names should be -#' given. You may also use argument \code{new_column = "auto"}, if \code{code_colname} +#' The name of the new column with the text describing the code. If several +#' codes should be translated, a vector with the new column names should be +#' given. You may also use argument \code{new_column = "auto"}, if \code{code_colname} #' have standardized PJS column names only, see details. #' @param position [\code{character}] \cr -#' Position for the new columns, can be one of c("first", "left", "right", -#' "last", "keep"). If several codes should be translated, either one value -#' to be applied for all may be given or a vector with specified position +#' Position for the new columns, can be one of c("first", "left", "right", +#' "last", "keep"). If several codes should be translated, either one value +#' to be applied for all may be given or a vector with specified position #' for each code to be translated should be given. Defaults to "right". #' @template overwrite #' @param backward [\code{logical(1)}] \cr -#' If \code{TRUE}, it translates from descriptive text and back to PJS code, +#' If \code{TRUE}, it translates from descriptive text and back to PJS code, #' see details. Defaults to \code{FALSE}. #' @param impute_old_when_missing [\code{logical(1)}] \cr #' Should existing value be transferred if no value for the code is found? @@ -143,23 +143,23 @@ #' @param from_path [\code{character(1)}] \cr #' Path for the source translation table for PJS codes. #' @param to_path [\code{character(1)}] \cr -#' Path for the target translation table for PJS codes when copying the +#' Path for the target translation table for PJS codes when copying the #' translation table. #' -#' @return \code{add_PJS_code_description} A data frame where the description text -#' for the PJS code has been added in the column to the right of the column +#' @return \code{add_PJS_code_description} A data frame where the description text +#' for the PJS code has been added in the column to the right of the column #' with the code. If the input is a tibble, it will be transformed to a data frame. #' -#' \code{read_PJS_codes_2_text} A data frame with the translation table for PJS -#' codes as read from the source csv-file. If not changing standard input, the +#' \code{read_PJS_codes_2_text} A data frame with the translation table for PJS +#' codes as read from the source csv-file. If not changing standard input, the #' standard file at NVI's internal network is read. #' -#' \code{copy_PJS_codes_2_text} Copies the source translation table for PJS codes -#' to another location. If the target file already exists the source file is only +#' \code{copy_PJS_codes_2_text} Copies the source translation table for PJS codes +#' to another location. If the target file already exists the source file is only #' copied if it is newer than the target file. #' #' @author Petter Hopp Petter.Hopp@@vetinst.no -#' @importFrom rlang .data +# @importFrom rlang .data #' @export #' @examples #' \dontrun{ @@ -188,20 +188,20 @@ #' PJS_variable_type = c("auto"), #' code_colname = c("artkode", "hensiktkode", "konklusjonkode"), #' new_column = c("auto")) -#' +#' #' # Translating art with species and breed names to only species names -#' # First the text in art is back-translated to the artkode -#' newdata4 <- add_PJS_code_description(data = olddata, +#' # First the text in art is back-translated to the artkode +#' newdata4 <- add_PJS_code_description(data = olddata, #' PJS_variable_type = "artrase", #' code_colname = "art", #' new_column = "artkode", #' backward = TRUE, -#' impute_old_when_missing = TRUE) -#' +#' impute_old_when_missing = TRUE) +#' #' # Thereafter, the code is translated to art #' # By using `impute_old_when_missing = TRUE`, you ensure that text that cannot #' # be translated back to code, is reported as text in the end result. -#' newdata4 <- add_PJS_code_description(data = newdata4, +#' newdata4 <- add_PJS_code_description(data = newdata4, #' PJS_variable_type = "art", #' code_colname = "artkode", #' new_column = "art", @@ -219,7 +219,7 @@ add_PJS_code_description <- function(data, overwrite = FALSE, backward = FALSE, impute_old_when_missing = FALSE) { - + if (PJS_variable_type[1] == "auto" | new_column[1] == "auto") { code_description_colname <- NVIdb::PJS_code_description_colname if (isTRUE(backward)) { @@ -229,11 +229,11 @@ add_PJS_code_description <- function(data, dplyr::left_join(code_description_colname, by = "code_colname") PJS_types_selected <- subset(PJS_types_selected, !is.na(PJS_types_selected$type)) } - + # ARGUMENT CHECKING ---- # Object to store check-results checks <- checkmate::makeAssertCollection() - + # Perform checks # data checkmate::assert_data_frame(data, add = checks) @@ -292,7 +292,7 @@ add_PJS_code_description <- function(data, # deparse(substitute(data)), "`" ), add = checks) - + # position NVIcheckmate::assert_subset_character(x = unique(position), choices = c("first", "left", "right", "last", "keep"), add = checks) # overwrite @@ -301,35 +301,35 @@ add_PJS_code_description <- function(data, checkmate::assert_flag(backward, add = checks) # impute_old_when_missing checkmate::assert_flag(impute_old_when_missing, add = checks) - + # Report check-results checkmate::reportAssertions(checks) - + # PREPARE ARGUMENTS ---- # Generates PJS_variable_type if "auto". # new_column was generated above because the new column names should be checked in the argument checking if (PJS_variable_type[1] == "auto") { PJS_variable_type <- PJS_types_selected$type } - - + + # Transforms position to a vector with the same length as number of PJS variables to be translated if (length(position) == 1 & length(code_colname) > 1) {position <- rep(position, length(code_colname))} - + # In bakcward translation, imputation of old if missing must be performed after original case have been restored, # i.e. it cannot be done by add_new_column, but must be done afterwards. impute_old_when_missing_backward <- impute_old_when_missing if (isTRUE(backward) & isTRUE(impute_old_when_missing)) { impute_old_when_missing <- FALSE } - - + + # runs the translation for several PJS variables at a time if wanted for (i in 1:length(code_colname)) { - + # Make a subset with only the codes that is relevant for the actual variabel code_2_description <- translation_table[base::which(translation_table$type == PJS_variable_type[i]), ] - + # Transform the translation file in the case that backward translation should be used if (isTRUE(backward)) { # Removes breeds from table if type = "art" @@ -341,25 +341,38 @@ add_PJS_code_description <- function(data, } # Removes non-unique description text, usually levels without name, i.e. "-" # Swips navn - kode + code_2_description$navn <- tolower(code_2_description$navn) + code_2_description <- unique(code_2_description) + column_names <- colnames(code_2_description) + navn_nr <- which(column_names == "navn") + kode_nr <- which(column_names == "kode") + column_names[c(navn_nr, kode_nr)] <- c("kode", "navn") + colnames(code_2_description) <- column_names code_2_description <- code_2_description %>% - dplyr::mutate(navn = tolower(.data$navn)) %>% - dplyr::distinct() %>% - dplyr::rename(kode = .data$navn, navn = .data$kode) %>% + dplyr::add_count(dplyr::across(c("type", "kode")), name = "antall") + + + # code_2_description <- code_2_description %>% + # dplyr::mutate(navn = tolower(.data$navn)) %>% + # dplyr::distinct() %>% + # dplyr::rename(kode = .data$navn, navn = .data$kode) %>% # dplyr::filter(is.na(.data$utgatt_dato)) %>% - dplyr::add_count(.data$type, .data$kode, name = "antall") %>% - dplyr::filter(.data$antall == 1) %>% - dplyr::select(-.data$antall) - + # dplyr::add_count(.data$type, .data$kode, name = "antall") %>% + # dplyr::filter(.data$antall == 1) %>% + # dplyr::select(-.data$antall) + code_2_description <- subset(code_2_description, code_2_description$antall == 1) + code_2_description$antall <- NULL + # Transforms code_colname in data to lower case. data$code_colname_org_case <- 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)), ] - + # # Changes the name of navn to text wanted in the df (txtvarname) # base::colnames(code_2_description)[base::which(base::colnames(code_2_description)=="navn")] <- new_column - + # Calls function that adds description at the position = position in the relation to the code data <- add_new_column(data, ID_column = code_colname[i], @@ -370,7 +383,7 @@ add_PJS_code_description <- function(data, position = position[i], overwrite = overwrite, impute_old_when_missing = impute_old_when_missing) - + if (isTRUE(backward)) { # Restores original case in code_colname @@ -389,4 +402,3 @@ add_PJS_code_description <- function(data, # To avoid checking of the variable kommune_fylke as default input argument in the function utils::globalVariables("PJS_codes_2_text") - diff --git a/R/add_kommune_fylke.R b/R/add_kommune_fylke.R index 164b422..25e28ef 100644 --- a/R/add_kommune_fylke.R +++ b/R/add_kommune_fylke.R @@ -56,7 +56,7 @@ #' fylkenr to fylke to given directory. If the target file already exists, the source file is copied only when it is newer than the target file. #' #' @author Petter Hopp Petter.Hopp@@vetinst.no -#' @importFrom rlang .data +# @importFrom rlang .data #' @export #' @examples #' \dontrun{ @@ -121,14 +121,23 @@ add_kommune_fylke <- function(data, # For fylkenr, select the fylke where most kommuner is within the fylke. This to avoid fylkenr to be translated to fylker # where one or a few kommuner has been relocated. - code_2_new <- code_2_new %>% - dplyr::rename(antall = .data$komnr) %>% - dplyr::distinct() %>% - dplyr::group_by(.data$fylkenr) %>% - dplyr::mutate(maxantall = max(.data$antall)) %>% - dplyr::ungroup() %>% - dplyr::filter(.data$maxantall == .data$antall) %>% - dplyr::select(-.data$antall, -.data$maxantall) + # code_2_new <- code_2_new %>% + # dplyr::rename(antall = dplyr::all_of("komnr")) %>% + # dplyr::distinct() %>% + # dplyr::group_by(.data$fylkenr) %>% + # dplyr::mutate(maxantall = max(.data$antall)) %>% + # dplyr::ungroup() # %>% + colnames(code_2_new)[which(colnames(code_2_new) == "komnr")] <- "antall" + code_2_new <- unique(code_2_new) + aggregated_data <- stats::aggregate(stats::as.formula("antall ~ fylkenr"), data = code_2_new, FUN = max) + colnames(aggregated_data)[2] <- "max_antall" + code_2_new <- merge(code_2_new, aggregated_data, by = "fylkenr", all.x = TRUE) + # code_2_new <- code_2_new[order(filnavn$fra_dato, filnavn$til_dato, decreasing = TRUE), ] + + code_2_new <- subset(code_2_new, code_2_new$max_antall == code_2_new$antall) + code_2_new[, c("antall", "maxantall")] <- c(NULL, NULL) + # dplyr::filter(.data$maxantall == .data$antall) %>% + # dplyr::select(-.data$antall, -.data$maxantall) # Removes tibble in case it makes trouble later code_2_new <- as.data.frame(code_2_new) @@ -156,4 +165,3 @@ add_kommune_fylke <- function(data, # To avoid checking of the variable kommune_fylke as default input argument in the function utils::globalVariables("kommune_fylke") - diff --git a/R/add_lokalitet.R b/R/add_lokalitet.R index 43954ef..cd3665d 100644 --- a/R/add_lokalitet.R +++ b/R/add_lokalitet.R @@ -3,58 +3,58 @@ #' zone and/or geo-coordinates. In addition there are function #' to read the translation table. #' @details \code{add_lokalitet} can be used to add aquaculture -#' zone and/or geo-coordinates to aquaculture sites. The new +#' zone and/or geo-coordinates to aquaculture sites. The new #' columns can be one or more of c("sone", "EastUTM_33N_WGS84", #' "NorthUTM_33N_WGS84", "Longitude_WGS84", "Latitude_WGS84"). -#' If the new columns in the result data frame should have -#' other names, \code{new_column} can be input as a named +#' If the new columns in the result data frame should have +#' other names, \code{new_column} can be input as a named #' vector, see examples. #' -#' \code{position} is used to give the position if the new columns -#' in the data.frame. For \code{position = "right"} the new -#' variables are placed to the right of the code_variable. -#' Likewise, for \code{position = "left"} the new variables -#' are placed to the left of the code_variable. If -#' \code{position = "first"} or \code{position = "last"} the +#' \code{position} is used to give the position if the new columns +#' in the data.frame. For \code{position = "right"} the new +#' variables are placed to the right of the code_variable. +#' Likewise, for \code{position = "left"} the new variables +#' are placed to the left of the code_variable. If +#' \code{position = "first"} or \code{position = "last"} the #' new columns are placed first or last, respectively, in the -#' data frame. A special case occurs for \code{position = "keep"} -#' which only has meaning when the new column has the same name -#' as an existing column and \code{overwrite = TRUE}. In these -#' cases, the existing column will be overwritten with new data +#' data frame. A special case occurs for \code{position = "keep"} +#' which only has meaning when the new column has the same name +#' as an existing column and \code{overwrite = TRUE}. In these +#' cases, the existing column will be overwritten with new data #' and have the same position. #' -#' \code{read_sonetilhorighet} reads the file "sonetilhorighet.txt" -#' into a data frame that can be used by other routines. Standard -#' setting will the file read in the latest updated 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. +#' \code{read_sonetilhorighet} reads the file "sonetilhorighet.txt" +#' into a data frame that can be used by other routines. Standard +#' setting will the file read in the latest updated 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. #' -#' @param data [\code{data.frame}]\cr +#' @param data [\code{data.frame}]\cr #' Data with a column with an aquaculture site number ("LokNr") -#' @param translation_table [\code{data.frame}]\cr +#' @param translation_table [\code{data.frame}]\cr #' Table for translating from loknr to the property in question. -#' @param code_column [\code{character(1)}]\cr +#' @param code_column [\code{character(1)}]\cr #' The column with the coded value. Valid values are one of c("LokNr"). If the column in #' data has another name, it can be input as a named vector, see examples. -#' @param new_column [\code{character}]\cr +#' @param new_column [\code{character}]\cr #' The new columns that should be included into the data frame. #' @template position #' @template overwrite -#' @param filename [\code{list}]\cr +#' @param filename [\code{list}]\cr #' The filenames of the source files with the tables for generating the translation table. -#' @param from_path [\code{character(1)}]\cr +#' @param from_path [\code{character(1)}]\cr #' Path for the source files for the translation table. #' -#' @return \code{add_lokalitet}: \code{data.frame} where the aquaculture +#' @return \code{add_lokalitet}: \code{data.frame} where the aquaculture #' zone and / or geo-coordinates have been added in the column to the #' right of the column with the LokNr. #' -#' \code{read_sonetilhorighet}: \code{data.frame} with "LokNr", -#' aquaculture zone and geo-coordinates. If not changing standard -#' input to the function, the standard file at NVI's internal +#' \code{read_sonetilhorighet}: \code{data.frame} with "LokNr", +#' aquaculture zone and geo-coordinates. If not changing standard +#' input to the function, the standard file at NVI's internal #' network is read. #' #' @author Petter Hopp Petter.Hopp@@vetinst.no diff --git a/R/add_poststed.R b/R/add_poststed.R index 588d64f..76f0b9c 100644 --- a/R/add_poststed.R +++ b/R/add_poststed.R @@ -71,7 +71,6 @@ #' new_column = c("poststed", "postkomnr" = "komnr")) #' } #' - add_poststed <- function(data, translation_table = poststed, code_column = c("postnr"), diff --git a/R/build_query_hensikt.R b/R/build_query_hensikt.R index 603d759..de60995 100644 --- a/R/build_query_hensikt.R +++ b/R/build_query_hensikt.R @@ -1,22 +1,18 @@ #' @title Builds query for selecting data for hensikt from PJS -#' @description Builds the query for selecting all data for one or +#' @description Builds the query for selecting all data for one or #' more hensikt within one year from PJS. The query is written #' in T-SQL as used by MS-SQL. #' -#' @details The function builds the SQL syntax to select all +#' @details The function builds the SQL syntax to select all #' PJS-journals concerning the hensiktkoder from PJS. #' -#' @param year [\code{numeric}] \cr -#' One year or a vector giving the first and last years that should -#' be selected. -#' @param hensikt [\code{character}] \cr -#' Vector with one or more specific hensiktkoder. If sub-hensikter +#' @template build_query_year +#' @param hensikt [\code{character}]\cr +#' Vector with one or more specific hensiktkoder. If sub-hensikter #' should be included, end the code with \%. -#' @param db [\code{character(1)}] \cr -#' The database for which the query is built. Currently only -#' the value "PJS" is accepted. +#' @template build_query_db #' -#' @return A list with select-statements for "v2_sak_m_res" and +#' @return A list with select-statements for "v2_sak_m_res" and #' "v_sakskonklusjon", respectively. The statements should be #' included in a \code{RODBC::sqlQuery}. #' diff --git a/R/build_query_one_disease.R b/R/build_query_one_disease.R index 47ed25f..abd67ee 100644 --- a/R/build_query_one_disease.R +++ b/R/build_query_one_disease.R @@ -21,11 +21,16 @@ #' purpose of examining for the infectious agent and/or disease will be included even if the examination has not been performed. This #' is important for a full control of all relevant data for an infectious agent and/or disease. #' -#' @param year One year or a vector with years giving the first and last years that should be selected as integer. -#' @param analytt One or more analyttkode given as a character. If sub-analytter should be included, end the code with \%. -#' @param hensikt Vector with specific hensikter. If sub-hensikter should be included, end the code with \%. Can be \code{NULL}. -#' @param metode Vector with specific metoder. Can be \code{NULL}. -#' @param db The database for which the query is built. Currently only the value "PJS" is accepted. +#' @template build_query_year +#' @param analytt [\code{character}]\cr +#' Analyttkoder that should be selected. If sub-analytter should be included, +#' end the code with \%. +#' @param hensikt [\code{character}]\cr +#' Specific hensiktkoder. If sub-hensikter should be included, +#' end the code with \%. Defaults to \code{NULL}. +#' @param metode [\code{character}]\cr +#' Specific metodekoder. Defaults to \code{NULL}. +#' @template build_query_db #' #' @return A list with select-statement fom v2_sak_m_res and v_sakskonklusjon to be included in a \code{RODBC::sqlQuery}. #' diff --git a/R/build_query_outbreak.R b/R/build_query_outbreak.R index 96dcbfa..d94877b 100644 --- a/R/build_query_outbreak.R +++ b/R/build_query_outbreak.R @@ -27,16 +27,20 @@ #' cannot be sufficient to define the outbreak, but is included if the #' outbreak is defined as all samples examined for a specific analytt. #' -#' @param period Time period given as year. One year or a vector with years giving the first and last years -#' that should be selected as integer. -#' @param utbrudd One or more utbrudd id given as a character. Can be \code{NULL}. -#' @param hensikt Vector with specific hensikter. If sub-hensikter should be -#' included, end the code with \%. Can be \code{NULL}. -#' @param analytt One or more analyttkode given as a character. If sub-analytter -#' should be included, end the code with \%. Can be \code{NULL}. -#' @param metode Vector with specific metoder. Can be \code{NULL}. -#' @param db The database for which the query is built. Currently only the value -#' "PJS" is accepted. +#' @param period [\code{numeric}]\cr +#' Time period given as year. One year or a vector giving the first +#' and last years that should be selected. +#' @param utbrudd [\code{character}]\cr +#' Utbruddsid(er) that should be selected. Defaults to \code{NULL}. +#' @param hensikt [\code{character}]\cr +#' Specific hensiktkoder. If sub-hensikter should be included, +#' end the code with \%. Defaults to \code{NULL}. +#' @param analytt [\code{character}]\cr +#' Analyttkoder that should be selected. If sub-analytter should be included, +#' end the code with \%. Defaults to \code{NULL}. +#' @param metode [\code{character}]\cr +#' Specific metodekoder. Defaults to \code{NULL}. +#' @template build_query_db #' #' @return A list with select-statement for v2_sak_m_res and v_sakskonklusjon to #' be included in a \code{RODBC::sqlQuery}. diff --git a/R/build_sql_modules.R b/R/build_sql_modules.R index 7609193..6620095 100644 --- a/R/build_sql_modules.R +++ b/R/build_sql_modules.R @@ -2,7 +2,6 @@ # Collection of query modules that can be used when building queries for PJS # build_sql_select_year ---- -#' @md #' @title Builds sql modules to be included in select statements for PJS #' @description Builds sql modules to be included in select statements for PJS #' when building queries for selecting data. The functions takes the values @@ -23,24 +22,23 @@ #' Be aware that these functions only builds an sql building block to be #' included into a select statement. It will not build a complete select #' statement. These functions are mainly intended for internal use and -#' are called from \code{\link{build_query_hensikt}}, \code{\link{build_query_one_disease}}, -#' and \code{\link{build_query_outbreak}}. If generating own select -#' statements, these can be used to facilitate the coding. The building -#' blocks can be combined with "AND" and "OR" and brackets to get the -#' intended select statement. +#' are called from +#' \ifelse{html}{\code{\link{build_query_hensikt}}}{\code{build_query_hensikt}}, +#' \ifelse{html}{\code{\link{build_query_one_disease}}}{\code{build_query_one_disease}} +#' and +#' \ifelse{html}{\code{\link{build_query_outbreak}}}{\code{build_query_outbreak}}. +#' If generating own select statements, these can be used to facilitate +#' the coding. The building blocks can be combined with "AND" and "OR" +#' and brackets to get the intended select statement. #' -#' @param year \[\code{numeric}\] \\cr -#' One year or a vector giving the first and last years that should -#' be selected. -#' @param values \[\code{character}\] \\cr -#' The value of the codes that should be selected. If sub-codes should be -#' included, add "%" after the code, see example. -#' @param varname \[\code{character(1)}\] \\cr +#' @template build_query_year +#' @param values [\code{character}]\cr +#' The value of the codes that should be selected. If sub-codes should be +#' included, add "\%" after the code, see example. +#' @param varname [\code{character(1)}]\cr #' The PJS variable name of the variable in PJS from which the #' coded values should be selected. -#' @param db \[\code{character(1)}\] \\cr -#' The database for which the query is built. Currently only -#' the value "PJS" is accepted. +#' @template build_query_db #' #' @return SQL-code to be included when building select-statements for PJS. #' diff --git a/R/copy_Prodtilskudd.R b/R/copy_Prodtilskudd.R index 6eddf27..b7001eb 100644 --- a/R/copy_Prodtilskudd.R +++ b/R/copy_Prodtilskudd.R @@ -4,7 +4,13 @@ copy_Prodtilskudd <- function(from_path = paste0(set_dir_NVI("Prodtilskudd"), "FormaterteData/"), to_path = NULL, Pkode_year = "last", - Pkode_month = "both") { + Pkode_month = "both", + extracted_date = NULL) { + + # PREPARE ARGUMENT ---- + # Removing ending "/" and "\\" from pathnames + from_path <- sub("/+$|\\\\+$", "", from_path) + to_path <- sub("/+$|\\\\+$", "", to_path) # ARGUMENT CHECKING ---- # Object to store check-results @@ -12,27 +18,43 @@ copy_Prodtilskudd <- function(from_path = paste0(set_dir_NVI("Prodtilskudd"), "F # Perform checks # from_path - checkmate::assert_character(from_path, len = 1, min.chars = 1, add = checks) - if (endsWith(from_path, "/")) { - checkmate::assert_directory_exists(substr(from_path, 1, nchar(from_path) - 1), access = "r", add = checks) - } else { - checkmate::assert_directory_exists(from_path, access = "r", add = checks) - } + checkmate::assert_string(from_path, min.chars = 1, add = checks) + checkmate::assert_directory_exists(from_path, access = "r", add = checks) # to_path - if (endsWith(to_path, "/")) { - checkmate::assert_directory_exists(substr(to_path, 1, nchar(to_path) - 1), access = "r", add = checks) - } else { - checkmate::assert_directory_exists(to_path, access = "r", add = checks) + checkmate::assert_string(to_path, min.chars = 1, add = checks) + checkmate::assert_directory_exists(to_path, access = "r", add = checks) + + if (is.null(extracted_date)) { + # 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[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) + } + # If extracted_date != NULL, then input "both" and "last" are not accepted + if (!is.null(extracted_date)) { + # Pkode_month + NVIcheckmate::assert_subset_character(Pkode_month, + choices = c("01", "03", "05", "07", "10", "12"), + comment = "The inputs 'both' and 'last' are not accepted when 'extracted_date' is given", + add = checks) + # Pkode_year + NVIcheckmate::assert_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, + comment = "The input 'last' is not accepted when 'extracted_date' is given", + add = checks) } - checkmate::assert_subset(Pkode_month, choices = c("both", "last", "01", "03", "05", "07", "10", "12"), add = checks) - 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_choice(Pkode_year, choices = c("last")), - add = checks) # Report check-results checkmate::reportAssertions(checks) @@ -42,7 +64,8 @@ copy_Prodtilskudd <- function(from_path = paste0(set_dir_NVI("Prodtilskudd"), "F # # READ IN ALL FILES IN THE DIRECTORY AND MAKE A LIST OF THE SELECTED VERSIONS OF EXTRACTS FROM PKODEREGISTERET ---- filelist <- select_prodtilskudd_files(from_path = from_path, Pkode_year = Pkode_year, - Pkode_month = Pkode_month) + Pkode_month = Pkode_month, + extracted_date = extracted_date) # COPY FILES ---- for (i in c(1:dim(filelist)[1])) { diff --git a/R/get_PAT.R b/R/get_PAT.R deleted file mode 100644 index 6ab2f36..0000000 --- a/R/get_PAT.R +++ /dev/null @@ -1,29 +0,0 @@ -#' @export -#' @rdname set_PAT - -get_PAT <- function(service) { - - # Error handling - # 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 of keyring is correctly installed - if (!is.element("keyring", utils::installed.packages()[, 1])) { - stop("Package keyring need to be installed for this function to work") - } - - # 2. Credentials for service are missing from the user profile - if (!is.element(tolower(service), tolower(keyring::key_list()[, 1]))) { - stop(paste("PAT for", - service, - "is not available for the current user on this computer")) - } - - # Identifies the spelling of service with regard to lower and upper case - # This is used in Connect-statement below to ensure correct spelling when fetching User ID and Password - service <- keyring::key_list()[which(tolower(keyring::key_list()[, 1]) == tolower(service)), 1] - - # fetch the PAT - PAT <- keyring::key_get(service, as.character(keyring::key_list(service)[2])) - - return(PAT) -} diff --git a/R/ignore_unused_imports.R b/R/ignore_unused_imports.R deleted file mode 100644 index 6f68ad1..0000000 --- a/R/ignore_unused_imports.R +++ /dev/null @@ -1,14 +0,0 @@ -# Remove NOTE when running CMD check and checking dependencies -# Namespaces in Imports field not imported from: -# 'NVIrpackages' 'rlang' 'rmarkdown' 'shiny' 'tidyr' -# All declared Imports should be used. - - -ignore_unused_imports <- function() { - # Removes NOTE because of packages needed for building vignette: "Contribute to ..." - rmarkdown::html_vignette - knitr::opts_chunk - NVIrpackages::NVIpackages - # R.rsp is used when adding the pdf reference manual as a vignette - R.rsp::rfile -} diff --git a/R/login.R b/R/login.R index b2de649..40d297d 100644 --- a/R/login.R +++ b/R/login.R @@ -49,9 +49,9 @@ #' \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 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 +#' 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 @@ -65,11 +65,13 @@ #' @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 +#' @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. +#' @param \dots Other arguments to be passed from the wrappers to +#' login_by_credentials or login_by_input #' @return An open ODBC-channel to the database service. #' @family Log in functions #' @seealso \code{\link{set_credentials}} @@ -214,28 +216,28 @@ login <- function(dbservice, #' @export #' @rdname login -login_PJS <- function(dbinterface = NULL) { +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" # 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, dbinterface = dbinterface) + login_by_credentials(dbservice, dbinterface = dbinterface, ...) } else { # If credentials are missing from the user profile - login_by_input(dbservice, dbinterface = dbinterface) + login_by_input(dbservice, dbinterface = dbinterface, ...) } } @@ -243,27 +245,27 @@ login_PJS <- function(dbinterface = NULL) { #' @export #' @rdname login -login_EOS <- function(dbinterface = NULL) { +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" # 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, dbinterface = dbinterface) + login_by_credentials(dbservice, dbinterface = dbinterface, ...) } else { # If credentials are missing from the user profile - login_by_input(dbservice, dbinterface = dbinterface) + login_by_input(dbservice, dbinterface = dbinterface, ...) } } diff --git a/R/login_by_credentials.R b/R/login_by_credentials.R index 13d5c2c..a5c9274 100644 --- a/R/login_by_credentials.R +++ b/R/login_by_credentials.R @@ -47,12 +47,6 @@ login_by_credentials <- function(dbservice, } } - # # Produce extra message in case parameters are lacking - # x_msg <- NVIcheckmate::check_package(x = "NVIconfig") - # - # # 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 @@ -73,28 +67,6 @@ login_by_credentials <- function(dbservice, # Report check-results checkmate::reportAssertions(checks) - # # Error handling - # # 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 of keyring is correctly installed - # if (!is.element("keyring", utils::installed.packages()[, 1])) { - # stop("Package keyring need to be installed for this function to work") - # } - # - # # 2. Credentials for dbservice are missing from the user profile - # if (!is.element(tolower(dbservice), tolower(keyring::key_list()[, 1]))) { - # stop(paste("Username and password for", - # dbservice, - # "is not available for the current user on this computer")) - # } - # - # # 3. 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 the spelling of service with regard to lower and upper case # This is used in Connect-statement below to ensure correct spelling when fetching User ID and Password @@ -102,8 +74,8 @@ login_by_credentials <- function(dbservice, if (dbinterface == "odbc") { # Connects to db using odbc - # use tryCatch to remove warning, - # look at https://stackoverflow.com/questions/12193779/how-to-write-trycatch-in-r + # uses removeTaskCallback to remove warning when using dbconnect within function + original_task_callback <- getTaskCallbackNames() connection <- DBI::dbConnect(drv = odbc::odbc(), Driver = dbdriver, Server = dbserver, @@ -111,21 +83,23 @@ login_by_credentials <- function(dbservice, Database = db, UID = as.character(keyring::key_list(dbservice)[2]), PWD = keyring::key_get(dbservice, as.character(keyring::key_list(dbservice)[2]))) + task_callback <- getTaskCallbackNames() + removeTaskCallback(which(!task_callback %in% original_task_callback)) - if(Sys.getenv("RSTUDIO") == "1"){ - # Opens connection pane in Rstudio. + if (Sys.getenv("RSTUDIO") == "1") { + # Opens connection pane in Rstudio. # This is not opened automatically when running dbconnect from within a function - code <- c(match.call()) # This saves what was typed into R - + code <- c(match.call()) # This saves what was typed into R + odbc:::on_connection_opened( - connection, - paste(c("library(internal_package)", + connection, + paste(c("library(internal_package)", paste("connection <-", gsub(", ", ",\n\t", code))), - collapse = "\n")) + collapse = "\n")) } - + } - + if (dbinterface == "RODBC") { # Connects to journal_rapp using ODBC connection <- RODBC::odbcDriverConnect(paste0("DRIVER=", dbdriver, @@ -156,7 +130,7 @@ login_by_credentials <- function(dbservice, #' @export #' @rdname login -login_by_credentials_PJS <- function(dbinterface = NULL) { +login_by_credentials_PJS <- function(dbinterface = NULL, ...) { # ARGUMENT CHECKING ---- # Object to store check-results @@ -173,7 +147,7 @@ login_by_credentials_PJS <- function(dbinterface = NULL) { checkmate::reportAssertions(checks) - connection <- NVIdb::login_by_credentials(dbservice = "PJS", dbinterface = dbinterface) + connection <- NVIdb::login_by_credentials(dbservice = "PJS", dbinterface = dbinterface, ...) return(connection) } @@ -183,7 +157,7 @@ login_by_credentials_PJS <- function(dbinterface = NULL) { #' @export #' @rdname login -login_by_credentials_EOS <- function(dbinterface = NULL) { +login_by_credentials_EOS <- function(dbinterface = NULL, ...) { # ARGUMENT CHECKING ---- # Object to store check-results @@ -195,11 +169,11 @@ login_by_credentials_EOS <- function(dbinterface = NULL) { 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) - connection <- NVIdb::login_by_credentials(dbservice = "EOS", dbinterface = dbinterface) + connection <- NVIdb::login_by_credentials(dbservice = "EOS", dbinterface = dbinterface, ...) return(connection) } diff --git a/R/login_by_input.R b/R/login_by_input.R index 43106c1..6026494 100644 --- a/R/login_by_input.R +++ b/R/login_by_input.R @@ -9,24 +9,16 @@ login_by_input <- function(dbservice, dbprotocol = NULL, dbinterface = NULL, dbtext = NULL) { - + # 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. @@ -35,14 +27,14 @@ login_by_input <- function(dbservice, 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"]} @@ -53,7 +45,7 @@ login_by_input <- function(dbservice, if (is.null(dbinterface)) {dbinterface <- connect[, "dbinterface"]} } } - + # dbdriver checkmate::assert_character(dbdriver, min.chars = 1, len = 1, any.missing = FALSE, add = checks) # db @@ -66,10 +58,10 @@ login_by_input <- function(dbservice, 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)) { @@ -81,37 +73,40 @@ login_by_input <- function(dbservice, # 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 if (dbinterface == "odbc") { # Connects to db using odbc - # use tryCatch to remove warning, - # look at https://stackoverflow.com/questions/12193779/how-to-write-trycatch-in-r + # uses removeTaskCallback to remove warning when using dbconnect within function + original_task_callback <- getTaskCallbackNames() connection <- DBI::dbConnect(drv = odbc::odbc(), Driver = dbdriver, Server = dbserver, port = dbport, Database = db, - UID = svDialogs::dlgInput(message = paste("Oppgi brukernavn for", dbtext))$res, + # UID = svDialogs::dlgInput(message = paste("Oppgi brukernavn for", dbtext))$res, + UID = askpass::askpass(prompt = paste("Oppgi brukernavn (username) for", dbtext)), # PWD = getPass::getPass(msg = paste("Oppgi passord for", dbtext))) - PWD = askpass::askpass(prompt = paste("Oppgi passord for", dbtext))) - - if(Sys.getenv("RSTUDIO") == "1"){ - # Opens connection pane in Rstudio. + PWD = askpass::askpass(prompt = paste("Oppgi passord for", dbtext))) + task_callback <- getTaskCallbackNames() + removeTaskCallback(which(!task_callback %in% original_task_callback)) + + if (Sys.getenv("RSTUDIO") == "1") { + # Opens connection pane in Rstudio. # This is not opened automatically when running dbconnect from within a function - code <- c(match.call()) # This saves what was typed into R - + code <- c(match.call()) # This saves what was typed into R + odbc:::on_connection_opened( - connection, - paste(c("library(internal_package)", + connection, + paste(c("library(internal_package)", paste("connection <-", gsub(", ", ",\n\t", code))), - collapse = "\n")) + collapse = "\n")) } - + } - + if (dbinterface == "RODBC") { connection <- RODBC::odbcDriverConnect(paste0("DRIVER=", dbdriver, ";Database=", db, @@ -119,24 +114,26 @@ login_by_input <- function(dbservice, ";Port=", dbport, ";PROTOCOL=", dbprotocol, ";UID=", - svDialogs::dlgInput(message = paste("Oppgi brukernavn for", dbtext))$res, + # svDialogs::dlgInput(message = paste("Oppgi brukernavn for", dbtext))$res, + askpass::askpass(prompt = paste("Oppgi brukernavn (username) for", dbtext)), ";PWD=", # getPass::getPass(msg = paste("Oppgi passord for", dbtext))) askpass::askpass(prompt = paste("Oppgi passord for", dbtext))) ) } - + 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, + # user = svDialogs::dlgInput(message = paste("Oppgi brukernavn for", dbtext))$res, + user = askpass::askpass(prompt = paste("Oppgi brukernavn (username) for", dbtext)), , # PWD = getPass::getPass(msg = paste("Oppgi passord for", dbtext))) - PWD = askpass::askpass(prompt = paste("Oppgi passord for", dbtext))) + PWD = askpass::askpass(prompt = paste("Oppgi passord for", dbtext))) } - + return(connection) } @@ -144,21 +141,21 @@ login_by_input <- function(dbservice, #' @export #' @rdname login -login_by_input_PJS <- function(dbinterface = NULL) { - +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", dbinterface = dbinterface) - + odbcConnection <- login_by_input(dbservice = "PJS", dbinterface = dbinterface, ...) + return(odbcConnection) } @@ -166,20 +163,20 @@ login_by_input_PJS <- function(dbinterface = NULL) { #' @export #' @rdname login -login_by_input_EOS <- function(dbinterface = NULL) { - +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", dbinterface = dbinterface) - + odbcConnection <- login_by_input(dbservice = "EOS", dbinterface = dbinterface, ...) + return(odbcConnection) } diff --git a/R/read_Prodtilskudd.R b/R/read_Prodtilskudd.R index 2d6716e..21fd069 100644 --- a/R/read_Prodtilskudd.R +++ b/R/read_Prodtilskudd.R @@ -1,26 +1,59 @@ #' @title Read Register for søknad om produksjonstilskudd -#' @description Functions to to read and copy versions of the produksjonstilskuddsregister. -#' @details The produksjonstilskuddsregister includes information on number of animals that the produsent has applied subsidies for at the -#' counting dates. Since 2017, the counting dates are in March and October. Landbruksdirektoratet provides three to four versions of the -#' register for each counting date. The functions automatically selects the last updated version of the register. +#' @description Functions to to read and copy versions of the +#' produksjonstilskuddsregister. +#' @details The produksjonstilskuddsregister includes information on number of +#' animals that the produsent has applied subsidies for at the counting +#' dates. Since 2017, the counting dates are in March and October. +#' Landbruksdirektoratet provides three to four versions of the register for +#' each counting date. The functions automatically selects the last updated +#' version of the register. #' -#' \code{read_Prodtilskudd} reads the produksjonstilskuddsregister into a data frame. The function gives options to select year and season The standard -#' settings will read in the files from NVI's internal network and select the latest updated file for both spring and autumn and combine them -#' into one file. 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_Prodtilskudd} reads the produksjonstilskuddsregister into a +#' data frame. The function gives options to select year and season The +#' standard settings will read in the files from NVI's internal network and +#' select the latest updated file for both spring and autumn and combine +#' them into one file. 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{copy_Prodtilskudd} copies the source produksjonstilskuddsregister for each of the year and seasons selected to a given directory. +#' \code{extracted_date} is used if specific versions of the register is required, +#' for example to reproduce the generation of data previously performed +#' using an older version of the register.You should also write in the +#' \code{extracted_date} in the script to document which version of the +#' register that was used. If so, first extract the last available version +#' of the register. Find the uttrekkdato in the data, and write in the +#' uttrekkdato in \code{extracted_date}. \code{extracted_date} cannot be used +#' in combination with \code{pkode_year} = "last" or \code{pkode_month} = +#' c("last", "both"). #' -#' @param from_path Path for the produksjonstilskuddsregister. -#' @param to_path Target path for the files with the produksjonstilskuddsregister. -#' @param Pkode_year The year(s) from which the register should be read. Options is "last", or a vector with one or more years. -#' @param Pkode_month The month for which the register should be read. The options are c("05", "10", "both", "last") for Pkode_year = 2017 -#' and c("03", "10", "both", "last") for Pkode_year >= 2018. +#' \code{copy_Prodtilskudd} copies the source produksjonstilskuddsregister +#' for each of the year and seasons selected to a given directory. +#' +#' @param from_path [\code{character(1)}]\cr +#' Path for the produksjonstilskuddsregister. Defaults to the standard +#' directory at the NVI network. +#' @param to_path [\code{character(1)}]\cr +#' Target path for the files with the produksjonstilskuddsregister. +#' @param Pkode_year [\code{character}] | [\code{numeric}]\cr +#' The year(s) from which the register should be read. Options is "last", or +#' a vector with one or more years. Defaults to "last". +#' @param Pkode_month [\code{character}]\cr +#' The month for which the register should be read. The options are +#' c("05", "10", "both", "last") for Pkode_year = 2017 and +#' c("03", "10", "both", "last") for Pkode_year >= 2018. Defaults to "both". +#' @param extracted_date [\code{character}]\cr +#' The date the data was extracted from the database of the Norwegian +#' Agricultural Agency. The format should be "yyyy-mm-dd". Defaults to +#' \code{NULL}. #' -#' @return \code{read_Prodtilskudd} reads one or more data frame(s) with the produksjonstilskuddsregister for each of the year and seasons selected. -#' If the options Pkode_year = "last" and Pkode_month = "last" is given, one file with the last produksjonstilskuddsregister is given. +#' @return \code{read_Prodtilskudd} reads one or more data frame(s) with the +#' produksjonstilskuddsregister for each of the year and seasons selected. +#' If the options Pkode_year = "last" and Pkode_month = "last" is given, +#' one file with the last produksjonstilskuddsregister is given. #' -#' \code{copy_Prodtilskudd} copies the source produksjonstilskuddsregister for each of the year and seasons selected. If the target file +#' \code{copy_Prodtilskudd} copies the source produksjonstilskuddsregister +#' for each of the year and seasons selected. If the target file #' already exists, the source files are copied only when newer than the target file. #' #' @author Petter Hopp Petter.Hopp@@vetinst.no @@ -37,7 +70,8 @@ #' read_Prodtilskudd <- function(from_path = paste0(set_dir_NVI("Prodtilskudd"), "FormaterteData/"), Pkode_year = "last", - Pkode_month = "both") { + Pkode_month = "both", + extracted_date = NULL) { # PREPARE ARGUMENT ---- # Removing ending "/" and "\\" from pathnames @@ -50,18 +84,38 @@ read_Prodtilskudd <- function(from_path = paste0(set_dir_NVI("Prodtilskudd"), "F # from_path checkmate::assert_character(from_path, len = 1, min.chars = 1, add = checks) checkmate::assert_directory_exists(from_path, access = "r", add = checks) - # 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[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) + # If extracted_date = NULL, then input "both" and "last" are accepted + if (is.null(extracted_date)) { + # 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[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) + } + # If extracted_date != NULL, then input "both" and "last" are not accepted + if (!is.null(extracted_date)) { + # Pkode_month + NVIcheckmate::assert_subset_character(Pkode_month, + choices = c("01", "03", "05", "07", "10", "12"), + comment = "The inputs 'both' and 'last' are not accepted when 'extracted_date' is given", + add = checks) + # Pkode_year + NVIcheckmate::assert_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, + comment = "The input 'last' is not accepted when 'extracted_date' is given", + add = checks) + } # Report check-results checkmate::reportAssertions(checks) @@ -70,7 +124,8 @@ read_Prodtilskudd <- function(from_path = paste0(set_dir_NVI("Prodtilskudd"), "F # READ IN ALL FILES IN THE DIRECTORY AND MAKE A LIST OF THE SELECTED VERSIONS OF EXTRACTS FROM PKODEREGISTERET filelist <- select_prodtilskudd_files(from_path = from_path, Pkode_year = as.character(Pkode_year), - Pkode_month = Pkode_month) + Pkode_month = Pkode_month, + extracted_date = extracted_date) # Read data for the selected year and months from Pkoderegisteret and combine into one dataframe for (i in 1:dim(filelist)[1]) { @@ -121,10 +176,12 @@ read_Prodtilskudd <- function(from_path = paste0(set_dir_NVI("Prodtilskudd"), "F #' @title List selected files from Søknad om register for produksjonstilskudd -#' @description List selected files with extracts from Søknad om register for produksjonstilskudd. -#' @details Reads the filenames of files with extracts from Søknad om register for produksjonstilskudd into a data frame. -#' The function gives options to select year and month and path for the files. The function is called from read_Prodtilskudd -#' and copy_Prodtilskudd. +#' @description List selected files with extracts from Søknad om register +#' for produksjonstilskudd. +#' @details Reads the filenames of files with extracts from Søknad om register +#' for produksjonstilskudd into a data frame. The function gives options to +#' select year and month and path for the files. The function is called from +#' \code{read_Prodtilskudd} and \code{copy_Prodtilskudd}. #' #' @param from_path Path for the source translation table for PJS-codes #' @param Pkode_year The year(s) from which the register should be read. Options is "last", or a vector with one or more years. @@ -145,7 +202,8 @@ read_Prodtilskudd <- function(from_path = paste0(set_dir_NVI("Prodtilskudd"), "F select_prodtilskudd_files <- function(from_path, Pkode_year, - Pkode_month) { + Pkode_month, + extracted_date) { # READ IN ALL FILES IN THE DIRECTORY AND MAKE A LIST OF THE LAST VERSION OF ALL UTREKK FRO PKODEREGISTERET filelist <- as.data.frame(list.files(path = from_path, pattern = "csv", ignore.case = TRUE, include.dirs = FALSE), stringsAsFactors = FALSE) @@ -166,30 +224,39 @@ select_prodtilskudd_files <- function(from_path, filelist$uttrekk_dato <- as.Date(sapply(filelist$fileinfo, FUN = find_n_th_word, position = 3), format = "%Y%m%d") max_uttrekk_dato <- stats::aggregate(filelist$uttrekk_dato, by = list(filelist$pkodeaar, filelist$pkodemonth), FUN = max) filelist <- merge(filelist, max_uttrekk_dato, by.x = c("pkodeaar", "pkodemonth"), by.y = c("Group.1", "Group.2")) - filelist <- subset(filelist, filelist$uttrekk_dato == filelist$x) - filelist <- filelist[, c("filename", "pkodeaar", "pkodemonth", "uttrekk_dato")] + filelist <- filelist[, c("filename", "pkodeaar", "pkodemonth", "uttrekk_dato", "x")] filelist <- filelist[order(filelist$pkodeaar, filelist$pkodemonth, filelist$uttrekk_dato, decreasing = TRUE), ] - if ("last" %in% Pkode_year) { - filelist <- filelist[c(1:2), ] - if (!"both" %in% Pkode_month) { - if ("last" %in% Pkode_month) { - filelist <- filelist[1, ] - } else { - filelist <- subset(filelist, filelist$pkodemonth %in% Pkode_month) + if (is.null(extracted_date)) { + filelist <- subset(filelist, filelist$uttrekk_dato == filelist$x) + if ("last" %in% Pkode_year) { + filelist <- filelist[c(1:2), ] + if (!"both" %in% Pkode_month) { + if ("last" %in% Pkode_month) { + filelist <- filelist[1, ] + } else { + filelist <- subset(filelist, filelist$pkodemonth %in% Pkode_month) + } } } - } - if (!"last" %in% Pkode_year) { - filelist <- subset(filelist, filelist$pkodeaar %in% Pkode_year) - if (!"both" %in% Pkode_month) { - if ("last" %in% Pkode_month) { - filelist <- filelist[1, ] - } else { - filelist <- subset(filelist, filelist$pkodemonth %in% Pkode_month) + if (!"last" %in% Pkode_year) { + filelist <- subset(filelist, filelist$pkodeaar %in% Pkode_year) + if (!"both" %in% Pkode_month) { + if ("last" %in% Pkode_month) { + filelist <- filelist[1, ] + } else { + filelist <- subset(filelist, filelist$pkodemonth %in% Pkode_month) + } } } } + # Selection for uttrekk_dato + if (!is.null(extracted_date)) { + filelist <- subset(filelist, filelist$pkodeaar %in% Pkode_year) + filelist <- subset(filelist, filelist$pkodemonth %in% Pkode_month) + checkmate::assert_choice(as.Date(extracted_date), choices = filelist$uttrekk_dato) + filelist <- subset(filelist, filelist$uttrekk_dato %in% as.Date(extracted_date)) + } return(filelist) } diff --git a/R/read_eos_data.R b/R/read_eos_data.R index 9582f2f..3ce49d2 100644 --- a/R/read_eos_data.R +++ b/R/read_eos_data.R @@ -1,15 +1,15 @@ #' @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 +#' @details read_eos_data uses #' \ifelse{html}{\code{\link[data.table:fread]{data.table::fread}}}{\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 +#' to read the data with the settings \code{showProgress = FALSE} and +#' \code{data.table = FALSE}. Other arguments can be passed to #' \ifelse{html}{\code{\link[data.table:fread]{data.table::fread}}}{\code{data.table::fread}} #' if necessary. -#' +#' #' The eos_table name is the same name as the name as in the EOS data base. -#' +#' #' @param from_path [\code{character(1)}]\cr #' Path for raw data from eos_data. #' @param eos_table [\code{character(1)}]\cr @@ -18,32 +18,32 @@ #' The years to be included in the result. Can be both numeric #' or character. Defaults to \code{NULL}, i.e. no selection. #' @param colClasses [\code{character}]\cr -#' The class of the columns, as in +#' The class of the columns, as in #' \ifelse{html}{\code{\link[utils:read.table]{utils::read.table}}}{\code{utils::read.table}}. #' Defaults to \code{"character"}. #' @param encoding [\code{character(1)}]\cr #' The encoding, one of c("UTF-8", "latin1"). Defaults to \code{"UTF-8"}. -#' @param \dots Other arguments to be passed to +#' @param \dots Other arguments to be passed to #' \ifelse{html}{\code{\link[data.table:fread]{data.table::fread}}}{\code{data.table::fread}}. #' #' @return A data frame with data from EOS. #' #' @author Petter Hopp Petter.Hopp@@vetinst.no #' @export -#' -read_eos_data <- function(eos_table, +#' +read_eos_data <- function(eos_table, from_path = paste0(set_dir_NVI("EOS"), "RaData"), year = NULL, - colClasses = "character", + 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() @@ -62,55 +62,55 @@ read_eos_data <- function(eos_table, null.ok = TRUE, add = checks) ## colClasses - checkmate::assert_character(colClasses, min.chars = 1, min.len = 1, + checkmate::assert_character(colClasses, min.chars = 1, min.len = 1, any.missing = FALSE, - all.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, + 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, + 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 57535f2..8236dd8 100644 --- a/R/read_sonetilhorighet.R +++ b/R/read_sonetilhorighet.R @@ -19,7 +19,7 @@ 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 index 48041af..ca0fd65 100644 --- a/R/read_varekode.R +++ b/R/read_varekode.R @@ -29,7 +29,7 @@ #' varekoder to descriptive text and metadata. #' #' @author Petter Hopp Petter.Hopp@@vetinst.no -#' @importFrom rlang .data +# @importFrom rlang .data #' @export #' @examples #' \dontrun{ @@ -41,10 +41,10 @@ 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() @@ -84,24 +84,24 @@ read_varekode <- function(filename = "varekoder.csv", } # 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" @@ -114,12 +114,17 @@ read_varekode <- function(filename = "varekoder.csv", 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 %>% + # 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)) + max_n_days <- stats::aggregate(n_days ~ aar, data = filnavn, FUN = max) + colnames(max_n_days)[2] <- "max_n_days" + filnavn <- merge(filnavn, max_n_days, by = "aar", all.x = TRUE) + filnavn <- filnavn[order(filnavn$fra_dato, filnavn$til_dato, decreasing = TRUE), ] + + # filnavn <- filnavn[c(2:dim(filnavn)[1]), ] # Select varekoder for time period # Selects from year @@ -132,7 +137,7 @@ read_varekode <- function(filename = "varekoder.csv", 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) { @@ -143,11 +148,12 @@ read_varekode <- function(filename = "varekoder.csv", # 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) - + sep = delimiter, + fileEncoding = "latin1") + # 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)))) { @@ -170,6 +176,6 @@ read_varekode <- function(filename = "varekoder.csv", df1 <- unique(df1) } } - + return(df1) } diff --git a/R/remove_PAT.R b/R/remove_PAT.R deleted file mode 100644 index 160e0f8..0000000 --- a/R/remove_PAT.R +++ /dev/null @@ -1,23 +0,0 @@ -#' @export -#' @rdname set_PAT - -remove_PAT <- function(service) { - - # ARGUMENT CHECKING ---- - checkmate::assert_character(x = service, min.chars = 1, len = 1, any.missing = FALSE) - - # REMOVE ALL EXISTING CREDENTIALS FOR service - # Checks if there are registered PAT for the database service - # Removes the service until no more service are registered - while (is.element(tolower(service), tolower(keyring::key_list()[, 1]))) { - # Identifies the spelling of service with regard to lower and upper case - # This is used in Connect-statement below to ensure correct spelling when fetching User ID - services <- keyring::key_list()[which(tolower(keyring::key_list()[, 1]) == tolower(service)), 1] - usernames <- keyring::key_list()[which(tolower(keyring::key_list()[, 1]) == tolower(service)), 2] - - # Removes the key for all combinations of service and username - for (i in 1:length(services)) { - keyring::key_delete(service = services[i], username = usernames[i]) - } - } -} diff --git a/R/retrieve_PJSdata.R b/R/retrieve_PJSdata.R new file mode 100644 index 0000000..422b808 --- /dev/null +++ b/R/retrieve_PJSdata.R @@ -0,0 +1,195 @@ +#' @title Retrieves data from PJS +#' @description Retrieves and standardises PJS data. \code{retrieve_PJSdata} is +#' a wrapper for several \code{NVIdb}-functions and the intention of +#' \code{retrieve_PJSdata} is to shorten code and to ensure that a standard +#' procedure is followed when retrieving PJS-data, see details. It can only +#' be used for retrieving case data from PJS and not for retrieving code registers +#' and similar. +#' +#' @details \code{retrieve_PJSdata} is a wrapper for the following \code{NVIdb}-functions: +#' \itemize{ +#' \item Constructs the select statement by a build_query-function (see details) +#' and selection parameters. +#' \item Creates an open ODBC-channel using +#' \ifelse{html}{\code{\link{login_PJS}}}{\code{login_PJS}}. +#' \item Retrieves the data using the select statement constructed above. +#' \item Standardises the data using +#' \ifelse{html}{\code{\link{standardize_PJSdata}}}{\code{standardize_PJSdata}}. +#' \item Excludes unwanted cases using +#' \ifelse{html}{\code{\link{exclude_from_PJSdata}}}{\code{exclude_from_PJSdata}}. +#' } +#' +#' For the function to run automatically without having to enter PJS user +#' credentials, it is dependent that PJS user credentials have been saved using +#' \ifelse{html}{\code{\link{set_credentials_PJS}}}{\code{set_credentials_PJS}}. +#' Otherwise, the credentials must be input manually to establish an open +#' ODBC channel. +#' +#' The select statement for PJS can be built giving the selection parameters and +#' input to one of the build_query-functions, i.e. +#' \ifelse{html}{\code{\link{build_query_hensikt}}}{\code{build_query_hensikt}}, +#' \ifelse{html}{\code{\link{build_query_one_disease}}}{\code{build_query_one_disease}} +#' and +#' \ifelse{html}{\code{\link{build_query_outbreak}}}{\code{build_query_outbreak}}. +#' The selection parameters can be set by using +#' \ifelse{html}{\code{\link{set_disease_parameters}}}{\code{set_disease_parameters}}. +#' or by giving a list of similar format for input to +#' \code{selection_parameters}, see the build_query-functions for necessary +#' input. +#' +#' \code{retrieve_PJSdata} gives the possibility of giving the select_statement +#' as a string instead of using the build_query-functions. This should only +#' by done for select statements that previously have been tested and are +#' known to have correct syntax. \code{retrieve_PJSdata} has no possibility +#' of checking the syntax before it is submitted to PJS and untested select +#' statements can take a lot of time or stop the function without proper +#' error messages. +#' +#' The output is a named list where each entry is a data frame with PJS-data. If +#' the select statement is named, the returned data frame will have that name. +#' If the select statement is unnamed, it will try to identify the first +#' table in the select statement and use this as name. If not possible, the +#' name will be of the format "PJSdata#" where # is the number of the select +#' statement. + +#' +#' @param year [\code{numeric}]\cr +#' One year or a vector giving the first and last years that should be selected. +#' Defaults to \code{NULL}. +#' @param selection_parameters [\code{character(1)}]\cr +#' Either the path and file name for an R script that can be sourced and that +#' sets the selection parameters or a named list with the selection parameters +#' (i.e. of the same format as the output of +#' \ifelse{html}{\code{\link{set_disease_parameters}}}{\code{set_disease_parameters}}). +#' Defaults to \code{NULL}. +#' @param FUN [\code{function}]\cr +#' Function to build the selection statement, see details. Defaults to \code{NULL}. +#' @param select_statement [\code{character(1)}]\cr +#' A written select statement, see details. Defaults to \code{NULL}. +#' @param \dots Other arguments to be passed to underlying functions: +#' \ifelse{html}{\code{\link{login_PJS}}}{\code{login_PJS}} +#' and +#' \ifelse{html}{\code{\link{exclude_from_PJSdata}}}{\code{exclude_from_PJSdata}}. +#' +#' @return A named list with PJS data. +#' +#' @author Petter Hopp Petter.Hopp@@vetinst.no +#' @export +#' @examples +#' +#' # +retrieve_PJSdata <- function(year = NULL, + selection_parameters = NULL, + FUN = NULL, + select_statement = NULL, + ...) { + + # ARGUMENT CHECKING ---- + # Object to store check-results + checks <- checkmate::makeAssertCollection() + + # Perform checks + checkmate::assert_integerish(year, + lower = 1990, upper = as.numeric(format(Sys.Date(), "%Y")), + min.len = 1, + null.ok = TRUE, + add = checks) + NVIcheckmate::assert(checkmate::check_file_exists(x = selection_parameters, access = "r"), + checkmate::check_list(x = selection_parameters, null.ok = TRUE), + combine = "or", + comment = "The argument selection_parameter must either be a file with selection parameters or a list with selection parameters", + add = checks) + checkmate::assert_function(FUN, null.ok = TRUE, add = checks) + # checkmate::assert_choice(deparse(substitute(FUN)), + # choices = c("build_query_one_disease", "build_query_hensikt", "build_query_outbreak"), + # null.ok = TRUE, + # add = checks) + checkmate::assert(checkmate::check_list(x = select_statement, null.ok = TRUE), + checkmate::check_string(x = select_statement), + combine = "or", + add = checks) + NVIcheckmate::assert_non_null(list(selection_parameters, select_statement, add = checks)) + NVIcheckmate::assert_non_null(list(FUN, select_statement), add = checks) + + # Report check-results + checkmate::reportAssertions(checks) + + # GENERATE SELECT STATEMENT ---- + if (!is.null(selection_parameters) & !is.null(FUN)) { + selection_parameters <- set_disease_parameters(selection_parameters = selection_parameters) + + # Character vector with arguments for FUN + FUN_args <- names(formals(args(FUN))) + + # Create FUN_input for modifications, + # keep the original selection_parameters. + FUN_input <- selection_parameters + # Rename list objects to input for FUN + names(FUN_input) <- gsub("2select", "", names(FUN_input)) + # Include year and period in FUN_input + FUN_input <- append(FUN_input, + values = list("year" = year, "period" = year)) + FUN_input <- append(FUN_input, + values = c("db" = "PJS")) + + # Keep only relevant arguments for FUN in FUN_input + FUN_input <- FUN_input[FUN_args] + select_statement <- do.call(FUN, FUN_input) + } + + # GIVE NAME TO EACH SELECTION STATEMENT + # check if the select statements are named. If not, give them names + # if there are no names for the list entries + if (is.null(names(select_statement))) { + select_statement_names <- rep("", c(1:length(select_statement))) + } else { + # Naming elements that miss names if some are named + select_statement_names <- names(select_statement) + } + # for (i in missing_names) { + missing_names <- which(select_statement_names == "") + if (length(missing_names) > 0) { + for (i in missing_names) { + select_statement_names[i] <- substr(select_statement[i], + gregexpr(pattern = "v[[:digit:]]*_", text = select_statement[i])[[1]][1], + min(gregexpr(pattern = "v[[:digit:]]*_", text = select_statement[i])[[1]][2] - 1, + nchar(select_statement[i]), na.rm = TRUE)) + # select_statement_names[i] <- stringi::stri_extract_first_words(select_statement_names[i]) + select_statement_names[i] <- sub("(\\s|,|\\.)[[:print:]]*", "", select_statement_names[i]) + if (select_statement_names[i] == "") {select_statement_names[i] <- paste0("PJSdata", as.character(i))} + } + } + + # IDENTIFY PROBABLE dbsource FROM select_statement_names + dbsource <- select_statement_names + dbsource <- gsub(pattern = "selection_v2_sak_m_res", replacement = "v2_sak_m_res", x = dbsource) + dbsource <- gsub(pattern = "selection_sakskonklusjon", replacement = "v_sakskonklusjon", x = dbsource) + dbsource <- gsub(pattern = "PJSdata[[:digit:]]*", replacement = "v2_sak_m_res", x = dbsource) + + # OPEN ODBC CHANNEL ---- + journal_rapp <- login_PJS(dbinterface = "odbc", ...) + PJSdata <- vector("list", length = length(select_statement)) + + # PERFORM SELECTION AND STANDARDISATION FOR EACH SELECT STATEMENT ---- + for (i in c(1:length(select_statement))) { + + # READ DATA FROM PJS ---- + PJSdata[[i]] <- DBI::dbGetQuery(con = journal_rapp, + statement = select_statement[[i]]) + # STANDARDIZE DATA ---- + PJSdata[[i]] <- standardize_PJSdata(PJSdata = PJSdata[[i]], dbsource = dbsource[i]) + + # Exclude ring trials, quality assurance and samples from abroad + PJSdata[[i]] <- exclude_from_PJSdata(PJSdata = PJSdata[[i]], ...) + + } + + # CLOSE ODBC CHANNEL ---- + DBI::dbDisconnect(journal_rapp) + + + # RETURN RESULT ---- + # Give name to each entry in the list of PJSdata + PJSdata <- stats::setNames(PJSdata, select_statement_names) + return(PJSdata) +} diff --git a/R/select_PJSdata_for_value.R b/R/select_PJSdata_for_value.R new file mode 100644 index 0000000..43b6e69 --- /dev/null +++ b/R/select_PJSdata_for_value.R @@ -0,0 +1,113 @@ +#' @title Selects a subset of PJSdata based on code values +#' @description Selects a subset of PJSdata based on code values. +#' The function accepts code values ending with "%" to indicate +#' that sub levels should be included. +#' @details The function is intended for cases where the select +#' query sent to PJS will be very complicated if the selection +#' is included and it can be easier to read the script if the +#' subset is selected in a second step. +#' +#' The function selects according to different values. The default +#' action is to include the selected rows. But when `keep_selected` +#' = `FALSE`, the selected rows are excluded from the data. +#' +#' @param data \[`data.frame`\]\cr +#' PJS data from which a subset should be selected. +#' @param code_column \[`character`\]\cr +#' Vector with the column names for the variables that is used in the selection. +#' @param value_2_check \[`character`\]\cr +#' Vector with the values that should be selected, see details and examples. +#' @param keep_selected \[`logical(1)`\]\cr +#' If `TRUE`, the selected rows are included, if `FALSE`, the selected columns +#' are excluded. Defaults to `TRUE`. +#' +#' @return A `data.frame`. +#' +#' @author Petter Hopp Petter.Hopp@@vetinst.no +#' @md +#' @export + +select_PJSdata_for_value <- function(data, + code_column, + value_2_check, + keep_selected = TRUE) { + # data <- PJSdata + # code_column <- "hensiktkode" + # value_2_check <- hensikt2delete + # include_missing_for = NULL + # keep_selected = TRUE + + # ARGUMENT CHECKING ---- + # Object to store check-results + checks <- checkmate::makeAssertCollection() + # Perform checks + checkmate::assert_data_frame(data, add = checks) + checkmate::assert_subset(code_column, choices = colnames(data), add = checks) + checkmate::assert_character(value_2_check, min.len = 1, add = checks) + checkmate::assert_flag(keep_selected, add = checks) + # Report check-results + checkmate::reportAssertions(checks) + + + data$sPfv_sort_order <- 1:nrow(data) + + + # transform value_2_check to regular expressions + value_2_check <- paste0("^", value_2_check, "$") + value_2_check <- gsub(pattern = "%$", replacement = "[[:digit:]]*", x = value_2_check, fixed = TRUE) + value_2_check <- gsub(pattern = "%-", replacement = "[[:digit:]]*-", x = value_2_check, fixed = TRUE) + + # Identifies all variables in the index taking into consideration the PJS-levels of the code_column(s) + index <- c("aar", "ansvarlig_seksjon", "innsendelsenr", "saksnr") + for (k in 1:length(code_column)) { + index <- union(index, + NVIdb::PJS_levels[which(NVIdb::PJS_levels[1:10, which(NVIdb::PJS_levels[which(NVIdb::PJS_levels$variable == code_column[k]), ] == 1)[1]] == 1), "variable"] +) + } + # Keeps only variables that exist in PJSdata. Necessary as resnr will not be in PJSdata. + index <- base::intersect(index, colnames(data)) + + # Generate data frame for check that only contains the relevant variables + ktr <- data[, unique(c(index, code_column))] + ktr <- unique(ktr) + + # Combine the codes that should be checked into one variable + # if (code_column == "hensiktkode" & length(code_column) == 1) { + # ktr$combined_codes <- ktr[, c(code_column)] + # } else { + # ktr$combined_codes <- apply(ktr[, c("hensiktkode", code_column)], 1, FUN = paste, collapse = "-") + # } + if (length(code_column) > 1) { + ktr$combined_codes <- apply(ktr[, c(code_column)], 1, FUN = paste, collapse = "-") + } else { + ktr$combined_codes <- ktr[, code_column] + ktr[is.na(ktr$combined_codes), "combined_codes"] <- "NA" + } + + + # Find records deviating from detected code values + ktr <- ktr %>% + dplyr::rowwise() %>% + dplyr::mutate(select = max(unlist(lapply(value_2_check, grep, x = combined_codes)), 0)) + + # if (!is.null(include_missing_for) & length(code_column == 1)) { + # ktr[which(is.na(ktr[, "combined_codes"])), "select"] <- 1 + # } + + ktr$select <- as.logical(ktr$select) + if (isFALSE(keep_selected)) { +ktr$select <- !ktr$select +} + + ktr <- subset(ktr, ktr$select == TRUE) + ktr[, c("combined_codes", "select")] <- c(NULL, NULL) + + column_names <- colnames(data) + data <- merge(x = ktr, y = data, by = c(index, code_column), all.x = TRUE, all.y = FALSE, sort = TRUE) + data <- data[, column_names] + + data <- data[order(data$sPfv_sort_order), ] + data$sPfv_sort_order <- NULL + + return(data) +} diff --git a/R/set_PAT-deprecated.R b/R/set_PAT-deprecated.R new file mode 100644 index 0000000..bf98f53 --- /dev/null +++ b/R/set_PAT-deprecated.R @@ -0,0 +1,172 @@ +#' @title Manage personal access token (PAT) for internet services +#' @description Save or remove the current user's PAT for internet services +#' in the the user profile. +#' @details For internet services like GitHub, personal access tokens can +#' replace username and password when accessing the service. To simplify +#' the access to the internet services when using R, the function +#' \code{set_PAT} makes it possible to save the personal access token +#' (PAT) in the user profile at the current machine. When the PAT has +#' been saved in the user profile, the functions \code{get_PAT} will +#' automatically get the PAT for use in code accessing the internet service. +#' +#' The user profile is not copied between computers. Consequently, if a user +#' runs scripts with \code{get_PAT} on different computers, +#' the PAT has to be saved at each computer separately. +#' +#' \code{set_PAT(service)} is used to set the PAT for a internet service. +#' The PAT are input using windows and saved in the users profile at +#' the current computer. When the PAT for the service has been changed, +#' \code{set_PAT(service)} can be used to update the PAT. +#' +#' \code{get_PAT(service)} is used to get the PAT for a internet service +#' that previously has been saved in the users profile at the current +#' computer. +#' +#' \code{remove_PAT(service)} is used to delete the PAT for a internet +#' service from the user's profile. +#' +#' @param service Name of the internet service, for example "GitHub". For +#' internet services where one don't use the premade wrappers, the name +#' can be chosen freely, but must be the same as used in \code{get_PAT} +#' @return \code{set_PAT} The PAT for a internet service are saved in the +#' user profile at the current computer. +#' +#' \code{get_PAT} The PAT for a internet service are fetched from the +#' user profile at the current computer to be used in R-scripts. +#' +#' \code{remove_PAT} The PAT for a internet service are deleted from +#' the user profile at the current computer. +#' +#' @author Petter Hopp Petter.Hopp@@vetinst.no +#' @name set_PAT-deprecated +#' @usage set_PAT(service) +#' @usage get_PAT(service) +#' @usage remove_PAT(service) +#' @keywords internal +#' @examples +#' \dontrun{ +#' set_PAT("GitHub") +#' +#' get_PAT("GitHub") +#' +#' remove_PAT("GitHub") +#' } +NULL + +#' @name get_PAT-deprecated +#' @rdname set_PAT-deprecated +#' @keywords internal +#' +NULL + +#' @name remove_PAT-deprecated +#' @rdname set_PAT-deprecated +#' @keywords internal +#' +NULL + + +#' @title \code{set_PAT}, \code{get_PAT}, and \code{remove_PAT} is deprecated +#' @description \code{set_PAT}, \code{get_PAT}, and \code{remove_PAT} was +#' deprecated from NVIdb v0.11.0 released 2023-09-22. These functions +#' should be replaced by corresponding functions in package 'gitcreds' +#' that are better, more flexible and maintained at cran. +#' @details The old help pages can be found at \code{help("set_PAT-deprecated")}. +#' Information on deprecated functions can be found at \code{help("NVIdb-deprecated")}. +#' @param service Name of the internet service, for example "GitHub". For +#' internet services where one don't use the premade wrappers, the name +#' can be chosen freely, but must be the same as used in \code{get_PAT} +#' @export +#' @rdname set_PAT +#' @keywords internal +#' +set_PAT <- function(service) { + + .Deprecated(new = "set_PAT", + package = "NVIdb", + msg = paste("'set_PAT', 'get_PAT', and 'remove_PAT' shouild be replaced by", + "corresponding functions in package 'gitcreds'. These functions", + "are better, more flexible and maintained at cran.")) + + # ARGUMENT CHECKING service ---- + checkmate::assert_character(x = service, min.chars = 1, len = 1, any.missing = FALSE) + + # Removes previously set PAT for the database service + remove_PAT(service) + + # Open window for input of PAT to the given service and saves service and PAT in the user's profile + # Use the service name as input to username + keyring::key_set_with_value(service = service, + username = service, + # password = getPass::getPass(paste("Enter your PAT for", service)), + password = askpass::askpass(prompt = paste("Enter your PAT for", service)), + keyring = NULL) +} + + +#' @export +#' @rdname set_PAT + +get_PAT <- function(service) { + + .Deprecated(new = "get_PAT", + package = "NVIdb", + msg = paste("'set_PAT', 'get_PAT', and 'remove_PAT' shouild be replaced by", + "corresponding functions in package 'gitcreds'. These functions", + "are better, more flexible and maintained at cran.")) + + # Error handling + # 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 of keyring is correctly installed + if (!is.element("keyring", utils::installed.packages()[, 1])) { + stop("Package keyring need to be installed for this function to work") + } + + # 2. Credentials for service are missing from the user profile + if (!is.element(tolower(service), tolower(keyring::key_list()[, 1]))) { + stop(paste("PAT for", + service, + "is not available for the current user on this computer")) + } + + # Identifies the spelling of service with regard to lower and upper case + # This is used in Connect-statement below to ensure correct spelling when fetching User ID and Password + service <- keyring::key_list()[which(tolower(keyring::key_list()[, 1]) == tolower(service)), 1] + + # fetch the PAT + PAT <- keyring::key_get(service, as.character(keyring::key_list(service)[2])) + + return(PAT) +} + + +#' @export +#' @rdname set_PAT + +remove_PAT <- function(service) { + + .Deprecated(new = "remove_PAT", + package = "NVIdb", + msg = paste("'set_PAT', 'get_PAT', and 'remove_PAT' shouild be replaced by", + "corresponding functions in package 'gitcreds'. These functions", + "are better, more flexible and maintained at cran.")) + + # ARGUMENT CHECKING ---- + checkmate::assert_character(x = service, min.chars = 1, len = 1, any.missing = FALSE) + + # REMOVE ALL EXISTING CREDENTIALS FOR service + # Checks if there are registered PAT for the database service + # Removes the service until no more service are registered + while (is.element(tolower(service), tolower(keyring::key_list()[, 1]))) { + # Identifies the spelling of service with regard to lower and upper case + # This is used in Connect-statement below to ensure correct spelling when fetching User ID + services <- keyring::key_list()[which(tolower(keyring::key_list()[, 1]) == tolower(service)), 1] + usernames <- keyring::key_list()[which(tolower(keyring::key_list()[, 1]) == tolower(service)), 2] + + # Removes the key for all combinations of service and username + for (i in 1:length(services)) { + keyring::key_delete(service = services[i], username = usernames[i]) + } + } +} diff --git a/R/set_PAT.R b/R/set_PAT.R deleted file mode 100644 index 0661e89..0000000 --- a/R/set_PAT.R +++ /dev/null @@ -1,55 +0,0 @@ -#' @title Manage personal access token (PAT) for internet services -#' @description Save or remove the current user's PAT for internet services in the the user profile. -#' @details For internet services like GitHub, personal access tokens can replace username and password when accessing the service. To simplify -#' the access to the internet services when using R, the function \code{set_PAT} makes it possible to save the personal access token (PAT) in -#' the user profile at the current machine. When the PAT has been saved in the user profile, the functions \code{get_PAT} will automatically -#' get the PAT for use in code accessing the internet service. -#' -#' The user profile is not copied between computers. Consequently, if a user runs scripts with \code{get_PAT} on different computers, -#' the PAT has to be saved at each computer separately. -#' -#' \code{set_PAT(service)} is used to set the PAT for a internet service. The PAT are input using windows and saved in the users profile at -#' the current computer. When the PAT for the service has been changed, \code{set_PAT(service)} can be used to update the PAT. -#' -#' \code{get_PAT(service)} is used to get the PAT for a internet service that previously has been saved in the users profile at the current -#' computer. -#' -#' \code{remove_PAT(service)} is used to delete the PAT for a internet service from the user's profile. -#' -#' @param service Name of the internet service, for example "GitHub". For internet services where one don't use the premade wrappers, the name can -#' be chosen freely, but must be the same as used in \code{get_PAT} -#' @return \code{set_PAT} The PAT for a internet service are saved in the user profile at the current computer. -#' -#' \code{get_PAT} The PAT for a internet service are fetched from the user profile at the current computer to be used in R-scripts. -#' -#' \code{remove_PAT} The PAT for a internet service are deleted from the user profile at the current computer. -#' -#' @author Petter Hopp Petter.Hopp@@vetinst.no -#' -#' @export -#' @examples -#' \dontrun{ -#' set_PAT("GitHub") -#' -#' get_PAT("GitHub") -#' -#' remove_PAT("GitHub") -#' } -#' -set_PAT <- function(service) { - - - # ARGUMENT CHECKING service ---- - checkmate::assert_character(x = service, min.chars = 1, len = 1, any.missing = FALSE) - - # Removes previously set PAT for the database service - remove_PAT(service) - - # Open window for input of PAT to the given service and saves service and PAT in the user's profile - # Use the service name as input to username - keyring::key_set_with_value(service = service, - username = service, - # password = getPass::getPass(paste("Enter your PAT for", service)), - password = askpass::askpass(prompt = paste("Enter your PAT for", service)), - keyring = NULL) -} diff --git a/R/set_credentials.R b/R/set_credentials.R index bbd9cfe..d73a999 100644 --- a/R/set_credentials.R +++ b/R/set_credentials.R @@ -54,7 +54,8 @@ set_credentials <- function(dbservice) { remove_credentials(dbservice) # Open window for input of username to the given dbservice - username <- svDialogs::dlgInput(message = paste("Oppgi brukernavn for", dbservice))$res + # username <- svDialogs::dlgInput(message = paste("Oppgi brukernavn for", dbservice))$res + username <- askpass::askpass(prompt = paste("Oppgi brukernavn (username) for", dbservice)) # ARGUMENT CHECKING username ---- checkmate::assert_character(x = username, min.chars = 1, len = 1, any.missing = FALSE) diff --git a/R/set_dir_NVI.R b/R/set_dir_NVI.R index 3aa7033..17d3b10 100644 --- a/R/set_dir_NVI.R +++ b/R/set_dir_NVI.R @@ -4,9 +4,9 @@ #' directories. The function returns the standard directory for the given #' data source. Thereby hard coding of the paths may be avoided. #' -#' The path ends with a slash as default. To facilitate the use of -#' \code{\link[base:file.path]{file.path}} you can use the argument -#' \code{slash = FALSE} to avoid ending slash. +#' The path ends with a slash as default. To facilitate the use of +#' \ifelse{html}{\code{\link[base:file.path]{file.path}}}{\code{file.path}} +#' you can use the argument \code{slash = FALSE} to avoid ending slash. #' #' @param datasource [\code{character(1)}]\cr #' The data source that one want to access. The input can be abbreviated @@ -14,7 +14,7 @@ #' directories, use \code{set_dir_NVI(datasource = "?")}. #' @param slash [\code{logical(1)}]\cr #' If \code{TRUE} the path ends with a slash, Defaults to \code{TRUE}. -#' +#' #' @return The full path for the directory at NVI's network. The path ends with #' "/" as default, see details. #' @@ -27,14 +27,14 @@ #' prodtilskudd_path <- set_dir_NVI(datasource = "ProdTilskudd") #' #' # Set pathname to a file using 'file.path' -#' pathname <- file.path(set_dir_NVI(datasource = "ProdTilskudd", slash = FALSE), -#' "subdir", +#' pathname <- file.path(set_dir_NVI(datasource = "ProdTilskudd", slash = FALSE), +#' "subdir", #' "filename") #' } #' set_dir_NVI <- function(datasource, slash = TRUE) { - + # ARGUMENT CHECKING ---- # Object to store check-results checks <- checkmate::makeAssertCollection() @@ -48,7 +48,7 @@ set_dir_NVI <- function(datasource, checkmate::assert_flag(x = slash, add = checks) # Report check-results checkmate::reportAssertions(checks) - + # SETTING THE PATH ---- # The paths are defined in the package NVIconfig pathname <- unname(NVIconfig:::path_NVI[datasource]) @@ -57,4 +57,3 @@ set_dir_NVI <- function(datasource, } return(pathname) } - diff --git a/R/set_disease_parameters.R b/R/set_disease_parameters.R index 805a5b4..3d36c32 100644 --- a/R/set_disease_parameters.R +++ b/R/set_disease_parameters.R @@ -1,45 +1,72 @@ #' @title Sets disease selection parameters #' @description Sets the disease selection parameters and store them in a list #' object. The list follows a standardised named format and the elements can -#' be used as input to \code{\link{build_query_one_disease}}, -#' \code{\link{build_query_hensikt}} or \code{\link{build_query_outbreak}}. +#' be used as input to +#' \ifelse{html}{\code{\link{build_query_hensikt}}}{\code{build_query_hensikt}}, +#' \ifelse{html}{\code{\link{build_query_one_disease}}}{\code{build_query_one_disease}} +#' or +#' \ifelse{html}{\code{\link{build_query_outbreak}}}{\code{build_query_outbreak}}. #' #' @details Saker in PJS that concern one infection / disease can be characterised #' by the "analytt" (at "konklusjon" and/or "resultat" level), specific "hensikter", #' a relevant "utbrudds_ID" and/or specific "metoder." These can be used to select #' saker in PJS and/or to structure and simplify the output from PJS. #' -#' One or more specific "hensikter" may be input to the selection statement. -#' With specific "hensikt" is meant a "hensikt" that will imply that the sample +#' One or more specific "hensiktkoder" may be input to the selection statement. +#' With specific "hensiktkode" is meant a "hensiktkode" that will imply that the sample #' will be examined for specific infectious agent(s) or disease. One or more -#' specific "metoder" may be input to the selection statement. With specific -#' "metode" is meant a "metode" that implies an examination that will give one -#' of the input 2 as a result. If sub-codes of "analytt" or "hensikt" +#' specific "metodekoder" may be input to the selection statement. With specific +#' "metodekode" is meant a "metodekode" that implies an examination that will give one +#' of the input 2 as a result. If sub-codes of "analyttkode" or "hensiktkode" #' should be included, end the code with \%. #' #' The selection parameters can be input values for dedicated arguments. For input parameters -#' \code{hensikt2select}, \code{utbrudd2select}, \code{metode2select}, and -#' \code{analytt2select}, the input may be given in a source file. This may be handy if the +#' \code{hensikt2select}, \code{hensikt2delete}, \code{utbrudd2select}, \code{metode2select}, +#' \code{analytt2select}, \code{analytt2delete}, \code{art2select}, and \code{include_missing_art}, +#' the input may be given in a source file. This may be handy if the #' selection will be performed many times. It also gives the possibility of -#' using a for loop that selects PJS-data and performs similar analyses at one +#' using a for loop that selects PJS-data and performs similar analyses for one #' disease at a time. #' -#' @param hensikt2select Vector with specific "hensikter". If sub-codes should -#' be included, end the code with \%. Can be \code{NULL}. -#' @param hensikt2delete Vector with "hensikter" for which saker should be excluded -#' If sub-codes should be included, end the code with \%. Can be \code{NULL}. -#' @param utbrudd2select String with an "utbruddsID". Can be \code{NULL}. -#' @param metode2select Vector with specific "metoder." Can be \code{NULL}. -#' @param analytt2select Vector with one or more "analyttkode" given as a character. -#' If sub-codes should be included, end the code with \%. Can be \code{NULL}. -#' @param art2select Vector with one or more "artkode" given as a character. -#' If sub-codes should be included, end the code with \%. \code{NA} can be -#' combined with another "artkode". Can be \code{NULL}. -#' @param missing_art Should missing art be included if one or more arter should -#' be selected. Character one of c("never", "always", "non_selected_hensikt"). -#' @param file path and file name for an R script that can be sourced and that -#' sets the parameters \code{hensikt2select}, \code{utbrudd2select}, \code{metode2select}, and -#' \code{analytt2select}. Can be \code{NULL}. +#' The selection parameter \code{analytt2delete} is intended for the situation where +#' \code{analytt2select} includes analytter higher in the hierarchy and there are +#' specific analytter lower in the hierarchy that should not be included. A typical +#' example is the selection of all samples with the analytt Mycobacterium spp and +#' below, but one is only interested in M. tuberculosis complex but not in M. avium. +#' +#' The possibility of input other arguments are kept to make it possible to use the +#' deprecated arguments \code{missing_art} and \code{file}. If these are used, a +#' warning is issued and the input is transferred to \code{include_missing_art} and +#' \code{selection_parameters}, respectively. +#' +#' @param hensikt2select [\code{character}]\cr +#' Specific "hensiktkoder" for the "analytt" in question. If sub-codes should +#' be included, end the code with \%.Defaults to \code{NULL}. +#' @param hensikt2delete [\code{character}]\cr +#' "hensiktkoder" for which saker should be excluded. +#' If sub-codes should be included, end the code with \%. Defaults to \code{NULL}. +#' @param utbrudd2select [\code{character(1)}]\cr +#' "utbruddsID". Defaults to \code{NULL}. +#' @param metode2select [\code{character}]\cr +#' Specific "metodekoder for the "analytt" in question." Defaults to \code{NULL}. +#' @param analytt2select [\code{character}]\cr +#' "analyttkoder" for the agent and/or disease. If sub-codes should be included, +#' end the code with \%. Defaults to \code{NULL}. +#' @param analytt2delete [\code{character}]\cr +#' Specific "analyttkoder" that should be deleted, see details. If sub-codes should +#' be included, end the code with \%. Defaults to \code{NULL}. +#' @param art2select [\code{character}]\cr +#' "artkoder". If sub-codes should be included, end the code with \%. \code{NA} can be +#' combined with another "artkode". Defaults to \code{NULL}. +#' @param include_missing_art [\code{character(1)}]\cr +#' Should missing art be included. Must be one of c("never", "always", "for_selected_hensikt"). +#' If NULL, it is set to "always" when \code{art2select} includes NA, else it is set to "never". +#' Defaults to \code{NULL}. +#' @param selection_parameters [\code{character(1)}]\cr +#' Either the path and file name for an R script that can be sourced and that +#' sets the selection parameters or a named list with the selection parameters +#' (i.e. equal to the output of this function). Defaults to \code{NULL}. +#' @param \dots Other arguments to be passed to `set_disease_parameters`. #' #' @return A named list with selection parameters that can be used to generate #' SQL selection-statements and facilitate structuring output from PJS. @@ -58,19 +85,51 @@ set_disease_parameters <- function(hensikt2select = NULL, utbrudd2select = NULL, metode2select = NULL, analytt2select = NULL, + analytt2delete = NULL, art2select = NULL, - missing_art = NULL, - file = NULL) { + include_missing_art = NULL, + selection_parameters = NULL, + ...) { # SET SELECTION PARAMETERS ---- + # Vector with possible selection parameter names + # missing_art is deprecated + var2select_template <- c("hensikt2select", "hensikt2delete", "utbrudd2select", + "metode2select", "analytt2select", "analytt2delete", "art2select", + "include_missing_art", "missing_art") + + # PREPARE ARGUMENTS BEFORE CHECKING ---- + if ("file" %in% ...names() & is.null(selection_parameters)) { + selection_parameters <- unlist(list(...)$file) + warning(paste("The argument 'file' is deprecated.", + "Use 'selection_parameters' instead", + "The input to 'file' has been transferred to 'selection_parameters' if this is NULL.")) + } + + if ("missing_art" %in% ...names() & is.null(include_missing_art)) { + include_missing_art <- unlist(list(...)$missing_art) + if (include_missing_art == "non_selected_hensikt") {include_missing_art <- "for_selected_hensikt"} + warning(paste("The argument 'missing_art' is deprecated.", + "Use 'include_missing_art' instead", + "The input to 'missing_art' has been transferred to 'include_missing_art' if this is NULL.")) + } + + + # Object to store check-results + checks <- checkmate::makeAssertCollection() # Import values from parameter file if exists - if (!is.null(file)) { - checkmate::assert_file(x = file) - if (!is.null(file)) { - script <- as.character(parse(file = file, encoding = "UTF-8")) + if (!is.null(selection_parameters)) { + NVIcheckmate::assert(checkmate::check_file_exists(x = selection_parameters, access = "r"), + checkmate::check_list(x = selection_parameters), + combine = "or", + comment = "The argument selection_parameter must either be a file with selection parameters or a list with selection parameters", + add = checks) + if (isTRUE(checkmate::check_file_exists(x = selection_parameters, access = "r"))) { + script <- as.character(parse(file = selection_parameters, encoding = "UTF-8")) - script <- script[grepl(pattern = paste0("[^hensikt2select|^hensikt2delete|^analytt2select|^metode2select|", - "^art2select|^utbrudd2select|^missing_art]", + script <- script[grepl(pattern = paste0("[^", + paste(var2select_template, collapse = "|^"), + "]", "[[:blank:]]*", "[=|<\\-]"), script)] @@ -79,23 +138,46 @@ set_disease_parameters <- function(hensikt2select = NULL, eval(parse(text = script[i])) } } + if (isTRUE(checkmate::check_list(x = selection_parameters))) { + checkmate::assert_subset(x = names(selection_parameters), + choices = var2select_template, + empty.ok = FALSE) + var2select <- intersect(names(selection_parameters[!sapply(selection_parameters, is.null)]), + var2select_template) + for (i in var2select) { + assign(i, unname(unlist(selection_parameters[i]))) + } + } + } + + # PREPARE INPUT BEFORE ARGUMENT CHECKING ---- + # when include_missing_art = NULL, set to "always" if NA included in art2select, else set to "never" + if (is.null(include_missing_art)) { + if (!is.null(art2select) && any(is.na(art2select))) { + include_missing_art <- "always" + } else { + include_missing_art <- "never" + } } # ARGUMENT CHECKING ---- - # Object to store check-results - checks <- checkmate::makeAssertCollection() + # # Object to store check-results + # checks <- checkmate::makeAssertCollection() # Perform checks - NVIcheckmate::assert_non_null(list(analytt2select, hensikt2select, utbrudd2select, file), add = checks) + NVIcheckmate::assert_non_null(list(analytt2select, hensikt2select, utbrudd2select, unlist(selection_parameters)), add = checks) checkmate::assert_character(hensikt2select, min.chars = 2, max.chars = 15, any.missing = FALSE, null.ok = TRUE, add = checks) checkmate::assert_character(hensikt2delete, min.chars = 2, max.chars = 15, any.missing = FALSE, null.ok = TRUE, add = checks) checkmate::assert_character(utbrudd2select, max.chars = 5, any.missing = FALSE, null.ok = TRUE, add = checks) checkmate::assert_character(metode2select, n.chars = 6, any.missing = FALSE, null.ok = TRUE, add = checks) checkmate::assert_character(analytt2select, min.chars = 2, max.chars = 20, any.missing = FALSE, null.ok = TRUE, add = checks) + checkmate::assert_character(analytt2delete, min.chars = 2, max.chars = 20, any.missing = FALSE, null.ok = TRUE, add = checks) checkmate::assert_character(art2select, min.chars = 2, max.chars = 20, all.missing = FALSE, null.ok = TRUE, add = checks) - if (!is.null(art2select)) { - checkmate::assert_choice(missing_art, choices = c("never", "always", "non_selected_hensikt"), add = checks) - } + # if (!is.null(art2select) && any(is.na(art2select))) { + checkmate::assert_choice(include_missing_art, + choices = c("never", "always", "for_selected_hensikt"), + add = checks) + # } # Report check-results checkmate::reportAssertions(checks) @@ -106,6 +188,7 @@ set_disease_parameters <- function(hensikt2select = NULL, "utbrudd2select" = utbrudd2select, "metode2select" = metode2select, "analytt2select" = analytt2select, + "analytt2delete" = analytt2delete, "art2select" = art2select, - "missing_art" = missing_art)) + "include_missing_art" = include_missing_art)) } diff --git a/R/standardize_PJSdata.R b/R/standardize_PJSdata.R index 643a035..8c1d2e6 100644 --- a/R/standardize_PJSdata.R +++ b/R/standardize_PJSdata.R @@ -1,13 +1,16 @@ #' @title Standardizing PJS-data #' @description Standardizing PJS-data. This standardizing should always be performed. #' Other functions used for further preparation of PJSdata, like -#' \code{\link{choose_PJS_levels}}, and \code{\link{exclude_from_PJSdata}} +#' \ifelse{html}{\code{\link{choose_PJS_levels}}}{\code{choose_PJS_levels}} +#' , and +#' \ifelse{html}{\code{\link{exclude_from_PJSdata}}}{\code{exclude_from_PJSdata}} #' will not work as intended unless the column names are standardized. #' #' @details The function performs the following standardizing of data extracted from PJS: #' \itemize{ #' \item The unnecessary columns konkl_provenr and vet_distriktnr are removed. -#' \item The column names are standardized using \code{\link{standardize_columns}}. +#' \item The column names are standardized using +#' \ifelse{html}{\code{\link{standardize_columns}}}{\code{standardize_columns}}. #' \item Numeric variables are transformed to numbers. #' \item Date variables are transformed to date format. #' \item Character variables are trimmed for leading and trailing spaces. @@ -15,11 +18,16 @@ #' \item Test data, i.e. saker with ansvarlig_seksjon in c("14", "99") are deleted. #' } #' -#' @param PJSdata Data frame with data extracted from PJS. -#' @param dbsource If specified, this will be used for fetching standard column -#' names by \code{\link{standardize_columns}}. +#' @param PJSdata [\code{data.frame}]\cr +#' Data retrieved from PJS. +#' @param dbsource [\code{character(1)}]\cr +#' The table that is the source of data. This will be used for fetching +#' standard column names by +#' \ifelse{html}{\code{\link{standardize_columns}}}{\code{standardize_columns}} +#' and should be the name of the data source as registered in the +#' "column_standards" table. Defaults to "v2_sak_m_res". #' -#' @return data frame with standardized PJS-data. +#' @return \code{data.frame} with standardized PJS-data. #' #' @author Petter Hopp Petter.Hopp@@vetinst.no #' @author Johan Åkerstedt Johan.Akerstedt@@vetinst.no diff --git a/R/standardize_columns.R b/R/standardize_columns.R index 22c4672..0f1282f 100644 --- a/R/standardize_columns.R +++ b/R/standardize_columns.R @@ -1,60 +1,116 @@ #' @title Standardize columns for scripts and reports -#' @description Standardizes column names, labels, column width for variables in external databases. +#' @description Standardizes column names, labels, column width +#' for variables in external databases. #' -#' @details Experimental, the standardization table is under development. This version only works when being connected to the NVI network. +#' @details The standardization table is under development. This +#' function only works when being connected to the NVI network. #' -#' Variables in internal and external data sources uses different variable names for the same content. -#' \code{Standarddize_columns} standardizes column names for use in scripts. It will be further developed to standardize column labels -#' and column widths for both Excel and DT. Furthermore, input values for the parameter \code{colClasses = } for \code{read.csv2} can be -#' generated. +#' Variables in internal and external data sources uses +#' different variable names for the same content. +#' \code{Standardize_columns} standardizes column names for +#' use in scripts. In addition, it standardises column labels +#' and column widths for Excel. Furthermore, input values for +#' the parameter \code{colClasses} for +#' \ifelse{html}{\code{\link[utils:read.csv2]{read.csv2}}}{\code{read.csv2}} +#' and +#' \ifelse{html}{\code{\link[data.table:fread]{data.table::fread}}}{\code{data.table::fread}} +#' can be generated. #' -#' \code{property = "colnames"} will replace the column names in a data frame with standardized column names. -#' All standard column names is snake_case. If no standard name is defined for a variable name, the variable -#' name is translated to snake_case and the national characters \code{c("æ", "ø", "å")} are translated to \code{c("ae", "oe", "aa")}. +#' \code{property = "colnames"} will replace the column names +#' in a data frame with standardized column names. All +#' standard column names is snake_case. If no standard name +#' is defined for a variable name, the variable +#' name is translated to snake_case and the national characters +#' c("æ", "ø", "å") are translated to +#' c("ae", "oe", "aa"). #' -#' \code{property = "colclasses"} will generate a named vector with the column classes for variables that may not be read correct when importing -#' data from a csv-file. This applies for example to numbers with leading zero that must be imported as character. This vector can be used as a -#' parameter for \code{colClasses = }. +#' \code{property = "colclasses"} will generate a named vector +#' with the column classes for variables that may not be read +#' correct when importing data from a csv-file. This applies +#' for example to numbers with leading zero that must be imported +#' as character. This vector can be used as a parameter for +#' \code{colClasses}. #' -#' The default fileEncoding is assumed to be "UTF-8". If another encoding one must give an additional argument like \code{fileEncoding = "latin"}. +#' The default \code{fileEncoding} is assumed to be "UTF-8". +#' If another encoding is needed, one must give an additional +#' argument like \code{fileEncoding = "latin1"}. #' -#' \code{property = "collabels"} will generate a vector with column labels that can be used to replace the column names in the header of the data -#' table. The column names are not changed automatiacally but can be changed by using a colname statement (see help). If no standard column label -#' is defined, the column name as Sentence case is used as column label. If English names are used and no English column label exists, the Norwegian -#' column label is used instead. +#' \code{property = "collabels"} will generate a vector with column +#' labels that can be used to replace the column names in the +#' header of the data table. The column names are not standardised +#' automatically but can be standardised by first using +#' \code{standardize_colnames} with \code{property = "colname"}. +#' If no standard column label for the column name is defined, +#' the column name as Sentence case is used as column label. +#' If English names are used and no English column label exists, +#' the Norwegian column label is used instead. #' -#' \code{property = "colwidths_Excel"} will generate a vector with column widths for Excel. To be used as input parameter to \code{openxlsx::.colwidth()}. -#' If no standard column width is defined, the Excel standard width of 10.78 is used. Be aware that the generation of column widths are based on the -#' column names. Do not change the column names to labels before the column widths are generated. +#' \code{property = "colwidths_Excel"} will generate a vector with +#' column widths for Excel. To be used as input parameter to +#' \ifelse{html}{\code{\link[openxlsx:setColWidths]{openxlsx::setColWidths}}}{\code{openxlsx::setColWidths}}. +#' If no standard column width is defined, the Excel standard +#' width of 10.78 is used. Be aware that the generation of column +#' widths are based on the column names. Do not change the column +#' names to labels before the column widths are generated. #' -#' \code{property = "colorder"} will generate a data frame with the column names in a predefined order. The column names should first have been standardized. -#' No standard order will be given unless the dbsource is defined in the column_standards table. If \code{exclude = FALSE} (the standard) the columns with no -#' predefined order will be moved to the last columns in the same order as they appeared in the original data frame. If \code{exclude = TRUE} all columns with -#' no predefined order is excluded from the data frame. This option is mainly intended for well defined and worked through routines like making selections lists -#' for the Food Safety Authority. Do not use \code{exclude = TRUE} unless you are certain that all columns that should be included are defined in the -#' column_standards table for this dbsource. If uncertain, you may first try with \code{exclude = FALSE} and thereafter compare with \code{exclude = TRUE} to -#' check if you loose important information. +#' \code{property = "colorder"} will generate a data frame with +#' the column names in a predefined order. The column names +#' should first have been standardised. No standard order will +#' be given unless the dbsource is defined in the column_standards +#' table. If \code{exclude = FALSE} (the standard) the columns +#' with no predefined order will be moved to the last columns +#' in the same order as they appeared in the original data frame. +#' If \code{exclude = TRUE} all columns with no predefined order +#' is excluded from the data frame. This option is mainly +#' intended for well defined and worked through routines like +#' making selections lists for the Food Safety Authority. Do +#' not use \code{exclude = TRUE} unless you are certain that +#' all columns that should be included are defined in the +#' column_standards table for this dbsource. If uncertain, +#' you may first try with \code{exclude = FALSE} and thereafter +#' compare with \code{exclude = TRUE} to check if you loose +#' important information. #' -#' @param data Data frame or if \code{property = "colclasses"} the path and filname of the csv-file used as data source -#' @param dbsource database source of data. Set to data if not specifically specified. Needed if translation to column names is dependent on data source -#' @param standards to input alternative standard tables to column_standards -#' @param property Property of the column that should be standardized, currently c("colnames", "colclasses", "collabels", "colwidths_Excel", "colorder"). -#' @param language Language for labels. Valid input are c("no", "en") -#' @param exclude Used in combination with \code{property = "colorder"}. \code{exclude = TRUE} excludes all columns with no predefinedcolorder. -#' @param \dots Other arguments to be passed read.csv2 when \code{property = "colclasses"}. +#' @param data [\code{data.frame} | \code{character(1)}]\cr +#' The data source. If \code{property = "colclasses"} the path and +#' file name of the csv-file used as data source should be given. +#' @param dbsource [\code{character(1)}]\cr +#' The database that is the source of data. Should be the name of +#' the data source as registered in column_standards table. Defaults +#' to \code{deparse(substitute(data))}. +#' @param standards [\code{character(1)}]\cr +#' For giving alternative standard tables to column_standards. +#' @param property [\code{character(1)}]\cr +#' Property of the column that should be standardized. Must be one +#' of c("colnames", "colclasses", "collabels", "colwidths_Excel", +#' "colorder"). Defaults to \code{NULL}. +#' @param language [\code{character(1)}]\cr +#' Language for labels. Must be one of c("no", "en"). Defaults to "no". +#' @param exclude [\code{logical(1)}]\cr +#' Used in combination with \code{property = "colorder"}. If \code{TRUE}, +#' all columns with no predefined column order are excluded. +#' Defaults to \code{FALSE}. +#' @param \dots Other arguments to be passed to +#' \ifelse{html}{\code{\link[utils:read.csv2]{read.csv2}}}{\code{read.csv2}} +#' when \code{property = "colclasses"}. #' -#' @return \code{property = "colnames"}. A data frame with standard column names. +#' @return \code{property = "colnames"}: A data frame with standard column names. #' -#' \code{property = "colclasses"}. a named vector of column classes to be used as input to functions for reading csv-files. +#' \code{property = "colclasses"}: A named vector of column classes to +#' be used as input to functions for reading csv-files, see details. #' -#' \code{property = "collabels"}. a vector with labels for the columns in the data frame. +#' \code{property = "collabels"}: A vector with labels for the columns +#' in the data frame. #' -#' \code{property = "colwidths_Excel"}. a vector with column widths for Excel. To be used as input parameter to \code{openxlsx::.colwidth()}. +#' \code{property = "colwidths_Excel"}: A vector with column widths for Excel. +#' To be used as input parameter to +#' \ifelse{html}{\code{\link[openxlsx:setColWidths]{openxlsx::setColWidths}}}{\code{openxlsx::setColWidths}}. #' -#' \code{property = "colorder"}. A data frame with column names in predefined order. If exclude = TRUEonly columns withh a defined order is included +#' \code{property = "colorder"}: A data frame with column names in predefined +#' order. If \code{exclude = TRUE} only columns with a defined order is included. #' #' @author Petter Hopp Petter.Hopp@@vetinst.no -#' @importFrom rlang .data +# @importFrom rlang .data #' @export #' @examples #' \dontrun{ @@ -84,7 +140,6 @@ standardize_columns <- function(data, language = "no", exclude = FALSE, ...) { - # TO DO: replace reading column standards with including column standards in sysdata for the package. # ARGUMENT CHECKING ---- @@ -105,8 +160,11 @@ standardize_columns <- function(data, checkmate::assert_data_frame(standards, null.ok = TRUE, add = checks) - checkmate::assert_subset(tolower(property), choices = c("colnames", "colclasses", "collabels", "colwidths_excel", - "colwidths_DT", "colorder"), add = checks) + checkmate::assert_subset(tolower(property), + choices = c("colnames", "colclasses", + "collabels", "colwidths_excel", + "colwidths_DT", "colorder"), + add = checks) checkmate::assert_subset(language, choices = c("no", "en"), add = checks) @@ -120,8 +178,10 @@ standardize_columns <- function(data, # Reading column standards from a csv-file based on in an Excel file if (is.null(standards)) { - column_standards <- utils::read.csv2(file = paste0(NVIdb::set_dir_NVI("ProgrammeringR"), "standardization/column_standards.csv"), - fileEncoding = "UTF-8") + column_standards <- utils::read.csv2( + file = paste0(NVIdb::set_dir_NVI("ProgrammeringR"), "standardization/column_standards.csv"), + fileEncoding = "UTF-8" + ) } else { column_standards <- standards } @@ -134,26 +194,43 @@ standardize_columns <- function(data, # Necessary to avoid change in order when using merge columnnames$original_sort_order <- seq_len(nrow(columnnames)) - standard <- column_standards %>% - # Filter to include only information for relevant column names and with property information - dplyr::filter(.data$colname_db %in% columnnames$V1) %>% - dplyr::filter(!is.na(.data$colname)) %>% - dplyr::select(.data$table_db, .data$colname_db, .data$colname) %>% - dplyr::distinct() + # standard <- column_standards %>% + # # Filter to include only information for relevant column names and with property information + # dplyr::filter(.data$colname_db %in% columnnames$V1) %>% + # dplyr::filter(!is.na(.data$colname)) %>% + # dplyr::select(.data$table_db, .data$colname_db, .data$colname) %>% + # dplyr::distinct() + standard <- column_standards + # Filter to include only information for relevant column names and with property information + standard <- subset(standard, standard$colname_db %in% columnnames$V1) + standard <- subset(standard, !is.na(standard$colname)) + standard <- standard[, c("table_db", "colname_db", "colname")] + # standard <- unique(standard) # Keep information on relevant table name and combine information for all other tables standard[which(standard$table_db != dbsource), "table_db"] <- NA standard <- unique(standard) if (dim(standard)[1] > 0) { - standard <- standard %>% - # Identify column names with only one suggested column width - dplyr::add_count(.data$colname_db, name = "n") %>% - dplyr::ungroup() %>% - # Select column width either if only one suggested or for the current table - dplyr::filter(.data$n == 1 | .data$table_db == dbsource & .data$n > 1) %>% - dplyr::select(.data$colname_db, .data$colname) %>% - dplyr::distinct() + # standard <- standard %>% + # # Identify column names with only one suggested column width + # dplyr::add_count(.data$colname_db, name = "n") %>% + # dplyr::ungroup() # %>% + # Identify column names with only one suggested column width + aggregated_value <- stats::aggregate(stats::as.formula(paste("cbind(n = colname)", + "~", + paste(c("colname_db"), collapse = " + "))), + data = standard, + FUN = function(x) {length(x)}) + standard <- merge(x = standard, y = aggregated_value, by = "colname_db", all.x = TRUE) + # # Select column width either if only one suggested or for the current table + # dplyr::filter(.data$n == 1 | .data$table_db == dbsource & .data$n > 1) %>% + # dplyr::select(.data$colname_db, .data$colname) %>% + # dplyr::distinct() + # Select column width either if only one suggested or for the current table + standard <- subset(standard, standard$n == 1 | (standard$table_db == dbsource & standard$n > 1)) + standard <- standard[, c("colname_db", "colname")] + standard <- unique(standard) } # # Standardize column names @@ -191,13 +268,14 @@ standardize_columns <- function(data, # READ FIRST LINE OF CSV-FILE, IDENTIFY COLUMN CLASSES AND PRODUCE A NAMED VECTOR FOR THE colclasses PARAMETER ---- if (property == "colclasses") { - # Read standard colclasses for database variable names stand_character <- unique(column_standards[which(!is.na(column_standards$colclasses)), c("colname_db", "colclasses")]) # Identifies columns that can look like numbers but should be treated as characters, usually because of leading zero # Read first line of csv-file - if (!exists("fileEncoding")) {fileEncoding <- "UTF-8"} + if (!exists("fileEncoding")) { + fileEncoding <- "UTF-8" + } colcharacter <- utils::read.csv2(file = data, header = FALSE, nrow = 1, fileEncoding = fileEncoding) # Transform the header into a data frame with one column colcharacter <- as.data.frame(matrix(colcharacter, ncol = 1)) @@ -222,55 +300,89 @@ standardize_columns <- function(data, ## Norwegian column labels ---- # Standard labels in Norwegian is always generated as is used to impute missing labels in other languages - standard <- column_standards %>% - # Filter to include only information for relevant column names and with property information - dplyr::filter(.data$colname %in% collabels$V1) %>% - dplyr::filter(!is.na(.data$label_1_no)) %>% - dplyr::select(.data$table_db, .data$colname, .data$label_1_no) %>% - dplyr::distinct() + # standard <- column_standards %>% + # # Filter to include only information for relevant column names and with property information + # dplyr::filter(.data$colname %in% collabels$V1) %>% + # dplyr::filter(!is.na(.data$label_1_no)) %>% + # dplyr::select(.data$table_db, .data$colname, .data$label_1_no) %>% + # dplyr::distinct() + standard <- column_standards + # Filter to include only information for relevant column names and with property information + standard <- subset(standard, standard$colname %in% collabels$V1) + standard <- subset(standard, !is.na(standard$label_1_no)) + standard <- standard[, c("table_db", "colname", "label_1_no")] + # standard <- unique(standard) # Keep information on relevant table name and combine information for all other tables standard[which(standard$table_db != dbsource), "table_db"] <- NA standard <- unique(standard) if (dim(standard)[1] > 0) { - standard <- standard %>% - # Identify column names with only one suggested column width - dplyr::add_count(.data$colname, name = "n") %>% - dplyr::ungroup() %>% - # Select column width either if only one suggested or for the current table - dplyr::filter(.data$n == 1 | .data$table_db == dbsource & .data$n > 1) %>% - dplyr::select(.data$colname, label = .data$label_1_no) %>% - dplyr::distinct() + # standard <- standard %>% + # # Identify column names with only one suggested column width + # dplyr::add_count(.data$colname, name = "n") %>% + # dplyr::ungroup() # %>% + aggregated_value <- stats::aggregate(stats::as.formula(paste("cbind(n = label_1_no)", + "~", + paste(c("colname"), collapse = " + "))), + data = standard, + FUN = function(x) {length(x)}) + standard <- merge(x = standard, y = aggregated_value, by = "colname", all.x = TRUE) + # Select column width either if only one suggested or for the current table + # dplyr::filter(.data$n == 1 | (.data$table_db == dbsource & .data$n > 1)) %>% + # dplyr::select(.data$colname, label = .data$label_1_no) %>% + # dplyr::distinct() + standard <- subset(standard, standard$n == 1 | (standard$table_db == dbsource & standard$n > 1)) + standard <- standard[, c("colname", "label_1_no")] + colnames(standard) <- c("colname", "label") + standard <- unique(standard) + } ## English column labels ---- if (language == "en") { - standard_en <- column_standards %>% - dplyr::filter(.data$colname %in% collabels$V1) %>% - dplyr::filter(!is.na(.data$label_1_en)) %>% - dplyr::select(.data$table_db, .data$colname, .data$label_1_en) %>% - dplyr::distinct() + standard_en <- column_standards # %>% + # dplyr::filter(.data$colname %in% collabels$V1) %>% + # dplyr::filter(!is.na(.data$label_1_en)) %>% + # dplyr::select(.data$table_db, .data$colname, .data$label_1_en) %>% + # dplyr::distinct() + # Filter to include only information for relevant column names and with property information + standard_en <- subset(standard_en, standard_en$colname %in% collabels$V1) + standard_en <- subset(standard_en, !is.na(standard_en$label_1_en)) + standard_en <- standard_en[, c("table_db", "colname", "label_1_en")] + standard_en <- unique(standard_en) # Keep information on relevant table name and combine information for all other tables standard_en[which(standard_en$table_db != dbsource), "table_db"] <- NA standard_en <- unique(standard_en) if (dim(standard_en)[1] > 0) { - standard_en <- standard_en %>% - # Identify column names with only one suggested column width - dplyr::add_count(.data$colname, name = "n") %>% - dplyr::ungroup() %>% - dplyr::filter(.data$n == 1 | .data$table_db == dbsource & .data$n > 1) %>% - dplyr::select(.data$colname, .data$label_1_en) %>% - dplyr::distinct() + # standard_en <- standard_en %>% + # # Identify column names with only one suggested column width + # dplyr::add_count(.data$colname, name = "n") %>% + # dplyr::ungroup() # %>% + aggregated_value <- stats::aggregate(stats::as.formula(paste("cbind(n = label_1_en)", + "~", + paste(c("colname"), collapse = " + "))), + data = standard_en, + FUN = function(x) {length(x)}) + standard_en <- merge(x = standard_en, y = aggregated_value, by = "colname", all.x = TRUE) + # dplyr::filter(.data$n == 1 | (.data$table_db == dbsource & .data$n > 1)) %>% + # dplyr::select(.data$colname, .data$label_1_en) %>% + # dplyr::distinct() + standard_en <- subset(standard_en, standard_en$n == 1 | (standard_en$table_db == dbsource & standard_en$n > 1)) + standard_en <- standard_en[, c("colname", "label_1_en")] + standard_en <- unique(standard_en) } # Impute missing labels with Norwegian labels - standard <- standard_en %>% - dplyr::full_join(standard, by = c("colname" = "colname")) %>% - dplyr::mutate(label = dplyr::coalesce(.data$label_1_en, .data$label)) %>% - dplyr::select(.data$colname, .data$label) + # standard <- standard_en %>% + # dplyr::full_join(standard, by = c("colname" = "colname")) %>% + # dplyr::mutate(label = dplyr::coalesce(.data$label_1_en, .data$label)) %>% + # dplyr::select(.data$colname, .data$label) + standard <- merge(x = standard, y = standard_en, by = "colname", all.x = TRUE) + standard[which(!is.na(standard$label_1_en)), "label"] <- standard[which(!is.na(standard$label_1_en)), "label_1_en"] + standard <- standard[, c("colname", "label")] } ## Impute Sentence case for those without defined label ----¨ @@ -278,9 +390,13 @@ standardize_columns <- function(data, # Impute with Sentence case of column name in case standard column name isn't defined collabels[which(is.na(collabels$label)), "label"] <- snakecase::to_sentence_case(collabels[which(is.na(collabels$label)), "V1"], - transliterations = c("aa" = "\u00e5", "Aa" = "\u00e5", "AA" = "\u00e5", "aA" = "\u00e5", - "oe" = "\u00f8", "Oe" = "\u00f8", "OE" = "\u00f8", "oE" = "\u00f8", - "ae" = "\u00e6", "Ae" = "\u00e6", "AE" = "\u00e6", "aE" = "\u00e6")) + transliterations = c("aa" = "\u00e5", "Aa" = "\u00e5", + "AA" = "\u00e5", "aA" = "\u00e5", + "oe" = "\u00f8", "Oe" = "\u00f8", + "OE" = "\u00f8", "oE" = "\u00f8", + "ae" = "\u00e6", "Ae" = "\u00e6", + "AE" = "\u00e6", "aE" = "\u00e6") + ) ## Make vector with column labels # Sorts data in original order @@ -291,7 +407,6 @@ standardize_columns <- function(data, # Return data frame with standardized column names return(collabels) - } # STANDARDIZE COLUMN WIDTHS FOR EXCEL ---- @@ -306,29 +421,42 @@ standardize_columns <- function(data, # print(head(column_standards)) # Standardize colwidths - standard <- column_standards %>% - # Filter to include only information for relevant column names and with property information - dplyr::filter(.data$colname %in% colwidths$V1) %>% - dplyr::filter(!is.na(.data$colwidth_Excel)) %>% - dplyr::select(.data$table_db, .data$colname, colwidth = .data$colwidth_Excel) - # uses which below as there seem to be a bug so that case_when doesn't work properly within a function - # dplyr::mutate(table_db = dplyr::case_when(table_db == "dbsource" ~ table_db, - # TRUE ~ as.character(NA))) %>% + # standard <- column_standards %>% + # # Filter to include only information for relevant column names and with property information + # dplyr::filter(.data$colname %in% colwidths$V1) %>% + # dplyr::filter(!is.na(.data$colwidth_Excel)) %>% + # dplyr::select(.data$table_db, .data$colname, colwidth = .data$colwidth_Excel) # dplyr::distinct() + standard <- column_standards + # Filter to include only information for relevant column names and with property information + standard <- subset(standard, standard$colname %in% colwidths$V1) + standard <- subset(standard, !is.na(standard$colwidth_Excel)) + standard <- standard[, c("table_db", "colname", "colwidth_Excel")] + colnames(standard) <- c("table_db", "colname", "colwidth") # Keep information on relevant table name and combine information for all other tables standard[which(standard$table_db != dbsource), "table_db"] <- NA standard <- unique(standard) # if there are information on column widths if (dim(standard)[1] > 0) { - standard <- standard %>% - # Identify column names with only one suggested column width - dplyr::add_count(.data$colname, name = "n") %>% - dplyr::ungroup() %>% - # Select column width either if only one suggested or for the current table - dplyr::filter(.data$n == 1 | .data$table_db == dbsource & .data$n > 1) %>% - dplyr::select(.data$colname, .data$colwidth) %>% - dplyr::distinct() + # standard <- standard %>% + # # Identify column names with only one suggested column width + # dplyr::add_count(.data$colname, name = "n") %>% + # dplyr::ungroup() # %>% + aggregated_value <- stats::aggregate(stats::as.formula(paste("cbind(n = colwidth)", + "~", + paste(c("colname"), collapse = " + "))), + data = standard, + FUN = function(x) {length(x)}) + standard <- merge(x = standard, y = aggregated_value, by = "colname", all.x = TRUE) + # # Select column width either if only one suggested or for the current table + # dplyr::filter(.data$n == 1 | .data$table_db == dbsource & .data$n > 1) %>% + # dplyr::select(.data$colname, .data$colwidth) %>% + # dplyr::distinct() + # Select column width either if only one suggested or for the current table + standard <- subset(standard, standard$n == 1 | (standard$table_db == dbsource & standard$n > 1)) + standard <- standard[, c("colname", "colwidth")] + standard <- unique(standard) } # New column with standard column names¨ @@ -348,7 +476,6 @@ standardize_columns <- function(data, # STANDARDIZE COLUMN ORDER ---- if (property == "colorder") { - if (!dbsource %in% column_standards[which(!is.na(column_standards$colorder)), "table_db"]) { warning("No sorting done as column order is not known for this table. Please update column_standards or use another dbsource") } else { @@ -360,19 +487,39 @@ standardize_columns <- function(data, ## Norwegian column labels ---- # Standard labels in Norwegian is always generated as is used to impute missing labels in other languages - standard <- column_standards %>% - # Filter to include only information for relevant column names and with property information - dplyr::filter(.data$table_db == dbsource) %>% - dplyr::filter(.data$colname %in% columnorder$V1) %>% - dplyr::filter(!is.na(.data$colorder)) %>% - dplyr::select(.data$colname, .data$colorder) %>% - dplyr::distinct() %>% - # removes colorders with more than suggested position - dplyr::add_count(.data$colname, name = "n") %>% - dplyr::filter(.data$n == 1) %>% - dplyr::select(.data$colname, .data$colorder) %>% - # Sort according to first column - dplyr::arrange(.data$colorder) + standard <- column_standards # %>% + # Filter to include only information for relevant column names and with property information + # dplyr::filter(.data$table_db == dbsource) %>% + # dplyr::filter(.data$colname %in% columnorder$V1) %>% + # dplyr::filter(!is.na(.data$colorder)) %>% + # dplyr::select(.data$colname, .data$colorder) %>% + # dplyr::distinct() %>% + + standard <- subset(standard, standard$table_db == dbsource) + standard <- subset(standard, standard$colname %in% columnorder$V1) + standard <- subset(standard, !is.na(standard$colorder)) + standard <- standard[, c("colname", "colorder")] + standard <- unique(standard) + + # removes colorders with more than suggested position + # standard <- standard %>% + # dplyr::add_count(.data$colname, name = "n") %>% + # dplyr::ungroup() # %>% + aggregated_value <- stats::aggregate(stats::as.formula(paste("cbind(n = colorder)", + "~", + paste(c("colname"), collapse = " + "))), + data = standard, + FUN = function(x) {length(x)}) + standard <- merge(x = standard, y = aggregated_value, by = "colname", all.x = TRUE) + # dplyr::filter(.data$n == 1) %>% + # dplyr::select(.data$colname, .data$colorder) %>% + # # Sort according to first column + # dplyr::arrange(.data$colorder) + + standard <- subset(standard, standard$n == 1) + standard <- standard[, c("colname", "colorder")] + # Sort according to colorder + standard <- standard[order(standard$colorder), ] # Order in accord with standard. # Keep non-ordered columns in last columns if exclude = FALSE diff --git a/R/standardize_eos_data.R b/R/standardize_eos_data.R index 08d271a..1bb719d 100644 --- a/R/standardize_eos_data.R +++ b/R/standardize_eos_data.R @@ -1,4 +1,4 @@ -#' @title Standardising EOS-data +#' @title Standardising EOS-data #' @description Standardising EOS-data. This standardising should always be performed. #' Otherwise summary numbers can be wrong. #' @@ -7,52 +7,52 @@ #' \item The column names are standardised using \code{\link{standardize_columns}}. #' \item Numeric variables are transformed to numbers. #' \item Datetime variables are transformed to dates. -#' \item Double registrations of a "Sak" due to the municipality being divided -#' between two Food Safety Authority office, are merged into one and for +#' \item Double registrations of a "Sak" due to the municipality being divided +#' between two Food Safety Authority office, are merged into one and for #' these, the information on Food Safety Authority office is removed. -#' \item Splits saksnr into saksnr and fagnr if saksnr combines both. -#' \item Breed is transformed to species. -#' \item Number of examined samples are corrected so it don't exceed the number +#' \item Splits saksnr into saksnr and fagnr if saksnr combines both. +#' \item Breed is transformed to species. +#' \item Number of examined samples are corrected so it don't exceed the number #' of received samples. -#' \item Redundant variables are deleted. +#' \item Redundant variables are deleted. #' } -#' Standardisation of column names may be set to \code{FALSE}. This should only be -#' done if the column names have been standardised previously as a new -#' standardisation of column names may give unpredicted results. Remark that all -#' other standardisations are dependent on standard column names, so the function +#' Standardisation of column names may be set to \code{FALSE}. This should only be +#' done if the column names have been standardised previously as a new +#' standardisation of column names may give unpredicted results. Remark that all +#' other standardisations are dependent on standard column names, so the function #' will not work if the data do not have standard column names. -#' +#' #' Transformation from breed to species is only performed when species is included #' in the data. You need to import the translation table for PJS-codes to perform #' the translation, use \code{PJS_codes_2_text <- read_PJS_codes_2_text()}. -#' +#' #' Correction of number of tested samples is only done when both number of received #' and number of tested are included in the data. -#' +#' #' There are a few reduntant varibles in some data sets. In CWD data both "sist_overfort" -#' and "sist_endret" keeps the same information. "sist_endret" is deleted. In -#' Salmonella and Campylobacter data, "prove_identitet" is always \code{NULL} and +#' and "sist_endret" keeps the same information. "sist_endret" is deleted. In +#' Salmonella and Campylobacter data, "prove_identitet" is always \code{NULL} and #' "prove_id" is \code{NULL} for salmonella data and equal ti "id_nr" for Campylobacter #' data. Both are deleted. Set \code{delete_redundant = FALSE} to keep them. -#' +#' #' @param data [\code{data.frame}]\cr #' The data retrieved from EOS. #' @param dbsource [\code{character(1)}]\cr -#' If specified, this will be used for fetching standard column names by -#' \code{\link{standardize_columns}}. Defaults to the name of the input data. +#' If specified, this will be used for fetching standard column names by +#' \code{\link{standardize_columns}}. Defaults to the name of the input data. #' @param standards [\code{data.frame}]\cr -#' The translation table to standard column names. Defaults to \code{NULL}. +#' The translation table to standard column names. Defaults to \code{NULL}. #' @param standardize_colnames [\code{logical(1)}]\cr -#' If \code{TRUE}, the column names will be standardised. Defaults to \code{TRUE)}. +#' If \code{TRUE}, the column names will be standardised. Defaults to \code{TRUE)}. #' @param breed_to_species [\code{logical(1)}]\cr -#' If \code{TRUE}, breed is translated back to species. Defaults to \code{TRUE)}. +#' If \code{TRUE}, breed is translated back to species. Defaults to \code{TRUE)}. #' @param adjust_n_examined [\code{logical(1)}]\cr -#' If \code{TRUE}, the number of examined samples is adjusted so it is at maximum -#' the number of received samples. Defaults to \code{TRUE}. +#' If \code{TRUE}, the number of examined samples is adjusted so it is at maximum +#' the number of received samples. Defaults to \code{TRUE}. #' @param delete_redundant [\code{logical(1)}]\cr -#' If \code{TRUE}, redundant variables in the data is deleted. Defaults to \code{TRUE}. +#' If \code{TRUE}, redundant variables in the data is deleted. Defaults to \code{TRUE}. #' @param \dots Other arguments to be passed to \code{\link{standardize_columns}}. -#' +#' #' @return \code{data.frame} with standardized EOS-data. #' #' @author Petter Hopp Petter.Hopp@@vetinst.no @@ -65,14 +65,14 @@ #' } #' standardize_eos_data <- function(data, - dbsource = deparse(substitute(data)), - standards = NULL, + dbsource = deparse(substitute(data)), + standards = NULL, standardize_colnames = TRUE, - breed_to_species = TRUE, + breed_to_species = TRUE, adjust_n_examined = TRUE, delete_redundant = TRUE, ...) { - + # ARGUMENT CHECKING ---- # Object to store check-results checks <- checkmate::makeAssertCollection() @@ -80,13 +80,13 @@ standardize_eos_data <- function(data, checkmate::assert_data_frame(data, add = checks) checkmate::assert_character(dbsource, len = 1, min.chars = 1, add = checks) checkmate::assert_data_frame(standards, null.ok = TRUE, add = checks) - checkmate::assert_flag(standardize_colnames, add = checks) - checkmate::assert_flag(breed_to_species, add = checks) + checkmate::assert_flag(standardize_colnames, add = checks) + checkmate::assert_flag(breed_to_species, add = checks) checkmate::assert_flag(adjust_n_examined, add = checks) - checkmate::assert_flag(delete_redundant, add = checks) + checkmate::assert_flag(delete_redundant, add = checks) # Report check-results checkmate::reportAssertions(checks) - + # STANDARDISE DATA ---- # Standardise column names if (isTRUE(standardize_colnames)) { @@ -94,64 +94,64 @@ standardize_eos_data <- function(data, dbsource = dbsource, standards = standards, property = "colnames", - ...) + ...) } - + if (isTRUE(delete_redundant)) { - data$sist_overfort2 <- NULL - data$prove_id <- NULL - data$prove_identitet <- NULL + data$sist_overfort2 <- NULL + data$prove_id <- NULL + data$prove_identitet <- NULL } - + # Change to numeric for ID-numbers and counts # Performed before trimming character variables to reduce variables that needs to be trimmed - cols_2_modify <- intersect(colnames(data), c("lopenr", "aar", "innsendelsenr", "avvik_i_registrering", + cols_2_modify <- intersect(colnames(data), c("lopenr", "aar", "innsendelsenr", "avvik_i_registrering", "ant_prover", grep("ant_und", colnames(data), value = TRUE))) # for (number in cols_2_modify) { # data[, number] <- as.numeric(data[, number]) # } data[, cols_2_modify] <- lapply(data[, cols_2_modify], as.numeric) - + # Change to date for date-variables # Performed before trimming character variables to reduce variables that needs to be trimmed cols_2_modify <- intersect(colnames(data), c("mottatt", "uttatt", "avsluttet", "sist_endret", "sist_overfort", "sist_overfort2")) for (dato in cols_2_modify) { data[, dato] <- as.Date(substr(data[, dato], 1, 10), format = "%Y-%m-%d") } - - # remove double rows due to one Sak being assigned to two MT offices + + # remove double rows due to one Sak being assigned to two MT offices # It varies which variables keep the information on MT office - proveid <- intersect(c("saksnr", "id_nr", "art", "driftsform"), + proveid <- intersect(c("saksnr", "id_nr", "art", "driftsform"), colnames(data)) - groupvar <- intersect(c("rekvirent", "rekvirentnr", "mt_avdelingnr", "mt_avdeling"), + groupvar <- intersect(c("rekvirent", "rekvirentnr", "mt_avdelingnr", "mt_avdeling"), colnames(data)) - data <- data %>% - dplyr::add_count(dplyr::across(dplyr::all_of(proveid)), name = "ant_per_sak") %>% - dplyr::add_count(dplyr::across(dplyr::all_of(c(proveid, groupvar))), name = "ant_per_MT") - - rownums <- which(data$ant_per_sak == (2 * data$ant_per_MT) ) - column_names <- intersect(c("lopenr", "rekvirent", "rekvirentnr", "mt_avdelingnr", "mt_avdeling"), + data <- data %>% + dplyr::add_count(dplyr::across(dplyr::all_of(proveid)), name = "ant_per_sak") %>% + dplyr::add_count(dplyr::across(dplyr::all_of(c(proveid, groupvar))), name = "ant_per_MT") + + rownums <- which(data$ant_per_sak == (2 * data$ant_per_MT)) + column_names <- intersect(c("lopenr", "rekvirent", "rekvirentnr", "mt_avdelingnr", "mt_avdeling"), colnames(data)) data[rownums, column_names] <- rep(NA_integer_, length(column_names)) data[, c("ant_per_sak", "ant_per_MT")] <- c(NULL, NULL) data <- unique(data) - + # Split saksnr into saksnr and fagnr if saksnr combines both if (any(grepl("/", data$saksnr))) { data$fagnr <- gsub(pattern = "[[:digit:]]*/", replacement = "", x = data$saksnr) data$saksnr <- gsub(pattern = "/[[:alnum:]' ']*", replacement = "", x = data$saksnr) } - + # backtranslate breed to species if (isTRUE(breed_to_species) & "art" %in% colnames(data)) { - data <- add_PJS_code_description(data = data, + data <- add_PJS_code_description(data = data, PJS_variable_type = "artrase", code_colname = "art", new_column = "artkode", backward = TRUE, - impute_old_when_missing = TRUE) - - data <- add_PJS_code_description(data = data, + impute_old_when_missing = TRUE) + + data <- add_PJS_code_description(data = data, PJS_variable_type = "art", code_colname = "artkode", new_column = "art", @@ -159,8 +159,8 @@ standardize_eos_data <- function(data, overwrite = TRUE, impute_old_when_missing = TRUE) data$artkode <- NULL - } - + } + # adjust number of examined if (isTRUE(adjust_n_examined) & "ant_prover" %in% colnames(data)) { ant_und <- grep("ant_und", colnames(data), value = TRUE) @@ -168,6 +168,5 @@ standardize_eos_data <- function(data, data[, i] <- pmin(data[, "ant_prover"], data[, i]) } } - return(data) + return(data) } - diff --git a/R/transform_code_combinations.R b/R/transform_code_combinations.R new file mode 100644 index 0000000..4585c90 --- /dev/null +++ b/R/transform_code_combinations.R @@ -0,0 +1,186 @@ +#' @title Transform combinations of code values into new values +#' @description Transforms combinations of code values into new values in a data +#' frame. This is intended for use when only a few code value combinations +#' should be changed and one will avoid building translation tables or code +#' with several if, which or case_when statements. In particularly it was +#' inspired by the need of changing a few code combinations in PJS data when +#' reporting surveillance programmes. +#' @details The function builds a transformation table based on the input. The +#' `from_values` and the `to_values` give the data to a transformation table, +#' and the `from_columns` and the `to_columns` give the column names for the +#' transformation table. +#' +#' The `from_values` is a list of one or more vectors. Each vector is named with +#' the column name and represents one column variable with code values. The +#' first entry in each vector constitute one code combination to be +#' transformed, the second entry constitutes the next code combinations. +#' +#' Likewise, is the `to_values` a list of one or more named vectors. Each +#' vector is named and represents one column variable with +#' code values to which the code combinations in the `from_values` should be +#' transformed. The name of the vector is the name of the columns with the +#' transformed values. The transformed values can be put in the original columns, +#' in which case the transformed combinations will replace +#' the original entries. If the transformed column names don't exist in data, +#' the columns will be added to the data. +#' +#' If the codes are not transformed, these can be kept in the data. +#' `impute_when_missing_from` gives the column names of the columns from which +#' to impute. Normally this will be the same as the original columns. However, +#' if the number of transformed columns is less than the original columns, it +#' will be necessary to give the columns from which to keep the code. +#' +#' @param data \[\code{data.frame}\]\cr +#' Data with code values that should be transformed. +#' @param from_values \[\code{list}\]\cr +#' List with named vector(s) of code values that should transformed, see details and examples. +#' @param to_values \[\code{list}\]\cr +#' List with named vector(s) of code values that should be the results of the transformation, +#' see details and examples. +#' @param impute_when_missing_from \[\code{character}\]\cr +#' Column names for the code variables from which code values should be copied if no +#' transformation is performed. Defaults to the original column names. +#' +#' @return A `data.frame`. +#' +#' @author Petter Hopp Petter.Hopp@@vetinst.no +#' @md +#' @export +#' @examples +#' library(NVIdb) +#' +#' # A code combination of two is tranformed to another code combination of two +#' data <- as.data.frame(cbind( +#' c("Detected", "Detected", "Not detected", NA), +#' c("M. bovis", "M. kansasii", "M. bovis", NA) +#' )) +#' colnames(data) <- c("kjennelse", "analytt") +#' +#' data <- transform_code_combinations(data = data, +#' from_values = list("kjennelse" = c("Detected"), +#' "analytt" = c("M. kansasii")), +#' to_values = list("kjennelse" = c("Not detected"), +#' "analytt" = c("M. bovis")), +#' impute_when_missing_from = c("kjennelse", "analytt")) +#' +#' # two code values to one new variable +#' data <- as.data.frame(cbind(c("hjort", "rein", "elg", "hjort", NA), +#' c("produksjonsdyr", "ville dyr", "ville dyr", "ville dyr", NA))) +#' colnames(data) <- c("art", "driftsform") +#' +#' data <- transform_code_combinations( +#' data = data, +#' from_values = list("art" = c("hjort", "rein", NA), +#' "driftsform" = c("produksjonsdyr", "ville dyr", NA)), +#' to_values = list("art2" = c("oppdrettshjort", "villrein", "ukjent")), +#' impute_when_missing_from = "art") +transform_code_combinations <- function(data, + from_values, + to_values, + impute_when_missing_from = NULL) { + # ARGUMENT CHECKING ---- + # Object to store check-results + checks <- checkmate::makeAssertCollection() + # Perform checks + checkmate::assert_data_frame(data, add = checks) + checkmate::assert_list(from_values, min.len = 1, add = checks) + checkmate::assert_list(to_values, min.len = 1, add = checks) + # checkmate::assert_character(from_columns, min.len = 1, min.chars = 1, add = checks) + # checkmate::assert_character(to_columns, min.len = 1, min.chars = 1, add = checks) + checkmate::assert_character(impute_when_missing_from, max.len = length(to_values), null.ok = TRUE, add = checks) + checkmate::assert_subset(impute_when_missing_from, choices = names(from_values), add = checks) + # Report check-results + checkmate::reportAssertions(checks) + + # CREATE TRANSLATION TABLE WITH FROM AND TO VALUES ---- + to_columns_temp <- paste0(rep("tcc_V", length(to_values)), as.character(1:length(to_values))) + translation_table <- data.frame(to_values) + colnames(translation_table) <- to_columns_temp + translation_table <- cbind(data.frame(from_values), translation_table) + + # CREATE SUBSET TO TRANSLATE ---- + subdata <- as.data.frame(data[, names(from_values)]) + colnames(subdata) <- names(from_values) + # subdata[is.na(subdata)] <- "_NA_" + subdata$sort_order <- 1:nrow(subdata) + + # PERFORM TRANSLATION ---- + subdata <- merge(subdata, translation_table, by = names(from_values), all.x = TRUE) + + if (!is.null(impute_when_missing_from)) { + if (length(to_columns_temp) == 1) { + subdata[is.na(subdata[, to_columns_temp]), to_columns_temp] <- + subdata[is.na(subdata[, to_columns_temp]), impute_when_missing_from] + } else { + subdata[rowSums(is.na(subdata[, to_columns_temp])) == length(to_columns_temp), to_columns_temp[1:length(impute_when_missing_from)]] <- + subdata[rowSums(is.na(subdata[, to_columns_temp])) == length(to_columns_temp), impute_when_missing_from] + } + } + subdata <- subdata[order(subdata$sort_order), ] + + # RETURN DATA WITH TRANSLATED COLUMNS + data[, names(to_values)] <- subdata[, to_columns_temp] + return(data) +} + +# +# +# transform_code_combinations <- function(data, +# from_values, +# to_values, +# from_columns, +# to_columns, +# impute_when_missing_from = NULL) { +# # ARGUMENT CHECKING ---- +# # Object to store check-results +# checks <- checkmate::makeAssertCollection() +# # Perform checks +# checkmate::assert_data_frame(data, add = checks) +# checkmate::assert_list(from_values, min.len = 1, add = checks) +# checkmate::assert_list(to_values, min.len = 1, add = checks) +# checkmate::assert_character(from_columns, min.len = 1, min.chars = 1, add = checks) +# checkmate::assert_character(to_columns, min.len = 1, min.chars = 1, add = checks) +# checkmate::assert_character(impute_when_missing_from, max.len = length(to_columns), null.ok = TRUE, add = checks) +# checkmate::assert_subset(impute_when_missing_from, choices = from_columns, add = checks) +# # Report check-results +# checkmate::reportAssertions(checks) +# +# # CREATE TRANSLATION TABLE WITH FROM AND TO VALUES ---- +# to_columns_temp <- paste0(rep("tcc_V", length(to_columns)), as.character(1:length(to_columns))) +# translation_table <- data.frame(unlist(from_values[1])) +# colnames(translation_table) <- from_columns[1] +# if (length(from_columns) > 1) { +# for (i in 2:length(from_values)) { +# translation_table[, from_columns[i]] <- as.data.frame(unlist(from_values[i])) +# } +# } +# for (i in 1:length(to_values)) { +# translation_table[, to_columns_temp[i]] <- as.data.frame(unlist(to_values[i])) +# } +# # translation_table[is.na(translation_table)] <- "_NA_" +# +# # CREATE SUBSET TO TRANSLATE ---- +# subdata <- as.data.frame(data[, from_columns]) +# colnames(subdata) <- from_columns +# # subdata[is.na(subdata)] <- "_NA_" +# subdata$sort_order <- 1:nrow(subdata) +# +# # PERFORM TRANSLATION ---- +# subdata <- merge(subdata, translation_table, by = c(from_columns), all.x = TRUE) +# +# if (!is.null(impute_when_missing_from)) { +# if (length(to_columns_temp) == 1) { +# subdata[is.na(subdata[, to_columns_temp]), to_columns_temp] <- +# subdata[is.na(subdata[, to_columns_temp]), impute_when_missing_from] +# } else { +# subdata[rowSums(is.na(subdata[, to_columns_temp])) == length(to_columns_temp), to_columns_temp[1:length(impute_when_missing_from)]] <- +# subdata[rowSums(is.na(subdata[, to_columns_temp])) == length(to_columns_temp), impute_when_missing_from] +# } +# } +# subdata <- subdata[order(subdata$sort_order), ] +# +# # RETURN DATA WITH TRANSLATED COLUMNS +# data[, to_columns] <- subdata[, to_columns_temp] +# return(data) +# } +# diff --git a/R/utils.R b/R/utils.R index 78460a0..755cb76 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) - + } } @@ -94,7 +94,7 @@ copy_file_if_updated <- function(filename, from_path, to_path) { #' Should existing value be transferred if no value for the code is found? #' Defaults to \code{FALSE}. #' -#' @return A data.frame with a new column with the translated value. The new +#' @return A data.frame with a new column with the translated value. The new #' column is placed in the position given in position. #' @author Petter Hopp Petter.Hopp@@vetinst.no #' @@ -110,38 +110,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) { @@ -155,11 +155,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, @@ -167,13 +167,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 (isTRUE(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 @@ -184,10 +184,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 @@ -232,14 +232,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) } @@ -267,15 +267,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 { @@ -337,20 +337,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)) } diff --git a/R/zzz.R b/R/zzz.R index fd78761..570d5de 100644 --- a/R/zzz.R +++ b/R/zzz.R @@ -16,7 +16,7 @@ .onAttach <- function(libname, pkgname) { # check if "NVIconfig" is installed - msg <- NVIcheckmate::check_package(x = "NVIconfig", version = "0.5.0") + msg <- NVIcheckmate::check_package(x = "NVIconfig", version = "0.8.0") # Print a startup message if not required version is installed if (!isTRUE(msg)) { diff --git a/README.Rmd b/README.Rmd index f0582fb..9237481 100644 --- a/README.Rmd +++ b/README.Rmd @@ -6,12 +6,13 @@ output: params: NVIpkg: "NVIdb" + pkg_path: !r usethis::proj_path() first_copyright_year: "2019" --- ```{r, include = FALSE} NVIpkg <- params$NVIpkg -# NVIpkg <- stringi::stri_extract_last_words(usethis::proj_path()) +pkg_path <- params$pkg_path NVIpkg_inline <- paste0("`", NVIpkg, "`") logo_path <- "" if (file.exists(paste0("./man/figures/", NVIpkg, "_logo.png"))) { @@ -56,12 +57,12 @@ stable and you will not need to update `NVIconfig` every time `NVIdb` is updated To install (or update) the `NVIconfig` package, run the following code: ``` {r text2, message=FALSE, warnings=FALSE, echo=FALSE, prompt = FALSE, comment = ""} -text2 <- paste(paste0('remotes::install_github("NorwegianVeterinaryInstitute/NVIconfig",'), - ' auth_token = "PAT",', - ' upgrade = FALSE,', - ' build = TRUE,', - ' build_vignettes = TRUE)', sep = '\n') -cat(text2, sep="", fill = TRUE) +text2 <- paste(paste0('remotes::install_github("NorwegianVeterinaryInstitute/NVIconfig",'), + ' auth_token = "PAT",', + ' upgrade = FALSE,', + ' build = TRUE,', + ' build_vignettes = TRUE)', sep = '\n') +cat(text2, sep = "", fill = TRUE) ``` where PAT is your personal access token. diff --git a/README.md b/README.md index 413b693..046eeaa 100644 --- a/README.md +++ b/README.md @@ -36,14 +36,28 @@ for more information. - R version > 4.0.0 - R package `remotes` -- Rtools 4.0 or Rtools 4.2 depending on R version +- Rtools version 4.0, 4.2 or 4.3 depending on R version First install and attach the `remotes` package. install.packages("remotes") library(remotes) -To install (or update) the `NVIdb` package, run the following code: +To install (or update) the `NVIdb` package without vignettes, run the +following code: + + remotes::install_github("NorwegianVeterinaryInstitute/NVIdb", + upgrade = FALSE, + build = TRUE, + build_vignettes = FALSE) + +To install (or update) the `NVIdb` package with vignettes, you will need +to first install some additional R-packages needed for creating the +vignettes. Check README below in the section [Vignettes](#vignettes) to +see which vignettes are available. To install the package with the +vignettes, first install the packages: `knitr`, `rmarkdown`, `R.rsp`, +and `NVIrpackages` (from GitHub) if they are missing. Then run the +following code: remotes::install_github("NorwegianVeterinaryInstitute/NVIdb", upgrade = FALSE, @@ -106,19 +120,36 @@ with codes into names and others. You can translate - postnr into poststed and poststedets kommunenr - old produsentnr into current produsentnr -#### Help +#### Further documentation + +##### Help The full list of all available functions and datasets can be accessed by typing help(package = "NVIdb") -Please check the NEWS for information on new features, bug fixes and -other changes. +##### Vignettes + +Consult the vignettes for task-oriented help. + + vignette(package = "NVIdb") + +Vignettes in package `NVIdb`: + +- Contribute to NVIdb (html) +- NVIdb reference manual (pdf) +- Retrieve and standardise PJS-data (html) + +##### NEWS + +Please check the +[NEWS](https://github.com/NorwegianVeterinaryInstitute/NVIdb/blob/main/NEWS) +for information on new features, bug fixes and other changes. ## Copyright and license -Copyright (c) 2019 - 2023 Norwegian Veterinary Institute. +Copyright (c) 2019 - 2024 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/build_query_db.R b/man-roxygen/build_query_db.R new file mode 100644 index 0000000..b9bdc59 --- /dev/null +++ b/man-roxygen/build_query_db.R @@ -0,0 +1,5 @@ +# template used for db in build_query-functions. +#' +#' @param db [\code{character(1)}]\cr +#' The database for which the query is built. Defaults to "PJS" that currently +#' is the only valid value. diff --git a/man-roxygen/build_query_year.R b/man-roxygen/build_query_year.R new file mode 100644 index 0000000..d58cd6c --- /dev/null +++ b/man-roxygen/build_query_year.R @@ -0,0 +1,5 @@ +# template used for year in build_query-functions. +#' +#' @param year [\code{numeric}]\cr +#' One year or a vector giving the first and last years that should +#' be selected. diff --git a/man/NVIdb-deprecated.Rd b/man/NVIdb-deprecated.Rd index ee398db..6417971 100644 --- a/man/NVIdb-deprecated.Rd +++ b/man/NVIdb-deprecated.Rd @@ -16,17 +16,25 @@ These functions are provided for compatibility with older deprecated functions are available at \code{help("-deprecated")}. } \details{ -\code{add_produsent} was deprecated 2022-05-02 as other properties +\code{add_produsent} was deprecated from v0.8.0 released 2022-08-25 + as other properties than 'gjeldende_prodnr8' could not be included without breaking backward compatibility. Use \code{add_produsent_properties} instead and ensure to set the parameter \code{impute_old_when_missing = TRUE} when translating from "prodnr8" to "gjeldende_prodnr8" and set the parameter \code{impute_old_when_missing = FALSE} when translating from "prodnr8" to other properties. + +\code{set_PAT}, \code{get_PAT}, and \code{remove_PAT} was deprecated from + v0.11.0 released 2023-09-22. The functions were never taken into use. + Functions from the much better package \code{gitcreds} should be used instead. } \examples{ \dontrun{ -add_produsent(...) ### -- use \code{\link{add_produsent_properties}} instead +add_produsent(...) ### -- use \code{\link{add_produsent_properties}} instead. +set_PAT(...) ### -- use \code{\link{gitcreds::gitcreds_set}} instead. +get_PAT(...) ### -- use \code{\link{gitcreds::gitcreds_get}} instead. +remove_PAT(...) ### -- use \code{\link{gitcreds::gitcreds_delete}} instead. } } \author{ diff --git a/man/add_PJS_code_description.Rd b/man/add_PJS_code_description.Rd index e58765f..1983f1a 100644 --- a/man/add_PJS_code_description.Rd +++ b/man/add_PJS_code_description.Rd @@ -35,31 +35,31 @@ read_PJS_codes_2_text( PJS data with at least one column that have codes for a PJS variable.} \item{translation_table}{[\code{data.frame}] \cr -Table with the code and the description for PJS variables. Defaults to +Table with the code and the description for PJS variables. Defaults to "PJS_codes_2_text".} \item{PJS_variable_type}{[\code{character}] \cr -One or more PJS variables, for example "hensikt". See details for a list -of all PJS variables included in the pre made translation table -"pjscode_2_descriptions.csv". If more than one code type should be translated, -they can be given in the vector. You may also use argument -\code{PJS_variable_type = "auto"}, if \code{code_colname} have standardized +One or more PJS variables, for example "hensikt". See details for a list +of all PJS variables included in the pre made translation table +"pjscode_2_descriptions.csv". If more than one code type should be translated, +they can be given in the vector. You may also use argument +\code{PJS_variable_type = "auto"}, if \code{code_colname} have standardized PJS column names only, see details.} \item{code_colname}{[\code{character}] \cr -The name of the column with codes that should be translated. If several codes +The name of the column with codes that should be translated. If several codes should be translated, a vector with the names of the coded variables should be given.} \item{new_column}{[\code{character}] \cr -The name of the new column with the text describing the code. If several -codes should be translated, a vector with the new column names should be -given. You may also use argument \code{new_column = "auto"}, if \code{code_colname} +The name of the new column with the text describing the code. If several +codes should be translated, a vector with the new column names should be +given. You may also use argument \code{new_column = "auto"}, if \code{code_colname} have standardized PJS column names only, see details.} \item{position}{[\code{character}] \cr -Position for the new columns, can be one of c("first", "left", "right", -"last", "keep"). If several codes should be translated, either one value -to be applied for all may be given or a vector with specified position +Position for the new columns, can be one of c("first", "left", "right", +"last", "keep"). If several codes should be translated, either one value +to be applied for all may be given or a vector with specified position for each code to be translated should be given. Defaults to "right".} \item{overwrite}{[\code{logical(1)}]. When the new column(s) already exist, @@ -68,7 +68,7 @@ the content in the existing column(s) is replaced by new data if \code{overwrite = FALSE}, an error is issued. Defaults to \code{FALSE}.} \item{backward}{[\code{logical(1)}] \cr -If \code{TRUE}, it translates from descriptive text and back to PJS code, +If \code{TRUE}, it translates from descriptive text and back to PJS code, see details. Defaults to \code{FALSE}.} \item{impute_old_when_missing}{[\code{logical(1)}] \cr @@ -82,49 +82,49 @@ File name of the source file for the translation table for PJS codes.} Path for the source translation table for PJS codes.} \item{to_path}{[\code{character(1)}] \cr -Path for the target translation table for PJS codes when copying the +Path for the target translation table for PJS codes when copying the translation table.} } \value{ -\code{add_PJS_code_description} A data frame where the description text - for the PJS code has been added in the column to the right of the column +\code{add_PJS_code_description} A data frame where the description text + for the PJS code has been added in the column to the right of the column with the code. If the input is a tibble, it will be transformed to a data frame. - \code{read_PJS_codes_2_text} A data frame with the translation table for PJS - codes as read from the source csv-file. If not changing standard input, the + \code{read_PJS_codes_2_text} A data frame with the translation table for PJS + codes as read from the source csv-file. If not changing standard input, the standard file at NVI's internal network is read. - \code{copy_PJS_codes_2_text} Copies the source translation table for PJS codes - to another location. If the target file already exists the source file is only + \code{copy_PJS_codes_2_text} Copies the source translation table for PJS codes + to another location. If the target file already exists the source file is only copied if it is newer than the target file. } \description{ -Functions to adds a column with descriptive text for a column - with PJS codes in a data frame with PJS data. You may also use backwards - translation from descriptive text to PJS code. In addition there are +Functions to adds a column with descriptive text for a column + with PJS codes in a data frame with PJS data. You may also use backwards + translation from descriptive text to PJS code. In addition there are functions to read and copy an updated version of the PJS code registers. } \details{ Export of data from PJS will produce data frames in which many columns - have coded data. These need to be translated into descriptive text to + have coded data. These need to be translated into descriptive text to increase readability. - \code{add_PJS_code_description} can be used to translate the codes into - descriptive text. In a data frame with coded values, the function can - return a data frame with the descriptive text in a new column. As default, - the descriptive text is input in a new column to the right of the column + \code{add_PJS_code_description} can be used to translate the codes into + descriptive text. In a data frame with coded values, the function can + return a data frame with the descriptive text in a new column. As default, + the descriptive text is input in a new column to the right of the column with codes. - \code{add_PJS_code_description} uses the pre made translation table - "PJS_codes_2_text.csv". The data need to be loaded by + \code{add_PJS_code_description} uses the pre made translation table + "PJS_codes_2_text.csv". The data need to be loaded by \code{read_PJS_codes_2_text} before running \code{add_PJS_code_description}, - see example. The file "PJS_codes_2_text.csv" is normally updated every night + see example. The file "PJS_codes_2_text.csv" is normally updated every night from PJS. - Currently, the translation table has PJS codes and the corresponding - description for the PJS variable types given in the first column in the table + Currently, the translation table has PJS codes and the corresponding + description for the PJS variable types given in the first column in the table below. The standardized PJS column name is given in the column "code colname" for - which the "PJS variable type" will translate into descriptive text. The standard + which the "PJS variable type" will translate into descriptive text. The standard new column name is given in the column "new column". \tabular{llll}{ @@ -161,51 +161,51 @@ Export of data from PJS will produce data frames in which many columns } If \code{code_colname} is a vector of standardized PJS column names - and a subset of "code column" in the table above, you may facilitate - coding by setting \code{PJS_variable_type = "auto"} and/or - \code{new_colname = "auto"}. Then the \code{PJS_variable_type} will be - automatically set according to the table above (for "artkode" - \code{PJS_variable_type = "art"} will be chosen). Likewise, the + and a subset of "code column" in the table above, you may facilitate + coding by setting \code{PJS_variable_type = "auto"} and/or + \code{new_colname = "auto"}. Then the \code{PJS_variable_type} will be + automatically set according to the table above (for "artkode" + \code{PJS_variable_type = "art"} will be chosen). Likewise, the \code{new_column} will be automatically set according to the table above. \code{position} is used to give the position if the new columns in the - data frame. For \code{position = "right"} the new variables are placed - to the right of the code_variable. Likewise, for \code{position = "left"} - the new variables are placed to the left of the code_variable. If - \code{position = "first"} or \code{position = "last"} the new columns are - placed first or last, respectively, in the data frame. A special case - occurs for \code{position = "keep"} which only has meaning when the new - column has the same name as an existing column and overwrite = TRUE. In - these cases, the existing column will be overwritten with new data and + data frame. For \code{position = "right"} the new variables are placed + to the right of the code_variable. Likewise, for \code{position = "left"} + the new variables are placed to the left of the code_variable. If + \code{position = "first"} or \code{position = "last"} the new columns are + placed first or last, respectively, in the data frame. A special case + occurs for \code{position = "keep"} which only has meaning when the new + column has the same name as an existing column and overwrite = TRUE. In + these cases, the existing column will be overwritten with new data and have the same position. - \code{backward = TRUE} can be used to translate from descriptive text and - back to PJS codes. This intended for cases where the PJS code has been lost - (for example in EOS data) or when data from other sources should be translated - to codes to be able to use the code hierarchy for further processing of the - data. Back translation ignores case. Be aware that the back translation is + \code{backward = TRUE} can be used to translate from descriptive text and + back to PJS codes. This intended for cases where the PJS code has been lost + (for example in EOS data) or when data from other sources should be translated + to codes to be able to use the code hierarchy for further processing of the + data. Back translation ignores case. Be aware that the back translation is most useful for short descriptive text strings, as longer strings may have been - shortened and the risk of misspelling and encoding problems is larger. For some - descriptive text strings, there are no unique translation. In these cases, + shortened and the risk of misspelling and encoding problems is larger. For some + descriptive text strings, there are no unique translation. In these cases, the code value is left empty. - \code{read_PJS_codes_2_text} reads the file "PJS_codes_2_text.csv" into a - data frame that can be used by \code{add_PJS_code_description}. In standard - setting will the file read in the latest updated file from NVI's internal - network. If changing the \code{from_path}, the function can be used to read + \code{read_PJS_codes_2_text} reads the file "PJS_codes_2_text.csv" into a + data frame that can be used by \code{add_PJS_code_description}. In standard + setting will the file read in the latest updated file from NVI's internal + network. If changing the \code{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. - PJS_codes_2_text.csv has the following columns: c("type", "kode", "navn", - "utgatt_dato"), where "type" is the PJS variable type as listed above (for - example hensikt), "kode" is the variable with the PJS code, "navn" is the text - describing the code, and "utgatt_dato" is the date for last date that the + PJS_codes_2_text.csv has the following columns: c("type", "kode", "navn", + "utgatt_dato"), where "type" is the PJS variable type as listed above (for + example hensikt), "kode" is the variable with the PJS code, "navn" is the text + describing the code, and "utgatt_dato" is the date for last date that the code was valid (NA if still valid). If translation tables are needed for - other PJS variables, a data frame with the same column definition can be + other PJS variables, a data frame with the same column definition can be constructed to translate new variables. - \code{copy_PJS_codes_2_text} copies the file pjsCodeDescriptions.csv to + \code{copy_PJS_codes_2_text} copies the file pjsCodeDescriptions.csv to a given directory. } \examples{ @@ -235,20 +235,20 @@ newdata3 <- add_PJS_code_description(olddata, PJS_variable_type = c("auto"), code_colname = c("artkode", "hensiktkode", "konklusjonkode"), new_column = c("auto")) - + # Translating art with species and breed names to only species names -# First the text in art is back-translated to the artkode -newdata4 <- add_PJS_code_description(data = olddata, +# First the text in art is back-translated to the artkode +newdata4 <- add_PJS_code_description(data = olddata, PJS_variable_type = "artrase", code_colname = "art", new_column = "artkode", backward = TRUE, - impute_old_when_missing = TRUE) - + impute_old_when_missing = TRUE) + # Thereafter, the code is translated to art # By using `impute_old_when_missing = TRUE`, you ensure that text that cannot # be translated back to code, is reported as text in the end result. -newdata4 <- add_PJS_code_description(data = newdata4, +newdata4 <- add_PJS_code_description(data = newdata4, PJS_variable_type = "art", code_colname = "artkode", new_column = "art", diff --git a/man/add_lokalitet.Rd b/man/add_lokalitet.Rd index dd283a3..ad0ae4f 100644 --- a/man/add_lokalitet.Rd +++ b/man/add_lokalitet.Rd @@ -49,13 +49,13 @@ The filenames of the source files with the tables for generating the translation Path for the source files for the translation table.} } \value{ -\code{add_lokalitet}: \code{data.frame} where the aquaculture +\code{add_lokalitet}: \code{data.frame} where the aquaculture zone and / or geo-coordinates have been added in the column to the right of the column with the LokNr. -\code{read_sonetilhorighet}: \code{data.frame} with "LokNr", - aquaculture zone and geo-coordinates. If not changing standard - input to the function, the standard file at NVI's internal +\code{read_sonetilhorighet}: \code{data.frame} with "LokNr", + aquaculture zone and geo-coordinates. If not changing standard + input to the function, the standard file at NVI's internal network is read. } \description{ @@ -65,33 +65,33 @@ Function to add a column with current aquaculture } \details{ \code{add_lokalitet} can be used to add aquaculture - zone and/or geo-coordinates to aquaculture sites. The new + zone and/or geo-coordinates to aquaculture sites. The new columns can be one or more of c("sone", "EastUTM_33N_WGS84", "NorthUTM_33N_WGS84", "Longitude_WGS84", "Latitude_WGS84"). - If the new columns in the result data frame should have - other names, \code{new_column} can be input as a named + If the new columns in the result data frame should have + other names, \code{new_column} can be input as a named vector, see examples. -\code{position} is used to give the position if the new columns - in the data.frame. For \code{position = "right"} the new - variables are placed to the right of the code_variable. - Likewise, for \code{position = "left"} the new variables - are placed to the left of the code_variable. If - \code{position = "first"} or \code{position = "last"} the +\code{position} is used to give the position if the new columns + in the data.frame. For \code{position = "right"} the new + variables are placed to the right of the code_variable. + Likewise, for \code{position = "left"} the new variables + are placed to the left of the code_variable. If + \code{position = "first"} or \code{position = "last"} the new columns are placed first or last, respectively, in the - data frame. A special case occurs for \code{position = "keep"} - which only has meaning when the new column has the same name - as an existing column and \code{overwrite = TRUE}. In these - cases, the existing column will be overwritten with new data + data frame. A special case occurs for \code{position = "keep"} + which only has meaning when the new column has the same name + as an existing column and \code{overwrite = TRUE}. In these + cases, the existing column will be overwritten with new data and have the same position. -\code{read_sonetilhorighet} reads the file "sonetilhorighet.txt" - into a data frame that can be used by other routines. Standard - setting will the file read in the latest updated 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. +\code{read_sonetilhorighet} reads the file "sonetilhorighet.txt" + into a data frame that can be used by other routines. Standard + setting will the file read in the latest updated 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. } \examples{ diff --git a/man/add_new_column.Rd b/man/add_new_column.Rd index eb68bbf..34bc097 100644 --- a/man/add_new_column.Rd +++ b/man/add_new_column.Rd @@ -41,7 +41,7 @@ Should existing value be transferred if no value for the code is found? Defaults to \code{FALSE}.} } \value{ -A data.frame with a new column with the translated value. The new +A data.frame with a new column with the translated value. The new column is placed in the position given in position. } \description{ diff --git a/man/build_query_hensikt.Rd b/man/build_query_hensikt.Rd index 970e1b3..135b00c 100644 --- a/man/build_query_hensikt.Rd +++ b/man/build_query_hensikt.Rd @@ -7,30 +7,30 @@ build_query_hensikt(year, hensikt, db = "PJS") } \arguments{ -\item{year}{[\code{numeric}] \cr +\item{year}{[\code{numeric}]\cr One year or a vector giving the first and last years that should be selected.} -\item{hensikt}{[\code{character}] \cr -Vector with one or more specific hensiktkoder. If sub-hensikter +\item{hensikt}{[\code{character}]\cr +Vector with one or more specific hensiktkoder. If sub-hensikter should be included, end the code with \%.} -\item{db}{[\code{character(1)}] \cr -The database for which the query is built. Currently only -the value "PJS" is accepted.} +\item{db}{[\code{character(1)}]\cr +The database for which the query is built. Defaults to "PJS" that currently +is the only valid value.} } \value{ -A list with select-statements for "v2_sak_m_res" and +A list with select-statements for "v2_sak_m_res" and "v_sakskonklusjon", respectively. The statements should be included in a \code{RODBC::sqlQuery}. } \description{ -Builds the query for selecting all data for one or +Builds the query for selecting all data for one or more hensikt within one year from PJS. The query is written in T-SQL as used by MS-SQL. } \details{ -The function builds the SQL syntax to select all +The function builds the SQL syntax to select all PJS-journals concerning the hensiktkoder from PJS. } \examples{ diff --git a/man/build_query_one_disease.Rd b/man/build_query_one_disease.Rd index d8d7c79..3107ac0 100644 --- a/man/build_query_one_disease.Rd +++ b/man/build_query_one_disease.Rd @@ -13,15 +13,24 @@ build_query_one_disease( ) } \arguments{ -\item{year}{One year or a vector with years giving the first and last years that should be selected as integer.} +\item{year}{[\code{numeric}]\cr +One year or a vector giving the first and last years that should +be selected.} -\item{analytt}{One or more analyttkode given as a character. If sub-analytter should be included, end the code with \%.} +\item{analytt}{[\code{character}]\cr +Analyttkoder that should be selected. If sub-analytter should be included, +end the code with \%.} -\item{hensikt}{Vector with specific hensikter. If sub-hensikter should be included, end the code with \%. Can be \code{NULL}.} +\item{hensikt}{[\code{character}]\cr +Specific hensiktkoder. If sub-hensikter should be included, +end the code with \%. Defaults to \code{NULL}.} -\item{metode}{Vector with specific metoder. Can be \code{NULL}.} +\item{metode}{[\code{character}]\cr +Specific metodekoder. Defaults to \code{NULL}.} -\item{db}{The database for which the query is built. Currently only the value "PJS" is accepted.} +\item{db}{[\code{character(1)}]\cr +The database for which the query is built. Defaults to "PJS" that currently +is the only valid value.} } \value{ A list with select-statement fom v2_sak_m_res and v_sakskonklusjon to be included in a \code{RODBC::sqlQuery}. diff --git a/man/build_query_outbreak.Rd b/man/build_query_outbreak.Rd index d84cb64..9fefbbb 100644 --- a/man/build_query_outbreak.Rd +++ b/man/build_query_outbreak.Rd @@ -14,21 +14,27 @@ build_query_outbreak( ) } \arguments{ -\item{period}{Time period given as year. One year or a vector with years giving the first and last years -that should be selected as integer.} +\item{period}{[\code{numeric}]\cr +Time period given as year. One year or a vector giving the first +and last years that should be selected.} -\item{utbrudd}{One or more utbrudd id given as a character. Can be \code{NULL}.} +\item{utbrudd}{[\code{character}]\cr +Utbruddsid(er) that should be selected. Defaults to \code{NULL}.} -\item{hensikt}{Vector with specific hensikter. If sub-hensikter should be -included, end the code with \%. Can be \code{NULL}.} +\item{hensikt}{[\code{character}]\cr +Specific hensiktkoder. If sub-hensikter should be included, +end the code with \%. Defaults to \code{NULL}.} -\item{analytt}{One or more analyttkode given as a character. If sub-analytter -should be included, end the code with \%. Can be \code{NULL}.} +\item{analytt}{[\code{character}]\cr +Analyttkoder that should be selected. If sub-analytter should be included, +end the code with \%. Defaults to \code{NULL}.} -\item{metode}{Vector with specific metoder. Can be \code{NULL}.} +\item{metode}{[\code{character}]\cr +Specific metodekoder. Defaults to \code{NULL}.} -\item{db}{The database for which the query is built. Currently only the value -"PJS" is accepted.} +\item{db}{[\code{character(1)}]\cr +The database for which the query is built. Defaults to "PJS" that currently +is the only valid value.} } \value{ A list with select-statement for v2_sak_m_res and v_sakskonklusjon to diff --git a/man/build_sql_modules.Rd b/man/build_sql_modules.Rd index 5423e8a..3848945 100644 --- a/man/build_sql_modules.Rd +++ b/man/build_sql_modules.Rd @@ -11,19 +11,19 @@ build_sql_select_year(year, varname, db = "PJS") build_sql_select_code(values, varname, db = "PJS") } \arguments{ -\item{year}{[\code{numeric}] \\cr -One year or a vector giving the first and last years that should +\item{year}{[\code{numeric}]\cr +One year or a vector giving the first and last years that should be selected.} -\item{varname}{[\code{character(1)}] \\cr +\item{varname}{[\code{character(1)}]\cr The PJS variable name of the variable in PJS from which the coded values should be selected.} -\item{db}{[\code{character(1)}] \\cr -The database for which the query is built. Currently only -the value "PJS" is accepted.} +\item{db}{[\code{character(1)}]\cr +The database for which the query is built. Defaults to "PJS" that currently +is the only valid value.} -\item{values}{[\code{character}] \\cr +\item{values}{[\code{character}]\cr The value of the codes that should be selected. If sub-codes should be included, add "\%" after the code, see example.} } @@ -32,30 +32,33 @@ SQL-code to be included when building select-statements for PJS. } \description{ Builds sql modules to be included in select statements for PJS -when building queries for selecting data. The functions takes the values -for which observations should be selected as input and builds the -sql syntax. + when building queries for selecting data. The functions takes the values + for which observations should be selected as input and builds the + sql syntax. } \details{ \code{build_sql_select_year} builds the SQL syntax to select observations -from one or more consecutive years from PJS. The input can be given as -one year, the first and last year or a range of years. If a range is given, -this will be interpreted as first and last years and all years in between -will be included. + from one or more consecutive years from PJS. The input can be given as + one year, the first and last year or a range of years. If a range is given, + this will be interpreted as first and last years and all years in between + will be included. \code{build_sql_select_code} builds the SQL syntax to select observations -with the given code values from one variable in PJS with hierarchical codes. -When the code value including sub codes should be selected, add "\%" to the -code, see example. + with the given code values from one variable in PJS with hierarchical codes. + When the code value including sub codes should be selected, add "%" to the + code, see example. Be aware that these functions only builds an sql building block to be -included into a select statement. It will not build a complete select -statement. These functions are mainly intended for internal use and -are called from \code{\link{build_query_hensikt}}, \code{\link{build_query_one_disease}}, -and \code{\link{build_query_outbreak}}. If generating own select -statements, these can be used to facilitate the coding. The building -blocks can be combined with "AND" and "OR" and brackets to get the -intended select statement. + included into a select statement. It will not build a complete select + statement. These functions are mainly intended for internal use and + are called from + \ifelse{html}{\code{\link{build_query_hensikt}}}{\code{build_query_hensikt}}, + \ifelse{html}{\code{\link{build_query_one_disease}}}{\code{build_query_one_disease}} + and + \ifelse{html}{\code{\link{build_query_outbreak}}}{\code{build_query_outbreak}}. + If generating own select statements, these can be used to facilitate + the coding. The building blocks can be combined with "AND" and "OR" + and brackets to get the intended select statement. } \examples{ # SQL-select module for selecting year from PJS diff --git a/man/login.Rd b/man/login.Rd index dacad44..fa63dee 100644 --- a/man/login.Rd +++ b/man/login.Rd @@ -23,9 +23,9 @@ login( dbinterface = NULL ) -login_PJS(dbinterface = NULL) +login_PJS(dbinterface = NULL, ...) -login_EOS(dbinterface = NULL) +login_EOS(dbinterface = NULL, ...) login_by_credentials( dbservice, @@ -37,9 +37,9 @@ login_by_credentials( dbinterface = NULL ) -login_by_credentials_PJS(dbinterface = NULL) +login_by_credentials_PJS(dbinterface = NULL, ...) -login_by_credentials_EOS(dbinterface = NULL) +login_by_credentials_EOS(dbinterface = NULL, ...) login_by_input( dbservice, @@ -52,9 +52,9 @@ login_by_input( dbtext = NULL ) -login_by_input_PJS(dbinterface = NULL) +login_by_input_PJS(dbinterface = NULL, ...) -login_by_input_EOS(dbinterface = NULL) +login_by_input_EOS(dbinterface = NULL, ...) } \arguments{ \item{dbservice}{Name of the database service, for example "PJS" or "EOS". @@ -71,9 +71,12 @@ 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 +\item{dbinterface}{The R-package that is used for interface towards the data base.} +\item{\dots}{Other arguments to be passed from the wrappers to +login_by_credentials or login_by_input} + \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.} @@ -134,9 +137,9 @@ 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 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 + 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 diff --git a/man/read_Prodtilskudd.Rd b/man/read_Prodtilskudd.Rd index ad93b84..4a0bf54 100644 --- a/man/read_Prodtilskudd.Rd +++ b/man/read_Prodtilskudd.Rd @@ -9,46 +9,82 @@ copy_Prodtilskudd( from_path = paste0(set_dir_NVI("Prodtilskudd"), "FormaterteData/"), to_path = NULL, Pkode_year = "last", - Pkode_month = "both" + Pkode_month = "both", + extracted_date = NULL ) read_Prodtilskudd( from_path = paste0(set_dir_NVI("Prodtilskudd"), "FormaterteData/"), Pkode_year = "last", - Pkode_month = "both" + Pkode_month = "both", + extracted_date = NULL ) } \arguments{ -\item{from_path}{Path for the produksjonstilskuddsregister.} +\item{from_path}{[\code{character(1)}]\cr +Path for the produksjonstilskuddsregister. Defaults to the standard +directory at the NVI network.} -\item{to_path}{Target path for the files with the produksjonstilskuddsregister.} +\item{to_path}{[\code{character(1)}]\cr +Target path for the files with the produksjonstilskuddsregister.} -\item{Pkode_year}{The year(s) from which the register should be read. Options is "last", or a vector with one or more years.} +\item{Pkode_year}{[\code{character}] | [\code{numeric}]\cr +The year(s) from which the register should be read. Options is "last", or +a vector with one or more years. Defaults to "last".} -\item{Pkode_month}{The month for which the register should be read. The options are c("05", "10", "both", "last") for Pkode_year = 2017 -and c("03", "10", "both", "last") for Pkode_year >= 2018.} +\item{Pkode_month}{[\code{character}]\cr +The month for which the register should be read. The options are +c("05", "10", "both", "last") for Pkode_year = 2017 and +c("03", "10", "both", "last") for Pkode_year >= 2018. Defaults to "both".} + +\item{extracted_date}{[\code{character}]\cr +The date the data was extracted from the database of the Norwegian +Agricultural Agency. The format should be "yyyy-mm-dd". Defaults to +\code{NULL}.} } \value{ -\code{read_Prodtilskudd} reads one or more data frame(s) with the produksjonstilskuddsregister for each of the year and seasons selected. - If the options Pkode_year = "last" and Pkode_month = "last" is given, one file with the last produksjonstilskuddsregister is given. +\code{read_Prodtilskudd} reads one or more data frame(s) with the + produksjonstilskuddsregister for each of the year and seasons selected. + If the options Pkode_year = "last" and Pkode_month = "last" is given, + one file with the last produksjonstilskuddsregister is given. - \code{copy_Prodtilskudd} copies the source produksjonstilskuddsregister for each of the year and seasons selected. If the target file + \code{copy_Prodtilskudd} copies the source produksjonstilskuddsregister + for each of the year and seasons selected. If the target file already exists, the source files are copied only when newer than the target file. } \description{ -Functions to to read and copy versions of the produksjonstilskuddsregister. +Functions to to read and copy versions of the + produksjonstilskuddsregister. } \details{ -The produksjonstilskuddsregister includes information on number of animals that the produsent has applied subsidies for at the - counting dates. Since 2017, the counting dates are in March and October. Landbruksdirektoratet provides three to four versions of the - register for each counting date. The functions automatically selects the last updated version of the register. +The produksjonstilskuddsregister includes information on number of + animals that the produsent has applied subsidies for at the counting + dates. Since 2017, the counting dates are in March and October. + Landbruksdirektoratet provides three to four versions of the register for + each counting date. The functions automatically selects the last updated + version of the register. + + \code{read_Prodtilskudd} reads the produksjonstilskuddsregister into a + data frame. The function gives options to select year and season The + standard settings will read in the files from NVI's internal network and + select the latest updated file for both spring and autumn and combine + them into one file. 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_Prodtilskudd} reads the produksjonstilskuddsregister into a data frame. The function gives options to select year and season The standard - settings will read in the files from NVI's internal network and select the latest updated file for both spring and autumn and combine them - into one file. 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{extracted_date} is used if specific versions of the register is required, + for example to reproduce the generation of data previously performed + using an older version of the register.You should also write in the + \code{extracted_date} in the script to document which version of the + register that was used. If so, first extract the last available version + of the register. Find the uttrekkdato in the data, and write in the + uttrekkdato in \code{extracted_date}. \code{extracted_date} cannot be used + in combination with \code{pkode_year} = "last" or \code{pkode_month} = + c("last", "both"). - \code{copy_Prodtilskudd} copies the source produksjonstilskuddsregister for each of the year and seasons selected to a given directory. + \code{copy_Prodtilskudd} copies the source produksjonstilskuddsregister + for each of the year and seasons selected to a given directory. } \examples{ \dontrun{ diff --git a/man/read_eos_data.Rd b/man/read_eos_data.Rd index 9f08f6c..edcaa43 100644 --- a/man/read_eos_data.Rd +++ b/man/read_eos_data.Rd @@ -25,7 +25,7 @@ The years to be included in the result. Can be both numeric or character. Defaults to \code{NULL}, i.e. no selection.} \item{colClasses}{[\code{character}]\cr -The class of the columns, as in +The class of the columns, as in \ifelse{html}{\code{\link[utils:read.table]{utils::read.table}}}{\code{utils::read.table}}. Defaults to \code{"character"}.} @@ -43,13 +43,13 @@ 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 +read_eos_data uses \ifelse{html}{\code{\link[data.table:fread]{data.table::fread}}}{\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 + to read the data with the settings \code{showProgress = FALSE} and + \code{data.table = FALSE}. Other arguments can be passed to \ifelse{html}{\code{\link[data.table:fread]{data.table::fread}}}{\code{data.table::fread}} if necessary. - + The eos_table name is the same name as the name as in the EOS data base. } \author{ diff --git a/man/retrieve_PJSdata.Rd b/man/retrieve_PJSdata.Rd new file mode 100644 index 0000000..931c4ef --- /dev/null +++ b/man/retrieve_PJSdata.Rd @@ -0,0 +1,102 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/retrieve_PJSdata.R +\name{retrieve_PJSdata} +\alias{retrieve_PJSdata} +\title{Retrieves data from PJS} +\usage{ +retrieve_PJSdata( + year = NULL, + selection_parameters = NULL, + FUN = NULL, + select_statement = NULL, + ... +) +} +\arguments{ +\item{year}{[\code{numeric}]\cr +One year or a vector giving the first and last years that should be selected. +Defaults to \code{NULL}.} + +\item{selection_parameters}{[\code{character(1)}]\cr +Either the path and file name for an R script that can be sourced and that + sets the selection parameters or a named list with the selection parameters + (i.e. of the same format as the output of + \ifelse{html}{\code{\link{set_disease_parameters}}}{\code{set_disease_parameters}}). + Defaults to \code{NULL}.} + +\item{FUN}{[\code{function}]\cr +Function to build the selection statement, see details. Defaults to \code{NULL}.} + +\item{select_statement}{[\code{character(1)}]\cr +A written select statement, see details. Defaults to \code{NULL}.} + +\item{\dots}{Other arguments to be passed to underlying functions: +\ifelse{html}{\code{\link{login_PJS}}}{\code{login_PJS}} +and +\ifelse{html}{\code{\link{exclude_from_PJSdata}}}{\code{exclude_from_PJSdata}}.} +} +\value{ +A named list with PJS data. +} +\description{ +Retrieves and standardises PJS data. \code{retrieve_PJSdata} is + a wrapper for several \code{NVIdb}-functions and the intention of + \code{retrieve_PJSdata} is to shorten code and to ensure that a standard + procedure is followed when retrieving PJS-data, see details. It can only + be used for retrieving case data from PJS and not for retrieving code registers + and similar. +} +\details{ +\code{retrieve_PJSdata} is a wrapper for the following \code{NVIdb}-functions: +\itemize{ + \item Constructs the select statement by a build_query-function (see details) + and selection parameters. + \item Creates an open ODBC-channel using + \ifelse{html}{\code{\link{login_PJS}}}{\code{login_PJS}}. + \item Retrieves the data using the select statement constructed above. + \item Standardises the data using + \ifelse{html}{\code{\link{standardize_PJSdata}}}{\code{standardize_PJSdata}}. + \item Excludes unwanted cases using + \ifelse{html}{\code{\link{exclude_from_PJSdata}}}{\code{exclude_from_PJSdata}}. + } + +For the function to run automatically without having to enter PJS user + credentials, it is dependent that PJS user credentials have been saved using + \ifelse{html}{\code{\link{set_credentials_PJS}}}{\code{set_credentials_PJS}}. + Otherwise, the credentials must be input manually to establish an open + ODBC channel. + +The select statement for PJS can be built giving the selection parameters and + input to one of the build_query-functions, i.e. + \ifelse{html}{\code{\link{build_query_hensikt}}}{\code{build_query_hensikt}}, + \ifelse{html}{\code{\link{build_query_one_disease}}}{\code{build_query_one_disease}} + and + \ifelse{html}{\code{\link{build_query_outbreak}}}{\code{build_query_outbreak}}. + The selection parameters can be set by using + \ifelse{html}{\code{\link{set_disease_parameters}}}{\code{set_disease_parameters}}. + or by giving a list of similar format for input to + \code{selection_parameters}, see the build_query-functions for necessary + input. + +\code{retrieve_PJSdata} gives the possibility of giving the select_statement + as a string instead of using the build_query-functions. This should only + by done for select statements that previously have been tested and are + known to have correct syntax. \code{retrieve_PJSdata} has no possibility + of checking the syntax before it is submitted to PJS and untested select + statements can take a lot of time or stop the function without proper + error messages. + +The output is a named list where each entry is a data frame with PJS-data. If + the select statement is named, the returned data frame will have that name. + If the select statement is unnamed, it will try to identify the first + table in the select statement and use this as name. If not possible, the + name will be of the format "PJSdata#" where # is the number of the select + statement. +} +\examples{ + +# +} +\author{ +Petter Hopp Petter.Hopp@vetinst.no +} diff --git a/man/select_PJSdata_for_value.Rd b/man/select_PJSdata_for_value.Rd new file mode 100644 index 0000000..1e22e15 --- /dev/null +++ b/man/select_PJSdata_for_value.Rd @@ -0,0 +1,48 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/select_PJSdata_for_value.R +\name{select_PJSdata_for_value} +\alias{select_PJSdata_for_value} +\title{Selects a subset of PJSdata based on code values} +\usage{ +select_PJSdata_for_value( + data, + code_column, + value_2_check, + keep_selected = TRUE +) +} +\arguments{ +\item{data}{[\code{data.frame}]\cr +PJS data from which a subset should be selected.} + +\item{code_column}{[\code{character}]\cr +Vector with the column names for the variables that is used in the selection.} + +\item{value_2_check}{[\code{character}]\cr +Vector with the values that should be selected, see details and examples.} + +\item{keep_selected}{[\code{logical(1)}]\cr +If \code{TRUE}, the selected rows are included, if \code{FALSE}, the selected columns +are excluded. Defaults to \code{TRUE}.} +} +\value{ +A \code{data.frame}. +} +\description{ +Selects a subset of PJSdata based on code values. +The function accepts code values ending with "\%" to indicate +that sub levels should be included. +} +\details{ +The function is intended for cases where the select +query sent to PJS will be very complicated if the selection +is included and it can be easier to read the script if the +subset is selected in a second step. + +The function selects according to different values. The default +action is to include the selected rows. But when \code{keep_selected} += \code{FALSE}, the selected rows are excluded from the data. +} +\author{ +Petter Hopp Petter.Hopp@vetinst.no +} diff --git a/man/select_prodtilskudd_files.Rd b/man/select_prodtilskudd_files.Rd index 0f59a13..bce397f 100644 --- a/man/select_prodtilskudd_files.Rd +++ b/man/select_prodtilskudd_files.Rd @@ -4,7 +4,7 @@ \alias{select_prodtilskudd_files} \title{List selected files from Søknad om register for produksjonstilskudd} \usage{ -select_prodtilskudd_files(from_path, Pkode_year, Pkode_month) +select_prodtilskudd_files(from_path, Pkode_year, Pkode_month, extracted_date) } \arguments{ \item{from_path}{Path for the source translation table for PJS-codes} @@ -18,12 +18,14 @@ and c("03", "10", "both", "last") for Pkode_year >= 2018.} A data frame with filenames of the files with the selected extracts of Prodtilskudd. } \description{ -List selected files with extracts from Søknad om register for produksjonstilskudd. +List selected files with extracts from Søknad om register + for produksjonstilskudd. } \details{ -Reads the filenames of files with extracts from Søknad om register for produksjonstilskudd into a data frame. - The function gives options to select year and month and path for the files. The function is called from read_Prodtilskudd - and copy_Prodtilskudd. +Reads the filenames of files with extracts from Søknad om register + for produksjonstilskudd into a data frame. The function gives options to + select year and month and path for the files. The function is called from + \code{read_Prodtilskudd} and \code{copy_Prodtilskudd}. } \examples{ \dontrun{ diff --git a/man/set_PAT-deprecated.Rd b/man/set_PAT-deprecated.Rd new file mode 100644 index 0000000..63c6c0a --- /dev/null +++ b/man/set_PAT-deprecated.Rd @@ -0,0 +1,71 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/set_PAT-deprecated.R +\name{set_PAT-deprecated} +\alias{set_PAT-deprecated} +\alias{get_PAT-deprecated} +\alias{remove_PAT-deprecated} +\title{Manage personal access token (PAT) for internet services} +\usage{ +set_PAT(service) + +get_PAT(service) + +remove_PAT(service) +} +\arguments{ +\item{service}{Name of the internet service, for example "GitHub". For +internet services where one don't use the premade wrappers, the name +can be chosen freely, but must be the same as used in \code{get_PAT}} +} +\value{ +\code{set_PAT} The PAT for a internet service are saved in the + user profile at the current computer. + + \code{get_PAT} The PAT for a internet service are fetched from the + user profile at the current computer to be used in R-scripts. + + \code{remove_PAT} The PAT for a internet service are deleted from + the user profile at the current computer. +} +\description{ +Save or remove the current user's PAT for internet services + in the the user profile. +} +\details{ +For internet services like GitHub, personal access tokens can + replace username and password when accessing the service. To simplify + the access to the internet services when using R, the function + \code{set_PAT} makes it possible to save the personal access token + (PAT) in the user profile at the current machine. When the PAT has + been saved in the user profile, the functions \code{get_PAT} will + automatically get the PAT for use in code accessing the internet service. + + The user profile is not copied between computers. Consequently, if a user + runs scripts with \code{get_PAT} on different computers, + the PAT has to be saved at each computer separately. + + \code{set_PAT(service)} is used to set the PAT for a internet service. + The PAT are input using windows and saved in the users profile at + the current computer. When the PAT for the service has been changed, + \code{set_PAT(service)} can be used to update the PAT. + + \code{get_PAT(service)} is used to get the PAT for a internet service + that previously has been saved in the users profile at the current + computer. + + \code{remove_PAT(service)} is used to delete the PAT for a internet + service from the user's profile. +} +\examples{ +\dontrun{ +set_PAT("GitHub") + +get_PAT("GitHub") + +remove_PAT("GitHub") +} +} +\author{ +Petter Hopp Petter.Hopp@vetinst.no +} +\keyword{internal} diff --git a/man/set_PAT.Rd b/man/set_PAT.Rd index 3999e82..4111697 100644 --- a/man/set_PAT.Rd +++ b/man/set_PAT.Rd @@ -1,58 +1,30 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/get_PAT.R, R/remove_PAT.R, R/set_PAT.R -\name{get_PAT} +% Please edit documentation in R/set_PAT-deprecated.R +\name{set_PAT} +\alias{set_PAT} \alias{get_PAT} \alias{remove_PAT} -\alias{set_PAT} -\title{Manage personal access token (PAT) for internet services} +\title{\code{set_PAT}, \code{get_PAT}, and \code{remove_PAT} is deprecated} \usage{ +set_PAT(service) + get_PAT(service) remove_PAT(service) - -set_PAT(service) } \arguments{ -\item{service}{Name of the internet service, for example "GitHub". For internet services where one don't use the premade wrappers, the name can -be chosen freely, but must be the same as used in \code{get_PAT}} -} -\value{ -\code{set_PAT} The PAT for a internet service are saved in the user profile at the current computer. - - \code{get_PAT} The PAT for a internet service are fetched from the user profile at the current computer to be used in R-scripts. - - \code{remove_PAT} The PAT for a internet service are deleted from the user profile at the current computer. +\item{service}{Name of the internet service, for example "GitHub". For +internet services where one don't use the premade wrappers, the name +can be chosen freely, but must be the same as used in \code{get_PAT}} } \description{ -Save or remove the current user's PAT for internet services in the the user profile. +\code{set_PAT}, \code{get_PAT}, and \code{remove_PAT} was + deprecated from NVIdb v0.11.0 released 2023-09-22. These functions + should be replaced by corresponding functions in package 'gitcreds' + that are better, more flexible and maintained at cran. } \details{ -For internet services like GitHub, personal access tokens can replace username and password when accessing the service. To simplify - the access to the internet services when using R, the function \code{set_PAT} makes it possible to save the personal access token (PAT) in - the user profile at the current machine. When the PAT has been saved in the user profile, the functions \code{get_PAT} will automatically - get the PAT for use in code accessing the internet service. - - The user profile is not copied between computers. Consequently, if a user runs scripts with \code{get_PAT} on different computers, - the PAT has to be saved at each computer separately. - - \code{set_PAT(service)} is used to set the PAT for a internet service. The PAT are input using windows and saved in the users profile at - the current computer. When the PAT for the service has been changed, \code{set_PAT(service)} can be used to update the PAT. - - \code{get_PAT(service)} is used to get the PAT for a internet service that previously has been saved in the users profile at the current - computer. - - \code{remove_PAT(service)} is used to delete the PAT for a internet service from the user's profile. -} -\examples{ -\dontrun{ -set_PAT("GitHub") - -get_PAT("GitHub") - -remove_PAT("GitHub") -} - -} -\author{ -Petter Hopp Petter.Hopp@vetinst.no +The old help pages can be found at \code{help("set_PAT-deprecated")}. + Information on deprecated functions can be found at \code{help("NVIdb-deprecated")}. } +\keyword{internal} diff --git a/man/set_dir_NVI.Rd b/man/set_dir_NVI.Rd index b7eb9f0..de0834e 100644 --- a/man/set_dir_NVI.Rd +++ b/man/set_dir_NVI.Rd @@ -27,9 +27,9 @@ The Norwegian Veterinary Institute has standard data sources at fixed directories. The function returns the standard directory for the given data source. Thereby hard coding of the paths may be avoided. -The path ends with a slash as default. To facilitate the use of - \code{\link[base:file.path]{file.path}} you can use the argument - \code{slash = FALSE} to avoid ending slash. +The path ends with a slash as default. To facilitate the use of + \ifelse{html}{\code{\link[base:file.path]{file.path}}}{\code{file.path}} + you can use the argument \code{slash = FALSE} to avoid ending slash. } \examples{ \dontrun{ @@ -37,8 +37,8 @@ The path ends with a slash as default. To facilitate the use of prodtilskudd_path <- set_dir_NVI(datasource = "ProdTilskudd") # Set pathname to a file using 'file.path' -pathname <- file.path(set_dir_NVI(datasource = "ProdTilskudd", slash = FALSE), - "subdir", +pathname <- file.path(set_dir_NVI(datasource = "ProdTilskudd", slash = FALSE), + "subdir", "filename") } diff --git a/man/set_disease_parameters.Rd b/man/set_disease_parameters.Rd index c3f77e1..30b2f49 100644 --- a/man/set_disease_parameters.Rd +++ b/man/set_disease_parameters.Rd @@ -10,35 +10,51 @@ set_disease_parameters( utbrudd2select = NULL, metode2select = NULL, analytt2select = NULL, + analytt2delete = NULL, art2select = NULL, - missing_art = NULL, - file = NULL + include_missing_art = NULL, + selection_parameters = NULL, + ... ) } \arguments{ -\item{hensikt2select}{Vector with specific "hensikter". If sub-codes should -be included, end the code with \%. Can be \code{NULL}.} +\item{hensikt2select}{[\code{character}]\cr +Specific "hensiktkoder" for the "analytt" in question. If sub-codes should + be included, end the code with \%.Defaults to \code{NULL}.} -\item{hensikt2delete}{Vector with "hensikter" for which saker should be excluded -If sub-codes should be included, end the code with \%. Can be \code{NULL}.} +\item{hensikt2delete}{[\code{character}]\cr +"hensiktkoder" for which saker should be excluded. + If sub-codes should be included, end the code with \%. Defaults to \code{NULL}.} -\item{utbrudd2select}{String with an "utbruddsID". Can be \code{NULL}.} +\item{utbrudd2select}{[\code{character(1)}]\cr +"utbruddsID". Defaults to \code{NULL}.} -\item{metode2select}{Vector with specific "metoder." Can be \code{NULL}.} +\item{metode2select}{[\code{character}]\cr +Specific "metodekoder for the "analytt" in question." Defaults to \code{NULL}.} -\item{analytt2select}{Vector with one or more "analyttkode" given as a character. -If sub-codes should be included, end the code with \%. Can be \code{NULL}.} +\item{analytt2select}{[\code{character}]\cr +"analyttkoder" for the agent and/or disease. If sub-codes should be included, + end the code with \%. Defaults to \code{NULL}.} -\item{art2select}{Vector with one or more "artkode" given as a character. -If sub-codes should be included, end the code with \%. \code{NA} can be -combined with another "artkode". Can be \code{NULL}.} +\item{analytt2delete}{[\code{character}]\cr +Specific "analyttkoder" that should be deleted, see details. If sub-codes should + be included, end the code with \%. Defaults to \code{NULL}.} -\item{missing_art}{Should missing art be included if one or more arter should -be selected. Character one of c("never", "always", "non_selected_hensikt").} +\item{art2select}{[\code{character}]\cr +"artkoder". If sub-codes should be included, end the code with \%. \code{NA} can be + combined with another "artkode". Defaults to \code{NULL}.} -\item{file}{path and file name for an R script that can be sourced and that -sets the parameters \code{hensikt2select}, \code{utbrudd2select}, \code{metode2select}, and -\code{analytt2select}. Can be \code{NULL}.} +\item{include_missing_art}{[\code{character(1)}]\cr +Should missing art be included. Must be one of c("never", "always", "for_selected_hensikt"). + If NULL, it is set to "always" when \code{art2select} includes NA, else it is set to "never". + Defaults to \code{NULL}.} + +\item{selection_parameters}{[\code{character(1)}]\cr +Either the path and file name for an R script that can be sourced and that + sets the selection parameters or a named list with the selection parameters + (i.e. equal to the output of this function). Defaults to \code{NULL}.} + +\item{\dots}{Other arguments to be passed to `set_disease_parameters`.} } \value{ A named list with selection parameters that can be used to generate @@ -47,8 +63,11 @@ A named list with selection parameters that can be used to generate \description{ Sets the disease selection parameters and store them in a list object. The list follows a standardised named format and the elements can - be used as input to \code{\link{build_query_one_disease}}, - \code{\link{build_query_hensikt}} or \code{\link{build_query_outbreak}}. + be used as input to + \ifelse{html}{\code{\link{build_query_hensikt}}}{\code{build_query_hensikt}}, + \ifelse{html}{\code{\link{build_query_one_disease}}}{\code{build_query_one_disease}} + or + \ifelse{html}{\code{\link{build_query_outbreak}}}{\code{build_query_outbreak}}. } \details{ Saker in PJS that concern one infection / disease can be characterised @@ -56,20 +75,32 @@ Saker in PJS that concern one infection / disease can be characterised a relevant "utbrudds_ID" and/or specific "metoder." These can be used to select saker in PJS and/or to structure and simplify the output from PJS. - One or more specific "hensikter" may be input to the selection statement. - With specific "hensikt" is meant a "hensikt" that will imply that the sample + One or more specific "hensiktkoder" may be input to the selection statement. + With specific "hensiktkode" is meant a "hensiktkode" that will imply that the sample will be examined for specific infectious agent(s) or disease. One or more - specific "metoder" may be input to the selection statement. With specific - "metode" is meant a "metode" that implies an examination that will give one - of the input 2 as a result. If sub-codes of "analytt" or "hensikt" + specific "metodekoder" may be input to the selection statement. With specific + "metodekode" is meant a "metodekode" that implies an examination that will give one + of the input 2 as a result. If sub-codes of "analyttkode" or "hensiktkode" should be included, end the code with \%. The selection parameters can be input values for dedicated arguments. For input parameters - \code{hensikt2select}, \code{utbrudd2select}, \code{metode2select}, and - \code{analytt2select}, the input may be given in a source file. This may be handy if the + \code{hensikt2select}, \code{hensikt2delete}, \code{utbrudd2select}, \code{metode2select}, + \code{analytt2select}, \code{analytt2delete}, \code{art2select}, and \code{include_missing_art}, + the input may be given in a source file. This may be handy if the selection will be performed many times. It also gives the possibility of - using a for loop that selects PJS-data and performs similar analyses at one + using a for loop that selects PJS-data and performs similar analyses for one disease at a time. + + The selection parameter \code{analytt2delete} is intended for the situation where + \code{analytt2select} includes analytter higher in the hierarchy and there are + specific analytter lower in the hierarchy that should not be included. A typical + example is the selection of all samples with the analytt Mycobacterium spp and + below, but one is only interested in M. tuberculosis complex but not in M. avium. + + The possibility of input other arguments are kept to make it possible to use the + deprecated arguments \code{missing_art} and \code{file}. If these are used, a + warning is issued and the input is transferred to \code{include_missing_art} and + \code{selection_parameters}, respectively. } \examples{ # Selection parameters for Pancreatic disease (PD) diff --git a/man/standardize_PJSdata.Rd b/man/standardize_PJSdata.Rd index b5fe466..4a54f92 100644 --- a/man/standardize_PJSdata.Rd +++ b/man/standardize_PJSdata.Rd @@ -7,25 +7,33 @@ standardize_PJSdata(PJSdata, dbsource = "v2_sak_m_res") } \arguments{ -\item{PJSdata}{Data frame with data extracted from PJS.} +\item{PJSdata}{[\code{data.frame}]\cr +Data retrieved from PJS.} -\item{dbsource}{If specified, this will be used for fetching standard column -names by \code{\link{standardize_columns}}.} +\item{dbsource}{[\code{character(1)}]\cr +The table that is the source of data. This will be used for fetching + standard column names by + \ifelse{html}{\code{\link{standardize_columns}}}{\code{standardize_columns}} + and should be the name of the data source as registered in the + "column_standards" table. Defaults to "v2_sak_m_res".} } \value{ -data frame with standardized PJS-data. +\code{data.frame} with standardized PJS-data. } \description{ Standardizing PJS-data. This standardizing should always be performed. Other functions used for further preparation of PJSdata, like - \code{\link{choose_PJS_levels}}, and \code{\link{exclude_from_PJSdata}} + \ifelse{html}{\code{\link{choose_PJS_levels}}}{\code{choose_PJS_levels}} + , and + \ifelse{html}{\code{\link{exclude_from_PJSdata}}}{\code{exclude_from_PJSdata}} will not work as intended unless the column names are standardized. } \details{ The function performs the following standardizing of data extracted from PJS: \itemize{ \item The unnecessary columns konkl_provenr and vet_distriktnr are removed. - \item The column names are standardized using \code{\link{standardize_columns}}. + \item The column names are standardized using + \ifelse{html}{\code{\link{standardize_columns}}}{\code{standardize_columns}}. \item Numeric variables are transformed to numbers. \item Date variables are transformed to date format. \item Character variables are trimmed for leading and trailing spaces. diff --git a/man/standardize_columns.Rd b/man/standardize_columns.Rd index a4ed30d..5182a3b 100644 --- a/man/standardize_columns.Rd +++ b/man/standardize_columns.Rd @@ -15,68 +15,124 @@ standardize_columns( ) } \arguments{ -\item{data}{Data frame or if \code{property = "colclasses"} the path and filname of the csv-file used as data source} - -\item{dbsource}{database source of data. Set to data if not specifically specified. Needed if translation to column names is dependent on data source} - -\item{standards}{to input alternative standard tables to column_standards} - -\item{property}{Property of the column that should be standardized, currently c("colnames", "colclasses", "collabels", "colwidths_Excel", "colorder").} - -\item{language}{Language for labels. Valid input are c("no", "en")} - -\item{exclude}{Used in combination with \code{property = "colorder"}. \code{exclude = TRUE} excludes all columns with no predefinedcolorder.} - -\item{\dots}{Other arguments to be passed read.csv2 when \code{property = "colclasses"}.} +\item{data}{[\code{data.frame} | \code{character(1)}]\cr +The data source. If \code{property = "colclasses"} the path and + file name of the csv-file used as data source should be given.} + +\item{dbsource}{[\code{character(1)}]\cr +The database that is the source of data. Should be the name of + the data source as registered in column_standards table. Defaults + to \code{deparse(substitute(data))}.} + +\item{standards}{[\code{character(1)}]\cr +For giving alternative standard tables to column_standards.} + +\item{property}{[\code{character(1)}]\cr +Property of the column that should be standardized. Must be one + of c("colnames", "colclasses", "collabels", "colwidths_Excel", + "colorder"). Defaults to \code{NULL}.} + +\item{language}{[\code{character(1)}]\cr +Language for labels. Must be one of c("no", "en"). Defaults to "no".} + +\item{exclude}{[\code{logical(1)}]\cr +Used in combination with \code{property = "colorder"}. If \code{TRUE}, + all columns with no predefined column order are excluded. + Defaults to \code{FALSE}.} + +\item{\dots}{Other arguments to be passed to +\ifelse{html}{\code{\link[utils:read.csv2]{read.csv2}}}{\code{read.csv2}} +when \code{property = "colclasses"}.} } \value{ -\code{property = "colnames"}. A data frame with standard column names. +\code{property = "colnames"}: A data frame with standard column names. - \code{property = "colclasses"}. a named vector of column classes to be used as input to functions for reading csv-files. +\code{property = "colclasses"}: A named vector of column classes to + be used as input to functions for reading csv-files, see details. - \code{property = "collabels"}. a vector with labels for the columns in the data frame. +\code{property = "collabels"}: A vector with labels for the columns + in the data frame. - \code{property = "colwidths_Excel"}. a vector with column widths for Excel. To be used as input parameter to \code{openxlsx::.colwidth()}. +\code{property = "colwidths_Excel"}: A vector with column widths for Excel. + To be used as input parameter to + \ifelse{html}{\code{\link[openxlsx:setColWidths]{openxlsx::setColWidths}}}{\code{openxlsx::setColWidths}}. - \code{property = "colorder"}. A data frame with column names in predefined order. If exclude = TRUEonly columns withh a defined order is included +\code{property = "colorder"}: A data frame with column names in predefined + order. If \code{exclude = TRUE} only columns with a defined order is included. } \description{ -Standardizes column names, labels, column width for variables in external databases. +Standardizes column names, labels, column width + for variables in external databases. } \details{ -Experimental, the standardization table is under development. This version only works when being connected to the NVI network. - - Variables in internal and external data sources uses different variable names for the same content. - \code{Standarddize_columns} standardizes column names for use in scripts. It will be further developed to standardize column labels - and column widths for both Excel and DT. Furthermore, input values for the parameter \code{colClasses = } for \code{read.csv2} can be - generated. - - \code{property = "colnames"} will replace the column names in a data frame with standardized column names. - All standard column names is snake_case. If no standard name is defined for a variable name, the variable - name is translated to snake_case and the national characters \code{c("æ", "ø", "å")} are translated to \code{c("ae", "oe", "aa")}. - - \code{property = "colclasses"} will generate a named vector with the column classes for variables that may not be read correct when importing - data from a csv-file. This applies for example to numbers with leading zero that must be imported as character. This vector can be used as a - parameter for \code{colClasses = }. - - The default fileEncoding is assumed to be "UTF-8". If another encoding one must give an additional argument like \code{fileEncoding = "latin"}. - - \code{property = "collabels"} will generate a vector with column labels that can be used to replace the column names in the header of the data - table. The column names are not changed automatiacally but can be changed by using a colname statement (see help). If no standard column label - is defined, the column name as Sentence case is used as column label. If English names are used and no English column label exists, the Norwegian - column label is used instead. - - \code{property = "colwidths_Excel"} will generate a vector with column widths for Excel. To be used as input parameter to \code{openxlsx::.colwidth()}. - If no standard column width is defined, the Excel standard width of 10.78 is used. Be aware that the generation of column widths are based on the - column names. Do not change the column names to labels before the column widths are generated. - - \code{property = "colorder"} will generate a data frame with the column names in a predefined order. The column names should first have been standardized. - No standard order will be given unless the dbsource is defined in the column_standards table. If \code{exclude = FALSE} (the standard) the columns with no - predefined order will be moved to the last columns in the same order as they appeared in the original data frame. If \code{exclude = TRUE} all columns with - no predefined order is excluded from the data frame. This option is mainly intended for well defined and worked through routines like making selections lists - for the Food Safety Authority. Do not use \code{exclude = TRUE} unless you are certain that all columns that should be included are defined in the - column_standards table for this dbsource. If uncertain, you may first try with \code{exclude = FALSE} and thereafter compare with \code{exclude = TRUE} to - check if you loose important information. +The standardization table is under development. This + function only works when being connected to the NVI network. + +Variables in internal and external data sources uses + different variable names for the same content. + \code{Standardize_columns} standardizes column names for + use in scripts. In addition, it standardises column labels + and column widths for Excel. Furthermore, input values for + the parameter \code{colClasses} for + \ifelse{html}{\code{\link[utils:read.csv2]{read.csv2}}}{\code{read.csv2}} + and + \ifelse{html}{\code{\link[data.table:fread]{data.table::fread}}}{\code{data.table::fread}} + can be generated. + +\code{property = "colnames"} will replace the column names + in a data frame with standardized column names. All + standard column names is snake_case. If no standard name + is defined for a variable name, the variable + name is translated to snake_case and the national characters + c("æ", "ø", "å") are translated to + c("ae", "oe", "aa"). + +\code{property = "colclasses"} will generate a named vector + with the column classes for variables that may not be read + correct when importing data from a csv-file. This applies + for example to numbers with leading zero that must be imported + as character. This vector can be used as a parameter for + \code{colClasses}. + +The default \code{fileEncoding} is assumed to be "UTF-8". + If another encoding is needed, one must give an additional + argument like \code{fileEncoding = "latin1"}. + +\code{property = "collabels"} will generate a vector with column + labels that can be used to replace the column names in the + header of the data table. The column names are not standardised + automatically but can be standardised by first using + \code{standardize_colnames} with \code{property = "colname"}. + If no standard column label for the column name is defined, + the column name as Sentence case is used as column label. + If English names are used and no English column label exists, + the Norwegian column label is used instead. + +\code{property = "colwidths_Excel"} will generate a vector with + column widths for Excel. To be used as input parameter to + \ifelse{html}{\code{\link[openxlsx:setColWidths]{openxlsx::setColWidths}}}{\code{openxlsx::setColWidths}}. + If no standard column width is defined, the Excel standard + width of 10.78 is used. Be aware that the generation of column + widths are based on the column names. Do not change the column + names to labels before the column widths are generated. + +\code{property = "colorder"} will generate a data frame with + the column names in a predefined order. The column names + should first have been standardised. No standard order will + be given unless the dbsource is defined in the column_standards + table. If \code{exclude = FALSE} (the standard) the columns + with no predefined order will be moved to the last columns + in the same order as they appeared in the original data frame. + If \code{exclude = TRUE} all columns with no predefined order + is excluded from the data frame. This option is mainly + intended for well defined and worked through routines like + making selections lists for the Food Safety Authority. Do + not use \code{exclude = TRUE} unless you are certain that + all columns that should be included are defined in the + column_standards table for this dbsource. If uncertain, + you may first try with \code{exclude = FALSE} and thereafter + compare with \code{exclude = TRUE} to check if you loose + important information. } \examples{ \dontrun{ diff --git a/man/standardize_eos_data.Rd b/man/standardize_eos_data.Rd index 27c3f99..6f700fb 100644 --- a/man/standardize_eos_data.Rd +++ b/man/standardize_eos_data.Rd @@ -20,7 +20,7 @@ standardize_eos_data( The data retrieved from EOS.} \item{dbsource}{[\code{character(1)}]\cr - If specified, this will be used for fetching standard column names by + If specified, this will be used for fetching standard column names by \code{\link{standardize_columns}}. Defaults to the name of the input data.} \item{standards}{[\code{data.frame}]\cr @@ -33,7 +33,7 @@ If \code{TRUE}, the column names will be standardised. Defaults to \code{TRUE)}. If \code{TRUE}, breed is translated back to species. Defaults to \code{TRUE)}.} \item{adjust_n_examined}{[\code{logical(1)}]\cr -If \code{TRUE}, the number of examined samples is adjusted so it is at maximum +If \code{TRUE}, the number of examined samples is adjusted so it is at maximum the number of received samples. Defaults to \code{TRUE}.} \item{delete_redundant}{[\code{logical(1)}]\cr @@ -54,31 +54,31 @@ The function performs the following standardising of data extracted from EOS: \item The column names are standardised using \code{\link{standardize_columns}}. \item Numeric variables are transformed to numbers. \item Datetime variables are transformed to dates. - \item Double registrations of a "Sak" due to the municipality being divided - between two Food Safety Authority office, are merged into one and for + \item Double registrations of a "Sak" due to the municipality being divided + between two Food Safety Authority office, are merged into one and for these, the information on Food Safety Authority office is removed. - \item Splits saksnr into saksnr and fagnr if saksnr combines both. - \item Breed is transformed to species. - \item Number of examined samples are corrected so it don't exceed the number + \item Splits saksnr into saksnr and fagnr if saksnr combines both. + \item Breed is transformed to species. + \item Number of examined samples are corrected so it don't exceed the number of received samples. - \item Redundant variables are deleted. + \item Redundant variables are deleted. } -Standardisation of column names may be set to \code{FALSE}. This should only be - done if the column names have been standardised previously as a new - standardisation of column names may give unpredicted results. Remark that all - other standardisations are dependent on standard column names, so the function +Standardisation of column names may be set to \code{FALSE}. This should only be + done if the column names have been standardised previously as a new + standardisation of column names may give unpredicted results. Remark that all + other standardisations are dependent on standard column names, so the function will not work if the data do not have standard column names. - + Transformation from breed to species is only performed when species is included in the data. You need to import the translation table for PJS-codes to perform the translation, use \code{PJS_codes_2_text <- read_PJS_codes_2_text()}. - + Correction of number of tested samples is only done when both number of received and number of tested are included in the data. - + There are a few reduntant varibles in some data sets. In CWD data both "sist_overfort" - and "sist_endret" keeps the same information. "sist_endret" is deleted. In - Salmonella and Campylobacter data, "prove_identitet" is always \code{NULL} and + and "sist_endret" keeps the same information. "sist_endret" is deleted. In + Salmonella and Campylobacter data, "prove_identitet" is always \code{NULL} and "prove_id" is \code{NULL} for salmonella data and equal ti "id_nr" for Campylobacter data. Both are deleted. Set \code{delete_redundant = FALSE} to keep them. } diff --git a/man/transform_code_combinations.Rd b/man/transform_code_combinations.Rd new file mode 100644 index 0000000..261b4cc --- /dev/null +++ b/man/transform_code_combinations.Rd @@ -0,0 +1,97 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/transform_code_combinations.R +\name{transform_code_combinations} +\alias{transform_code_combinations} +\title{Transform combinations of code values into new values} +\usage{ +transform_code_combinations( + data, + from_values, + to_values, + impute_when_missing_from = NULL +) +} +\arguments{ +\item{data}{[\code{data.frame}]\cr +Data with code values that should be transformed.} + +\item{from_values}{[\code{list}]\cr +List with named vector(s) of code values that should transformed, see details and examples.} + +\item{to_values}{[\code{list}]\cr +List with named vector(s) of code values that should be the results of the transformation, +see details and examples.} + +\item{impute_when_missing_from}{[\code{character}]\cr +Column names for the code variables from which code values should be copied if no +transformation is performed. Defaults to the original column names.} +} +\value{ +A \code{data.frame}. +} +\description{ +Transforms combinations of code values into new values in a data +frame. This is intended for use when only a few code value combinations +should be changed and one will avoid building translation tables or code +with several if, which or case_when statements. In particularly it was +inspired by the need of changing a few code combinations in PJS data when +reporting surveillance programmes. +} +\details{ +The function builds a transformation table based on the input. The +\code{from_values} and the \code{to_values} give the data to a transformation table, +and the \code{from_columns} and the \code{to_columns} give the column names for the +transformation table. + +The \code{from_values} is a list of one or more vectors. Each vector is named with +the column name and represents one column variable with code values. The +first entry in each vector constitute one code combination to be +transformed, the second entry constitutes the next code combinations. + +Likewise, is the \code{to_values} a list of one or more named vectors. Each +vector is named and represents one column variable with +code values to which the code combinations in the \code{from_values} should be +transformed. The name of the vector is the name of the columns with the +transformed values. The transformed values can be put in the original columns, +in which case the transformed combinations will replace +the original entries. If the transformed column names don't exist in data, +the columns will be added to the data. + +If the codes are not transformed, these can be kept in the data. +\code{impute_when_missing_from} gives the column names of the columns from which +to impute. Normally this will be the same as the original columns. However, +if the number of transformed columns is less than the original columns, it +will be necessary to give the columns from which to keep the code. +} +\examples{ +library(NVIdb) + +# A code combination of two is tranformed to another code combination of two + data <- as.data.frame(cbind( +c("Detected", "Detected", "Not detected", NA), + c("M. bovis", "M. kansasii", "M. bovis", NA) +)) + colnames(data) <- c("kjennelse", "analytt") + + data <- transform_code_combinations(data = data, + from_values = list("kjennelse" = c("Detected"), + "analytt" = c("M. kansasii")), + to_values = list("kjennelse" = c("Not detected"), + "analytt" = c("M. bovis")), + impute_when_missing_from = c("kjennelse", "analytt")) + +# two code values to one new variable +data <- as.data.frame(cbind(c("hjort", "rein", "elg", "hjort", NA), + c("produksjonsdyr", "ville dyr", "ville dyr", "ville dyr", NA))) +colnames(data) <- c("art", "driftsform") + +data <- transform_code_combinations( + data = data, + from_values = list("art" = c("hjort", "rein", NA), + "driftsform" = c("produksjonsdyr", "ville dyr", NA)), + to_values = list("art2" = c("oppdrettshjort", "villrein", "ukjent")), + impute_when_missing_from = "art") +} +\author{ +Petter Hopp Petter.Hopp@vetinst.no +} diff --git a/notes/.gitignore b/notes/.gitignore index 2d19fc7..63bc47a 100644 --- a/notes/.gitignore +++ b/notes/.gitignore @@ -1 +1,2 @@ *.html +vignette_install_NVIverse.Rmd diff --git a/notes/develop.R b/notes/develop.R index e4432d1..4d939a0 100644 --- a/notes/develop.R +++ b/notes/develop.R @@ -24,6 +24,12 @@ pkg <- stringi::stri_extract_last_words(pkg_path) # type = "develop", # document = FALSE) +# UPDATE LICENSE +# NVIpackager::update_license(pkg = pkg, +# pkg_path = pkg_path, +# copyright_owner = "Norwegian Veterinary Institute") + + # DOCUMENTATION AND STYLING ---- # 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) @@ -32,7 +38,7 @@ pkg <- stringi::stri_extract_last_words(pkg_path) # Should be run before git push when documentation for functions have been changed NVIpackager::document_NVIpkg(pkg = pkg, pkg_path = pkg_path, - style = FALSE, + style = TRUE, contributing = FALSE, readme = FALSE, manual = "update", @@ -89,3 +95,22 @@ utils::help(package = (pkg)) library(package = pkg, character.only = TRUE) +# MANUAL CHECK OF SCRIPTS ---- +# Search for string +txt <- "\\.data\\$" +files_with_pattern <- findInFiles::findInFiles(ext = "R", pattern = txt, output = "tibble") +files_with_pattern <- findInFiles::FIF2dataframe(files_with_pattern) +package <- rep(pkg, dim(files_with_pattern)[1]) +files_with_pattern <- cbind(package, files_with_pattern) + +wb <- openxlsx::createWorkbook() +# Replace with openxlsx::addWorksheet() +NVIpretty::add_formatted_worksheet(data = files_with_pattern, + workbook = wb, + sheet = make.names(paste0(pkg, txt))) +openxlsx::saveWorkbook(wb, + file = file.path("../", paste0(pkg, "_", "files_with_pattern.xlsx")), + overwrite = TRUE) + +# Replace all occurrences of string in scripts + diff --git a/notes/get_holiday.R b/notes/get_holiday.R deleted file mode 100644 index 279eaf1..0000000 --- a/notes/get_holiday.R +++ /dev/null @@ -1,109 +0,0 @@ -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/notes/select_PJSdata_for_value.R b/notes/select_PJSdata_for_value.R deleted file mode 100644 index ed1834d..0000000 --- a/notes/select_PJSdata_for_value.R +++ /dev/null @@ -1,68 +0,0 @@ - - -select_PJSdata_for_value <- function(data, - code_column, - value_2_check, - include_missing_for = NULL, - keep_selected = TRUE) { - - # data <- PJSdata - # code_column <- "hensiktkode" - # value_2_check <- hensikt2delete - # include_missing_for = NULL - # keep_selected = TRUE - - - - # transform value_2_check to regular expressions - value_2_check <- paste0("^", value_2_check) - value_2_check <- gsub(pattern = "%", replacement = "[[:digit:]]*", x = value_2_check, fixed = TRUE) - - # Identifies all variables in the index taking into consideration the PJS-levels of the code_column(s) - index <- c("aar", "ansvarlig_seksjon", "innsendelsenr", "saksnr") - for (k in 1:length(code_column)) { - index <- union(index, - NVIdb::PJS_levels[which(NVIdb::PJS_levels[1:10, which(NVIdb::PJS_levels[which(NVIdb::PJS_levels$variable == code_column[k]), ] == 1)[1]] == 1), "variable"]) - } - # Keeps only variables that exist in PJSdata. Necessary as resnr will not be in PJSdata. - index <- base::intersect(index, colnames(data)) - - # Generate data frame for check that only contains the relevant variables - ktr <- data[, unique(c(index, code_column))] - ktr <- unique(ktr) - - # Combine the codes that should be checked into one variable - # if (code_column == "hensiktkode" & length(code_column) == 1) { - # ktr$combined_codes <- ktr[, c(code_column)] - # } else { - # ktr$combined_codes <- apply(ktr[, c("hensiktkode", code_column)], 1, FUN = paste, collapse = "-") - # } - if(length(code_column) > 1) { - ktr$combined_codes <- apply(ktr[, c(code_column)], 1, FUN = paste, collapse = "-") - } else { - ktr$combined_codes <- ktr[, code_column] - ktr[is.na(ktr$combined_codes), "combined_codes"] <- "NA" - } - - - # Find records deviating from detected code values - ktr <- ktr %>% - dplyr::rowwise() %>% - dplyr::mutate(select = max(unlist(lapply(value_2_check, grep, x = combined_codes)), 0)) - - # if (!is.null(include_missing_for) & length(code_column == 1)) { - # ktr[which(is.na(ktr[, "combined_codes"])), "select"] <- 1 - # } - - ktr$select <- as.logical(ktr$select) - if (isFALSE(keep_selected)) {ktr$select <- !ktr$select} - - ktr <- subset(ktr, select == TRUE) - ktr[, c("combined_codes", "select")] <- c(NULL, NULL) - - column_names <- colnames(data) - data <- merge(x = ktr, y = data, by = c(index, code_column), all.x = TRUE, all.y = FALSE, sort = TRUE) - data <- data[, column_names] - - return(data) -} diff --git a/notes/set_disease_parameters2.R b/notes/set_disease_parameters2.R new file mode 100644 index 0000000..4165c31 --- /dev/null +++ b/notes/set_disease_parameters2.R @@ -0,0 +1,135 @@ +#' @title Sets disease selection parameters +#' @description Sets the disease selection parameters and store them in a list +#' object. The list follows a standardised named format and the elements can +#' be used as input to +#' \ifelse{html}{\code{\link{build_query_hensikt}}}{\code{build_query_hensikt}}, +#' \ifelse{html}{\code{\link{build_query_one_disease}}}{\code{build_query_one_disease}} +#' or +#' \ifelse{html}{\code{\link{build_query_outbreak}}}{\code{build_query_outbreak}}. +#' +#' @details Saker in PJS that concern one infection / disease can be characterised +#' by the "analytt" (at "konklusjon" and/or "resultat" level), specific "hensikter", +#' a relevant "utbrudds_ID" and/or specific "metoder." These can be used to select +#' saker in PJS and/or to structure and simplify the output from PJS. +#' +#' One or more specific "hensiktkoder" may be input to the selection statement. +#' With specific "hensiktkode" is meant a "hensiktkode" that will imply that the sample +#' will be examined for specific infectious agent(s) or disease. One or more +#' specific "metodekoder" may be input to the selection statement. With specific +#' "metodekode" is meant a "metodekode" that implies an examination that will give one +#' of the input 2 as a result. If sub-codes of "analyttkode" or "hensiktkode" +#' should be included, end the code with \%. +#' +#' The selection parameters can be input values for dedicated arguments. For input parameters +#' \code{hensikt2select}, \code{utbrudd2select}, \code{metode2select}, +#' \code{analytt2select}, \code{art2select}, and \code{include_missing_art}, +#' the input may be given in a source file. This may be handy if the +#' selection will be performed many times. It also gives the possibility of +#' using a for loop that selects PJS-data and performs similar analyses for one +#' disease at a time. +#' +#' @param hensikt2select [\code{character}]\cr +#' Specific "hensiktkoder" for the "analytt" in question. If sub-codes should +#' be included, end the code with \%. Can be \code{NULL}. +#' @param hensikt2delete [\code{character}]\cr +#' "hensiktkoder" for which saker should be excluded +#' If sub-codes should be included, end the code with \%. Can be \code{NULL}. +#' @param utbrudd2select [\code{character(1)}]\cr +#' "utbruddsID". Can be \code{NULL}. +#' @param metode2select [\code{character}]\cr +#' Specific "metodekoder for the "analytt" in question." Can be \code{NULL}. +#' @param analytt2select [\code{character}]\cr +#' "analyttkoder". If sub-codes should be included, end the code with \%. +#' Can be \code{NULL}. +#' @param art2select [\code{character}]\cr +#' "artkoder". If sub-codes should be included, end the code with \%. \code{NA} can be +#' combined with another "artkode". Can be \code{NULL}. +#' @param include_missing_art [\code{character(1)}]\cr +#' Should missing art be included. Must be one of c("never", "always", "for_selected_hensikt"). +#' If NULL, it is set to "always" when \code{art2select} includes NA, else it is set to "never". +#' @param file [\code{character(1)}]\cr +#' path and file name for an R script that can be sourced and that +#' sets the parameters \code{hensikt2select}, \code{utbrudd2select}, \code{metode2select}, and +#' \code{analytt2select}. Can be \code{NULL}. +#' +#' @return A named list with selection parameters that can be used to generate +#' SQL selection-statements and facilitate structuring output from PJS. +#' +#' @author Petter Hopp Petter.Hopp@@vetinst.no +#' @export +#' @examples +#' # Selection parameters for Pancreatic disease (PD) +#' selection_parameters <- set_disease_parameters( +#' analytt2select = c("01220104%", "1502010235"), +#' hensikt2select = c("0100108018", "0100109003", "0100111003", "0800109"), +#' metode2select = c("070070", "070231", "010057", "060265") +#' ) +set_disease_parameters <- function(hensikt2select = NULL, + hensikt2delete = NULL, + utbrudd2select = NULL, + metode2select = NULL, + analytt2select = NULL, + art2select = NULL, + include_missing_art = NULL, + file = NULL) { + + # SET SELECTION PARAMETERS ---- + # Import values from parameter file if exists + if (!is.null(file)) { + checkmate::assert_file(x = file) + if (!is.null(file)) { + script <- as.character(parse(file = file, encoding = "UTF-8")) + + script <- script[grepl(pattern = paste0("[^hensikt2select|^hensikt2delete|^analytt2select|^metode2select|", + "^art2select|^utbrudd2select|^missing_art]", + "[[:blank:]]*", + "[=|<\\-]"), + script)] + + for (i in 1:length(script)) { + eval(parse(text = script[i])) + } + } + } + + # PREPARE INPUT BEFORE ARGUMENT CHECKING ---- + # when include_missing_art = NULL, set to "always" if NA included in art2select, else set to "never" + if (is.null(include_missing_art)) { + if (!is.null(art2select) && any(is.na(art2select))) { + include_missing_art <- "always" + } else { + include_missing_art <- "never" + } + } + + # ARGUMENT CHECKING ---- + # Object to store check-results + checks <- checkmate::makeAssertCollection() + + # Perform checks + NVIcheckmate::assert_non_null(list(analytt2select, hensikt2select, utbrudd2select, file), add = checks) + checkmate::assert_character(hensikt2select, min.chars = 2, max.chars = 15, any.missing = FALSE, null.ok = TRUE, add = checks) + checkmate::assert_character(hensikt2delete, min.chars = 2, max.chars = 15, any.missing = FALSE, null.ok = TRUE, add = checks) + checkmate::assert_character(utbrudd2select, max.chars = 5, any.missing = FALSE, null.ok = TRUE, add = checks) + checkmate::assert_character(metode2select, n.chars = 6, any.missing = FALSE, null.ok = TRUE, add = checks) + checkmate::assert_character(analytt2select, min.chars = 2, max.chars = 20, any.missing = FALSE, null.ok = TRUE, add = checks) + checkmate::assert_character(art2select, min.chars = 2, max.chars = 20, all.missing = FALSE, null.ok = TRUE, add = checks) + # if (!is.null(art2select) && any(is.na(art2select))) { + checkmate::assert_choice(include_missing_art, + choices = c("never", "always", "for_selected_hensikt"), + add = checks) + # } + + # Report check-results + checkmate::reportAssertions(checks) + + # CREATE LIST WITH PARAMETER VALUES ---- + return(list("hensikt2select" = hensikt2select, + "hensikt2delete" = hensikt2delete, + "utbrudd2select" = utbrudd2select, + "metode2select" = metode2select, + "analytt2select" = analytt2select, + "art2select" = art2select, + "include_missing_art" = include_missing_art)) +} + diff --git a/notes/test_transform_code_combinations.R b/notes/test_transform_code_combinations.R deleted file mode 100644 index d1baa80..0000000 --- a/notes/test_transform_code_combinations.R +++ /dev/null @@ -1,93 +0,0 @@ -library(NVIdb) -library(testthat) - -test_that("transform code combinations, from 2 columns to 2 columns", { - # A code combination of two is tranformed to another code combination of two - data <- as.data.frame(cbind(c("Detected", "Detected", "Not detected", NA), - c("M. bovis", "M. kansasii", "M. bovis", NA))) - colnames(data) <- c("kjennelse", "analytt") - - transform_code_combinations(data = data, - from_values = list(c("Detected"), - c("M. kansasii")), - to_values = list(c("Not detected"), - c("M. bovis")), - from_columns = c("kjennelse", "analytt"), - to_columns = c("kjennelse", "analytt"), - impute_when_missing_from = c("kjennelse", "analytt") - ) - - correct_result <- as.data.frame(cbind(c("Detected", "Detected", "Not detected", NA), - c("M. bovis", "M. kansasii", "M. bovis", NA))) - - # # examples - # # two code values to one new varable - # from_values <- list(c("hjort", "rein", "rein", NA), - # c("produksjonsdyr", "ville dyr", "produksjonsdyr", NA)) - # to_values <- list(c("oppdrettshjort", "villrein", "tamrein", "Ukjent")) - # from_columns <- c("art", "driftsform") - # to_columns <- c("art2") - # impute_when_missing_from <- "art" - # - # PJSdata <- as.data.frame(cbind(c("hjort", "rein", "rein", "elg", "hjort", "rein", "rein", NA), - # c("produksjonsdyr", "ville dyr", "produksjonsdyr", "ville dyr", "ville dyr", "produksjonsdyr", "ville dyr", NA))) - # colnames(PJSdata) <- c("art", "driftsform") - # data <- PJSdata - # - # - -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")) -}) - - -library(NVIdb) -library(testthat) - -test_that("transform_code_combinations: two variables to one", { - - # two code values to one new varable - data <- as.data.frame(cbind(c("hjort", "rein", "rein", "elg", "hjort", "rein", "rein", NA), - c("produksjonsdyr", "ville dyr", "produksjonsdyr", "ville dyr", "ville dyr", "produksjonsdyr", "ville dyr", NA))) - colnames(data) <- c("art", "driftsform") - - correct_result <- rbind(data, - c("opdrettshjort", "villrein", "tamrein", "elg", "hjort", "tamrein", "villrein", "ukjent")) - - tranform_code_combinations(data = data, - from_values <- list(c("hjort", "rein", "rein", NA), - c("produksjonsdyr", "ville dyr", "produksjonsdyr", NA)), - to_values <- list(c("oppdrettshjort", "villrein", "tamrein", "ukjent")), - from_columns <- c("art", "driftsform"), - to_columns <- c("art2"), - impute_when_missing_from <- "art") - - expect_identical(data, correct_result) -}) -# - -test_that("transform_code_combinations: one variable to three", { - - data <- as.data.frame(c("fixed organs", "fresh bulk milk", "blood sample", NA)) - colnames(data) <- c("material") - - correct_result <- rbind(data, - c("single sample", "bulk milk", "single sample", NA), - c("fixed", "fresh", "fresh", NA), - c("organs", "milk", "blood", NA)) - - tranform_code_combinations(data = data, - from_values <- list(c("hjort", "rein", "rein", NA), - c("produksjonsdyr", "ville dyr", "produksjonsdyr", NA)), - to_values <- list(c("oppdrettshjort", "villrein", "tamrein", "ukjent")), - from_columns <- c("art", "driftsform"), - to_columns <- c("art2"), - impute_when_missing_from <- "art") - - expect_identical(data, correct_result) -}) diff --git a/notes/transform_code_combinations.R b/notes/transform_code_combinations.R deleted file mode 100644 index 1867b60..0000000 --- a/notes/transform_code_combinations.R +++ /dev/null @@ -1,137 +0,0 @@ -#' @title Transform combinations of code values into new values -#' @description Transforms combinations of code values into new values in a data -#' frame. This is intended for use when only a few code value combinations -#' should be changed and one will avoid building translation tables or code -#' with several if, which or case_when statements. In particularly it was -#' inspired by the need of changing a few code combinations in PJS data when -#' reporting surveillance programmes. -#' @details The function builds a transformation table based on the input. The -#' from_values and the to_values give the data to a transformation table, -#' and the from_columns and the to_columns give the column names for the -#' transformation table. -#' -#' The from-values is a list of one or more vectors. Each vector represents one -#' column variable with code values. The first entry in each vector -#' constitute one code combination to be transformed, the second entry -#' constitutes the next code combinations. Likewise, is the to_values a list -#' of one or more vectors. Each vector represents one column variable with -#' code values to which the code combinations in the from_values should be -#' transformed. -#' -#' The from_columns is a vector of column names for the codes that should be -#' transformed. The column names will name each vector with code values in -#' the from_values list. The column names must exist in the data. Likewise, -#' the to_columns is a vector of column names for the columns with the -#' transformed code values. The to_columns can be the same as the -#' from_columns, in which case the transformed combinations will replace -#' the original entries. If the to_columns don't exist in data, the column -#' will be added to the data. -#' -#' If the codes are not transformed, these will be kept in the data. -#' impute_when_missing_from gives the column names of the columns from which -#' to impute. Normally this will be the same as the from_columns. However, -#' if the number of columns in to_columns is less than in from_columns, it -#' will be necessary to give the columns from which to keep the code. -#' -#' @param data \[\code{data.frame}\]\cr -#' Data with code values that should be transformed. -#' @param from_values \[\code{list}\]\cr -#' List with vector(s) of code values that should transformed, see details and examples. -#' @param to_values \[\code{list}\]\cr -#' List with vector(s) of code values that should be the results of the transformation, -#' see details and examples. -#' @param from_columns \[\code{character}\]\cr -#' Column names for the code variables that should be transformed. -#' @param to_columns \[\code{character}\]\cr -#' Column names for the code variables with the results of the transformation. -#' @param impute_when_missing_from \[\code{character}\]\cr -#' Column names for the code variables from which code values should be copied if no -#' transformation is performed. Defaults to \code{from_columns}. -#' -#' @return A \code{data.frame}. -#' -#' @author Petter Hopp Petter.Hopp@@vetinst.no -#' @export - - -transform_code_combinations <- function(data, - from_values, - to_values, - from_columns, - to_columns, - impute_when_missing_from = NULL) { - - # ARGUMENT CHECKING ---- - # Object to store check-results - checks <- checkmate::makeAssertCollection() - # Perform checks - checkmate::assert_data_frame(data, add = checks) - checkmate::assert_list(from_values, min.len = 1, add = checks) - checkmate::assert_list(to_values, min.len = 1, add = checks) - checkmate::assert_character(from_columns, min.len = 1, min.chars = 1, add = checks) - checkmate::assert_character(to_columns, min.len = 1, min.chars = 1, add = checks) - checkmate::assert_character(impute_when_missing_from, max.len = length(to_columns), null.ok = TRUE, add = checks) - checkmate::assert_subset(impute_when_missing_from, choices = from_columns, add = checks) - # Report check-results - checkmate::reportAssertions(checks) - - # CREATE TRANSLATION TABLE WITH FROM AND TO VALUES ---- - to_columns_temp <- paste0(rep("tcc_V", length(to_columns)), as.character(1:length(to_columns))) - translation_table <- data.frame(unlist(from_values[1])) - colnames(translation_table) <- from_columns[1] - for (i in 2:length(from_values)) { - translation_table[, from_columns[i]] <- as.data.frame(unlist(from_values[i])) - } - for (i in 1:length(to_values)) { - translation_table[, to_columns_temp[i]] <- as.data.frame(unlist(to_values[i])) - } - # translation_table[is.na(translation_table)] <- "_NA_" - - # CREATE SUBSET TO TRANSLATE ---- - subdata <- data[, from_columns] - # subdata[is.na(subdata)] <- "_NA_" - subdata$sort_order <- 1:nrow(subdata) - - # PERFORM TRANSLATION ---- - subdata <- merge(subdata, translation_table, by = c(from_columns), all.x = TRUE) - - if (!is.null(impute_when_missing_from)) { - subdata[rowSums(is.na(subdata[, to_columns_temp])) == length(to_columns_temp), to_columns_temp[1:length(impute_when_missing_from)]] <- - subdata[rowSums(is.na(subdata[, to_columns_temp])) == length(to_columns_temp), impute_when_missing_from] - } - subdata <- subdata[order(subdata$sort_order), ] - - # RETURN DATA WITH TRANSLATED COLUMNS - data[, to_columns] <- subdata[, to_columns_temp] - return(data) -} - -# # examples -# # two code values to one new varable -# from_values <- list(c("hjort", "rein", "rein", NA), -# c("produksjonsdyr", "ville dyr", "produksjonsdyr", NA)) -# to_values <- list(c("oppdrettshjort", "villrein", "tamrein", "Ukjent")) -# from_columns <- c("art", "driftsform") -# to_columns <- c("art2") -# impute_when_missing_from <- "art" -# -# PJSdata <- as.data.frame(cbind(c("hjort", "rein", "rein", "elg", "hjort", "rein", "rein", NA), -# c("produksjonsdyr", "ville dyr", "produksjonsdyr", "ville dyr", "ville dyr", "produksjonsdyr", "ville dyr", NA))) -# colnames(PJSdata) <- c("art", "driftsform") -# data <- PJSdata -# -# -# # A code combination of two is tranformed to another code combination of two -# from_values <- list(c("Detected"), -# c("M. kansasii")) -# to_values <- list(c("Not detected"), -# c("M. bovis")) -# from_columns <- c("kjennelse", "analytt") -# to_columns <- c("kjennelse", "analytt") -# impute_when_missing_from <- c("kjennelse", "analytt") -# -# PJSdata <- as.data.frame(cbind(c("Detected", "Detected", "Not detected", NA), -# c("M. bovis", "M. kansasii", "M. bovis", NA))) -# colnames(PJSdata) <- c("kjennelse", "analytt") -# data <- PJSdata -# diff --git a/tests/testthat/test_Prodtilskudd.R b/tests/testthat/test_Prodtilskudd.R index 16f268f..53a23cf 100644 --- a/tests/testthat/test_Prodtilskudd.R +++ b/tests/testthat/test_Prodtilskudd.R @@ -48,6 +48,28 @@ test_that("Read Prodtilskudd", { }) +test_that("Read Prodtilskudd, extracted_date", { + # skip if no connection to 'FAG' have been established + skip_if_not(dir.exists(set_dir_NVI("FAG"))) + + # Reads data + Pkoder <- read_Prodtilskudd(Pkode_year = "2019", Pkode_month = "03", extracted_date = "2020-01-13") + + Pkoder$Telledato <- as.Date(Pkoder$Telledato) + # check type data.frame + expect_identical(class(Pkoder), "data.frame") + # check number of rows and columns + expect_equal(dim(Pkoder), c(26921, 67)) + + # check correct version + # expect_equal(as.vector(unique(Pkoder$`Søknadsår`)), 2019) + # expect_equal(as.vector(unique(Pkoder$Telledato)), as.integer(as.Date("2019-03-01"))) + correct_result <- as.data.frame(cbind("S\u00F8knads\u00E5r" = 2019, "Telledato" = as.Date("2019-03-01"))) + # correct_result$`Søknadsår` <- as.numeric(correct_result$`Søknadsår`) + expect_equal(as.character(unique(Pkoder[, c("S\u00F8knads\u00E5r", "Telledato")])), as.character(correct_result)) + +}) + test_that("errors for copy_Prodtilskudd", { linewidth <- options("width") diff --git a/tests/testthat/test_credentials.R b/tests/testthat/test_credentials.R new file mode 100644 index 0000000..61e104a --- /dev/null +++ b/tests/testthat/test_credentials.R @@ -0,0 +1,34 @@ +library(NVIdb) +library(testthat) + +test_that("test remove_credentials", { + # skip if no connection to 'FAG' have been established + # skip_if_not(isTRUE(NVIcheckmate::check_credentials("PJS"))) + + keyring::key_set_with_value(service = "test", username = "bruker", password = "1234567") + expect_true(NVIcheckmate::check_credentials("test")) + + remove_credentials("test") + expect_false(isTRUE(NVIcheckmate::check_credentials("test"))) +}) + + +test_that("Errors or warnings for set_credentials", { + linewidth <- options("width") + options(width = 80) + + expect_error(set_credentials(), + regexpr = "argument 'dbservice' is missing, with no default") + + options(width = unlist(linewidth)) +}) + +test_that("Errors or warnings for remove_credentials", { + linewidth <- options("width") + options(width = 80) + + expect_error(remove_credentials(), + regexpr = "argument 'dbservice' is missing, with no default") + + options(width = unlist(linewidth)) +}) diff --git a/tests/testthat/test_login_by_input.R b/tests/testthat/test_login_by_input.R new file mode 100644 index 0000000..d98077c --- /dev/null +++ b/tests/testthat/test_login_by_input.R @@ -0,0 +1,22 @@ +library(NVIdb) +library(testthat) + + +test_that("Errors or warnings for login_by_input", { + linewidth <- options("width") + options(width = 80) + + expect_error(login_by_input("PHS"), + regexpr = "Variable 'dbservice': Must be element of") + + expect_error(login_by_input(dbservice = "PJS", + dbdriver = 1, + db = 123L, + dbserver = 23, + dbport = NA, + dbprotocol = 1234, + dbinterface = "x"), + regexpr = "Variable 'dbdriver': Must be of type 'character'") + + options(width = unlist(linewidth)) +}) diff --git a/tests/testthat/test_read_eos_data.R b/tests/testthat/test_read_eos_data.R index d161057..3d22928 100644 --- a/tests/testthat/test_read_eos_data.R +++ b/tests/testthat/test_read_eos_data.R @@ -1,4 +1,4 @@ -library(NVIdb) +library(NVIdb) library(testthat) library(checkmate) @@ -6,45 +6,44 @@ 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 + + # 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))), + + 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 + + # Read data with Saksnr ila <- read_eos_data(eos_table = "proveresultat_ila", - from_path = paste0(set_dir_NVI("EOS"), "RaData/"), + 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/"), + 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_select_PJSdata_for_value.R b/tests/testthat/test_select_PJSdata_for_value.R new file mode 100644 index 0000000..24302ef --- /dev/null +++ b/tests/testthat/test_select_PJSdata_for_value.R @@ -0,0 +1,136 @@ +library(NVIdb) +library(testthat) + +test_that("test select_PJSdata_for_value", { + + df <- as.data.frame(cbind(saksnr = c(1, 2, 3, 4, 5, 6, 7, 8, 9, 10), + code1 = c("01", "01", "01001", "01001", "02", "02", "02001", "02002", "0200201", NA), + code2 = c("03", "03", "03003", "03004", "04", "05", "04003", "04004", "0400403", NA))) + + correct_result <- as.data.frame(cbind(saksnr = c(1, 2), + code1 = c("01", "01"), + code2 = c("03", "03"))) + + expect_identical(select_PJSdata_for_value(data = df, + code_column = "code1", + value_2_check = "01", + keep_selected = TRUE), + correct_result) + + correct_result <- as.data.frame(cbind(saksnr = c(1, 2, 3, 4), + code1 = c("01", "01", "01001", "01001"), + code2 = c("03", "03", "03003", "03004"))) + + expect_identical(select_PJSdata_for_value(data = df, + code_column = "code1", + value_2_check = "01%", + keep_selected = TRUE), + correct_result) + + correct_result <- as.data.frame(cbind(saksnr = c(10), + code1 = c(NA_character_), + code2 = c(NA_character_))) + + expect_identical(select_PJSdata_for_value(data = df, + code_column = "code1", + value_2_check = "NA", + keep_selected = TRUE), + correct_result) + + + correct_result <- as.data.frame(cbind(saksnr = c(1, 2, 5, 6, 7, 8, 9, 10), + code1 = c("01", "01", "02", "02", "02001", "02002", "0200201", NA_character_), + code2 = c("03", "03", "04", "05", "04003", "04004", "0400403", NA_character_))) + + result <- select_PJSdata_for_value(data = df, + code_column = "code1", + value_2_check = c("01", "02%", "NA"), + keep_selected = TRUE) + rownames(result) <- NULL + expect_identical(result, + correct_result) + + correct_result <- as.data.frame(cbind(saksnr = c(3, 4, 5, 6, 7, 8, 9, 10), + code1 = c("01001", "01001", "02", "02", "02001", "02002", "0200201", NA), + code2 = c("03003", "03004", "04", "05", "04003", "04004", "0400403", NA))) + + result <- select_PJSdata_for_value(data = df, + code_column = "code1", + value_2_check = c("01"), + keep_selected = FALSE) + rownames(result) <- NULL + expect_identical(result, + correct_result) + + correct_result <- as.data.frame(cbind(saksnr = c(3, 4), + code1 = c("01001", "01001"), + code2 = c("03003", "03004"))) + + result <- select_PJSdata_for_value(data = df, + code_column = "code1", + value_2_check = c("01", "02%", "NA"), + keep_selected = FALSE) + rownames(result) <- NULL + expect_identical(result, + correct_result) + + + correct_result <- as.data.frame(cbind(saksnr = c(1, 2), + code1 = c("01", "01"), + code2 = c("03", "03"))) + + expect_identical(select_PJSdata_for_value(data = df, + code_column = c("code1", "code2"), + value_2_check = "01%-03", + keep_selected = TRUE), + correct_result) + + correct_result <- as.data.frame(cbind(saksnr = c(1, 2, 3, 4), + code1 = c("01", "01", "01001", "01001"), + code2 = c("03", "03", "03003", "03004"))) + + expect_identical(select_PJSdata_for_value(data = df, + code_column = c("code1", "code2"), + value_2_check = "01%-03%", + keep_selected = TRUE), + correct_result) + + +}) + + +test_that("Errors or warnings for select_PJSdata_for_value", { + linewidth <- options("width") + options(width = 80) + + df <- as.data.frame(cbind(saksnr = c(1, 2, 3, 4, 5, 6, 7, 8, 9, 10), + code1 = c("01", "01", "01001", "01001", "02", "02", "02001", "02002", "0200201", NA), + code2 = c("03", "03", "03003", "03004", "04", "05", "04003", "04004", "0400403", NA))) + + expect_error(select_PJSdata_for_value(data = "df", + code_column = "code1", + value_2_check = "01", + keep_selected = TRUE), + regexpr = "Variable 'data': Must be of type 'data.frame', not 'character'") + + expect_error(select_PJSdata_for_value(data = df, + code_column = "code4", + value_2_check = "01", + keep_selected = TRUE), + regexpr = "{'saksnr','code1','code2'}, but has additional elements {'code4'}", + fixed = TRUE) + + expect_error(select_PJSdata_for_value(data = df, + code_column = "code1", + value_2_check = TRUE, + keep_selected = TRUE), + regexpr = "'value_2_check': Must be of type 'character'") + + expect_error(select_PJSdata_for_value(data = df, + code_column = "code1", + value_2_check = "01", + keep_selected = "TRUE"), + regexpr = "Variable 'keep_selected': Must be of type 'logical flag'") + + options(width = unlist(linewidth)) +}) diff --git a/tests/testthat/test_set_disease_parameters.R b/tests/testthat/test_set_disease_parameters.R index cb05483..8786656 100644 --- a/tests/testthat/test_set_disease_parameters.R +++ b/tests/testthat/test_set_disease_parameters.R @@ -11,8 +11,21 @@ test_that("set disease parameters by direct input", { "utbrudd2select" = NULL, "metode2select" = c("070070", "070231", "010057", "060265"), "analytt2select" = c("01220104%", "1502010235"), + "analytt2delete" = NULL, "art2select" = NULL, - "missing_art" = NULL)) + "include_missing_art" = "never")) + + parameters2 <- set_disease_parameters(selection_parameters = parameters) + expect_equal(parameters2, + list("hensikt2select" = c("0100108018", "0100109003", "0100111003", "0800109"), + "hensikt2delete" = NULL, + "utbrudd2select" = NULL, + "metode2select" = c("070070", "070231", "010057", "060265"), + "analytt2select" = c("01220104%", "1502010235"), + "analytt2delete" = NULL, + "art2select" = NULL, + "include_missing_art" = "never")) + parameters <- set_disease_parameters(hensikt2select = c("0100108018", "0100109003", "0100111003"), hensikt2delete = c("0800109"), @@ -25,43 +38,112 @@ test_that("set disease parameters by direct input", { "utbrudd2select" = "22", "metode2select" = c("070070", "070231", "010057", "060265"), "analytt2select" = c("01220104%", "1502010235"), + "analytt2delete" = NULL, "art2select" = NULL, - "missing_art" = NULL)) + "include_missing_art" = "never")) + + parameters2 <- set_disease_parameters(selection_parameters = parameters) + expect_equal(parameters2, + list("hensikt2select" = c("0100108018", "0100109003", "0100111003"), + "hensikt2delete" = c("0800109"), + "utbrudd2select" = "22", + "metode2select" = c("070070", "070231", "010057", "060265"), + "analytt2select" = c("01220104%", "1502010235"), + "analytt2delete" = NULL, + "art2select" = NULL, + "include_missing_art" = "never")) + + parameters <- set_disease_parameters(hensikt2select = c("0100108018", "0100109003", "0100111003"), + hensikt2delete = c("0800109"), + utbrudd2select = "22", + metode2select = NULL, + art2select = c("01%"), + include_missing_art = "never") + expect_equal(parameters, + list("hensikt2select" = c("0100108018", "0100109003", "0100111003"), + "hensikt2delete" = c("0800109"), + "utbrudd2select" = "22", + "metode2select" = NULL, + "analytt2select" = NULL, + "analytt2delete" = NULL, + "art2select" = c("01%"), + "include_missing_art" = "never")) parameters <- set_disease_parameters(hensikt2select = c("0100108018", "0100109003", "0100111003"), hensikt2delete = c("0800109"), utbrudd2select = "22", metode2select = NULL, art2select = c("01%"), - missing_art = "never") + include_missing_art = NULL) expect_equal(parameters, list("hensikt2select" = c("0100108018", "0100109003", "0100111003"), "hensikt2delete" = c("0800109"), "utbrudd2select" = "22", "metode2select" = NULL, "analytt2select" = NULL, + "analytt2delete" = NULL, "art2select" = c("01%"), - "missing_art" = "never")) + "include_missing_art" = "never")) + + parameters <- set_disease_parameters(hensikt2select = c("0100108018", "0100109003", "0100111003"), + hensikt2delete = c("0800109"), + utbrudd2select = "22", + metode2select = NULL, + art2select = c("01%", NA), + include_missing_art = NULL) + expect_equal(parameters, + list("hensikt2select" = c("0100108018", "0100109003", "0100111003"), + "hensikt2delete" = c("0800109"), + "utbrudd2select" = "22", + "metode2select" = NULL, + "analytt2select" = NULL, + "analytt2delete" = NULL, + "art2select" = c("01%", NA), + "include_missing_art" = "always")) + + parameters2 <- set_disease_parameters(selection_parameters = parameters) + expect_equal(parameters2, + list("hensikt2select" = c("0100108018", "0100109003", "0100111003"), + "hensikt2delete" = c("0800109"), + "utbrudd2select" = "22", + "metode2select" = NULL, + "analytt2select" = NULL, + "analytt2delete" = NULL, + "art2select" = c("01%", NA), + "include_missing_art" = "always")) + }) test_that("set disease parameters using parameter file", { -writeLines( - c('hensikt2select <- c("0100108018", "0100109003", "0100111003", "0800109")', - 'utbrudd2select <- NULL', - 'metode2select <- c("070070", "070231", "010057", "060265")', - 'analytt2select <- c("01220104%", "1502010235")'), - con = file.path(tempdir(), "PD.R") -) + writeLines( + c('hensikt2select <- c("0100108018", "0100109003", "0100111003", "0800109")', + 'utbrudd2select <- NULL', + 'metode2select <- c("070070", "070231", "010057", "060265")', + 'analytt2select <- c("01220104%", "1502010235")'), + con = file.path(tempdir(), "PD.R") + ) parameters <- set_disease_parameters(file = file.path(tempdir(), "PD.R")) -expect_equal(parameters, - list("hensikt2select" = c("0100108018", "0100109003", "0100111003", "0800109"), - "hensikt2delete" = NULL, - "utbrudd2select" = NULL, - "metode2select" = c("070070", "070231", "010057", "060265"), - "analytt2select" = c("01220104%", "1502010235"), - "art2select" = NULL, - "missing_art" = NULL)) + expect_equal(parameters, + list("hensikt2select" = c("0100108018", "0100109003", "0100111003", "0800109"), + "hensikt2delete" = NULL, + "utbrudd2select" = NULL, + "metode2select" = c("070070", "070231", "010057", "060265"), + "analytt2select" = c("01220104%", "1502010235"), + "analytt2delete" = NULL, + "art2select" = NULL, + "include_missing_art" = "never")) + + parameters <- set_disease_parameters(selection_parameters = file.path(tempdir(), "PD.R")) + expect_equal(parameters, + list("hensikt2select" = c("0100108018", "0100109003", "0100111003", "0800109"), + "hensikt2delete" = NULL, + "utbrudd2select" = NULL, + "metode2select" = c("070070", "070231", "010057", "060265"), + "analytt2select" = c("01220104%", "1502010235"), + "analytt2delete" = NULL, + "art2select" = NULL, + "include_missing_art" = "never")) }) @@ -97,25 +179,25 @@ test_that("errors for set_disease_parameters", { expect_error(set_disease_parameters(hensikt2select = NULL, analytt2select = NULL, utbrudd2select = NULL), - regexp = "At least one of the arguments must have input different from") + regexp = "have input different from NULL and NA") expect_error(set_disease_parameters(hensikt2delete = "01001080180100108018", analytt2select = "01220104%", utbrudd2select = "2"), regexp = "but element 1 has 20 characters") - expect_error(set_disease_parameters(hensikt2delete = "0100108018", - analytt2select = "01220104%", - utbrudd2select = "2", - art2select = "05%"), - regexp = "Variable 'missing_art': Must be a subset of") + # expect_error(set_disease_parameters(hensikt2delete = "0100108018", + # analytt2select = "01220104%", + # utbrudd2select = "2", + # art2select = "05%"), + # regexp = "Variable 'include_missing_art': Must be a subset of") expect_error(set_disease_parameters(hensikt2delete = "0100108018", analytt2select = "01220104%", utbrudd2select = "2", - art2select = "05%", - missing_art = FALSE), - regexp = "Variable 'missing_art': Must be element of set") + art2select = c("05%", NA), + include_missing_art = "yes"), + regexp = "Variable 'include_missing_art': Must be element of set") options(width = unlist(linewidth)) }) diff --git a/tests/testthat/test_standardize_columns.R b/tests/testthat/test_standardize_columns.R index 1c71e96..58b8a1f 100644 --- a/tests/testthat/test_standardize_columns.R +++ b/tests/testthat/test_standardize_columns.R @@ -124,7 +124,7 @@ correct_result <- c(5.00, 10.71, 10.71, 10.71, 10.71, 10.71, 10.71, 10.00, 10.71 10.71, 10.71, 10.71, 10.71, 10.71, 10.71, 10.71, 10.71, 10.71, 10.71, 10.71, 10.71, 10.71, 10.71, 10.71, 10.71, 10.71, 10.71, 10.71, 10.71, 10.71, 10.71, 10.71, 10.71, 10.71, 10.71, 10.71, 10.71, 10.71, 10.71, - 10.71, 10.71, 10.71, 10.71, 10.71) + 10.71, 10.71, 10.71, 10.71, 8.00) expect_equal(standardize_columns(data = PJStest, property = "colwidths_Excel"), correct_result) @@ -143,7 +143,7 @@ correct_result <- c(5.00, 10.71, 10.71, 10.71, 10.71, 10.71, 10.71, 10.00, 10.71 10.71, 10.71, 10.71, 10.71, 10.71, 10.71, 10.71, 10.71, 10.71, 10.71, 10.71, 10.71, 10.71, 10.71, 10.71, 10.71, 10.71, 10.71, 10.71, 10.71, 8.00, 10.00, 10.71, 10.71, 10.71, 10.71, 10.71, 10.71, 10.71, 10.71, - 10.71, 10.71, 10.71, 30.00, 10.71) + 10.71, 10.71, 10.71, 30.00, 8.00) expect_equal(standardize_columns(data = PJStest, property = "colwidths_Excel"), correct_result) @@ -161,7 +161,7 @@ correct_result <- c(5.00, 10.71, 10.71, 10.71, 10.71, 10.71, 10.71, 10.00, 10.71 10.71, 10.71, 10.71, 10.71, 10.71, 10.71, 10.71, 10.71, 10.71, 10.71, 10.71, 10.71, 10.71, 10.71, 10.71, 10.71, 10.71, 10.71, 10.71, 10.71, 8.00, 10.00, 10.71, 10.71, 10.71, 10.71, 10.71, 10.71, 10.71, 10.71, - 10.71, 10.71, 10.71, 30.00, 10.71) + 10.71, 10.71, 10.71, 30.00, 8.00) expect_equal(standardize_columns(data = PJStest, property = "colwidths_Excel"), correct_result) diff --git a/tests/testthat/test_transform_code_combinations.R b/tests/testthat/test_transform_code_combinations.R new file mode 100644 index 0000000..492099e --- /dev/null +++ b/tests/testthat/test_transform_code_combinations.R @@ -0,0 +1,83 @@ +library(NVIdb) +library(testthat) + +test_that("transform code combinations, from 2 columns to 2 columns", { + # A code combination of two is tranformed to another code combination of two in the original columns + data <- as.data.frame(cbind(c("Detected", "Detected", "Not detected", NA), + c("M. bovis", "M. kansasii", "M. bovis", NA))) + colnames(data) <- c("kjennelse", "analytt") + + data <- transform_code_combinations(data = data, + from_values = list("kjennelse" = c("Detected"), + "analytt" = c("M. kansasii")), + to_values = list("kjennelse" = c("Not detected"), + "analytt" = c("M. bovis")), + impute_when_missing_from = c("kjennelse", "analytt")) + + correct_result <- as.data.frame(cbind(c("Detected", "Not detected", "Not detected", NA), + c("M. bovis", "M. bovis", "M. bovis", NA))) + colnames(correct_result) <- c("kjennelse", "analytt") + expect_identical(data, correct_result) + + # A code combination of two is transformed to another code combination of two into new columns + data <- as.data.frame(cbind(c("Detected", "Detected", "Not detected", NA), + c("M. bovis", "M. kansasii", "M. bovis", NA))) + colnames(data) <- c("kjennelse", "analytt") + + correct_result <- as.data.frame(cbind(data, + c("Detected", "Not detected", "Not detected", NA), + c("M. bovis", "M. bovis", "M. bovis", NA))) + colnames(correct_result) <- c("kjennelse", "analytt", "kjennelse2", "analytt2") + + data <- transform_code_combinations(data = data, + from_values = list("kjennelse" = c("Detected"), + "analytt" = c("M. kansasii")), + to_values = list("kjennelse2" = c("Not detected"), + "analytt2" = c("M. bovis")), + impute_when_missing_from = c("kjennelse", "analytt")) + + expect_identical(data, correct_result) +}) + +test_that("transform_code_combinations: two variables to one", { + + # two code values to one new variable + data <- as.data.frame(cbind(c("hjort", "rein", "rein", "elg", "hjort", "rein", "rein", NA), + c("produksjonsdyr", "ville dyr", "produksjonsdyr", "ville dyr", + "ville dyr", "produksjonsdyr", "ville dyr", NA))) + colnames(data) <- c("art", "driftsform") + + correct_result <- cbind(data, + c("oppdrettshjort", "villrein", "tamrein", "elg", "hjort", "tamrein", "villrein", "ukjent")) + colnames(correct_result) <- c("art", "driftsform", "art2") + + data <- transform_code_combinations(data = data, + from_values = list("art" = c("hjort", "rein", "rein", NA), + "driftsform" = c("produksjonsdyr", "ville dyr", "produksjonsdyr", NA)), + to_values = list("art2" = c("oppdrettshjort", "villrein", "tamrein", "ukjent")), + impute_when_missing_from = "art") + + expect_identical(data, correct_result) +}) +# + +test_that("transform_code_combinations: one variable to three", { + + data <- as.data.frame(c("fixed organs", "fresh bulk milk", "blood sample", NA)) + colnames(data) <- c("material") + + correct_result <- cbind(data, + c("organs", "milk", "blood", NA), + c("single sample", "bulk milk", "single sample", NA), + c("fixed", "fresh", "fresh", NA)) + colnames(correct_result) <- c("material", "material_type", "sample_type", "preparation") + + data <- transform_code_combinations(data = data, + from_values = list("material" = c("fixed organs", "fresh bulk milk", "blood sample", NA)), + to_values = list("material_type" = c("organs", "milk", "blood", NA), + "sample_type" = c("single sample", "bulk milk", "single sample", NA), + "preparation" = c("fixed", "fresh", "fresh", NA)), + impute_when_missing_from = "material") + + expect_identical(data, correct_result) +}) diff --git a/vignettes/Contribute_to_NVIdb.Rmd b/vignettes/Contribute_to_NVIdb.Rmd index ae4f1af..09cf489 100644 --- a/vignettes/Contribute_to_NVIdb.Rmd +++ b/vignettes/Contribute_to_NVIdb.Rmd @@ -1,6 +1,7 @@ --- output: rmarkdown::html_vignette: + css: "NVI_vignette_style.css" keep_md: true md_document: variant: markdown_github @@ -79,8 +80,7 @@ Care to fix bugs or implement new functionality for our_package? Great! Have a l ## Development guidelines -If you want to contribute code, you are welcome to do so. Please try to adhere -to some principles and style convention used for `NVIverse`-packages. +If you want to contribute code, you are welcome to do so. You will find a description of the code conventions, which have been used, in the vignette "NVIverse code conventions" in the package `NVIpackager`. A summary of the principles and style convention used for `NVIverse`-packages is given below. * Please limit the number of package dependencies for `r NVIpkg_inline`. The use of base functions is much appreciated. diff --git a/vignettes/NVI_vignette_style.css b/vignettes/NVI_vignette_style.css new file mode 100644 index 0000000..d600561 --- /dev/null +++ b/vignettes/NVI_vignette_style.css @@ -0,0 +1,11 @@ +h1, h2, h3, h4 { + color: #1b314f; + font-family: "Open Sans", "Helvetica Neue", Helvetica, Arial, sans-serif; +} +body { + color: #1b314f; + font-family: "source-serif-pro", "merriweather", serif; +} +thead { + font-family: "Open Sans", "Helvetica Neue", Helvetica, Arial, sans-serif; +} diff --git a/vignettes/NVIdb.pdf b/vignettes/NVIdb.pdf index 8f8935e..be18bed 100644 Binary files a/vignettes/NVIdb.pdf and b/vignettes/NVIdb.pdf differ diff --git a/vignettes/Retrieve_and_standardise_PJS-data.Rmd b/vignettes/Retrieve_and_standardise_PJS-data.Rmd index 7d83555..ec83bfd 100644 --- a/vignettes/Retrieve_and_standardise_PJS-data.Rmd +++ b/vignettes/Retrieve_and_standardise_PJS-data.Rmd @@ -1,6 +1,9 @@ --- title: "Retrieve and standardise PJS-data" -output: rmarkdown::html_vignette +output: + rmarkdown::html_vignette: + css: "NVI_vignette_style.css" + vignette: > %\VignetteEngine{knitr::rmarkdown} %\VignetteIndexEntry{Retrieve and standardise PJS-data}