https://github.com/cran/unmarked
Tip revision: 0be1e45d20451fc1bfa4af3dbb1f5a1329689e21 authored by Richard Chandler on 25 June 2012, 00:00:00 UTC
version 0.9-8
version 0.9-8
Tip revision: 0be1e45
nll_distsamp.cpp
#include "nll_distsamp.h"
#include "detfuns.h"
SEXP nll_distsamp( SEXP y_, SEXP lam_, SEXP sig_, SEXP scale_, SEXP a_, SEXP u_, SEXP w_, SEXP db_, SEXP keyfun_, SEXP survey_, SEXP reltol_ ) {
Rcpp::IntegerMatrix y(y_);
Rcpp::NumericVector lam(lam_);
Rcpp::NumericVector sig(sig_);
double scale = Rcpp::as<double>(scale_);
Rcpp::NumericMatrix a(a_);
Rcpp::NumericMatrix u(u_);
Rcpp::NumericVector w(w_);
Rcpp::NumericVector db(db_);
std::string keyfun = Rcpp::as<std::string>(keyfun_);
std::string survey = Rcpp::as<std::string>(survey_);
int R = y.nrow(); //y.n_rows;
int J = y.ncol(); // y.n_cols;
// Integration settings given to Rdqags
// TODO: Allow for user-defined settings
double epsrel = Rcpp::as<double>(reltol_);
double epsabs = epsrel;
int limit = 100;
int lenw = 400;
int last = 0;
int iwork = 100;
double work = 400.0;
// double mu = 0.0;
double ll = 0.0;
// void *ex;
double *ex;
ex = (double *) R_alloc(2, sizeof(double));
for(int i=0; i<R; i++) {
for(int j=0; j<J; j++) {
double cp = 0.0;
ex[0] = sig(i);
ex[1] = scale;
if(keyfun=="uniform") {
cp = u(i,j);
} else {
double lower = db[j];
double upper = db[j+1];
double result = 0.0;
double abserr = 0.0;
int neval = 0;
int ier = 0;
if(survey=="point") {
if(keyfun=="halfnorm") {
Rdqags(grhn, ex, &lower, &upper, &epsabs, &epsrel, &result,
&abserr, &neval, &ier, &limit, &lenw, &last, &iwork,
&work);
} else if(keyfun=="exp") {
Rdqags(grexp, ex, &lower, &upper, &epsabs, &epsrel, &result,
&abserr, &neval, &ier, &limit, &lenw, &last, &iwork,
&work);
} else if(keyfun=="hazard") {
Rdqags(grhaz, ex, &lower, &upper, &epsabs, &epsrel, &result,
&abserr, &neval, &ier, &limit, &lenw, &last, &iwork,
&work);
}
cp = result * M_2PI / a(i,j) * u(i,j); // M_2PI is 2*pi
} else if(survey=="line") {
if(keyfun=="halfnorm") {
Rdqags(gxhn, ex, &lower, &upper, &epsabs, &epsrel, &result,
&abserr, &neval, &ier, &limit, &lenw, &last, &iwork,
&work);
} else if(keyfun=="exp") {
Rdqags(gxexp, ex, &lower, &upper, &epsabs, &epsrel, &result,
&abserr, &neval, &ier, &limit, &lenw, &last, &iwork,
&work);
} else if(keyfun=="hazard") {
Rdqags(gxhaz, ex, &lower, &upper, &epsabs, &epsrel, &result,
&abserr, &neval, &ier, &limit, &lenw, &last, &iwork,
&work);
}
cp = result / w(j) * u(i,j);
}
}
/* add error checking/handling here, ier>0 */
ll += Rf_dpois(y(i,j), lam(i)*cp, true);
}
}
return Rcpp::wrap(-ll);
}