Filename | /Users/ap13/perl5/lib/perl5/Graph.pm |
Statements | Executed 2879358 statements in 2.76s |
Calls | P | F | Exclusive Time |
Inclusive Time |
Subroutine |
---|---|---|---|---|---|
24876 | 1 | 1 | 617ms | 858ms | _edges | Graph::
29935 | 4 | 2 | 312ms | 1.88s | add_edge | Graph::
34963 | 3 | 2 | 253ms | 276ms | has_edge | Graph::
24934 | 1 | 1 | 241ms | 491ms | add_vertex | Graph::
29935 | 1 | 1 | 231ms | 721ms | _add_edge | Graph::
19958 | 2 | 1 | 222ms | 1.50s | set_edge_attribute | Graph::
70075 | 4 | 2 | 193ms | 251ms | multiedged | Graph::
24965 | 2 | 1 | 152ms | 152ms | _vertex_ids | Graph::
15003 | 3 | 1 | 139ms | 2.07s | add_weighted_edge | Graph::
39968 | 3 | 1 | 99.7ms | 250ms | expect_non_multiedged | Graph::
54871 | 3 | 1 | 87.9ms | 87.9ms | has_union_find | Graph::
36 | 1 | 1 | 84.6ms | 1.79s | _heap_walk | Graph::
24876 | 2 | 2 | 83.3ms | 1.50s | successors | Graph::
24914 | 2 | 1 | 74.9ms | 102ms | omniedged | Graph::
4991 | 2 | 1 | 69.3ms | 861ms | _MST_add | Graph::
24972 | 2 | 1 | 67.9ms | 79.1ms | multivertexed | Graph::
5007 | 1 | 1 | 62.8ms | 325ms | get_edge_attribute | Graph::
24876 | 1 | 1 | 45.3ms | 45.3ms | _edges_from | Graph::
2 | 1 | 1 | 25.5ms | 1.40s | _connected_components_compute | Graph::
10011 | 4 | 2 | 24.5ms | 24.5ms | _next_random | Graph::
15177 | 4 | 1 | 24.3ms | 24.3ms | is_compat02 | Graph::
26277 | 1 | 1 | 22.7ms | 22.7ms | CORE:sort (opcode) | Graph::
4991 | 1 | 1 | 18.7ms | 18.7ms | __ANON__[:2754] | Graph::
76 | 3 | 1 | 18.5ms | 34.7ms | vertices05 | Graph::
4871 | 1 | 1 | 9.00ms | 9.00ms | has_vertex | Graph::
112 | 5 | 3 | 6.23ms | 16.6ms | new | Graph::
36 | 1 | 1 | 5.68ms | 13.6ms | _root_opt | Graph::
336 | 3 | 1 | 4.98ms | 4.98ms | _opt | Graph::
38 | 1 | 1 | 3.87ms | 20.7ms | vertices | Graph::
1 | 1 | 1 | 3.12ms | 15.2ms | BEGIN@42 | Graph::
1 | 1 | 1 | 2.89ms | 3.27ms | BEGIN@13 | Graph::
1 | 1 | 1 | 2.79ms | 2.98ms | BEGIN@38 | Graph::
134 | 1 | 1 | 1.92ms | 3.24ms | edges05 | Graph::
148 | 2 | 1 | 1.89ms | 1.89ms | _get_options | Graph::
1 | 1 | 1 | 1.61ms | 1.96ms | BEGIN@28 | Graph::
134 | 2 | 1 | 1.51ms | 5.98ms | edges | Graph::
1 | 1 | 1 | 1.32ms | 3.17ms | BEGIN@29 | Graph::
2 | 1 | 1 | 1.21ms | 12.1ms | unique_vertices | Graph::
1 | 1 | 1 | 949µs | 1.16ms | BEGIN@86 | Graph::
224 | 2 | 1 | 743µs | 743µs | _opt_get | Graph::
36 | 1 | 1 | 686µs | 1.80s | MST_Prim | Graph::
172 | 2 | 2 | 646µs | 789µs | countedged | Graph::
1 | 1 | 1 | 565µs | 590µs | BEGIN@31 | Graph::
67 | 1 | 1 | 502µs | 5.56ms | add_edges | Graph::
1 | 1 | 1 | 487µs | 4.77ms | BEGIN@32 | Graph::
1 | 1 | 1 | 472µs | 809µs | BEGIN@35 | Graph::
1 | 1 | 1 | 442µs | 1.34ms | BEGIN@34 | Graph::
112 | 1 | 1 | 348µs | 348µs | _opt_unknown | Graph::
1 | 1 | 1 | 346µs | 4.14ms | BEGIN@33 | Graph::
1 | 1 | 1 | 312µs | 485µs | BEGIN@36 | Graph::
38 | 1 | 1 | 238µs | 293µs | directed | Graph::
38 | 2 | 1 | 201µs | 490µs | expect_undirected | Graph::
36 | 1 | 1 | 184µs | 184µs | __ANON__[:2745] | Graph::
38 | 1 | 1 | 158µs | 177µs | countvertexed | Graph::
2 | 1 | 1 | 80µs | 1.40s | _check_cache | Graph::
2 | 2 | 1 | 61µs | 1.40s | connected_components | Graph::
2 | 1 | 1 | 30µs | 1.40s | _connected_components | Graph::
1 | 1 | 1 | 26µs | 26µs | BEGIN@55 | Graph::
1 | 1 | 1 | 25µs | 98µs | BEGIN@39 | Graph::
1 | 1 | 1 | 18µs | 40µs | BEGIN@3 | Graph::
1 | 1 | 1 | 16µs | 62µs | BEGIN@40 | Graph::
2 | 1 | 1 | 16µs | 16µs | __ANON__[:2741] | Graph::
1 | 1 | 1 | 13µs | 56µs | BEGIN@1733 | Graph::
1 | 1 | 1 | 13µs | 29µs | BEGIN@30 | Graph::
1 | 1 | 1 | 12µs | 58µs | BEGIN@116 | Graph::
1 | 1 | 1 | 11µs | 23µs | BEGIN@178 | Graph::
1 | 1 | 1 | 10µs | 10µs | BEGIN@2155 | Graph::
1 | 1 | 1 | 10µs | 29µs | BEGIN@15 | Graph::
1 | 1 | 1 | 3µs | 3µs | BEGIN@5 | Graph::
0 | 0 | 0 | 0s | 0s | APSP_Floyd_Warshall | Graph::
0 | 0 | 0 | 0s | 0s | Infinity | Graph::
0 | 0 | 0 | 0s | 0s | MST_Kruskal | Graph::
0 | 0 | 0 | 0s | 0s | SPT_Bellman_Ford | Graph::
0 | 0 | 0 | 0s | 0s | SPT_Bellman_Ford_clear_cache | Graph::
0 | 0 | 0 | 0s | 0s | SPT_Dijkstra | Graph::
0 | 0 | 0 | 0s | 0s | SPT_Dijkstra_clear_cache | Graph::
0 | 0 | 0 | 0s | 0s | SP_Bellman_Ford | Graph::
0 | 0 | 0 | 0s | 0s | SP_Dijkstra | Graph::
0 | 0 | 0 | 0s | 0s | TransitiveClosure_Floyd_Warshall | Graph::
0 | 0 | 0 | 0s | 0s | _MST_attr | Graph::
0 | 0 | 0 | 0s | 0s | _MST_edges | Graph::
0 | 0 | 0 | 0s | 0s | _SPT_Bellman_Ford | Graph::
0 | 0 | 0 | 0s | 0s | _SPT_Bellman_Ford_compute | Graph::
0 | 0 | 0 | 0s | 0s | _SPT_Dijkstra_compute | Graph::
0 | 0 | 0 | 0s | 0s | _SPT_add | Graph::
0 | 0 | 0 | 0s | 0s | __ANON__[:1726] | Graph::
0 | 0 | 0 | 0s | 0s | __ANON__[:2211] | Graph::
0 | 0 | 0 | 0s | 0s | __ANON__[:2269] | Graph::
0 | 0 | 0 | 0s | 0s | __ANON__[:2817] | Graph::
0 | 0 | 0 | 0s | 0s | __ANON__[:2904] | Graph::
0 | 0 | 0 | 0s | 0s | __ANON__[:2908] | Graph::
0 | 0 | 0 | 0s | 0s | __ANON__[:2994] | Graph::
0 | 0 | 0 | 0s | 0s | __ANON__[:2998] | Graph::
0 | 0 | 0 | 0s | 0s | __ANON__[:3030] | Graph::
0 | 0 | 0 | 0s | 0s | __ANON__[:3034] | Graph::
0 | 0 | 0 | 0s | 0s | __ANON__[:3047] | Graph::
0 | 0 | 0 | 0s | 0s | __ANON__[:3623] | Graph::
0 | 0 | 0 | 0s | 0s | __ANON__[:3785] | Graph::
0 | 0 | 0 | 0s | 0s | __SPT_Bellman_Ford | Graph::
0 | 0 | 0 | 0s | 0s | __carp_confess | Graph::
0 | 0 | 0 | 0s | 0s | __factorial | Graph::
0 | 0 | 0 | 0s | 0s | __fisher_yates_shuffle | Graph::
0 | 0 | 0 | 0s | 0s | __stringified | Graph::
0 | 0 | 0 | 0s | 0s | _all_predecessors | Graph::
0 | 0 | 0 | 0s | 0s | _all_successors | Graph::
0 | 0 | 0 | 0s | 0s | _attr02_012 | Graph::
0 | 0 | 0 | 0s | 0s | _attr02_123 | Graph::
0 | 0 | 0 | 0s | 0s | _attr02_234 | Graph::
0 | 0 | 0 | 0s | 0s | _biconnectivity_compute | Graph::
0 | 0 | 0 | 0s | 0s | _biconnectivity_dfs | Graph::
0 | 0 | 0 | 0s | 0s | _biconnectivity_out | Graph::
0 | 0 | 0 | 0s | 0s | _can_deep_copy_Storable | Graph::
0 | 0 | 0 | 0s | 0s | _clear_cache | Graph::
0 | 0 | 0 | 0s | 0s | _deep_copy_DataDumper | Graph::
0 | 0 | 0 | 0s | 0s | _deep_copy_Storable | Graph::
0 | 0 | 0 | 0s | 0s | _defattr | Graph::
0 | 0 | 0 | 0s | 0s | _dump | Graph::
0 | 0 | 0 | 0s | 0s | _edges_at | Graph::
0 | 0 | 0 | 0s | 0s | _edges_id_path | Graph::
0 | 0 | 0 | 0s | 0s | _edges_to | Graph::
0 | 0 | 0 | 0s | 0s | _expected | Graph::
0 | 0 | 0 | 0s | 0s | _factorial | Graph::
0 | 0 | 0 | 0s | 0s | _get_edge_attribute | Graph::
0 | 0 | 0 | 0s | 0s | _get_union_find | Graph::
0 | 0 | 0 | 0s | 0s | _in_degree | Graph::
0 | 0 | 0 | 0s | 0s | _minmax_path | Graph::
0 | 0 | 0 | 0s | 0s | _next_alphabetic | Graph::
0 | 0 | 0 | 0s | 0s | _next_numeric | Graph::
0 | 0 | 0 | 0s | 0s | _out_degree | Graph::
0 | 0 | 0 | 0s | 0s | _set_edge_attribute | Graph::
0 | 0 | 0 | 0s | 0s | _strongly_connected_components | Graph::
0 | 0 | 0 | 0s | 0s | _strongly_connected_components_compute | Graph::
0 | 0 | 0 | 0s | 0s | _total_degree | Graph::
0 | 0 | 0 | 0s | 0s | _transitive_closure_matrix_compute | Graph::
0 | 0 | 0 | 0s | 0s | _undirected_copy_compute | Graph::
0 | 0 | 0 | 0s | 0s | _union_find_add_edge | Graph::
0 | 0 | 0 | 0s | 0s | _union_find_add_vertex | Graph::
0 | 0 | 0 | 0s | 0s | add_cycle | Graph::
0 | 0 | 0 | 0s | 0s | add_edge_by_id | Graph::
0 | 0 | 0 | 0s | 0s | add_edge_get_id | Graph::
0 | 0 | 0 | 0s | 0s | add_path | Graph::
0 | 0 | 0 | 0s | 0s | add_vertex_by_id | Graph::
0 | 0 | 0 | 0s | 0s | add_vertex_get_id | Graph::
0 | 0 | 0 | 0s | 0s | add_vertices | Graph::
0 | 0 | 0 | 0s | 0s | add_weighted_edge_by_id | Graph::
0 | 0 | 0 | 0s | 0s | add_weighted_edges | Graph::
0 | 0 | 0 | 0s | 0s | add_weighted_edges_by_id | Graph::
0 | 0 | 0 | 0s | 0s | add_weighted_path | Graph::
0 | 0 | 0 | 0s | 0s | add_weighted_path_by_id | Graph::
0 | 0 | 0 | 0s | 0s | add_weighted_vertex | Graph::
0 | 0 | 0 | 0s | 0s | add_weighted_vertex_by_id | Graph::
0 | 0 | 0 | 0s | 0s | add_weighted_vertices | Graph::
0 | 0 | 0 | 0s | 0s | add_weighted_vertices_by_id | Graph::
0 | 0 | 0 | 0s | 0s | all_neighbours | Graph::
0 | 0 | 0 | 0s | 0s | all_predecessors | Graph::
0 | 0 | 0 | 0s | 0s | all_reachable | Graph::
0 | 0 | 0 | 0s | 0s | all_successors | Graph::
0 | 0 | 0 | 0s | 0s | articulation_points | Graph::
0 | 0 | 0 | 0s | 0s | average_degree | Graph::
0 | 0 | 0 | 0s | 0s | average_path_length | Graph::
0 | 0 | 0 | 0s | 0s | betweenness | Graph::
0 | 0 | 0 | 0s | 0s | biconnected_component_by_index | Graph::
0 | 0 | 0 | 0s | 0s | biconnected_component_by_vertex | Graph::
0 | 0 | 0 | 0s | 0s | biconnected_components | Graph::
0 | 0 | 0 | 0s | 0s | biconnected_graph | Graph::
0 | 0 | 0 | 0s | 0s | biconnectivity | Graph::
0 | 0 | 0 | 0s | 0s | biconnectivity_clear_cache | Graph::
0 | 0 | 0 | 0s | 0s | bridges | Graph::
0 | 0 | 0 | 0s | 0s | center_vertices | Graph::
0 | 0 | 0 | 0s | 0s | clustering_coefficient | Graph::
0 | 0 | 0 | 0s | 0s | complement_graph | Graph::
0 | 0 | 0 | 0s | 0s | complete_graph | Graph::
0 | 0 | 0 | 0s | 0s | connected_component_by_index | Graph::
0 | 0 | 0 | 0s | 0s | connected_component_by_vertex | Graph::
0 | 0 | 0 | 0s | 0s | connected_graph | Graph::
0 | 0 | 0 | 0s | 0s | connectivity_clear_cache | Graph::
0 | 0 | 0 | 0s | 0s | copy | Graph::
0 | 0 | 0 | 0s | 0s | could_be_isomorphic | Graph::
0 | 0 | 0 | 0s | 0s | deep_copy | Graph::
0 | 0 | 0 | 0s | 0s | degree | Graph::
0 | 0 | 0 | 0s | 0s | delete_attribute | Graph::
0 | 0 | 0 | 0s | 0s | delete_attributes | Graph::
0 | 0 | 0 | 0s | 0s | delete_cycle | Graph::
0 | 0 | 0 | 0s | 0s | delete_edge | Graph::
0 | 0 | 0 | 0s | 0s | delete_edge_attribute | Graph::
0 | 0 | 0 | 0s | 0s | delete_edge_attribute_by_id | Graph::
0 | 0 | 0 | 0s | 0s | delete_edge_attributes | Graph::
0 | 0 | 0 | 0s | 0s | delete_edge_attributes_by_id | Graph::
0 | 0 | 0 | 0s | 0s | delete_edge_by_id | Graph::
0 | 0 | 0 | 0s | 0s | delete_edge_weight | Graph::
0 | 0 | 0 | 0s | 0s | delete_edge_weight_by_id | Graph::
0 | 0 | 0 | 0s | 0s | delete_edges | Graph::
0 | 0 | 0 | 0s | 0s | delete_path | Graph::
0 | 0 | 0 | 0s | 0s | delete_vertex | Graph::
0 | 0 | 0 | 0s | 0s | delete_vertex_attribute | Graph::
0 | 0 | 0 | 0s | 0s | delete_vertex_attribute_by_id | Graph::
0 | 0 | 0 | 0s | 0s | delete_vertex_attributes | Graph::
0 | 0 | 0 | 0s | 0s | delete_vertex_attributes_by_id | Graph::
0 | 0 | 0 | 0s | 0s | delete_vertex_by_id | Graph::
0 | 0 | 0 | 0s | 0s | delete_vertex_weight | Graph::
0 | 0 | 0 | 0s | 0s | delete_vertex_weight_by_id | Graph::
0 | 0 | 0 | 0s | 0s | delete_vertices | Graph::
0 | 0 | 0 | 0s | 0s | density | Graph::
0 | 0 | 0 | 0s | 0s | density_limits | Graph::
0 | 0 | 0 | 0s | 0s | diameter | Graph::
0 | 0 | 0 | 0s | 0s | directed_copy | Graph::
0 | 0 | 0 | 0s | 0s | edges02 | Graph::
0 | 0 | 0 | 0s | 0s | edges_at | Graph::
0 | 0 | 0 | 0s | 0s | edges_from | Graph::
0 | 0 | 0 | 0s | 0s | edges_to | Graph::
0 | 0 | 0 | 0s | 0s | eq | Graph::
0 | 0 | 0 | 0s | 0s | expect_acyclic | Graph::
0 | 0 | 0 | 0s | 0s | expect_dag | Graph::
0 | 0 | 0 | 0s | 0s | expect_directed | Graph::
0 | 0 | 0 | 0s | 0s | expect_multiedged | Graph::
0 | 0 | 0 | 0s | 0s | expect_multivertexed | Graph::
0 | 0 | 0 | 0s | 0s | expect_non_multivertexed | Graph::
0 | 0 | 0 | 0s | 0s | expect_non_unionfind | Graph::
0 | 0 | 0 | 0s | 0s | exterior_vertices | Graph::
0 | 0 | 0 | 0s | 0s | find_a_cycle | Graph::
0 | 0 | 0 | 0s | 0s | for_shortest_paths | Graph::
0 | 0 | 0 | 0s | 0s | get_attribute | Graph::
0 | 0 | 0 | 0s | 0s | get_attributes | Graph::
0 | 0 | 0 | 0s | 0s | get_edge_attribute_by_id | Graph::
0 | 0 | 0 | 0s | 0s | get_edge_attribute_names | Graph::
0 | 0 | 0 | 0s | 0s | get_edge_attribute_names_by_id | Graph::
0 | 0 | 0 | 0s | 0s | get_edge_attribute_values | Graph::
0 | 0 | 0 | 0s | 0s | get_edge_attribute_values_by_id | Graph::
0 | 0 | 0 | 0s | 0s | get_edge_attributes | Graph::
0 | 0 | 0 | 0s | 0s | get_edge_attributes_by_id | Graph::
0 | 0 | 0 | 0s | 0s | get_edge_count | Graph::
0 | 0 | 0 | 0s | 0s | get_edge_weight | Graph::
0 | 0 | 0 | 0s | 0s | get_edge_weight_by_id | Graph::
0 | 0 | 0 | 0s | 0s | get_multiedge_ids | Graph::
0 | 0 | 0 | 0s | 0s | get_multivertex_ids | Graph::
0 | 0 | 0 | 0s | 0s | get_vertex_attribute | Graph::
0 | 0 | 0 | 0s | 0s | get_vertex_attribute_by_id | Graph::
0 | 0 | 0 | 0s | 0s | get_vertex_attribute_names | Graph::
0 | 0 | 0 | 0s | 0s | get_vertex_attribute_names_by_id | Graph::
0 | 0 | 0 | 0s | 0s | get_vertex_attribute_values | Graph::
0 | 0 | 0 | 0s | 0s | get_vertex_attribute_values_by_id | Graph::
0 | 0 | 0 | 0s | 0s | get_vertex_attributes | Graph::
0 | 0 | 0 | 0s | 0s | get_vertex_attributes_by_id | Graph::
0 | 0 | 0 | 0s | 0s | get_vertex_count | Graph::
0 | 0 | 0 | 0s | 0s | get_vertex_weight | Graph::
0 | 0 | 0 | 0s | 0s | get_vertex_weight_by_id | Graph::
0 | 0 | 0 | 0s | 0s | has_a_cycle | Graph::
0 | 0 | 0 | 0s | 0s | has_attribute | Graph::
0 | 0 | 0 | 0s | 0s | has_attributes | Graph::
0 | 0 | 0 | 0s | 0s | has_cycle | Graph::
0 | 0 | 0 | 0s | 0s | has_edge_attribute | Graph::
0 | 0 | 0 | 0s | 0s | has_edge_attribute_by_id | Graph::
0 | 0 | 0 | 0s | 0s | has_edge_attributes | Graph::
0 | 0 | 0 | 0s | 0s | has_edge_attributes_by_id | Graph::
0 | 0 | 0 | 0s | 0s | has_edge_by_id | Graph::
0 | 0 | 0 | 0s | 0s | has_edge_weight | Graph::
0 | 0 | 0 | 0s | 0s | has_edge_weight_by_id | Graph::
0 | 0 | 0 | 0s | 0s | has_edges | Graph::
0 | 0 | 0 | 0s | 0s | has_path | Graph::
0 | 0 | 0 | 0s | 0s | has_vertex_attribute | Graph::
0 | 0 | 0 | 0s | 0s | has_vertex_attribute_by_id | Graph::
0 | 0 | 0 | 0s | 0s | has_vertex_attributes | Graph::
0 | 0 | 0 | 0s | 0s | has_vertex_attributes_by_id | Graph::
0 | 0 | 0 | 0s | 0s | has_vertex_by_id | Graph::
0 | 0 | 0 | 0s | 0s | has_vertex_weight | Graph::
0 | 0 | 0 | 0s | 0s | has_vertex_weight_by_id | Graph::
0 | 0 | 0 | 0s | 0s | has_vertices | Graph::
0 | 0 | 0 | 0s | 0s | hyperedged | Graph::
0 | 0 | 0 | 0s | 0s | hypervertexed | Graph::
0 | 0 | 0 | 0s | 0s | in_degree | Graph::
0 | 0 | 0 | 0s | 0s | in_edges | Graph::
0 | 0 | 0 | 0s | 0s | interior_vertices | Graph::
0 | 0 | 0 | 0s | 0s | is_acyclic | Graph::
0 | 0 | 0 | 0s | 0s | is_biconnected | Graph::
0 | 0 | 0 | 0s | 0s | is_connected | Graph::
0 | 0 | 0 | 0s | 0s | is_dag | Graph::
0 | 0 | 0 | 0s | 0s | is_edge_connected | Graph::
0 | 0 | 0 | 0s | 0s | is_edge_separable | Graph::
0 | 0 | 0 | 0s | 0s | is_exterior_vertex | Graph::
0 | 0 | 0 | 0s | 0s | is_interior_vertex | Graph::
0 | 0 | 0 | 0s | 0s | is_isolated_vertex | Graph::
0 | 0 | 0 | 0s | 0s | is_multi_graph | Graph::
0 | 0 | 0 | 0s | 0s | is_predecessorful_vertex | Graph::
0 | 0 | 0 | 0s | 0s | is_predecessorless_vertex | Graph::
0 | 0 | 0 | 0s | 0s | is_pseudo_graph | Graph::
0 | 0 | 0 | 0s | 0s | is_reachable | Graph::
0 | 0 | 0 | 0s | 0s | is_self_loop_vertex | Graph::
0 | 0 | 0 | 0s | 0s | is_simple_graph | Graph::
0 | 0 | 0 | 0s | 0s | is_sink_vertex | Graph::
0 | 0 | 0 | 0s | 0s | is_source_vertex | Graph::
0 | 0 | 0 | 0s | 0s | is_strongly_connected | Graph::
0 | 0 | 0 | 0s | 0s | is_successorful_vertex | Graph::
0 | 0 | 0 | 0s | 0s | is_successorless_vertex | Graph::
0 | 0 | 0 | 0s | 0s | is_transitive | Graph::
0 | 0 | 0 | 0s | 0s | is_weakly_connected | Graph::
0 | 0 | 0 | 0s | 0s | isolated_vertices | Graph::
0 | 0 | 0 | 0s | 0s | longest_path | Graph::
0 | 0 | 0 | 0s | 0s | ne | Graph::
0 | 0 | 0 | 0s | 0s | neighbours | Graph::
0 | 0 | 0 | 0s | 0s | omnivertexed | Graph::
0 | 0 | 0 | 0s | 0s | out_degree | Graph::
0 | 0 | 0 | 0s | 0s | out_edges | Graph::
0 | 0 | 0 | 0s | 0s | path_length | Graph::
0 | 0 | 0 | 0s | 0s | path_predecessor | Graph::
0 | 0 | 0 | 0s | 0s | path_vertices | Graph::
0 | 0 | 0 | 0s | 0s | predecessorful_vertices | Graph::
0 | 0 | 0 | 0s | 0s | predecessorless_vertices | Graph::
0 | 0 | 0 | 0s | 0s | predecessors | Graph::
0 | 0 | 0 | 0s | 0s | radius | Graph::
0 | 0 | 0 | 0s | 0s | random_edge | Graph::
0 | 0 | 0 | 0s | 0s | random_graph | Graph::
0 | 0 | 0 | 0s | 0s | random_predecessor | Graph::
0 | 0 | 0 | 0s | 0s | random_successor | Graph::
0 | 0 | 0 | 0s | 0s | random_vertex | Graph::
0 | 0 | 0 | 0s | 0s | refvertexed | Graph::
0 | 0 | 0 | 0s | 0s | refvertexed_stringified | Graph::
0 | 0 | 0 | 0s | 0s | same_biconnected_components | Graph::
0 | 0 | 0 | 0s | 0s | same_connected_components | Graph::
0 | 0 | 0 | 0s | 0s | same_strongly_connected_components | Graph::
0 | 0 | 0 | 0s | 0s | same_weakly_connected_components | Graph::
0 | 0 | 0 | 0s | 0s | self_loop_vertices | Graph::
0 | 0 | 0 | 0s | 0s | set_attribute | Graph::
0 | 0 | 0 | 0s | 0s | set_attributes | Graph::
0 | 0 | 0 | 0s | 0s | set_edge_attribute_by_id | Graph::
0 | 0 | 0 | 0s | 0s | set_edge_attributes | Graph::
0 | 0 | 0 | 0s | 0s | set_edge_attributes_by_id | Graph::
0 | 0 | 0 | 0s | 0s | set_edge_weight | Graph::
0 | 0 | 0 | 0s | 0s | set_edge_weight_by_id | Graph::
0 | 0 | 0 | 0s | 0s | set_vertex_attribute | Graph::
0 | 0 | 0 | 0s | 0s | set_vertex_attribute_by_id | Graph::
0 | 0 | 0 | 0s | 0s | set_vertex_attributes | Graph::
0 | 0 | 0 | 0s | 0s | set_vertex_attributes_by_id | Graph::
0 | 0 | 0 | 0s | 0s | set_vertex_weight | Graph::
0 | 0 | 0 | 0s | 0s | set_vertex_weight_by_id | Graph::
0 | 0 | 0 | 0s | 0s | shortest_path | Graph::
0 | 0 | 0 | 0s | 0s | sink_vertices | Graph::
0 | 0 | 0 | 0s | 0s | source_vertices | Graph::
0 | 0 | 0 | 0s | 0s | stringify | Graph::
0 | 0 | 0 | 0s | 0s | strong_connectivity_clear_cache | Graph::
0 | 0 | 0 | 0s | 0s | strongly_connected_component_by_index | Graph::
0 | 0 | 0 | 0s | 0s | strongly_connected_component_by_vertex | Graph::
0 | 0 | 0 | 0s | 0s | strongly_connected_components | Graph::
0 | 0 | 0 | 0s | 0s | strongly_connected_graph | Graph::
0 | 0 | 0 | 0s | 0s | subgraph_by_radius | Graph::
0 | 0 | 0 | 0s | 0s | successorful_vertices | Graph::
0 | 0 | 0 | 0s | 0s | successorless_vertices | Graph::
0 | 0 | 0 | 0s | 0s | topological_sort | Graph::
0 | 0 | 0 | 0s | 0s | transitive_closure_matrix | Graph::
0 | 0 | 0 | 0s | 0s | transpose_edge | Graph::
0 | 0 | 0 | 0s | 0s | transpose_graph | Graph::
0 | 0 | 0 | 0s | 0s | undirected_copy | Graph::
0 | 0 | 0 | 0s | 0s | undirected_copy_clear_cache | Graph::
0 | 0 | 0 | 0s | 0s | uniqedged | Graph::
0 | 0 | 0 | 0s | 0s | unique_edges | Graph::
0 | 0 | 0 | 0s | 0s | uniqvertexed | Graph::
0 | 0 | 0 | 0s | 0s | vertex | Graph::
0 | 0 | 0 | 0s | 0s | vertex_eccentricity | Graph::
0 | 0 | 0 | 0s | 0s | vertices_at | Graph::
0 | 0 | 0 | 0s | 0s | weakly_connected_component_by_index | Graph::
0 | 0 | 0 | 0s | 0s | weakly_connected_component_by_vertex | Graph::
0 | 0 | 0 | 0s | 0s | weakly_connected_components | Graph::
0 | 0 | 0 | 0s | 0s | weakly_connected_graph | Graph::
Line | State ments |
Time on line |
Calls | Time in subs |
Code |
---|---|---|---|---|---|
1 | package Graph; | ||||
2 | |||||
3 | 2 | 109µs | 2 | 61µs | # spent 40µs (18+21) within Graph::BEGIN@3 which was called:
# once (18µs+21µs) by Bio::Roary::OrderGenes::BEGIN@22 at line 3 # spent 40µs making 1 call to Graph::BEGIN@3
# spent 21µs making 1 call to strict::import |
4 | |||||
5 | # spent 3µs within Graph::BEGIN@5 which was called:
# once (3µs+0s) by Bio::Roary::OrderGenes::BEGIN@22 at line 11 | ||||
6 | 1 | 4µs | if (0) { # SET THIS TO ZERO FOR TESTING AND RELEASES! | ||
7 | $SIG{__DIE__ } = \&__carp_confess; | ||||
8 | $SIG{__WARN__} = \&__carp_confess; | ||||
9 | } | ||||
10 | sub __carp_confess { require Carp; Carp::confess(@_) } | ||||
11 | 1 | 18µs | 1 | 3µs | } # spent 3µs making 1 call to Graph::BEGIN@5 |
12 | |||||
13 | 2 | 115µs | 2 | 3.57ms | # spent 3.27ms (2.89+384µs) within Graph::BEGIN@13 which was called:
# once (2.89ms+384µs) by Bio::Roary::OrderGenes::BEGIN@22 at line 13 # spent 3.27ms making 1 call to Graph::BEGIN@13
# spent 301µs making 1 call to Exporter::import |
14 | |||||
15 | 2 | 64µs | 2 | 48µs | # spent 29µs (10+19) within Graph::BEGIN@15 which was called:
# once (10µs+19µs) by Bio::Roary::OrderGenes::BEGIN@22 at line 15 # spent 29µs making 1 call to Graph::BEGIN@15
# spent 19µs making 1 call to vars::import |
16 | |||||
17 | 1 | 2µs | $VERSION = '0.96'; | ||
18 | |||||
19 | 1 | 62µs | require 5.006; # Weak references are absolutely required. | ||
20 | |||||
21 | 1 | 60µs | my $can_deep_copy_Storable = # spent 326µs executing statements in string eval | ||
22 | eval 'require Storable; require B::Deparse; $Storable::VERSION >= 2.05 && $B::Deparse::VERSION >= 0.61' && !$@; | ||||
23 | |||||
24 | sub _can_deep_copy_Storable () { | ||||
25 | return $can_deep_copy_Storable; | ||||
26 | } | ||||
27 | |||||
28 | 2 | 132µs | 2 | 1.98ms | # spent 1.96ms (1.61+352µs) within Graph::BEGIN@28 which was called:
# once (1.61ms+352µs) by Bio::Roary::OrderGenes::BEGIN@22 at line 28 # spent 1.96ms making 1 call to Graph::BEGIN@28
# spent 20µs making 1 call to Exporter::import |
29 | 2 | 128µs | 2 | 3.19ms | # spent 3.17ms (1.32+1.85) within Graph::BEGIN@29 which was called:
# once (1.32ms+1.85ms) by Bio::Roary::OrderGenes::BEGIN@22 at line 29 # spent 3.17ms making 1 call to Graph::BEGIN@29
# spent 19µs making 1 call to Exporter::import |
30 | 2 | 29µs | 2 | 45µs | # spent 29µs (13+16) within Graph::BEGIN@30 which was called:
# once (13µs+16µs) by Bio::Roary::OrderGenes::BEGIN@22 at line 30 # spent 29µs making 1 call to Graph::BEGIN@30
# spent 16µs making 1 call to Exporter::import |
31 | 2 | 109µs | 1 | 590µs | # spent 590µs (565+25) within Graph::BEGIN@31 which was called:
# once (565µs+25µs) by Bio::Roary::OrderGenes::BEGIN@22 at line 31 # spent 590µs making 1 call to Graph::BEGIN@31 |
32 | 2 | 129µs | 1 | 4.77ms | # spent 4.77ms (487µs+4.29) within Graph::BEGIN@32 which was called:
# once (487µs+4.29ms) by Bio::Roary::OrderGenes::BEGIN@22 at line 32 # spent 4.77ms making 1 call to Graph::BEGIN@32 |
33 | 2 | 184µs | 1 | 4.14ms | # spent 4.14ms (346µs+3.80) within Graph::BEGIN@33 which was called:
# once (346µs+3.80ms) by Bio::Roary::OrderGenes::BEGIN@22 at line 33 # spent 4.14ms making 1 call to Graph::BEGIN@33 |
34 | 2 | 200µs | 2 | 1.37ms | # spent 1.34ms (442µs+895µs) within Graph::BEGIN@34 which was called:
# once (442µs+895µs) by Bio::Roary::OrderGenes::BEGIN@22 at line 34 # spent 1.34ms making 1 call to Graph::BEGIN@34
# spent 30µs making 1 call to Exporter::import |
35 | 2 | 172µs | 2 | 839µs | # spent 809µs (472+337) within Graph::BEGIN@35 which was called:
# once (472µs+337µs) by Bio::Roary::OrderGenes::BEGIN@22 at line 35 # spent 809µs making 1 call to Graph::BEGIN@35
# spent 31µs making 1 call to Exporter::import |
36 | 2 | 169µs | 1 | 485µs | # spent 485µs (312+173) within Graph::BEGIN@36 which was called:
# once (312µs+173µs) by Bio::Roary::OrderGenes::BEGIN@22 at line 36 # spent 485µs making 1 call to Graph::BEGIN@36 |
37 | |||||
38 | 2 | 178µs | 2 | 3.02ms | # spent 2.98ms (2.79+187µs) within Graph::BEGIN@38 which was called:
# once (2.79ms+187µs) by Bio::Roary::OrderGenes::BEGIN@22 at line 38 # spent 2.98ms making 1 call to Graph::BEGIN@38
# spent 36µs making 1 call to Exporter::import |
39 | 2 | 50µs | 2 | 112µs | # spent 98µs (25+73) within Graph::BEGIN@39 which was called:
# once (25µs+73µs) by Bio::Roary::OrderGenes::BEGIN@22 at line 39 # spent 98µs making 1 call to Graph::BEGIN@39
# spent 14µs making 1 call to List::Util::import |
40 | 2 | 43µs | 2 | 108µs | # spent 62µs (16+46) within Graph::BEGIN@40 which was called:
# once (16µs+46µs) by Bio::Roary::OrderGenes::BEGIN@22 at line 40 # spent 62µs making 1 call to Graph::BEGIN@40
# spent 46µs making 1 call to Exporter::import |
41 | |||||
42 | 2 | 371µs | 1 | 15.2ms | # spent 15.2ms (3.12+12.0) within Graph::BEGIN@42 which was called:
# once (3.12ms+12.0ms) by Bio::Roary::OrderGenes::BEGIN@22 at line 42 # spent 15.2ms making 1 call to Graph::BEGIN@42 |
43 | |||||
44 | sub _F () { 0 } # Flags. | ||||
45 | sub _G () { 1 } # Generation. | ||||
46 | sub _V () { 2 } # Vertices. | ||||
47 | sub _E () { 3 } # Edges. | ||||
48 | sub _A () { 4 } # Attributes. | ||||
49 | sub _U () { 5 } # Union-Find. | ||||
50 | sub _S () { 6 } # Successors. | ||||
51 | sub _P () { 7 } # Predecessors. | ||||
52 | |||||
53 | 1 | 500ns | my $Inf; | ||
54 | |||||
55 | # spent 26µs within Graph::BEGIN@55 which was called:
# once (26µs+0s) by Bio::Roary::OrderGenes::BEGIN@22 at line 61 | ||||
56 | 2 | 23µs | local $SIG{FPE}; | ||
57 | eval { $Inf = exp(999) } || | ||||
58 | eval { $Inf = 9**9**9 } || | ||||
59 | 1 | 800ns | eval { $Inf = 1e+999 } || | ||
60 | { $Inf = 1e+99 }; # Close enough for most practical purposes. | ||||
61 | 1 | 55µs | 1 | 26µs | } # spent 26µs making 1 call to Graph::BEGIN@55 |
62 | |||||
63 | sub Infinity () { $Inf } | ||||
64 | |||||
65 | # Graphs are blessed array references. | ||||
66 | # - The first element contains the flags. | ||||
67 | # - The second element is the vertices. | ||||
68 | # - The third element is the edges. | ||||
69 | # - The fourth element is the attributes of the whole graph. | ||||
70 | # The defined flags for Graph are: | ||||
71 | # - _COMPAT02 for user API compatibility with the Graph 0.20xxx series. | ||||
72 | # The vertices are contained in either a "simplemap" | ||||
73 | # (if no hypervertices) or in a "map". | ||||
74 | # The edges are always in a "map". | ||||
75 | # The defined flags for maps are: | ||||
76 | # - _COUNT for countedness: more than one instance | ||||
77 | # - _HYPER for hyperness: a different number of "coordinates" than usual; | ||||
78 | # expects one for vertices and two for edges | ||||
79 | # - _UNORD for unordered coordinates (a set): if _UNORD is not set | ||||
80 | # the coordinates are assumed to be meaningfully ordered | ||||
81 | # - _UNIQ for unique coordinates: if set duplicates are removed, | ||||
82 | # if not, duplicates are assumed to meaningful | ||||
83 | # - _UNORDUNIQ: just a union of _UNORD and UNIQ | ||||
84 | # Vertices are assumed to be _UNORDUNIQ; edges assume none of these flags. | ||||
85 | |||||
86 | 2 | 328µs | 2 | 1.27ms | # spent 1.16ms (949µs+207µs) within Graph::BEGIN@86 which was called:
# once (949µs+207µs) by Bio::Roary::OrderGenes::BEGIN@22 at line 86 # spent 1.16ms making 1 call to Graph::BEGIN@86
# spent 115µs making 1 call to Graph::Attribute::import |
87 | |||||
88 | sub _COMPAT02 () { 0x00000001 } | ||||
89 | |||||
90 | sub stringify { | ||||
91 | my $g = shift; | ||||
92 | my $u = $g->is_undirected; | ||||
93 | my $e = $u ? '=' : '-'; | ||||
94 | my @e = | ||||
95 | map { | ||||
96 | my @v = | ||||
97 | map { | ||||
98 | ref($_) eq 'ARRAY' ? "[" . join(" ", @$_) . "]" : "$_" | ||||
99 | } | ||||
100 | @$_; | ||||
101 | join($e, $u ? sort { "$a" cmp "$b" } @v : @v) } $g->edges05; | ||||
102 | my @s = sort { "$a" cmp "$b" } @e; | ||||
103 | push @s, sort { "$a" cmp "$b" } $g->isolated_vertices; | ||||
104 | join(",", @s); | ||||
105 | } | ||||
106 | |||||
107 | sub eq { | ||||
108 | "$_[0]" eq "$_[1]" | ||||
109 | } | ||||
110 | |||||
111 | sub ne { | ||||
112 | "$_[0]" ne "$_[1]" | ||||
113 | } | ||||
114 | |||||
115 | use overload | ||||
116 | 2 | 9µs | # spent 58µs (12+46) within Graph::BEGIN@116 which was called:
# once (12µs+46µs) by Bio::Roary::OrderGenes::BEGIN@22 at line 118 | ||
117 | 'eq' => \&eq, | ||||
118 | 1 | 386µs | 2 | 103µs | 'ne' => \≠ # spent 58µs making 1 call to Graph::BEGIN@116
# spent 46µs making 1 call to overload::import |
119 | |||||
120 | sub _opt { | ||||
121 | 672 | 3.43ms | my ($opt, $flags, %flags) = @_; | ||
122 | 3360 | 945µs | while (my ($flag, $FLAG) = each %flags) { | ||
123 | 224 | 131µs | if (exists $opt->{$flag}) { | ||
124 | $$flags |= $FLAG if $opt->{$flag}; | ||||
125 | delete $opt->{$flag}; | ||||
126 | } | ||||
127 | if (exists $opt->{my $non = "non$flag"}) { | ||||
128 | $$flags &= ~$FLAG if $opt->{$non}; | ||||
129 | delete $opt->{$non}; | ||||
130 | } | ||||
131 | } | ||||
132 | } | ||||
133 | |||||
134 | # spent 24.3ms within Graph::is_compat02 which was called 15177 times, avg 2µs/call:
# 15003 times (23.9ms+0s) by Graph::add_weighted_edge at line 1932, avg 2µs/call
# 134 times (222µs+0s) by Graph::edges at line 593, avg 2µs/call
# 38 times (136µs+0s) by Graph::vertices at line 423, avg 4µs/call
# 2 times (15µs+0s) by Graph::unique_vertices at line 451, avg 7µs/call | ||||
135 | 30354 | 33.3ms | my ($g) = @_; | ||
136 | $g->[ _F ] & _COMPAT02; | ||||
137 | } | ||||
138 | |||||
139 | 1 | 7µs | *compat02 = \&is_compat02; | ||
140 | |||||
141 | # spent 87.9ms within Graph::has_union_find which was called 54871 times, avg 2µs/call:
# 29935 times (48.5ms+0s) by Graph::add_edge at line 506, avg 2µs/call
# 24934 times (39.4ms+0s) by Graph::add_vertex at line 398, avg 2µs/call
# 2 times (7µs+0s) by Graph::_connected_components_compute at line 2715, avg 3µs/call | ||||
142 | 109742 | 115ms | my ($g) = @_; | ||
143 | ($g->[ _F ] & _UNIONFIND) && defined $g->[ _U ]; | ||||
144 | } | ||||
145 | |||||
146 | sub _get_union_find { | ||||
147 | my ($g) = @_; | ||||
148 | $g->[ _U ]; | ||||
149 | } | ||||
150 | |||||
151 | sub _opt_get { | ||||
152 | 448 | 763µs | my ($opt, $key, $var) = @_; | ||
153 | 148 | 126µs | if (exists $opt->{$key}) { | ||
154 | $$var = $opt->{$key}; | ||||
155 | delete $opt->{$key}; | ||||
156 | } | ||||
157 | } | ||||
158 | |||||
159 | # spent 348µs within Graph::_opt_unknown which was called 112 times, avg 3µs/call:
# 112 times (348µs+0s) by Graph::new at line 256, avg 3µs/call | ||||
160 | 224 | 410µs | my ($opt) = @_; | ||
161 | if (my @opt = keys %$opt) { | ||||
162 | my $f = (caller(1))[3]; | ||||
163 | require Carp; | ||||
164 | Carp::confess(sprintf | ||||
165 | "$f: Unknown option%s: @{[map { qq['$_'] } sort @opt]}", | ||||
166 | @opt > 1 ? 's' : ''); | ||||
167 | } | ||||
168 | } | ||||
169 | |||||
170 | # spent 16.6ms (6.23+10.4) within Graph::new which was called 112 times, avg 148µs/call:
# 38 times (2.03ms+3.30ms) by Graph::Traversal::reset at line 19 of Graph/Traversal.pm, avg 140µs/call
# 36 times (2.05ms+3.42ms) by Bio::Roary::OrderGenes::_reorder_connected_components at line 151 of lib/Bio/Roary/OrderGenes.pm, avg 152µs/call
# 36 times (1.91ms+3.37ms) by Graph::Undirected::new at line 46 of Graph/Undirected.pm, avg 147µs/call
# once (189µs+195µs) by Bio::Roary::OrderGenes::_build_group_graphs at line 120 of lib/Bio/Roary/OrderGenes.pm
# once (53µs+92µs) by Bio::Roary::OrderGenes::_create_accessory_graph at line 288 of lib/Bio/Roary/OrderGenes.pm | ||||
171 | 4032 | 4.77ms | my $class = shift; | ||
172 | my $gflags = 0; | ||||
173 | my $vflags; | ||||
174 | my $eflags; | ||||
175 | 112 | 1.58ms | my %opt = _get_options( \@_ ); # spent 1.58ms making 112 calls to Graph::_get_options, avg 14µs/call | ||
176 | |||||
177 | if (ref $class && $class->isa('Graph')) { | ||||
178 | 2 | 7.47ms | 2 | 34µs | # spent 23µs (11+12) within Graph::BEGIN@178 which was called:
# once (11µs+12µs) by Bio::Roary::OrderGenes::BEGIN@22 at line 178 # spent 23µs making 1 call to Graph::BEGIN@178
# spent 12µs making 1 call to strict::unimport |
179 | for my $c (qw(undirected refvertexed compat02 | ||||
180 | hypervertexed countvertexed multivertexed | ||||
181 | hyperedged countedged multiedged omniedged | ||||
182 | __stringified)) { | ||||
183 | # $opt{$c}++ if $class->$c; # 5.00504-incompatible | ||||
184 | if (&{"Graph::$c"}($class)) { $opt{$c}++ } | ||||
185 | } | ||||
186 | # $opt{unionfind}++ if $class->has_union_find; # 5.00504-incompatible | ||||
187 | if (&{"Graph::has_union_find"}($class)) { $opt{unionfind}++ } | ||||
188 | } | ||||
189 | |||||
190 | 112 | 548µs | _opt_get(\%opt, undirected => \$opt{omniedged}); # spent 548µs making 112 calls to Graph::_opt_get, avg 5µs/call | ||
191 | 112 | 195µs | _opt_get(\%opt, omnidirected => \$opt{omniedged}); # spent 195µs making 112 calls to Graph::_opt_get, avg 2µs/call | ||
192 | |||||
193 | 76 | 72µs | if (exists $opt{directed}) { | ||
194 | $opt{omniedged} = !$opt{directed}; | ||||
195 | delete $opt{directed}; | ||||
196 | } | ||||
197 | |||||
198 | my $vnonomni = | ||||
199 | $opt{nonomnivertexed} || | ||||
200 | (exists $opt{omnivertexed} && !$opt{omnivertexed}); | ||||
201 | my $vnonuniq = | ||||
202 | $opt{nonuniqvertexed} || | ||||
203 | (exists $opt{uniqvertexed} && !$opt{uniqvertexed}); | ||||
204 | |||||
205 | 112 | 2.63ms | _opt(\%opt, \$vflags, # spent 2.63ms making 112 calls to Graph::_opt, avg 23µs/call | ||
206 | countvertexed => _COUNT, | ||||
207 | multivertexed => _MULTI, | ||||
208 | hypervertexed => _HYPER, | ||||
209 | omnivertexed => _UNORD, | ||||
210 | uniqvertexed => _UNIQ, | ||||
211 | refvertexed => _REF, | ||||
212 | refvertexed_stringified => _REFSTR , | ||||
213 | __stringified => _STR, | ||||
214 | ); | ||||
215 | |||||
216 | 112 | 1.62ms | _opt(\%opt, \$eflags, # spent 1.62ms making 112 calls to Graph::_opt, avg 15µs/call | ||
217 | countedged => _COUNT, | ||||
218 | multiedged => _MULTI, | ||||
219 | hyperedged => _HYPER, | ||||
220 | omniedged => _UNORD, | ||||
221 | uniqedged => _UNIQ, | ||||
222 | ); | ||||
223 | |||||
224 | 112 | 730µs | _opt(\%opt, \$gflags, # spent 730µs making 112 calls to Graph::_opt, avg 7µs/call | ||
225 | compat02 => _COMPAT02, | ||||
226 | unionfind => _UNIONFIND, | ||||
227 | ); | ||||
228 | |||||
229 | if (exists $opt{vertices_unsorted}) { # Graph 0.20103 compat. | ||||
230 | my $unsorted = $opt{vertices_unsorted}; | ||||
231 | delete $opt{vertices_unsorted}; | ||||
232 | require Carp; | ||||
233 | Carp::confess("Graph: vertices_unsorted must be true") | ||||
234 | unless $unsorted; | ||||
235 | } | ||||
236 | |||||
237 | my @V; | ||||
238 | if ($opt{vertices}) { | ||||
239 | require Carp; | ||||
240 | Carp::confess("Graph: vertices should be an array ref") | ||||
241 | unless ref $opt{vertices} eq 'ARRAY'; | ||||
242 | @V = @{ $opt{vertices} }; | ||||
243 | delete $opt{vertices}; | ||||
244 | } | ||||
245 | |||||
246 | my @E; | ||||
247 | if ($opt{edges}) { | ||||
248 | unless (ref $opt{edges} eq 'ARRAY') { | ||||
249 | require Carp; | ||||
250 | Carp::confess("Graph: edges should be an array ref of array refs"); | ||||
251 | } | ||||
252 | @E = @{ $opt{edges} }; | ||||
253 | delete $opt{edges}; | ||||
254 | } | ||||
255 | |||||
256 | 112 | 348µs | _opt_unknown(\%opt); # spent 348µs making 112 calls to Graph::_opt_unknown, avg 3µs/call | ||
257 | |||||
258 | my $uflags; | ||||
259 | 224 | 65µs | if (defined $vflags) { | ||
260 | $uflags = $vflags; | ||||
261 | $uflags |= _UNORD unless $vnonomni; | ||||
262 | $uflags |= _UNIQ unless $vnonuniq; | ||||
263 | } else { | ||||
264 | $uflags = _UNORDUNIQ; | ||||
265 | $vflags = 0; | ||||
266 | } | ||||
267 | |||||
268 | if (!($vflags & _HYPER) && ($vflags & _UNORDUNIQ)) { | ||||
269 | my @but; | ||||
270 | push @but, 'unordered' if ($vflags & _UNORD); | ||||
271 | push @but, 'unique' if ($vflags & _UNIQ); | ||||
272 | require Carp; | ||||
273 | Carp::confess(sprintf "Graph: not hypervertexed but %s", | ||||
274 | join(' and ', @but)); | ||||
275 | } | ||||
276 | |||||
277 | unless (defined $eflags) { | ||||
278 | $eflags = ($gflags & _COMPAT02) ? _COUNT : 0; | ||||
279 | } | ||||
280 | |||||
281 | if (!($vflags & _HYPER) && ($vflags & _UNIQ)) { | ||||
282 | require Carp; | ||||
283 | Carp::confess("Graph: not hypervertexed but uniqvertexed"); | ||||
284 | } | ||||
285 | |||||
286 | if (($vflags & _COUNT) && ($vflags & _MULTI)) { | ||||
287 | require Carp; | ||||
288 | Carp::confess("Graph: both countvertexed and multivertexed"); | ||||
289 | } | ||||
290 | |||||
291 | if (($eflags & _COUNT) && ($eflags & _MULTI)) { | ||||
292 | require Carp; | ||||
293 | Carp::confess("Graph: both countedged and multiedged"); | ||||
294 | } | ||||
295 | |||||
296 | my $g = bless [ ], ref $class || $class; | ||||
297 | |||||
298 | $g->[ _F ] = $gflags; | ||||
299 | $g->[ _G ] = 0; | ||||
300 | 112 | 1.71ms | $g->[ _V ] = ($vflags & (_HYPER | _MULTI)) ? # spent 1.71ms making 112 calls to Graph::AdjacencyMap::Light::_new, avg 15µs/call | ||
301 | Graph::AdjacencyMap::Heavy->_new($uflags, 1) : | ||||
302 | (($vflags & ~_UNORD) ? | ||||
303 | Graph::AdjacencyMap::Vertex->_new($uflags, 1) : | ||||
304 | Graph::AdjacencyMap::Light->_new($g, $uflags, 1)); | ||||
305 | 112 | 1.00ms | $g->[ _E ] = (($vflags & _HYPER) || ($eflags & ~_UNORD)) ? # spent 1.00ms making 112 calls to Graph::AdjacencyMap::Light::_new, avg 9µs/call | ||
306 | Graph::AdjacencyMap::Heavy->_new($eflags, 2) : | ||||
307 | Graph::AdjacencyMap::Light->_new($g, $eflags, 2); | ||||
308 | |||||
309 | $g->add_vertices(@V) if @V; | ||||
310 | |||||
311 | if (@E) { | ||||
312 | for my $e (@E) { | ||||
313 | unless (ref $e eq 'ARRAY') { | ||||
314 | require Carp; | ||||
315 | Carp::confess("Graph: edges should be array refs"); | ||||
316 | } | ||||
317 | $g->add_edge(@$e); | ||||
318 | } | ||||
319 | } | ||||
320 | |||||
321 | if (($gflags & _UNIONFIND)) { | ||||
322 | $g->[ _U ] = Graph::UnionFind->new; | ||||
323 | } | ||||
324 | |||||
325 | return $g; | ||||
326 | } | ||||
327 | |||||
328 | 38 | 187µs | 38 | 19µs | # spent 177µs (158+19) within Graph::countvertexed which was called 38 times, avg 5µs/call:
# 38 times (158µs+19µs) by Graph::vertices at line 426, avg 5µs/call # spent 19µs making 38 calls to Graph::AdjacencyMap::Light::_is_COUNT, avg 508ns/call |
329 | 24972 | 93.6ms | 24972 | 11.2ms | sub multivertexed { $_[0]->[ _V ]->_is_MULTI } # spent 11.2ms making 24972 calls to Graph::AdjacencyMap::Light::_is_MULTI, avg 447ns/call |
330 | sub hypervertexed { $_[0]->[ _V ]->_is_HYPER } | ||||
331 | sub omnivertexed { $_[0]->[ _V ]->_is_UNORD } | ||||
332 | sub uniqvertexed { $_[0]->[ _V ]->_is_UNIQ } | ||||
333 | sub refvertexed { $_[0]->[ _V ]->_is_REF } | ||||
334 | sub refvertexed_stringified { $_[0]->[ _V ]->_is_REFSTR } | ||||
335 | sub __stringified { $_[0]->[ _V ]->_is_STR } | ||||
336 | |||||
337 | 172 | 777µs | 172 | 142µs | # spent 789µs (646+142) within Graph::countedged which was called 172 times, avg 5µs/call:
# 134 times (490µs+73µs) by Graph::edges at line 596, avg 4µs/call
# 38 times (156µs+70µs) by Graph::Traversal::configure at line 77 of Graph/Traversal.pm, avg 6µs/call # spent 77µs making 141 calls to Graph::AdjacencyMap::Light::_is_COUNT, avg 544ns/call
# spent 66µs making 31 calls to Graph::AdjacencyMap::_is_COUNT, avg 2µs/call |
338 | 70075 | 177ms | 70075 | 57.8ms | # spent 251ms (193+57.8) within Graph::multiedged which was called 70075 times, avg 4µs/call:
# 39968 times (113ms+37.4ms) by Graph::expect_non_multiedged at line 2115, avg 4µs/call
# 29935 times (79.2ms+20.3ms) by Graph::add_edge at line 490, avg 3µs/call
# 134 times (378µs+67µs) by Graph::edges at line 596, avg 3µs/call
# 38 times (135µs+43µs) by Graph::Traversal::configure at line 77 of Graph/Traversal.pm, avg 5µs/call # spent 53.1ms making 59852 calls to Graph::AdjacencyMap::_is_MULTI, avg 887ns/call
# spent 4.67ms making 10223 calls to Graph::AdjacencyMap::Light::_is_MULTI, avg 457ns/call |
339 | sub hyperedged { $_[0]->[ _E ]->_is_HYPER } | ||||
340 | 24914 | 59.5ms | 24914 | 27.1ms | sub omniedged { $_[0]->[ _E ]->_is_UNORD } # spent 27.1ms making 24914 calls to Graph::AdjacencyMap::_is_UNORD, avg 1µs/call |
341 | sub uniqedged { $_[0]->[ _E ]->_is_UNIQ } | ||||
342 | |||||
343 | 1 | 2µs | *undirected = \&omniedged; | ||
344 | 1 | 2µs | *omnidirected = \&omniedged; | ||
345 | 38 | 179µs | 38 | 56µs | # spent 293µs (238+56) within Graph::directed which was called 38 times, avg 8µs/call:
# 38 times (238µs+56µs) by Graph::Traversal::reset at line 19 of Graph/Traversal.pm, avg 8µs/call # spent 56µs making 38 calls to Graph::AdjacencyMap::_is_UNORD, avg 1µs/call |
346 | |||||
347 | 1 | 1µs | *is_directed = \&directed; | ||
348 | 1 | 2µs | *is_undirected = \&undirected; | ||
349 | |||||
350 | 1 | 2µs | *is_countvertexed = \&countvertexed; | ||
351 | 1 | 1µs | *is_multivertexed = \&multivertexed; | ||
352 | 1 | 1µs | *is_hypervertexed = \&hypervertexed; | ||
353 | 1 | 2µs | *is_omnidirected = \&omnidirected; | ||
354 | 1 | 2µs | *is_uniqvertexed = \&uniqvertexed; | ||
355 | 1 | 2µs | *is_refvertexed = \&refvertexed; | ||
356 | 1 | 1µs | *is_refvertexed_stringified = \&refvertexed_stringified; | ||
357 | |||||
358 | 1 | 2µs | *is_countedged = \&countedged; | ||
359 | 1 | 2µs | *is_multiedged = \&multiedged; | ||
360 | 1 | 2µs | *is_hyperedged = \&hyperedged; | ||
361 | 1 | 1µs | *is_omniedged = \&omniedged; | ||
362 | 1 | 1µs | *is_uniqedged = \&uniqedged; | ||
363 | |||||
364 | sub _union_find_add_vertex { | ||||
365 | my ($g, $v) = @_; | ||||
366 | my $UF = $g->[ _U ]; | ||||
367 | $UF->add( $g->[ _V ]->_get_path_id( $v ) ); | ||||
368 | } | ||||
369 | |||||
370 | # spent 491ms (241+250) within Graph::add_vertex which was called 24934 times, avg 20µs/call:
# 24934 times (241ms+250ms) by Graph::_add_edge at line 469, avg 20µs/call | ||||
371 | 224406 | 145ms | my $g = shift; | ||
372 | 24934 | 78.9ms | if ($g->is_multivertexed) { # spent 78.9ms making 24934 calls to Graph::multivertexed, avg 3µs/call | ||
373 | return $g->add_vertex_by_id(@_, _GEN_ID); | ||||
374 | } | ||||
375 | my @r; | ||||
376 | if (@_ > 1) { | ||||
377 | unless ($g->is_countvertexed || $g->is_hypervertexed) { | ||||
378 | require Carp; | ||||
379 | Carp::croak("Graph::add_vertex: use add_vertices for more than one vertex or use hypervertexed"); | ||||
380 | } | ||||
381 | for my $v ( @_ ) { | ||||
382 | if (defined $v) { | ||||
383 | $g->[ _V ]->set_path( $v ) unless $g->has_vertex( $v ); | ||||
384 | } else { | ||||
385 | require Carp; | ||||
386 | Carp::croak("Graph::add_vertex: undef vertex"); | ||||
387 | } | ||||
388 | } | ||||
389 | } | ||||
390 | for my $v ( @_ ) { | ||||
391 | 24934 | 18.0ms | unless (defined $v) { | ||
392 | require Carp; | ||||
393 | Carp::croak("Graph::add_vertex: undef vertex"); | ||||
394 | } | ||||
395 | } | ||||
396 | 24934 | 132ms | $g->[ _V ]->set_path( @_ ); # spent 132ms making 24934 calls to Graph::AdjacencyMap::Light::set_path, avg 5µs/call | ||
397 | $g->[ _G ]++; | ||||
398 | 24934 | 39.4ms | $g->_union_find_add_vertex( @_ ) if $g->has_union_find; # spent 39.4ms making 24934 calls to Graph::has_union_find, avg 2µs/call | ||
399 | return $g; | ||||
400 | } | ||||
401 | |||||
402 | # spent 9.00ms within Graph::has_vertex which was called 4871 times, avg 2µs/call:
# 4871 times (9.00ms+0s) by Bio::Roary::OrderGenes::_remove_weak_edges_from_graph at line 325 of lib/Bio/Roary/OrderGenes.pm, avg 2µs/call | ||||
403 | 14613 | 11.8ms | my $g = shift; | ||
404 | my $V = $g->[ _V ]; | ||||
405 | return exists $V->[ _s ]->{ $_[0] } if ($V->[ _f ] & _LIGHT); | ||||
406 | $V->has_path( @_ ); | ||||
407 | } | ||||
408 | |||||
409 | # spent 34.7ms (18.5+16.3) within Graph::vertices05 which was called 76 times, avg 457µs/call:
# 38 times (8.94ms+7.46ms) by Graph::vertices at line 422, avg 432µs/call
# 36 times (3.83ms+3.60ms) by Graph::_root_opt at line 2329, avg 206µs/call
# 2 times (5.69ms+5.19ms) by Graph::unique_vertices at line 450, avg 5.44ms/call | ||||
410 | 228 | 18.5ms | my $g = shift; | ||
411 | 76 | 16.2ms | my @v = $g->[ _V ]->paths( @_ ); # spent 16.2ms making 76 calls to Graph::AdjacencyMap::Light::paths, avg 213µs/call | ||
412 | 76 | 95µs | if (wantarray) { # spent 95µs making 76 calls to Graph::AdjacencyMap::Light::_is_HYPER, avg 1µs/call | ||
413 | return $g->[ _V ]->_is_HYPER ? | ||||
414 | @v : map { ref $_ eq 'ARRAY' ? @$_ : $_ } @v; | ||||
415 | } else { | ||||
416 | return scalar @v; | ||||
417 | } | ||||
418 | } | ||||
419 | |||||
420 | # spent 20.7ms (3.87+16.9) within Graph::vertices which was called 38 times, avg 546µs/call:
# 38 times (3.87ms+16.9ms) by Graph::Traversal::reset at line 12 of Graph/Traversal.pm, avg 546µs/call | ||||
421 | 114 | 1.94ms | my $g = shift; | ||
422 | 38 | 16.4ms | my @v = $g->vertices05; # spent 16.4ms making 38 calls to Graph::vertices05, avg 432µs/call | ||
423 | 38 | 145µs | 38 | 136µs | if ($g->is_compat02) { # spent 136µs making 38 calls to Graph::is_compat02, avg 4µs/call |
424 | wantarray ? sort @v : scalar @v; | ||||
425 | } else { | ||||
426 | 38 | 1.67ms | 76 | 332µs | if ($g->is_multivertexed || $g->is_countvertexed) { # spent 177µs making 38 calls to Graph::countvertexed, avg 5µs/call
# spent 155µs making 38 calls to Graph::multivertexed, avg 4µs/call |
427 | if (wantarray) { | ||||
428 | my @V; | ||||
429 | for my $v ( @v ) { | ||||
430 | push @V, ($v) x $g->get_vertex_count($v); | ||||
431 | } | ||||
432 | return @V; | ||||
433 | } else { | ||||
434 | my $V = 0; | ||||
435 | for my $v ( @v ) { | ||||
436 | $V += $g->get_vertex_count($v); | ||||
437 | } | ||||
438 | return $V; | ||||
439 | } | ||||
440 | } else { | ||||
441 | return @v; | ||||
442 | } | ||||
443 | } | ||||
444 | } | ||||
445 | |||||
446 | 1 | 9µs | *vertices_unsorted = \&vertices_unsorted; # Graph 0.20103 compat. | ||
447 | |||||
448 | # spent 12.1ms (1.21+10.9) within Graph::unique_vertices which was called 2 times, avg 6.05ms/call:
# 2 times (1.21ms+10.9ms) by Graph::_connected_components_compute at line 2737, avg 6.05ms/call | ||||
449 | 6 | 746µs | my $g = shift; | ||
450 | 2 | 10.9ms | my @v = $g->vertices05; # spent 10.9ms making 2 calls to Graph::vertices05, avg 5.44ms/call | ||
451 | 2 | 446µs | 2 | 15µs | if ($g->is_compat02) { # spent 15µs making 2 calls to Graph::is_compat02, avg 7µs/call |
452 | wantarray ? sort @v : scalar @v; | ||||
453 | } else { | ||||
454 | return @v; | ||||
455 | } | ||||
456 | } | ||||
457 | |||||
458 | sub has_vertices { | ||||
459 | my $g = shift; | ||||
460 | scalar $g->[ _V ]->has_paths( @_ ); | ||||
461 | } | ||||
462 | |||||
463 | # spent 721ms (231+491) within Graph::_add_edge which was called 29935 times, avg 24µs/call:
# 29935 times (231ms+491ms) by Graph::add_edge at line 503, avg 24µs/call | ||||
464 | 149675 | 87.8ms | my $g = shift; | ||
465 | my $V = $g->[ _V ]; | ||||
466 | my @e; | ||||
467 | 29935 | 12.8ms | if (($V->[ _f ]) & _LIGHT) { | ||
468 | for my $v ( @_ ) { | ||||
469 | 119740 | 96.5ms | 24934 | 491ms | $g->add_vertex( $v ) unless exists $V->[ _s ]->{ $v }; # spent 491ms making 24934 calls to Graph::add_vertex, avg 20µs/call |
470 | push @e, $V->[ _s ]->{ $v }; | ||||
471 | } | ||||
472 | } else { | ||||
473 | my $h = $g->[ _V ]->_is_HYPER; | ||||
474 | for my $v ( @_ ) { | ||||
475 | my @v = ref $v eq 'ARRAY' && $h ? @$v : $v; | ||||
476 | $g->add_vertex( @v ) unless $V->has_path( @v ); | ||||
477 | push @e, $V->_get_path_id( @v ); | ||||
478 | } | ||||
479 | } | ||||
480 | return @e; | ||||
481 | } | ||||
482 | |||||
483 | sub _union_find_add_edge { | ||||
484 | my ($g, $u, $v) = @_; | ||||
485 | $g->[ _U ]->union($u, $v); | ||||
486 | } | ||||
487 | |||||
488 | # spent 1.88s (312ms+1.57) within Graph::add_edge which was called 29935 times, avg 63µs/call:
# 15003 times (153ms+818ms) by Graph::add_weighted_edge at line 1938, avg 65µs/call
# 9910 times (105ms+419ms) by Graph::Traversal::next at line 301 of Graph/Traversal.pm, avg 53µs/call
# 4955 times (53.4ms+324ms) by Graph::set_edge_attribute at line 1468, avg 76µs/call
# 67 times (828µs+4.23ms) by Graph::add_edges at line 1678, avg 75µs/call | ||||
489 | 239480 | 215ms | my $g = shift; | ||
490 | 29935 | 99.4ms | if ($g->is_multiedged) { # spent 99.4ms making 29935 calls to Graph::multiedged, avg 3µs/call | ||
491 | unless (@_ == 2 || $g->is_hyperedged) { | ||||
492 | require Carp; | ||||
493 | Carp::croak("Graph::add_edge: use add_edges for more than one edge"); | ||||
494 | } | ||||
495 | return $g->add_edge_by_id(@_, _GEN_ID); | ||||
496 | } | ||||
497 | unless (@_ == 2) { | ||||
498 | unless ($g->is_hyperedged) { | ||||
499 | require Carp; | ||||
500 | Carp::croak("Graph::add_edge: graph is not hyperedged"); | ||||
501 | } | ||||
502 | } | ||||
503 | 29935 | 721ms | my @e = $g->_add_edge( @_ ); # spent 721ms making 29935 calls to Graph::_add_edge, avg 24µs/call | ||
504 | 29935 | 697ms | $g->[ _E ]->set_path( @e ); # spent 592ms making 19958 calls to Graph::AdjacencyMap::Heavy::set_path, avg 30µs/call
# spent 105ms making 9977 calls to Graph::AdjacencyMap::Light::set_path, avg 10µs/call | ||
505 | $g->[ _G ]++; | ||||
506 | 29935 | 48.5ms | $g->_union_find_add_edge( @e ) if $g->has_union_find; # spent 48.5ms making 29935 calls to Graph::has_union_find, avg 2µs/call | ||
507 | return $g; | ||||
508 | } | ||||
509 | |||||
510 | sub _vertex_ids { | ||||
511 | 124825 | 74.5ms | my $g = shift; | ||
512 | my $V = $g->[ _V ]; | ||||
513 | my @e; | ||||
514 | 24965 | 15.3ms | if (($V->[ _f ] & _LIGHT)) { | ||
515 | for my $v ( @_ ) { | ||||
516 | 99860 | 50.0ms | return () unless exists $V->[ _s ]->{ $v }; | ||
517 | push @e, $V->[ _s ]->{ $v }; | ||||
518 | } | ||||
519 | } else { | ||||
520 | my $h = $g->[ _V ]->_is_HYPER; | ||||
521 | for my $v ( @_ ) { | ||||
522 | my @v = ref $v eq 'ARRAY' && $h ? @$v : $v; | ||||
523 | return () unless $V->has_path( @v ); | ||||
524 | push @e, $V->_get_path_id( @v ); | ||||
525 | } | ||||
526 | } | ||||
527 | return @e; | ||||
528 | } | ||||
529 | |||||
530 | # spent 276ms (253+22.7) within Graph::has_edge which was called 34963 times, avg 8µs/call:
# 19958 times (139ms+12.8ms) by Graph::set_edge_attribute at line 1468, avg 8µs/call
# 9998 times (65.5ms+4.92ms) by Bio::Roary::OrderGenes::_reorder_connected_components at line 162 of lib/Bio/Roary/OrderGenes.pm, avg 7µs/call
# 5007 times (48.5ms+4.99ms) by Graph::get_edge_attribute at line 1567, avg 11µs/call | ||||
531 | 227369 | 51.8ms | my $g = shift; | ||
532 | my $E = $g->[ _E ]; | ||||
533 | my $V = $g->[ _V ]; | ||||
534 | my @i; | ||||
535 | 61240 | 68.9ms | if (($V->[ _f ] & _LIGHT) && @_ == 2) { | ||
536 | return 0 unless | ||||
537 | exists $V->[ _s ]->{ $_[0] } && | ||||
538 | exists $V->[ _s ]->{ $_[1] }; | ||||
539 | @i = @{ $V->[ _s ] }{ @_[ 0, 1 ] }; | ||||
540 | } else { | ||||
541 | @i = $g->_vertex_ids( @_ ); | ||||
542 | return 0 if @i == 0 && @_; | ||||
543 | } | ||||
544 | my $f = $E->[ _f ]; | ||||
545 | 52554 | 147ms | if ($E->[ _a ] == 2 && @i == 2 && !($f & (_HYPER|_REF|_UNIQ))) { # Fast path. | ||
546 | 26277 | 22.7ms | @i = sort @i if ($f & _UNORD); # spent 22.7ms making 26277 calls to Graph::CORE:sort, avg 865ns/call | ||
547 | return exists $E->[ _s ]->{ $i[0] } && | ||||
548 | exists $E->[ _s ]->{ $i[0] }->{ $i[1] } ? 1 : 0; | ||||
549 | } else { | ||||
550 | return defined $E->_get_path_id( @i ) ? 1 : 0; | ||||
551 | } | ||||
552 | } | ||||
553 | |||||
554 | # spent 3.24ms (1.92+1.32) within Graph::edges05 which was called 134 times, avg 24µs/call:
# 134 times (1.92ms+1.32ms) by Graph::edges at line 611, avg 24µs/call | ||||
555 | 536 | 789µs | my $g = shift; | ||
556 | my $V = $g->[ _V ]; | ||||
557 | 134 | 709µs | my @e = $g->[ _E ]->paths( @_ ); # spent 709µs making 134 calls to Graph::AdjacencyMap::Light::paths, avg 5µs/call | ||
558 | wantarray ? | ||||
559 | 536 | 686µs | 201 | 607µs | map { [ map { my @v = $V->_get_id_path($_); # spent 607µs making 201 calls to Graph::AdjacencyMap::Light::_get_id_path, avg 3µs/call |
560 | @v == 1 ? $v[0] : [ @v ] } | ||||
561 | @$_ ] } | ||||
562 | @e : @e; | ||||
563 | } | ||||
564 | |||||
565 | sub edges02 { | ||||
566 | my $g = shift; | ||||
567 | if (@_ && defined $_[0]) { | ||||
568 | unless (defined $_[1]) { | ||||
569 | my @e = $g->edges_at($_[0]); | ||||
570 | wantarray ? | ||||
571 | map { @$_ } | ||||
572 | sort { $a->[0] cmp $b->[0] || $a->[1] cmp $b->[1] } @e | ||||
573 | : @e; | ||||
574 | } else { | ||||
575 | die "edges02: unimplemented option"; | ||||
576 | } | ||||
577 | } else { | ||||
578 | my @e = map { ($_) x $g->get_edge_count(@$_) } $g->edges05( @_ ); | ||||
579 | wantarray ? | ||||
580 | map { @$_ } | ||||
581 | sort { $a->[0] cmp $b->[0] || $a->[1] cmp $b->[1] } @e | ||||
582 | : @e; | ||||
583 | } | ||||
584 | } | ||||
585 | |||||
586 | sub unique_edges { | ||||
587 | my $g = shift; | ||||
588 | ($g->is_compat02) ? $g->edges02( @_ ) : $g->edges05( @_ ); | ||||
589 | } | ||||
590 | |||||
591 | # spent 5.98ms (1.51+4.47) within Graph::edges which was called 134 times, avg 45µs/call:
# 67 times (939µs+2.36ms) by Graph::AdjacencyMap::Light::__attr at line 221 of Graph/AdjacencyMap/Light.pm, avg 49µs/call
# 67 times (570µs+2.10ms) by Graph::AdjacencyMap::Light::__attr at line 225 of Graph/AdjacencyMap/Light.pm, avg 40µs/call | ||||
592 | 268 | 204µs | my $g = shift; | ||
593 | 134 | 359µs | 134 | 222µs | if ($g->is_compat02) { # spent 222µs making 134 calls to Graph::is_compat02, avg 2µs/call |
594 | return $g->edges02( @_ ); | ||||
595 | } else { | ||||
596 | 134 | 482µs | 268 | 1.01ms | if ($g->is_multiedged || $g->is_countedged) { # spent 563µs making 134 calls to Graph::countedged, avg 4µs/call
# spent 445µs making 134 calls to Graph::multiedged, avg 3µs/call |
597 | if (wantarray) { | ||||
598 | my @E; | ||||
599 | for my $e ( $g->edges05 ) { | ||||
600 | push @E, ($e) x $g->get_edge_count(@$e); | ||||
601 | } | ||||
602 | return @E; | ||||
603 | } else { | ||||
604 | my $E = 0; | ||||
605 | for my $e ( $g->edges05 ) { | ||||
606 | $E += $g->get_edge_count(@$e); | ||||
607 | } | ||||
608 | return $E; | ||||
609 | } | ||||
610 | } else { | ||||
611 | 134 | 3.24ms | return $g->edges05; # spent 3.24ms making 134 calls to Graph::edges05, avg 24µs/call | ||
612 | } | ||||
613 | } | ||||
614 | } | ||||
615 | |||||
616 | sub has_edges { | ||||
617 | my $g = shift; | ||||
618 | scalar $g->[ _E ]->has_paths( @_ ); | ||||
619 | } | ||||
620 | |||||
621 | ### | ||||
622 | # by_id | ||||
623 | # | ||||
624 | |||||
625 | sub add_vertex_by_id { | ||||
626 | my $g = shift; | ||||
627 | $g->expect_multivertexed; | ||||
628 | $g->[ _V ]->set_path_by_multi_id( @_ ); | ||||
629 | $g->[ _G ]++; | ||||
630 | $g->_union_find_add_vertex( @_ ) if $g->has_union_find; | ||||
631 | return $g; | ||||
632 | } | ||||
633 | |||||
634 | sub add_vertex_get_id { | ||||
635 | my $g = shift; | ||||
636 | $g->expect_multivertexed; | ||||
637 | my $id = $g->[ _V ]->set_path_by_multi_id( @_, _GEN_ID ); | ||||
638 | $g->[ _G ]++; | ||||
639 | $g->_union_find_add_vertex( @_ ) if $g->has_union_find; | ||||
640 | return $id; | ||||
641 | } | ||||
642 | |||||
643 | sub has_vertex_by_id { | ||||
644 | my $g = shift; | ||||
645 | $g->expect_multivertexed; | ||||
646 | $g->[ _V ]->has_path_by_multi_id( @_ ); | ||||
647 | } | ||||
648 | |||||
649 | sub delete_vertex_by_id { | ||||
650 | my $g = shift; | ||||
651 | $g->expect_multivertexed; | ||||
652 | $g->expect_non_unionfind; | ||||
653 | my $V = $g->[ _V ]; | ||||
654 | return unless $V->has_path_by_multi_id( @_ ); | ||||
655 | # TODO: what to about the edges at this vertex? | ||||
656 | # If the multiness of this vertex goes to zero, delete the edges? | ||||
657 | $V->del_path_by_multi_id( @_ ); | ||||
658 | $g->[ _G ]++; | ||||
659 | return $g; | ||||
660 | } | ||||
661 | |||||
662 | sub get_multivertex_ids { | ||||
663 | my $g = shift; | ||||
664 | $g->expect_multivertexed; | ||||
665 | $g->[ _V ]->get_multi_ids( @_ ); | ||||
666 | } | ||||
667 | |||||
668 | sub add_edge_by_id { | ||||
669 | my $g = shift; | ||||
670 | $g->expect_multiedged; | ||||
671 | my $id = pop; | ||||
672 | my @e = $g->_add_edge( @_ ); | ||||
673 | $g->[ _E ]->set_path_by_multi_id( @e, $id ); | ||||
674 | $g->[ _G ]++; | ||||
675 | $g->_union_find_add_edge( @e ) if $g->has_union_find; | ||||
676 | return $g; | ||||
677 | } | ||||
678 | |||||
679 | sub add_edge_get_id { | ||||
680 | my $g = shift; | ||||
681 | $g->expect_multiedged; | ||||
682 | my @i = $g->_add_edge( @_ ); | ||||
683 | my $id = $g->[ _E ]->set_path_by_multi_id( @i, _GEN_ID ); | ||||
684 | $g->_union_find_add_edge( @i ) if $g->has_union_find; | ||||
685 | $g->[ _G ]++; | ||||
686 | return $id; | ||||
687 | } | ||||
688 | |||||
689 | sub has_edge_by_id { | ||||
690 | my $g = shift; | ||||
691 | $g->expect_multiedged; | ||||
692 | my $id = pop; | ||||
693 | my @i = $g->_vertex_ids( @_ ); | ||||
694 | return 0 if @i == 0 && @_; | ||||
695 | $g->[ _E ]->has_path_by_multi_id( @i, $id ); | ||||
696 | } | ||||
697 | |||||
698 | sub delete_edge_by_id { | ||||
699 | my $g = shift; | ||||
700 | $g->expect_multiedged; | ||||
701 | $g->expect_non_unionfind; | ||||
702 | my $V = $g->[ _E ]; | ||||
703 | my $id = pop; | ||||
704 | my @i = $g->_vertex_ids( @_ ); | ||||
705 | return unless $V->has_path_by_multi_id( @i, $id ); | ||||
706 | $V->del_path_by_multi_id( @i, $id ); | ||||
707 | $g->[ _G ]++; | ||||
708 | return $g; | ||||
709 | } | ||||
710 | |||||
711 | sub get_multiedge_ids { | ||||
712 | my $g = shift; | ||||
713 | $g->expect_multiedged; | ||||
714 | my @id = $g->_vertex_ids( @_ ); | ||||
715 | return unless @id; | ||||
716 | $g->[ _E ]->get_multi_ids( @id ); | ||||
717 | } | ||||
718 | |||||
719 | ### | ||||
720 | # Neighbourhood. | ||||
721 | # | ||||
722 | |||||
723 | sub vertices_at { | ||||
724 | my $g = shift; | ||||
725 | my $V = $g->[ _V ]; | ||||
726 | return @_ unless ($V->[ _f ] & _HYPER); | ||||
727 | my %v; | ||||
728 | my @i; | ||||
729 | for my $v ( @_ ) { | ||||
730 | my $i = $V->_get_path_id( $v ); | ||||
731 | return unless defined $i; | ||||
732 | push @i, ( $v{ $v } = $i ); | ||||
733 | } | ||||
734 | my $Vi = $V->_ids; | ||||
735 | my @v; | ||||
736 | while (my ($i, $v) = each %{ $Vi }) { | ||||
737 | my %i; | ||||
738 | my $h = $V->[_f ] & _HYPER; | ||||
739 | @i{ @i } = @i if @i; # @todo: nonuniq hyper vertices? | ||||
740 | for my $u (ref $v eq 'ARRAY' && $h ? @$v : $v) { | ||||
741 | my $j = exists $v{ $u } ? $v{ $u } : ( $v{ $u } = $i ); | ||||
742 | if (defined $j && exists $i{ $j }) { | ||||
743 | delete $i{ $j }; | ||||
744 | unless (keys %i) { | ||||
745 | push @v, $v; | ||||
746 | last; | ||||
747 | } | ||||
748 | } | ||||
749 | } | ||||
750 | } | ||||
751 | return @v; | ||||
752 | } | ||||
753 | |||||
754 | sub _edges_at { | ||||
755 | my $g = shift; | ||||
756 | my $V = $g->[ _V ]; | ||||
757 | my $E = $g->[ _E ]; | ||||
758 | my @e; | ||||
759 | my $en = 0; | ||||
760 | my %ev; | ||||
761 | my $h = $V->[_f ] & _HYPER; | ||||
762 | for my $v ( $h ? $g->vertices_at( @_ ) : @_ ) { | ||||
763 | my $vi = $V->_get_path_id( ref $v eq 'ARRAY' && $h ? @$v : $v ); | ||||
764 | next unless defined $vi; | ||||
765 | my $Ei = $E->_ids; | ||||
766 | while (my ($ei, $ev) = each %{ $Ei }) { | ||||
767 | if (wantarray) { | ||||
768 | for my $j (@$ev) { | ||||
769 | push @e, [ $ei, $ev ] | ||||
770 | if $j == $vi && !$ev{$ei}++; | ||||
771 | } | ||||
772 | } else { | ||||
773 | for my $j (@$ev) { | ||||
774 | $en++ if $j == $vi; | ||||
775 | } | ||||
776 | } | ||||
777 | } | ||||
778 | } | ||||
779 | return wantarray ? @e : $en; | ||||
780 | } | ||||
781 | |||||
782 | # spent 858ms (617+242) within Graph::_edges which was called 24876 times, avg 35µs/call:
# 24876 times (617ms+242ms) by Graph::AdjacencyMap::_successors at line 829, avg 35µs/call | ||||
783 | 373140 | 196ms | my $g = shift; | ||
784 | my $n = pop; | ||||
785 | my $i = $n == _S ? 0 : -1; # _edges_from() or _edges_to() | ||||
786 | my $V = $g->[ _V ]; | ||||
787 | my $E = $g->[ _E ]; | ||||
788 | my $N = $g->[ $n ]; | ||||
789 | my $h = $V->[ _f ] & _HYPER; | ||||
790 | 402 | 17.8ms | unless (defined $N && $N->[ 0 ] == $g->[ _G ]) { | ||
791 | $g->[ $n ]->[ 1 ] = { }; | ||||
792 | $N = $g->[ $n ]; | ||||
793 | my $u = $E->[ _f ] & _UNORD; | ||||
794 | 67 | 168µs | my $Ei = $E->_ids; # spent 168µs making 67 calls to Graph::AdjacencyMap::_ids, avg 3µs/call | ||
795 | 44895 | 14.2ms | while (my ($ei, $ev) = each %{ $Ei }) { | ||
796 | next unless @$ev; | ||||
797 | my $e = [ $ei, $ev ]; | ||||
798 | 29930 | 28.1ms | if ($u) { | ||
799 | push @{ $N->[ 1 ]->{ $ev->[ 0] } }, $e; | ||||
800 | push @{ $N->[ 1 ]->{ $ev->[-1] } }, $e; | ||||
801 | } else { | ||||
802 | my $e = [ $ei, $ev ]; | ||||
803 | push @{ $N->[ 1 ]->{ $ev->[$i] } }, $e; | ||||
804 | } | ||||
805 | } | ||||
806 | $N->[ 0 ] = $g->[ _G ]; | ||||
807 | } | ||||
808 | my @e; | ||||
809 | my @at = $h ? $g->vertices_at( @_ ) : @_; | ||||
810 | my %at; @at{@at} = (); | ||||
811 | for my $v ( @at ) { | ||||
812 | 74628 | 94.3ms | 24876 | 75.4ms | my $vi = $V->_get_path_id( ref $v eq 'ARRAY' && $h ? @$v : $v ); # spent 75.4ms making 24876 calls to Graph::AdjacencyMap::Light::_get_path_id, avg 3µs/call |
813 | next unless defined $vi && exists $N->[ 1 ]->{ $vi }; | ||||
814 | push @e, @{ $N->[ 1 ]->{ $vi } }; | ||||
815 | } | ||||
816 | 49752 | 43.3ms | 24876 | 102ms | if (wantarray && $g->is_undirected) { # spent 102ms making 24876 calls to Graph::omniedged, avg 4µs/call |
817 | 24876 | 27.4ms | 24876 | 64.5ms | my @i = map { $V->_get_path_id( $_ ) } @_; # spent 64.5ms making 24876 calls to Graph::AdjacencyMap::Light::_get_path_id, avg 3µs/call |
818 | for my $e ( @e ) { | ||||
819 | 50037 | 84.2ms | unless ( $e->[ 1 ]->[ $i ] == $i[ $i ] ) { | ||
820 | $e = [ $e->[ 0 ], [ reverse @{ $e->[ 1 ] } ] ]; | ||||
821 | } | ||||
822 | } | ||||
823 | } | ||||
824 | return @e; | ||||
825 | } | ||||
826 | |||||
827 | # spent 45.3ms within Graph::_edges_from which was called 24876 times, avg 2µs/call:
# 24876 times (45.3ms+0s) by Graph::AdjacencyMap::_successors at line 394 of Graph/AdjacencyMap.pm, avg 2µs/call | ||||
828 | 49752 | 83.1ms | push @_, _S; | ||
829 | 24876 | 858ms | goto &_edges; # spent 858ms making 24876 calls to Graph::_edges, avg 35µs/call | ||
830 | } | ||||
831 | |||||
832 | sub _edges_to { | ||||
833 | push @_, _P; | ||||
834 | goto &_edges; | ||||
835 | } | ||||
836 | |||||
837 | sub _edges_id_path { | ||||
838 | my $g = shift; | ||||
839 | my $V = $g->[ _V ]; | ||||
840 | [ map { my @v = $V->_get_id_path($_); | ||||
841 | @v == 1 ? $v[0] : [ @v ] } | ||||
842 | @{ $_[0]->[1] } ]; | ||||
843 | } | ||||
844 | |||||
845 | sub edges_at { | ||||
846 | my $g = shift; | ||||
847 | map { $g->_edges_id_path($_ ) } $g->_edges_at( @_ ); | ||||
848 | } | ||||
849 | |||||
850 | sub edges_from { | ||||
851 | my $g = shift; | ||||
852 | map { $g->_edges_id_path($_ ) } $g->_edges_from( @_ ); | ||||
853 | } | ||||
854 | |||||
855 | sub edges_to { | ||||
856 | my $g = shift; | ||||
857 | map { $g->_edges_id_path($_ ) } $g->_edges_to( @_ ); | ||||
858 | } | ||||
859 | |||||
860 | # spent 1.50s (83.3ms+1.42) within Graph::successors which was called 24876 times, avg 60µs/call:
# 19885 times (65.5ms+1.11s) by Graph::Traversal::next at line 285 of Graph/Traversal.pm, avg 59µs/call
# 4991 times (17.8ms+314ms) by Graph::_MST_add at line 2316, avg 67µs/call | ||||
861 | 74628 | 70.6ms | my $g = shift; | ||
862 | my $E = $g->[ _E ]; | ||||
863 | 24876 | 1.42s | ($E->[ _f ] & _LIGHT) ? # spent 1.42s making 24876 calls to Graph::AdjacencyMap::_successors, avg 57µs/call | ||
864 | $E->_successors($g, @_) : | ||||
865 | Graph::AdjacencyMap::_successors($E, $g, @_); | ||||
866 | } | ||||
867 | |||||
868 | sub predecessors { | ||||
869 | my $g = shift; | ||||
870 | my $E = $g->[ _E ]; | ||||
871 | ($E->[ _f ] & _LIGHT) ? | ||||
872 | $E->_predecessors($g, @_) : | ||||
873 | Graph::AdjacencyMap::_predecessors($E, $g, @_); | ||||
874 | } | ||||
875 | |||||
876 | sub _all_successors { | ||||
877 | my $g = shift; | ||||
878 | my @init = @_; | ||||
879 | my %todo; | ||||
880 | @todo{@init} = @init; | ||||
881 | my %seen; | ||||
882 | my %init = %todo; | ||||
883 | my %self; | ||||
884 | while (keys %todo) { | ||||
885 | my @todo = values %todo; | ||||
886 | for my $t (@todo) { | ||||
887 | $seen{$t} = delete $todo{$t}; | ||||
888 | for my $s ($g->successors($t)) { | ||||
889 | $self{$s} = $s if exists $init{$s}; | ||||
890 | $todo{$s} = $s unless exists $seen{$s}; | ||||
891 | } | ||||
892 | } | ||||
893 | } | ||||
894 | for my $v (@init) { | ||||
895 | delete $seen{$v} unless $g->has_edge($v, $v) || $self{$v}; | ||||
896 | } | ||||
897 | return values %seen; | ||||
898 | } | ||||
899 | |||||
900 | sub all_successors { | ||||
901 | my $g = shift; | ||||
902 | $g->expect_directed; | ||||
903 | return $g->_all_successors(@_); | ||||
904 | } | ||||
905 | |||||
906 | sub _all_predecessors { | ||||
907 | my $g = shift; | ||||
908 | my @init = @_; | ||||
909 | my %todo; | ||||
910 | @todo{@init} = @init; | ||||
911 | my %seen; | ||||
912 | my %init = %todo; | ||||
913 | my %self; | ||||
914 | while (keys %todo) { | ||||
915 | my @todo = values %todo; | ||||
916 | for my $t (@todo) { | ||||
917 | $seen{$t} = delete $todo{$t}; | ||||
918 | for my $p ($g->predecessors($t)) { | ||||
919 | $self{$p} = $p if exists $init{$p}; | ||||
920 | $todo{$p} = $p unless exists $seen{$p}; | ||||
921 | } | ||||
922 | } | ||||
923 | } | ||||
924 | for my $v (@init) { | ||||
925 | delete $seen{$v} unless $g->has_edge($v, $v) || $self{$v}; | ||||
926 | } | ||||
927 | return values %seen; | ||||
928 | } | ||||
929 | |||||
930 | sub all_predecessors { | ||||
931 | my $g = shift; | ||||
932 | $g->expect_directed; | ||||
933 | return $g->_all_predecessors(@_); | ||||
934 | } | ||||
935 | |||||
936 | sub neighbours { | ||||
937 | my $g = shift; | ||||
938 | my $V = $g->[ _V ]; | ||||
939 | my @s = map { my @v = @{ $_->[ 1 ] }; shift @v; @v } $g->_edges_from( @_ ); | ||||
940 | my @p = map { my @v = @{ $_->[ 1 ] }; pop @v; @v } $g->_edges_to ( @_ ); | ||||
941 | my %n; | ||||
942 | @n{ @s } = @s; | ||||
943 | @n{ @p } = @p; | ||||
944 | map { $V->_get_id_path($_) } keys %n; | ||||
945 | } | ||||
946 | |||||
947 | 1 | 2µs | *neighbors = \&neighbours; | ||
948 | |||||
949 | sub all_neighbours { | ||||
950 | my $g = shift; | ||||
951 | my @init = @_; | ||||
952 | my @v = @init; | ||||
953 | my %n; | ||||
954 | my $o = 0; | ||||
955 | while (1) { | ||||
956 | my @p = $g->_all_predecessors(@v); | ||||
957 | my @s = $g->_all_successors(@v); | ||||
958 | @n{@p} = @p; | ||||
959 | @n{@s} = @s; | ||||
960 | @v = values %n; | ||||
961 | last if @v == $o; # Leave if no growth. | ||||
962 | $o = @v; | ||||
963 | } | ||||
964 | for my $v (@init) { | ||||
965 | delete $n{$v} unless $g->has_edge($v, $v); | ||||
966 | } | ||||
967 | return values %n; | ||||
968 | } | ||||
969 | |||||
970 | 1 | 2µs | *all_neighbors = \&all_neighbours; | ||
971 | |||||
972 | sub all_reachable { | ||||
973 | my $g = shift; | ||||
974 | $g->directed ? $g->all_successors(@_) : $g->all_neighbors(@_); | ||||
975 | } | ||||
976 | |||||
977 | sub delete_edge { | ||||
978 | my $g = shift; | ||||
979 | $g->expect_non_unionfind; | ||||
980 | my @i = $g->_vertex_ids( @_ ); | ||||
981 | return $g unless @i; | ||||
982 | my $i = $g->[ _E ]->_get_path_id( @i ); | ||||
983 | return $g unless defined $i; | ||||
984 | $g->[ _E ]->_del_id( $i ); | ||||
985 | $g->[ _G ]++; | ||||
986 | return $g; | ||||
987 | } | ||||
988 | |||||
989 | sub delete_vertex { | ||||
990 | my $g = shift; | ||||
991 | $g->expect_non_unionfind; | ||||
992 | my $V = $g->[ _V ]; | ||||
993 | return $g unless $V->has_path( @_ ); | ||||
994 | my $E = $g->[ _E ]; | ||||
995 | for my $e ( $g->_edges_at( @_ ) ) { | ||||
996 | $E->_del_id( $e->[ 0 ] ); | ||||
997 | } | ||||
998 | $V->del_path( @_ ); | ||||
999 | $g->[ _G ]++; | ||||
1000 | return $g; | ||||
1001 | } | ||||
1002 | |||||
1003 | sub get_vertex_count { | ||||
1004 | my $g = shift; | ||||
1005 | $g->[ _V ]->_get_path_count( @_ ) || 0; | ||||
1006 | } | ||||
1007 | |||||
1008 | sub get_edge_count { | ||||
1009 | my $g = shift; | ||||
1010 | my @e = $g->_vertex_ids( @_ ); | ||||
1011 | return 0 unless @e; | ||||
1012 | $g->[ _E ]->_get_path_count( @e ) || 0; | ||||
1013 | } | ||||
1014 | |||||
1015 | sub delete_vertices { | ||||
1016 | my $g = shift; | ||||
1017 | $g->expect_non_unionfind; | ||||
1018 | while (@_) { | ||||
1019 | my $v = shift @_; | ||||
1020 | $g->delete_vertex($v); | ||||
1021 | } | ||||
1022 | return $g; | ||||
1023 | } | ||||
1024 | |||||
1025 | sub delete_edges { | ||||
1026 | my $g = shift; | ||||
1027 | $g->expect_non_unionfind; | ||||
1028 | while (@_) { | ||||
1029 | my ($u, $v) = splice @_, 0, 2; | ||||
1030 | $g->delete_edge($u, $v); | ||||
1031 | } | ||||
1032 | return $g; | ||||
1033 | } | ||||
1034 | |||||
1035 | ### | ||||
1036 | # Degrees. | ||||
1037 | # | ||||
1038 | |||||
1039 | sub _in_degree { | ||||
1040 | my $g = shift; | ||||
1041 | return undef unless @_ && $g->has_vertex( @_ ); | ||||
1042 | my $in = 0; | ||||
1043 | $in += $g->get_edge_count( @$_ ) for $g->edges_to( @_ ); | ||||
1044 | return $in; | ||||
1045 | } | ||||
1046 | |||||
1047 | sub in_degree { | ||||
1048 | my $g = shift; | ||||
1049 | $g->_in_degree( @_ ); | ||||
1050 | } | ||||
1051 | |||||
1052 | sub _out_degree { | ||||
1053 | my $g = shift; | ||||
1054 | return undef unless @_ && $g->has_vertex( @_ ); | ||||
1055 | my $out = 0; | ||||
1056 | $out += $g->get_edge_count( @$_ ) for $g->edges_from( @_ ); | ||||
1057 | return $out; | ||||
1058 | } | ||||
1059 | |||||
1060 | sub out_degree { | ||||
1061 | my $g = shift; | ||||
1062 | $g->_out_degree( @_ ); | ||||
1063 | } | ||||
1064 | |||||
1065 | sub _total_degree { | ||||
1066 | my $g = shift; | ||||
1067 | return undef unless @_ && $g->has_vertex( @_ ); | ||||
1068 | $g->is_undirected ? | ||||
1069 | $g->_in_degree( @_ ) : | ||||
1070 | $g-> in_degree( @_ ) - $g-> out_degree( @_ ); | ||||
1071 | } | ||||
1072 | |||||
1073 | sub degree { | ||||
1074 | my $g = shift; | ||||
1075 | if (@_) { | ||||
1076 | $g->_total_degree( @_ ); | ||||
1077 | } elsif ($g->is_undirected) { | ||||
1078 | my $total = 0; | ||||
1079 | $total += $g->_total_degree( $_ ) for $g->vertices05; | ||||
1080 | return $total; | ||||
1081 | } else { | ||||
1082 | return 0; | ||||
1083 | } | ||||
1084 | } | ||||
1085 | |||||
1086 | 1 | 2µs | *vertex_degree = \°ree; | ||
1087 | |||||
1088 | sub is_sink_vertex { | ||||
1089 | my $g = shift; | ||||
1090 | return 0 unless @_; | ||||
1091 | $g->successors( @_ ) == 0 && $g->predecessors( @_ ) > 0; | ||||
1092 | } | ||||
1093 | |||||
1094 | sub is_source_vertex { | ||||
1095 | my $g = shift; | ||||
1096 | return 0 unless @_; | ||||
1097 | $g->predecessors( @_ ) == 0 && $g->successors( @_ ) > 0; | ||||
1098 | } | ||||
1099 | |||||
1100 | sub is_successorless_vertex { | ||||
1101 | my $g = shift; | ||||
1102 | return 0 unless @_; | ||||
1103 | $g->successors( @_ ) == 0; | ||||
1104 | } | ||||
1105 | |||||
1106 | sub is_predecessorless_vertex { | ||||
1107 | my $g = shift; | ||||
1108 | return 0 unless @_; | ||||
1109 | $g->predecessors( @_ ) == 0; | ||||
1110 | } | ||||
1111 | |||||
1112 | sub is_successorful_vertex { | ||||
1113 | my $g = shift; | ||||
1114 | return 0 unless @_; | ||||
1115 | $g->successors( @_ ) > 0; | ||||
1116 | } | ||||
1117 | |||||
1118 | sub is_predecessorful_vertex { | ||||
1119 | my $g = shift; | ||||
1120 | return 0 unless @_; | ||||
1121 | $g->predecessors( @_ ) > 0; | ||||
1122 | } | ||||
1123 | |||||
1124 | sub is_isolated_vertex { | ||||
1125 | my $g = shift; | ||||
1126 | return 0 unless @_; | ||||
1127 | $g->predecessors( @_ ) == 0 && $g->successors( @_ ) == 0; | ||||
1128 | } | ||||
1129 | |||||
1130 | sub is_interior_vertex { | ||||
1131 | my $g = shift; | ||||
1132 | return 0 unless @_; | ||||
1133 | my $p = $g->predecessors( @_ ); | ||||
1134 | my $s = $g->successors( @_ ); | ||||
1135 | if ($g->is_self_loop_vertex( @_ )) { | ||||
1136 | $p--; | ||||
1137 | $s--; | ||||
1138 | } | ||||
1139 | $p > 0 && $s > 0; | ||||
1140 | } | ||||
1141 | |||||
1142 | sub is_exterior_vertex { | ||||
1143 | my $g = shift; | ||||
1144 | return 0 unless @_; | ||||
1145 | $g->predecessors( @_ ) == 0 || $g->successors( @_ ) == 0; | ||||
1146 | } | ||||
1147 | |||||
1148 | sub is_self_loop_vertex { | ||||
1149 | my $g = shift; | ||||
1150 | return 0 unless @_; | ||||
1151 | for my $s ( $g->successors( @_ ) ) { | ||||
1152 | return 1 if $s eq $_[0]; # @todo: multiedges, hypervertices | ||||
1153 | } | ||||
1154 | return 0; | ||||
1155 | } | ||||
1156 | |||||
1157 | sub sink_vertices { | ||||
1158 | my $g = shift; | ||||
1159 | grep { $g->is_sink_vertex($_) } $g->vertices05; | ||||
1160 | } | ||||
1161 | |||||
1162 | sub source_vertices { | ||||
1163 | my $g = shift; | ||||
1164 | grep { $g->is_source_vertex($_) } $g->vertices05; | ||||
1165 | } | ||||
1166 | |||||
1167 | sub successorless_vertices { | ||||
1168 | my $g = shift; | ||||
1169 | grep { $g->is_successorless_vertex($_) } $g->vertices05; | ||||
1170 | } | ||||
1171 | |||||
1172 | sub predecessorless_vertices { | ||||
1173 | my $g = shift; | ||||
1174 | grep { $g->is_predecessorless_vertex($_) } $g->vertices05; | ||||
1175 | } | ||||
1176 | |||||
1177 | sub successorful_vertices { | ||||
1178 | my $g = shift; | ||||
1179 | grep { $g->is_successorful_vertex($_) } $g->vertices05; | ||||
1180 | } | ||||
1181 | |||||
1182 | sub predecessorful_vertices { | ||||
1183 | my $g = shift; | ||||
1184 | grep { $g->is_predecessorful_vertex($_) } $g->vertices05; | ||||
1185 | } | ||||
1186 | |||||
1187 | sub isolated_vertices { | ||||
1188 | my $g = shift; | ||||
1189 | grep { $g->is_isolated_vertex($_) } $g->vertices05; | ||||
1190 | } | ||||
1191 | |||||
1192 | sub interior_vertices { | ||||
1193 | my $g = shift; | ||||
1194 | grep { $g->is_interior_vertex($_) } $g->vertices05; | ||||
1195 | } | ||||
1196 | |||||
1197 | sub exterior_vertices { | ||||
1198 | my $g = shift; | ||||
1199 | grep { $g->is_exterior_vertex($_) } $g->vertices05; | ||||
1200 | } | ||||
1201 | |||||
1202 | sub self_loop_vertices { | ||||
1203 | my $g = shift; | ||||
1204 | grep { $g->is_self_loop_vertex($_) } $g->vertices05; | ||||
1205 | } | ||||
1206 | |||||
1207 | ### | ||||
1208 | # Paths and cycles. | ||||
1209 | # | ||||
1210 | |||||
1211 | sub add_path { | ||||
1212 | my $g = shift; | ||||
1213 | my $u = shift; | ||||
1214 | while (@_) { | ||||
1215 | my $v = shift; | ||||
1216 | $g->add_edge($u, $v); | ||||
1217 | $u = $v; | ||||
1218 | } | ||||
1219 | return $g; | ||||
1220 | } | ||||
1221 | |||||
1222 | sub delete_path { | ||||
1223 | my $g = shift; | ||||
1224 | $g->expect_non_unionfind; | ||||
1225 | my $u = shift; | ||||
1226 | while (@_) { | ||||
1227 | my $v = shift; | ||||
1228 | $g->delete_edge($u, $v); | ||||
1229 | $u = $v; | ||||
1230 | } | ||||
1231 | return $g; | ||||
1232 | } | ||||
1233 | |||||
1234 | sub has_path { | ||||
1235 | my $g = shift; | ||||
1236 | my $u = shift; | ||||
1237 | while (@_) { | ||||
1238 | my $v = shift; | ||||
1239 | return 0 unless $g->has_edge($u, $v); | ||||
1240 | $u = $v; | ||||
1241 | } | ||||
1242 | return $g; | ||||
1243 | } | ||||
1244 | |||||
1245 | sub add_cycle { | ||||
1246 | my $g = shift; | ||||
1247 | $g->add_path(@_, $_[0]); | ||||
1248 | } | ||||
1249 | |||||
1250 | sub delete_cycle { | ||||
1251 | my $g = shift; | ||||
1252 | $g->expect_non_unionfind; | ||||
1253 | $g->delete_path(@_, $_[0]); | ||||
1254 | } | ||||
1255 | |||||
1256 | sub has_cycle { | ||||
1257 | my $g = shift; | ||||
1258 | @_ ? ($g->has_path(@_, $_[0]) ? 1 : 0) : 0; | ||||
1259 | } | ||||
1260 | |||||
1261 | sub has_a_cycle { | ||||
1262 | my $g = shift; | ||||
1263 | my @r = ( back_edge => \&Graph::Traversal::has_a_cycle ); | ||||
1264 | push @r, | ||||
1265 | down_edge => \&Graph::Traversal::has_a_cycle | ||||
1266 | if $g->is_undirected; | ||||
1267 | my $t = Graph::Traversal::DFS->new($g, @r, @_); | ||||
1268 | $t->dfs; | ||||
1269 | return $t->get_state('has_a_cycle'); | ||||
1270 | } | ||||
1271 | |||||
1272 | sub find_a_cycle { | ||||
1273 | my $g = shift; | ||||
1274 | my @r = ( back_edge => \&Graph::Traversal::find_a_cycle); | ||||
1275 | push @r, | ||||
1276 | down_edge => \&Graph::Traversal::find_a_cycle | ||||
1277 | if $g->is_undirected; | ||||
1278 | my $t = Graph::Traversal::DFS->new($g, @r, @_); | ||||
1279 | $t->dfs; | ||||
1280 | $t->has_state('a_cycle') ? @{ $t->get_state('a_cycle') } : (); | ||||
1281 | } | ||||
1282 | |||||
1283 | ### | ||||
1284 | # Attributes. | ||||
1285 | |||||
1286 | # Vertex attributes. | ||||
1287 | |||||
1288 | sub set_vertex_attribute { | ||||
1289 | my $g = shift; | ||||
1290 | $g->expect_non_multivertexed; | ||||
1291 | my $value = pop; | ||||
1292 | my $attr = pop; | ||||
1293 | $g->add_vertex( @_ ) unless $g->has_vertex( @_ ); | ||||
1294 | $g->[ _V ]->_set_path_attr( @_, $attr, $value ); | ||||
1295 | } | ||||
1296 | |||||
1297 | sub set_vertex_attribute_by_id { | ||||
1298 | my $g = shift; | ||||
1299 | $g->expect_multivertexed; | ||||
1300 | my $value = pop; | ||||
1301 | my $attr = pop; | ||||
1302 | $g->add_vertex_by_id( @_ ) unless $g->has_vertex_by_id( @_ ); | ||||
1303 | $g->[ _V ]->_set_path_attr( @_, $attr, $value ); | ||||
1304 | } | ||||
1305 | |||||
1306 | sub set_vertex_attributes { | ||||
1307 | my $g = shift; | ||||
1308 | $g->expect_non_multivertexed; | ||||
1309 | my $attr = pop; | ||||
1310 | $g->add_vertex( @_ ) unless $g->has_vertex( @_ ); | ||||
1311 | $g->[ _V ]->_set_path_attrs( @_, $attr ); | ||||
1312 | } | ||||
1313 | |||||
1314 | sub set_vertex_attributes_by_id { | ||||
1315 | my $g = shift; | ||||
1316 | $g->expect_multivertexed; | ||||
1317 | my $attr = pop; | ||||
1318 | $g->add_vertex_by_id( @_ ) unless $g->has_vertex_by_id( @_ ); | ||||
1319 | $g->[ _V ]->_set_path_attrs( @_, $attr ); | ||||
1320 | } | ||||
1321 | |||||
1322 | sub has_vertex_attributes { | ||||
1323 | my $g = shift; | ||||
1324 | $g->expect_non_multivertexed; | ||||
1325 | return 0 unless $g->has_vertex( @_ ); | ||||
1326 | $g->[ _V ]->_has_path_attrs( @_ ); | ||||
1327 | } | ||||
1328 | |||||
1329 | sub has_vertex_attributes_by_id { | ||||
1330 | my $g = shift; | ||||
1331 | $g->expect_multivertexed; | ||||
1332 | return 0 unless $g->has_vertex_by_id( @_ ); | ||||
1333 | $g->[ _V ]->_has_path_attrs( @_ ); | ||||
1334 | } | ||||
1335 | |||||
1336 | sub has_vertex_attribute { | ||||
1337 | my $g = shift; | ||||
1338 | $g->expect_non_multivertexed; | ||||
1339 | my $attr = pop; | ||||
1340 | return 0 unless $g->has_vertex( @_ ); | ||||
1341 | $g->[ _V ]->_has_path_attr( @_, $attr ); | ||||
1342 | } | ||||
1343 | |||||
1344 | sub has_vertex_attribute_by_id { | ||||
1345 | my $g = shift; | ||||
1346 | $g->expect_multivertexed; | ||||
1347 | my $attr = pop; | ||||
1348 | return 0 unless $g->has_vertex_by_id( @_ ); | ||||
1349 | $g->[ _V ]->_has_path_attr( @_, $attr ); | ||||
1350 | } | ||||
1351 | |||||
1352 | sub get_vertex_attributes { | ||||
1353 | my $g = shift; | ||||
1354 | $g->expect_non_multivertexed; | ||||
1355 | return unless $g->has_vertex( @_ ); | ||||
1356 | my $a = $g->[ _V ]->_get_path_attrs( @_ ); | ||||
1357 | ($g->is_compat02) ? (defined $a ? %{ $a } : ()) : $a; | ||||
1358 | } | ||||
1359 | |||||
1360 | sub get_vertex_attributes_by_id { | ||||
1361 | my $g = shift; | ||||
1362 | $g->expect_multivertexed; | ||||
1363 | return unless $g->has_vertex_by_id( @_ ); | ||||
1364 | $g->[ _V ]->_get_path_attrs( @_ ); | ||||
1365 | } | ||||
1366 | |||||
1367 | sub get_vertex_attribute { | ||||
1368 | my $g = shift; | ||||
1369 | $g->expect_non_multivertexed; | ||||
1370 | my $attr = pop; | ||||
1371 | return unless $g->has_vertex( @_ ); | ||||
1372 | $g->[ _V ]->_get_path_attr( @_, $attr ); | ||||
1373 | } | ||||
1374 | |||||
1375 | sub get_vertex_attribute_by_id { | ||||
1376 | my $g = shift; | ||||
1377 | $g->expect_multivertexed; | ||||
1378 | my $attr = pop; | ||||
1379 | return unless $g->has_vertex_by_id( @_ ); | ||||
1380 | $g->[ _V ]->_get_path_attr( @_, $attr ); | ||||
1381 | } | ||||
1382 | |||||
1383 | sub get_vertex_attribute_names { | ||||
1384 | my $g = shift; | ||||
1385 | $g->expect_non_multivertexed; | ||||
1386 | return unless $g->has_vertex( @_ ); | ||||
1387 | $g->[ _V ]->_get_path_attr_names( @_ ); | ||||
1388 | } | ||||
1389 | |||||
1390 | sub get_vertex_attribute_names_by_id { | ||||
1391 | my $g = shift; | ||||
1392 | $g->expect_multivertexed; | ||||
1393 | return unless $g->has_vertex_by_id( @_ ); | ||||
1394 | $g->[ _V ]->_get_path_attr_names( @_ ); | ||||
1395 | } | ||||
1396 | |||||
1397 | sub get_vertex_attribute_values { | ||||
1398 | my $g = shift; | ||||
1399 | $g->expect_non_multivertexed; | ||||
1400 | return unless $g->has_vertex( @_ ); | ||||
1401 | $g->[ _V ]->_get_path_attr_values( @_ ); | ||||
1402 | } | ||||
1403 | |||||
1404 | sub get_vertex_attribute_values_by_id { | ||||
1405 | my $g = shift; | ||||
1406 | $g->expect_multivertexed; | ||||
1407 | return unless $g->has_vertex_by_id( @_ ); | ||||
1408 | $g->[ _V ]->_get_path_attr_values( @_ ); | ||||
1409 | } | ||||
1410 | |||||
1411 | sub delete_vertex_attributes { | ||||
1412 | my $g = shift; | ||||
1413 | $g->expect_non_multivertexed; | ||||
1414 | return undef unless $g->has_vertex( @_ ); | ||||
1415 | $g->[ _V ]->_del_path_attrs( @_ ); | ||||
1416 | } | ||||
1417 | |||||
1418 | sub delete_vertex_attributes_by_id { | ||||
1419 | my $g = shift; | ||||
1420 | $g->expect_multivertexed; | ||||
1421 | return undef unless $g->has_vertex_by_id( @_ ); | ||||
1422 | $g->[ _V ]->_del_path_attrs( @_ ); | ||||
1423 | } | ||||
1424 | |||||
1425 | sub delete_vertex_attribute { | ||||
1426 | my $g = shift; | ||||
1427 | $g->expect_non_multivertexed; | ||||
1428 | my $attr = pop; | ||||
1429 | return undef unless $g->has_vertex( @_ ); | ||||
1430 | $g->[ _V ]->_del_path_attr( @_, $attr ); | ||||
1431 | } | ||||
1432 | |||||
1433 | sub delete_vertex_attribute_by_id { | ||||
1434 | my $g = shift; | ||||
1435 | $g->expect_multivertexed; | ||||
1436 | my $attr = pop; | ||||
1437 | return undef unless $g->has_vertex_by_id( @_ ); | ||||
1438 | $g->[ _V ]->_del_path_attr( @_, $attr ); | ||||
1439 | } | ||||
1440 | |||||
1441 | # Edge attributes. | ||||
1442 | |||||
1443 | sub _set_edge_attribute { | ||||
1444 | my $g = shift; | ||||
1445 | my $value = pop; | ||||
1446 | my $attr = pop; | ||||
1447 | my $E = $g->[ _E ]; | ||||
1448 | my $f = $E->[ _f ]; | ||||
1449 | my @i; | ||||
1450 | if ($E->[ _a ] == 2 && @_ == 2 && !($f & (_HYPER|_REF|_UNIQ))) { # Fast path. | ||||
1451 | @_ = sort @_ if ($f & _UNORD); | ||||
1452 | my $s = $E->[ _s ]; | ||||
1453 | $g->add_edge( @_ ) unless exists $s->{ $_[0] } && exists $s->{ $_[0] }->{ $_[1] }; | ||||
1454 | @i = @{ $g->[ _V ]->[ _s ] }{ @_ }; | ||||
1455 | } else { | ||||
1456 | $g->add_edge( @_ ) unless $g->has_edge( @_ ); | ||||
1457 | @i = $g->_vertex_ids( @_ ); | ||||
1458 | } | ||||
1459 | $g->[ _E ]->_set_path_attr( @i, $attr, $value ); | ||||
1460 | } | ||||
1461 | |||||
1462 | sub set_edge_attribute { | ||||
1463 | 139706 | 148ms | my $g = shift; | ||
1464 | 19958 | 124ms | $g->expect_non_multiedged; # spent 124ms making 19958 calls to Graph::expect_non_multiedged, avg 6µs/call | ||
1465 | my $value = pop; | ||||
1466 | my $attr = pop; | ||||
1467 | my $E = $g->[ _E ]; | ||||
1468 | 24913 | 530ms | $g->add_edge( @_ ) unless $g->has_edge( @_ ); # spent 378ms making 4955 calls to Graph::add_edge, avg 76µs/call
# spent 152ms making 19958 calls to Graph::has_edge, avg 8µs/call | ||
1469 | 39916 | 628ms | $E->_set_path_attr( $g->_vertex_ids( @_ ), $attr, $value ); # spent 505ms making 19958 calls to Graph::AdjacencyMap::_set_path_attr, avg 25µs/call
# spent 123ms making 19958 calls to Graph::_vertex_ids, avg 6µs/call | ||
1470 | } | ||||
1471 | |||||
1472 | sub set_edge_attribute_by_id { | ||||
1473 | my $g = shift; | ||||
1474 | $g->expect_multiedged; | ||||
1475 | my $value = pop; | ||||
1476 | my $attr = pop; | ||||
1477 | # $g->add_edge_by_id( @_ ) unless $g->has_edge_by_id( @_ ); | ||||
1478 | my $id = pop; | ||||
1479 | $g->[ _E ]->_set_path_attr( $g->_vertex_ids( @_ ), $id, $attr, $value ); | ||||
1480 | } | ||||
1481 | |||||
1482 | sub set_edge_attributes { | ||||
1483 | my $g = shift; | ||||
1484 | $g->expect_non_multiedged; | ||||
1485 | my $attr = pop; | ||||
1486 | $g->add_edge( @_ ) unless $g->has_edge( @_ ); | ||||
1487 | $g->[ _E ]->_set_path_attrs( $g->_vertex_ids( @_ ), $attr ); | ||||
1488 | } | ||||
1489 | |||||
1490 | sub set_edge_attributes_by_id { | ||||
1491 | my $g = shift; | ||||
1492 | $g->expect_multiedged; | ||||
1493 | my $attr = pop; | ||||
1494 | $g->add_edge_by_id( @_ ) unless $g->has_edge_by_id( @_ ); | ||||
1495 | my $id = pop; | ||||
1496 | $g->[ _E ]->_set_path_attrs( $g->_vertex_ids( @_ ), $id, $attr ); | ||||
1497 | } | ||||
1498 | |||||
1499 | sub has_edge_attributes { | ||||
1500 | my $g = shift; | ||||
1501 | $g->expect_non_multiedged; | ||||
1502 | return 0 unless $g->has_edge( @_ ); | ||||
1503 | $g->[ _E ]->_has_path_attrs( $g->_vertex_ids( @_ ) ); | ||||
1504 | } | ||||
1505 | |||||
1506 | sub has_edge_attributes_by_id { | ||||
1507 | my $g = shift; | ||||
1508 | $g->expect_multiedged; | ||||
1509 | return 0 unless $g->has_edge_by_id( @_ ); | ||||
1510 | my $id = pop; | ||||
1511 | $g->[ _E ]->_has_path_attrs( $g->_vertex_ids( @_ ), $id ); | ||||
1512 | } | ||||
1513 | |||||
1514 | sub has_edge_attribute { | ||||
1515 | my $g = shift; | ||||
1516 | $g->expect_non_multiedged; | ||||
1517 | my $attr = pop; | ||||
1518 | return 0 unless $g->has_edge( @_ ); | ||||
1519 | $g->[ _E ]->_has_path_attr( $g->_vertex_ids( @_ ), $attr ); | ||||
1520 | } | ||||
1521 | |||||
1522 | sub has_edge_attribute_by_id { | ||||
1523 | my $g = shift; | ||||
1524 | $g->expect_multiedged; | ||||
1525 | my $attr = pop; | ||||
1526 | return 0 unless $g->has_edge_by_id( @_ ); | ||||
1527 | my $id = pop; | ||||
1528 | $g->[ _E ]->_has_path_attr( $g->_vertex_ids( @_ ), $id, $attr ); | ||||
1529 | } | ||||
1530 | |||||
1531 | sub get_edge_attributes { | ||||
1532 | my $g = shift; | ||||
1533 | $g->expect_non_multiedged; | ||||
1534 | return unless $g->has_edge( @_ ); | ||||
1535 | my $a = $g->[ _E ]->_get_path_attrs( $g->_vertex_ids( @_ ) ); | ||||
1536 | ($g->is_compat02) ? (defined $a ? %{ $a } : ()) : $a; | ||||
1537 | } | ||||
1538 | |||||
1539 | sub get_edge_attributes_by_id { | ||||
1540 | my $g = shift; | ||||
1541 | $g->expect_multiedged; | ||||
1542 | return unless $g->has_edge_by_id( @_ ); | ||||
1543 | my $id = pop; | ||||
1544 | return $g->[ _E ]->_get_path_attrs( $g->_vertex_ids( @_ ), $id ); | ||||
1545 | } | ||||
1546 | |||||
1547 | sub _get_edge_attribute { # Fast path; less checks. | ||||
1548 | my $g = shift; | ||||
1549 | my $attr = pop; | ||||
1550 | my $E = $g->[ _E ]; | ||||
1551 | my $f = $E->[ _f ]; | ||||
1552 | if ($E->[ _a ] == 2 && @_ == 2 && !($f & (_HYPER|_REF|_UNIQ))) { # Fast path. | ||||
1553 | @_ = sort @_ if ($f & _UNORD); | ||||
1554 | my $s = $E->[ _s ]; | ||||
1555 | return unless exists $s->{ $_[0] } && exists $s->{ $_[0] }->{ $_[1] }; | ||||
1556 | } else { | ||||
1557 | return unless $g->has_edge( @_ ); | ||||
1558 | } | ||||
1559 | my @i = $g->_vertex_ids( @_ ); | ||||
1560 | $E->_get_path_attr( @i, $attr ); | ||||
1561 | } | ||||
1562 | |||||
1563 | # spent 325ms (62.8+262) within Graph::get_edge_attribute which was called 5007 times, avg 65µs/call:
# 5007 times (62.8ms+262ms) by Graph::_MST_add at line 2317, avg 65µs/call | ||||
1564 | 40056 | 41.7ms | my $g = shift; | ||
1565 | 5007 | 33.6ms | $g->expect_non_multiedged; # spent 33.6ms making 5007 calls to Graph::expect_non_multiedged, avg 7µs/call | ||
1566 | my $attr = pop; | ||||
1567 | 5007 | 53.5ms | return undef unless $g->has_edge( @_ ); # spent 53.5ms making 5007 calls to Graph::has_edge, avg 11µs/call | ||
1568 | 5007 | 29.0ms | my @i = $g->_vertex_ids( @_ ); # spent 29.0ms making 5007 calls to Graph::_vertex_ids, avg 6µs/call | ||
1569 | return undef if @i == 0 && @_; | ||||
1570 | my $E = $g->[ _E ]; | ||||
1571 | 5007 | 146ms | $E->_get_path_attr( @i, $attr ); # spent 146ms making 5007 calls to Graph::AdjacencyMap::_get_path_attr, avg 29µs/call | ||
1572 | } | ||||
1573 | |||||
1574 | sub get_edge_attribute_by_id { | ||||
1575 | my $g = shift; | ||||
1576 | $g->expect_multiedged; | ||||
1577 | my $attr = pop; | ||||
1578 | return unless $g->has_edge_by_id( @_ ); | ||||
1579 | my $id = pop; | ||||
1580 | $g->[ _E ]->_get_path_attr( $g->_vertex_ids( @_ ), $id, $attr ); | ||||
1581 | } | ||||
1582 | |||||
1583 | sub get_edge_attribute_names { | ||||
1584 | my $g = shift; | ||||
1585 | $g->expect_non_multiedged; | ||||
1586 | return unless $g->has_edge( @_ ); | ||||
1587 | $g->[ _E ]->_get_path_attr_names( $g->_vertex_ids( @_ ) ); | ||||
1588 | } | ||||
1589 | |||||
1590 | sub get_edge_attribute_names_by_id { | ||||
1591 | my $g = shift; | ||||
1592 | $g->expect_multiedged; | ||||
1593 | return unless $g->has_edge_by_id( @_ ); | ||||
1594 | my $id = pop; | ||||
1595 | $g->[ _E ]->_get_path_attr_names( $g->_vertex_ids( @_ ), $id ); | ||||
1596 | } | ||||
1597 | |||||
1598 | sub get_edge_attribute_values { | ||||
1599 | my $g = shift; | ||||
1600 | $g->expect_non_multiedged; | ||||
1601 | return unless $g->has_edge( @_ ); | ||||
1602 | $g->[ _E ]->_get_path_attr_values( $g->_vertex_ids( @_ ) ); | ||||
1603 | } | ||||
1604 | |||||
1605 | sub get_edge_attribute_values_by_id { | ||||
1606 | my $g = shift; | ||||
1607 | $g->expect_multiedged; | ||||
1608 | return unless $g->has_edge_by_id( @_ ); | ||||
1609 | my $id = pop; | ||||
1610 | $g->[ _E ]->_get_path_attr_values( $g->_vertex_ids( @_ ), $id ); | ||||
1611 | } | ||||
1612 | |||||
1613 | sub delete_edge_attributes { | ||||
1614 | my $g = shift; | ||||
1615 | $g->expect_non_multiedged; | ||||
1616 | return unless $g->has_edge( @_ ); | ||||
1617 | $g->[ _E ]->_del_path_attrs( $g->_vertex_ids( @_ ) ); | ||||
1618 | } | ||||
1619 | |||||
1620 | sub delete_edge_attributes_by_id { | ||||
1621 | my $g = shift; | ||||
1622 | $g->expect_multiedged; | ||||
1623 | return unless $g->has_edge_by_id( @_ ); | ||||
1624 | my $id = pop; | ||||
1625 | $g->[ _E ]->_del_path_attrs( $g->_vertex_ids( @_ ), $id ); | ||||
1626 | } | ||||
1627 | |||||
1628 | sub delete_edge_attribute { | ||||
1629 | my $g = shift; | ||||
1630 | $g->expect_non_multiedged; | ||||
1631 | my $attr = pop; | ||||
1632 | return unless $g->has_edge( @_ ); | ||||
1633 | $g->[ _E ]->_del_path_attr( $g->_vertex_ids( @_ ), $attr ); | ||||
1634 | } | ||||
1635 | |||||
1636 | sub delete_edge_attribute_by_id { | ||||
1637 | my $g = shift; | ||||
1638 | $g->expect_multiedged; | ||||
1639 | my $attr = pop; | ||||
1640 | return unless $g->has_edge_by_id( @_ ); | ||||
1641 | my $id = pop; | ||||
1642 | $g->[ _E ]->_del_path_attr( $g->_vertex_ids( @_ ), $id, $attr ); | ||||
1643 | } | ||||
1644 | |||||
1645 | ### | ||||
1646 | # Compat. | ||||
1647 | # | ||||
1648 | |||||
1649 | sub vertex { | ||||
1650 | my $g = shift; | ||||
1651 | $g->has_vertex( @_ ) ? @_ : undef; | ||||
1652 | } | ||||
1653 | |||||
1654 | sub out_edges { | ||||
1655 | my $g = shift; | ||||
1656 | return unless @_ && $g->has_vertex( @_ ); | ||||
1657 | my @e = $g->edges_from( @_ ); | ||||
1658 | wantarray ? map { @$_ } @e : @e; | ||||
1659 | } | ||||
1660 | |||||
1661 | sub in_edges { | ||||
1662 | my $g = shift; | ||||
1663 | return unless @_ && $g->has_vertex( @_ ); | ||||
1664 | my @e = $g->edges_to( @_ ); | ||||
1665 | wantarray ? map { @$_ } @e : @e; | ||||
1666 | } | ||||
1667 | |||||
1668 | sub add_vertices { | ||||
1669 | my $g = shift; | ||||
1670 | $g->add_vertex( $_ ) for @_; | ||||
1671 | return $g; | ||||
1672 | } | ||||
1673 | |||||
1674 | # spent 5.56ms (502µs+5.06) within Graph::add_edges which was called 67 times, avg 83µs/call:
# 67 times (502µs+5.06ms) by Graph::AdjacencyMap::Light::__attr at line 227 of Graph/AdjacencyMap/Light.pm, avg 83µs/call | ||||
1675 | 201 | 232µs | my $g = shift; | ||
1676 | while (@_) { | ||||
1677 | 134 | 175µs | my $u = shift @_; | ||
1678 | 67 | 5.06ms | if (ref $u eq 'ARRAY') { # spent 5.06ms making 67 calls to Graph::add_edge, avg 75µs/call | ||
1679 | $g->add_edge( @$u ); | ||||
1680 | } else { | ||||
1681 | if (@_) { | ||||
1682 | my $v = shift @_; | ||||
1683 | $g->add_edge( $u, $v ); | ||||
1684 | } else { | ||||
1685 | require Carp; | ||||
1686 | Carp::croak("Graph::add_edges: missing end vertex"); | ||||
1687 | } | ||||
1688 | } | ||||
1689 | } | ||||
1690 | return $g; | ||||
1691 | } | ||||
1692 | |||||
1693 | ### | ||||
1694 | # More constructors. | ||||
1695 | # | ||||
1696 | |||||
1697 | sub copy { | ||||
1698 | my $g = shift; | ||||
1699 | my %opt = _get_options( \@_ ); | ||||
1700 | |||||
1701 | my $c = | ||||
1702 | (ref $g)->new(map { $_ => $g->$_ ? 1 : 0 } | ||||
1703 | qw(directed | ||||
1704 | compat02 | ||||
1705 | refvertexed | ||||
1706 | hypervertexed | ||||
1707 | countvertexed | ||||
1708 | multivertexed | ||||
1709 | hyperedged | ||||
1710 | countedged | ||||
1711 | multiedged | ||||
1712 | omniedged | ||||
1713 | __stringified)); | ||||
1714 | for my $v ($g->isolated_vertices) { $c->add_vertex($v) } | ||||
1715 | for my $e ($g->edges05) { $c->add_edge(@$e) } | ||||
1716 | |||||
1717 | return $c; | ||||
1718 | } | ||||
1719 | |||||
1720 | 1 | 2µs | *copy_graph = \© | ||
1721 | |||||
1722 | sub _deep_copy_Storable { | ||||
1723 | my $g = shift; | ||||
1724 | my $safe = new Safe; | ||||
1725 | local $Storable::Deparse = 1; | ||||
1726 | local $Storable::Eval = sub { $safe->reval($_[0]) }; | ||||
1727 | return Storable::thaw(Storable::freeze($g)); | ||||
1728 | } | ||||
1729 | |||||
1730 | sub _deep_copy_DataDumper { | ||||
1731 | my $g = shift; | ||||
1732 | my $d = Data::Dumper->new([$g]); | ||||
1733 | 2 | 1.88ms | 2 | 98µs | # spent 56µs (13+42) within Graph::BEGIN@1733 which was called:
# once (13µs+42µs) by Bio::Roary::OrderGenes::BEGIN@22 at line 1733 # spent 56µs making 1 call to Graph::BEGIN@1733
# spent 42µs making 1 call to vars::import |
1734 | $d->Purity(1)->Terse(1)->Deepcopy(1); | ||||
1735 | $d->Deparse(1) if $] >= 5.008; | ||||
1736 | eval $d->Dump; | ||||
1737 | } | ||||
1738 | |||||
1739 | sub deep_copy { | ||||
1740 | if (_can_deep_copy_Storable()) { | ||||
1741 | return _deep_copy_Storable(@_); | ||||
1742 | } else { | ||||
1743 | return _deep_copy_DataDumper(@_); | ||||
1744 | } | ||||
1745 | } | ||||
1746 | |||||
1747 | 1 | 2µs | *deep_copy_graph = \&deep_copy; | ||
1748 | |||||
1749 | sub transpose_edge { | ||||
1750 | my $g = shift; | ||||
1751 | if ($g->is_directed) { | ||||
1752 | return undef unless $g->has_edge( @_ ); | ||||
1753 | my $c = $g->get_edge_count( @_ ); | ||||
1754 | my $a = $g->get_edge_attributes( @_ ); | ||||
1755 | my @e = reverse @_; | ||||
1756 | $g->delete_edge( @_ ) unless $g->has_edge( @e ); | ||||
1757 | $g->add_edge( @e ) for 1..$c; | ||||
1758 | $g->set_edge_attributes(@e, $a) if $a; | ||||
1759 | } | ||||
1760 | return $g; | ||||
1761 | } | ||||
1762 | |||||
1763 | sub transpose_graph { | ||||
1764 | my $g = shift; | ||||
1765 | my $t = $g->copy; | ||||
1766 | if ($t->directed) { | ||||
1767 | for my $e ($t->edges05) { | ||||
1768 | $t->transpose_edge(@$e); | ||||
1769 | } | ||||
1770 | } | ||||
1771 | return $t; | ||||
1772 | } | ||||
1773 | |||||
1774 | 1 | 2µs | *transpose = \&transpose_graph; | ||
1775 | |||||
1776 | sub complete_graph { | ||||
1777 | my $g = shift; | ||||
1778 | my $c = $g->new( directed => $g->directed ); | ||||
1779 | my @v = $g->vertices05; | ||||
1780 | for (my $i = 0; $i <= $#v; $i++ ) { | ||||
1781 | for (my $j = 0; $j <= $#v; $j++ ) { | ||||
1782 | next if $i >= $j; | ||||
1783 | if ($g->is_undirected) { | ||||
1784 | $c->add_edge($v[$i], $v[$j]); | ||||
1785 | } else { | ||||
1786 | $c->add_edge($v[$i], $v[$j]); | ||||
1787 | $c->add_edge($v[$j], $v[$i]); | ||||
1788 | } | ||||
1789 | } | ||||
1790 | } | ||||
1791 | return $c; | ||||
1792 | } | ||||
1793 | |||||
1794 | 1 | 2µs | *complement = \&complement_graph; | ||
1795 | |||||
1796 | sub complement_graph { | ||||
1797 | my $g = shift; | ||||
1798 | my $c = $g->new( directed => $g->directed ); | ||||
1799 | my @v = $g->vertices05; | ||||
1800 | for (my $i = 0; $i <= $#v; $i++ ) { | ||||
1801 | for (my $j = 0; $j <= $#v; $j++ ) { | ||||
1802 | next if $i >= $j; | ||||
1803 | if ($g->is_undirected) { | ||||
1804 | $c->add_edge($v[$i], $v[$j]) | ||||
1805 | unless $g->has_edge($v[$i], $v[$j]); | ||||
1806 | } else { | ||||
1807 | $c->add_edge($v[$i], $v[$j]) | ||||
1808 | unless $g->has_edge($v[$i], $v[$j]); | ||||
1809 | $c->add_edge($v[$j], $v[$i]) | ||||
1810 | unless $g->has_edge($v[$j], $v[$i]); | ||||
1811 | } | ||||
1812 | } | ||||
1813 | } | ||||
1814 | return $c; | ||||
1815 | } | ||||
1816 | |||||
1817 | 1 | 2µs | *complete = \&complete_graph; | ||
1818 | |||||
1819 | ### | ||||
1820 | # Transitivity. | ||||
1821 | # | ||||
1822 | |||||
1823 | sub is_transitive { | ||||
1824 | my $g = shift; | ||||
1825 | Graph::TransitiveClosure::is_transitive($g); | ||||
1826 | } | ||||
1827 | |||||
1828 | ### | ||||
1829 | # Weighted vertices. | ||||
1830 | # | ||||
1831 | |||||
1832 | 1 | 800ns | my $defattr = 'weight'; | ||
1833 | |||||
1834 | sub _defattr { | ||||
1835 | return $defattr; | ||||
1836 | } | ||||
1837 | |||||
1838 | sub add_weighted_vertex { | ||||
1839 | my $g = shift; | ||||
1840 | $g->expect_non_multivertexed; | ||||
1841 | my $w = pop; | ||||
1842 | $g->add_vertex(@_); | ||||
1843 | $g->set_vertex_attribute(@_, $defattr, $w); | ||||
1844 | } | ||||
1845 | |||||
1846 | sub add_weighted_vertices { | ||||
1847 | my $g = shift; | ||||
1848 | $g->expect_non_multivertexed; | ||||
1849 | while (@_) { | ||||
1850 | my ($v, $w) = splice @_, 0, 2; | ||||
1851 | $g->add_vertex($v); | ||||
1852 | $g->set_vertex_attribute($v, $defattr, $w); | ||||
1853 | } | ||||
1854 | } | ||||
1855 | |||||
1856 | sub get_vertex_weight { | ||||
1857 | my $g = shift; | ||||
1858 | $g->expect_non_multivertexed; | ||||
1859 | $g->get_vertex_attribute(@_, $defattr); | ||||
1860 | } | ||||
1861 | |||||
1862 | sub has_vertex_weight { | ||||
1863 | my $g = shift; | ||||
1864 | $g->expect_non_multivertexed; | ||||
1865 | $g->has_vertex_attribute(@_, $defattr); | ||||
1866 | } | ||||
1867 | |||||
1868 | sub set_vertex_weight { | ||||
1869 | my $g = shift; | ||||
1870 | $g->expect_non_multivertexed; | ||||
1871 | my $w = pop; | ||||
1872 | $g->set_vertex_attribute(@_, $defattr, $w); | ||||
1873 | } | ||||
1874 | |||||
1875 | sub delete_vertex_weight { | ||||
1876 | my $g = shift; | ||||
1877 | $g->expect_non_multivertexed; | ||||
1878 | $g->delete_vertex_attribute(@_, $defattr); | ||||
1879 | } | ||||
1880 | |||||
1881 | sub add_weighted_vertex_by_id { | ||||
1882 | my $g = shift; | ||||
1883 | $g->expect_multivertexed; | ||||
1884 | my $w = pop; | ||||
1885 | $g->add_vertex_by_id(@_); | ||||
1886 | $g->set_vertex_attribute_by_id(@_, $defattr, $w); | ||||
1887 | } | ||||
1888 | |||||
1889 | sub add_weighted_vertices_by_id { | ||||
1890 | my $g = shift; | ||||
1891 | $g->expect_multivertexed; | ||||
1892 | my $id = pop; | ||||
1893 | while (@_) { | ||||
1894 | my ($v, $w) = splice @_, 0, 2; | ||||
1895 | $g->add_vertex_by_id($v, $id); | ||||
1896 | $g->set_vertex_attribute_by_id($v, $id, $defattr, $w); | ||||
1897 | } | ||||
1898 | } | ||||
1899 | |||||
1900 | sub get_vertex_weight_by_id { | ||||
1901 | my $g = shift; | ||||
1902 | $g->expect_multivertexed; | ||||
1903 | $g->get_vertex_attribute_by_id(@_, $defattr); | ||||
1904 | } | ||||
1905 | |||||
1906 | sub has_vertex_weight_by_id { | ||||
1907 | my $g = shift; | ||||
1908 | $g->expect_multivertexed; | ||||
1909 | $g->has_vertex_attribute_by_id(@_, $defattr); | ||||
1910 | } | ||||
1911 | |||||
1912 | sub set_vertex_weight_by_id { | ||||
1913 | my $g = shift; | ||||
1914 | $g->expect_multivertexed; | ||||
1915 | my $w = pop; | ||||
1916 | $g->set_vertex_attribute_by_id(@_, $defattr, $w); | ||||
1917 | } | ||||
1918 | |||||
1919 | sub delete_vertex_weight_by_id { | ||||
1920 | my $g = shift; | ||||
1921 | $g->expect_multivertexed; | ||||
1922 | $g->delete_vertex_attribute_by_id(@_, $defattr); | ||||
1923 | } | ||||
1924 | |||||
1925 | ### | ||||
1926 | # Weighted edges. | ||||
1927 | # | ||||
1928 | |||||
1929 | # spent 2.07s (139ms+1.93) within Graph::add_weighted_edge which was called 15003 times, avg 138µs/call:
# 9767 times (89.9ms+1.18s) by Bio::Roary::OrderGenes::_add_groups_to_graph at line 133 of lib/Bio/Roary/OrderGenes.pm, avg 131µs/call
# 5005 times (46.5ms+706ms) by Bio::Roary::OrderGenes::_reorder_connected_components at line 167 of lib/Bio/Roary/OrderGenes.pm, avg 150µs/call
# 231 times (2.87ms+39.7ms) by Bio::Roary::OrderGenes::_create_accessory_graph at line 312 of lib/Bio/Roary/OrderGenes.pm, avg 184µs/call | ||||
1930 | 45009 | 57.3ms | my $g = shift; | ||
1931 | 15003 | 92.4ms | $g->expect_non_multiedged; # spent 92.4ms making 15003 calls to Graph::expect_non_multiedged, avg 6µs/call | ||
1932 | 45009 | 38.2ms | 15003 | 23.9ms | if ($g->is_compat02) { # spent 23.9ms making 15003 calls to Graph::is_compat02, avg 2µs/call |
1933 | my $w = splice @_, 1, 1; | ||||
1934 | $g->add_edge(@_); | ||||
1935 | $g->set_edge_attribute(@_, $defattr, $w); | ||||
1936 | } else { | ||||
1937 | my $w = pop; | ||||
1938 | 15003 | 972ms | $g->add_edge(@_); # spent 972ms making 15003 calls to Graph::add_edge, avg 65µs/call | ||
1939 | 15003 | 843ms | $g->set_edge_attribute(@_, $defattr, $w); # spent 843ms making 15003 calls to Graph::set_edge_attribute, avg 56µs/call | ||
1940 | } | ||||
1941 | } | ||||
1942 | |||||
1943 | sub add_weighted_edges { | ||||
1944 | my $g = shift; | ||||
1945 | $g->expect_non_multiedged; | ||||
1946 | if ($g->is_compat02) { | ||||
1947 | while (@_) { | ||||
1948 | my ($u, $w, $v) = splice @_, 0, 3; | ||||
1949 | $g->add_edge($u, $v); | ||||
1950 | $g->set_edge_attribute($u, $v, $defattr, $w); | ||||
1951 | } | ||||
1952 | } else { | ||||
1953 | while (@_) { | ||||
1954 | my ($u, $v, $w) = splice @_, 0, 3; | ||||
1955 | $g->add_edge($u, $v); | ||||
1956 | $g->set_edge_attribute($u, $v, $defattr, $w); | ||||
1957 | } | ||||
1958 | } | ||||
1959 | } | ||||
1960 | |||||
1961 | sub add_weighted_edges_by_id { | ||||
1962 | my $g = shift; | ||||
1963 | $g->expect_multiedged; | ||||
1964 | my $id = pop; | ||||
1965 | while (@_) { | ||||
1966 | my ($u, $v, $w) = splice @_, 0, 3; | ||||
1967 | $g->add_edge_by_id($u, $v, $id); | ||||
1968 | $g->set_edge_attribute_by_id($u, $v, $id, $defattr, $w); | ||||
1969 | } | ||||
1970 | } | ||||
1971 | |||||
1972 | sub add_weighted_path { | ||||
1973 | my $g = shift; | ||||
1974 | $g->expect_non_multiedged; | ||||
1975 | my $u = shift; | ||||
1976 | while (@_) { | ||||
1977 | my ($w, $v) = splice @_, 0, 2; | ||||
1978 | $g->add_edge($u, $v); | ||||
1979 | $g->set_edge_attribute($u, $v, $defattr, $w); | ||||
1980 | $u = $v; | ||||
1981 | } | ||||
1982 | } | ||||
1983 | |||||
1984 | sub get_edge_weight { | ||||
1985 | my $g = shift; | ||||
1986 | $g->expect_non_multiedged; | ||||
1987 | $g->get_edge_attribute(@_, $defattr); | ||||
1988 | } | ||||
1989 | |||||
1990 | sub has_edge_weight { | ||||
1991 | my $g = shift; | ||||
1992 | $g->expect_non_multiedged; | ||||
1993 | $g->has_edge_attribute(@_, $defattr); | ||||
1994 | } | ||||
1995 | |||||
1996 | sub set_edge_weight { | ||||
1997 | my $g = shift; | ||||
1998 | $g->expect_non_multiedged; | ||||
1999 | my $w = pop; | ||||
2000 | $g->set_edge_attribute(@_, $defattr, $w); | ||||
2001 | } | ||||
2002 | |||||
2003 | sub delete_edge_weight { | ||||
2004 | my $g = shift; | ||||
2005 | $g->expect_non_multiedged; | ||||
2006 | $g->delete_edge_attribute(@_, $defattr); | ||||
2007 | } | ||||
2008 | |||||
2009 | sub add_weighted_edge_by_id { | ||||
2010 | my $g = shift; | ||||
2011 | $g->expect_multiedged; | ||||
2012 | if ($g->is_compat02) { | ||||
2013 | my $w = splice @_, 1, 1; | ||||
2014 | $g->add_edge_by_id(@_); | ||||
2015 | $g->set_edge_attribute_by_id(@_, $defattr, $w); | ||||
2016 | } else { | ||||
2017 | my $w = pop; | ||||
2018 | $g->add_edge_by_id(@_); | ||||
2019 | $g->set_edge_attribute_by_id(@_, $defattr, $w); | ||||
2020 | } | ||||
2021 | } | ||||
2022 | |||||
2023 | sub add_weighted_path_by_id { | ||||
2024 | my $g = shift; | ||||
2025 | $g->expect_multiedged; | ||||
2026 | my $id = pop; | ||||
2027 | my $u = shift; | ||||
2028 | while (@_) { | ||||
2029 | my ($w, $v) = splice @_, 0, 2; | ||||
2030 | $g->add_edge_by_id($u, $v, $id); | ||||
2031 | $g->set_edge_attribute_by_id($u, $v, $id, $defattr, $w); | ||||
2032 | $u = $v; | ||||
2033 | } | ||||
2034 | } | ||||
2035 | |||||
2036 | sub get_edge_weight_by_id { | ||||
2037 | my $g = shift; | ||||
2038 | $g->expect_multiedged; | ||||
2039 | $g->get_edge_attribute_by_id(@_, $defattr); | ||||
2040 | } | ||||
2041 | |||||
2042 | sub has_edge_weight_by_id { | ||||
2043 | my $g = shift; | ||||
2044 | $g->expect_multiedged; | ||||
2045 | $g->has_edge_attribute_by_id(@_, $defattr); | ||||
2046 | } | ||||
2047 | |||||
2048 | sub set_edge_weight_by_id { | ||||
2049 | my $g = shift; | ||||
2050 | $g->expect_multiedged; | ||||
2051 | my $w = pop; | ||||
2052 | $g->set_edge_attribute_by_id(@_, $defattr, $w); | ||||
2053 | } | ||||
2054 | |||||
2055 | sub delete_edge_weight_by_id { | ||||
2056 | my $g = shift; | ||||
2057 | $g->expect_multiedged; | ||||
2058 | $g->delete_edge_attribute_by_id(@_, $defattr); | ||||
2059 | } | ||||
2060 | |||||
2061 | ### | ||||
2062 | # Error helpers. | ||||
2063 | # | ||||
2064 | |||||
2065 | 1 | 200ns | my %expected; | ||
2066 | 1 | 4µs | @expected{qw(directed undirected acyclic)} = qw(undirected directed cyclic); | ||
2067 | |||||
2068 | sub _expected { | ||||
2069 | my $exp = shift; | ||||
2070 | my $got = @_ ? shift : $expected{$exp}; | ||||
2071 | $got = defined $got ? ", got $got" : ""; | ||||
2072 | if (my @caller2 = caller(2)) { | ||||
2073 | die "$caller2[3]: expected $exp graph$got, at $caller2[1] line $caller2[2].\n"; | ||||
2074 | } else { | ||||
2075 | my @caller1 = caller(1); | ||||
2076 | die "$caller1[3]: expected $exp graph$got, at $caller1[1] line $caller1[2].\n"; | ||||
2077 | } | ||||
2078 | } | ||||
2079 | |||||
2080 | sub expect_undirected { | ||||
2081 | 76 | 187µs | my $g = shift; | ||
2082 | 38 | 289µs | _expected('undirected') unless $g->is_undirected; # spent 289µs making 38 calls to Graph::omniedged, avg 8µs/call | ||
2083 | } | ||||
2084 | |||||
2085 | sub expect_directed { | ||||
2086 | my $g = shift; | ||||
2087 | _expected('directed') unless $g->is_directed; | ||||
2088 | } | ||||
2089 | |||||
2090 | sub expect_acyclic { | ||||
2091 | my $g = shift; | ||||
2092 | _expected('acyclic') unless $g->is_acyclic; | ||||
2093 | } | ||||
2094 | |||||
2095 | sub expect_dag { | ||||
2096 | my $g = shift; | ||||
2097 | my @got; | ||||
2098 | push @got, 'undirected' unless $g->is_directed; | ||||
2099 | push @got, 'cyclic' unless $g->is_acyclic; | ||||
2100 | _expected('directed acyclic', "@got") if @got; | ||||
2101 | } | ||||
2102 | |||||
2103 | sub expect_multivertexed { | ||||
2104 | my $g = shift; | ||||
2105 | _expected('multivertexed') unless $g->is_multivertexed; | ||||
2106 | } | ||||
2107 | |||||
2108 | sub expect_non_multivertexed { | ||||
2109 | my $g = shift; | ||||
2110 | _expected('non-multivertexed') if $g->is_multivertexed; | ||||
2111 | } | ||||
2112 | |||||
2113 | # spent 250ms (99.7+151) within Graph::expect_non_multiedged which was called 39968 times, avg 6µs/call:
# 19958 times (49.1ms+75.3ms) by Graph::set_edge_attribute at line 1464, avg 6µs/call
# 15003 times (37.0ms+55.4ms) by Graph::add_weighted_edge at line 1931, avg 6µs/call
# 5007 times (13.6ms+19.9ms) by Graph::get_edge_attribute at line 1565, avg 7µs/call | ||||
2114 | 79936 | 83.1ms | my $g = shift; | ||
2115 | 39968 | 151ms | _expected('non-multiedged') if $g->is_multiedged; # spent 151ms making 39968 calls to Graph::multiedged, avg 4µs/call | ||
2116 | } | ||||
2117 | |||||
2118 | sub expect_multiedged { | ||||
2119 | my $g = shift; | ||||
2120 | _expected('multiedged') unless $g->is_multiedged; | ||||
2121 | } | ||||
2122 | |||||
2123 | sub expect_non_unionfind { | ||||
2124 | my $g = shift; | ||||
2125 | _expected('non-unionfind') if $g->has_union_find; | ||||
2126 | } | ||||
2127 | |||||
2128 | sub _get_options { | ||||
2129 | 740 | 2.08ms | my @caller = caller(1); | ||
2130 | unless (@_ == 1 && ref $_[0] eq 'ARRAY') { | ||||
2131 | die "$caller[3]: internal error: should be called with only one array ref argument, at $caller[1] line $caller[2].\n"; | ||||
2132 | } | ||||
2133 | my @opt = @{ $_[0] }; | ||||
2134 | unless (@opt % 2 == 0) { | ||||
2135 | die "$caller[3]: expected an options hash, got a non-even number of arguments, at $caller[1] line $caller[2].\n"; | ||||
2136 | } | ||||
2137 | return @opt; | ||||
2138 | } | ||||
2139 | |||||
2140 | ### | ||||
2141 | # Random constructors and accessors. | ||||
2142 | # | ||||
2143 | |||||
2144 | sub __fisher_yates_shuffle (@) { | ||||
2145 | # From perlfaq4, but modified to be non-modifying. | ||||
2146 | my @a = @_; | ||||
2147 | my $i = @a; | ||||
2148 | while ($i--) { | ||||
2149 | my $j = int rand ($i+1); | ||||
2150 | @a[$i,$j] = @a[$j,$i]; | ||||
2151 | } | ||||
2152 | return @a; | ||||
2153 | } | ||||
2154 | |||||
2155 | # spent 10µs within Graph::BEGIN@2155 which was called:
# once (10µs+0s) by Bio::Roary::OrderGenes::BEGIN@22 at line 2166 | ||||
2156 | sub _shuffle(@); | ||||
2157 | # Workaround for the Perl bug [perl #32383] where -d:Dprof and | ||||
2158 | # List::Util::shuffle do not like each other: if any debugging | ||||
2159 | # (-d) flags are on, fall back to our own Fisher-Yates shuffle. | ||||
2160 | # The bug was fixed by perl changes #26054 and #26062, which | ||||
2161 | # went to Perl 5.9.3. If someone tests this with a pre-5.9.3 | ||||
2162 | # bleadperl that calls itself 5.9.3 but doesn't yet have the | ||||
2163 | # patches, oh, well. | ||||
2164 | 1 | 11µs | *_shuffle = $^P && $] < 5.009003 ? | ||
2165 | \&__fisher_yates_shuffle : \&List::Util::shuffle; | ||||
2166 | 1 | 8.76ms | 1 | 10µs | } # spent 10µs making 1 call to Graph::BEGIN@2155 |
2167 | |||||
2168 | sub random_graph { | ||||
2169 | my $class = (@_ % 2) == 0 ? 'Graph' : shift; | ||||
2170 | my %opt = _get_options( \@_ ); | ||||
2171 | my $random_edge; | ||||
2172 | unless (exists $opt{vertices} && defined $opt{vertices}) { | ||||
2173 | require Carp; | ||||
2174 | Carp::croak("Graph::random_graph: argument 'vertices' missing or undef"); | ||||
2175 | } | ||||
2176 | if (exists $opt{random_seed}) { | ||||
2177 | srand($opt{random_seed}); | ||||
2178 | delete $opt{random_seed}; | ||||
2179 | } | ||||
2180 | if (exists $opt{random_edge}) { | ||||
2181 | $random_edge = $opt{random_edge}; | ||||
2182 | delete $opt{random_edge}; | ||||
2183 | } | ||||
2184 | my @V; | ||||
2185 | if (my $ref = ref $opt{vertices}) { | ||||
2186 | if ($ref eq 'ARRAY') { | ||||
2187 | @V = @{ $opt{vertices} }; | ||||
2188 | } else { | ||||
2189 | Carp::croak("Graph::random_graph: argument 'vertices' illegal"); | ||||
2190 | } | ||||
2191 | } else { | ||||
2192 | @V = 0..($opt{vertices} - 1); | ||||
2193 | } | ||||
2194 | delete $opt{vertices}; | ||||
2195 | my $V = @V; | ||||
2196 | my $C = $V * ($V - 1) / 2; | ||||
2197 | my $E; | ||||
2198 | if (exists $opt{edges} && exists $opt{edges_fill}) { | ||||
2199 | Carp::croak("Graph::random_graph: both arguments 'edges' and 'edges_fill' specified"); | ||||
2200 | } | ||||
2201 | $E = exists $opt{edges_fill} ? $opt{edges_fill} * $C : $opt{edges}; | ||||
2202 | delete $opt{edges}; | ||||
2203 | delete $opt{edges_fill}; | ||||
2204 | my $g = $class->new(%opt); | ||||
2205 | $g->add_vertices(@V); | ||||
2206 | return $g if $V < 2; | ||||
2207 | $C *= 2 if $g->directed; | ||||
2208 | $E = $C / 2 unless defined $E; | ||||
2209 | $E = int($E + 0.5); | ||||
2210 | my $p = $E / $C; | ||||
2211 | $random_edge = sub { $p } unless defined $random_edge; | ||||
2212 | # print "V = $V, E = $E, C = $C, p = $p\n"; | ||||
2213 | if ($p > 1.0 && !($g->countedged || $g->multiedged)) { | ||||
2214 | require Carp; | ||||
2215 | Carp::croak("Graph::random_graph: needs to be countedged or multiedged ($E > $C)"); | ||||
2216 | } | ||||
2217 | my @V1 = @V; | ||||
2218 | my @V2 = @V; | ||||
2219 | # Shuffle the vertex lists so that the pairs at | ||||
2220 | # the beginning of the lists are not more likely. | ||||
2221 | @V1 = _shuffle @V1; | ||||
2222 | @V2 = _shuffle @V2; | ||||
2223 | LOOP: | ||||
2224 | while ($E) { | ||||
2225 | for my $v1 (@V1) { | ||||
2226 | for my $v2 (@V2) { | ||||
2227 | next if $v1 eq $v2; # TODO: allow self-loops? | ||||
2228 | my $q = $random_edge->($g, $v1, $v2, $p); | ||||
2229 | if ($q && ($q == 1 || rand() <= $q) && | ||||
2230 | !$g->has_edge($v1, $v2)) { | ||||
2231 | $g->add_edge($v1, $v2); | ||||
2232 | $E--; | ||||
2233 | last LOOP unless $E; | ||||
2234 | } | ||||
2235 | } | ||||
2236 | } | ||||
2237 | } | ||||
2238 | return $g; | ||||
2239 | } | ||||
2240 | |||||
2241 | sub random_vertex { | ||||
2242 | my $g = shift; | ||||
2243 | my @V = $g->vertices05; | ||||
2244 | @V[rand @V]; | ||||
2245 | } | ||||
2246 | |||||
2247 | sub random_edge { | ||||
2248 | my $g = shift; | ||||
2249 | my @E = $g->edges05; | ||||
2250 | @E[rand @E]; | ||||
2251 | } | ||||
2252 | |||||
2253 | sub random_successor { | ||||
2254 | my ($g, $v) = @_; | ||||
2255 | my @S = $g->successors($v); | ||||
2256 | @S[rand @S]; | ||||
2257 | } | ||||
2258 | |||||
2259 | sub random_predecessor { | ||||
2260 | my ($g, $v) = @_; | ||||
2261 | my @P = $g->predecessors($v); | ||||
2262 | @P[rand @P]; | ||||
2263 | } | ||||
2264 | |||||
2265 | ### | ||||
2266 | # Algorithms. | ||||
2267 | # | ||||
2268 | |||||
2269 | 1 | 3µs | my $MST_comparator = sub { ($_[0] || 0) <=> ($_[1] || 0) }; | ||
2270 | |||||
2271 | sub _MST_attr { | ||||
2272 | my $attr = shift; | ||||
2273 | my $attribute = | ||||
2274 | exists $attr->{attribute} ? | ||||
2275 | $attr->{attribute} : $defattr; | ||||
2276 | my $comparator = | ||||
2277 | exists $attr->{comparator} ? | ||||
2278 | $attr->{comparator} : $MST_comparator; | ||||
2279 | return ($attribute, $comparator); | ||||
2280 | } | ||||
2281 | |||||
2282 | sub _MST_edges { | ||||
2283 | my ($g, $attr) = @_; | ||||
2284 | my ($attribute, $comparator) = _MST_attr($attr); | ||||
2285 | map { $_->[1] } | ||||
2286 | sort { $comparator->($a->[0], $b->[0], $a->[1], $b->[1]) } | ||||
2287 | map { [ $g->get_edge_attribute(@$_, $attribute), $_ ] } | ||||
2288 | $g->edges05; | ||||
2289 | } | ||||
2290 | |||||
2291 | sub MST_Kruskal { | ||||
2292 | my ($g, %attr) = @_; | ||||
2293 | |||||
2294 | $g->expect_undirected; | ||||
2295 | |||||
2296 | my $MST = Graph::Undirected->new; | ||||
2297 | |||||
2298 | my $UF = Graph::UnionFind->new; | ||||
2299 | for my $v ($g->vertices05) { $UF->add($v) } | ||||
2300 | |||||
2301 | for my $e ($g->_MST_edges(\%attr)) { | ||||
2302 | my ($u, $v) = @$e; # TODO: hyperedges | ||||
2303 | my $t0 = $UF->find( $u ); | ||||
2304 | my $t1 = $UF->find( $v ); | ||||
2305 | unless ($t0 eq $t1) { | ||||
2306 | $UF->union($u, $v); | ||||
2307 | $MST->add_edge($u, $v); | ||||
2308 | } | ||||
2309 | } | ||||
2310 | |||||
2311 | return $MST; | ||||
2312 | } | ||||
2313 | |||||
2314 | sub _MST_add { | ||||
2315 | 9982 | 24.8ms | my ($g, $h, $HF, $r, $attr, $unseen) = @_; | ||
2316 | 4991 | 332ms | for my $s ( grep { exists $unseen->{ $_ } } $g->successors( $r ) ) { # spent 332ms making 4991 calls to Graph::successors, avg 67µs/call | ||
2317 | 5007 | 29.1ms | 15021 | 460ms | $HF->add( Graph::MSTHeapElem->new( $r, $s, $g->get_edge_attribute( $r, $s, $attr ) ) ); # spent 325ms making 5007 calls to Graph::get_edge_attribute, avg 65µs/call
# spent 117ms making 5007 calls to Heap071::Fibonacci::add, avg 23µs/call
# spent 17.0ms making 5007 calls to Graph::MSTHeapElem::new, avg 3µs/call |
2318 | } | ||||
2319 | } | ||||
2320 | |||||
2321 | sub _next_alphabetic { shift; (sort keys %{ $_[0] })[0] } | ||||
2322 | sub _next_numeric { shift; (sort { $a <=> $b } keys %{ $_[0] })[0] } | ||||
2323 | 20022 | 30.2ms | # spent 24.5ms within Graph::_next_random which was called 10011 times, avg 2µs/call:
# 9910 times (23.8ms+0s) by Graph::Traversal::next at line 298 of Graph/Traversal.pm, avg 2µs/call
# 36 times (348µs+0s) by Graph::Traversal::next at line 324 of Graph/Traversal.pm, avg 10µs/call
# 36 times (280µs+0s) by Graph::_heap_walk at line 2385, avg 8µs/call
# 29 times (84µs+0s) by Graph::Traversal::next at line 332 of Graph/Traversal.pm, avg 3µs/call | ||
2324 | |||||
2325 | # spent 13.6ms (5.68+7.92) within Graph::_root_opt which was called 36 times, avg 378µs/call:
# 36 times (5.68ms+7.92ms) by Graph::_heap_walk at line 2364, avg 378µs/call | ||||
2326 | 504 | 5.75ms | my $g = shift; | ||
2327 | 36 | 305µs | my %opt = @_ == 1 ? ( first_root => $_[0] ) : _get_options( \@_ ); # spent 305µs making 36 calls to Graph::_get_options, avg 8µs/call | ||
2328 | my %unseen; | ||||
2329 | 36 | 7.43ms | my @unseen = $g->vertices05; # spent 7.43ms making 36 calls to Graph::vertices05, avg 206µs/call | ||
2330 | @unseen{ @unseen } = @unseen; | ||||
2331 | 36 | 187µs | @unseen = _shuffle @unseen; # spent 187µs making 36 calls to List::Util::shuffle, avg 5µs/call | ||
2332 | my $r; | ||||
2333 | if (exists $opt{ start }) { | ||||
2334 | $opt{ first_root } = $opt{ start }; | ||||
2335 | $opt{ next_root } = undef; | ||||
2336 | } | ||||
2337 | if (exists $opt{ get_next_root }) { | ||||
2338 | $opt{ next_root } = $opt{ get_next_root }; # Graph 0.201 compat. | ||||
2339 | } | ||||
2340 | 36 | 30µs | if (exists $opt{ first_root }) { | ||
2341 | if (ref $opt{ first_root } eq 'CODE') { | ||||
2342 | $r = $opt{ first_root }->( $g, \%unseen ); | ||||
2343 | } else { | ||||
2344 | $r = $opt{ first_root }; | ||||
2345 | } | ||||
2346 | } else { | ||||
2347 | $r = shift @unseen; | ||||
2348 | } | ||||
2349 | my $next = | ||||
2350 | exists $opt{ next_root } ? | ||||
2351 | $opt{ next_root } : | ||||
2352 | $opt{ next_alphabetic } ? | ||||
2353 | \&_next_alphabetic : | ||||
2354 | $opt{ next_numeric } ? \&_next_numeric : | ||||
2355 | \&_next_random; | ||||
2356 | my $code = ref $next eq 'CODE'; | ||||
2357 | my $attr = exists $opt{ attribute } ? $opt{ attribute } : $defattr; | ||||
2358 | return ( \%opt, \%unseen, \@unseen, $r, $next, $code, $attr ); | ||||
2359 | } | ||||
2360 | |||||
2361 | # spent 1.79s (84.6ms+1.71) within Graph::_heap_walk which was called 36 times, avg 49.8ms/call:
# 36 times (84.6ms+1.71s) by Graph::MST_Prim at line 2394, avg 49.8ms/call | ||||
2362 | 180 | 582µs | my ($g, $h, $add, $etc) = splice @_, 0, 4; # Leave %opt in @_. | ||
2363 | |||||
2364 | 36 | 13.6ms | my ($opt, $unseenh, $unseena, $r, $next, $code, $attr) = $g->_root_opt(@_); # spent 13.6ms making 36 calls to Graph::_root_opt, avg 378µs/call | ||
2365 | 36 | 189µs | my $HF = Heap071::Fibonacci->new; # spent 189µs making 36 calls to Heap071::Fibonacci::new, avg 5µs/call | ||
2366 | |||||
2367 | while (defined $r) { | ||||
2368 | # print "r = $r\n"; | ||||
2369 | 180 | 348µs | 36 | 34.2ms | $add->($g, $h, $HF, $r, $attr, $unseenh, $etc); # spent 34.2ms making 36 calls to Graph::_MST_add, avg 950µs/call |
2370 | delete $unseenh->{ $r }; | ||||
2371 | 36 | 100µs | while (defined $HF->top) { # spent 100µs making 36 calls to Heap071::Fibonacci::top, avg 3µs/call | ||
2372 | 10014 | 24.3ms | 5007 | 154ms | my $t = $HF->extract_top; # spent 154ms making 5007 calls to Heap071::Fibonacci::extract_top, avg 31µs/call |
2373 | # use Data::Dumper; print "t = ", Dumper($t); | ||||
2374 | 10014 | 13.7ms | 5008 | 8.36ms | if (defined $t) { # spent 8.01ms making 5007 calls to Heap071::Fibonacci::top, avg 2µs/call
# spent 355µs making 1 call to AutoLoader::AUTOLOAD |
2375 | 5007 | 9.05ms | my ($u, $v, $w) = $t->val; # spent 9.05ms making 5007 calls to Graph::MSTHeapElem::val, avg 2µs/call | ||
2376 | # print "extracted top: $u $v $w\n"; | ||||
2377 | 14865 | 18.4ms | if (exists $unseenh->{ $v }) { | ||
2378 | 4955 | 661ms | $h->set_edge_attribute($u, $v, $attr, $w); # spent 661ms making 4955 calls to Graph::set_edge_attribute, avg 133µs/call | ||
2379 | delete $unseenh->{ $v }; | ||||
2380 | 4955 | 827ms | $add->($g, $h, $HF, $v, $attr, $unseenh, $etc); # spent 827ms making 4955 calls to Graph::_MST_add, avg 167µs/call | ||
2381 | } | ||||
2382 | } | ||||
2383 | } | ||||
2384 | return $h unless defined $next; | ||||
2385 | 36 | 280µs | $r = $code ? $next->( $g, $unseenh ) : shift @$unseena; # spent 280µs making 36 calls to Graph::_next_random, avg 8µs/call | ||
2386 | } | ||||
2387 | |||||
2388 | return $h; | ||||
2389 | } | ||||
2390 | |||||
2391 | # spent 1.80s (686µs+1.80) within Graph::MST_Prim which was called 36 times, avg 50.0ms/call:
# 36 times (686µs+1.80s) by Bio::Roary::OrderGenes::_reorder_connected_components at line 183 of lib/Bio/Roary/OrderGenes.pm, avg 50.0ms/call | ||||
2392 | 108 | 603µs | my $g = shift; | ||
2393 | 36 | 443µs | $g->expect_undirected; # spent 443µs making 36 calls to Graph::expect_undirected, avg 12µs/call | ||
2394 | 1 | 1.55ms | 108 | 1.80s | $g->_heap_walk(Graph::Undirected->new(), \&_MST_add, undef, @_); # spent 1.79s making 36 calls to Graph::_heap_walk, avg 49.8ms/call
# spent 5.67ms making 36 calls to Graph::Undirected::new, avg 158µs/call
# spent 539µs making 36 calls to Heap071::Fibonacci::DESTROY, avg 15µs/call |
2395 | } | ||||
2396 | |||||
2397 | 1 | 2µs | *MST_Dijkstra = \&MST_Prim; | ||
2398 | |||||
2399 | 1 | 1µs | *minimum_spanning_tree = \&MST_Prim; | ||
2400 | |||||
2401 | ### | ||||
2402 | # Cycle detection. | ||||
2403 | # | ||||
2404 | |||||
2405 | 1 | 2µs | *is_cyclic = \&has_a_cycle; | ||
2406 | |||||
2407 | sub is_acyclic { | ||||
2408 | my $g = shift; | ||||
2409 | return !$g->is_cyclic; | ||||
2410 | } | ||||
2411 | |||||
2412 | sub is_dag { | ||||
2413 | my $g = shift; | ||||
2414 | return $g->is_directed && $g->is_acyclic ? 1 : 0; | ||||
2415 | } | ||||
2416 | |||||
2417 | 1 | 2µs | *is_directed_acyclic_graph = \&is_dag; | ||
2418 | |||||
2419 | ### | ||||
2420 | # Backward compat. | ||||
2421 | # | ||||
2422 | |||||
2423 | sub average_degree { | ||||
2424 | my $g = shift; | ||||
2425 | my $V = $g->vertices05; | ||||
2426 | |||||
2427 | return $V ? $g->degree / $V : 0; | ||||
2428 | } | ||||
2429 | |||||
2430 | sub density_limits { | ||||
2431 | my $g = shift; | ||||
2432 | |||||
2433 | my $V = $g->vertices05; | ||||
2434 | my $M = $V * ($V - 1); | ||||
2435 | |||||
2436 | $M /= 2 if $g->is_undirected; | ||||
2437 | |||||
2438 | return ( 0.25 * $M, 0.75 * $M, $M ); | ||||
2439 | } | ||||
2440 | |||||
2441 | sub density { | ||||
2442 | my $g = shift; | ||||
2443 | my ($sparse, $dense, $complete) = $g->density_limits; | ||||
2444 | |||||
2445 | return $complete ? $g->edges / $complete : 0; | ||||
2446 | } | ||||
2447 | |||||
2448 | ### | ||||
2449 | # Attribute backward compat | ||||
2450 | # | ||||
2451 | |||||
2452 | sub _attr02_012 { | ||||
2453 | my ($g, $op, $ga, $va, $ea) = splice @_, 0, 5; | ||||
2454 | if ($g->is_compat02) { | ||||
2455 | if (@_ == 0) { return $ga->( $g ) } | ||||
2456 | elsif (@_ == 1) { return $va->( $g, @_ ) } | ||||
2457 | elsif (@_ == 2) { return $ea->( $g, @_ ) } | ||||
2458 | else { | ||||
2459 | die sprintf "$op: wrong number of arguments (%d)", scalar @_; | ||||
2460 | } | ||||
2461 | } else { | ||||
2462 | die "$op: not a compat02 graph" | ||||
2463 | } | ||||
2464 | } | ||||
2465 | |||||
2466 | sub _attr02_123 { | ||||
2467 | my ($g, $op, $ga, $va, $ea) = splice @_, 0, 5; | ||||
2468 | if ($g->is_compat02) { | ||||
2469 | if (@_ == 1) { return $ga->( $g, @_ ) } | ||||
2470 | elsif (@_ == 2) { return $va->( $g, @_[1, 0] ) } | ||||
2471 | elsif (@_ == 3) { return $ea->( $g, @_[1, 2, 0] ) } | ||||
2472 | else { | ||||
2473 | die sprintf "$op: wrong number of arguments (%d)", scalar @_; | ||||
2474 | } | ||||
2475 | } else { | ||||
2476 | die "$op: not a compat02 graph" | ||||
2477 | } | ||||
2478 | } | ||||
2479 | |||||
2480 | sub _attr02_234 { | ||||
2481 | my ($g, $op, $ga, $va, $ea) = splice @_, 0, 5; | ||||
2482 | if ($g->is_compat02) { | ||||
2483 | if (@_ == 2) { return $ga->( $g, @_ ) } | ||||
2484 | elsif (@_ == 3) { return $va->( $g, @_[1, 0, 2] ) } | ||||
2485 | elsif (@_ == 4) { return $ea->( $g, @_[1, 2, 0, 3] ) } | ||||
2486 | else { | ||||
2487 | die sprintf "$op: wrong number of arguments (%d)", scalar @_; | ||||
2488 | } | ||||
2489 | } else { | ||||
2490 | die "$op: not a compat02 graph"; | ||||
2491 | } | ||||
2492 | } | ||||
2493 | |||||
2494 | sub set_attribute { | ||||
2495 | my $g = shift; | ||||
2496 | $g->_attr02_234('set_attribute', | ||||
2497 | \&Graph::set_graph_attribute, | ||||
2498 | \&Graph::set_vertex_attribute, | ||||
2499 | \&Graph::set_edge_attribute, | ||||
2500 | @_); | ||||
2501 | |||||
2502 | } | ||||
2503 | |||||
2504 | sub set_attributes { | ||||
2505 | my $g = shift; | ||||
2506 | my $a = pop; | ||||
2507 | $g->_attr02_123('set_attributes', | ||||
2508 | \&Graph::set_graph_attributes, | ||||
2509 | \&Graph::set_vertex_attributes, | ||||
2510 | \&Graph::set_edge_attributes, | ||||
2511 | $a, @_); | ||||
2512 | |||||
2513 | } | ||||
2514 | |||||
2515 | sub get_attribute { | ||||
2516 | my $g = shift; | ||||
2517 | $g->_attr02_123('get_attribute', | ||||
2518 | \&Graph::get_graph_attribute, | ||||
2519 | \&Graph::get_vertex_attribute, | ||||
2520 | \&Graph::get_edge_attribute, | ||||
2521 | @_); | ||||
2522 | |||||
2523 | } | ||||
2524 | |||||
2525 | sub get_attributes { | ||||
2526 | my $g = shift; | ||||
2527 | $g->_attr02_012('get_attributes', | ||||
2528 | \&Graph::get_graph_attributes, | ||||
2529 | \&Graph::get_vertex_attributes, | ||||
2530 | \&Graph::get_edge_attributes, | ||||
2531 | @_); | ||||
2532 | |||||
2533 | } | ||||
2534 | |||||
2535 | sub has_attribute { | ||||
2536 | my $g = shift; | ||||
2537 | return 0 unless @_; | ||||
2538 | $g->_attr02_123('has_attribute', | ||||
2539 | \&Graph::has_graph_attribute, | ||||
2540 | \&Graph::has_vertex_attribute, | ||||
2541 | \&Graph::get_edge_attribute, | ||||
2542 | @_); | ||||
2543 | |||||
2544 | } | ||||
2545 | |||||
2546 | sub has_attributes { | ||||
2547 | my $g = shift; | ||||
2548 | $g->_attr02_012('has_attributes', | ||||
2549 | \&Graph::has_graph_attributes, | ||||
2550 | \&Graph::has_vertex_attributes, | ||||
2551 | \&Graph::has_edge_attributes, | ||||
2552 | @_); | ||||
2553 | |||||
2554 | } | ||||
2555 | |||||
2556 | sub delete_attribute { | ||||
2557 | my $g = shift; | ||||
2558 | $g->_attr02_123('delete_attribute', | ||||
2559 | \&Graph::delete_graph_attribute, | ||||
2560 | \&Graph::delete_vertex_attribute, | ||||
2561 | \&Graph::delete_edge_attribute, | ||||
2562 | @_); | ||||
2563 | |||||
2564 | } | ||||
2565 | |||||
2566 | sub delete_attributes { | ||||
2567 | my $g = shift; | ||||
2568 | $g->_attr02_012('delete_attributes', | ||||
2569 | \&Graph::delete_graph_attributes, | ||||
2570 | \&Graph::delete_vertex_attributes, | ||||
2571 | \&Graph::delete_edge_attributes, | ||||
2572 | @_); | ||||
2573 | |||||
2574 | } | ||||
2575 | |||||
2576 | ### | ||||
2577 | # Simple DFS uses. | ||||
2578 | # | ||||
2579 | |||||
2580 | sub topological_sort { | ||||
2581 | my $g = shift; | ||||
2582 | my %opt = _get_options( \@_ ); | ||||
2583 | my $eic = $opt{ empty_if_cyclic }; | ||||
2584 | my $hac; | ||||
2585 | if ($eic) { | ||||
2586 | $hac = $g->has_a_cycle; | ||||
2587 | } else { | ||||
2588 | $g->expect_dag; | ||||
2589 | } | ||||
2590 | delete $opt{ empty_if_cyclic }; | ||||
2591 | my $t = Graph::Traversal::DFS->new($g, %opt); | ||||
2592 | my @s = $t->dfs; | ||||
2593 | $hac ? () : reverse @s; | ||||
2594 | } | ||||
2595 | |||||
2596 | 1 | 2µs | *toposort = \&topological_sort; | ||
2597 | |||||
2598 | sub _undirected_copy_compute { | ||||
2599 | my $g = shift; | ||||
2600 | my $c = Graph::Undirected->new; | ||||
2601 | for my $v ($g->isolated_vertices) { # TODO: if iv ... | ||||
2602 | $c->add_vertex($v); | ||||
2603 | } | ||||
2604 | for my $e ($g->edges05) { | ||||
2605 | $c->add_edge(@$e); | ||||
2606 | } | ||||
2607 | return $c; | ||||
2608 | } | ||||
2609 | |||||
2610 | sub undirected_copy { | ||||
2611 | my $g = shift; | ||||
2612 | $g->expect_directed; | ||||
2613 | return _check_cache($g, 'undirected', \&_undirected_copy_compute); | ||||
2614 | } | ||||
2615 | |||||
2616 | 1 | 2µs | *undirected_copy_graph = \&undirected_copy; | ||
2617 | |||||
2618 | sub directed_copy { | ||||
2619 | my $g = shift; | ||||
2620 | $g->expect_undirected; | ||||
2621 | my $c = Graph::Directed->new; | ||||
2622 | for my $v ($g->isolated_vertices) { # TODO: if iv ... | ||||
2623 | $c->add_vertex($v); | ||||
2624 | } | ||||
2625 | for my $e ($g->edges05) { | ||||
2626 | my @e = @$e; | ||||
2627 | $c->add_edge(@e); | ||||
2628 | $c->add_edge(reverse @e); | ||||
2629 | } | ||||
2630 | return $c; | ||||
2631 | } | ||||
2632 | |||||
2633 | 1 | 2µs | *directed_copy_graph = \&directed_copy; | ||
2634 | |||||
2635 | ### | ||||
2636 | # Cache or not. | ||||
2637 | # | ||||
2638 | |||||
2639 | 1 | 6µs | my %_cache_type = | ||
2640 | ( | ||||
2641 | 'connectivity' => '_ccc', | ||||
2642 | 'strong_connectivity' => '_scc', | ||||
2643 | 'biconnectivity' => '_bcc', | ||||
2644 | 'SPT_Dijkstra' => '_spt_di', | ||||
2645 | 'SPT_Bellman_Ford' => '_spt_bf', | ||||
2646 | 'undirected' => '_undirected', | ||||
2647 | ); | ||||
2648 | |||||
2649 | # spent 1.40s (80µs+1.40) within Graph::_check_cache which was called 2 times, avg 701ms/call:
# 2 times (80µs+1.40s) by Graph::_connected_components at line 2763, avg 701ms/call | ||||
2650 | 6 | 11µs | my ($g, $type, $code) = splice @_, 0, 3; | ||
2651 | my $c = $_cache_type{$type}; | ||||
2652 | 6 | 28µs | if (defined $c) { | ||
2653 | 2 | 52µs | my $a = $g->get_graph_attribute($c); # spent 52µs making 2 calls to Graph::Attribute::get_attribute, avg 26µs/call | ||
2654 | 6 | 35µs | unless (defined $a && $a->[ 0 ] == $g->[ _G ]) { | ||
2655 | $a->[ 0 ] = $g->[ _G ]; | ||||
2656 | 2 | 1.40s | $a->[ 1 ] = $code->( $g, @_ ); # spent 1.40s making 2 calls to Graph::_connected_components_compute, avg 701ms/call | ||
2657 | 2 | 63µs | $g->set_graph_attribute($c, $a); # spent 63µs making 2 calls to Graph::Attribute::set_attribute, avg 32µs/call | ||
2658 | } | ||||
2659 | return $a->[ 1 ]; | ||||
2660 | } else { | ||||
2661 | Carp::croak("Graph: unknown cache type '$type'"); | ||||
2662 | } | ||||
2663 | } | ||||
2664 | |||||
2665 | sub _clear_cache { | ||||
2666 | my ($g, $type) = @_; | ||||
2667 | my $c = $_cache_type{$type}; | ||||
2668 | if (defined $c) { | ||||
2669 | $g->delete_graph_attribute($c); | ||||
2670 | } else { | ||||
2671 | Carp::croak("Graph: unknown cache type '$type'"); | ||||
2672 | } | ||||
2673 | } | ||||
2674 | |||||
2675 | sub connectivity_clear_cache { | ||||
2676 | my $g = shift; | ||||
2677 | _clear_cache($g, 'connectivity'); | ||||
2678 | } | ||||
2679 | |||||
2680 | sub strong_connectivity_clear_cache { | ||||
2681 | my $g = shift; | ||||
2682 | _clear_cache($g, 'strong_connectivity'); | ||||
2683 | } | ||||
2684 | |||||
2685 | sub biconnectivity_clear_cache { | ||||
2686 | my $g = shift; | ||||
2687 | _clear_cache($g, 'biconnectivity'); | ||||
2688 | } | ||||
2689 | |||||
2690 | sub SPT_Dijkstra_clear_cache { | ||||
2691 | my $g = shift; | ||||
2692 | _clear_cache($g, 'SPT_Dijkstra'); | ||||
2693 | $g->delete_graph_attribute('SPT_Dijkstra_first_root'); | ||||
2694 | } | ||||
2695 | |||||
2696 | sub SPT_Bellman_Ford_clear_cache { | ||||
2697 | my $g = shift; | ||||
2698 | _clear_cache($g, 'SPT_Bellman_Ford'); | ||||
2699 | } | ||||
2700 | |||||
2701 | sub undirected_copy_clear_cache { | ||||
2702 | my $g = shift; | ||||
2703 | _clear_cache($g, 'undirected_copy'); | ||||
2704 | } | ||||
2705 | |||||
2706 | ### | ||||
2707 | # Connected components. | ||||
2708 | # | ||||
2709 | |||||
2710 | # spent 1.40s (25.5ms+1.38) within Graph::_connected_components_compute which was called 2 times, avg 701ms/call:
# 2 times (25.5ms+1.38s) by Graph::_check_cache at line 2656, avg 701ms/call | ||||
2711 | 12 | 42µs | my $g = shift; | ||
2712 | my %cce; | ||||
2713 | my %cci; | ||||
2714 | my $cc = 0; | ||||
2715 | 14 | 25.5ms | 2 | 7µs | if ($g->has_union_find) { # spent 7µs making 2 calls to Graph::has_union_find, avg 3µs/call |
2716 | my $UF = $g->_get_union_find(); | ||||
2717 | my $V = $g->[ _V ]; | ||||
2718 | my %icce; # Isolated vertices. | ||||
2719 | my %icci; | ||||
2720 | my $icc = 0; | ||||
2721 | for my $v ( $g->unique_vertices ) { | ||||
2722 | $cc = $UF->find( $V->_get_path_id( $v ) ); | ||||
2723 | if (defined $cc) { | ||||
2724 | $cce{ $v } = $cc; | ||||
2725 | push @{ $cci{ $cc } }, $v; | ||||
2726 | } else { | ||||
2727 | $icce{ $v } = $icc; | ||||
2728 | push @{ $icci{ $icc } }, $v; | ||||
2729 | $icc++; | ||||
2730 | } | ||||
2731 | } | ||||
2732 | if ($icc) { | ||||
2733 | @cce{ keys %icce } = values %icce; | ||||
2734 | @cci{ keys %icci } = values %icci; | ||||
2735 | } | ||||
2736 | } else { | ||||
2737 | 2 | 12.1ms | my @u = $g->unique_vertices; # spent 12.1ms making 2 calls to Graph::unique_vertices, avg 6.05ms/call | ||
2738 | my %r; @r{ @u } = @u; | ||||
2739 | # spent 16µs within Graph::__ANON__[/Users/ap13/perl5/lib/perl5/Graph.pm:2741] which was called 2 times, avg 8µs/call:
# 2 times (16µs+0s) by Graph::Traversal::next at line 324 of Graph/Traversal.pm, avg 8µs/call | ||||
2740 | 2 | 19µs | (each %r)[1]; | ||
2741 | }; | ||||
2742 | # spent 184µs within Graph::__ANON__[/Users/ap13/perl5/lib/perl5/Graph.pm:2745] which was called 36 times, avg 5µs/call:
# 36 times (184µs+0s) by Graph::Traversal::next at line 332 of Graph/Traversal.pm, avg 5µs/call | ||||
2743 | 72 | 216µs | $cc++ if keys %r; | ||
2744 | (each %r)[1]; | ||||
2745 | }; | ||||
2746 | my $t = Graph::Traversal::DFS->new($g, | ||||
2747 | first_root => $froot, | ||||
2748 | next_root => $nroot, | ||||
2749 | # spent 18.7ms within Graph::__ANON__[/Users/ap13/perl5/lib/perl5/Graph.pm:2754] which was called 4991 times, avg 4µs/call:
# 4991 times (18.7ms+0s) by Graph::Traversal::visit at line 193 of Graph/Traversal.pm, avg 4µs/call | ||||
2750 | 19964 | 20.6ms | my ($v, $t) = @_; | ||
2751 | $cce{ $v } = $cc; | ||||
2752 | push @{ $cci{ $cc } }, $v; | ||||
2753 | delete $r{ $v }; | ||||
2754 | }, | ||||
2755 | 2 | 18.6ms | @_); # spent 18.6ms making 2 calls to Graph::Traversal::new, avg 9.32ms/call | ||
2756 | 2 | 1.35s | $t->dfs; # spent 1.35s making 2 calls to Graph::Traversal::postorder, avg 673ms/call | ||
2757 | } | ||||
2758 | return [ \%cce, \%cci ]; | ||||
2759 | } | ||||
2760 | |||||
2761 | # spent 1.40s (30µs+1.40) within Graph::_connected_components which was called 2 times, avg 701ms/call:
# 2 times (30µs+1.40s) by Graph::connected_components at line 2785, avg 701ms/call | ||||
2762 | 6 | 30µs | my $g = shift; | ||
2763 | 2 | 1.40s | my $ccc = _check_cache($g, 'connectivity', # spent 1.40s making 2 calls to Graph::_check_cache, avg 701ms/call | ||
2764 | \&_connected_components_compute, @_); | ||||
2765 | return @{ $ccc }; | ||||
2766 | } | ||||
2767 | |||||
2768 | sub connected_component_by_vertex { | ||||
2769 | my ($g, $v) = @_; | ||||
2770 | $g->expect_undirected; | ||||
2771 | my ($CCE, $CCI) = $g->_connected_components(); | ||||
2772 | return $CCE->{ $v }; | ||||
2773 | } | ||||
2774 | |||||
2775 | sub connected_component_by_index { | ||||
2776 | my ($g, $i) = @_; | ||||
2777 | $g->expect_undirected; | ||||
2778 | my ($CCE, $CCI) = $g->_connected_components(); | ||||
2779 | return defined $CCI->{ $i } ? @{ $CCI->{ $i } } : ( ); | ||||
2780 | } | ||||
2781 | |||||
2782 | # spent 1.40s (61µs+1.40) within Graph::connected_components which was called 2 times, avg 701ms/call:
# once (21µs+1.37s) by Bio::Roary::OrderGenes::_build_groups_to_contigs at line 232 of lib/Bio/Roary/OrderGenes.pm
# once (39µs+34.7ms) by Bio::Roary::OrderGenes::_build_groups_to_contigs at line 213 of lib/Bio/Roary/OrderGenes.pm | ||||
2783 | 8 | 50µs | my $g = shift; | ||
2784 | 2 | 46µs | $g->expect_undirected; # spent 46µs making 2 calls to Graph::expect_undirected, avg 23µs/call | ||
2785 | 2 | 1.40s | my ($CCE, $CCI) = $g->_connected_components(); # spent 1.40s making 2 calls to Graph::_connected_components, avg 701ms/call | ||
2786 | return values %{ $CCI }; | ||||
2787 | } | ||||
2788 | |||||
2789 | sub same_connected_components { | ||||
2790 | my $g = shift; | ||||
2791 | $g->expect_undirected; | ||||
2792 | if ($g->has_union_find) { | ||||
2793 | my $UF = $g->_get_union_find(); | ||||
2794 | my $V = $g->[ _V ]; | ||||
2795 | my $u = shift; | ||||
2796 | my $c = $UF->find( $V->_get_path_id ( $u ) ); | ||||
2797 | my $d; | ||||
2798 | for my $v ( @_) { | ||||
2799 | return 0 | ||||
2800 | unless defined($d = $UF->find( $V->_get_path_id( $v ) )) && | ||||
2801 | $d eq $c; | ||||
2802 | } | ||||
2803 | return 1; | ||||
2804 | } else { | ||||
2805 | my ($CCE, $CCI) = $g->_connected_components(); | ||||
2806 | my $u = shift; | ||||
2807 | my $c = $CCE->{ $u }; | ||||
2808 | for my $v ( @_ ) { | ||||
2809 | return 0 | ||||
2810 | unless defined $CCE->{ $v } && | ||||
2811 | $CCE->{ $v } eq $c; | ||||
2812 | } | ||||
2813 | return 1; | ||||
2814 | } | ||||
2815 | } | ||||
2816 | |||||
2817 | 1 | 2µs | my $super_component = sub { join("+", sort @_) }; | ||
2818 | |||||
2819 | sub connected_graph { | ||||
2820 | my ($g, %opt) = @_; | ||||
2821 | $g->expect_undirected; | ||||
2822 | my $cg = Graph->new(undirected => 1); | ||||
2823 | if ($g->has_union_find && $g->vertices == 1) { | ||||
2824 | # TODO: super_component? | ||||
2825 | $cg->add_vertices($g->vertices); | ||||
2826 | } else { | ||||
2827 | my $sc_cb = | ||||
2828 | exists $opt{super_component} ? | ||||
2829 | $opt{super_component} : $super_component; | ||||
2830 | for my $cc ( $g->connected_components() ) { | ||||
2831 | my $sc = $sc_cb->(@$cc); | ||||
2832 | $cg->add_vertex($sc); | ||||
2833 | $cg->set_vertex_attribute($sc, 'subvertices', [ @$cc ]); | ||||
2834 | } | ||||
2835 | } | ||||
2836 | return $cg; | ||||
2837 | } | ||||
2838 | |||||
2839 | sub is_connected { | ||||
2840 | my $g = shift; | ||||
2841 | $g->expect_undirected; | ||||
2842 | my ($CCE, $CCI) = $g->_connected_components(); | ||||
2843 | return keys %{ $CCI } == 1; | ||||
2844 | } | ||||
2845 | |||||
2846 | sub is_weakly_connected { | ||||
2847 | my $g = shift; | ||||
2848 | $g->expect_directed; | ||||
2849 | $g->undirected_copy->is_connected(@_); | ||||
2850 | } | ||||
2851 | |||||
2852 | 1 | 2µs | *weakly_connected = \&is_weakly_connected; | ||
2853 | |||||
2854 | sub weakly_connected_components { | ||||
2855 | my $g = shift; | ||||
2856 | $g->expect_directed; | ||||
2857 | $g->undirected_copy->connected_components(@_); | ||||
2858 | } | ||||
2859 | |||||
2860 | sub weakly_connected_component_by_vertex { | ||||
2861 | my $g = shift; | ||||
2862 | $g->expect_directed; | ||||
2863 | $g->undirected_copy->connected_component_by_vertex(@_); | ||||
2864 | } | ||||
2865 | |||||
2866 | sub weakly_connected_component_by_index { | ||||
2867 | my $g = shift; | ||||
2868 | $g->expect_directed; | ||||
2869 | $g->undirected_copy->connected_component_by_index(@_); | ||||
2870 | } | ||||
2871 | |||||
2872 | sub same_weakly_connected_components { | ||||
2873 | my $g = shift; | ||||
2874 | $g->expect_directed; | ||||
2875 | $g->undirected_copy->same_connected_components(@_); | ||||
2876 | } | ||||
2877 | |||||
2878 | sub weakly_connected_graph { | ||||
2879 | my $g = shift; | ||||
2880 | $g->expect_directed; | ||||
2881 | $g->undirected_copy->connected_graph(@_); | ||||
2882 | } | ||||
2883 | |||||
2884 | sub _strongly_connected_components_compute { | ||||
2885 | my $g = shift; | ||||
2886 | my $t = Graph::Traversal::DFS->new($g); | ||||
2887 | my @d = reverse $t->dfs; | ||||
2888 | my @c; | ||||
2889 | my $h = $g->transpose_graph; | ||||
2890 | my $u = | ||||
2891 | Graph::Traversal::DFS->new($h, | ||||
2892 | next_root => sub { | ||||
2893 | my ($t, $u) = @_; | ||||
2894 | my $root; | ||||
2895 | while (defined($root = shift @d)) { | ||||
2896 | last if exists $u->{ $root }; | ||||
2897 | } | ||||
2898 | if (defined $root) { | ||||
2899 | push @c, []; | ||||
2900 | return $root; | ||||
2901 | } else { | ||||
2902 | return; | ||||
2903 | } | ||||
2904 | }, | ||||
2905 | pre => sub { | ||||
2906 | my ($v, $t) = @_; | ||||
2907 | push @{ $c[-1] }, $v; | ||||
2908 | }, | ||||
2909 | @_); | ||||
2910 | $u->dfs; | ||||
2911 | return \@c; | ||||
2912 | } | ||||
2913 | |||||
2914 | sub _strongly_connected_components { | ||||
2915 | my $g = shift; | ||||
2916 | my $type = 'strong_connectivity'; | ||||
2917 | my $scc = _check_cache($g, $type, | ||||
2918 | \&_strongly_connected_components_compute, @_); | ||||
2919 | return defined $scc ? @$scc : ( ); | ||||
2920 | } | ||||
2921 | |||||
2922 | sub strongly_connected_components { | ||||
2923 | my $g = shift; | ||||
2924 | $g->expect_directed; | ||||
2925 | $g->_strongly_connected_components(@_); | ||||
2926 | } | ||||
2927 | |||||
2928 | sub strongly_connected_component_by_vertex { | ||||
2929 | my $g = shift; | ||||
2930 | my $v = shift; | ||||
2931 | $g->expect_directed; | ||||
2932 | my @scc = $g->_strongly_connected_components( next_alphabetic => 1, @_ ); | ||||
2933 | for (my $i = 0; $i <= $#scc; $i++) { | ||||
2934 | for (my $j = 0; $j <= $#{ $scc[$i] }; $j++) { | ||||
2935 | return $i if $scc[$i]->[$j] eq $v; | ||||
2936 | } | ||||
2937 | } | ||||
2938 | return; | ||||
2939 | } | ||||
2940 | |||||
2941 | sub strongly_connected_component_by_index { | ||||
2942 | my $g = shift; | ||||
2943 | my $i = shift; | ||||
2944 | $g->expect_directed; | ||||
2945 | my $c = ( $g->_strongly_connected_components(@_) )[ $i ]; | ||||
2946 | return defined $c ? @{ $c } : (); | ||||
2947 | } | ||||
2948 | |||||
2949 | sub same_strongly_connected_components { | ||||
2950 | my $g = shift; | ||||
2951 | $g->expect_directed; | ||||
2952 | my @scc = $g->_strongly_connected_components( next_alphabetic => 1, @_ ); | ||||
2953 | my @i; | ||||
2954 | while (@_) { | ||||
2955 | my $v = shift; | ||||
2956 | for (my $i = 0; $i <= $#scc; $i++) { | ||||
2957 | for (my $j = 0; $j <= $#{ $scc[$i] }; $j++) { | ||||
2958 | if ($scc[$i]->[$j] eq $v) { | ||||
2959 | push @i, $i; | ||||
2960 | return 0 if @i > 1 && $i[-1] ne $i[0]; | ||||
2961 | } | ||||
2962 | } | ||||
2963 | } | ||||
2964 | } | ||||
2965 | return 1; | ||||
2966 | } | ||||
2967 | |||||
2968 | sub is_strongly_connected { | ||||
2969 | my $g = shift; | ||||
2970 | $g->expect_directed; | ||||
2971 | my $t = Graph::Traversal::DFS->new($g); | ||||
2972 | my @d = reverse $t->dfs; | ||||
2973 | my @c; | ||||
2974 | my $h = $g->transpose; | ||||
2975 | my $u = | ||||
2976 | Graph::Traversal::DFS->new($h, | ||||
2977 | next_root => sub { | ||||
2978 | my ($t, $u) = @_; | ||||
2979 | my $root; | ||||
2980 | while (defined($root = shift @d)) { | ||||
2981 | last if exists $u->{ $root }; | ||||
2982 | } | ||||
2983 | if (defined $root) { | ||||
2984 | unless (@{ $t->{ roots } }) { | ||||
2985 | push @c, []; | ||||
2986 | return $root; | ||||
2987 | } else { | ||||
2988 | $t->terminate; | ||||
2989 | return; | ||||
2990 | } | ||||
2991 | } else { | ||||
2992 | return; | ||||
2993 | } | ||||
2994 | }, | ||||
2995 | pre => sub { | ||||
2996 | my ($v, $t) = @_; | ||||
2997 | push @{ $c[-1] }, $v; | ||||
2998 | }, | ||||
2999 | @_); | ||||
3000 | $u->dfs; | ||||
3001 | return @{ $u->{ roots } } == 1 && keys %{ $u->{ unseen } } == 0; | ||||
3002 | } | ||||
3003 | |||||
3004 | 1 | 2µs | *strongly_connected = \&is_strongly_connected; | ||
3005 | |||||
3006 | sub strongly_connected_graph { | ||||
3007 | my $g = shift; | ||||
3008 | my %attr = @_; | ||||
3009 | |||||
3010 | $g->expect_directed; | ||||
3011 | |||||
3012 | my $t = Graph::Traversal::DFS->new($g); | ||||
3013 | my @d = reverse $t->dfs; | ||||
3014 | my @c; | ||||
3015 | my $h = $g->transpose; | ||||
3016 | my $u = | ||||
3017 | Graph::Traversal::DFS->new($h, | ||||
3018 | next_root => sub { | ||||
3019 | my ($t, $u) = @_; | ||||
3020 | my $root; | ||||
3021 | while (defined($root = shift @d)) { | ||||
3022 | last if exists $u->{ $root }; | ||||
3023 | } | ||||
3024 | if (defined $root) { | ||||
3025 | push @c, []; | ||||
3026 | return $root; | ||||
3027 | } else { | ||||
3028 | return; | ||||
3029 | } | ||||
3030 | }, | ||||
3031 | pre => sub { | ||||
3032 | my ($v, $t) = @_; | ||||
3033 | push @{ $c[-1] }, $v; | ||||
3034 | } | ||||
3035 | ); | ||||
3036 | |||||
3037 | $u->dfs; | ||||
3038 | |||||
3039 | my $sc_cb; | ||||
3040 | my $hv_cb; | ||||
3041 | |||||
3042 | _opt_get(\%attr, super_component => \$sc_cb); | ||||
3043 | _opt_get(\%attr, hypervertex => \$hv_cb); | ||||
3044 | _opt_unknown(\%attr); | ||||
3045 | |||||
3046 | if (defined $hv_cb && !defined $sc_cb) { | ||||
3047 | $sc_cb = sub { $hv_cb->( [ @_ ] ) }; | ||||
3048 | } | ||||
3049 | unless (defined $sc_cb) { | ||||
3050 | $sc_cb = $super_component; | ||||
3051 | } | ||||
3052 | |||||
3053 | my $s = Graph->new; | ||||
3054 | |||||
3055 | my %c; | ||||
3056 | my @s; | ||||
3057 | for (my $i = 0; $i < @c; $i++) { | ||||
3058 | my $c = $c[$i]; | ||||
3059 | $s->add_vertex( $s[$i] = $sc_cb->(@$c) ); | ||||
3060 | $s->set_vertex_attribute($s[$i], 'subvertices', [ @$c ]); | ||||
3061 | for my $v (@$c) { | ||||
3062 | $c{$v} = $i; | ||||
3063 | } | ||||
3064 | } | ||||
3065 | |||||
3066 | my $n = @c; | ||||
3067 | for my $v ($g->vertices) { | ||||
3068 | unless (exists $c{$v}) { | ||||
3069 | $c{$v} = $n; | ||||
3070 | $s[$n] = $v; | ||||
3071 | $n++; | ||||
3072 | } | ||||
3073 | } | ||||
3074 | |||||
3075 | for my $e ($g->edges05) { | ||||
3076 | my ($u, $v) = @$e; # @TODO: hyperedges | ||||
3077 | unless ($c{$u} == $c{$v}) { | ||||
3078 | my ($p, $q) = ( $s[ $c{ $u } ], $s[ $c{ $v } ] ); | ||||
3079 | $s->add_edge($p, $q) unless $s->has_edge($p, $q); | ||||
3080 | } | ||||
3081 | } | ||||
3082 | |||||
3083 | if (my @i = $g->isolated_vertices) { | ||||
3084 | $s->add_vertices(map { $s[ $c{ $_ } ] } @i); | ||||
3085 | } | ||||
3086 | |||||
3087 | return $s; | ||||
3088 | } | ||||
3089 | |||||
3090 | ### | ||||
3091 | # Biconnectivity. | ||||
3092 | # | ||||
3093 | |||||
3094 | sub _biconnectivity_out { | ||||
3095 | my ($state, $u, $v) = @_; | ||||
3096 | if (exists $state->{stack}) { | ||||
3097 | my @BC; | ||||
3098 | while (@{$state->{stack}}) { | ||||
3099 | my $e = pop @{$state->{stack}}; | ||||
3100 | push @BC, $e; | ||||
3101 | last if defined $u && $e->[0] eq $u && $e->[1] eq $v; | ||||
3102 | } | ||||
3103 | if (@BC) { | ||||
3104 | push @{$state->{BC}}, \@BC; | ||||
3105 | } | ||||
3106 | } | ||||
3107 | } | ||||
3108 | |||||
3109 | sub _biconnectivity_dfs { | ||||
3110 | my ($g, $u, $state) = @_; | ||||
3111 | $state->{num}->{$u} = $state->{dfs}++; | ||||
3112 | $state->{low}->{$u} = $state->{num}->{$u}; | ||||
3113 | for my $v ($g->successors($u)) { | ||||
3114 | unless (exists $state->{num}->{$v}) { | ||||
3115 | push @{$state->{stack}}, [$u, $v]; | ||||
3116 | $state->{pred}->{$v} = $u; | ||||
3117 | $state->{succ}->{$u}->{$v}++; | ||||
3118 | _biconnectivity_dfs($g, $v, $state); | ||||
3119 | if ($state->{low}->{$v} < $state->{low}->{$u}) { | ||||
3120 | $state->{low}->{$u} = $state->{low}->{$v}; | ||||
3121 | } | ||||
3122 | if ($state->{low}->{$v} >= $state->{num}->{$u}) { | ||||
3123 | _biconnectivity_out($state, $u, $v); | ||||
3124 | } | ||||
3125 | } elsif (defined $state->{pred}->{$u} && | ||||
3126 | $state->{pred}->{$u} ne $v && | ||||
3127 | $state->{num}->{$v} < $state->{num}->{$u}) { | ||||
3128 | push @{$state->{stack}}, [$u, $v]; | ||||
3129 | if ($state->{num}->{$v} < $state->{low}->{$u}) { | ||||
3130 | $state->{low}->{$u} = $state->{num}->{$v}; | ||||
3131 | } | ||||
3132 | } | ||||
3133 | } | ||||
3134 | } | ||||
3135 | |||||
3136 | sub _biconnectivity_compute { | ||||
3137 | my ($g) = @_; | ||||
3138 | my %state; | ||||
3139 | @{$state{BC}} = (); | ||||
3140 | @{$state{BR}} = (); | ||||
3141 | %{$state{V2BC}} = (); | ||||
3142 | %{$state{BC2V}} = (); | ||||
3143 | @{$state{AP}} = (); | ||||
3144 | $state{dfs} = 0; | ||||
3145 | my @u = _shuffle $g->vertices; | ||||
3146 | for my $u (@u) { | ||||
3147 | unless (exists $state{num}->{$u}) { | ||||
3148 | _biconnectivity_dfs($g, $u, \%state); | ||||
3149 | _biconnectivity_out(\%state); | ||||
3150 | delete $state{stack}; | ||||
3151 | } | ||||
3152 | } | ||||
3153 | |||||
3154 | # Mark the components each vertex belongs to. | ||||
3155 | my $bci = 0; | ||||
3156 | for my $bc (@{$state{BC}}) { | ||||
3157 | for my $e (@$bc) { | ||||
3158 | for my $v (@$e) { | ||||
3159 | $state{V2BC}->{$v}->{$bci}++; | ||||
3160 | } | ||||
3161 | } | ||||
3162 | $bci++; | ||||
3163 | } | ||||
3164 | |||||
3165 | # Any isolated vertices get each their own component. | ||||
3166 | for my $v ($g->vertices) { | ||||
3167 | unless (exists $state{V2BC}->{$v}) { | ||||
3168 | $state{V2BC}->{$v}->{$bci++}++; | ||||
3169 | } | ||||
3170 | } | ||||
3171 | |||||
3172 | for my $v ($g->vertices) { | ||||
3173 | for my $bc (keys %{$state{V2BC}->{$v}}) { | ||||
3174 | $state{BC2V}->{$bc}->{$v}->{$bc}++; | ||||
3175 | } | ||||
3176 | } | ||||
3177 | |||||
3178 | # Articulation points / cut vertices are the vertices | ||||
3179 | # which belong to more than one component. | ||||
3180 | for my $v (keys %{$state{V2BC}}) { | ||||
3181 | if (keys %{$state{V2BC}->{$v}} > 1) { | ||||
3182 | push @{$state{AP}}, $v; | ||||
3183 | } | ||||
3184 | } | ||||
3185 | |||||
3186 | # Bridges / cut edges are the components of two vertices. | ||||
3187 | for my $v (keys %{$state{BC2V}}) { | ||||
3188 | my @v = keys %{$state{BC2V}->{$v}}; | ||||
3189 | if (@v == 2) { | ||||
3190 | push @{$state{BR}}, \@v; | ||||
3191 | } | ||||
3192 | } | ||||
3193 | |||||
3194 | # Create the subgraph components. | ||||
3195 | my @sg; | ||||
3196 | for my $bc (@{$state{BC}}) { | ||||
3197 | my %v; | ||||
3198 | my $w = Graph::Undirected->new(); | ||||
3199 | for my $e (@$bc) { | ||||
3200 | my ($u, $v) = @$e; | ||||
3201 | $v{$u}++; | ||||
3202 | $v{$v}++; | ||||
3203 | $w->add_edge($u, $v); | ||||
3204 | } | ||||
3205 | push @sg, [ keys %v ]; | ||||
3206 | } | ||||
3207 | |||||
3208 | return [ $state{AP}, \@sg, $state{BR}, $state{V2BC}, ]; | ||||
3209 | } | ||||
3210 | |||||
3211 | sub biconnectivity { | ||||
3212 | my $g = shift; | ||||
3213 | $g->expect_undirected; | ||||
3214 | my $bcc = _check_cache($g, 'biconnectivity', | ||||
3215 | \&_biconnectivity_compute, @_); | ||||
3216 | return defined $bcc ? @$bcc : ( ); | ||||
3217 | } | ||||
3218 | |||||
3219 | sub is_biconnected { | ||||
3220 | my $g = shift; | ||||
3221 | my ($ap) = ($g->biconnectivity(@_))[0]; | ||||
3222 | return $g->edges >= 2 ? @$ap == 0 : undef ; | ||||
3223 | } | ||||
3224 | |||||
3225 | sub is_edge_connected { | ||||
3226 | my $g = shift; | ||||
3227 | my ($br) = ($g->biconnectivity(@_))[2]; | ||||
3228 | return $g->edges >= 2 ? @$br == 0 : undef; | ||||
3229 | } | ||||
3230 | |||||
3231 | sub is_edge_separable { | ||||
3232 | my $g = shift; | ||||
3233 | my ($br) = ($g->biconnectivity(@_))[2]; | ||||
3234 | return $g->edges >= 2 ? @$br > 0 : undef; | ||||
3235 | } | ||||
3236 | |||||
3237 | sub articulation_points { | ||||
3238 | my $g = shift; | ||||
3239 | my ($ap) = ($g->biconnectivity(@_))[0]; | ||||
3240 | return @$ap; | ||||
3241 | } | ||||
3242 | |||||
3243 | 1 | 2µs | *cut_vertices = \&articulation_points; | ||
3244 | |||||
3245 | sub biconnected_components { | ||||
3246 | my $g = shift; | ||||
3247 | my ($bc) = ($g->biconnectivity(@_))[1]; | ||||
3248 | return @$bc; | ||||
3249 | } | ||||
3250 | |||||
3251 | sub biconnected_component_by_index { | ||||
3252 | my $g = shift; | ||||
3253 | my $i = shift; | ||||
3254 | my ($bc) = ($g->biconnectivity(@_))[1]; | ||||
3255 | return $bc->[ $i ]; | ||||
3256 | } | ||||
3257 | |||||
3258 | sub biconnected_component_by_vertex { | ||||
3259 | my $g = shift; | ||||
3260 | my $v = shift; | ||||
3261 | my ($v2bc) = ($g->biconnectivity(@_))[3]; | ||||
3262 | return defined $v2bc->{ $v } ? keys %{ $v2bc->{ $v } } : (); | ||||
3263 | } | ||||
3264 | |||||
3265 | sub same_biconnected_components { | ||||
3266 | my $g = shift; | ||||
3267 | my $u = shift; | ||||
3268 | my @u = $g->biconnected_component_by_vertex($u, @_); | ||||
3269 | return 0 unless @u; | ||||
3270 | my %ubc; @ubc{ @u } = (); | ||||
3271 | while (@_) { | ||||
3272 | my $v = shift; | ||||
3273 | my @v = $g->biconnected_component_by_vertex($v); | ||||
3274 | if (@v) { | ||||
3275 | my %vbc; @vbc{ @v } = (); | ||||
3276 | my $vi; | ||||
3277 | for my $ui (keys %ubc) { | ||||
3278 | if (exists $vbc{ $ui }) { | ||||
3279 | $vi = $ui; | ||||
3280 | last; | ||||
3281 | } | ||||
3282 | } | ||||
3283 | return 0 unless defined $vi; | ||||
3284 | } | ||||
3285 | } | ||||
3286 | return 1; | ||||
3287 | } | ||||
3288 | |||||
3289 | sub biconnected_graph { | ||||
3290 | my ($g, %opt) = @_; | ||||
3291 | my ($bc, $v2bc) = ($g->biconnectivity, %opt)[1, 3]; | ||||
3292 | my $bcg = Graph::Undirected->new; | ||||
3293 | my $sc_cb = | ||||
3294 | exists $opt{super_component} ? | ||||
3295 | $opt{super_component} : $super_component; | ||||
3296 | for my $c (@$bc) { | ||||
3297 | $bcg->add_vertex(my $s = $sc_cb->(@$c)); | ||||
3298 | $bcg->set_vertex_attribute($s, 'subvertices', [ @$c ]); | ||||
3299 | } | ||||
3300 | my %k; | ||||
3301 | for my $i (0..$#$bc) { | ||||
3302 | my @u = @{ $bc->[ $i ] }; | ||||
3303 | my %i; @i{ @u } = (); | ||||
3304 | for my $j (0..$#$bc) { | ||||
3305 | if ($i > $j) { | ||||
3306 | my @v = @{ $bc->[ $j ] }; | ||||
3307 | my %j; @j{ @v } = (); | ||||
3308 | for my $u (@u) { | ||||
3309 | if (exists $j{ $u }) { | ||||
3310 | unless ($k{ $i }{ $j }++) { | ||||
3311 | $bcg->add_edge($sc_cb->(@{$bc->[$i]}), | ||||
3312 | $sc_cb->(@{$bc->[$j]})); | ||||
3313 | } | ||||
3314 | last; | ||||
3315 | } | ||||
3316 | } | ||||
3317 | } | ||||
3318 | } | ||||
3319 | } | ||||
3320 | return $bcg; | ||||
3321 | } | ||||
3322 | |||||
3323 | sub bridges { | ||||
3324 | my $g = shift; | ||||
3325 | my ($br) = ($g->biconnectivity(@_))[2]; | ||||
3326 | return defined $br ? @$br : (); | ||||
3327 | } | ||||
3328 | |||||
3329 | ### | ||||
3330 | # SPT. | ||||
3331 | # | ||||
3332 | |||||
3333 | sub _SPT_add { | ||||
3334 | my ($g, $h, $HF, $r, $attr, $unseen, $etc) = @_; | ||||
3335 | my $etc_r = $etc->{ $r } || 0; | ||||
3336 | for my $s ( grep { exists $unseen->{ $_ } } $g->successors( $r ) ) { | ||||
3337 | my $t = $g->get_edge_attribute( $r, $s, $attr ); | ||||
3338 | $t = 1 unless defined $t; | ||||
3339 | if ($t < 0) { | ||||
3340 | require Carp; | ||||
3341 | Carp::croak("Graph::SPT_Dijkstra: edge $r-$s is negative ($t)"); | ||||
3342 | } | ||||
3343 | if (!defined($etc->{ $s }) || ($etc_r + $t) < $etc->{ $s }) { | ||||
3344 | my $etc_s = $etc->{ $s } || 0; | ||||
3345 | $etc->{ $s } = $etc_r + $t; | ||||
3346 | # print "$r - $s : setting $s to $etc->{ $s } ($etc_r, $etc_s)\n"; | ||||
3347 | $h->set_vertex_attribute( $s, $attr, $etc->{ $s }); | ||||
3348 | $h->set_vertex_attribute( $s, 'p', $r ); | ||||
3349 | $HF->add( Graph::SPTHeapElem->new($r, $s, $etc->{ $s }) ); | ||||
3350 | } | ||||
3351 | } | ||||
3352 | } | ||||
3353 | |||||
3354 | sub _SPT_Dijkstra_compute { | ||||
3355 | } | ||||
3356 | |||||
3357 | sub SPT_Dijkstra { | ||||
3358 | my $g = shift; | ||||
3359 | my %opt = @_ == 1 ? (first_root => $_[0]) : @_; | ||||
3360 | my $first_root = $opt{ first_root }; | ||||
3361 | unless (defined $first_root) { | ||||
3362 | $opt{ first_root } = $first_root = $g->random_vertex(); | ||||
3363 | } | ||||
3364 | my $spt_di = $g->get_graph_attribute('_spt_di'); | ||||
3365 | unless (defined $spt_di && exists $spt_di->{ $first_root } && $spt_di->{ $first_root }->[ 0 ] == $g->[ _G ]) { | ||||
3366 | my %etc; | ||||
3367 | my $sptg = $g->_heap_walk($g->new, \&_SPT_add, \%etc, %opt); | ||||
3368 | $spt_di->{ $first_root } = [ $g->[ _G ], $sptg ]; | ||||
3369 | $g->set_graph_attribute('_spt_di', $spt_di); | ||||
3370 | } | ||||
3371 | |||||
3372 | my $spt = $spt_di->{ $first_root }->[ 1 ]; | ||||
3373 | |||||
3374 | $spt->set_graph_attribute('SPT_Dijkstra_root', $first_root); | ||||
3375 | |||||
3376 | return $spt; | ||||
3377 | } | ||||
3378 | |||||
3379 | 1 | 2µs | *SSSP_Dijkstra = \&SPT_Dijkstra; | ||
3380 | |||||
3381 | 1 | 1µs | *single_source_shortest_paths = \&SPT_Dijkstra; | ||
3382 | |||||
3383 | sub SP_Dijkstra { | ||||
3384 | my ($g, $u, $v) = @_; | ||||
3385 | my $sptg = $g->SPT_Dijkstra(first_root => $u); | ||||
3386 | my @path = ($v); | ||||
3387 | my %seen; | ||||
3388 | my $V = $g->vertices; | ||||
3389 | my $p; | ||||
3390 | while (defined($p = $sptg->get_vertex_attribute($v, 'p'))) { | ||||
3391 | last if exists $seen{$p}; | ||||
3392 | push @path, $p; | ||||
3393 | $v = $p; | ||||
3394 | $seen{$p}++; | ||||
3395 | last if keys %seen == $V || $u eq $v; | ||||
3396 | } | ||||
3397 | @path = () if @path && $path[-1] ne $u; | ||||
3398 | return reverse @path; | ||||
3399 | } | ||||
3400 | |||||
3401 | sub __SPT_Bellman_Ford { | ||||
3402 | my ($g, $u, $v, $attr, $d, $p, $c0, $c1) = @_; | ||||
3403 | return unless $c0->{ $u }; | ||||
3404 | my $w = $g->get_edge_attribute($u, $v, $attr); | ||||
3405 | $w = 1 unless defined $w; | ||||
3406 | if (defined $d->{ $v }) { | ||||
3407 | if (defined $d->{ $u }) { | ||||
3408 | if ($d->{ $v } > $d->{ $u } + $w) { | ||||
3409 | $d->{ $v } = $d->{ $u } + $w; | ||||
3410 | $p->{ $v } = $u; | ||||
3411 | $c1->{ $v }++; | ||||
3412 | } | ||||
3413 | } # else !defined $d->{ $u } && defined $d->{ $v } | ||||
3414 | } else { | ||||
3415 | if (defined $d->{ $u }) { | ||||
3416 | # defined $d->{ $u } && !defined $d->{ $v } | ||||
3417 | $d->{ $v } = $d->{ $u } + $w; | ||||
3418 | $p->{ $v } = $u; | ||||
3419 | $c1->{ $v }++; | ||||
3420 | } # else !defined $d->{ $u } && !defined $d->{ $v } | ||||
3421 | } | ||||
3422 | } | ||||
3423 | |||||
3424 | sub _SPT_Bellman_Ford { | ||||
3425 | my ($g, $opt, $unseenh, $unseena, $r, $next, $code, $attr) = @_; | ||||
3426 | my %d; | ||||
3427 | return unless defined $r; | ||||
3428 | $d{ $r } = 0; | ||||
3429 | my %p; | ||||
3430 | my $V = $g->vertices; | ||||
3431 | my %c0; # Changed during the last iteration? | ||||
3432 | $c0{ $r }++; | ||||
3433 | for (my $i = 0; $i < $V; $i++) { | ||||
3434 | my %c1; | ||||
3435 | for my $e ($g->edges) { | ||||
3436 | my ($u, $v) = @$e; | ||||
3437 | __SPT_Bellman_Ford($g, $u, $v, $attr, \%d, \%p, \%c0, \%c1); | ||||
3438 | if ($g->undirected) { | ||||
3439 | __SPT_Bellman_Ford($g, $v, $u, $attr, \%d, \%p, \%c0, \%c1); | ||||
3440 | } | ||||
3441 | } | ||||
3442 | %c0 = %c1 unless $i == $V - 1; | ||||
3443 | } | ||||
3444 | |||||
3445 | for my $e ($g->edges) { | ||||
3446 | my ($u, $v) = @$e; | ||||
3447 | if (defined $d{ $u } && defined $d{ $v }) { | ||||
3448 | my $d = $g->get_edge_attribute($u, $v, $attr); | ||||
3449 | if (defined $d && $d{ $v } > $d{ $u } + $d) { | ||||
3450 | require Carp; | ||||
3451 | Carp::croak("Graph::SPT_Bellman_Ford: negative cycle exists"); | ||||
3452 | } | ||||
3453 | } | ||||
3454 | } | ||||
3455 | |||||
3456 | return (\%p, \%d); | ||||
3457 | } | ||||
3458 | |||||
3459 | sub _SPT_Bellman_Ford_compute { | ||||
3460 | } | ||||
3461 | |||||
3462 | sub SPT_Bellman_Ford { | ||||
3463 | my $g = shift; | ||||
3464 | |||||
3465 | my ($opt, $unseenh, $unseena, $r, $next, $code, $attr) = $g->_root_opt(@_); | ||||
3466 | |||||
3467 | unless (defined $r) { | ||||
3468 | $r = $g->random_vertex(); | ||||
3469 | return unless defined $r; | ||||
3470 | } | ||||
3471 | |||||
3472 | my $spt_bf = $g->get_graph_attribute('_spt_bf'); | ||||
3473 | unless (defined $spt_bf && | ||||
3474 | exists $spt_bf->{ $r } && $spt_bf->{ $r }->[ 0 ] == $g->[ _G ]) { | ||||
3475 | my ($p, $d) = | ||||
3476 | $g->_SPT_Bellman_Ford($opt, $unseenh, $unseena, | ||||
3477 | $r, $next, $code, $attr); | ||||
3478 | my $h = $g->new; | ||||
3479 | for my $v (keys %$p) { | ||||
3480 | my $u = $p->{ $v }; | ||||
3481 | $h->add_edge( $u, $v ); | ||||
3482 | $h->set_edge_attribute( $u, $v, $attr, | ||||
3483 | $g->get_edge_attribute($u, $v, $attr)); | ||||
3484 | $h->set_vertex_attribute( $v, $attr, $d->{ $v } ); | ||||
3485 | $h->set_vertex_attribute( $v, 'p', $u ); | ||||
3486 | } | ||||
3487 | $spt_bf->{ $r } = [ $g->[ _G ], $h ]; | ||||
3488 | $g->set_graph_attribute('_spt_bf', $spt_bf); | ||||
3489 | } | ||||
3490 | |||||
3491 | my $spt = $spt_bf->{ $r }->[ 1 ]; | ||||
3492 | |||||
3493 | $spt->set_graph_attribute('SPT_Bellman_Ford_root', $r); | ||||
3494 | |||||
3495 | return $spt; | ||||
3496 | } | ||||
3497 | |||||
3498 | 1 | 2µs | *SSSP_Bellman_Ford = \&SPT_Bellman_Ford; | ||
3499 | |||||
3500 | sub SP_Bellman_Ford { | ||||
3501 | my ($g, $u, $v) = @_; | ||||
3502 | my $sptg = $g->SPT_Bellman_Ford(first_root => $u); | ||||
3503 | my @path = ($v); | ||||
3504 | my %seen; | ||||
3505 | my $V = $g->vertices; | ||||
3506 | my $p; | ||||
3507 | while (defined($p = $sptg->get_vertex_attribute($v, 'p'))) { | ||||
3508 | last if exists $seen{$p}; | ||||
3509 | push @path, $p; | ||||
3510 | $v = $p; | ||||
3511 | $seen{$p}++; | ||||
3512 | last if keys %seen == $V; | ||||
3513 | } | ||||
3514 | # @path = () if @path && "$path[-1]" ne "$u"; | ||||
3515 | return reverse @path; | ||||
3516 | } | ||||
3517 | |||||
3518 | ### | ||||
3519 | # Transitive Closure. | ||||
3520 | # | ||||
3521 | |||||
3522 | sub TransitiveClosure_Floyd_Warshall { | ||||
3523 | my $self = shift; | ||||
3524 | my $class = ref $self || $self; | ||||
3525 | $self = shift unless ref $self; | ||||
3526 | bless Graph::TransitiveClosure->new($self, @_), $class; | ||||
3527 | } | ||||
3528 | |||||
3529 | 1 | 2µs | *transitive_closure = \&TransitiveClosure_Floyd_Warshall; | ||
3530 | |||||
3531 | sub APSP_Floyd_Warshall { | ||||
3532 | my $self = shift; | ||||
3533 | my $class = ref $self || $self; | ||||
3534 | $self = shift unless ref $self; | ||||
3535 | bless Graph::TransitiveClosure->new($self, path => 1, @_), $class; | ||||
3536 | } | ||||
3537 | |||||
3538 | 1 | 2µs | *all_pairs_shortest_paths = \&APSP_Floyd_Warshall; | ||
3539 | |||||
3540 | sub _transitive_closure_matrix_compute { | ||||
3541 | } | ||||
3542 | |||||
3543 | sub transitive_closure_matrix { | ||||
3544 | my $g = shift; | ||||
3545 | my $tcm = $g->get_graph_attribute('_tcm'); | ||||
3546 | if (defined $tcm) { | ||||
3547 | if (ref $tcm eq 'ARRAY') { # YECHHH! | ||||
3548 | if ($tcm->[ 0 ] == $g->[ _G ]) { | ||||
3549 | $tcm = $tcm->[ 1 ]; | ||||
3550 | } else { | ||||
3551 | undef $tcm; | ||||
3552 | } | ||||
3553 | } | ||||
3554 | } | ||||
3555 | unless (defined $tcm) { | ||||
3556 | my $apsp = $g->APSP_Floyd_Warshall(@_); | ||||
3557 | $tcm = $apsp->get_graph_attribute('_tcm'); | ||||
3558 | $g->set_graph_attribute('_tcm', [ $g->[ _G ], $tcm ]); | ||||
3559 | } | ||||
3560 | |||||
3561 | return $tcm; | ||||
3562 | } | ||||
3563 | |||||
3564 | sub path_length { | ||||
3565 | my $g = shift; | ||||
3566 | my $tcm = $g->transitive_closure_matrix; | ||||
3567 | $tcm->path_length(@_); | ||||
3568 | } | ||||
3569 | |||||
3570 | sub path_predecessor { | ||||
3571 | my $g = shift; | ||||
3572 | my $tcm = $g->transitive_closure_matrix; | ||||
3573 | $tcm->path_predecessor(@_); | ||||
3574 | } | ||||
3575 | |||||
3576 | sub path_vertices { | ||||
3577 | my $g = shift; | ||||
3578 | my $tcm = $g->transitive_closure_matrix; | ||||
3579 | $tcm->path_vertices(@_); | ||||
3580 | } | ||||
3581 | |||||
3582 | sub is_reachable { | ||||
3583 | my $g = shift; | ||||
3584 | my $tcm = $g->transitive_closure_matrix; | ||||
3585 | $tcm->is_reachable(@_); | ||||
3586 | } | ||||
3587 | |||||
3588 | sub for_shortest_paths { | ||||
3589 | my $g = shift; | ||||
3590 | my $c = shift; | ||||
3591 | my $t = $g->transitive_closure_matrix; | ||||
3592 | my @v = $g->vertices; | ||||
3593 | my $n = 0; | ||||
3594 | for my $u (@v) { | ||||
3595 | for my $v (@v) { | ||||
3596 | next unless $t->is_reachable($u, $v); | ||||
3597 | $n++; | ||||
3598 | $c->($t, $u, $v, $n); | ||||
3599 | } | ||||
3600 | } | ||||
3601 | return $n; | ||||
3602 | } | ||||
3603 | |||||
3604 | sub _minmax_path { | ||||
3605 | my $g = shift; | ||||
3606 | my $min; | ||||
3607 | my $max; | ||||
3608 | my $minp; | ||||
3609 | my $maxp; | ||||
3610 | $g->for_shortest_paths(sub { | ||||
3611 | my ($t, $u, $v, $n) = @_; | ||||
3612 | my $l = $t->path_length($u, $v); | ||||
3613 | return unless defined $l; | ||||
3614 | my $p; | ||||
3615 | if ($u ne $v && (!defined $max || $l > $max)) { | ||||
3616 | $max = $l; | ||||
3617 | $maxp = $p = [ $t->path_vertices($u, $v) ]; | ||||
3618 | } | ||||
3619 | if ($u ne $v && (!defined $min || $l < $min)) { | ||||
3620 | $min = $l; | ||||
3621 | $minp = $p || [ $t->path_vertices($u, $v) ]; | ||||
3622 | } | ||||
3623 | }); | ||||
3624 | return ($min, $max, $minp, $maxp); | ||||
3625 | } | ||||
3626 | |||||
3627 | sub diameter { | ||||
3628 | my $g = shift; | ||||
3629 | my ($min, $max, $minp, $maxp) = $g->_minmax_path(@_); | ||||
3630 | return defined $maxp ? (wantarray ? @$maxp : $max) : undef; | ||||
3631 | } | ||||
3632 | |||||
3633 | 1 | 2µs | *graph_diameter = \&diameter; | ||
3634 | |||||
3635 | sub longest_path { | ||||
3636 | my ($g, $u, $v) = @_; | ||||
3637 | my $t = $g->transitive_closure_matrix; | ||||
3638 | if (defined $u) { | ||||
3639 | if (defined $v) { | ||||
3640 | return wantarray ? | ||||
3641 | $t->path_vertices($u, $v) : $t->path_length($u, $v); | ||||
3642 | } else { | ||||
3643 | my $max; | ||||
3644 | my @max; | ||||
3645 | for my $v ($g->vertices) { | ||||
3646 | next if $u eq $v; | ||||
3647 | my $l = $t->path_length($u, $v); | ||||
3648 | if (defined $l && (!defined $max || $l > $max)) { | ||||
3649 | $max = $l; | ||||
3650 | @max = $t->path_vertices($u, $v); | ||||
3651 | } | ||||
3652 | } | ||||
3653 | return wantarray ? @max : $max; | ||||
3654 | } | ||||
3655 | } else { | ||||
3656 | if (defined $v) { | ||||
3657 | my $max; | ||||
3658 | my @max; | ||||
3659 | for my $u ($g->vertices) { | ||||
3660 | next if $u eq $v; | ||||
3661 | my $l = $t->path_length($u, $v); | ||||
3662 | if (defined $l && (!defined $max || $l > $max)) { | ||||
3663 | $max = $l; | ||||
3664 | @max = $t->path_vertices($u, $v); | ||||
3665 | } | ||||
3666 | } | ||||
3667 | return wantarray ? @max : @max - 1; | ||||
3668 | } else { | ||||
3669 | my ($min, $max, $minp, $maxp) = $g->_minmax_path(@_); | ||||
3670 | return defined $maxp ? (wantarray ? @$maxp : $max) : undef; | ||||
3671 | } | ||||
3672 | } | ||||
3673 | } | ||||
3674 | |||||
3675 | sub vertex_eccentricity { | ||||
3676 | my ($g, $u) = @_; | ||||
3677 | $g->expect_undirected; | ||||
3678 | if ($g->is_connected) { | ||||
3679 | my $max; | ||||
3680 | for my $v ($g->vertices) { | ||||
3681 | next if $u eq $v; | ||||
3682 | my $l = $g->path_length($u, $v); | ||||
3683 | if (defined $l && (!defined $max || $l > $max)) { | ||||
3684 | $max = $l; | ||||
3685 | } | ||||
3686 | } | ||||
3687 | return $max; | ||||
3688 | } else { | ||||
3689 | return Infinity(); | ||||
3690 | } | ||||
3691 | } | ||||
3692 | |||||
3693 | sub shortest_path { | ||||
3694 | my ($g, $u, $v) = @_; | ||||
3695 | $g->expect_undirected; | ||||
3696 | my $t = $g->transitive_closure_matrix; | ||||
3697 | if (defined $u) { | ||||
3698 | if (defined $v) { | ||||
3699 | return wantarray ? | ||||
3700 | $t->path_vertices($u, $v) : $t->path_length($u, $v); | ||||
3701 | } else { | ||||
3702 | my $min; | ||||
3703 | my @min; | ||||
3704 | for my $v ($g->vertices) { | ||||
3705 | next if $u eq $v; | ||||
3706 | my $l = $t->path_length($u, $v); | ||||
3707 | if (defined $l && (!defined $min || $l < $min)) { | ||||
3708 | $min = $l; | ||||
3709 | @min = $t->path_vertices($u, $v); | ||||
3710 | } | ||||
3711 | } | ||||
3712 | return wantarray ? @min : $min; | ||||
3713 | } | ||||
3714 | } else { | ||||
3715 | if (defined $v) { | ||||
3716 | my $min; | ||||
3717 | my @min; | ||||
3718 | for my $u ($g->vertices) { | ||||
3719 | next if $u eq $v; | ||||
3720 | my $l = $t->path_length($u, $v); | ||||
3721 | if (defined $l && (!defined $min || $l < $min)) { | ||||
3722 | $min = $l; | ||||
3723 | @min = $t->path_vertices($u, $v); | ||||
3724 | } | ||||
3725 | } | ||||
3726 | return wantarray ? @min : $min; | ||||
3727 | } else { | ||||
3728 | my ($min, $max, $minp, $maxp) = $g->_minmax_path(@_); | ||||
3729 | return defined $minp ? (wantarray ? @$minp : $min) : undef; | ||||
3730 | } | ||||
3731 | } | ||||
3732 | } | ||||
3733 | |||||
3734 | sub radius { | ||||
3735 | my $g = shift; | ||||
3736 | $g->expect_undirected; | ||||
3737 | my ($center, $radius) = (undef, Infinity()); | ||||
3738 | for my $v ($g->vertices) { | ||||
3739 | my $x = $g->vertex_eccentricity($v); | ||||
3740 | ($center, $radius) = ($v, $x) if defined $x && $x < $radius; | ||||
3741 | } | ||||
3742 | return $radius; | ||||
3743 | } | ||||
3744 | |||||
3745 | sub center_vertices { | ||||
3746 | my ($g, $delta) = @_; | ||||
3747 | $g->expect_undirected; | ||||
3748 | $delta = 0 unless defined $delta; | ||||
3749 | $delta = abs($delta); | ||||
3750 | my @c; | ||||
3751 | my $r = $g->radius; | ||||
3752 | if (defined $r) { | ||||
3753 | for my $v ($g->vertices) { | ||||
3754 | my $e = $g->vertex_eccentricity($v); | ||||
3755 | next unless defined $e; | ||||
3756 | push @c, $v if abs($e - $r) <= $delta; | ||||
3757 | } | ||||
3758 | } | ||||
3759 | return @c; | ||||
3760 | } | ||||
3761 | |||||
3762 | 1 | 2µs | *centre_vertices = \¢er_vertices; | ||
3763 | |||||
3764 | sub average_path_length { | ||||
3765 | my $g = shift; | ||||
3766 | my @A = @_; | ||||
3767 | my $d = 0; | ||||
3768 | my $m = 0; | ||||
3769 | my $n = $g->for_shortest_paths(sub { | ||||
3770 | my ($t, $u, $v, $n) = @_; | ||||
3771 | my $l = $t->path_length($u, $v); | ||||
3772 | if ($l) { | ||||
3773 | my $c = @A == 0 || | ||||
3774 | (@A == 1 && $u eq $A[0]) || | ||||
3775 | ((@A == 2) && | ||||
3776 | (defined $A[0] && | ||||
3777 | $u eq $A[0]) || | ||||
3778 | (defined $A[1] && | ||||
3779 | $v eq $A[1])); | ||||
3780 | if ($c) { | ||||
3781 | $d += $l; | ||||
3782 | $m++; | ||||
3783 | } | ||||
3784 | } | ||||
3785 | }); | ||||
3786 | return $m ? $d / $m : undef; | ||||
3787 | } | ||||
3788 | |||||
3789 | ### | ||||
3790 | # Simple tests. | ||||
3791 | # | ||||
3792 | |||||
3793 | sub is_multi_graph { | ||||
3794 | my $g = shift; | ||||
3795 | return 0 unless $g->is_multiedged || $g->is_countedged; | ||||
3796 | my $multiedges = 0; | ||||
3797 | for my $e ($g->edges05) { | ||||
3798 | my ($u, @v) = @$e; | ||||
3799 | for my $v (@v) { | ||||
3800 | return 0 if $u eq $v; | ||||
3801 | } | ||||
3802 | $multiedges++ if $g->get_edge_count(@$e) > 1; | ||||
3803 | } | ||||
3804 | return $multiedges; | ||||
3805 | } | ||||
3806 | |||||
3807 | sub is_simple_graph { | ||||
3808 | my $g = shift; | ||||
3809 | return 1 unless $g->is_countedged || $g->is_multiedged; | ||||
3810 | for my $e ($g->edges05) { | ||||
3811 | return 0 if $g->get_edge_count(@$e) > 1; | ||||
3812 | } | ||||
3813 | return 1; | ||||
3814 | } | ||||
3815 | |||||
3816 | sub is_pseudo_graph { | ||||
3817 | my $g = shift; | ||||
3818 | my $m = $g->is_countedged || $g->is_multiedged; | ||||
3819 | for my $e ($g->edges05) { | ||||
3820 | my ($u, @v) = @$e; | ||||
3821 | for my $v (@v) { | ||||
3822 | return 1 if $u eq $v; | ||||
3823 | } | ||||
3824 | return 1 if $m && $g->get_edge_count($u, @v) > 1; | ||||
3825 | } | ||||
3826 | return 0; | ||||
3827 | } | ||||
3828 | |||||
3829 | ### | ||||
3830 | # Rough isomorphism guess. | ||||
3831 | # | ||||
3832 | |||||
3833 | 1 | 3µs | my %_factorial = (0 => 1, 1 => 1); | ||
3834 | |||||
3835 | sub __factorial { | ||||
3836 | my $n = shift; | ||||
3837 | for (my $i = 2; $i <= $n; $i++) { | ||||
3838 | next if exists $_factorial{$i}; | ||||
3839 | $_factorial{$i} = $i * $_factorial{$i - 1}; | ||||
3840 | } | ||||
3841 | $_factorial{$n}; | ||||
3842 | } | ||||
3843 | |||||
3844 | sub _factorial { | ||||
3845 | my $n = int(shift); | ||||
3846 | if ($n < 0) { | ||||
3847 | require Carp; | ||||
3848 | Carp::croak("factorial of a negative number"); | ||||
3849 | } | ||||
3850 | __factorial($n) unless exists $_factorial{$n}; | ||||
3851 | return $_factorial{$n}; | ||||
3852 | } | ||||
3853 | |||||
3854 | sub could_be_isomorphic { | ||||
3855 | my ($g0, $g1) = @_; | ||||
3856 | return 0 unless $g0->vertices == $g1->vertices; | ||||
3857 | return 0 unless $g0->edges05 == $g1->edges05; | ||||
3858 | my %d0; | ||||
3859 | for my $v0 ($g0->vertices) { | ||||
3860 | $d0{ $g0->in_degree($v0) }{ $g0->out_degree($v0) }++ | ||||
3861 | } | ||||
3862 | my %d1; | ||||
3863 | for my $v1 ($g1->vertices) { | ||||
3864 | $d1{ $g1->in_degree($v1) }{ $g1->out_degree($v1) }++ | ||||
3865 | } | ||||
3866 | return 0 unless keys %d0 == keys %d1; | ||||
3867 | for my $da (keys %d0) { | ||||
3868 | return 0 | ||||
3869 | unless exists $d1{$da} && | ||||
3870 | keys %{ $d0{$da} } == keys %{ $d1{$da} }; | ||||
3871 | for my $db (keys %{ $d0{$da} }) { | ||||
3872 | return 0 | ||||
3873 | unless exists $d1{$da}{$db} && | ||||
3874 | $d0{$da}{$db} == $d1{$da}{$db}; | ||||
3875 | } | ||||
3876 | } | ||||
3877 | for my $da (keys %d0) { | ||||
3878 | for my $db (keys %{ $d0{$da} }) { | ||||
3879 | return 0 unless $d1{$da}{$db} == $d0{$da}{$db}; | ||||
3880 | } | ||||
3881 | delete $d1{$da}; | ||||
3882 | } | ||||
3883 | return 0 unless keys %d1 == 0; | ||||
3884 | my $f = 1; | ||||
3885 | for my $da (keys %d0) { | ||||
3886 | for my $db (keys %{ $d0{$da} }) { | ||||
3887 | $f *= _factorial(abs($d0{$da}{$db})); | ||||
3888 | } | ||||
3889 | } | ||||
3890 | return $f; | ||||
3891 | } | ||||
3892 | |||||
3893 | ### | ||||
3894 | # Analysis functions. | ||||
3895 | |||||
3896 | sub subgraph_by_radius | ||||
3897 | { | ||||
3898 | my ($g, $n, $rad) = @_; | ||||
3899 | |||||
3900 | return unless defined $n && defined $rad && $rad >= 0; | ||||
3901 | |||||
3902 | my $r = (ref $g)->new; | ||||
3903 | |||||
3904 | if ($rad == 0) { | ||||
3905 | return $r->add_vertex($n); | ||||
3906 | } | ||||
3907 | |||||
3908 | my %h; | ||||
3909 | $h{1} = [ [ $n, $g->successors($n) ] ]; | ||||
3910 | for my $i (1..$rad) { | ||||
3911 | $h{$i+1} = []; | ||||
3912 | for my $arr (@{ $h{$i} }) { | ||||
3913 | my ($p, @succ) = @{ $arr }; | ||||
3914 | for my $s (@succ) { | ||||
3915 | $r->add_edge($p, $s); | ||||
3916 | push(@{ $h{$i+1} }, [$s, $g->successors($s)]) if $i < $rad; | ||||
3917 | } | ||||
3918 | } | ||||
3919 | } | ||||
3920 | |||||
3921 | return $r; | ||||
3922 | } | ||||
3923 | |||||
3924 | sub clustering_coefficient { | ||||
3925 | my ($g) = @_; | ||||
3926 | my %clustering; | ||||
3927 | |||||
3928 | my $gamma = 0; | ||||
3929 | |||||
3930 | for my $n ($g->vertices()) { | ||||
3931 | my $gamma_v = 0; | ||||
3932 | my @neigh = $g->successors($n); | ||||
3933 | my %c; | ||||
3934 | for my $u (@neigh) { | ||||
3935 | for my $v (@neigh) { | ||||
3936 | if (!$c{"$u-$v"} && $g->has_edge($u, $v)) { | ||||
3937 | $gamma_v++; | ||||
3938 | $c{"$u-$v"} = 1; | ||||
3939 | $c{"$v-$u"} = 1; | ||||
3940 | } | ||||
3941 | } | ||||
3942 | } | ||||
3943 | if (@neigh > 1) { | ||||
3944 | $clustering{$n} = $gamma_v/(@neigh * (@neigh - 1) / 2); | ||||
3945 | $gamma += $gamma_v/(@neigh * (@neigh - 1) / 2); | ||||
3946 | } else { | ||||
3947 | $clustering{$n} = 0; | ||||
3948 | } | ||||
3949 | } | ||||
3950 | |||||
3951 | $gamma /= $g->vertices(); | ||||
3952 | |||||
3953 | return wantarray ? ($gamma, %clustering) : $gamma; | ||||
3954 | } | ||||
3955 | |||||
3956 | sub betweenness { | ||||
3957 | my $g = shift; | ||||
3958 | |||||
3959 | my @V = $g->vertices(); | ||||
3960 | |||||
3961 | my %Cb; # C_b{w} = 0 | ||||
3962 | |||||
3963 | $Cb{$_} = 0 for @V; | ||||
3964 | |||||
3965 | for my $s (@V) { | ||||
3966 | my @S; # stack (unshift, shift) | ||||
3967 | |||||
3968 | my %P; # P{w} = empty list | ||||
3969 | $P{$_} = [] for @V; | ||||
3970 | |||||
3971 | my %sigma; # \sigma{t} = 0 | ||||
3972 | $sigma{$_} = 0 for @V; | ||||
3973 | $sigma{$s} = 1; | ||||
3974 | |||||
3975 | my %d; # d{t} = -1; | ||||
3976 | $d{$_} = -1 for @V; | ||||
3977 | $d{$s} = 0; | ||||
3978 | |||||
3979 | my @Q; # queue (push, shift) | ||||
3980 | push @Q, $s; | ||||
3981 | |||||
3982 | while (@Q) { | ||||
3983 | my $v = shift @Q; | ||||
3984 | unshift @S, $v; | ||||
3985 | for my $w ($g->successors($v)) { | ||||
3986 | # w found for first time | ||||
3987 | if ($d{$w} < 0) { | ||||
3988 | push @Q, $w; | ||||
3989 | $d{$w} = $d{$v} + 1; | ||||
3990 | } | ||||
3991 | # Shortest path to w via v | ||||
3992 | if ($d{$w} == $d{$v} + 1) { | ||||
3993 | $sigma{$w} += $sigma{$v}; | ||||
3994 | push @{ $P{$w} }, $v; | ||||
3995 | } | ||||
3996 | } | ||||
3997 | } | ||||
3998 | |||||
3999 | my %delta; | ||||
4000 | $delta{$_} = 0 for @V; | ||||
4001 | |||||
4002 | while (@S) { | ||||
4003 | my $w = shift @S; | ||||
4004 | for my $v (@{ $P{$w} }) { | ||||
4005 | $delta{$v} += $sigma{$v}/$sigma{$w} * (1 + $delta{$w}); | ||||
4006 | } | ||||
4007 | if ($w ne $s) { | ||||
4008 | $Cb{$w} += $delta{$w}; | ||||
4009 | } | ||||
4010 | } | ||||
4011 | } | ||||
4012 | |||||
4013 | return %Cb; | ||||
4014 | } | ||||
4015 | |||||
4016 | ### | ||||
4017 | # Debugging. | ||||
4018 | # | ||||
4019 | |||||
4020 | sub _dump { | ||||
4021 | require Data::Dumper; | ||||
4022 | my $d = Data::Dumper->new([$_[0]],[ref $_[0]]); | ||||
4023 | defined wantarray ? $d->Dump : print $d->Dump; | ||||
4024 | } | ||||
4025 | |||||
4026 | 1 | 94µs | 1; | ||
# spent 22.7ms within Graph::CORE:sort which was called 26277 times, avg 865ns/call:
# 26277 times (22.7ms+0s) by Graph::has_edge at line 546, avg 865ns/call |