/** 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); }
/** Internal function * * Check cyclicity; based on depth-first search & topological sorting */ bool rel_is_cyclic(int i, int* xp, int n, int* helper) { if (helper[i] == 1) return true; if (helper[i] == 2) return false; helper[i] = 1; for (int j=0; j<n; ++j) { if (xp[i+j*n]) { if (j!=i && rel_is_cyclic(j, xp, n, helper)) return true; } } helper[i] = 2; return false; }
/** Get the transitive reduction of a binary relation * * @param x square logical matrix * @return square logical matrix * * @version 0.2 (Marek Gagolewski) */ SEXP rel_reduction_transitive(SEXP x) { SEXP cyc = rel_is_cyclic(x); if (LOGICAL(cyc)[0] != false) Rf_error(MSG__EXPECTED_ACYCLIC, "R"); x = rel_closure_transitive(x); // is logical matrix, dimnames are preserved, no NAs, we may overwrite its elements 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 // (Aho et al. 1972) for (R_len_t i=0; i<n; ++i) { for (R_len_t j=0; j<n; ++j) { yp[i+n*j] = xp[i+n*j]; if (xp[i+n*j] && i != j) { // determine whether i -> j may be removed for (R_len_t k=0; k<n; ++k) { if (i != k && k != j && xp[i+n*k] && xp[k+n*j]) { yp[i+n*j] = 0; break; } } } } } return y; }