# List manipulation and plotting

I have a code which takes as input RandomSample[Range[d^2],4] for a given d and outputs a value q which is either 0 or 1.

The following code outputs a Table with 5 elements of the form {RandomSample[Range[d^2],4],q}. In this specific case d=4.

d = 4; times=5;

testpath[v_] :=
Module[{neighs, i, intersections},
neighs =
Delete[neighlist, {Flatten[Position[nodlist, v[]]],
Flatten[Position[nodlist, v[[-1]]]]}]; intersections = List[];
For[i = 1, i <= Length[neighs], i++,
AppendTo[intersections, Length[Intersection[v, neighs[[i]]]]]];
If[Times @@ Boole[EvenQ[intersections]] == 1, 1, 0]]

nbp = 2; order = 0;
graph = GridGraph[{d, d}, VertexLabels -> "Name"];
Table[
nodlist = RandomSample[Range[d^2], 2 nbp];
For[i = 1; j = 0; lenshortpaths = List[]; allpaths = List[];
neighlist = List[]; validpaths = List[];
numvalidpaths = List[], i <= 2 nbp - 1, i = i + 2, j = j + 1;
AppendTo[lenshortpaths,
Length[FindShortestPath[graph, nodlist[[i]], nodlist[[i + 1]]]]];
AppendTo[allpaths,
FindPath[
VertexDelete[graph,
Complement[nodlist, {nodlist[[i]], nodlist[[i + 1]]}]],
nodlist[[i]], nodlist[[i + 1]], lenshortpaths[[j]] + order,
All]];
For[k = 1; l = 0, k <= Length[allpaths[[j]]], k++,
If[IsomorphicGraphQ[Subgraph[graph, allpaths[[j, k]]],
PathGraph[allpaths[[j, k]]]],
AppendTo[validpaths, allpaths[[j, k]]]; l = l + 1]];
AppendTo[numvalidpaths, l];
AppendTo[neighlist,
Complement[
VertexList[
NeighborhoodGraph[graph, nodlist[[i]]]], {nodlist[[i]]}]];
AppendTo[neighlist,
Complement[
VertexList[
NeighborhoodGraph[graph, nodlist[[i + 1]]]], {nodlist[[
i + 1]]}]]];
occ = 2; validpathsx = validpaths;
While[And[occ == 2, Length[validpathsx] >= 0],
If[Length[validpathsx] > 0,
If[testpath[validpathsx[]] == 1, occ = 1;(*Print[occ]*),
validpathsx = Delete[validpathsx, 1]], occ = 0;(*Print[
occ]*)]]; {nodlist, occ}, times]

(*{{{4, 6, 5, 13}, 0}, {{12, 6, 1, 8}, 1}, {{11, 15, 5, 8}, 1},
{{3, 10, 6, 16}, 1}, {{10, 3, 11, 4}, 0}}*)


Heres what I want to do; For any number between 1 and 16 (i.e.d^2) I need to calculate the ratio between the number of times it was part of a random sample with a corresponding q value of 1 vs the number of times with q=0.

For example, if for times=5 I get {{{4, 6, 5, 13}, 0}, {{12, 6, 1, 8}, 1}, {{11, 15, 5, 8}, 1}, {{3, 10, 6, 16}, 1}, {{10, 3, 11, 4}, 0}}, then for 11 the ratio would be 1, since its part of {11, 15, 5, 8} and {10, 3, 11, 4} with q values 1 and 0 respectively.

I then need to plot the d^2 ratios in a coloured grid plot.

Using the example provided:

d =4;

lst = {{{4, 6, 5, 13}, 0}, {{12, 6, 1, 8}, 1}, {{11, 15, 5, 8}, 1}, {{3, 10, 6, 16}, 1}, {{10, 3, 11, 4}, 0}};



I GatherBy the Last part of in each element in lst (corresponding to if q=0 or q=1). I then define two separate lists, Flatten out the gathered elements, and use Counts to count how many times each number occurs with q=0 and q=1:

(*In[]:*)
gathList = GatherBy[lst, Last];
zeroList = Counts@Flatten@gathList[[1, All, 1]]
oneList = Counts@Flatten@gathList[[2, All, 1]]

(*Out[]:*)
<|4 -> 2, 6 -> 1, 5 -> 1, 13 -> 1, 10 -> 1, 3 -> 1, 11 -> 1|>

<|12 -> 1, 6 -> 2, 1 -> 1, 8 -> 2, 11 -> 1, 15 -> 1, 5 -> 1, 3 -> 1,
10 -> 1, 16 -> 1|>


I then pad the counts associations with values zero for all the numbers that aren't present in oneList and zeroList:

(*In[]:*)
allNums = Range[d^2];
zeroNums = Keys@zeroList;
notInZero = # -> 0 & /@ Complement[allNums, zeroNums] /.
List -> Association;
oneNums = Keys@oneList;
notInOne = # -> 0 & /@ Complement[allNums, oneNums] /.
List -> Association;
fullZeroList = KeySort@Join[zeroList, notInZero]
fullOneList = KeySort@Join[oneList, notInOne]

(*Out[]:*)

<|1 -> 0, 2 -> 0, 3 -> 1, 4 -> 2, 5 -> 1, 6 -> 1, 7 -> 0, 8 -> 0,
9 -> 0, 10 -> 1, 11 -> 1, 12 -> 0, 13 -> 1, 14 -> 0, 15 -> 0,
16 -> 0|>

<|1 -> 1, 2 -> 0, 3 -> 1, 4 -> 0, 5 -> 1, 6 -> 2, 7 -> 0, 8 -> 2,
9 -> 0, 10 -> 1, 11 -> 1, 12 -> 1, 13 -> 0, 14 -> 0, 15 -> 1,
16 -> 1|>


The ratio of occurrences for each number 1,...,d^2 can then be outputted with:

(*In[]:*)
fullOneList/fullZeroList

(*Out[]:*)

<|1 -> ComplexInfinity, 2 -> Indeterminate, 3 -> 1, 4 -> 0, 5 -> 1,
6 -> 2, 7 -> Indeterminate, 8 -> ComplexInfinity, 9 -> Indeterminate,
10 -> 1, 11 -> 1, 12 -> ComplexInfinity, 13 -> 0,
14 -> Indeterminate, 15 -> ComplexInfinity, 16 -> ComplexInfinity|>


In the case where a number appears with q=1 but not q=0, we get ComplexInfinity, when it occurs in neither we get Indetermine (because it's 0/0) and 0 when it occurs with q=0 but not q=1.

You can directly call ListPlot on an Association (I.e. ListPlot[fullOneList/fullZeroList], but you will probably want to replace the ComplexInfinity and Indeterminate values with some other numerical value (like a large number for ComplexInfinity, and maybe just 0 for Indeterminate since it corresponds to a number being in neither lists) so that ListPlot doesn't give you a bunch of error messages.

Create a counting function that checks for the target value.

With

paths = {{{4, 6, 5, 13}, 0}, {{12, 6, 1, 8}, 1},
{{11, 15, 5, 8},1}, {{3, 10, 6, 16}, 1},
{{10, 3, 11, 4}, 0}};


and counting function

qNumCount[paths_, num_, q_] :=
Total@Boole[
And @@ Through[{
MemberQ[num]@*First
, EqualTo[q]@*Last
}@#] & /@ paths
]


Then

qNumCount[paths, 11, 1]

1


Map this across the range of values for both values of q

counts = {#, qNumCount[paths, #, 1], qNumCount[paths, #, 0]} & /@ Range@16

{{1, 1, 0}, {2, 0, 0}, {3, 1, 1}, {4, 0, 2}, {5, 1, 1}, {6, 2, 1},
{7, 0, 0}, {8, 2, 0}, {9, 0, 0}, {10, 1, 1}, {11, 1, 1},
{12, 1, 0}, {13, 0, 1}, {14, 0, 0}, {15, 1, 0}, {16, 1, 0}}


Plot the counts

BarChart[
counts[[All, 2 ;;]]
, ChartLegends -> {"q=1", "q=0"}
, ChartLabels -> {counts[[All, 1]], None}
, BarSpacing -> {None, Medium}
, PlotTheme -> "HeightGrid"
] Hope this helps.

poss={{{4, 6, 5, 13}, 0}, {{12, 6, 1, 8}, 1}, {{11, 15, 5, 8}, 1},
{{3, 10, 6, 16}, 1}, {{10, 3, 11, 4}, 0}};
selectedElements1 = Flatten[Cases[poss, {_, 1}][[All, 1]]];
list1 =Table[Count[selectedElements1, i], {i, 4^2}];

ArrayPlot[Partition[list1, d], ColorFunction ->.
"BlueGreenYellow",
Frame -> True, FrameTicks -> {Range[d], Range[d]},
FrameLabel -> {{"Row", None}, {"Column", None}},
ColorFunctionScaling -> True]