How to make arbitrary transpositions of associations and datasets
If you factor a permuation perm
into a product of cycles of the form $(j\ k)$ with $k=j+1$, then the permuation can be effected by Query
and Transpose
.
Functions:
adjacentCycles[perm] (* factors perm into "adjacent" 2-cycles *)
dsTranspose[x, perm] (* like Transpose[x, perm],
but x is a Dataset or Association *)
Code:
(* adjacentCycles
* factor permutations into cycles of the form (n n+1)
*)
adjacentCycles[p_?PermutationListQ] :=
Flatten@iAdjacentCycles[PermutationCycles[p]];
adjacentCycles[c : Cycles[{{__Integer} ..}]] :=
Flatten@iAdjacentCycles[c];
iAdjacentCycles[Cycles[c : {}]] := {};
iAdjacentCycles[Cycles[c : {c1_, c2__}]] :=(*Join@@*)
iAdjacentCycles /@ Cycles@*List /@ c;
iAdjacentCycles[Cycles[{c : {x_, y_, z__}}]] :=(*Join@@*)
iAdjacentCycles /@ Cycles@*List /@ Reverse@Partition[c, 2, 1];
iAdjacentCycles[Cycles[{c : {x_, y_}}]] := Module[{a, b},
{a, b} = MinMax[{x, y}];
With[{factors =
Cycles@*List /@ Reverse@Partition[Range[a, b], 2, 1]},
Reverse@Rest[factors]~Join~factors]
];
ClearAll[dsTranspose];
dsTranspose[assoc_Association, perm_?PermutationListQ] :=
With[{res = dsTranspose[Dataset@assoc, perm]},
Normal@res /; Dataset`ValidDatasetQ[res]
];
dsTranspose[ds_Dataset, perm_?PermutationListQ] :=
Module[{
xps, (* perm factored as 2-cycle transpositions *)
xpFN, (* applies Transpose or Query[Transpose] to appropriate level *)
res},
xps = adjacentCycles@perm;
xps = xps[[All, 1, 1, 1]] - 1; (* levels to be transposed *)
xpFN[0] = Transpose;
xpFN[n_Integer?Positive] :=
Map[Check[Query[Transpose][#],
Throw[$Failed, dsTranspose]] &, #, {n}] &;
res = Catch[Fold[xpFN[#2][#1] &, ds, xps], dsTranspose];
res /; Dataset`ValidDatasetQ[res]
];
Example:
assoc = Fold[AssociationThread[#2 -> #1] &, "X",
Reverse@Table[ToString[10 i + j], {i, 4}, {j, 2}]]
(*
<|"11" ->
<|"21" -> <|"31" -> <|"41" -> "X", "42" -> "X"|>,
"32" -> <|"41" -> "X", "42" -> "X"|>|>,
"22" -> <|"31" -> <|"41" -> "X", "42" -> "X"|>,
"32" -> <|"41" -> "X", "42" -> "X"|>|>|>,
"12" ->
<|"21" -> <|"31" -> <|"41" -> "X", "42" -> "X"|>,
"32" -> <|"41" -> "X", "42" -> "X"|>|>,
"22" -> <|"31" -> <|"41" -> "X", "42" -> "X"|>,
"32" -> <|"41" -> "X", "42" -> "X"|>|>|>|>
*)
dsTranspose[assoc, {3, 1, 4, 2}]
(* (* perm: *)
<|"21" -> (* level 2 -> 1 *)
<|"41" -> (* level 4 -> 2 *)
<|"11" -> (* level 1 -> 3 *)
<|"31" -> "X", (* level 3 -> 4 *)
"32" -> "X"|>,
"12" -> <|"31" -> "X", "32" -> "X"|>|>,
"42" -> <|"11" -> <|"31" -> "X", "32" -> "X"|>,
"12" -> <|"31" -> "X", "32" -> "X"|>|>|>,
"22" ->
<|"41" -> <|"11" -> <|"31" -> "X", "32" -> "X"|>,
"12" -> <|"31" -> "X", "32" -> "X"|>|>,
"42" -> <|"11" -> <|"31" -> "X", "32" -> "X"|>,
"12" -> <|"31" -> "X", "32" -> "X"|>|>|>|>
*)
Definitions
Here is an alternative implementation using the
Wolfram Function Repository
functions
AssociationKeyFlatten
and
ToAssociations
(submitted by WRI personnel) and
the function meMerge
(localMerge
) from
the answer by andre314:
Clear[TransposeAssoc];
TransposeAssoc[assoc_Association, perm_?PermutationListQ] :=
Block[{assoc2, assoc3, LocalMerge},
LocalMerge[x : {_Association ..}] := Merge[x, LocalMerge];
LocalMerge[{x_}] := x;
assoc2 = ResourceFunction["AssociationKeyFlatten"][assoc];
assoc3 = KeyMap[Permute[#, perm] &, assoc2];
LocalMerge[
ResourceFunction["ToAssociations"]@
KeyValueMap[Fold[{#2 -> #1} &, #2, Reverse@#1] &, assoc3]]
];
Step-by-step run
Here is an approach that doesn't need to flatten the whole tree of data.
Let's take the example of moving the level 1 keys at the level 3, on the data assoc
of your self-answer :
assoc = Fold[AssociationThread[#2 -> #1] &, "X",
Reverse@Table[ToString[10 i + j], {i, 4}, {j, 2}]]
Here is a function showAssocListTree
that will be usefull to show clearly how associations are nested. It's just a formatting function. It is useless to understand it:
showAssocListTree = RightComposition[
# //. List[content___] :> Prepend[List1 /@ List1[content], "List"] &
, # /. List1 -> List &
, # //. as : Association[___] :>
Prepend[List @@@ Normal[as], "Ass."] &
, TableForm[#] &
, ToBoxes
, # //. GridBox[{{"\"List\"", ___}, r___}, r01___] :>
RowBox[{RotationBox[
StyleBox["\"List\"", FontVariations -> {"Underline" -> True}],
BoxRotation -> Pi/2], "["(*StyleBox["[",FontWeight\[Rule]
"Bold"]*), GridBox[{r}, r01]}] &
, # //. GridBox[{{"\"Ass.\"", ___}, r___}, r01___] :>
RowBox[{"-> ", RotationBox["\"Ass.\"", BoxRotation -> Pi/2],
StyleBox["[", FontWeight -> "Bold"], GridBox[{r}, r01]}] &
, # /. RowBox[{"-> ", r___}] :> RowBox[{r}] &
, # //. InterpretationBox[x_, ___] :> x &
, # /. RowBox[{a___, RotationBox["\"Ass.\"", BoxRotation -> Pi/2],
r___}] :>
RowBox[{a, RotationBox["\"Association\"", BoxRotation -> Pi/2],
r}] &
, RawBoxes
, Style[#, GridBoxOptions -> { GridBoxDividers -> None},
SpanMaxSize -> DirectedInfinity[1]] &
];
your data formatted :
assoc // showAssocListTree
Insertion of level 1 data at level 3 :
listOfAssoc=KeyValueMap[
Function[{k, v}, Map[Association[k -> #] &, v, {2}]], assoc];
listOfAssoc //showAssocListTree
Note that the outer Association
has been transformed in a List
.
Now, the built-in function Merge
will be applied. This function only merge two successive levels. So, a recursive function is first created. Note that when applied, this recursive function will explode exponentially, but in most cases, it's better than to flatten the whole tree, and there are probably ways to circumvent this problem.
ClearAll[myMerge]
myMerge[x : {_Association ..}] := Merge[x, myMerge]
myMerge[{x_}] := x
myMerge[listOfAssoc ] //showAssocListTree
This approach can be generalised to the general case. For example {3, 1, 4, 2} could be decomposed as {1, 2, 3, 4} -> {1, 3, 4, 2} -> {3, 1, 4, 2}
inspiration source