https://github.com/cran/GAS
Raw File
Tip revision: e588e3a10bf22cb7dff4a49a848baac63d743c3f authored by Leopoldo Catania on 04 February 2022, 09:30:12 UTC
version 0.3.4
Tip revision: e588e3a
snorm2.cpp
#include <RcppArmadillo.h>
#include "ber.h"
#include "Utils.h"

using namespace arma;
using namespace Rcpp;

double dSNORM2(double dY, double dMu, double dSigma2, double dDelta, bool bLog = false){

  double dLPDF = log(2.0*dDelta) - log(1.0 + pow(dDelta, 2.0)) - 0.5*log(dSigma2);

  double dZ = 0.0;

  if (dY < dMu){
    dZ = (dDelta*(dY - dMu))/pow(dSigma2, 0.5);
  }else{
    dZ = (dY - dMu)/(dDelta * pow(dSigma2, 0.5));
  }

  dLPDF += Rf_dnorm4(dZ, 0.0, 1.0, 1);

  if(!bLog) dLPDF = exp(dLPDF);

  return dLPDF;

}


double pSNORM2(double dY, double dMu, double dSigma2, double dDelta){

  double dP = 0.0;

  double dZ = 0.0;

  if (dY < dMu){

    dZ = (dDelta*(dY - dMu))/pow(dSigma2, 0.5);

    dP = 2.0/(1.0 + pow(dDelta, 2.0)) * Rf_pnorm5(dZ, 0.0,1.0,1,0);

  }else{

    dZ = (dY - dMu)/(dDelta * pow(dSigma2, 0.5));

    dP = (1.0 - pow(dDelta, 2.0))/ (1.0 + pow(dDelta, 2.0)) +  2.0 * pow(dDelta, 2.0)/(1.0 + pow(dDelta, 2.0)) * Rf_pnorm5(dZ, 0.0,1.0,1,0);

  }

  return dP;

}


double rSNORM2(double dMu, double dSigma2, double dDelta){

  double dZ0 = Rf_rnorm(0.0, 1.0);
  double dZ1 = Rf_rnorm(0.0, 1.0);

  double dPi = 1.0/(1.0 + pow(dDelta, 2.0));

  double dU = rBER(dPi);

  double dY = dMu + pow(dSigma2, 0.5) * (dDelta*(1.0 - dU)*abs3(dZ0) - dU*abs3(dZ1)/dDelta);

  return dY;

}


double qSNORM2(double dP, double dMu, double dSigma2, double dDelta,
            double lower=-150, double upper=150, int maxiter=1e4, double eps=1e-7) {
  double a=lower;
  double b=upper;

  double x=lower;
  double x1=upper;
  int iter = 1;
  double fa,fx;
  //check
  fa = pSNORM2(a,  dMu, dSigma2, dDelta) - dP;
  fx = pSNORM2(x1, dMu, dSigma2, dDelta) - dP;

  if(fa*fx>0){
    Rprintf("Bisection Error: upper and lower function evaluations have same sign");
    return NA_LOGICAL;
  }

  do
  {
    fa=pSNORM2(a, dMu, dSigma2, dDelta) - dP;
    fx=pSNORM2(x, dMu, dSigma2, dDelta) - dP;

    if (fa*fx < 0){
      b=x;
    }else{
      a=x;
    }

    x1=(a+b)/2.0;
    iter++;

    if (abs3(x1-x) < eps)
    {
      return x1;
    }
    x=x1;
  }while(iter<maxiter);

  Rprintf("Bisection Warning: Maximum numeber of iteration reached");
  return NA_LOGICAL;
}


arma::vec mSNORM2(double dMu, double dSigma2, double dDelta){
  arma::vec vMoments(4);

  double dSigma = pow(dSigma2, 0.5);
  double dDelta2 = pow(dDelta, 2.0);

  vMoments(0) = dMu + pow(2.0, 0.5)*dSigma*(dDelta2 - 1.0)/(pow(M_PI, 0.5)*dDelta);
  vMoments(1) = (dSigma2*((M_PI - 2.0)*pow(dDelta, 6.0) + 2.0*dDelta2*(dDelta2 + 1.0) + M_PI - 2.0))/(M_PI * dDelta2*(1.0 + dDelta2));
  vMoments(2) = pow(2.0, 0.5)*(1.0 - dDelta2)*pow(1.0 + dDelta2, 0.5)*((M_PI - 4.0)*pow(dDelta, 6.0) + 2.0*(2.0 - M_PI)*dDelta2*(1.0 + dDelta2) + M_PI - 4.0)/pow((M_PI - 2.0)*pow(dDelta, 6.0) + 2.0*dDelta2*(1.0 + dDelta2) + (M_PI - 2.0), 3.0/2.0);
  vMoments(3) = ( (1.0 + dDelta2)*((3.0*pow(M_PI, 2.0)- 4.0*M_PI - 12.0)*(pow(dDelta, 10.0) + 1.0) + 4.0*(9.0 - 2.0*M_PI)*dDelta2*(pow(dDelta, 6.0) + 1.0)) )/pow( (M_PI - 2.0)*pow(dDelta, 6.0) + 2.0*dDelta2*(1.0 + dDelta2) + (M_PI - 2.0), 2.0) +
                (1.0 + dDelta2)*(12.0*(M_PI - 2.0)*pow(dDelta, 4.0)*(dDelta2 + 1.0))/pow((M_PI - 2.0)*pow(dDelta, 6.0) + 2.0*dDelta2*(1.0 + dDelta2) + (M_PI - 2.0), 2.0);

  return vMoments;

}

arma::vec SNORM2_Score(double dY, arma::vec vTheta){

  double dMu     = vTheta(0);
  double dSigma2 = vTheta(1);
  double dDelta  = vTheta(2);

  double dDelta2 = pow(dDelta, 2.0);

  arma::vec vScore(3);

  double dI = 1.0;
  if(dY >= dMu) dI = 0.0;

  double dI_c = 1.0 - dI;

  double ddMu     = dDelta2/dSigma2 * (dY - dMu)*dI + dI_c*(dY - dMu)/(dDelta2*dSigma2);
  double ddSigma2 = -1.0/(2.0*dSigma2) + dDelta2*pow(dY - dMu, 2.0)/(2.0*pow(dSigma2, 2.0)) * dI + dI_c*pow(dY - dMu, 2.0)/(2.0*dDelta2*pow(dSigma2, 2.0));
  double ddDelta  = 1.0/dDelta - 2.0*dDelta/(1.0 + dDelta2) - dDelta/dSigma2 * pow(dY - dMu, 2.0)*dI + dI_c * pow(dY - dMu, 2.0)/(pow(dDelta, 3.0)*dSigma2);

  vScore(0) = ddMu;
  vScore(1) = ddSigma2;
  vScore(2) = ddDelta;

  return vScore;
}

arma::mat SNORM2_IM(arma::vec vTheta){

  double dSigma2 = vTheta(1);
  double dDelta  = vTheta(2);
  double dDelta2 = pow(dDelta, 2.0);

  arma::mat mIM = zeros(3,3);

  double uu = 1.0/dSigma2;
  double tu = 8.0/(pow(2.0*M_PI*dSigma2, 0.5)*(1.0 + dDelta2));
  double dd = 1.0/(2.0*pow(dSigma2, 2.0));
  double td = (dDelta2 - 1.0)/(dDelta*(1.0 + dDelta2)*dSigma2);
  double tt = 2.0/dDelta2 + 4.0/pow(1.0 + dDelta2 , 2.0);

  mIM(0,0) = uu;
  mIM(2,0) = tu;
  mIM(0,2) = tu;
  mIM(1,1) = dd;
  mIM(2,1) = td;
  mIM(1,2) = td;
  mIM(2,2) = tt;

  return mIM;

}
back to top