Finds a value of the Box-Cox transformation parameter lambda for which the (positive) random variable with log-density \(\log f\) has a density closer to that of a Gaussian random variable. In the following we use theta (\(\theta\)) to denote the argument of logf on the original scale and phi (\(\phi\)) on the Box-Cox transformed scale.

find_lambda_rcpp(
  logf,
  ...,
  d = 1,
  n_grid = NULL,
  ep_bc = 1e-04,
  min_phi = rep(ep_bc, d),
  max_phi = rep(10, d),
  which_lam = 1:d,
  lambda_range = c(-3, 3),
  init_lambda = NULL,
  phi_to_theta = NULL,
  log_j = NULL,
  user_args = list()
)

Arguments

logf

A pointer to a compiled C++ function returning the log of the target density \(f\).

...

further arguments to be passed to logf and related functions.

d

A numeric scalar. Dimension of \(f\).

n_grid

A numeric scalar. Number of ordinates for each variable in phi. If this is not supplied a default value of ceiling(2501 ^ (1 / d)) is used.

ep_bc

A (positive) numeric scalar. Smallest possible value of phi to consider. Used to avoid negative values of phi.

min_phi, max_phi

Numeric vectors. Smallest and largest values of phi at which to evaluate logf, i.e., the range of values of phi over which to evaluate logf. Any components in min_phi that are not positive are set to ep_bc.

which_lam

A numeric vector. Contains the indices of the components of phi that ARE to be Box-Cox transformed.

lambda_range

A numeric vector of length 2. Range of lambda over which to optimise.

init_lambda

A numeric vector of length 1 or d. Initial value of lambda used in the search for the best lambda. If init_lambda is a scalar then rep(init_lambda, d) is used.

phi_to_theta

A pointer to a compiled C++ function returning (the inverse) of the transformation from theta to phi used to ensure positivity of phi prior to Box-Cox transformation. The argument is phi and the returned value is theta. If phi_to_theta is undefined at the input value then the function should return NA.

log_j

A pointer to a compiled C++ function returning the log of the Jacobian of the transformation from theta to phi, i.e., based on derivatives of \(phi\) with respect to \(theta\). Takes theta as its argument.

user_args

A list of numeric components providing arguments to the user-supplied functions phi_to_theta and log_j.

Value

A list containing the following components

lambda

A numeric vector. The value of lambda.

gm

A numeric vector. Box-cox scaling parameter, estimated by the geometric mean of the values of phi used in the optimisation to find the value of lambda, weighted by the values of f evaluated at phi.

init_psi

A numeric vector. An initial estimate of the mode of the Box-Cox transformed density

sd_psi

A numeric vector. Estimates of the marginal standard deviations of the Box-Cox transformed variables.

phi_to_theta

as detailed above (only if phi_to_theta is supplied)

log_j

as detailed above (only if log_j is supplied)

user_args

as detailed above (only if user_args is supplied)

Details

The general idea is to evaluate the density \(f\) on a d-dimensional grid, with n_grid ordinates for each of the d variables. We treat each combination of the variables in the grid as a data point and perform an estimation of the Box-Cox transformation parameter lambda, in which each data point is weighted by the density at that point. The vectors min_phi and max_phi define the limits of the grid and which_lam can be used to specify that only certain components of phi are to be transformed.

References

Box, G. and Cox, D. R. (1964) An Analysis of Transformations. Journal of the Royal Statistical Society. Series B (Methodological), 26(2), 211-252.

Andrews, D. F. and Gnanadesikan, R. and Warner, J. L. (1971) Transformations of Multivariate Data, Biometrics, 27(4).

Eddelbuettel, D. and Francois, R. (2011). Rcpp: Seamless R and C++ Integration. Journal of Statistical Software, 40(8), 1-18. doi:10.18637/jss.v040.i08

Eddelbuettel, D. (2013). Seamless R and C++ Integration with Rcpp, Springer, New York. ISBN 978-1-4614-6867-7.

See also

ru_rcpp to perform ratio-of-uniforms sampling.

find_lambda_one_d_rcpp to produce (somewhat) automatically a list for the argument lambda of ru for the d = 1 case.

Examples


# Log-normal density ===================
# Note: the default value max_phi = 10 is OK here but this will not always
# be the case
ptr_lnorm <- create_xptr("logdlnorm")
mu <- 0
sigma <- 1
lambda <- find_lambda_rcpp(logf = ptr_lnorm, mu = mu, sigma = sigma)
lambda
#> $lambda
#> [1] 0.05408856
#> 
#> $gm
#> [1] 0.971952
#> 
#> $init_psi
#> [1] -0.05181524
#> 
#> $sd_psi
#>      Var1 
#> 0.8614544 
#> 
#> $user_args
#> list()
#> 
x <- ru_rcpp(logf = ptr_lnorm, mu = mu, sigma = sigma, d = 1, n = 1000,
             trans = "BC", lambda = lambda)

# Gamma density ===================
alpha <- 1
#  Choose a sensible value of max_phi
max_phi <- qgamma(0.999, shape = alpha)
# [Of course, typically the quantile function won't be available.  However,
# In practice the value of lambda chosen is quite insensitive to the choice
# of max_phi, provided that max_phi is not far too large or far too small.]

ptr_gam <- create_xptr("logdgamma")
lambda <- find_lambda_rcpp(logf = ptr_gam, alpha = alpha, max_phi = max_phi)
lambda
#> $lambda
#> [1] 0.2801406
#> 
#> $gm
#> [1] 0.5525366
#> 
#> $init_psi
#> [1] -0.2060046
#> 
#> $sd_psi
#>     Var1 
#> 0.573372 
#> 
#> $user_args
#> list()
#> 
x <- ru_rcpp(logf = ptr_gam, alpha = alpha, d = 1, n = 1000, trans = "BC",
             lambda = lambda)

# \donttest{
# Generalized Pareto posterior distribution ===================

n <- 1000
# Sample data from a GP(sigma, xi) distribution
gpd_data <- rgpd(m = 100, xi = -0.5, sigma = 1)
# Calculate summary statistics for use in the log-likelihood
ss <- gpd_sum_stats(gpd_data)
# Calculate an initial estimate
init <- c(mean(gpd_data), 0)

n <- 1000
# Sample on original scale, with no rotation ----------------
ptr_gp <- create_xptr("loggp")
for_ru_rcpp <- c(list(logf = ptr_gp, init = init, d = 2, n = n,
                     lower = c(0, -Inf)), ss, rotate = FALSE)
x1 <- do.call(ru_rcpp, for_ru_rcpp)
#> Warning: One or more convergence indicators are non-zero.
#>                 box      vals1      vals2 conv
#> a        1.00000000  0.0000000  0.0000000    0
#> b1minus -0.13000299 -0.2071359  0.1476476    0
#> b2minus -0.09362841  0.2715489 -0.1605458    0
#> b1plus   0.13436828  0.4277783 -0.2421006   52
#> b2plus   0.10911979 -0.2028613  0.2025477    0
plot(x1, xlab = "sigma", ylab = "xi")
# Parameter constraint line xi > -sigma/max(data)
# [This may not appear if the sample is far from the constraint.]
abline(a = 0, b = -1 / ss$xm)

summary(x1)
#> ru bounding box:  
#>                 box      vals1      vals2 conv
#> a        1.00000000  0.0000000  0.0000000    0
#> b1minus -0.13000299 -0.2071359  0.1476476    0
#> b2minus -0.09362841  0.2715489 -0.1605458    0
#> b1plus   0.13436828  0.4277783 -0.2421006   52
#> b2plus   0.10911979 -0.2028613  0.2025477    0
#> 
#> estimated probability of acceptance:  
#> [1] 0.1777146
#> 
#> sample summary 
#>        V1               V2         
#>  Min.   :0.6368   Min.   :-0.8058  
#>  1st Qu.:0.9154   1st Qu.:-0.5397  
#>  Median :0.9922   Median :-0.4858  
#>  Mean   :0.9981   Mean   :-0.4810  
#>  3rd Qu.:1.0728   3rd Qu.:-0.4279  
#>  Max.   :1.5301   Max.   :-0.1156  

# Sample on original scale, with rotation ----------------
for_ru_rcpp <- c(list(logf = ptr_gp, init = init, d = 2, n = n,
                      lower = c(0, -Inf)), ss)
x2 <- do.call(ru_rcpp, for_ru_rcpp)
plot(x2, xlab = "sigma", ylab = "xi")
abline(a = 0, b = -1 / ss$xm)

summary(x2)
#> ru bounding box:  
#>                 box       vals1       vals2 conv
#> a        1.00000000  0.00000000  0.00000000    0
#> b1minus -0.04683301 -0.06988293  0.03476465    0
#> b2minus -0.06387570  0.05417618 -0.10952842    0
#> b1plus   0.11386488  0.25623381  0.11698770    0
#> b2plus   0.07444431  0.13646543  0.13818324    0
#> 
#> estimated probability of acceptance:  
#> [1] 0.4366812
#> 
#> sample summary 
#>        V1               V2         
#>  Min.   :0.6316   Min.   :-0.7649  
#>  1st Qu.:0.9256   1st Qu.:-0.5369  
#>  Median :0.9918   Median :-0.4818  
#>  Mean   :1.0016   Mean   :-0.4802  
#>  3rd Qu.:1.0799   3rd Qu.:-0.4311  
#>  Max.   :1.4597   Max.   :-0.1446  

# Sample on Box-Cox transformed scale ----------------

# Find initial estimates for phi = (phi1, phi2),
# where phi1 = sigma
#   and phi2 = xi + sigma / max(x),
# and ranges of phi1 and phi2 over over which to evaluate
# the posterior to find a suitable value of lambda.
temp <- do.call(gpd_init, ss)
min_phi <- pmax(0, temp$init_phi - 2 * temp$se_phi)
max_phi <- pmax(0, temp$init_phi + 2 * temp$se_phi)

# Set phi_to_theta() that ensures positivity of phi
# We use phi1 = sigma and phi2 = xi + sigma / max(data)

# Create an external pointer to this C++ function
ptr_phi_to_theta_gp <- create_phi_to_theta_xptr("gp")
# Note: log_j is set to zero by default inside find_lambda_rcpp()
lambda <- find_lambda_rcpp(logf = ptr_gp, ss = ss, d = 2, min_phi = min_phi,
                           max_phi = max_phi, user_args = list(xm = ss$xm),
                           phi_to_theta = ptr_phi_to_theta_gp)
lambda
#> $lambda
#> [1] 0.1483802 0.3481883
#> 
#> $gm
#> [1] 0.99644214 0.03626961
#> 
#> $init_psi
#> [1] -0.003183355 -0.222046939
#> 
#> $sd_psi
#>       Var1       Var2 
#> 0.11381920 0.02736034 
#> 
#> $phi_to_theta
#> <pointer: 0x0000019635d3c240>
#> 
#> $log_j
#> <pointer: 0x0000019635d3c190>
#> 
#> $user_args
#> $user_args$xm
#> [1] 1.877702
#> 
#> 

# Sample on Box-Cox transformed, without rotation
x3 <- ru_rcpp(logf = ptr_gp, ss = ss, d = 2, n = n, trans = "BC",
              lambda = lambda, rotate = FALSE)
plot(x3, xlab = "sigma", ylab = "xi")
abline(a = 0, b = -1 / ss$xm)

summary(x3)
#> ru bounding box:  
#>                 box      vals1       vals2 conv
#> a        1.00000000  0.0000000  0.00000000    0
#> b1minus -0.14319161 -0.2392579  0.03347515    0
#> b2minus -0.03666052  0.0750684 -0.05744262    0
#> b1plus   0.14336221  0.2391691 -0.01961998    0
#> b2plus   0.03802654 -0.1082754  0.06223388    0
#> 
#> estimated probability of acceptance:  
#> [1] 0.4940711
#> 
#> sample summary 
#>        V1               V2         
#>  Min.   :0.6913   Min.   :-0.7568  
#>  1st Qu.:0.9217   1st Qu.:-0.5317  
#>  Median :0.9923   Median :-0.4843  
#>  Mean   :0.9985   Mean   :-0.4792  
#>  3rd Qu.:1.0701   3rd Qu.:-0.4297  
#>  Max.   :1.4289   Max.   :-0.1352  

# Sample on Box-Cox transformed, with rotation
x4 <- ru_rcpp(logf = ptr_gp, ss = ss, d = 2, n = n, trans = "BC",
              lambda = lambda)
plot(x4, xlab = "sigma", ylab = "xi")
abline(a = 0, b = -1 / ss$xm)

summary(x4)
#> ru bounding box:  
#>                 box        vals1        vals2 conv
#> a        1.00000000  0.000000000  0.000000000    0
#> b1minus -0.06770054 -0.109679905  0.009802127    0
#> b2minus -0.06730913 -0.005497794 -0.105465288    0
#> b1plus   0.07401495  0.125207720  0.005869616    0
#> b2plus   0.06981715 -0.008719787  0.114262120    0
#> 
#> estimated probability of acceptance:  
#> [1] 0.532198
#> 
#> sample summary 
#>        V1               V2          
#>  Min.   :0.6260   Min.   :-0.80867  
#>  1st Qu.:0.9237   1st Qu.:-0.53690  
#>  Median :0.9961   Median :-0.48915  
#>  Mean   :1.0042   Mean   :-0.48614  
#>  3rd Qu.:1.0792   3rd Qu.:-0.43558  
#>  Max.   :1.5400   Max.   :-0.08697  

def_par <- graphics::par(no.readonly = TRUE)
par(mfrow = c(2,2), mar = c(4, 4, 1.5, 1))
plot(x1, xlab = "sigma", ylab = "xi", ru_scale = TRUE,
  main = "mode relocation")
plot(x2, xlab = "sigma", ylab = "xi", ru_scale = TRUE,
  main = "mode relocation and rotation")
plot(x3, xlab = "sigma", ylab = "xi", ru_scale = TRUE,
  main = "Box-Cox and mode relocation")
plot(x4, xlab = "sigma", ylab = "xi", ru_scale = TRUE,
  main = "Box-Cox, mode relocation and rotation")

graphics::par(def_par)
# }