C++ (Cpp) prepare_arg_logical_square_matrixの例

コード例 #1

/** Get the transitive closure of a binary relation
 *
 * @param x square logical matrix
 * @return square logical matrix
 *
 * @version 0.2 (Marek Gagolewski)
 */
SEXP rel_closure_transitive(SEXP x)
{
   x = prepare_arg_logical_square_matrix(x, "R");
   SEXP dim = Rf_getAttrib(x, R_DimSymbol);
   R_len_t n = INTEGER(dim)[0];
   int* xp = INTEGER(x);

   SEXP y = Rf_allocVector(LGLSXP, n*n);
   int* yp = INTEGER(y);
   Rf_setAttrib(y, R_DimSymbol, dim);
   Rf_setAttrib(y, R_DimNamesSymbol, Rf_getAttrib(x, R_DimNamesSymbol)); // preserve dimnames

   for (R_len_t i=0; i<n*n; ++i) {
      if (xp[i] == NA_LOGICAL)
         Rf_error(MSG__ARG_EXPECTED_NOT_NA, "R"); // missing values are not allowed
      yp[i] = xp[i];
   }

   for (R_len_t k=0; k<n; ++k) { // Warshall's algorithm
      for (R_len_t i=0; i<n; ++i) {
         for (R_len_t j=0; j<n; ++j) {
            yp[i+n*j] = (yp[i+n*j] || (yp[i+n*k] && yp[k+n*j]));
         }
      }
   }

   return y;
}

コード例 #2

/** Check if a binary relation is cyclic
 *
 * @param x square logical matrix
 * @return logical scalar
 *
 * @version 0.2 (Marek Gagolewski)
 */
SEXP rel_is_cyclic(SEXP x)
{
   x = prepare_arg_logical_square_matrix(x, "R");
   SEXP dim = Rf_getAttrib(x, R_DimSymbol);
   R_len_t n = INTEGER(dim)[0];
   int* xp = INTEGER(x);

   for (int i=0; i<n*n; ++i)
      if (xp[i] == NA_LOGICAL)
         return Rf_ScalarLogical(NA_LOGICAL);

   int* helper = new int[n];
   for (int i=0; i<n; ++i)
      helper[i] = 0;

   bool ret = false;
   int i=0;
   do {
      while (i < n) { if (helper[i] == 0) break; i++; } // get an unmarked node
      if (i == n) break;
      ret = rel_is_cyclic(i, xp, n, helper);
   } while(!ret);

   delete[] helper;
   return Rf_ScalarLogical(ret);
}

コード例 #3

ファイル: rel_symmetry.cpp プロジェクト: Rexamine/agop

/** Get the symmetric closure of a binary relation
 *
 * @param x square logical matrix
 * @return square logical matrix
 *
 * @version 0.2 (Marek Gagolewski)
 */
SEXP rel_closure_symmetric(SEXP x)
{
    x = prepare_arg_logical_square_matrix(x, "R");
    SEXP dim = Rf_getAttrib(x, R_DimSymbol);
    R_len_t n = INTEGER(dim)[0];
    int* xp = INTEGER(x);

    SEXP y = Rf_allocVector(LGLSXP, n*n);
    int* yp = INTEGER(y);
    Rf_setAttrib(y, R_DimSymbol, dim);
    Rf_setAttrib(y, R_DimNamesSymbol, Rf_getAttrib(x, R_DimNamesSymbol)); // preserve dimnames

    for (R_len_t i=0; i<n*n; ++i) {
        if (xp[i] == NA_LOGICAL)
            Rf_error(MSG__ARG_EXPECTED_NOT_NA, "R"); // missing values are not allowed
        yp[i] = xp[i];
    }

    for (R_len_t i=0; i<n-1; ++i) {
        for (R_len_t j=i+1; j<n; ++j) {
            if (yp[i+n*j] && !yp[j+n*i])
                yp[j+n*i] = TRUE;
            else if (yp[j+n*i] && !yp[i+n*j])
                yp[i+n*j] = TRUE;
        }
    }

    return y;
}

コード例 #4

/** Check if a binary relation is irreflexive
 *
 * @param x square logical matrix
 * @return logical scalar
 *
 * @version 0.2 (Marek Gagolewski)
 */
SEXP rel_is_irreflexive(SEXP x)
{
   x = prepare_arg_logical_square_matrix(x, "R");
   SEXP dim = Rf_getAttrib(x, R_DimSymbol);
   R_len_t n = INTEGER(dim)[0];
   int* xp = INTEGER(x);
   for (R_len_t i=0; i<n; ++i) {
      if (xp[i+i*n] == NA_LOGICAL)
         return Rf_ScalarLogical(NA_LOGICAL);
      else if (xp[i+i*n])
         return Rf_ScalarLogical(FALSE);
   }
   return Rf_ScalarLogical(TRUE);
}

コード例 #5

ファイル: rel_antisymmetry.cpp プロジェクト: Rexamine/agop

/** Check if a binary relation is antisymmetric
 *
 * @param x square logical matrix
 * @return logical scalar
 *
 * @version 0.2 (Marek Gagolewski)
 */
SEXP rel_is_antisymmetric(SEXP x)
{
   x = prepare_arg_logical_square_matrix(x, "R");
   SEXP dim = Rf_getAttrib(x, R_DimSymbol);
   R_len_t n = INTEGER(dim)[0];
   int* xp = INTEGER(x);
   for (R_len_t i=0; i<n-1; ++i) {
      for (R_len_t j=i+1; j<n; ++j) {
         if (xp[j+i*n] == NA_LOGICAL && (xp[i+j*n] == NA_LOGICAL || xp[i+j*n]))
            return Rf_ScalarLogical(NA_LOGICAL);
         else if (xp[i+j*n] == NA_LOGICAL && (xp[j+i*n] == NA_LOGICAL || xp[j+i*n]))
            return Rf_ScalarLogical(NA_LOGICAL);
         else if (xp[i+j*n] != NA_LOGICAL && xp[j+i*n] != NA_LOGICAL && xp[i+j*n] && xp[j+i*n])
            return Rf_ScalarLogical(FALSE);
      }
   }
   return Rf_ScalarLogical(TRUE);
}

コード例 #6

/** Check if a binary relation is transitive
 *
 * @param x square logical matrix
 * @return logical scalar
 *
 * @version 0.2 (Marek Gagolewski)
 */
SEXP rel_is_transitive(SEXP x)
{
   x = prepare_arg_logical_square_matrix(x, "R");
   SEXP dim = Rf_getAttrib(x, R_DimSymbol);
   R_len_t n = INTEGER(dim)[0];
   int* xp = INTEGER(x);
   for (R_len_t i=0; i<n; ++i) {
      for (R_len_t j=0; j<n; ++j) {
         if (i == j) continue; // don't care
         if (xp[i+j*n] == NA_LOGICAL)
            return Rf_ScalarLogical(NA_LOGICAL); // this could be done better
         if (!xp[i+j*n]) continue; // nothing more to check
         for (R_len_t k=0; k<n; ++k) {
            if (xp[i+k*n] == NA_LOGICAL || xp[j+k*n] == NA_LOGICAL)
               return Rf_ScalarLogical(NA_LOGICAL); // this could be done better
            if (xp[j+k*n] && !xp[i+k*n])
               return Rf_ScalarLogical(FALSE);
         }
      }
   }
   return Rf_ScalarLogical(TRUE);
}