R/RcppExports.R

Defines functions sample_group csample_num tableC select_equal sumVec updateVecC updateMatC ipu_step_f ipu_step ipu_step_ref arithmetic_mean geometric_mean geometric_mean_reference computeLinearG1 computeLinear

Documented in arithmetic_mean computeLinear computeLinearG1 geometric_mean geometric_mean_reference ipu_step ipu_step ipu_step ipu_step_f ipu_step_ref

# Generated by using Rcpp::compileAttributes() -> do not edit by hand
# Generator token: 10BE3573-1514-4C36-9D1C-5A225CD40393

#' @rdname computeFrac
#' @export
computeLinear <- function(curValue, target, x, w, boundLinear = 10) {
    .Call('_simPop_computeLinear', PACKAGE = 'simPop', curValue, target, x, w, boundLinear)
}

#' @rdname computeFrac
#' @export
computeLinearG1 <- function(curValue, target, x, w, boundLinear = 10) {
    .Call('_simPop_computeLinearG1', PACKAGE = 'simPop', curValue, target, x, w, boundLinear)
}

#' Calculate mean by factors
#' 
#' These functions calculate the arithmetic and geometric mean of the weight for each class. `geometric_mean` and
#' `arithmetic_mean` return a `numeric` vector of the same length as `w` which stores the averaged weight for each 
#' observation. `geometric_mean_reference` returns the same value by reference, i.e. the input value `w` gets 
#' overwritten by the updated weights. See examples.
#' 
#' @md
#' @name cpp_mean
#' @param w An numeric vector. All entries should be positive.
#' @param classes A factor variable. Must have the same length as `w`.
#' @examples
#' 
#' ## create random data
#' nobs <- 10
#' classLabels <- letters[1:3]
#' dat = data.frame(
#'   weight = exp(rnorm(nobs)),
#'   household = factor(sample(classLabels, nobs, replace = TRUE))
#' )
#' dat
#' 
#' ## calculate weights with geometric_mean
#' geom_weight <- geometric_mean(dat$weight, dat$household)
#' cbind(dat, geom_weight)
#' 
#' ## calculate weights with arithmetic_mean
#' arith_weight <- arithmetic_mean(dat$weight, dat$household)
#' cbind(dat, arith_weight)
#' 
#' ## calculate weights "by reference"
#' geometric_mean_reference(dat$weight, dat$household)
#' dat
#' 
#' @rdname cpp_mean
#' @export
geometric_mean_reference <- function(w, classes) {
    invisible(.Call('_simPop_geometric_mean_reference', PACKAGE = 'simPop', w, classes))
}

#' @rdname cpp_mean
#' @export
geometric_mean <- function(w, classes) {
    .Call('_simPop_geometric_mean', PACKAGE = 'simPop', w, classes)
}

#' @rdname cpp_mean
#' @export
arithmetic_mean <- function(w, classes) {
    .Call('_simPop_arithmetic_mean', PACKAGE = 'simPop', w, classes)
}

#' Perform one step of iterative proportional updating
#' 
#' C++ routines to invoke a single iteration of the Iterative proportional updating (IPU) scheme. Targets and classes 
#' are assumed to be one dimensional in the `ipu_step` functions. `combine_factors` aggregates several vectors of 
#' type factor into a single one to allow multidimensional ipu-steps. See examples.
#' 
#' `ipu_step` returns the adjusted weights. `ipu_step_ref` does the same, but updates `w` by reference rather than 
#' returning. `ipu_step_f` returns a multiplicator: adjusted weights divided by unadjusted weights. `combine_factors` is
#' designed to make `ipu_step` work with contingency tables produced by [xtabs].
#' 
#' @md
#' @name ipu_step
#' @param w a numeric vector of weights. All entries should be positive.
#' @param classes a factor variable. Must have the same length as `w`.
#' @param targets key figure to target with the ipu scheme. A numeric verctor of the same length as `levels(classes)`. 
#' This can also be a `table` produced by `xtabs`. See examples.
#' @examples
#' 
#' ############# one-dimensional ipu ##############
#' 
#' ## create random data
#' nobs <- 10
#' classLabels <- letters[1:3]
#' dat = data.frame(
#'   weight = exp(rnorm(nobs)),
#'   household = factor(sample(classLabels, nobs, replace = TRUE))
#' )
#' dat
#' 
#' ## create targets (same lenght as classLabels!)
#' targets <- 3:5
#' 
#' ## calculate weights
#' new_weight <- ipu_step(dat$weight, dat$household, targets)
#' cbind(dat, new_weight)
#' 
#' ## check solution
#' xtabs(new_weight ~ dat$household)
#' 
#' ## calculate weights "by reference"
#' ipu_step_ref(dat$weight, dat$household, targets)
#' dat
#' 
#' ############# multidimensional ipu ##############
#' 
#' ## load data
#' factors <- c("time", "sex", "smoker", "day")
#' data(tips, package = "reshape2")
#' tips <- tips[factors]
#' 
#' ## combine factors
#' con <- xtabs(~., tips)
#' cf <- combine_factors(tips, con)
#' cbind(tips, cf)[sample(nrow(tips), 10),]
#' 
#' ## adjust weights
#' weight <- rnorm(nrow(tips)) + 5
#' adjusted_weight <- ipu_step(weight, cf, con)
#' 
#' ## check outputs
#' con2 <- xtabs(adjusted_weight ~ ., data = tips)
#' sum((con - con2)^2)
#' 
#' @rdname ipu_step
#' @export
ipu_step_ref <- function(w, classes, targets) {
    invisible(.Call('_simPop_ipu_step_ref', PACKAGE = 'simPop', w, classes, targets))
}

#' @rdname ipu_step
#' @export
ipu_step <- function(w, classes, targets) {
    .Call('_simPop_ipu_step', PACKAGE = 'simPop', w, classes, targets)
}

#' @rdname ipu_step
#' @export
ipu_step_f <- function(w, classes, targets) {
    .Call('_simPop_ipu_step_f', PACKAGE = 'simPop', w, classes, targets)
}

updateMatC <- function(M, add_row, add_col, remove_row, remove_col, hhsize, hhid) {
    .Call('_simPop_updateMatC', PACKAGE = 'simPop', M, add_row, add_col, remove_row, remove_col, hhsize, hhid)
}

updateVecC <- function(init_weight, add_index, remove_index, hhsize, hhid, sizefactor) {
    .Call('_simPop_updateVecC', PACKAGE = 'simPop', init_weight, add_index, remove_index, hhsize, hhid, sizefactor)
}

sumVec <- function(init_weight, sizefactor) {
    .Call('_simPop_sumVec', PACKAGE = 'simPop', init_weight, sizefactor)
}

select_equal <- function(x, val1, val2) {
    .Call('_simPop_select_equal', PACKAGE = 'simPop', x, val1, val2)
}

tableC <- function(x) {
    .Call('_simPop_tableC', PACKAGE = 'simPop', x)
}

csample_num <- function(x, size, replace, prob = as.numeric( c())) {
    .Call('_simPop_csample_num', PACKAGE = 'simPop', x, size, replace, prob)
}

sample_group <- function(x, group_x, group, group_num, replace) {
    .Call('_simPop_sample_group', PACKAGE = 'simPop', x, group_x, group, group_num, replace)
}
statistikat/simPop documentation built on Oct. 20, 2018, 8:06 a.m.