refactor: Small refactor to use "profiles" rather than old-reginst
Basically pass in a raw DataFrame and parse column numbers rather than an inst that is pre-set as a List
This commit is contained in:
parent
c0470b3fc7
commit
250a49c430
|
@ -3,3 +3,4 @@
|
|||
.RData
|
||||
tags
|
||||
*.log
|
||||
src/.ccls
|
||||
|
|
|
@ -1,6 +1,6 @@
|
|||
Package: rcguts
|
||||
Title: Backend Functions for R Choice Packages
|
||||
Version: 0.15.0
|
||||
Version: 0.16.0
|
||||
Authors@R: person('Brian Albert', 'Monroe', email = 'brianalbertmonroe@gmail.com', role = c('aut', 'cre'))
|
||||
Description: This package provides some backend functions that are shared by the R Choice family of pacakes. In particular, likelihood functions written in c++.
|
||||
Depends: R (>= 3.4.1)
|
||||
|
|
|
@ -2,7 +2,6 @@
|
|||
|
||||
export(calc_likelihood)
|
||||
export(calc_utility)
|
||||
export(list2_cube)
|
||||
export(mlgeneral)
|
||||
export(set_uparsers)
|
||||
export(slike)
|
||||
|
|
|
@ -11,13 +11,6 @@ vpow <- function(base, exp) {
|
|||
.Call('_rcguts_vpow', PACKAGE = 'rcguts', base, exp)
|
||||
}
|
||||
|
||||
#' Turn list to cube object
|
||||
#'
|
||||
#' @export list2_cube
|
||||
list2_cube <- function(Inst, out_prob) {
|
||||
.Call('_rcguts_list2_cube', PACKAGE = 'rcguts', Inst, out_prob)
|
||||
}
|
||||
|
||||
gslikelihood <- function(dfun, Utilities) {
|
||||
.Call('_rcguts_gslikelihood', PACKAGE = 'rcguts', dfun, Utilities)
|
||||
}
|
||||
|
@ -25,34 +18,35 @@ gslikelihood <- function(dfun, Utilities) {
|
|||
#' Generic Utility calculation
|
||||
#'
|
||||
#' @param pmat the parameter vector
|
||||
#' @param Inst the insrument as a list of its components
|
||||
#' @param fun_types List of the utility, probability weighting, and stochstic function types
|
||||
#' @param par_index fun_types List of giving the index in the par vector of the parameters for each fun_type
|
||||
#' @param inst the insrument as a list of its components
|
||||
#' @param profile the profile of the instrument
|
||||
#' @param ftypes List of the utility, probability weighting, and stochstic function types
|
||||
#' @param ft_index ftypes List of giving the index in the par vector of the parameters for each fun_type
|
||||
#' @export calc_utility
|
||||
calc_utility <- function(pmat, Inst, fun_types, par_index) {
|
||||
.Call('_rcguts_calc_utility', PACKAGE = 'rcguts', pmat, Inst, fun_types, par_index)
|
||||
calc_utility <- function(pmat, inst, profile, ftypes, ft_index) {
|
||||
.Call('_rcguts_calc_utility', PACKAGE = 'rcguts', pmat, inst, profile, ftypes, ft_index)
|
||||
}
|
||||
|
||||
#' Generic Likelihood calculation
|
||||
#'
|
||||
#' @param pmat the parameter vector
|
||||
#' @param Inst the insrument as a list of its components
|
||||
#' @param fun_types List of the utility, probability weighting, and stochstic function types
|
||||
#' @param par_index fun_types List of giving the index in the par vector of the parameters for each fun_type
|
||||
#' @param inst the insrument as a list of its components
|
||||
#' @param ftypes List of the utility, probability weighting, and stochstic function types
|
||||
#' @param ft_index ftypes List of giving the index in the par vector of the parameters for each fun_type
|
||||
#' @export calc_likelihood
|
||||
calc_likelihood <- function(pmat, Inst, fun_types, par_index) {
|
||||
.Call('_rcguts_calc_likelihood', PACKAGE = 'rcguts', pmat, Inst, fun_types, par_index)
|
||||
calc_likelihood <- function(pmat, inst, profile, ftypes, ft_index) {
|
||||
.Call('_rcguts_calc_likelihood', PACKAGE = 'rcguts', pmat, inst, profile, ftypes, ft_index)
|
||||
}
|
||||
|
||||
#' Return a likelihood vector for choices
|
||||
#'
|
||||
#' @param par the parameter vector
|
||||
#' @param Inst the insrument as a list of its components
|
||||
#' @param fun_types List of the utility, probability weighting, and stochstic function types
|
||||
#' @param par_index fun_types List of giving the index in the par vector of the parameters for each fun_type
|
||||
#' @param inst the insrument as a list of its components
|
||||
#' @param ftypes List of the utility, probability weighting, and stochstic function types
|
||||
#' @param ft_index ftypes List of giving the index in the par vector of the parameters for each fun_type
|
||||
#' @export mlgeneral
|
||||
mlgeneral <- function(pmat, inst, fun_types, par_index) {
|
||||
.Call('_rcguts_mlgeneral', PACKAGE = 'rcguts', pmat, inst, fun_types, par_index)
|
||||
mlgeneral <- function(pmat, inst, profile, ftypes, ft_index) {
|
||||
.Call('_rcguts_mlgeneral', PACKAGE = 'rcguts', pmat, inst, profile, ftypes, ft_index)
|
||||
}
|
||||
|
||||
gsutility <- function(pars, ufun, outcomes) {
|
||||
|
|
|
@ -46,27 +46,6 @@ namespace rcguts {
|
|||
return Rcpp::as<arma::mat >(rcpp_result_gen);
|
||||
}
|
||||
|
||||
inline arma::cube list2_cube(List Inst, int out_prob) {
|
||||
typedef SEXP(*Ptr_list2_cube)(SEXP,SEXP);
|
||||
static Ptr_list2_cube p_list2_cube = NULL;
|
||||
if (p_list2_cube == NULL) {
|
||||
validateSignature("arma::cube(*list2_cube)(List,int)");
|
||||
p_list2_cube = (Ptr_list2_cube)R_GetCCallable("rcguts", "_rcguts_list2_cube");
|
||||
}
|
||||
RObject rcpp_result_gen;
|
||||
{
|
||||
RNGScope RCPP_rngScope_gen;
|
||||
rcpp_result_gen = p_list2_cube(Shield<SEXP>(Rcpp::wrap(Inst)), Shield<SEXP>(Rcpp::wrap(out_prob)));
|
||||
}
|
||||
if (rcpp_result_gen.inherits("interrupted-error"))
|
||||
throw Rcpp::internal::InterruptedException();
|
||||
if (Rcpp::internal::isLongjumpSentinel(rcpp_result_gen))
|
||||
throw Rcpp::LongjumpException(rcpp_result_gen);
|
||||
if (rcpp_result_gen.inherits("try-error"))
|
||||
throw Rcpp::exception(Rcpp::as<std::string>(rcpp_result_gen).c_str());
|
||||
return Rcpp::as<arma::cube >(rcpp_result_gen);
|
||||
}
|
||||
|
||||
inline arma::vec gslikelihood(std::string dfun, arma::vec Utilities) {
|
||||
typedef SEXP(*Ptr_gslikelihood)(SEXP,SEXP);
|
||||
static Ptr_gslikelihood p_gslikelihood = NULL;
|
||||
|
@ -88,17 +67,17 @@ namespace rcguts {
|
|||
return Rcpp::as<arma::vec >(rcpp_result_gen);
|
||||
}
|
||||
|
||||
inline arma::mat calc_utility(arma::mat pmat, List Inst, List fun_types, List par_index) {
|
||||
typedef SEXP(*Ptr_calc_utility)(SEXP,SEXP,SEXP,SEXP);
|
||||
inline arma::mat calc_utility(arma::mat pmat, DataFrame inst, List profile, List ftypes, List ft_index) {
|
||||
typedef SEXP(*Ptr_calc_utility)(SEXP,SEXP,SEXP,SEXP,SEXP);
|
||||
static Ptr_calc_utility p_calc_utility = NULL;
|
||||
if (p_calc_utility == NULL) {
|
||||
validateSignature("arma::mat(*calc_utility)(arma::mat,List,List,List)");
|
||||
validateSignature("arma::mat(*calc_utility)(arma::mat,DataFrame,List,List,List)");
|
||||
p_calc_utility = (Ptr_calc_utility)R_GetCCallable("rcguts", "_rcguts_calc_utility");
|
||||
}
|
||||
RObject rcpp_result_gen;
|
||||
{
|
||||
RNGScope RCPP_rngScope_gen;
|
||||
rcpp_result_gen = p_calc_utility(Shield<SEXP>(Rcpp::wrap(pmat)), Shield<SEXP>(Rcpp::wrap(Inst)), Shield<SEXP>(Rcpp::wrap(fun_types)), Shield<SEXP>(Rcpp::wrap(par_index)));
|
||||
rcpp_result_gen = p_calc_utility(Shield<SEXP>(Rcpp::wrap(pmat)), Shield<SEXP>(Rcpp::wrap(inst)), Shield<SEXP>(Rcpp::wrap(profile)), Shield<SEXP>(Rcpp::wrap(ftypes)), Shield<SEXP>(Rcpp::wrap(ft_index)));
|
||||
}
|
||||
if (rcpp_result_gen.inherits("interrupted-error"))
|
||||
throw Rcpp::internal::InterruptedException();
|
||||
|
@ -109,17 +88,17 @@ namespace rcguts {
|
|||
return Rcpp::as<arma::mat >(rcpp_result_gen);
|
||||
}
|
||||
|
||||
inline arma::mat calc_likelihood(arma::mat pmat, List Inst, List fun_types, List par_index) {
|
||||
typedef SEXP(*Ptr_calc_likelihood)(SEXP,SEXP,SEXP,SEXP);
|
||||
inline arma::mat calc_likelihood(arma::mat pmat, DataFrame inst, List profile, List ftypes, List ft_index) {
|
||||
typedef SEXP(*Ptr_calc_likelihood)(SEXP,SEXP,SEXP,SEXP,SEXP);
|
||||
static Ptr_calc_likelihood p_calc_likelihood = NULL;
|
||||
if (p_calc_likelihood == NULL) {
|
||||
validateSignature("arma::mat(*calc_likelihood)(arma::mat,List,List,List)");
|
||||
validateSignature("arma::mat(*calc_likelihood)(arma::mat,DataFrame,List,List,List)");
|
||||
p_calc_likelihood = (Ptr_calc_likelihood)R_GetCCallable("rcguts", "_rcguts_calc_likelihood");
|
||||
}
|
||||
RObject rcpp_result_gen;
|
||||
{
|
||||
RNGScope RCPP_rngScope_gen;
|
||||
rcpp_result_gen = p_calc_likelihood(Shield<SEXP>(Rcpp::wrap(pmat)), Shield<SEXP>(Rcpp::wrap(Inst)), Shield<SEXP>(Rcpp::wrap(fun_types)), Shield<SEXP>(Rcpp::wrap(par_index)));
|
||||
rcpp_result_gen = p_calc_likelihood(Shield<SEXP>(Rcpp::wrap(pmat)), Shield<SEXP>(Rcpp::wrap(inst)), Shield<SEXP>(Rcpp::wrap(profile)), Shield<SEXP>(Rcpp::wrap(ftypes)), Shield<SEXP>(Rcpp::wrap(ft_index)));
|
||||
}
|
||||
if (rcpp_result_gen.inherits("interrupted-error"))
|
||||
throw Rcpp::internal::InterruptedException();
|
||||
|
@ -130,17 +109,17 @@ namespace rcguts {
|
|||
return Rcpp::as<arma::mat >(rcpp_result_gen);
|
||||
}
|
||||
|
||||
inline arma::vec mlgeneral(arma::mat pmat, List inst, List fun_types, List par_index) {
|
||||
typedef SEXP(*Ptr_mlgeneral)(SEXP,SEXP,SEXP,SEXP);
|
||||
inline arma::vec mlgeneral(arma::mat pmat, DataFrame inst, List profile, List ftypes, List ft_index) {
|
||||
typedef SEXP(*Ptr_mlgeneral)(SEXP,SEXP,SEXP,SEXP,SEXP);
|
||||
static Ptr_mlgeneral p_mlgeneral = NULL;
|
||||
if (p_mlgeneral == NULL) {
|
||||
validateSignature("arma::vec(*mlgeneral)(arma::mat,List,List,List)");
|
||||
validateSignature("arma::vec(*mlgeneral)(arma::mat,DataFrame,List,List,List)");
|
||||
p_mlgeneral = (Ptr_mlgeneral)R_GetCCallable("rcguts", "_rcguts_mlgeneral");
|
||||
}
|
||||
RObject rcpp_result_gen;
|
||||
{
|
||||
RNGScope RCPP_rngScope_gen;
|
||||
rcpp_result_gen = p_mlgeneral(Shield<SEXP>(Rcpp::wrap(pmat)), Shield<SEXP>(Rcpp::wrap(inst)), Shield<SEXP>(Rcpp::wrap(fun_types)), Shield<SEXP>(Rcpp::wrap(par_index)));
|
||||
rcpp_result_gen = p_mlgeneral(Shield<SEXP>(Rcpp::wrap(pmat)), Shield<SEXP>(Rcpp::wrap(inst)), Shield<SEXP>(Rcpp::wrap(profile)), Shield<SEXP>(Rcpp::wrap(ftypes)), Shield<SEXP>(Rcpp::wrap(ft_index)));
|
||||
}
|
||||
if (rcpp_result_gen.inherits("interrupted-error"))
|
||||
throw Rcpp::internal::InterruptedException();
|
||||
|
|
|
@ -4,16 +4,16 @@
|
|||
\alias{calc_likelihood}
|
||||
\title{Generic Likelihood calculation}
|
||||
\usage{
|
||||
calc_likelihood(pmat, Inst, fun_types, par_index)
|
||||
calc_likelihood(pmat, inst, profile, ftypes, ft_index)
|
||||
}
|
||||
\arguments{
|
||||
\item{pmat}{the parameter vector}
|
||||
|
||||
\item{Inst}{the insrument as a list of its components}
|
||||
\item{inst}{the insrument as a list of its components}
|
||||
|
||||
\item{fun_types}{List of the utility, probability weighting, and stochstic function types}
|
||||
\item{ftypes}{List of the utility, probability weighting, and stochstic function types}
|
||||
|
||||
\item{par_index}{fun_types List of giving the index in the par vector of the parameters for each fun_type}
|
||||
\item{ft_index}{ftypes List of giving the index in the par vector of the parameters for each fun_type}
|
||||
}
|
||||
\description{
|
||||
Generic Likelihood calculation
|
||||
|
|
|
@ -4,16 +4,18 @@
|
|||
\alias{calc_utility}
|
||||
\title{Generic Utility calculation}
|
||||
\usage{
|
||||
calc_utility(pmat, Inst, fun_types, par_index)
|
||||
calc_utility(pmat, inst, profile, ftypes, ft_index)
|
||||
}
|
||||
\arguments{
|
||||
\item{pmat}{the parameter vector}
|
||||
|
||||
\item{Inst}{the insrument as a list of its components}
|
||||
\item{inst}{the insrument as a list of its components}
|
||||
|
||||
\item{fun_types}{List of the utility, probability weighting, and stochstic function types}
|
||||
\item{profile}{the profile of the instrument}
|
||||
|
||||
\item{par_index}{fun_types List of giving the index in the par vector of the parameters for each fun_type}
|
||||
\item{ftypes}{List of the utility, probability weighting, and stochstic function types}
|
||||
|
||||
\item{ft_index}{ftypes List of giving the index in the par vector of the parameters for each fun_type}
|
||||
}
|
||||
\description{
|
||||
Generic Utility calculation
|
||||
|
|
|
@ -1,11 +0,0 @@
|
|||
% Generated by roxygen2: do not edit by hand
|
||||
% Please edit documentation in R/RcppExports.R
|
||||
\name{list2_cube}
|
||||
\alias{list2_cube}
|
||||
\title{Turn list to cube object}
|
||||
\usage{
|
||||
list2_cube(Inst, out_prob)
|
||||
}
|
||||
\description{
|
||||
Turn list to cube object
|
||||
}
|
|
@ -4,16 +4,16 @@
|
|||
\alias{mlgeneral}
|
||||
\title{Return a likelihood vector for choices}
|
||||
\usage{
|
||||
mlgeneral(pmat, inst, fun_types, par_index)
|
||||
mlgeneral(pmat, inst, profile, ftypes, ft_index)
|
||||
}
|
||||
\arguments{
|
||||
\item{fun_types}{List of the utility, probability weighting, and stochstic function types}
|
||||
\item{inst}{the insrument as a list of its components}
|
||||
|
||||
\item{par_index}{fun_types List of giving the index in the par vector of the parameters for each fun_type}
|
||||
\item{ftypes}{List of the utility, probability weighting, and stochstic function types}
|
||||
|
||||
\item{ft_index}{ftypes List of giving the index in the par vector of the parameters for each fun_type}
|
||||
|
||||
\item{par}{the parameter vector}
|
||||
|
||||
\item{Inst}{the insrument as a list of its components}
|
||||
}
|
||||
\description{
|
||||
Return a likelihood vector for choices
|
||||
|
|
|
@ -44,41 +44,6 @@ RcppExport SEXP _rcguts_vpow(SEXP baseSEXP, SEXP expSEXP) {
|
|||
UNPROTECT(1);
|
||||
return rcpp_result_gen;
|
||||
}
|
||||
// list2_cube
|
||||
arma::cube list2_cube(List Inst, int out_prob);
|
||||
static SEXP _rcguts_list2_cube_try(SEXP InstSEXP, SEXP out_probSEXP) {
|
||||
BEGIN_RCPP
|
||||
Rcpp::RObject rcpp_result_gen;
|
||||
Rcpp::traits::input_parameter< List >::type Inst(InstSEXP);
|
||||
Rcpp::traits::input_parameter< int >::type out_prob(out_probSEXP);
|
||||
rcpp_result_gen = Rcpp::wrap(list2_cube(Inst, out_prob));
|
||||
return rcpp_result_gen;
|
||||
END_RCPP_RETURN_ERROR
|
||||
}
|
||||
RcppExport SEXP _rcguts_list2_cube(SEXP InstSEXP, SEXP out_probSEXP) {
|
||||
SEXP rcpp_result_gen;
|
||||
{
|
||||
Rcpp::RNGScope rcpp_rngScope_gen;
|
||||
rcpp_result_gen = PROTECT(_rcguts_list2_cube_try(InstSEXP, out_probSEXP));
|
||||
}
|
||||
Rboolean rcpp_isInterrupt_gen = Rf_inherits(rcpp_result_gen, "interrupted-error");
|
||||
if (rcpp_isInterrupt_gen) {
|
||||
UNPROTECT(1);
|
||||
Rf_onintr();
|
||||
}
|
||||
bool rcpp_isLongjump_gen = Rcpp::internal::isLongjumpSentinel(rcpp_result_gen);
|
||||
if (rcpp_isLongjump_gen) {
|
||||
Rcpp::internal::resumeJump(rcpp_result_gen);
|
||||
}
|
||||
Rboolean rcpp_isError_gen = Rf_inherits(rcpp_result_gen, "try-error");
|
||||
if (rcpp_isError_gen) {
|
||||
SEXP rcpp_msgSEXP_gen = Rf_asChar(rcpp_result_gen);
|
||||
UNPROTECT(1);
|
||||
Rf_error(CHAR(rcpp_msgSEXP_gen));
|
||||
}
|
||||
UNPROTECT(1);
|
||||
return rcpp_result_gen;
|
||||
}
|
||||
// gslikelihood
|
||||
arma::vec gslikelihood(std::string dfun, arma::vec Utilities);
|
||||
static SEXP _rcguts_gslikelihood_try(SEXP dfunSEXP, SEXP UtilitiesSEXP) {
|
||||
|
@ -115,23 +80,24 @@ RcppExport SEXP _rcguts_gslikelihood(SEXP dfunSEXP, SEXP UtilitiesSEXP) {
|
|||
return rcpp_result_gen;
|
||||
}
|
||||
// calc_utility
|
||||
arma::mat calc_utility(arma::mat pmat, List Inst, List fun_types, List par_index);
|
||||
static SEXP _rcguts_calc_utility_try(SEXP pmatSEXP, SEXP InstSEXP, SEXP fun_typesSEXP, SEXP par_indexSEXP) {
|
||||
arma::mat calc_utility(arma::mat pmat, DataFrame inst, List profile, List ftypes, List ft_index);
|
||||
static SEXP _rcguts_calc_utility_try(SEXP pmatSEXP, SEXP instSEXP, SEXP profileSEXP, SEXP ftypesSEXP, SEXP ft_indexSEXP) {
|
||||
BEGIN_RCPP
|
||||
Rcpp::RObject rcpp_result_gen;
|
||||
Rcpp::traits::input_parameter< arma::mat >::type pmat(pmatSEXP);
|
||||
Rcpp::traits::input_parameter< List >::type Inst(InstSEXP);
|
||||
Rcpp::traits::input_parameter< List >::type fun_types(fun_typesSEXP);
|
||||
Rcpp::traits::input_parameter< List >::type par_index(par_indexSEXP);
|
||||
rcpp_result_gen = Rcpp::wrap(calc_utility(pmat, Inst, fun_types, par_index));
|
||||
Rcpp::traits::input_parameter< DataFrame >::type inst(instSEXP);
|
||||
Rcpp::traits::input_parameter< List >::type profile(profileSEXP);
|
||||
Rcpp::traits::input_parameter< List >::type ftypes(ftypesSEXP);
|
||||
Rcpp::traits::input_parameter< List >::type ft_index(ft_indexSEXP);
|
||||
rcpp_result_gen = Rcpp::wrap(calc_utility(pmat, inst, profile, ftypes, ft_index));
|
||||
return rcpp_result_gen;
|
||||
END_RCPP_RETURN_ERROR
|
||||
}
|
||||
RcppExport SEXP _rcguts_calc_utility(SEXP pmatSEXP, SEXP InstSEXP, SEXP fun_typesSEXP, SEXP par_indexSEXP) {
|
||||
RcppExport SEXP _rcguts_calc_utility(SEXP pmatSEXP, SEXP instSEXP, SEXP profileSEXP, SEXP ftypesSEXP, SEXP ft_indexSEXP) {
|
||||
SEXP rcpp_result_gen;
|
||||
{
|
||||
Rcpp::RNGScope rcpp_rngScope_gen;
|
||||
rcpp_result_gen = PROTECT(_rcguts_calc_utility_try(pmatSEXP, InstSEXP, fun_typesSEXP, par_indexSEXP));
|
||||
rcpp_result_gen = PROTECT(_rcguts_calc_utility_try(pmatSEXP, instSEXP, profileSEXP, ftypesSEXP, ft_indexSEXP));
|
||||
}
|
||||
Rboolean rcpp_isInterrupt_gen = Rf_inherits(rcpp_result_gen, "interrupted-error");
|
||||
if (rcpp_isInterrupt_gen) {
|
||||
|
@ -152,23 +118,24 @@ RcppExport SEXP _rcguts_calc_utility(SEXP pmatSEXP, SEXP InstSEXP, SEXP fun_type
|
|||
return rcpp_result_gen;
|
||||
}
|
||||
// calc_likelihood
|
||||
arma::mat calc_likelihood(arma::mat pmat, List Inst, List fun_types, List par_index);
|
||||
static SEXP _rcguts_calc_likelihood_try(SEXP pmatSEXP, SEXP InstSEXP, SEXP fun_typesSEXP, SEXP par_indexSEXP) {
|
||||
arma::mat calc_likelihood(arma::mat pmat, DataFrame inst, List profile, List ftypes, List ft_index);
|
||||
static SEXP _rcguts_calc_likelihood_try(SEXP pmatSEXP, SEXP instSEXP, SEXP profileSEXP, SEXP ftypesSEXP, SEXP ft_indexSEXP) {
|
||||
BEGIN_RCPP
|
||||
Rcpp::RObject rcpp_result_gen;
|
||||
Rcpp::traits::input_parameter< arma::mat >::type pmat(pmatSEXP);
|
||||
Rcpp::traits::input_parameter< List >::type Inst(InstSEXP);
|
||||
Rcpp::traits::input_parameter< List >::type fun_types(fun_typesSEXP);
|
||||
Rcpp::traits::input_parameter< List >::type par_index(par_indexSEXP);
|
||||
rcpp_result_gen = Rcpp::wrap(calc_likelihood(pmat, Inst, fun_types, par_index));
|
||||
Rcpp::traits::input_parameter< DataFrame >::type inst(instSEXP);
|
||||
Rcpp::traits::input_parameter< List >::type profile(profileSEXP);
|
||||
Rcpp::traits::input_parameter< List >::type ftypes(ftypesSEXP);
|
||||
Rcpp::traits::input_parameter< List >::type ft_index(ft_indexSEXP);
|
||||
rcpp_result_gen = Rcpp::wrap(calc_likelihood(pmat, inst, profile, ftypes, ft_index));
|
||||
return rcpp_result_gen;
|
||||
END_RCPP_RETURN_ERROR
|
||||
}
|
||||
RcppExport SEXP _rcguts_calc_likelihood(SEXP pmatSEXP, SEXP InstSEXP, SEXP fun_typesSEXP, SEXP par_indexSEXP) {
|
||||
RcppExport SEXP _rcguts_calc_likelihood(SEXP pmatSEXP, SEXP instSEXP, SEXP profileSEXP, SEXP ftypesSEXP, SEXP ft_indexSEXP) {
|
||||
SEXP rcpp_result_gen;
|
||||
{
|
||||
Rcpp::RNGScope rcpp_rngScope_gen;
|
||||
rcpp_result_gen = PROTECT(_rcguts_calc_likelihood_try(pmatSEXP, InstSEXP, fun_typesSEXP, par_indexSEXP));
|
||||
rcpp_result_gen = PROTECT(_rcguts_calc_likelihood_try(pmatSEXP, instSEXP, profileSEXP, ftypesSEXP, ft_indexSEXP));
|
||||
}
|
||||
Rboolean rcpp_isInterrupt_gen = Rf_inherits(rcpp_result_gen, "interrupted-error");
|
||||
if (rcpp_isInterrupt_gen) {
|
||||
|
@ -189,23 +156,24 @@ RcppExport SEXP _rcguts_calc_likelihood(SEXP pmatSEXP, SEXP InstSEXP, SEXP fun_t
|
|||
return rcpp_result_gen;
|
||||
}
|
||||
// mlgeneral
|
||||
arma::vec mlgeneral(arma::mat pmat, List inst, List fun_types, List par_index);
|
||||
static SEXP _rcguts_mlgeneral_try(SEXP pmatSEXP, SEXP instSEXP, SEXP fun_typesSEXP, SEXP par_indexSEXP) {
|
||||
arma::vec mlgeneral(arma::mat pmat, DataFrame inst, List profile, List ftypes, List ft_index);
|
||||
static SEXP _rcguts_mlgeneral_try(SEXP pmatSEXP, SEXP instSEXP, SEXP profileSEXP, SEXP ftypesSEXP, SEXP ft_indexSEXP) {
|
||||
BEGIN_RCPP
|
||||
Rcpp::RObject rcpp_result_gen;
|
||||
Rcpp::traits::input_parameter< arma::mat >::type pmat(pmatSEXP);
|
||||
Rcpp::traits::input_parameter< List >::type inst(instSEXP);
|
||||
Rcpp::traits::input_parameter< List >::type fun_types(fun_typesSEXP);
|
||||
Rcpp::traits::input_parameter< List >::type par_index(par_indexSEXP);
|
||||
rcpp_result_gen = Rcpp::wrap(mlgeneral(pmat, inst, fun_types, par_index));
|
||||
Rcpp::traits::input_parameter< DataFrame >::type inst(instSEXP);
|
||||
Rcpp::traits::input_parameter< List >::type profile(profileSEXP);
|
||||
Rcpp::traits::input_parameter< List >::type ftypes(ftypesSEXP);
|
||||
Rcpp::traits::input_parameter< List >::type ft_index(ft_indexSEXP);
|
||||
rcpp_result_gen = Rcpp::wrap(mlgeneral(pmat, inst, profile, ftypes, ft_index));
|
||||
return rcpp_result_gen;
|
||||
END_RCPP_RETURN_ERROR
|
||||
}
|
||||
RcppExport SEXP _rcguts_mlgeneral(SEXP pmatSEXP, SEXP instSEXP, SEXP fun_typesSEXP, SEXP par_indexSEXP) {
|
||||
RcppExport SEXP _rcguts_mlgeneral(SEXP pmatSEXP, SEXP instSEXP, SEXP profileSEXP, SEXP ftypesSEXP, SEXP ft_indexSEXP) {
|
||||
SEXP rcpp_result_gen;
|
||||
{
|
||||
Rcpp::RNGScope rcpp_rngScope_gen;
|
||||
rcpp_result_gen = PROTECT(_rcguts_mlgeneral_try(pmatSEXP, instSEXP, fun_typesSEXP, par_indexSEXP));
|
||||
rcpp_result_gen = PROTECT(_rcguts_mlgeneral_try(pmatSEXP, instSEXP, profileSEXP, ftypesSEXP, ft_indexSEXP));
|
||||
}
|
||||
Rboolean rcpp_isInterrupt_gen = Rf_inherits(rcpp_result_gen, "interrupted-error");
|
||||
if (rcpp_isInterrupt_gen) {
|
||||
|
@ -376,11 +344,10 @@ static int _rcguts_RcppExport_validate(const char* sig) {
|
|||
static std::set<std::string> signatures;
|
||||
if (signatures.empty()) {
|
||||
signatures.insert("arma::mat(*vpow)(const arma::vec,const arma::vec)");
|
||||
signatures.insert("arma::cube(*list2_cube)(List,int)");
|
||||
signatures.insert("arma::vec(*gslikelihood)(std::string,arma::vec)");
|
||||
signatures.insert("arma::mat(*calc_utility)(arma::mat,List,List,List)");
|
||||
signatures.insert("arma::mat(*calc_likelihood)(arma::mat,List,List,List)");
|
||||
signatures.insert("arma::vec(*mlgeneral)(arma::mat,List,List,List)");
|
||||
signatures.insert("arma::mat(*calc_utility)(arma::mat,DataFrame,List,List,List)");
|
||||
signatures.insert("arma::mat(*calc_likelihood)(arma::mat,DataFrame,List,List,List)");
|
||||
signatures.insert("arma::vec(*mlgeneral)(arma::mat,DataFrame,List,List,List)");
|
||||
signatures.insert("arma::vec(*gsutility)(arma::vec,std::string,arma::vec)");
|
||||
signatures.insert("arma::vec(*gsdiscount)(arma::vec,std::string,arma::vec)");
|
||||
signatures.insert("arma::vec(*gsstochastic)(arma::vec,std::string,arma::vec,arma::vec)");
|
||||
|
@ -392,7 +359,6 @@ static int _rcguts_RcppExport_validate(const char* sig) {
|
|||
// registerCCallable (register entry points for exported C++ functions)
|
||||
RcppExport SEXP _rcguts_RcppExport_registerCCallable() {
|
||||
R_RegisterCCallable("rcguts", "_rcguts_vpow", (DL_FUNC)_rcguts_vpow_try);
|
||||
R_RegisterCCallable("rcguts", "_rcguts_list2_cube", (DL_FUNC)_rcguts_list2_cube_try);
|
||||
R_RegisterCCallable("rcguts", "_rcguts_gslikelihood", (DL_FUNC)_rcguts_gslikelihood_try);
|
||||
R_RegisterCCallable("rcguts", "_rcguts_calc_utility", (DL_FUNC)_rcguts_calc_utility_try);
|
||||
R_RegisterCCallable("rcguts", "_rcguts_calc_likelihood", (DL_FUNC)_rcguts_calc_likelihood_try);
|
||||
|
@ -407,11 +373,10 @@ RcppExport SEXP _rcguts_RcppExport_registerCCallable() {
|
|||
|
||||
static const R_CallMethodDef CallEntries[] = {
|
||||
{"_rcguts_vpow", (DL_FUNC) &_rcguts_vpow, 2},
|
||||
{"_rcguts_list2_cube", (DL_FUNC) &_rcguts_list2_cube, 2},
|
||||
{"_rcguts_gslikelihood", (DL_FUNC) &_rcguts_gslikelihood, 2},
|
||||
{"_rcguts_calc_utility", (DL_FUNC) &_rcguts_calc_utility, 4},
|
||||
{"_rcguts_calc_likelihood", (DL_FUNC) &_rcguts_calc_likelihood, 4},
|
||||
{"_rcguts_mlgeneral", (DL_FUNC) &_rcguts_mlgeneral, 4},
|
||||
{"_rcguts_calc_utility", (DL_FUNC) &_rcguts_calc_utility, 5},
|
||||
{"_rcguts_calc_likelihood", (DL_FUNC) &_rcguts_calc_likelihood, 5},
|
||||
{"_rcguts_mlgeneral", (DL_FUNC) &_rcguts_mlgeneral, 5},
|
||||
{"_rcguts_gsutility", (DL_FUNC) &_rcguts_gsutility, 3},
|
||||
{"_rcguts_gsdiscount", (DL_FUNC) &_rcguts_gsdiscount, 3},
|
||||
{"_rcguts_gsstochastic", (DL_FUNC) &_rcguts_gsstochastic, 4},
|
||||
|
|
|
@ -19,42 +19,33 @@ arma::mat vpow(const arma::vec base, const arma::vec exp) {
|
|||
return out;
|
||||
}
|
||||
|
||||
//' Turn list to cube object
|
||||
//'
|
||||
//' @export list2_cube
|
||||
// [[Rcpp::export]]
|
||||
arma::cube list2_cube(List Inst, int out_prob) {
|
||||
// out_prob 0 is outcomes, 1 is probs
|
||||
List outcomes_list = Inst["outcomes"];
|
||||
List probabilities_list = Inst["probabilities"];
|
||||
List times_list = Inst["times"];
|
||||
arma::cube inst_cube(DataFrame inst, List profile, std::string prof_val) {
|
||||
// Get the list for this profile value
|
||||
List val_prof = profile[prof_val];
|
||||
// The number of options
|
||||
arma::uword nopt = val_prof.length();
|
||||
// First outcome to determine dimensions for cube
|
||||
arma::vec prof_element = val_prof[0];
|
||||
// The number of columns for each option is the number of elements in this profile
|
||||
arma::uword ncol = prof_element.n_elem;
|
||||
// The number of rows for each option is the number of rows in the inst
|
||||
arma::uword nrow = inst.nrows();
|
||||
|
||||
// The number of outcomes - MUST BE THE SAME AS PROBABILITIES AND TIMES
|
||||
int noutcomes = outcomes_list.length();
|
||||
// Cube for this prof_val
|
||||
arma::cube out_cube(nrow, ncol, nopt);
|
||||
// Matrix for each slice
|
||||
arma::mat out_mat(nrow, ncol);
|
||||
|
||||
// First outcome
|
||||
arma::mat first = outcomes_list[0];
|
||||
int nrow = first.n_rows;
|
||||
int ncol = first.n_cols;
|
||||
|
||||
// Outcomes cube
|
||||
arma::cube outcomes(nrow, ncol, noutcomes);
|
||||
arma::cube probabilities(nrow, ncol, noutcomes);
|
||||
arma::cube times(nrow, ncol, noutcomes);
|
||||
|
||||
for (int s = 0 ; s < noutcomes ; s++) {
|
||||
outcomes.slice(s) = Rcpp::as<arma::mat>(outcomes_list[s]);
|
||||
probabilities.slice(s) = Rcpp::as<arma::mat>(probabilities_list[s]);
|
||||
times.slice(s) = Rcpp::as<arma::mat>(times_list[s]);
|
||||
}
|
||||
|
||||
if (out_prob == 0) {
|
||||
return(outcomes);
|
||||
}
|
||||
else if (out_prob == 1) {
|
||||
return(probabilities);
|
||||
}
|
||||
else {
|
||||
return(times);
|
||||
for (arma::uword s = 0 ; s < nopt ; s++) {
|
||||
// R indexes from 1, C++ from 0, so subtract 1 from the profile index
|
||||
prof_element = Rcpp::as<arma::colvec>(val_prof[s]) - 1;
|
||||
// Loop through the prof_element and add the corresponding column from
|
||||
// inst to the matrix for this option's value
|
||||
for (arma::uword i = 0; i < ncol; i ++) {
|
||||
out_mat.col(i) = Rcpp::as<arma::colvec>(inst[prof_element[i]]);
|
||||
}
|
||||
// Add in the matrix to this slice
|
||||
out_cube.slice(s) = out_mat;
|
||||
}
|
||||
return(out_cube);
|
||||
}
|
||||
|
|
92
src/main.cpp
92
src/main.cpp
|
@ -4,22 +4,29 @@
|
|||
#include "main.hpp"
|
||||
using namespace Rcpp;
|
||||
|
||||
|
||||
//' Generic Utility calculation
|
||||
//'
|
||||
//' @param pmat the parameter vector
|
||||
//' @param Inst the insrument as a list of its components
|
||||
//' @param fun_types List of the utility, probability weighting, and stochstic function types
|
||||
//' @param par_index fun_types List of giving the index in the par vector of the parameters for each fun_type
|
||||
//' @param inst the insrument as a list of its components
|
||||
//' @param profile the profile of the instrument
|
||||
//' @param ftypes List of the utility, probability weighting, and stochstic function types
|
||||
//' @param ft_index ftypes List of giving the index in the par vector of the parameters for each fun_type
|
||||
//' @export calc_utility
|
||||
// [[Rcpp::export]]
|
||||
arma::mat calc_utility(arma::mat pmat, List Inst, List fun_types, List par_index) {
|
||||
arma::mat calc_utility(arma::mat pmat, DataFrame inst, List profile, List ftypes, List ft_index) {
|
||||
|
||||
// First put everything into cubes
|
||||
arma::cube outcomes = list2_cube(Inst, 0);
|
||||
arma::cube probs = list2_cube(Inst, 1);
|
||||
arma::cube times = list2_cube(Inst, 2);
|
||||
arma::mat Max_Min = Inst["Max_Min"];
|
||||
arma::cube outcomes = inst_cube(inst, profile, "outcomes");
|
||||
arma::cube probs = inst_cube(inst, profile, "probabilities");
|
||||
arma::cube times = inst_cube(inst, profile, "times");
|
||||
|
||||
// Max and Min outcomes get a matrix
|
||||
arma::uword maxi = profile["Max"];
|
||||
arma::uword mini = profile["Min"];
|
||||
|
||||
arma::mat Max_Min(inst.rows(), 2);
|
||||
Max_Min.col(1) = Rcpp::as<arma::colvec>(inst[maxi]);
|
||||
Max_Min.col(2) = Rcpp::as<arma::colvec>(inst[mini]);
|
||||
|
||||
// To reconstruct the pointers we need some more info
|
||||
int nslice = outcomes.n_slices;
|
||||
|
@ -43,17 +50,17 @@ arma::mat calc_utility(arma::mat pmat, List Inst, List fun_types, List par_index
|
|||
double *likemat_mem = likemat.memptr();
|
||||
|
||||
// Get the function types
|
||||
std::string ufun = fun_types["ufun"];
|
||||
std::string pfun = fun_types["pfun"];
|
||||
std::string tfun = fun_types["tfun"];
|
||||
std::string sfun = fun_types["sfun"];
|
||||
std::string dfun = fun_types["dfun"];
|
||||
std::string ufun = ftypes["ufun"];
|
||||
std::string pfun = ftypes["pfun"];
|
||||
std::string tfun = ftypes["tfun"];
|
||||
std::string sfun = ftypes["sfun"];
|
||||
std::string dfun = ftypes["dfun"];
|
||||
|
||||
// Get the indicies of the parameters that need to be passed to each piece
|
||||
arma::uvec uind = par_index["ufun"];
|
||||
arma::uvec pind = par_index["pfun"];
|
||||
arma::uvec tind = par_index["tfun"];
|
||||
arma::uvec sind = par_index["sfun"];
|
||||
arma::uvec uind = ft_index["ufun"];
|
||||
arma::uvec pind = ft_index["pfun"];
|
||||
arma::uvec tind = ft_index["tfun"];
|
||||
arma::uvec sind = ft_index["sfun"];
|
||||
|
||||
// R indexes from 1, Rcpp from 0, so adjust each index down one.
|
||||
uind -= 1;
|
||||
|
@ -67,7 +74,7 @@ arma::mat calc_utility(arma::mat pmat, List Inst, List fun_types, List par_index
|
|||
arma::mat tpar = pmat.cols(tind);
|
||||
arma::mat spar = pmat.cols(sind);
|
||||
|
||||
// Just like with the about matricies, we need more info to reconstruct pointers
|
||||
// Just like with the above matricies, we need more info to reconstruct pointers
|
||||
int upar_num = upar.n_cols;
|
||||
int ppar_num = ppar.n_cols;
|
||||
int tpar_num = tpar.n_cols;
|
||||
|
@ -98,42 +105,44 @@ arma::mat calc_utility(arma::mat pmat, List Inst, List fun_types, List par_index
|
|||
stochastic(sfun, spar_mem, spar_num, U_mem, Max_Min_mem, nrow, nslice);
|
||||
|
||||
return(Utility);
|
||||
|
||||
}
|
||||
|
||||
//' Generic Likelihood calculation
|
||||
//'
|
||||
//' @param pmat the parameter vector
|
||||
//' @param Inst the insrument as a list of its components
|
||||
//' @param fun_types List of the utility, probability weighting, and stochstic function types
|
||||
//' @param par_index fun_types List of giving the index in the par vector of the parameters for each fun_type
|
||||
//' @param inst the insrument as a list of its components
|
||||
//' @param ftypes List of the utility, probability weighting, and stochstic function types
|
||||
//' @param ft_index ftypes List of giving the index in the par vector of the parameters for each fun_type
|
||||
//' @export calc_likelihood
|
||||
// [[Rcpp::export]]
|
||||
arma::mat calc_likelihood(arma::mat pmat, List Inst, List fun_types, List par_index) {
|
||||
arma::mat calc_likelihood(arma::mat pmat, DataFrame inst, List profile, List ftypes, List ft_index) {
|
||||
|
||||
// We need some information here
|
||||
List outcomes_list = Inst["outcomes"];
|
||||
// Get the list for this profile value
|
||||
List val_prof = profile["outcomes"];
|
||||
// The number of options
|
||||
int nslice = outcomes_list.length();
|
||||
// The number of rows and columns for each option
|
||||
arma::mat first_option = outcomes_list[0];
|
||||
int nrow = first_option.n_rows;
|
||||
int ncol = first_option.n_cols;
|
||||
arma::uword nopt = val_prof.length();
|
||||
// First outcome to determine dimensions for cube
|
||||
arma::vec prof_element = val_prof[0];
|
||||
// The number of columns for each option is the number of elements in this profile
|
||||
arma::uword ncol = prof_element.n_elem;
|
||||
// The number of rows for each option is the number of rows in the inst
|
||||
arma::uword nrow = inst.nrows();
|
||||
|
||||
// The Utility of each option
|
||||
arma::mat Utility = calc_utility(pmat, Inst, fun_types, par_index);
|
||||
arma::mat Utility = calc_utility(pmat, inst, profile, ftypes, ft_index);
|
||||
|
||||
// Pointer for utility
|
||||
double *U_mem = Utility.memptr();
|
||||
|
||||
// The likelihood of each option
|
||||
arma::mat likemat(nrow, nslice);
|
||||
arma::mat likemat(nrow, nopt);
|
||||
// Get the function types
|
||||
std::string dfun = fun_types["dfun"];
|
||||
std::string dfun = ftypes["dfun"];
|
||||
// Pointer for likelihood
|
||||
double *likemat_mem = likemat.memptr();
|
||||
|
||||
// Generate the likelihoods
|
||||
likelihood(dfun, likemat_mem, U_mem, nrow, nslice);
|
||||
likelihood(dfun, likemat_mem, U_mem, nrow, nopt);
|
||||
|
||||
return(likemat);
|
||||
}
|
||||
|
@ -141,18 +150,21 @@ arma::mat calc_likelihood(arma::mat pmat, List Inst, List fun_types, List par_in
|
|||
//' Return a likelihood vector for choices
|
||||
//'
|
||||
//' @param par the parameter vector
|
||||
//' @param Inst the insrument as a list of its components
|
||||
//' @param fun_types List of the utility, probability weighting, and stochstic function types
|
||||
//' @param par_index fun_types List of giving the index in the par vector of the parameters for each fun_type
|
||||
//' @param inst the insrument as a list of its components
|
||||
//' @param ftypes List of the utility, probability weighting, and stochstic function types
|
||||
//' @param ft_index ftypes List of giving the index in the par vector of the parameters for each fun_type
|
||||
//' @export mlgeneral
|
||||
// [[Rcpp::export]]
|
||||
arma::vec mlgeneral(arma::mat pmat, List inst, List fun_types, List par_index) {
|
||||
arma::vec mlgeneral(arma::mat pmat, DataFrame inst, List profile, List ftypes, List ft_index) {
|
||||
// Get the likelihoods for the options
|
||||
arma::mat likelihoods = calc_likelihood(pmat, inst, profile, ftypes, ft_index);
|
||||
// Grab the choice vector
|
||||
arma::vec choice = inst["choice"];
|
||||
arma::mat likelihoods = calc_likelihood(pmat, inst, fun_types, par_index);
|
||||
// Generate the final likelihood vector
|
||||
arma::vec like(likelihoods.n_rows);
|
||||
for (int r = 0; r < likelihoods.n_rows ; r++) {
|
||||
like(r) = likelihoods(r, choice(r));
|
||||
}
|
||||
return(like);
|
||||
}
|
||||
|
||||
|
|
14
src/main.hpp
14
src/main.hpp
|
@ -2,6 +2,14 @@
|
|||
#include <RcppArmadillo.h>
|
||||
using namespace Rcpp;
|
||||
|
||||
// Functions actually in the main file
|
||||
arma::mat calc_utility(arma::mat pmat, DataFrame inst, List profile, List ftypes, List ft_index);
|
||||
arma::vec gslikelihood(std::string sfun, arma::vec Utilities);
|
||||
|
||||
// Helper functions
|
||||
arma::mat vpow(const arma::vec base, const arma::vec exp);
|
||||
arma::cube inst_cube(DataFrame inst, List profile, std::string prof_val);
|
||||
|
||||
// Utility Functions
|
||||
void utility (std::string ufun, double* par_mem, int par_num, double* outs_mem, double* Max_Min_mem, int nrow, int ncol, int nslice);
|
||||
void ufx_ev (double* par_mem, int par_num, double *outs_mem, double *Max_Min_mem, int nrow, int ncol, int nslice);
|
||||
|
@ -43,9 +51,3 @@ arma::vec gsstochastic(arma::vec pars, std::string sfun, arma::vec Utilities, ar
|
|||
// Distribution functions for likelihoods
|
||||
void likelihood (std::string dfun, double* likemat_mem, double* U_mem, int nrow, int ncol);
|
||||
void like_logit (double* likemat_mem, double* U_mem, int nrow, int ncol);
|
||||
// Get the likelihood of each option given the adjusted utilities
|
||||
arma::vec gslikelihood(std::string sfun, arma::vec Utilities);
|
||||
|
||||
// Helper functions
|
||||
arma::mat vpow(const arma::vec base, const arma::vec exp);
|
||||
arma::cube list2_cube(List Inst, int out_prob);
|
||||
|
|
Loading…
Reference in New Issue