1
$\begingroup$

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.

$\endgroup$

3 Answers 3

0
$\begingroup$

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.

$\endgroup$
0
$\begingroup$

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"
 ]

Mathematica graphics

Hope this helps.

$\endgroup$
0
$\begingroup$
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] 
$\endgroup$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge you have read our privacy policy.

Not the answer you're looking for? Browse other questions tagged or ask your own question.