Merge pull request #67 from 0UmfHxcvx5J7JoaOhFSs5mncnisTJJ6q/fix/prop…

…er_linters set package linters
pik-piam · Aug 9, 2023 · 4f53306 · 4f53306
2 parents 3f21ab7 + 25d91cf
commit 4f53306
Show file tree

Hide file tree

Showing 44 changed files with 375 additions and 175 deletions.
diff --git a/.buildlibrary b/.buildlibrary
@@ -1,4 +1,4 @@
-ValidationKey: '609772800'
+ValidationKey: '610998170'
 AcceptedWarnings:
 - 'Warning: package ''.*'' was built under R version'
 - 'Warning: namespace ''.*'' is not available and has been replaced'

diff --git a/.lintr b/.lintr
@@ -1,2 +1,55 @@
-linters: lucode2::lintrRules()
+linters: list(
+    any_duplicated_linter(),
+    any_is_na_linter(),
+    backport_linter(),
+    boolean_arithmetic_linter(),
+    class_equals_linter(),
+    condition_message_linter(),
+    conjunct_test_linter(),
+    consecutive_assertion_linter(),
+    duplicate_argument_linter(),
+    empty_assignment_linter(),
+    equals_na_linter(),
+    expect_comparison_linter(),
+    expect_identical_linter(),
+    expect_length_linter(),
+    expect_named_linter(),
+    expect_not_linter(),
+    expect_null_linter(),
+    expect_s3_class_linter(),
+    expect_s4_class_linter(),
+    expect_true_false_linter(),
+    expect_type_linter(),
+    for_loop_index_linter(),
+    function_return_linter(),
+    ifelse_censor_linter(),
+    inner_combine_linter(),
+    is_numeric_linter(),
+    lengths_linter(),
+    literal_coercion_linter(),
+    matrix_apply_linter(),
+    missing_package_linter(),
+    namespace_linter(),
+    numeric_leading_zero_linter(),
+    object_usage_linter(),
+    outer_negation_linter(),
+    package_hooks_linter(),
+    pipe_call_linter(),
+    redundant_equals_linter(),
+    redundant_ifelse_linter(),
+    regex_subset_linter(),
+    routine_registration_linter(),
+    semicolon_linter(),
+    seq_linter(),
+    sort_linter(),
+    sprintf_linter(),
+    strings_as_factors_linter(),
+    system_file_linter(),
+    undesirable_operator_linter(),
+    unnecessary_lambda_linter(),
+    unnecessary_nested_if_linter(),
+    unnecessary_placeholder_linter(),
+    unreachable_code_linter(),
+    unused_import_linter(),
+    vector_logic_linter())
 encoding: "UTF-8"
diff --git a/CITATION.cff b/CITATION.cff
@@ -2,8 +2,8 @@ cff-version: 1.2.0
 message: If you use this software, please cite it using the metadata from this file.
 type: software
 title: 'quitte: Bits and pieces of code to use with quitte-style data frames'
-version: 0.3120.0
-date-released: '2023-07-06'
+version: 0.3121.0
+date-released: '2023-08-08'
 abstract: A collection of functions for easily dealing with quitte-style data frames,
   doing multi-model comparisons and plots.
 authors:

diff --git a/DESCRIPTION b/DESCRIPTION
@@ -1,8 +1,8 @@
 Type: Package
 Package: quitte
 Title: Bits and pieces of code to use with quitte-style data frames
-Version: 0.3120.0
-Date: 2023-07-06
+Version: 0.3121.0
+Date: 2023-08-08
 Authors@R: c(
     person("Michaja", "Pehl", , "[email protected]", role = c("aut", "cre")),
     person("Nico", "Bauer", , "[email protected]", role = "aut"),

diff --git a/NAMESPACE b/NAMESPACE
@@ -112,9 +112,18 @@ importFrom(gms,chooseFromList)
 importFrom(grDevices,hcl)
 importFrom(lazyeval,f_eval)
 importFrom(lazyeval,interp)
+importFrom(lazyeval,lazy_dots)
+importFrom(lazyeval,lazy_eval)
+importFrom(lifecycle,deprecate_warn)
+importFrom(lubridate,is.POSIXct)
+importFrom(magclass,"getNames<-")
+importFrom(magclass,"getSets<-")
 importFrom(magclass,as.data.frame)
 importFrom(magclass,as.magpie)
+importFrom(magclass,clean_magpie)
 importFrom(magclass,getItems)
+importFrom(magclass,getNames)
+importFrom(magclass,getSets)
 importFrom(magrittr,"%>%")
 importFrom(plyr,revalue)
 importFrom(purrr,map)
@@ -124,6 +133,7 @@ importFrom(readr,read_lines)
 importFrom(readr,write_lines)
 importFrom(readxl,excel_sheets)
 importFrom(readxl,read_excel)
+importFrom(reshape2,dcast)
 importFrom(reshape2,melt)
 importFrom(rlang,"!!!")
 importFrom(rlang,"!!")
@@ -134,8 +144,10 @@ importFrom(rlang,is_empty)
 importFrom(rlang,is_false)
 importFrom(rlang,sym)
 importFrom(rlang,syms)
+importFrom(stats,as.formula)
 importFrom(stats,formula)
 importFrom(stats,na.omit)
+importFrom(stats,quantile)
 importFrom(stats,setNames)
 importFrom(stats,spline)
 importFrom(stringr,str_to_title)

diff --git a/R/add_countrycode.R b/R/add_countrycode.R
@@ -20,6 +20,8 @@
 #' @author Michaja Pehl
 #'
 #' @importFrom countrycode countrycode
+#' @importFrom lazyeval lazy_dots
+#' @importFrom stats setNames
 #'
 #' @examples
 #' library(dplyr)
@@ -33,7 +35,7 @@
 
 #' @export
 add_countrycode <- function(data, ..., warn = TRUE, na.rm = FALSE) {
-    dots <- lazyeval::lazy_dots(...)
+    dots <- lazy_dots(...)
 
     source.type   <- as.character(dots[[1]]$expr)
     source.column <- ifelse('' == names(dots[1]), source.type, names(dots[1]))
@@ -43,8 +45,8 @@ add_countrycode <- function(data, ..., warn = TRUE, na.rm = FALSE) {
                                  names(dots[2]))
 
     add_countrycode_(data,
-                     stats::setNames(source.type, source.column),
-                     stats::setNames(destination.type, destination.column),
+                     setNames(source.type, source.column),
+                     setNames(destination.type, destination.column),
                      warn = warn, na.rm = na.rm)
 }
 
@@ -53,11 +55,11 @@ add_countrycode <- function(data, ..., warn = TRUE, na.rm = FALSE) {
 add_countrycode_ <- function(data, origin, destination, warn = TRUE,
                              na.rm = FALSE) {
 
-    source.type        <- stats::setNames(origin, NULL)
+    source.type        <- setNames(origin, NULL)
     source.column      <- ifelse(is.null(names(origin)), source.type,
                                  names(origin))
 
-    destination.type   <- stats::setNames(destination, NULL)
+    destination.type   <- setNames(destination, NULL)
     destination.column <- ifelse(is.null(names(destination)), destination.type,
                                  names(destination))
 

diff --git a/R/aggregate_map.R b/R/aggregate_map.R
@@ -218,7 +218,7 @@ aggregate_map <- function(data,
   diff_map_data = setdiff(items_map, items_data)
   diff_data_map = setdiff(items_data, items_map)
 
-  if(length(diff_map_data) > 0 | length(diff_data_map) >0 ){
+  if (length(diff_map_data) > 0 || length(diff_data_map) > 0) {
 
     message_mismatch = paste0("the number of regions/variables does not correspond: \n",
                               "these regions/variables are in the mapping but not in data : ",paste(diff_map_data, collapse = " "), "\n",

diff --git a/R/as.quitte.R b/R/as.quitte.R
@@ -17,8 +17,10 @@
 #' @param na.rm if set to TRUE entries with value NA will be removed
 #' @author Jan Philipp Dietrich
 #' @keywords classes
-#' @importFrom reshape2 melt
 #' @importFrom forcats fct_na_value_to_level
+#' @importFrom magclass clean_magpie getNames getNames<- getSets getSets<-
+#' @importFrom reshape2 melt
+#' @importFrom stats setNames
 #' @importFrom tibble as_tibble
 #'
 #' @export
@@ -71,7 +73,8 @@ as.quitte.data.frame <- function(x, periodClass = "integer", addNA = FALSE, na.r
     colnames(x)[colnames(x) == paste0("data", 2)] <- "model"
     colnames(x)[colnames(x) == paste0("data", 3)] <- "variable"
 
-    if (!("value" %in% colnames(x)) & any(!is.na(suppressWarnings(as.integer(colnames(x)))))) {
+    if (   !"value" %in% colnames(x)
+        && !all(is.na(suppressWarnings(as.integer(colnames(x)))))) {
       x <- suppressMessages(melt(x))
       colnames(x)[which(colnames(x) == "value") - 1] <- "period"
     }
@@ -91,14 +94,14 @@ as.quitte.data.frame <- function(x, periodClass = "integer", addNA = FALSE, na.r
         if (!("unit"     %in% colnames(x)))
             x <- cbind(x, unit = fct_na_value_to_level(factor(NA),
                                                        level = '(Missing)'))
-        if (periodClass == "POSIXct")
-            if (!("period"   %in% colnames(x)))
-                x <- cbind(x, period = as.POSIXct(NA))
-        if (periodClass == "integer")
-            if (!("period" %in% colnames(x)))
-                  x <- cbind(x, period = as.integer(NA))
-        if (!("value"    %in% colnames(x)))
-              stop("Data frame cannot be converted. A column \"value\" has to be provided!")
+        if (periodClass == "POSIXct" && !"period" %in% colnames(x))
+            x <- cbind(x, period = as.POSIXct(NA))
+
+        if (periodClass == "integer" && !"period" %in% colnames(x))
+            x <- cbind(x, period = NA_integer_)
+
+        if (!"value" %in% colnames(x))
+            stop("Data frame cannot be converted. A column \"value\" has to be provided!")
     }
     factorCheck <- sapply(x[, factorColumns], is.factor) # nolint
     if (!all(factorCheck)) {
@@ -111,10 +114,10 @@ as.quitte.data.frame <- function(x, periodClass = "integer", addNA = FALSE, na.r
 
     if (periodClass == "integer")
         x$period <- as.integer(x$period)
-    if (periodClass == "POSIXct") {
-        if (!("POSIXct" %in% attr(x$period, "class")))
-            x$period <- ISOyear(x$period)
-    }
+
+    if (periodClass == "POSIXct" && !("POSIXct" %in% attr(x$period, "class")))
+        x$period <- ISOyear(x$period)
+
     if (!is.numeric(x$value))
         stop("Value column must contain numeric data!")
 
@@ -141,20 +144,17 @@ as.quitte.magpie <- function(x, periodClass = "integer", addNA = FALSE, na.rm =
     if (!(periodClass %in% c("integer", "POSIXct")))
       stop("periodClass must be in c('integer', 'POSIXct')")
 
-    x <- magclass::clean_magpie(x, what = "sets")
-    if (magclass::getSets(x, fulldim = FALSE)[3] == "d3") {
-      magclass::getSets(x, fulldim = FALSE)[3] <- "variable"
-    }
-    if (!("unit" %in% magclass::getSets(x))        &
- ("variable" %in% magclass::getSets(x))) {
-      if (all(grepl(" \\(.*\\)$",
-                    magclass::getNames(x, fulldim = TRUE)$variable))) {
-        magclass::getNames(x) <- sub(" \\(([^\\()]*)\\)($|\\.)", ".\\1\\2",
-                                     magclass::getNames(x))
-        magclass::getSets(x, fulldim = FALSE)[3] <-
-          sub("variable", "variable.unit",
-              magclass::getSets(x, fulldim = FALSE)[3])
-      }
+    x <- clean_magpie(x, what = "sets")
+    if (getSets(x, fulldim = FALSE)[3] == "d3")
+      getSets(x, fulldim = FALSE)[3] <- "variable"
+
+    if (   !"unit" %in% getSets(x)
+        && "variable" %in% getSets(x)
+        && all(grepl(" \\(.*\\)$", getNames(x, fulldim = TRUE)$variable))
+        ) {
+        getNames(x) <- sub(" \\(([^\\()]*)\\)($|\\.)", ".\\1\\2", getNames(x))
+        getSets(x, fulldim = FALSE)[3] <- sub("variable", "variable.unit",
+                                              getSets(x, fulldim = FALSE)[3])
     }
 
     d <- dimnames(x)
@@ -166,7 +166,7 @@ as.quitte.magpie <- function(x, periodClass = "integer", addNA = FALSE, na.rm =
       datanames <- NULL
     }
 
-    x <- magclass::as.data.frame(x)
+    x <- as.data.frame(x)
 
     if (all(is.na(x$Cell)))
       x$Cell <- NULL # nolint
@@ -175,8 +175,7 @@ as.quitte.magpie <- function(x, periodClass = "integer", addNA = FALSE, na.rm =
       for (i in seq_along(datanames))
         colnames(x)[colnames(x) == paste0("Data", i)] <- datanames[i]
     } else {
-      if ("Data1" %in% colnames(x))
-        if (all(levels(x$Data1) == "NA"))
+      if ("Data1" %in% colnames(x) && all(levels(x$Data1) == "NA"))
           x$Data1 <- NULL # nolint
     }
 
@@ -206,7 +205,7 @@ as.quitte.magpie <- function(x, periodClass = "integer", addNA = FALSE, na.rm =
     if (length(missingColumns) > 0) {
       x <- data.frame(
         x,
-        stats::setNames(
+        setNames(
           as.list(rep(fct_na_value_to_level(factor(NA), level = '(Missing)'),
                       length(missingColumns))),
           missingColumns)

diff --git a/R/calcAddVariable.R b/R/calcAddVariable.R
@@ -36,10 +36,12 @@
 #'
 #' @author Anselm Schultes, Michaja Pehl
 #'
+#' @importFrom stats as.formula setNames
+#'
 #' @export
 calcAddVariable <- function(data, formula, newUnit = "None", na.act = "no") {
 
-    formula <- stats::as.formula(formula)
+    formula <- as.formula(formula)
     .dots <- list(c(as.character(formula[3]), newUnit))
     names(.dots) <- as.character(formula[2])
 

diff --git a/R/calcCumulatedDiscount.R b/R/calcCumulatedDiscount.R
@@ -21,6 +21,8 @@
 #'     erg <- calcCumulatedDiscount(data, disRate=0.03)
 #'   }
 #'
+#' @importFrom reshape2 dcast
+#'
 #' @export
 calcCumulatedDiscount = function(data,
                                  nameVar='Consumption',
@@ -42,7 +44,7 @@ calcCumulatedDiscount = function(data,
   }
   data=data[,!(names(data) == 'unit')]
   #convert to wide format
-  data = reshape2::dcast(data,... ~ variable)
+  data = dcast(data,... ~ variable)
   #rename variable
   names(data)[names(data) == nameVar] = 'varToAggregate'
 
@@ -72,17 +74,17 @@ calcCumulatedDiscount = function(data,
     mutate(
       weight1 = mapply(
         function(dt,dr) {
-          sum( (1+dr)^(-seq(as.double(0.5),as.double(dt-0.5)) )
-             * (1 - seq(as.double(0.5),as.double(dt-0.5))/dt)
+          sum( (1+dr)^(-seq(0.5, as.double(dt-0.5)) )
+             * (1 - seq(0.5, as.double(dt-0.5))/dt)
               )
           },   # Why no use (1:dt) instead??
         (!!sym('year') - lag(!!sym('year'), default = first(!!sym('year')), order_by = !!sym('year'))),  # first element in year here doesnt matter anyways, will be thrown out later on..
         !!sym('disRate')
       ),
     weight2 = mapply(
       function(dt,dr) {
-        sum( (1+dr)^(-(seq(as.double(0.5),as.double(dt-0.5)) - dt))
-           * (seq(as.double(0.5),as.double(dt-0.5))/dt)
+        sum( (1+dr)^(-(seq(0.5, as.double(dt-0.5)) - dt))
+           * (seq(0.5, as.double(dt-0.5))/dt)
            )
          },
       (!!sym('year') - lag(!!sym('year'), default = first(!!sym('year')), order_by = !!sym('year'))),

diff --git a/R/calcDecompEff.R b/R/calcDecompEff.R
@@ -83,11 +83,17 @@
 calcDecompEff <- function(df, x, bau=NULL, pol=NULL, gap = "policy"){
 
   #--- Initial Checks
-  if (gap == "policy" & (is.null(bau) | is.null(pol))) stop("please provide bau and pol, if you want the differences in the policies")
-  if (gap == "time" & !(is.null(bau) & is.null(pol))) warning("differentiating by time. Change gap to 'policy' if you want the differences in the policies")
-  if (length(x[names(x) == "explained"]) != 1) stop("the explained variable has to be named 'explained in the x vector'")
+  if (gap == "policy" && (is.null(bau) || is.null(pol)))
+      stop("please provide bau and pol, if you want the differences in the policies")
 
-  if (!(gap %in% c("time", "policy") )) stop("gap is either time or policy")
+  if (gap == "time" && !(is.null(bau) && is.null(pol)))
+      warning("differentiating by time. Change gap to 'policy' if you want the differences in the policies")
+
+  if (length(x[names(x) == "explained"]) != 1)
+      stop("the explained variable has to be named 'explained in the x vector'")
+
+  if (!(gap %in% c("time", "policy") ))
+      stop("gap is either time or policy")
 
   #--- Internal Functions
 
@@ -176,7 +182,7 @@ calcDecompEff <- function(df, x, bau=NULL, pol=NULL, gap = "policy"){
 
   #replace variable names and scenario names by placeholders
   kaya$variable = factor(kaya$variable)
-  namesVar_in = letters[1:length(explanatory)]
+  namesVar_in = letters[seq_along(explanatory)]
   names(namesVar_in) = explanatory
 
   kaya = levels2letters(kaya,namesVar_in,explanatory)
@@ -256,8 +262,8 @@ calcDecompEff_scen <- function(df, x, bau){
 
   scens = setdiff(getScenarios(df), bau)
 
-  tmp = do.call(rbind,
-                lapply(scens, function(scen){
-                  tmp_kaya = calcDecompEff(df,x,bau = bau,pol = scen)
-                }))
+  do.call(rbind,
+          lapply(scens, function(scen){
+            calcDecompEff(df,x,bau = bau,pol = scen)
+          }))
 }