diff --git a/Documentation/Images/AcyclicGraphTakeInput.png b/Documentation/Images/AcyclicGraphTakeInput.png new file mode 100644 index 000000000..e05de3027 Binary files /dev/null and b/Documentation/Images/AcyclicGraphTakeInput.png differ diff --git a/Documentation/Images/AcyclicGraphTakeOutput.png b/Documentation/Images/AcyclicGraphTakeOutput.png new file mode 100644 index 000000000..8596ef92b Binary files /dev/null and b/Documentation/Images/AcyclicGraphTakeOutput.png differ diff --git a/Documentation/SymbolsAndFunctions/UtilityFunctions/AcyclicGraphTake.md b/Documentation/SymbolsAndFunctions/UtilityFunctions/AcyclicGraphTake.md new file mode 100644 index 000000000..e03cb3e4f --- /dev/null +++ b/Documentation/SymbolsAndFunctions/UtilityFunctions/AcyclicGraphTake.md @@ -0,0 +1,21 @@ +###### [Symbols and Functions](/README.md#symbols-and-functions) > Utility Functions > + +# AcyclicGraphTake + +**`AcyclicGraphTake`** gives the intersectiom of the out-component of the first vertex +with the in-component of the second vertex: + +```wl +In[] := graph = BlockRandom[ + DirectedGraph[RandomGraph[{10, 10}], "Acyclic", VertexLabels -> Automatic], + RandomSeeding -> 2 +] +``` + + + +```wl +In[] := AcyclicGraphTake[graph, {1, 9}] +``` + + diff --git a/Kernel/AcyclicGraphTake.m b/Kernel/AcyclicGraphTake.m new file mode 100644 index 000000000..22fa843e8 --- /dev/null +++ b/Kernel/AcyclicGraphTake.m @@ -0,0 +1,52 @@ +Package["SetReplace`"] + +PackageImport["GeneralUtilities`"] + +PackageExport["AcyclicGraphTake"] + +(* Utility function to check for directed, acyclic graphs *) +dagQ[graph_] := AcyclicGraphQ[graph] && DirectedGraphQ[graph] && LoopFreeGraphQ[graph] + +(* Documentation *) +SetUsage @ " +AcyclicGraphTake[gr$, vrts$] gives the intersection in graph gr$ of the in-component of the first vertex in vrts$ \ +with the out-component of the second vertex in vrts$. +"; + +(* SyntaxInformation *) +SyntaxInformation[AcyclicGraphTake] = + {"ArgumentsPattern" -> {_, _}}; + +(* Argument count *) +AcyclicGraphTake[args___] := 0 /; + !Developer`CheckArgumentCount[AcyclicGraphTake[args], 2, 2] && False; + +(* main *) +expr : AcyclicGraphTake[graph_, vertices_] := ModuleScope[ + res = Catch[acyclicGraphTake[HoldForm @ expr, graph, vertices]]; + res /; res =!= $Failed +]; + +(* Normal form *) +acyclicGraphTake[_, graph_ ? dagQ, {startVertex_, endVertex_}] /; + VertexQ[graph, startVertex] && VertexQ[graph, endVertex] := ModuleScope[ + Subgraph[graph, Intersection[ + VertexInComponent[graph, endVertex], VertexOutComponent[graph, startVertex]]] +] + +(* Incorrect arguments messages *) +AcyclicGraphTake::invalidGraph = "The argument at position `1` in `2` should be a directed, acyclic graph."; +acyclicGraphTake[expr_, graph_ ? (Not @* dagQ), _] := + (Message[AcyclicGraphTake::invalidGraph, 1, HoldForm @ expr]; + Throw[$Failed]); + +AcyclicGraphTake::invalidVertexList = "The argument at position `1` in `2` should be a list of two vertices."; +acyclicGraphTake[expr_, _, Except[{_, _}]] := + (Message[AcyclicGraphTake::invalidVertexList, 2, HoldForm @ expr]; + Throw[$Failed]); + +AcyclicGraphTake::invalidVertex = "The argument `1` is not a valid vertex in `2`."; +acyclicGraphTake[expr_, graph_Graph, {startVertex_, endVertex_}] /; + (Not @ (VertexQ[graph, startVertex] && VertexQ[graph, endVertex])) := + (Message[AcyclicGraphTake::invalidVertex, If[VertexQ[graph, startVertex], endVertex, startVertex], HoldForm @ expr]; + Throw[$Failed]); diff --git a/README.md b/README.md index 7787eacc5..bdb1f38e0 100644 --- a/README.md +++ b/README.md @@ -203,6 +203,7 @@ ideas. So, if you are interested, please join! * [HypergraphPlot](Documentation/SymbolsAndFunctions/HypergraphPlot.md) * [RulePlot of WolframModel](Documentation/SymbolsAndFunctions/RulePlotOfWolframModel.md) * Utility Functions + * [AcyclicGraphTake](Documentation/SymbolsAndFunctions/UtilityFunctions/AcyclicGraphTake.md) * [IndexHypergraph](Documentation/SymbolsAndFunctions/UtilityFunctions/IndexHypergraph.md) * [IsomorphicHypergraphQ](Documentation/SymbolsAndFunctions/UtilityFunctions/IsomorphicHypergraphQ.md) * [HypergraphToGraph](Documentation/SymbolsAndFunctions/UtilityFunctions/HypergraphToGraph.md) diff --git a/Tests/AcyclicGraphTake.wlt b/Tests/AcyclicGraphTake.wlt new file mode 100644 index 000000000..14f68a607 --- /dev/null +++ b/Tests/AcyclicGraphTake.wlt @@ -0,0 +1,95 @@ +<| + "AcyclicGraphTake" -> <| + "init" -> ( + Attributes[Global`testUnevaluated] = {HoldAll}; + Global`testUnevaluated[args___] := SetReplace`PackageScope`testUnevaluated[VerificationTest, args]; + ), + "tests" -> { + (* Verification tests *) + VerificationTest[ + EdgeList[AcyclicGraphTake[Graph[{1 -> 2, 2 -> 3, 2 -> 4, 3 -> 4, 4 -> 5, 5 -> 6}], {2, 5}]], + EdgeList[Graph[{2 -> 3, 2 -> 4, 3 -> 4, 4 -> 5}]] + ], + + VerificationTest[ + EdgeList[AcyclicGraphTake[Graph[{1 -> 2, 2 -> 3, 3 -> 4, 4 -> 5}], {2, 5}]], + EdgeList[Graph[{2 -> 3, 3 -> 4, 4 -> 5}]] + ], + + VerificationTest[ + AcyclicGraphTake[Graph[{1 -> 2, 2 -> 3, 3 -> 4}], {1, 1}], + Graph[{1}, {}] + ], + + VerificationTest[ + EdgeList[AcyclicGraphTake[Graph[{1 -> 2, 2 -> 3, 4 -> 3}], {1, 4}]], + {} + ], + + (* unevaluated *) + + (* argument count *) + With[{ + dag = Graph[{1 -> 2, 2 -> 3}], + loopGraph = Graph[{1 -> 1, 1 -> 2}], + undirectedGraph = Graph[{1 <-> 2, 2 <-> 3}], + cyclicGraph = Graph[{1 -> 2, 2 -> 1}] + }, + { + testUnevaluated[ + AcyclicGraphTake[], + {AcyclicGraphTake::argrx} + ], + + testUnevaluated[ + AcyclicGraphTake[x], + {AcyclicGraphTake::argr} + ], + + (* first argument: graph *) + testUnevaluated[ + AcyclicGraphTake[x, ], + {AcyclicGraphTake::invalidGraph} + ], + + testUnevaluated[ + AcyclicGraphTake[loopGraph, x], + {AcyclicGraphTake::invalidGraph} + ], + + testUnevaluated[ + AcyclicGraphTake[undirectedGraph, x], + {AcyclicGraphTake::invalidGraph} + ], + + testUnevaluated[ + AcyclicGraphTake[cyclicGraph, x], + {AcyclicGraphTake::invalidGraph} + ], + + (* second argument: vertex list *) + testUnevaluated[ + AcyclicGraphTake[dag, x], + {AcyclicGraphTake::invalidVertexList} + ], + + testUnevaluated[ + AcyclicGraphTake[dag, {x, y, z}], + {AcyclicGraphTake::invalidVertexList} + ], + + testUnevaluated[ + AcyclicGraphTake[dag, {6, 1}], + {AcyclicGraphTake::invalidVertex} + ], + + testUnevaluated[ + AcyclicGraphTake[dag, {1, 6}], + {AcyclicGraphTake::invalidVertex} + ] + } + ] + }, + "options" -> <|"Parallel" -> False|> + |> +|>