List manipulation and plotting

Question

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[[1]]]], 
 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]]] == 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.

Answer 1

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.

Answer 2

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.

Answer 3

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]