arma::vec cpp_UpdateBeta (arma::mat x_small, arma::vec weights_small,
                          arma::vec y_small, arma::mat x_big, 
                          arma::vec weights_big, arma::vec y_big, 
                          arma::vec gamma) {
  // This is a simple helper function used within the solver for 
  // weighted linear regression with an l1 penalty. 
  //
  // Args:
  //    gamma: The current estimate of gamma, used to update beta. 
  //    ...: For all other arguments see cpp_SolveL1Linear.
  // Returns:
  //    beta: The update of the parameter vector beta.
  
  // Obtain the matrix W * X where W is the diagonal weight matrix
  arma::mat weighted_X_small(x_small.begin(), x_small.n_rows, x_small.n_cols, true);
  arma::mat weighted_X_big(x_big.begin(), x_big.n_rows, x_big.n_cols, true);
  
  weighted_X_small.each_col()  %= weights_small;
  weighted_X_big.each_col()  %= weights_big;
  
  // Update beta by a simple least squares like update.
  arma::vec beta;
  beta = inv(x_small.t() * weighted_X_small + x_big.t() * weighted_X_big) * 
        (weighted_X_small.t() * y_small + weighted_X_big.t() * y_big - 
         x_big.t() * weighted_X_big * gamma);
  return beta;
}
// this function sample the loading parameters considering constant 
//  observational variance.
// [[Rcpp::export]]
arma::mat SampleDfmLoads(arma::mat y, arma::mat factors, arma::vec psi, 
  int s, double c0)
{
  /**
   * The data matrix 'y' is (T \times q).
   * Note that the factors matrix is (T+h \times k). In the models considered
   *  in the dissertation, h > s. This means that we always have the 
   *  VAR order, 'h', greater than the number of dynamic factors, 's', in the 
   *  observational equation. 
   * The argument 's' is the order of the dynamic factors present in the
   *  observational equation.
   * The prior mean is set to zero.
   */
   
  int T = y.n_rows;
  int q = y.n_cols;;
  int k = factors.n_cols;
  int TpH = factors.n_rows;
  int h = TpH - T;
  if (h < s+1){
    throw std::range_error(
      "Argument 's' greater than or equal to factors' VAR order in SampleDfmLoads.cpp"
      );
  }
  arma::mat I_q = eye(q, q);
//  std::cout << "\nh = " << h << "\n";
  arma::mat Xlambda;
  Xlambda = factors.rows(h, TpH-1);
//  std::cout << "\nNumber of rows in Xlambda is " << Xlambda.n_rows << "\n";
  if (s > 0){
    for (int i = 1; i <= s; i++){
    Xlambda = arma::join_rows(Xlambda, factors.rows(h-i, TpH-i-1));
    }
  }
  
  // posterior variance
  arma::mat Eigvec;
  arma::vec eigval;
  
  arma::eig_sym(eigval, Eigvec, arma::symmatu(Xlambda.t() * Xlambda));
  
  arma::mat kronEig = kron(I_q, Eigvec);  
  arma::vec L1eigval = 1.0/(arma::kron((1.0/psi), eigval) + 1/c0);
  arma::mat L1 = kronEig * diagmat(L1eigval) * kronEig.t();
  
  // posterior mean
  arma::vec yStar(y.begin(),  T*q);
  arma::vec l1 = L1 * (arma::kron(arma::diagmat(1.0/psi), Xlambda.t()) * yStar);
  arma::mat l1Mat(l1.begin(), k*(s+1), q); // mean in matrix form
  
  // random generation
  arma::vec vecnorm = sqrt(L1eigval) % randn(q*k*(s+1), 1);  
  arma::mat LambdaBar(vecnorm.begin(), k*(s+1), q, false);
  LambdaBar = l1Mat + Eigvec * LambdaBar;
  
  return LambdaBar.t();
}
Exemple #3
0
//[[Rcpp::export]]
IntegerVector whichNA(arma::mat X) {
  NumericVector x(X.begin(), X.end());
  int n = x.size();
  IntegerVector y = seq_len(n);//(x.begin(), x.end());
  IntegerVector z = y[is_na(x)];
  if(z.size()==0)
    std::cout << "\nNenhum valor faltante.\n";
  return z;
}
Exemple #4
0
 /** \brief Extracts the data and passes it to the kmeans algorithm
  * \param[in] model An ESBTL Protein model
  * \param[in] An armadillo matrix, will get overwritten
  * \return A labeling vector
  * */
 arma::urowvec
   operator() (const ESBTL::Default_system::Model& model, arma::mat & data) {
     data = arma::mat(3, (unsigned int) std::distance(model.atoms_begin(), model.atoms_end()));
     auto mat_it = data.begin();
     for (ESBTL::Default_system::Model::Atoms_const_iterator it_atm=model.atoms_begin();it_atm!=model.atoms_end();++it_atm){
       *(mat_it++) = it_atm->x();
       *(mat_it++) = it_atm->y();
       *(mat_it++) = it_atm->z();
     }
     data = transformation_(data);
     arma::urowvec labels = kmeans(data, params_);
     return labels;
   }
// [[Rcpp::export]]
arma::mat cpp_GenerateWeightMat(double lambda, arma::mat x_small, 
                           arma::mat x_big, arma::mat x_test, 
                           arma::vec mu_small, arma::vec mu_big) {
  // This function is the c++ implementation of the function
  // GenerateWrightMat. For details see helper_functions.R
  //
  // Args:
  //    Note: The arguments remain unchanged. The notation is slightly changed
  //    because in C++ we cannot name objects with '.' and hence is replaced by 
  //    '_' for object names.
  
  int N_small = x_small.n_rows;
  int N_big = x_big.n_rows;
  // int N_test = x_test.n_rows;
  int p = x_small.n_cols;
  
  arma::mat cov_small(x_small.begin(), N_small, p, true);
  cov_small.each_col() %= mu_small % (1 - mu_small);
  cov_small = trans(x_small) * cov_small;
  
  arma::mat cov_big(x_big.begin(), N_big, p, true);
  cov_big.each_col() %= mu_big % (1 - mu_big);
  cov_big = trans(x_big) * cov_big;
  
  arma::mat cov_test = trans(x_test) * x_test;
  
  arma::mat temp_matrix = cov_test * inv_sympd(cov_big) * cov_small;
  arma::mat weight_matrix = cov_small + lambda * (cov_test + temp_matrix);
  weight_matrix = inv(weight_matrix) * (cov_small + lambda * temp_matrix);

  // In case we would like these quantities.
  // arma::mat cov_beta_small = inv(cov_small);
  // arma::mat cov_beta_lambda = inv(cov_small + cov_big  - 
  //                                cov_big * inv_sympd(cov_test) * cov_big/lambda);
  
  return weight_matrix;
}
arma::vec cpp_UpdateGamma (arma::mat x_big, arma::vec weights_big,
                           arma::vec y_big, 
                           arma::vec gamma, arma::vec beta, 
                           double lambda) {
  // Another helper function used by the main algorithm.
  // In this algorithm we loop through and do a coordinate wise update of
  // gamma.
  // 
  // Agrs: 
  //    beta/gamma: The 'current' parameter vectors.
  //    x/weights/y_big: Design, weights and response for the big population.
  //    lambda: The value of the penalty parameter.
  // Returns:
  //    gamma: The updated gamma vector. 
  

  // Obtain value of dimension.
  int p = gamma.size();
  
  // Initialize matrix X * beta. 
  arma::mat x_beta = x_big * beta;
  
  // We need the diagonal entries of X^T * W * X.
  // This is easy when W is a diagonal matrix.
  arma::mat W_times_X(x_big.begin(), x_big.n_rows, x_big.n_cols, true);
  W_times_X.each_col() %= weights_big;
  // We obtain the diagonal entries of X^T * W * X for the denominators.
  arma::mat Xt_W_X = x_big.t() * W_times_X;
  arma::vec denoms = Xt_W_X.diag();
  
  // Some temporary vectors which we use later.
  arma::vec temp_gamma(gamma.begin(), gamma.size(), true);
  double temp1;
  
  // Loop through the different gamma values which need to be updated.
  for(int i = 0; i < p; i++) {
    // Instead of excluding a column we simply set gamma_j = 0 to get the fitted
    // value without the effect of gamma_j.
    temp_gamma(i) = 0;
    temp1 = as_scalar(x_big.col(i).t() * (weights_big % (y_big - x_beta - x_big * temp_gamma)));
    gamma(i) = (cpp_sign(temp1) * cpp_max(abs(temp1) - lambda, 0.0))/denoms(i);
    
    temp_gamma(i) = gamma(i);
    
  }
  return gamma;
}
Exemple #7
0
//[[Rcpp::export]]
Rcpp::List changeNA(arma::mat X) {
  NumericVector x(X.begin(), X.end());
  int n = x.size();
  IntegerVector y = seq_len(n)-1;//(x.begin(), x.end());
  IntegerVector z = y[is_na(x)];
  if(z.size()==0){
    std::cout << "Nenhum valor faltante.\n";
    SEXP xNULL = R_NilValue;
    return Rcpp::List::create(xNULL);  
  } else{
    arma::uvec Xna = as<arma::uvec>(z);
    NumericVector bx(Xna.n_rows, 100.0);
    arma::vec b = as<arma::vec>(bx);
    X.elem(Xna) = b;
    return Rcpp::List::create(X);
  }  
}
Exemple #8
0
 /** \brief Extracts the data and passes it to the kmeans algorithm
  * \param[in] model An ESBTL Protein model
  * \param[in] An armadillo matrix, will get overwritten
  * \return A labeling vector
  */
 arma::urowvec
   operator() (const ESBTL::Default_system::Model& model, arma::mat & data) {
     data = arma::mat(3, (unsigned int) std::distance(model.atoms_begin(), model.atoms_end()));
     arma::urowvec labels = arma::urowvec(data.n_cols);
     unsigned int * label_it = labels.begin();
     unsigned int label = 0;
     auto mat_it = data.begin();
     for (ESBTL::Default_system::Model::Chains_const_iterator it_cha=model.chains_begin();it_cha!=model.chains_end();++it_cha){
       for (ESBTL::Default_system::Model::Chain::Atoms_const_iterator it_atm = it_cha->atoms_begin(); it_atm != it_cha->atoms_end(); ++it_atm) {
         *(mat_it++) = it_atm->x();
         *(mat_it++) = it_atm->y();
         *(mat_it++) = it_atm->z();
         *(label_it++) = label;
       }
       ++label;
     }
     return labels;
   }
//[[Rcpp::export]]
arma::vec cpp_SolveLogistic(arma::mat X, arma::vec y, 
                            arma::vec initial_beta,
                            int max_iter = 100, 
                            double tol = 1e-5) {
  // The C++ implementation of the function SolveLogistic.
  // One main difference is that I cannot figure out how to pass null values
  // to c++. In this case an initial estimate of beta is required.
  
  // Initialize some vectors
  arma::vec beta(initial_beta.begin(), initial_beta.size(), false);
  arma::vec beta_new = beta;
  arma::vec mu_current = cpp_GetFittedValues(X, beta);
  
  // Begin main loop.
  for (int i = 1; i <= max_iter; i++) {
    // Set current vector of fitted values.
    mu_current = cpp_GetFittedValues(X, beta);
    
    // Evaluate V * X where V is the diagonal variance matrix.
    arma::mat var_times_X(X.begin(), X.n_rows, X.n_cols, true);
    var_times_X.each_col() %= mu_current % (1 - mu_current);
    
    // Update beta.
    beta_new = beta + inv(trans(X) * var_times_X) * (trans(X) * (y - mu_current));
    
    // Check for convergence.
    if (sum(pow(beta_new - beta, 2)) < tol) {
      return beta_new;
    } else {
      beta = beta_new;
    }
  }
  
  // Throw warning if it did not converge.
  Function warning("warning");
  warning("The newton-raphson algorithm did not converge.");
  
  // Return the non-converged beta vector.
  return beta_new;
}
Exemple #10
0
////> Main function ////
// [[Rcpp::export]]
List calcPotts_cpp (const S4& W_SR, const S4& W_LR, arma::mat sample, NumericVector rho, const arma::mat& coords, 
                    const IntegerVector& site_order, int iter_max, double cv_criterion, 
                    bool test_regional, NumericVector distance_ref, double threshold, double neutre, int nbGroup_min, bool multiV, bool last_vs_others, 
                    bool prior, bool type_reg, int verbose){
  
  //// preparation
  int p = sample.n_cols;
  int n = sample.n_rows;
  
  IntegerVector W_SRi = W_SR.slot("i");
  IntegerVector W_SRp = W_SR.slot("p");
  NumericVector W_SRx = W_SR.slot("x");
  
  arma::mat Wpred(n, p);
   
  vector < vector < double > > pred_global(p);
  for(int iter_p = 0 ; iter_p < p ; iter_p ++){
    pred_global[iter_p].resize(n);
    for(int iter_px = 0 ; iter_px < n ; iter_px++){
      pred_global[iter_p][iter_px] = sample(iter_px, iter_p);
    }
  }
  vector < vector < double > > pred_global_hist = pred_global;
    
  if(prior == false){
    std::fill(sample.begin(), sample.end(), 1);
  }
  
  arma::mat V(n, p);
   
  IntegerVector rang;
  bool no_site_order = (site_order[0] < 0);
  if(no_site_order == false){
    rang = site_order;
  }
  
  int index_px;
  double norm;
  double val_criterion = cv_criterion + 1;
  double diff_criterion = 0, diff; 
  double cv_criterion2 = n * cv_criterion ; 
  int iter_updateV = 0 ;
  
  vector < double > res_multipotentiel(n) ;
  int iter = 0 ;
  
  //// estimation
  
  while(iter < iter_max && ( (val_criterion > cv_criterion) || (test_regional == true && iter_updateV != iter) ) ){

    iter++;
    pred_global_hist = pred_global; 
    
    if(no_site_order){
      rang = rank_hpp(runif(n)) - 1; // tirer aleatoirement l ordre des sites
    }
   
    //// regional potential
    if(test_regional == true){
      if(iter == 1 || val_criterion <= cv_criterion || diff_criterion > cv_criterion2){ 
      iter_updateV = iter ;
      
      for(int iter_p = (p - 1) ; iter_p>= 0 ; iter_p --){

        if(last_vs_others == false || iter_p == (p - 1)){
        
        res_multipotentiel =  calcMultiPotential_hpp(W_SR, W_LR, pred_global[iter_p], 
                                                     threshold, coords, Rcpp::as < std::vector < double > >(distance_ref), 
                                                     nbGroup_min, multiV, 
                                                     neutre)[0]; 
            
          for(int iter_px = 0 ; iter_px < n ; iter_px++){
           
            V(iter_px, iter_p) = res_multipotentiel[iter_px];
            
            if(type_reg){
              V(iter_px, iter_p) = V(iter_px, iter_p)  * (V(iter_px, iter_p) - pred_global[iter_p][iter_px]);
            }
          }
        
        }else{
          V.col(iter_p) = 1 - V.col(p - 1);
        }
      }
      
      }else{
        cv_criterion2 /= 1.1;
      } 
    }

    //// update site probabilities
    val_criterion = 0;
    diff_criterion = 0;
    
    for(int iter_px = 0 ; iter_px < n ; iter_px++){ // pour chaque pixel
      
      norm = 0.0;
      index_px = rang(iter_px);
      
      for(int iter_p = 0 ; iter_p < p ; iter_p++){ // pour chaque groupe
        Wpred(index_px, iter_p) = 0.0;
        
        for(int iter_vois = W_SRp[index_px]; iter_vois < W_SRp[index_px + 1]; iter_vois++){ // pour chaque voisin
          if(type_reg){
            Wpred(index_px, iter_p) += W_SRx[iter_vois]*pred_global[iter_p][W_SRi[iter_vois]]*max(0.0, pred_global[iter_p][W_SRi[iter_vois]]-sample(index_px, iter_p));
            }else{
            Wpred(index_px, iter_p) += W_SRx[iter_vois] *pred_global[iter_p][W_SRi[iter_vois]];
          }
        }
        
        // exponentielle rho
        if(test_regional == false){
          pred_global[iter_p][index_px] = sample(index_px, iter_p) *exp(rho(0) *Wpred(index_px, iter_p)) ;
        }else{
          pred_global[iter_p][index_px] = sample(index_px, iter_p) *exp(rho(0) *Wpred(index_px, iter_p) + rho(1) *V(index_px, iter_p));
        } 
        norm += pred_global[iter_p][index_px];
      } 
      
      // normalisation 
      for(int iter_p = 0 ; iter_p < p ; iter_p++){
        pred_global[iter_p][index_px] /= norm;
        diff = abs(pred_global_hist[iter_p][index_px]-pred_global[iter_p][index_px]);
        diff_criterion += diff;
        val_criterion = max(val_criterion, diff);
      }
      
    }         

    if(verbose > 0){
      if(verbose == 1){Rcout << "*" ;}
      if(verbose == 2){Rcout << "iteration " << iter << " : totaldiff = " << diff_criterion << " | maxdiff = " << val_criterion << endl;}
    }

  }  
  
  if(verbose == 1){Rcout << endl;}
  
  //// export
  arma::mat spatialPrior(n, p);
  for(int iter_px = 0 ; iter_px < n ; iter_px++){
    index_px = rang(iter_px);
    for(int iter_p = 0 ; iter_p < p ; iter_p++){
      if(test_regional == false){
        spatialPrior(index_px, iter_p) = exp(rho(0) *Wpred(index_px, iter_p)) ;
      }else{
          spatialPrior(index_px, iter_p) = exp(rho(0) *Wpred(index_px, iter_p) + rho(1) *V(index_px, iter_p));
      } 
    }
  }
  
  return Rcpp::List::create(Rcpp::Named("predicted") = pred_global, 
                            Rcpp::Named("spatialPrior") = spatialPrior, 
                            Rcpp::Named("cv") = val_criterion <= cv_criterion, 
                            Rcpp::Named("iter_max") = iter
                            );
  
}
//[[Rcpp::export]]
arma::vec cpp_SolvePenaltyL2One (arma::mat x_full, arma::mat x_fancy, 
                         arma::vec y_full, arma::mat x_test,
                         arma::vec pars_full,
                         double lambda, 
                         int max_iter = 100, double tol = 1e-5) {
  // The cpp version of the penalized regression solver.
  // In this case we use a slightly different notation. 
  // Here also we solve for only a single value of lambda. 
  // Args:
  //    x_full: The top four blocks of the matrix fancy X in notes/GLM.pdf.
  //    x_fancy: The fancy X matrix in notes/GLM.pdf.
  //    x_test: The test set design matrix.
  //    y_full: The non-zero part of the fancy y vector of notes/GLM.pdf.
  //    pars_full: The parameter vector (beta, gamma).
  //    ...: The other parameters remain unchanged.
  //
  // Returns: 
  //    The full parameter vector (beta, gamma).
  
  
  // Initialize p.
  arma::uword p = x_test.n_cols;
  
  // Initialize vectors for algorithm.
  arma::vec pars_full_new;
  arma::vec mu_full;
  arma::vec mu_full_new;
  
  // Begin main loop
  for (int i = 1; i <= max_iter; i++) {
    // Get current mean vector
    mu_full = 1/(1 + exp(-x_full * pars_full));
    
    // Create the y fancy vector.
    arma::vec y_fancy = join_vert(y_full - mu_full, 
                                  -lambda * x_test * pars_full.tail(p)); 
    // Create the diagonal of the fancy V matrix.
    arma::vec v_fancy = join_vert(mu_full % (1 - mu_full), 
                                  lambda * ones<vec>(x_test.n_rows));
    
    // As before, we first obtain the V_fancy * X_fancy.
    arma::mat var_times_X(x_fancy.begin(), x_fancy.n_rows, x_fancy.n_cols, true);
    var_times_X.each_col() %= v_fancy;
    
    // Update the parameter vector.
    pars_full_new = pars_full +
                    solve(trans(x_fancy) * var_times_X, trans(x_fancy) * y_fancy);
    // Check for convergence.
    if (sum(pow(pars_full_new - pars_full, 2)) < tol) {
      return pars_full_new;
    } else {
      pars_full = pars_full_new;
    }
    
  }
  
  // Throw warning if it did not converge.
  Function warning("warning");
  warning("The newton-raphson algorithm did not converge.");
  
  // Return the non-converged beta vector.
  return pars_full_new;
}
Exemple #12
0
arma::vec mat2vec(arma::mat y)
{
arma::vec b(y.begin(), y.size(), /*copy_aux_mem*/false, /*strict*/true);
return b;
}