R/RcppExports.R

In seroanalytics/serosolver: Inference Framework for Serological Data

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

#' Takes a subset of a Nullable NumericVector, but only if it isn't NULL
subset_nullable_vector <- function(x, index1, index2) {
    .Call('_serosolver_subset_nullable_vector', PACKAGE = 'serosolver', x, index1, index2)
}

#' Sum likelihoods into buckets
#' 
#' Given a large vector of likelihood values and a vector, indices, of length n_indivs, sums the likelihoods to give one value per individual, where indices indicates which individual each index of liks corresponds to.
#' @param liks NumericVector of likelihoods
#' @param indices IntegerVector of indices of same length as liks, where the max value of this should be the same as n_indivs - 1
#' @param n_indivs int, number of individuals to generate bucketed likelihoods for
#' @export
sum_likelihoods <- function(liks, indices, n_indivs) {
    .Call('_serosolver_sum_likelihoods', PACKAGE = 'serosolver', liks, indices, n_indivs)
}

#' Convert melted antigenic map to cross reactivity
#'
#' Multiplies all elements of the provided vector, x such that y = 1 - sigma*x. Also makes sure that no calculated value is less than 0
#' @param x the melted antigenic map
#' @param sigma the cross reactivity waning parameter
#' @return a vector of cross reactivity
create_cross_reactivity_vector <- function(x, sigma) {
    .Call('_serosolver_create_cross_reactivity_vector', PACKAGE = 'serosolver', x, sigma)
}

#' Sums a vector based on bucket sizes
#'
#' Given a vector (a) and another vector of bucket sizes, returns the summed vector (a)
#' @param a the vector to be bucketed
#' @param buckets the vector of bucket sizes to sum a over
#' @return the vector of summed a
#' @export
sum_buckets <- function(a, buckets) {
    .Call('_serosolver_sum_buckets', PACKAGE = 'serosolver', a, buckets)
}

#' Count infections by group and time
#'
#' @export
sum_infections_by_group <- function(inf_hist, group_ids_vec, n_groups) {
    .Call('_serosolver_sum_infections_by_group', PACKAGE = 'serosolver', inf_hist, group_ids_vec, n_groups)
}

#' Add measurement shifts to predictions
#'
#' Adds observation error shifts to predicted antibody titres.
#' @param predicted_titre NumericVector, the predicted titres. Note that this vector will be changed!
#' @param to_add NumericVector the vector of all measurement shifts to apply
#' @param start_index_in_data int the first index of to_add and predicted_titres to combine
#' @param end_index_in_data int the end index of to_add and predicted_titres to combine
#' @return nothing
#' @export
add_measurement_shifts <- function(predicted_titres, to_add, start_index_in_data, end_index_in_data) {
    invisible(.Call('_serosolver_add_measurement_shifts', PACKAGE = 'serosolver', predicted_titres, to_add, start_index_in_data, end_index_in_data))
}

#' Overall model function, fast implementation
#'
#' @param theta NumericVector, the named vector of model parameters
#' @param infection_history_mat IntegerMatrix, the matrix of 1s and 0s showing presence/absence of infection for each possible time for each individual. 
#' @param circulation_times NumericVector, the actual times of circulation that the infection history vector corresponds to
#' @param circulation_times_indices IntegerVector, which entry in the melted antigenic map that these infection times correspond to
#' @param sample_times NumericVector, the times that each blood sample was taken
#' @param type_data_start IntegerVector, one entry for each unique individual. Each entry gives the starting index for each individual of the data frame `unique(titre_dat[,c("individual","obs_type")])`.
#' @param obs_types IntegerVector, result of `unique(titre_dat[,c("individual","obs_type")])$obs_type`
#' @param sample_data_start IntegerVector, one entry for each unique individual and observation type combination. Each entry dictates how many indices through sample_times to iterate per individual and observation type (ie. how many sample times does each individual have?)
#' @param titre_data_start IntegerVector, How many cumulative rows in the titre data correspond to each unique individual and observation type combination? 
#' @param nrows_per_sample IntegerVector, one entry per sample taken. Dictates how many entries to iterate through cum_nrows_per_individual_in_data for each sampling time considered
#' @param measurement_strain_indices IntegerVector, the indices of all measured strains in the melted antigenic map, with one entry per measured titre
#' @param antigenic_map_long NumericVector, the collapsed cross reactivity map for long term boosting, after multiplying by sigma1 see \code{\link{create_cross_reactivity_vector}}
#' @param antigenic_map_short NumericVector, the collapsed cross reactivity map for short term boosting, after multiplying by sigma2, see \code{\link{create_cross_reactivity_vector}}
#' @param antigenic_distances NumericVector, the collapsed cross reactivity map giving euclidean antigenic distances, see \code{\link{create_cross_reactivity_vector}}
#' @param mus NumericVector, if length is greater than one, assumes that strain-specific boosting is used rather than a single boosting parameter
#' @param boosting_vec_indices IntegerVector, same length as circulation_times, giving the index in the vector \code{mus} that each entry should use as its boosting parameter.
#' @param boost_before_infection bool to indicate if calculated titre for that time should be before the infection has occurred, used to calculate titre-mediated immunity
#' @return NumericVector of predicted titres for each entry in measurement_strain_indices
#' @export
#' @family titre_model
titre_data_fast <- function(theta, unique_theta_indices, unique_obs_types, infection_history_mat, circulation_times, circulation_times_indices, sample_times, type_data_start, obs_types, sample_data_start, titre_data_start, nrows_per_sample, measurement_strain_indices, antigenic_map_long, antigenic_map_short, antigenic_distances, mus_strain_dep, boosting_vec_indices, boost_before_infection = FALSE) {
    .Call('_serosolver_titre_data_fast', PACKAGE = 'serosolver', theta, unique_theta_indices, unique_obs_types, infection_history_mat, circulation_times, circulation_times_indices, sample_times, type_data_start, obs_types, sample_data_start, titre_data_start, nrows_per_sample, measurement_strain_indices, antigenic_map_long, antigenic_map_short, antigenic_distances, mus_strain_dep, boosting_vec_indices, boost_before_infection)
}

#' Marginal prior probability (p(Z)) of a particular infection history matrix single prior
#'  Prior is independent contribution from each year
#' @param infection_history IntegerMatrix, the infection history matrix
#' @param n_alive IntegerVector, vector giving the number of individuals alive in each time unit
#' @param alpha double, alpha parameter for beta distribution prior
#' @param beta double, beta parameter for beta distribution prior
#' @return a single prior probability
#' @export
#' @family inf_mat_prior
inf_mat_prior_cpp <- function(infection_history, n_alive, alpha, beta) {
    .Call('_serosolver_inf_mat_prior_cpp', PACKAGE = 'serosolver', infection_history, n_alive, alpha, beta)
}

#' Marginal prior probability (p(Z)) of a particular infection history matrix vector prior
#'  Prior is independent contribution from each year, but each year has its own alpha and beta
#' @param infection_history IntegerMatrix, the infection history matrix
#' @param n_alive IntegerVector, vector giving the number of individuals alive in each time unit
#' @param alphas NumericVector, alpha parameters for beta distribution prior, one for each time unit
#' @param betas NumericVector, beta parameters for beta distribution prior, one for each time unit
#' @return a single prior probability
#' @export
#' @family inf_mat_prior
inf_mat_prior_cpp_vector <- function(infection_history, n_alive, alphas, betas) {
    .Call('_serosolver_inf_mat_prior_cpp_vector', PACKAGE = 'serosolver', infection_history, n_alive, alphas, betas)
}

#' Marginal prior probability (p(Z)) of infection history matrix with groups
#'  Prior is independent contribution from each year and group
#' @param n_infections IntegerMatrix, the total number of infections in each time point/group
#' @param n_alive IntegerMatrix, matrix giving the number of individuals alive in each time unit in each group
#' @param alpha double, alpha parameter for beta distribution prior
#' @param beta double, beta parameter for beta distribution prior
#' @return a single prior probability
#' @export
#' @family inf_mat_prior
inf_mat_prior_group_cpp <- function(n_infections, n_alive, alpha, beta) {
    .Call('_serosolver_inf_mat_prior_group_cpp', PACKAGE = 'serosolver', n_infections, n_alive, alpha, beta)
}

#' Marginal prior probability (p(Z)) of a particular infection history matrix vector prior by group
#'  Prior is independent contribution from each time, but each time has its own alpha and beta
#' @param n_infections IntegerMatrix, the total number of infections in each time point/group
#' @param n_alive IntegerMatrix, matrix giving the number of individuals alive in each time unit in each group
#' @param alphas NumericVector, alpha parameters for beta distribution prior, one for each time unit
#' @param betas NumericVector, beta parameters for beta distribution prior, one for each time unit
#' @return a single prior probability
#' @export
#' @family inf_mat_prior
inf_mat_prior_group_cpp_vector <- function(n_infections, n_alive, alphas, betas) {
    .Call('_serosolver_inf_mat_prior_group_cpp_vector', PACKAGE = 'serosolver', n_infections, n_alive, alphas, betas)
}

#' Marginal prior probability (p(Z)) of a particular infection history matrix total prior
#'  Prior here is on the total number of infections across all individuals and times
#' @param n_infections_group IntegerVector, the total number of infections in each group
#' @param n_alive_group IntegerVector, vector giving total number of potential infection events per group
#' @param alpha double, alpha parameter for beta distribution prior
#' @param beta double, beta parameter for beta distribution prior
#' @return a single prior probability
#' @export
#' @family inf_mat_prior
inf_mat_prior_total_group_cpp <- function(n_infections_group, n_alive_group, alpha, beta) {
    .Call('_serosolver_inf_mat_prior_total_group_cpp', PACKAGE = 'serosolver', n_infections_group, n_alive_group, alpha, beta)
}

#' Fast observation error function
#'  Calculate the probability of a set of observed titres given a corresponding set of predicted titres. FAST IMPLEMENTATION
#' @param theta NumericVector, a named parameter vector giving the normal distribution standard deviation and the max observable titre
#' @param obs NumericVector, the vector of observed log titres
#' @param predicted_titres NumericVector, the vector of predicted log titres
#' @param a vector of same length as the input data giving the probability of observing each observation given the predictions
#' @return a likelihood for each observed titre
#' @export
#' @family likelihood_functions
likelihood_func_fast <- function(theta, obs, predicted_titres) {
    .Call('_serosolver_likelihood_func_fast', PACKAGE = 'serosolver', theta, obs, predicted_titres)
}

#' Fast observation error function continuous
#'  Calculate the probability of a set of observed titres given a corresponding set of predicted titres assuming continuous, bounded observations. FAST IMPLEMENTATION
#' @name Fast observation error function continuous
#' @param theta NumericVector, a named parameter vector giving the normal distribution standard deviation and the max observable titre
#' @param obs NumericVector, the vector of observed log titres
#' @param predicted_titres NumericVector, the vector of predicted log titres
#' @param a vector of same length as the input data giving the probability of observing each observation given the predictions
#' @return a likelihood for each observed titre
#' @export
#' @family likelihood_functions
likelihood_func_fast_continuous <- function(theta, obs, predicted_titres) {
    .Call('_serosolver_likelihood_func_fast_continuous', PACKAGE = 'serosolver', theta, obs, predicted_titres)
}

#' Fast infection history proposal function
#' 
#' Proposes a new matrix of infection histories using a beta binomial proposal distribution. This particular implementation allows for n_infs epoch times to be changed with each function call. Furthermore, the size of the swap step is specified for each individual by move_sizes.
#' @param infection_history_mat and RcppArmadillo matrix of infection histories, where rows represent individuals and columns represent potential infection times. The contents should be a set of 1s (presence of infection) and 0s (absence of infection)
#' @param sampled_indivs IntegerVector, indices of which individuals to resample. Note that this is indexed from 1 (ie. as if passing straight from R)
#' @param age_mask IntegerVector, for each individual gives the first column in the infection history matrix that an individual could have been exposed to indexed from 1. ie. if alive for the whole period, entry would be 1. If alive for the 11th epoch, entry would be 11.
#' @param move_sizes IntegerVector, how far can a swap step sample from specified for each individual
#' @param n_infs IntegerVector, how many infections to add/remove/swap with each proposal step for each individual
#' @param alpha double, alpha parameter of the beta binomial
#' @param beta double, beta parameter of the beta binomial
#' @param rand_ns NumericVector, a vector of random numbers for each sampled individual. The idea is to pre-specify whether an individual experiences an add/remove step or a swap step to avoid random number sampling in C++
#' @return a matrix of 1s and 0s corresponding to the infection histories for all individuals
#' @export
#' @family infection_history_proposal
inf_hist_prop_prior_v3 <- function(infection_history_mat, sampled_indivs, age_mask, strain_mask, move_sizes, n_infs, alpha, beta, rand_ns, swap_propn) {
    .Call('_serosolver_inf_hist_prop_prior_v3', PACKAGE = 'serosolver', infection_history_mat, sampled_indivs, age_mask, strain_mask, move_sizes, n_infs, alpha, beta, rand_ns, swap_propn)
}

#' Infection history gibbs proposal
#'
#' Generates a new infection history matrix and corresponding individual likelihoods, using a gibbs sampler from the infection history prior. See \code{\link{inf_hist_prop_prior_v3}}, as inputs are very similar.
#' @param theta NumericVector, the named model parameters used to solve the model
#' @param infection_history_mat IntegerMatrix the matrix of 1s and 0s corresponding to individual infection histories
#' @param old_probs_1 NumericVector, the current likelihoods for each individual
#' @param sampled_indivs IntegerVector, indices of sampled individuals
#' @param n_years_samp_vec int, for each individual, how many time periods to resample infections for?
#' @param age_mask IntegerVector, length of the number of individuals, with indices specifying first time period that an individual can be infected (indexed from 1, such that a value of 1 allows an individual to be infected in any time period)
#' @param strain_mask IntegerVector, length of the number of individuals, with indices specifying last time period that an individual can be infected (ie. last time a sample was taken)
#' @param n_alive IntegerMatrix, number of columns is the number of time periods that an individual could be infected, giving the number of individual alive in each time period. Number of rows is the number of distinct groups.
#' @param n_infections IntegerMatrix, the number of infections in each year (columns) for each group (rows)
#' @param n_infected_group IntegerVector, the total number of infections across all times in each group
#' @param prior_lookup arma::cube, the pre-computed lookup table for the beta prior on infection histories, dimensions are number of infections, time, and group
#' @param swap_propn double, gives the proportion of proposals that will be swap steps (ie. swap contents of two cells in infection_history rather than adding/removing infections)
#' @param swap_distance int, in a swap step, how many time steps either side of the chosen time period to swap with
#' @param alpha double, alpha parameter for beta prior on infection probability
#' @param beta double, beta parameter for beta prior on infection probability
#' @param circulation_times NumericVector, the times that each strain circulated
#' @param circulation_times_indices IntegerVector, indexing vector from 0:(number of strains-1)
#' @param sample_times NumericVector, the vector of real times that samples were taken
#' @param rows_per_indiv_in_samples IntegerVector, How many rows in titre data correspond to each individual, sample and repeat?
#' @param cum_nrows_per_individual_in_data IntegerVector, How many rows in the titre data correspond to each individual?
#' @param cum_nrows_per_individual_in_repeat_data IntegerVector, For the repeat data (ie. already calculated these titres), how many rows in the titre data correspond to each individual?
#' @param nrows_per_blood_sample IntegerVector, Split the sample times and runs for each individual
#' @param group_id_vec IntegerVector, vector with 1 entry per individual, giving the group ID of that individual
#' @param measurement_strain_indices IntegerVector, For each titre measurement, corresponding entry in antigenic map
#' @param antigenic_map_long NumericVector, the collapsed cross reactivity map for long term boosting, after multiplying by sigma1, see \code{\link{create_cross_reactivity_vector}}
#' @param antigenic_map_short NumericVector, the collapsed cross reactivity map for short term boosting, after multiplying by sigma2, see \code{\link{create_cross_reactivity_vector}}
#' @param antigenic_distances NumericVector matching the dimensions of antigenic_map_long and antigenic_map_short, but with the raw antigenic distances between strains
#' @param data NumericVector, data for all individuals for the first instance of each calculated titre
#' @param repeat_data NumericVector, the repeat titre data for all individuals (ie. do not solve the same titres twice)
#' @param repeat_indices IntegerVector, which index in the main data vector does each entry in repeat_data correspond to ie. which calculated titre in predicted_titres should be used for each observation?
#' @param titre_shifts NumericVector, if length matches the length of \code{data}, adds these as measurement shifts to the predicted titres. If lengths do not match, is not used.
#' @param proposal_iter IntegerVector, vector with entry for each individual, storing the number of infection history add/remove proposals for each individual.
#' @param accepted_iter IntegerVector, vector with entry for each individual, storing the number of accepted infection history add/remove proposals for each individual.
#' @param proposal_swap IntegerVector, vector with entry for each individual, storing the number of proposed infection history swaps
#' @param accepted_swap IntegerVector, vector with entry for each individual, storing the number of accepted infection history swaps
#' @param mus NumericVector, if length is greater than one, assumes that strain-specific boosting is used rather than a single boosting parameter
#' @param boosting_vec_indices IntegerVector, same length as circulation_times, giving the index in the vector \code{mus} that each entry should use as its boosting parameter.
#' @param total_alive IntegerVector, giving the total number of potential infection events for each group. This only applies to prior version 4. If set to a vector of values -1, then this is ignored.
#' @param temp double, temperature for parallel tempering MCMC
#' @param solve_likelihood bool, if FALSE does not solve likelihood when calculating acceptance probability
#' @param data_type int, defaults to 1 for discretized, bounded data. Set to 2 for continuous, bounded data
#' @return an R list with 6 entries: 1) the vector replacing old_probs_1, corresponding to the new likelihoods per individual; 2) the matrix of 1s and 0s corresponding to the new infection histories for all individuals; 3-6) the updated entries for proposal_iter, accepted_iter, proposal_swap and accepted_swap.
#' @export
#' @family infection_history_proposal
inf_hist_prop_prior_v2_and_v4 <- function(theta, unique_theta_indices, unique_obs_types, infection_history_mat, old_probs_1, sampled_indivs, n_years_samp_vec, age_mask, strain_mask, n_alive, n_infections, n_infected_group, prior_lookup, swap_propn, swap_distance, propose_from_prior, alpha, beta, circulation_times, circulation_times_indices, sample_times, type_data_start, obs_types, sample_data_start, titre_data_start, nrows_per_sample, cum_nrows_per_individual_in_data, cum_nrows_per_individual_in_repeat_data, group_id_vec, measurement_strain_indices, antigenic_map_long, antigenic_map_short, antigenic_distances, data, repeat_data, n_titres_total, repeat_indices, repeat_data_exist, titre_shifts, proposal_iter, accepted_iter, proposal_swap, accepted_swap, overall_swap_proposals, overall_add_proposals, time_sample_probs, mus_strain_dep, boosting_vec_indices, total_alive, data_types, obs_weights, temp = 1, solve_likelihood = TRUE) {
    .Call('_serosolver_inf_hist_prop_prior_v2_and_v4', PACKAGE = 'serosolver', theta, unique_theta_indices, unique_obs_types, infection_history_mat, old_probs_1, sampled_indivs, n_years_samp_vec, age_mask, strain_mask, n_alive, n_infections, n_infected_group, prior_lookup, swap_propn, swap_distance, propose_from_prior, alpha, beta, circulation_times, circulation_times_indices, sample_times, type_data_start, obs_types, sample_data_start, titre_data_start, nrows_per_sample, cum_nrows_per_individual_in_data, cum_nrows_per_individual_in_repeat_data, group_id_vec, measurement_strain_indices, antigenic_map_long, antigenic_map_short, antigenic_distances, data, repeat_data, n_titres_total, repeat_indices, repeat_data_exist, titre_shifts, proposal_iter, accepted_iter, proposal_swap, accepted_swap, overall_swap_proposals, overall_add_proposals, time_sample_probs, mus_strain_dep, boosting_vec_indices, total_alive, data_types, obs_weights, temp, solve_likelihood)
}

#' Function to calculate non-linear waning
#'  All additional parameters for the function are declared here
#' @param theta NumericVector, the named vector of model parameters
#' @param time_infected double the time infected (sampling_time - circulation_time)
#' @return value of waning parameter based on time since infected 
#' @useDynLib serosolver
#' @export
wane_function <- function(theta, time_infected, wane) {
    .Call('_serosolver_wane_function', PACKAGE = 'serosolver', theta, time_infected, wane)
}