add conditional loglik function

NAMESPACE

@@ -4,6 +4,7 @@ S3method(fitted,vinereg)
 S3method(predict,vinereg)
 S3method(print,vinereg)
 S3method(summary,vinereg)
+export(cll)
 export(cpit)
 export(plot_effects)
 export(vinereg)

R/RcppExports.R

@@ -17,3 +17,11 @@ cond_dist_cpp <- function(u, vinecop_r, num_threads) {
     .Call(`_vinereg_cond_dist_cpp`, u, vinecop_r, num_threads)
 }
 
+cond_loglik_cpp <- function(u, vinecop_r, num_threads) {
+    .Call(`_vinereg_cond_loglik_cpp`, u, vinecop_r, num_threads)
+}
+
+with_parameters_cop_cpp <- function(vinecop_r, parameters) {
+    .Call(`_vinereg_with_parameters_cop_cpp`, vinecop_r, parameters)
+}
+

R/cpit.R

@@ -27,3 +27,37 @@ cpit <- function(object, newdata, cores = 1) {
   newdata <- to_uscale(newdata, object$margins)
   cond_dist_cpp(newdata, object$vine, cores)
 }
+
+#' Conditional log-likelihood
+#'
+#' Calculates the conditional log-likelihood of the response given the covariates.
+#'
+#' @param object an object of class \code{vinereg}.
+#' @param newdata matrix of response and covariate values for which to compute
+#'   the conditional distribution.
+#' @param cores integer; the number of cores to use for computations.
+#'
+#' @export
+#'
+#' @examples
+#' \dontshow{
+#' set.seed(1)
+#' }
+#' # simulate data
+#' x <- matrix(rnorm(500), 250, 2)
+#' y <- x %*% c(1, -2)
+#' dat <- data.frame(y = y, x = x, z = as.factor(rbinom(250, 2, 0.5)))
+#'
+#' # fit vine regression model
+#' fit <- vinereg(y ~ ., dat)
+#'
+#' cll(fit, dat)
+#' fit$stats$cll
+cll <- function(object, newdata, cores = 1) {
+  newdata <- prepare_newdata(newdata, object, use_response = TRUE)
+  y <- prep_for_kde1d(newdata[, 1])
+  ll_marg <- sum(log(kde1d::dkde1d(y, fit$margins[[1]])))
+  newdata <- to_uscale(newdata, object$margins)
+  ll_cop <- cond_loglik_cpp(newdata, object$vine, cores)
+  ll_cop + ll_marg
+}

src/RcppExports.cpp

@@ -79,12 +79,39 @@ BEGIN_RCPP
     return rcpp_result_gen;
 END_RCPP
 }
+// cond_loglik_cpp
+double cond_loglik_cpp(const Eigen::MatrixXd& u, const Rcpp::List& vinecop_r, size_t num_threads);
+RcppExport SEXP _vinereg_cond_loglik_cpp(SEXP uSEXP, SEXP vinecop_rSEXP, SEXP num_threadsSEXP) {
+BEGIN_RCPP
+    Rcpp::RObject rcpp_result_gen;
+    Rcpp::RNGScope rcpp_rngScope_gen;
+    Rcpp::traits::input_parameter< const Eigen::MatrixXd& >::type u(uSEXP);
+    Rcpp::traits::input_parameter< const Rcpp::List& >::type vinecop_r(vinecop_rSEXP);
+    Rcpp::traits::input_parameter< size_t >::type num_threads(num_threadsSEXP);
+    rcpp_result_gen = Rcpp::wrap(cond_loglik_cpp(u, vinecop_r, num_threads));
+    return rcpp_result_gen;
+END_RCPP
+}
+// with_parameters_cop_cpp
+Rcpp::List with_parameters_cop_cpp(const Rcpp::List& vinecop_r, const Eigen::VectorXd parameters);
+RcppExport SEXP _vinereg_with_parameters_cop_cpp(SEXP vinecop_rSEXP, SEXP parametersSEXP) {
+BEGIN_RCPP
+    Rcpp::RObject rcpp_result_gen;
+    Rcpp::RNGScope rcpp_rngScope_gen;
+    Rcpp::traits::input_parameter< const Rcpp::List& >::type vinecop_r(vinecop_rSEXP);
+    Rcpp::traits::input_parameter< const Eigen::VectorXd >::type parameters(parametersSEXP);
+    rcpp_result_gen = Rcpp::wrap(with_parameters_cop_cpp(vinecop_r, parameters));
+    return rcpp_result_gen;
+END_RCPP
+}
 
 static const R_CallMethodDef CallEntries[] = {
     {"_vinereg_fit_margins_cpp", (DL_FUNC) &_vinereg_fit_margins_cpp, 9},
     {"_vinereg_select_dvine_cpp", (DL_FUNC) &_vinereg_select_dvine_cpp, 11},
     {"_vinereg_cond_quantile_cpp", (DL_FUNC) &_vinereg_cond_quantile_cpp, 4},
     {"_vinereg_cond_dist_cpp", (DL_FUNC) &_vinereg_cond_dist_cpp, 3},
+    {"_vinereg_cond_loglik_cpp", (DL_FUNC) &_vinereg_cond_loglik_cpp, 3},
+    {"_vinereg_with_parameters_cop_cpp", (DL_FUNC) &_vinereg_with_parameters_cop_cpp, 2},
     {NULL, NULL, 0}
 };