resolve linters (cont.)

* diagnose the apckage with the new version of
  lintr
* Adapt .lintr so certain linters are ignored

.lintr

@@ -1,4 +1,6 @@
 linters: with_defaults(
   object_name_linter = NULL,
-  commented_code_linter = NULL)
+  commented_code_linter = NULL,
+  cyclocomp_linter = NULL,
+  object_length_linter = NULL)
 exclusions: list("R/RcppExports.R")

R/calc.stError.R

@@ -250,7 +250,7 @@
 #' err.est$Estimates
 #'
 #' # use add.arg-argument
-#' fun <- function(x,w,b){
+#' fun <- function(x, w, b) {
 #'   sum(x*w*b)
 #' }
 #' add.arg = list(b="onePerson")
@@ -270,7 +270,7 @@
 #' library(laeken)
 #'
 #' ## set up help function that returns only the gini index
-#' help_gini <- function(x, w){
+#' help_gini <- function(x, w) {
 #'  return(gini(x, w)$value)
 #' }
 #'
@@ -289,7 +289,7 @@
 #'
 #' # this function estimates the povmd60 indicator with x as income vector
 #' # and w as weight vector
-#' povmd <- function(x, w){
+#' povmd <- function(x, w) {
 #'  md <- laeken::weightedMedian(x, w)*0.6
 #'  pmd60 <- x < md
 #'  return(as.integer(pmd60))
@@ -309,7 +309,7 @@
 #' # and set fun.adjust.var=NULL,adjust.var=NULL
 #' # and set fun = povmd, var = "eqIncome"
 #'
-#' povmd2 <- function(x, w){
+#' povmd2 <- function(x, w) {
 #'  md <- laeken::weightedMedian(x, w)*0.6
 #'  pmd60 <- x < md
 #'  # weighted ratio is directly estimated inside my function
@@ -422,7 +422,7 @@ calc.stError <- function(
            " not argument(s) of supplied function.")
     }
 
-    if (any(!unlist(add.arg) %in% c.names)){
+    if (any(!unlist(add.arg) %in% c.names)) {
       notInData <- unlist(add.arg)
       notInData <- notInData[!notInData %in% c.names]
       stop(paste(notInData, collapse = " "), " not in column names of dat.")
@@ -538,7 +538,7 @@ calc.stError <- function(
     period.diff <- strsplit(period.diff, "-")
 
     rm.index <- rep(0, length(period.diff))
-    for (i in 1:length(period.diff)) {
+    for (i in seq_len(period.diff)) {
       if (any(!period.diff[[i]] %in% periods.dat)) {
         warning("Removing ", paste(period.diff[[i]], collapse = "-"),
                 " from period.diff - period(s) not present in column ",
@@ -692,7 +692,7 @@ help.stError <- function(
     fun_original <- fun # nolint
     fun <- dt.eval(
       "function(", paste0(formalArgs(fun), collapse = ","),
-      ",national.arg){fun_original(x,w,add.arg)/national.arg*100}")
+      ",national.arg) {fun_original(x,w,add.arg)/national.arg*100}")
   }
 
   # define names for estimates for each weight (normal weights and boostrap
@@ -708,7 +708,7 @@ help.stError <- function(
     dt.eval("dat[,", varnew, ":=.(", eval.fun.adjust, "),by=list(",
             period, ")]")
 
-    res.names <- c(t(outer(var, 1:length(c(weights, b.weights)), paste_)))
+    res.names <- c(t(outer(var, seq_len(c(weights, b.weights)), paste_)))
 
     varnew <- c(var, paste0(var, ".", 2:(length(b.weights) + 1)))
 
@@ -721,7 +721,7 @@ help.stError <- function(
     }
   } else {
 
-    res.names <- c(t(outer(var, 1:length(c(weights, b.weights)), paste_)))
+    res.names <- c(t(outer(var, seq_len(c(weights, b.weights)), paste_)))
     if (national) {
       eval.fun <- paste0(res.names, "=fun(", paste(c(t(outer(
         var, c(weights, b.weights), paste_c
@@ -848,7 +848,7 @@ help.stError <- function(
       roll.miss <- unique(dt.eval("dat[", na.eval, ",list(", by.eval, ")]"))
       roll.miss <- lapply(
         roll.miss,
-        function(l){
+        function(l) {
           unique(na.omit(l))
         }
       )
@@ -949,7 +949,7 @@ help.stError <- function(
         diff.mean.est[, est_type := "diff_mean"]
 
         # calcualte N and n for groups and diff
-        diff.roll.Nn <- lapply(period.diff.mean, function(y){
+        diff.roll.Nn <- lapply(period.diff.mean, function(y) {
           y_cond <- paste(period, paste0("c(", paste(unlist(y), collapse = ","),
                                          ")"), sep = "%in%")
           diff.y <- dt.eval("var.est[ID==1&est==var[1]&", y_cond,

R/computeFrac.R

@@ -42,6 +42,6 @@
 #'
 #' @aliases numericalWeighting
 #' @export computeFrac
-computeFrac <- function(curValue, target, x, w){
+computeFrac <- function(curValue, target, x, w) {
   target / curValue
 }

R/draw.bootstrap.R

@@ -152,7 +152,7 @@
 #' year <- eusilc[, unique(year)]
 #' year <- year[-1]
 #' leaf_out <- c()
-#' for(y in year){
+#' for(y in year) {
 #'   split.person <- eusilc[
 #'     year == (y-1) & !duplicated(hid) & !(hid %in% leaf_out),
 #'     sample(pid, 20)
@@ -288,7 +288,7 @@ draw.bootstrap <- function(
   spec.variables <- c(hid, weights, period, strata, cluster, totals, pid)
   spec.variables <- spec.variables[!spec.variables %in% c("1", "I")]
   dat.na <- dat[, mget(spec.variables)]
-  dat.na <- sapply(dat.na, function(z){
+  dat.na <- sapply(dat.na, function(z) {
     any(is.na(z))
   })
   if (any(dat.na)) {

R/generateHHID.R

@@ -37,7 +37,7 @@
 #' year <- eusilc[,unique(year)]
 #' year <- year[-1]
 #' leaf_out <- c()
-#' for(y in year){
+#' for(y in year) {
 #'   split.person <- eusilc[year==(y-1)&!duplicated(db030)&!db030%in%leaf_out,
 #'                          sample(rb030,20)]
 #'   overwrite.person <- eusilc[year==(y)&!duplicated(db030)&!db030%in%leaf_out,
@@ -64,7 +64,7 @@
 #'
 
 
-generate.HHID <- function(dat, period = "RB010", pid = "RB030", hid = "DB030"){
+generate.HHID <- function(dat, period = "RB010", pid = "RB030", hid = "DB030") {
 
   ID_new <- ID_orig <- ALL_NEW <- ID_new_help <- NULL
 

R/helpers.R

@@ -20,7 +20,7 @@ dt.eval <- function(..., env = parent.frame()) {
   if (length(expressions) > 1) {
     return(lapply(
       expressions,
-      function(z){
+      function(z) {
         eval(parse(text = z), envir = env)
       }
     ))
@@ -36,7 +36,7 @@ dt.eval2 <- function(...) {
 getEllipsis <- function(element, default, ell) {
   ifelse(is.null(ell[[element]]), default, ell[[element]])
 }
-getEllipsis2 <- function(element, default, ell){
+getEllipsis2 <- function(element, default, ell) {
 
   if (is.null(ell[[element]])) {
     return(default)
@@ -46,7 +46,7 @@ getEllipsis2 <- function(element, default, ell){
 }
 
 # helpfunction to create contingency tables
-makeCalibTable <- function(dat, weights, period, vars){
+makeCalibTable <- function(dat, weights, period, vars) {
   # make contingency table
   formTab <- paste(weights, "~", paste(c(period, vars), collapse = "+"))
   varsTab <- xtabs(formTab, data = dat)
@@ -84,7 +84,7 @@ povmd <- function(x, w) {
 }
 
 # helpfunction for quantile calcultion with missings
-quantileNA <- function(x, probs, p.names, np = length(probs)){
+quantileNA <- function(x, probs, p.names, np = length(probs)) {
 
   if (any(is.na(x))) {
     out <- rep(NA_real_, np)
@@ -95,7 +95,7 @@ quantileNA <- function(x, probs, p.names, np = length(probs)){
   return(out)
 }
 
-randomInsert <- function(x, y, n = 20){
+randomInsert <- function(x, y, n = 20) {
   if (length(x) < 20 | length(y) < 20) {
     stop("n must be smaller than length(x) and length(y)")
   }
@@ -106,7 +106,7 @@ randomInsert <- function(x, y, n = 20){
   return(x)
 }
 
-generateRandomName <- function(nchar = 20, existingNames){
+generateRandomName <- function(nchar = 20, existingNames) {
 
   newName <- paste(sample(c(letters, LETTERS), nchar), collapse = "")
   while (newName %in% existingNames) {

R/ipf.r

@@ -8,9 +8,9 @@
 combine_factors <- function(dat, targets) {
 
   x <- as.data.frame(targets)
-  x$ID_ipu <- 1:nrow(x)
+  x$ID_ipu <- seq_len(x)
   x <- merge(dat, x, by = names(dimnames(targets)), sort = FALSE, all.x = TRUE)
-  factor(x$ID_ipu, levels = 1:length(targets))
+  factor(x$ID_ipu, levels = seq_len(targets))
 }
 
 getMeanFun <- function(meanHH) {
@@ -21,7 +21,7 @@ getMeanFun <- function(meanHH) {
   meanfun <- switch(meanHH,
                     arithmetic = arithmetic_mean,
                     geometric = geometric_mean,
-                    none = function(x, w){
+                    none = function(x, w) {
                       x
                     }
   )
@@ -42,14 +42,14 @@ getMeanFun <- function(meanHH) {
 #' @examples
 #' kishFactor(rep(1,10))
 #' kishFactor(rlnorm(10))
-kishFactor <- function(w){
+kishFactor <- function(w) {
   if (!is.numeric(w)) {
     stop("The input must be a numeric vector")
   }
   n <- length(w)
   sqrt(n * sum(w ^ 2) / sum(w) ^ 2)
 }
-boundsFak <- function(g1, g0, f, bound = 4){
+boundsFak <- function(g1, g0, f, bound = 4) {
   # Berechnet die neuen Gewichte (innerhalb 4, .25 Veraenderungsraten)
   g1 <- g1 * f
   TF <- which((g1 / g0) > bound)
@@ -60,7 +60,7 @@ boundsFak <- function(g1, g0, f, bound = 4){
   g1[TF] <- (1 / bound) * g0[TF]
   return(g1)
 }
-boundsFakHH <- function(g1, g0, eps, orig, p, bound = 4){
+boundsFakHH <- function(g1, g0, eps, orig, p, bound = 4) {
   # Berechnet die neuen Gewichte fuer Unter- und Obergrenze (innerhalb 4,
   #   .25 Veraenderungsraten)
   u <- orig * (1 - eps)
@@ -333,7 +333,7 @@ addWeightsAndAttributes <- function(dat, conP, conH, epsP, epsH, dat_original,
   # add calibrated weights. Use setkey to make sure the indexes match
   setkey(dat, OriginalSortingVariable)
 
-  if ((maxIter < calIter) & returnNA){
+  if ((maxIter < calIter) & returnNA) {
     outTable[, c(variableKeepingTheCalibWeight) := NA]
   } else {
     outTable[, c(variableKeepingTheCalibWeight) :=
@@ -379,7 +379,9 @@ addWeightsAndAttributes <- function(dat, conP, conH, epsP, epsH, dat_original,
 #' individual level constraints.
 #'
 #' This function implements the weighting procedure described
-#' [here](http://www.ajs.or.at/index.php/ajs/article/viewFile/doi10.17713ajs.v45i3.120/512). Usage examples can be found in the corresponding vignette (`vignette("ipf")`)
+#' [here](https://doi.org/10.17713/ajs.v45i3.120).
+#' Usage examples can be found in the corresponding vignette
+#' (`vignette("ipf")`).
 #'
 #' `conP` and `conH` are contingency tables, which can be created with `xtabs`.
 #' The `dimnames` of those tables should match the names and levels of the
@@ -575,7 +577,7 @@ ipf <- function(
   if (is.null(hid)) {
     #delVars <- c("hid")
     hid <- "hid"
-    dat[, hid := as.factor(1:nrow(dat))]
+    dat[, hid := as.factor(seq_len(dat))]
     dat[, representativeHouseholdForCalibration := 1]
   } else {
     if (!is.factor(dat[[hid]]))
@@ -588,11 +590,11 @@ ipf <- function(
   pColNames <- lapply(conP, function(x) names(dimnames(x)))
   hColNames <- lapply(conH, function(x) names(dimnames(x)))
 
-  for (i in seq_along(conP)){
+  for (i in seq_along(conP)) {
     current_colnames <- pColNames[[i]]
 
-    for (colname in current_colnames){
-      if (!inherits(dat[[colname]], "factor")){
+    for (colname in current_colnames) {
+      if (!inherits(dat[[colname]], "factor")) {
         if (conversion_messages)
           message("converting column ", colname, " to factor")
         set(
@@ -660,7 +662,7 @@ ipf <- function(
   if (check_hh_vars) {
     ## Check for non-unqiue values inside of a household for variabels used
     ##   in Household constraints
-    for (hh in hColNames){
+    for (hh in hColNames) {
       for (h in hh) {
         setnames(dat, h, "temporary_hvar")
         if (dat[, length(unique(temporary_hvar)),

R/plot.R

@@ -395,7 +395,7 @@ plot.surveysd <- function(
 }
 
 
-define_type <- function(plot.x, x, variable = "HX080"){
+define_type <- function(plot.x, x, variable = "HX080") {
 
   SMALLGROUP <- res_type <- NULL
 
@@ -421,7 +421,7 @@ define_type <- function(plot.x, x, variable = "HX080"){
   return(plot.x)
 }
 
-convert_factors <- function(x){
+convert_factors <- function(x) {
   x <- x[, lapply(
     .SD,
     function(z) {

R/recalib.R

@@ -178,7 +178,7 @@ recalib <- function(
   ellipsis[["conversion_messages"]] <- getEllipsis2("conversion_messages",
                                                    FALSE, ellipsis)
   ellipsis[["verbose"]] <- getEllipsis2("verbose", TRUE, ellipsis)
-  ellipsis <- lapply(names(ipfDefaults), function(z){
+  ellipsis <- lapply(names(ipfDefaults), function(z) {
     getEllipsis2(z, ipfDefaults[[z]], ellipsis)
   })
   names(ellipsis) <- names(ipfDefaults)
@@ -191,11 +191,11 @@ recalib <- function(
   )))
 
   # check conP and conH
-  conPnames <- lapply(conP, function(z){
+  conPnames <- lapply(conP, function(z) {
     z <- names(dimnames(z))
     z[z != period]
   })
-  conHnames <- lapply(conH, function(z){
+  conHnames <- lapply(conH, function(z) {
     z <- names(dimnames(z))
     z[z != period]
   })
@@ -235,13 +235,13 @@ recalib <- function(
   vars <- c(period, unique(unlist(c(conP.var, conH.var, conPnames, conHnames))))
   vars.class <- unlist(lapply(dat[, mget(vars)], function(z) {
     z.class <- class(z)
-    if (z.class[1] == "labelled"){
+    if (z.class[1] == "labelled") {
       z.class <- "factor"
     }
     return(z.class)
   }))
   # convert to factor
-  for (i in 1:length(vars)) {
+  for (i in seq_len(vars)) {
     if (vars.class[[vars[i]]] != "factor") {
       dt.eval("dat[,", vars[i], ":=as.factor(", vars[i], ")]")
     }
@@ -332,7 +332,7 @@ recalib <- function(
       cat("Calibration failed for bootstrap replicates", calib.fail, "\n")
       cat("Corresponding bootstrap replicates will be discarded\n")
       lead.char <- sub("[[:digit:]].*", "", b.rep[1])
-      b.rep_new <- paste0(lead.char, 1:length(b.rep))
+      b.rep_new <- paste0(lead.char, seq_len(b.rep))
       setnames(dat, b.rep, b.rep_new)
       cat("Returning", length(b.rep), "calibrated bootstrap weights\n")
       b.rep <- b.rep_new
@@ -343,7 +343,7 @@ recalib <- function(
   dat[, c("hidfactor", "FirstPersonInHousehold_") := NULL]
 
   # recode vars back to either integer of character
-  for (i in 1:length(vars.class)) {
+  for (i in seq_len(vars.class)) {
     if (vars.class[i] %in% c("integer", "numeric")) {
       dt.eval("dat[,", vars[i], ":=as.numeric(as.character(", vars[i], "))]")
     } else if (vars.class[i] == "character") {

R/rescaled.bootstrap.R

@@ -426,7 +426,7 @@ select.nstar <- function(n, N, f, n_prev, n_draw_prev, lambda_prev,
   return(n_draw)
 }
 
-draw.without.replacement <- function(n, n_draw){
+draw.without.replacement <- function(n, n_draw) {
   delta <- rep(c(1.0, 0.0), c(n_draw, n - n_draw))
   if (length(delta) > 1) {
     delta <- sample(delta)