diff --git a/.lintr b/.lintr index ea53ac8..1ad552f 100644 --- a/.lintr +++ b/.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") diff --git a/R/calc.stError.R b/R/calc.stError.R index 90a7256..e9877b7 100644 --- a/R/calc.stError.R +++ b/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, diff --git a/R/computeFrac.R b/R/computeFrac.R index d01e36d..9ff1a54 100644 --- a/R/computeFrac.R +++ b/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 } diff --git a/R/draw.bootstrap.R b/R/draw.bootstrap.R index 98c424b..7bc2bcf 100644 --- a/R/draw.bootstrap.R +++ b/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)) { diff --git a/R/generateHHID.R b/R/generateHHID.R index af46a5f..5791fce 100644 --- a/R/generateHHID.R +++ b/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 diff --git a/R/helpers.R b/R/helpers.R index 1fd917f..ae27468 100644 --- a/R/helpers.R +++ b/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) { diff --git a/R/ipf.r b/R/ipf.r index b9bf723..baaae96 100644 --- a/R/ipf.r +++ b/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)), diff --git a/R/plot.R b/R/plot.R index eada563..368eac3 100644 --- a/R/plot.R +++ b/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) { diff --git a/R/recalib.R b/R/recalib.R index 1d6a160..7a9ca78 100644 --- a/R/recalib.R +++ b/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") { diff --git a/R/rescaled.bootstrap.R b/R/rescaled.bootstrap.R index c03eb09..8fd3ddc 100644 --- a/R/rescaled.bootstrap.R +++ b/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) diff --git a/man/calc.stError.Rd b/man/calc.stError.Rd index 602b375..0bf971b 100644 --- a/man/calc.stError.Rd +++ b/man/calc.stError.Rd @@ -289,7 +289,7 @@ err.est <- calc.stError( 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") @@ -309,7 +309,7 @@ all((compare.value$V1-err.est$Estimates$val_povertyRisk)==0) 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) } @@ -328,7 +328,7 @@ err.est$Estimates # 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)) @@ -348,7 +348,7 @@ err.est$Estimates # 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 diff --git a/man/draw.bootstrap.Rd b/man/draw.bootstrap.Rd index 2918f24..bf3995c 100644 --- a/man/draw.bootstrap.Rd +++ b/man/draw.bootstrap.Rd @@ -184,7 +184,7 @@ eusilc[, pidsplit := pid] 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) diff --git a/man/generate.HHID.Rd b/man/generate.HHID.Rd index b78f45c..9c9c8f6 100644 --- a/man/generate.HHID.Rd +++ b/man/generate.HHID.Rd @@ -48,7 +48,7 @@ eusilc[,rb030split:=rb030] 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, diff --git a/man/ipf.Rd b/man/ipf.Rd index 79b2108..08077c0 100644 --- a/man/ipf.Rd +++ b/man/ipf.Rd @@ -128,7 +128,9 @@ individual level constraints. } \details{ This function implements the weighting procedure described -\href{http://www.ajs.or.at/index.php/ajs/article/viewFile/doi10.17713ajs.v45i3.120/512}{here}. Usage examples can be found in the corresponding vignette (\code{vignette("ipf")}) +\href{https://doi.org/10.17713/ajs.v45i3.120}{here}. +Usage examples can be found in the corresponding vignette +(\code{vignette("ipf")}). \code{conP} and \code{conH} are contingency tables, which can be created with \code{xtabs}. The \code{dimnames} of those tables should match the names and levels of the