static inline void rvine_tree_cleanup(igraph_t *tree) { igraph_integer_t e, a; for (a = 0; a < igraph_vcount(tree); a++) { if (VAP(tree, "h", a) != VAP(tree, "hrev", a)) { gsl_vector_free(VAP(tree, "h", a)); gsl_vector_free(VAP(tree, "hrev", a)); gsl_permutation_free(VAP(tree, "hrank", a)); gsl_permutation_free(VAP(tree, "hrevrank", a)); } else if (VAP(tree, "h", a) != NULL) { gsl_vector_free(VAP(tree, "h", a)); gsl_permutation_free(VAP(tree, "hrank", a)); } else { gsl_vector_free(VAP(tree, "hrev", a)); gsl_permutation_free(VAP(tree, "hrevrank", a)); } } DELVAS(tree); for (e = 0; e < igraph_ecount(tree); e++) { gsl_vector_short_free(EAP(tree, "Ue", e)); dml_measure_free(EAP(tree, "measure", e)); } DELEA(tree, "Ue"); DELEA(tree, "weight"); DELEA(tree, "measure"); }
static void main_init() { ptr tc = get_thread_context(); ptr p; INT i; /* force thread inline allocation to go through find_room until ready */ AP(tc) = (ptr)0; EAP(tc) = (ptr)0; REAL_EAP(tc) = (ptr)0; /* set up dummy CP so locking in read/write/Scall won't choke */ CP(tc) = Svoid; CODERANGESTOFLUSH(tc) = Snil; if (S_boot_time) S_G.protect_next = 0; S_segment_init(); S_alloc_init(); S_thread_init(); S_intern_init(); S_gc_init(); S_number_init(); S_schsig_init(); S_new_io_init(); S_print_init(); S_stats_init(); S_foreign_init(); S_prim_init(); S_prim5_init(); S_fasl_init(); S_machine_init(); S_flushcache_init(); /* must come after S_machine_init(); */ #ifdef FEATURE_EXPEDITOR S_expeditor_init(); #endif /* FEATURE_EXPEDITOR */ if (!S_boot_time) return; FXLENGTHBV(tc) = p = S_bytevector(256); for (i = 0; i < 256; i += 1) { BVIT(p, i) = (iptr)FIX(i & 0x80 ? 8 : i & 0x40 ? 7 : i & 0x20 ? 6 : i & 0x10 ? 5 : i & 0x08 ? 4 : i & 0x04 ? 3 : i & 0x02 ? 2 : i & 0x01 ? 1 : 0); } FXFIRSTBITSETBV(tc) = p = S_bytevector(256); for (i = 0; i < 256; i += 1) { BVIT(p, i) = (iptr)FIX(i & 0x01 ? 0 : i & 0x02 ? 1 : i & 0x04 ? 2 : i & 0x08 ? 3 : i & 0x10 ? 4 : i & 0x20 ? 5 : i & 0x40 ? 6 : i & 0x80 ? 7 : 0); } NULLIMMUTABLEVECTOR(tc) = S_null_immutable_vector(); NULLIMMUTABLEFXVECTOR(tc) = S_null_immutable_fxvector(); NULLIMMUTABLEBYTEVECTOR(tc) = S_null_immutable_bytevector(); NULLIMMUTABLESTRING(tc) = S_null_immutable_string(); PARAMETERS(tc) = S_G.null_vector; for (i = 0 ; i < virtual_register_count ; i += 1) { VIRTREG(tc, i) = FIX(0); } p = S_code(tc, type_code, size_rp_header); CODERELOC(p) = S_relocation_table(0); CODENAME(p) = Sfalse; CODEARITYMASK(p) = FIX(0); CODEFREE(p) = 0; CODEINFO(p) = Sfalse; CODEPINFOS(p) = Snil; RPHEADERFRAMESIZE(&CODEIT(p, 0)) = 0; RPHEADERLIVEMASK(&CODEIT(p, 0)) = 0; RPHEADERTOPLINK(&CODEIT(p, 0)) = (uptr)&RPHEADERTOPLINK(&CODEIT(p, 0)) - (uptr)p; S_protect(&S_G.dummy_code_object); S_G.dummy_code_object = p; S_protect(&S_G.error_invoke_code_object); S_G.error_invoke_code_object = Snil; S_protect(&S_G.invoke_code_object); S_G.invoke_code_object = Snil; S_protect(&S_G.active_threads_id); S_G.active_threads_id = S_intern((const unsigned char *)"$active-threads"); S_set_symbol_value(S_G.active_threads_id, FIX(0)); S_protect(&S_G.heap_reserve_ratio_id); S_G.heap_reserve_ratio_id = S_intern((const unsigned char *)"$heap-reserve-ratio"); SETSYMVAL(S_G.heap_reserve_ratio_id, Sflonum(default_heap_reserve_ratio)); S_protect(&S_G.scheme_version_id); S_G.scheme_version_id = S_intern((const unsigned char *)"$scheme-version"); S_protect(&S_G.make_load_binary_id); S_G.make_load_binary_id = S_intern((const unsigned char *)"$make-load-binary"); S_protect(&S_G.load_binary); S_G.load_binary = Sfalse; }
static void rvine_trees_to_vine(dml_vine_t *vine, igraph_t **trees) { size_t n = vine->dim; size_t *order_inv; gsl_vector_short *B; igraph_integer_t Cea, Ceb; size_t x = 0, x_hat = 0, x_hat_hat = 0; // Initialized to avoid GCC warnings. dml_copula_t *copula = NULL; // Initialized to avoid GCC warnings. igraph_integer_t e; // Edge id. igraph_integer_t a, b, aa, ab, ba, bb; // Vertex id. igraph_t **last_trees = NULL; igraph_t *graph = NULL; gsl_vector_short *Ue, *Ua, *Ub; // Set the number of trees of the vines. vine->trees = n - 1; while (trees[vine->trees - 1] == NULL) vine->trees--; // Nothing to do for vines without trees. if (vine->trees == 0) return; // Selecting a structure for the trees that were truncated. // Is this really necessary? Think a better solution. if (vine->trees != n - 1) { igraph_i_set_attribute_table(&igraph_cattribute_table); last_trees = g_malloc_n(n - 1 - vine->trees, sizeof(igraph_t *)); graph = g_malloc(sizeof(igraph_t)); for (size_t k = vine->trees; k < n - 1; k++) { // Tree index. igraph_empty(graph, n - k, IGRAPH_UNDIRECTED); // Adding all "possible" edges. for (a = 0; a < igraph_vcount(graph) - 1; a++) { for (b = a + 1; b < igraph_vcount(graph); b++) { // Checking the proximity condition. igraph_edge(k <= vine->trees ? trees[k - 1] : last_trees[k - 1 - vine->trees], a, &aa, &ab); igraph_edge(k <= vine->trees ? trees[k - 1] : last_trees[k - 1 - vine->trees], b, &ba, &bb); if (aa == ba || aa == bb || ab == ba || ab == bb) { igraph_add_edge(graph, a, b); igraph_get_eid(graph, &e, a, b, IGRAPH_UNDIRECTED, 1); // Variables "connected" by this edge and conditioned set. Ua = EAP(k <= vine->trees ? trees[k - 1] : last_trees[k - 1 - vine->trees], "Ue", a); Ub = EAP(k <= vine->trees ? trees[k - 1] : last_trees[k - 1 - vine->trees], "Ue", b); Ue = gsl_vector_short_calloc(n); for (size_t i = 0; i < n; i++) { gsl_vector_short_set(Ue, i, gsl_vector_short_get(Ua, i) | gsl_vector_short_get(Ub, i)); if (gsl_vector_short_get(Ua, i) && !gsl_vector_short_get(Ub, i)) { SETEAN(graph, "Cea", e, i + 1); } if (gsl_vector_short_get(Ub, i) && !gsl_vector_short_get(Ua, i)) { SETEAN(graph, "Ceb", e, i + 1); } } SETEAP(graph, "Ue", e, Ue); } } } // Compute the minimum weight spanning tree. last_trees[k - vine->trees] = g_malloc(sizeof(igraph_t)); igraph_minimum_spanning_tree_unweighted(graph, last_trees[k - vine->trees]); igraph_destroy(graph); } } order_inv = g_malloc0_n(n, sizeof(size_t)); B = gsl_vector_short_calloc(n); // for loop in line 2. for (size_t i = 0; i < n - 1; i++) { if (trees[n - i - 2] == NULL) { for (e = 0; e < igraph_ecount(last_trees[n - i - 2 - vine->trees]); e++) { x = EAN(last_trees[n - i - 2 - vine->trees], "Cea", e); x_hat = EAN(last_trees[n - i - 2 - vine->trees], "Ceb", e); if (!gsl_vector_short_get(B, x - 1) && !gsl_vector_short_get(B, x_hat - 1)) { x_hat = 0; copula = NULL; break; } } } else { for (e = 0; e < igraph_ecount(trees[n - i - 2]); e++) { x = EAN(trees[n - i - 2], "Cea", e); x_hat = EAN(trees[n - i - 2], "Ceb", e); if (!gsl_vector_short_get(B, x - 1) && !gsl_vector_short_get(B, x_hat - 1)) { copula = EAP(trees[n - i - 2], "copula", e); break; } } } // Line 4. gsl_vector_short_set(B, x - 1, 1); vine->order[n - i - 1] = x - 1; order_inv[x - 1] = n - i; vine->matrix[i][i] = x; vine->matrix[i + 1][i] = x_hat; vine->copulas[i + 1][i] = copula; // for loop in line 5. for (size_t k = i + 2; k < n; k++) { if (trees[n - k - 1] != NULL) { for (e = 0; e < igraph_ecount(trees[n - k - 1]); e++) { Cea = EAN(trees[n - k - 1], "Cea", e); Ceb = EAN(trees[n - k - 1], "Ceb", e); if (x == Cea) { x_hat_hat = Ceb; if (!gsl_vector_short_get(B, x_hat_hat - 1)) { // The pseudocode of the algorithm does not included // this check. Invalid matrices were generated when // x_hat_hat is set to an index already assigned // to a diagonal entry. copula = EAP(trees[n - k - 1], "copula", e); break; } } else if (x == Ceb) { x_hat_hat = Cea; if (!gsl_vector_short_get(B, x_hat_hat - 1)) { // Ibdem to the previous comment. copula = EAP(trees[n - k - 1], "copula", e); break; } } } vine->matrix[k][i] = x_hat_hat; vine->copulas[k][i] = copula; } } } for (size_t i = 0; i < n; i++) { if (!gsl_vector_short_get(B, i)) { vine->matrix[n - 1][n - 1] = i + 1; vine->order[0] = i; order_inv[i] = 1; break; } } // Reorder the variables. The simulation algorithm assumes that the // diagonal entries of the R-vine matrix are ordered from n to 1. for (size_t i = 0; i < n; i++) { for (size_t j = 0; j <= i; j++) { if (vine->matrix[i][j] > 0) { vine->matrix[i][j] = order_inv[vine->matrix[i][j] - 1]; } } } if (vine->trees != n - 1) { for (size_t i = 0; i < n - 1 - vine->trees; i++) { for (e = 0; e < igraph_ecount(last_trees[i]); e++) { Ue = EAP(last_trees[i], "Ue", e); gsl_vector_short_free(Ue); } DELEA(last_trees[i], "Ue"); igraph_destroy(last_trees[i]); g_free(last_trees[i]); } g_free(last_trees); g_free(graph); } g_free(order_inv); gsl_vector_short_free(B); }
static void fit_rvine_trees(igraph_t **trees, const gsl_matrix *data, const dml_vine_weight_t weight, const dml_vine_trunc_t trunc, const dml_copula_indeptest_t indeptest, const double indeptest_level, const dml_copula_type_t *types, const size_t types_size, const dml_copula_select_t select, const gsl_rng *rng) { size_t m, n; igraph_t *graph; igraph_vector_t *graph_weight; dml_copula_t *copula; gsl_vector *x; igraph_integer_t e; // Edge id. igraph_integer_t a, aa, ab, b, ba, bb; // Vertex id. gsl_vector *u = NULL, *v = NULL; igraph_integer_t Cea, Ceb; gsl_vector_short *Ue, *Ua, *Ub; size_t k; dml_measure_t *measure; double tree_aic, copula_aic; gsl_permutation *perm, *rank, *u_rank = NULL, *v_rank = NULL; igraph_i_set_attribute_table(&igraph_cattribute_table); m = data->size1; n = data->size2; graph = g_malloc(sizeof(igraph_t)); graph_weight = g_malloc(sizeof(igraph_vector_t)); perm = gsl_permutation_alloc(m); for (k = 0; k < n - 1; k++) { // Tree index. if (k == 0) { igraph_full(graph, n, IGRAPH_UNDIRECTED, IGRAPH_NO_LOOPS); // Assign the observations to the nodes. for (size_t i = 0; i < n; i++) { // Variable and node index. x = gsl_vector_alloc(m); gsl_matrix_get_col(x, data, i); // Results of the h-function of the copula assigned to the // edge that corresponds to this vertex in the previous tree. // h for the h-function with its arguments in order and // hrev for the h-function with its arguments reversed. In the // first tree both are equal to the observations of the // corresponding variable, in the rest of the trees they differ. SETVAP(graph, "h", i, x); SETVAP(graph, "hrev", i, x); gsl_sort_vector_index(perm, x); rank = gsl_permutation_alloc(m); gsl_permutation_inverse(rank, perm); // Ranks of the h and hrev vectors. SETVAP(graph, "hrank", i, rank); SETVAP(graph, "hrevrank", i, rank); } for (e = 0; e < igraph_ecount(graph); e++) { igraph_edge(graph, e, &a, &b); // Variables "connected" by this edge. Ue = gsl_vector_short_calloc(n); gsl_vector_short_set(Ue, a, 1); gsl_vector_short_set(Ue, b, 1); SETEAP(graph, "Ue", e, Ue); // Conditioned set. SETEAN(graph, "Cea", e, a + 1); SETEAN(graph, "Ceb", e, b + 1); Cea = EAN(graph, "Cea", e); Ceb = EAN(graph, "Ceb", e); // Calculate the weight of the edge. u = VAP(graph, "h", a); v = VAP(graph, "h", b); u_rank = VAP(graph, "hrank", a); v_rank = VAP(graph, "hrank", b); // The conditioned set is ordered to make the order of the // arguments in the bivariate copulas unique as suggested in // Czado, C. (2010) Pair-Copula Constructions of Multivariate // Copulas. In Jaworski, P. and Durante, F. and Hardle, W. K. // and Rychlik, T. (eds.) Copula Theory and Its Applications, // Springer-Verlag, 93-109. if (Cea < Ceb) { rvine_set_weight(graph, weight, e, u, v, u_rank, v_rank); } else { rvine_set_weight(graph, weight, e, v, u, v_rank, u_rank); } } } else { igraph_empty(graph, n - k, IGRAPH_UNDIRECTED); // Adding all "possible" edges. for (a = 0; a < igraph_vcount(graph) - 1; a++) { for (b = a + 1; b < igraph_vcount(graph); b++) { igraph_edge(trees[k - 1], a, &aa, &ab); igraph_edge(trees[k - 1], b, &ba, &bb); // Checking the proximity condition. if (aa == ba || aa == bb || ab == ba || ab == bb) { igraph_add_edge(graph, a, b); igraph_get_eid(graph, &e, a, b, IGRAPH_UNDIRECTED, 1); // Variables "connected" by this edge and conditioned set. Ua = EAP(trees[k - 1], "Ue", a); Ub = EAP(trees[k - 1], "Ue", b); Ue = gsl_vector_short_calloc(n); for (size_t i = 0; i < n; i++) { gsl_vector_short_set(Ue, i, gsl_vector_short_get(Ua, i) | gsl_vector_short_get(Ub, i)); if (gsl_vector_short_get(Ua, i) && !gsl_vector_short_get(Ub, i)) { SETEAN(graph, "Cea", e, i + 1); } if (gsl_vector_short_get(Ub, i) && !gsl_vector_short_get(Ua, i)) { SETEAN(graph, "Ceb", e, i + 1); } } SETEAP(graph, "Ue", e, Ue); } } } // Compute pseudo-observations and edge weights. for (a = 0; a < igraph_vcount(graph); a++) { // See the comment in the code for the first tree. SETVAP(graph, "h", a, NULL); SETVAP(graph, "hrev", a, NULL); SETVAP(graph, "hrank", a, NULL); SETVAP(graph, "hrevrank", a, NULL); } for (e = 0; e < igraph_ecount(graph); e++) { igraph_edge(graph, e, &a, &b); Cea = EAN(graph, "Cea", e); Ceb = EAN(graph, "Ceb", e); // Assign u and u_rank. if ((Cea == EAN(trees[k - 1], "Cea", a) && (EAN(trees[k - 1], "Cea", a) < EAN(trees[k - 1], "Ceb", a))) || (Cea != EAN(trees[k - 1], "Cea", a) && (EAN(trees[k - 1], "Cea", a) > EAN(trees[k - 1], "Ceb", a)))) { u = VAP(graph, "h", a); if (u == NULL) { copula = EAP(trees[k - 1], "copula", a); measure = EAP(trees[k - 1], "measure", a); u = gsl_vector_alloc(m); dml_copula_h(copula, measure->x, measure->y, u); SETVAP(graph, "h", a, u); gsl_sort_vector_index(perm, u); rank = gsl_permutation_alloc(m); gsl_permutation_inverse(rank, perm); SETVAP(graph, "hrank", a, rank); } u_rank = VAP(graph, "hrank", a); } if ((Cea == EAN(trees[k - 1], "Cea", a) && (EAN(trees[k - 1], "Cea", a) > EAN(trees[k - 1], "Ceb", a))) || (Cea != EAN(trees[k - 1], "Cea", a) && (EAN(trees[k - 1], "Cea", a) < EAN(trees[k - 1], "Ceb", a)))) { u = VAP(graph, "hrev", a); if (u == NULL) { copula = EAP(trees[k - 1], "copula", a); measure = EAP(trees[k - 1], "measure", a); u = gsl_vector_alloc(m); dml_copula_h(copula, measure->y, measure->x, u); SETVAP(graph, "hrev", a, u); gsl_sort_vector_index(perm, u); rank = gsl_permutation_alloc(m); gsl_permutation_inverse(rank, perm); SETVAP(graph, "hrevrank", a, rank); } u_rank = VAP(graph, "hrevrank", a); } // Assign v and v_rank. if ((Ceb == EAN(trees[k - 1], "Cea", b) && (EAN(trees[k - 1], "Cea", b) < EAN(trees[k - 1], "Ceb", b))) || (Ceb != EAN(trees[k - 1], "Cea", b) && (EAN(trees[k - 1], "Cea", b) > EAN(trees[k - 1], "Ceb", b)))) { v = VAP(graph, "h", b); if (v == NULL) { copula = EAP(trees[k - 1], "copula", b); measure = EAP(trees[k - 1], "measure", b); v = gsl_vector_alloc(m); dml_copula_h(copula, measure->x, measure->y, v); SETVAP(graph, "h", b, v); gsl_sort_vector_index(perm, v); rank = gsl_permutation_alloc(m); gsl_permutation_inverse(rank, perm); SETVAP(graph, "hrank", b, rank); } v_rank = VAP(graph, "hrank", b); } if ((Ceb == EAN(trees[k - 1], "Cea", b) && (EAN(trees[k - 1], "Cea", b) > EAN(trees[k - 1], "Ceb", b))) || (Ceb != EAN(trees[k - 1], "Cea", b) && (EAN(trees[k - 1], "Cea", b) < EAN(trees[k - 1], "Ceb", b)))) { v = VAP(graph, "hrev", b); if (v == NULL) { copula = EAP(trees[k - 1], "copula", b); measure = EAP(trees[k - 1], "measure", b); v = gsl_vector_alloc(m); dml_copula_h(copula, measure->y, measure->x, v); SETVAP(graph, "hrev", b, v); gsl_sort_vector_index(perm, v); rank = gsl_permutation_alloc(m); gsl_permutation_inverse(rank, perm); SETVAP(graph, "hrevrank", b, rank); } v_rank = VAP(graph, "hrevrank", b); } // Set the weight of the edge. The arguments are ordered here. // The order determines the x and y fields of measure. if (Cea < Ceb) { rvine_set_weight(graph, weight, e, u, v, u_rank, v_rank); } else { rvine_set_weight(graph, weight, e, v, u, v_rank, u_rank); } } } // Compute the minimum weight spanning tree. trees[k] = g_malloc(sizeof(igraph_t)); igraph_vector_init(graph_weight, igraph_ecount(graph)); EANV(graph, "weight", graph_weight); igraph_minimum_spanning_tree_prim(graph, trees[k], graph_weight); igraph_vector_destroy(graph_weight); tree_aic = 0; for (e = 0; e < igraph_ecount(trees[k]); e++) { igraph_edge(trees[k], e, &a, &b); Cea = EAN(trees[k], "Cea", e); Ceb = EAN(trees[k], "Ceb", e); measure = EAP(trees[k], "measure", e); // Assign a bivariate copula to the edge. if (Cea < Ceb) { copula = dml_copula_select(measure->x, measure->y, measure, indeptest, indeptest_level, types, types_size, select, rng); // Get information for the truncation of the vine. if (trunc == DML_VINE_TRUNC_AIC) { dml_copula_aic(copula, measure->x, measure->y, &copula_aic); tree_aic += copula_aic; } } else { copula = dml_copula_select(measure->y, measure->x, measure, indeptest, indeptest_level, types, types_size, select, rng); // Get information for the truncation of the vine. if (trunc == DML_VINE_TRUNC_AIC) { dml_copula_aic(copula, measure->y, measure->x, &copula_aic); tree_aic += copula_aic; } } SETEAP(trees[k], "copula", e, copula); } igraph_destroy(graph); // Check if the vine should be truncated. if (trunc == DML_VINE_TRUNC_AIC && tree_aic >= 0) { // Free the memory used for the last tree. rvine_tree_cleanup(trees[k]); for (e = 0; e < igraph_ecount(trees[k]); e++) { copula = EAP(trees[k], "copula", e); dml_copula_free(copula); } igraph_destroy(trees[k]); g_free(trees[k]); trees[k] = NULL; break; } if (k > 0) rvine_tree_cleanup(trees[k - 1]); } // Cleanup the last tree if the vine was completely estimated. // If the vine was truncated, the last tree will be freed in // the function vine_fit_rvine, because the rvine_trees_to_vine // function needs some attributes of its edges. if (k == n - 1) { rvine_tree_cleanup(trees[n - 2]); } g_free(graph_weight); g_free(graph); gsl_permutation_free(perm); }