/**
* Compute the covvariance array for AR1 case
* This is based on the parameter rho.
* This is done in two steps:
* 1) fist calculate the correlation matrix dCor given phi
* 2) Get the mle estimate of m_sig2 given the correlation.
**/
void logistic_normal::compute_covariance_matrix(const dvariable& phi)
{
m_V.allocate(m_y1,m_y2,m_b1,m_nB2-1,m_b1,m_nB2-1);
m_V.initialize();
dvar3_array dCor(m_y1,m_y2,m_b1,m_nB2,m_b1,m_nB2);
dCor.initialize();
int i,j,k,nb;
for( i = m_y1; i <= m_y2; i++ )
{
nb = m_nB2(i);
dCor(i) = identity_matrix(m_b1,nb);
// 2). Compute the vector of coefficients.
dvar_vector drho(m_b1,nb);
for( j = m_b1; j <= nb; j++ )
{
drho(j) = pow(phi,j-m_b1+1);
}
// 3). Compute correlation matrix dCor
for( j = m_b1; j <= nb; j++ )
{
for( k = m_b1; k <= nb; k++ )
{
if( j != k ) dCor(i)(j,k) = drho(m_b1+abs(j-k));
}
}
m_V(i) = trans(trans(dCor(i).sub(m_b1,nb-1)).sub(m_b1,nb-1));
}
// compute mle estimate of sigma
compute_mle_sigma(m_V);
// cout<<"Got to here sigma = "<<m_sig<<endl;
for( i = m_y1; i <= m_y2; i++ )
{
nb = m_nB2(i);
for( j = m_b1; j <= nb; j++ )
{
dCor(i).rowfill(j, extract_row(dCor(i),j)*m_sig );
}
for( k = m_b1; k <= nb; k++ )
{
dCor(i).colfill(k, extract_column(dCor(i),k)*m_sig );
}
//cout<<dCor(i)<<endl;
// Kmat
dmatrix I = identity_matrix(m_b1,nb-1);
dmatrix tKmat(m_b1,nb,m_b1,nb-1);
tKmat.sub(m_b1,nb-1) = I;
tKmat(nb) = -1;
dmatrix Kmat = trans(tKmat);
m_V(i) = Kmat * dCor(i) * tKmat;
}
}
/***********************************************************************//**
* @brief Unary matrix multiplication operator
*
* @param[in] matrix Matrix.
*
* @exception GException::matrix_mismatch
* Incompatible matrix size.
*
* This method performs a matrix multiplication. The operation can only
* succeed when the dimensions of both matrices are compatible.
*
* In case of rectangular matrices the result matrix does not change and
* the operation is performed inplace. For the general case the result
* matrix changes in size and for simplicity a new matrix is allocated to
* hold the result.
***************************************************************************/
GMatrix& GMatrix::operator*=(const GMatrix& matrix)
{
// Raise an exception if the matrix dimensions are not compatible
if (m_cols != matrix.m_rows) {
throw GException::matrix_mismatch(G_OP_MAT_MUL,
m_rows, m_cols,
matrix.m_rows, matrix.m_cols);
}
// Case A: Matrices are rectangular, so perform 'inplace' multiplication
if (m_rows == m_cols) {
for (int row = 0; row < m_rows; ++row) {
GVector v_row = extract_row(row);
for (int col = 0; col < m_cols; ++col) {
double sum = 0.0;
for (int i = 0; i < m_cols; ++i) {
sum += v_row[i] * matrix(i,col);
}
(*this)(row,col) = sum;
}
}
}
// Case B: Matrices are not rectangular, so we cannot work inplace
else {
// Allocate result matrix
GMatrix result(m_rows, matrix.m_cols);
// Loop over all elements of result matrix
for (int row = 0; row < m_rows; ++row) {
for (int col = 0; col < matrix.m_cols; ++col) {
double sum = 0.0;
for (int i = 0; i < m_cols; ++i) {
sum += (*this)(row,i) * matrix(i,col);
}
result(row,col) = sum;
}
}
// Assign result
*this = result;
} // endelse: matrices were not rectangular
// Return result
return *this;
}
SEXP get_pi (SEXP Rpostmat,
SEXP Rfun,
SEXP Rr,
SEXP Rr_low,
SEXP Rinds,
SEXP Rxcol,
SEXP Rycol) {
SEXP rc = R_NilValue;
int i,j,k;
double dist;
int num_cnt, denom_cnt; /*counters for those filling conditions*/
int f_ans; /*used to hold the result of the function*/
/*turn all of the R stuff passed in to the type of stuff we can
referene in C*/
double *r = REAL(Rr);
double *r_low = REAL(Rr_low);
int *inds = INTEGER(Rinds);
int xcol = INTEGER(Rxcol)[0]-1;
int ycol = INTEGER(Rycol)[0]-1;
SEXP postmat_dim = getAttrib(Rpostmat, R_DimSymbol);
double *postmat = REAL(Rpostmat);
int rows = INTEGER(postmat_dim)[0];
/*some sanity checking*/
if (!isFunction(Rfun)) error("Rfun must be a function");
/*prepare the return information*/
PROTECT(rc=allocVector(REALSXP, length(Rr)));
/*repeat calculation for all r*/
for (i=0;i<length(Rr);i++) {
//Rprintf("%1.1f,%1.1f\n", r_low[i],r[i]); //DEBUG
/*zero out counts*/
num_cnt = 0;
denom_cnt = 0;
/*might be faster to have some scraning criteria, but
we will loop throufh every pair...j is from */
for (j=0;j<rows;j++) {
/*k is to*/
for (k=0; k<rows;k++) {
/*do not compare someone with themself*/
if (inds[k] == inds[j]) continue;
/*calculate the distance*/
dist = sqrt(pow(postmat[j+xcol*rows] - postmat[k+xcol*rows],2) +
pow(postmat[j+ycol*rows] - postmat[k+ycol*rows],2));
if ((dist>r[i]) | (dist<r_low[i])) continue;
/*call the user supplied function*/
f_ans = (int)run_fun(Rfun,
extract_row(Rpostmat,j),
extract_row(Rpostmat,k));
/*update the counts appropriately*/
if (f_ans==1) {
denom_cnt++;
num_cnt++;
} else if (f_ans==2) {
denom_cnt++;
}
}
}
//Rprintf("%d/%d\n",num_cnt,denom_cnt); // DEBUG
REAL(rc)[i] = (double)num_cnt/denom_cnt;
}
UNPROTECT(1);
return(rc);
}
/**
* Compute the covvariance array for AR2 case
* This is based on the parameters rho and psi.
* Note that phi1 is bounded (-1,1)
* Then set phi2 = -1 + (1 + |phi1|)*psi
* and psi is bounded (0,1)
* This implies the upper bound for phi2 is 1.0 when |phi1|= 1 and psi = 1
**/
void logistic_normal::compute_covariance_matrix(const dvariable& phi1, const dvariable& psi)
{
m_V.allocate(m_y1,m_y2,m_b1,m_nB2-1,m_b1,m_nB2-1);
m_V.initialize();
dvar3_array dCor(m_y1,m_y2,m_b1,m_nB2,m_b1,m_nB2);
dCor.initialize();
int i,j,k,nb;
for( i = m_y1; i <= m_y2; i++ )
{
nb = m_nB2(i);
// dmatrix I = identity_matrix(m_b1,nb-1);
// m_V(i) = I;
dCor(i) = identity_matrix(m_b1,nb);
// 2). Compute the vector of coefficients.
dvariable phi2 = -1. + (1. + sfabs(phi1)) * psi;
dvar_vector drho(m_b1-1,nb-1);
drho = 1.0;
drho(m_b1) = phi1 / (1.0 - phi2);
for( j = m_b1+1; j <= nb-1; j++ )
{
drho(j) = phi1*drho(j-1) + phi2*drho(j-2);
}
// 3). Compute correlation matrix m_V
for( j = m_b1; j < nb; j++ )
{
for( k = m_b1; k < nb; k++ )
{
//if( j != k ) m_V(i)(j,k) = drho(m_b1+abs(j-k));
if( j != k ) dCor(i)(j,k) = drho(m_b1+abs(j-k));
}
}
m_V(i) = trans(trans(dCor(i).sub(m_b1,nb-1)).sub(m_b1,nb-1));
}
// compute mle estimate of sigma
compute_mle_sigma(m_V);
for( i = m_y1; i <= m_y2; i++ )
{
nb = m_nB2(i);
for( j = m_b1; j < nb; j++ )
{
m_V(i).rowfill(j, extract_row(m_V(i),j) * m_sig );
}
for( k = m_b1; k < nb; k++ )
{
m_V(i).colfill(k, extract_column( m_V(i),k ) * m_sig );
}
// Kmat
dmatrix I = identity_matrix(m_b1,nb-1);
dmatrix tKmat(m_b1,nb,m_b1,nb-1);
tKmat.sub(m_b1,nb-1) = I;
tKmat(nb) = -1;
dmatrix Kmat = trans(tKmat);
m_V(i) = Kmat * dCor(i) * tKmat;
}
}
