2
$\begingroup$

I have a square matrix that shows relationships between 71 plants: 1 is a positive, -1 is negative, 0 is inconclusive and blanks are unknown:

I would like find the largest groups of plants that only have a positive relationship with no negative relationships among any of the members.

data = {{"", "Basil", "Cucumber", "Tomato", "Potato", "Peanut"}, {"Basil", 
  "", 0, -1, 0, ""}, {"Cucumber", "", "", "", -1, -1}, {"Tomato", -1,
   "", "", "", ""}, {"Potato", "", -1, 0, "", ""}, {"Peanut", 1, -1, 
  "", "", ""}}

The full set:

https://pastebin.com/06krccza

I was able to find out who to make a Weighted Adjacency Graph using:

Generating social network graph from a CSV file

However, I am looking for something that simplifies relationships to where I can pick out groups of good matches.

Improve this question
$\endgroup$
12
  • 2
    $\begingroup$ Why you do not have "Beans, French" in the columns of dataset but have it in rows? Also, are not relationships mutual, so you have to have symmetric values? $\endgroup$
    – Vitaliy Kaurov
    Commented Sep 2, 2020 at 4:17
  • $\begingroup$ Please expand on "I want find clusters of plants that go well together." and clarify what you mean. $\endgroup$
    – Szabolcs
    Commented Sep 2, 2020 at 8:53
  • $\begingroup$ I corrected the mistakes in the data and made a simpler set. $\endgroup$
    – user72725
    Commented Sep 2, 2020 at 13:54
  • $\begingroup$ I edited the question. I am looking for clusters of plants that only have positive relationships among the members of the group. A bonus would be candidates that may have a positive relationship based on a '0' value. $\endgroup$
    – user72725
    Commented Sep 2, 2020 at 13:55
  • 2
    $\begingroup$ I’m voting to close this question because any solution to the OP's question requires advice about clustering and handling missing values. Advice from a statistician or from stats.stackexchange.com is needed first prior to implementation in Mathematica. $\endgroup$
    – JimB
    Commented Sep 2, 2020 at 16:41

1 Answer 1

Reset to default
5
$\begingroup$

Ingest the data, make a matrix of the correlations, make a list with plant names:

data = Get["~/Downloads/06krccza.txt"];
matData = data[[2 ;; -1, 2 ;; -1]];
lsPlantNames = Rest@data[[1]];
Length[lsPlantNames]

(*70*)

Make association of correlations and distances:

aCors = Association@
   Map[lsPlantNames[[#[[1]]]] -> #[[2]] &, 
    Most[ArrayRules[SparseArray[matData]]]];
aDists = Map[
   N@Which[TrueQ[# == 1], 0, TrueQ[# == -1], 1000, True, 1] &, aCors];

Note that in order to address question's main, non-trivial condition

[...] find the largest groups of plants that only have a positive relationship with no negative relationships among any of the members.

the distances in aDists that correspond to negative correlations are (very) large numbers.

Make a nearest neighbors graph:

gr = NearestNeighborGraph[lsPlantNames, {90, 0.1}, 
  DistanceFunction -> (Lookup[aDists, Key[{#1, #2}], 1000] &), 
  Method -> "Octree", DirectedEdges -> False, 
  GraphLayout -> "SpringElectricalEmbedding", VertexLabels -> "Name"]

enter image description here

Find cliques / clusters:

lsClqs = FindClique[gr, Infinity, All];
Length[lsClqs]

Examine the clusters lengths:

Tally[Length /@ lsClqs]

(*{{4, 1}, {3, 10}, {2, 32}, {1, 36}}*)

Verify the found clusters do not have negative correlations

aHasNegativeCor = 
  Association[# -> FreeQ[Outer[aCors[{##}] &, #, #], -1] & /@ clqs];
Tally[Values[aHasNegativeCor]]

(*{{True, 78}, {False, 1}}*)

Examine the negative correlation and/or delete it:

Select[aHasNegativeCor, ! # &]

(*<|{"Beans, Runner", "Garlic", "Leek"} -> False|>*)

Final result:

lsClqs2 = Keys[Select[aHasNegativeCor, # &]];
lsClqs2[[1 ;; 4]]

(*{{"Onion", "Pea", "Potato", "Tomato"}, {"Onion", "Parsnip", 
  "Tomato"}, {"Leek", "Onion", "Pea"}, {"Garlic", "Leek", "Pea"}}*)

First answer

Some code that might help these questions.

Since data was not provided, let us make some:

SeedRandom[32]; 
data2 = Block[{lsWords = Sort@RandomWord[71], res},
   res = Flatten[
     Table[{lsWords[[i]], lsWords[[j]], 
       RandomChoice[{0.1, 0.8, 0.1} -> {-1, 0, 1}]}, {i, 1, 
       Length[lsWords]}, {j, i + 1, Length[lsWords]}], 1];
   res = Union[Join[res, res[[All, {2, 1, 3}]]]];
   Select[res, #[[3]] != 0 &]
   ];

Make a graph with the positive correlations only:

 gr = Graph[UndirectedEdge @@@ Select[data2, #[[3]] > 0 &]]

Find graph communities:

 CommunityGraphPlot[gr, VertexLabels -> "Name"]

enter image description here

If you provide the actual data more adequate answers might be given.

Improve this answer
$\endgroup$
11
  • $\begingroup$ Having executed the first part of your code, I obtained "RandomWord::nodict: Word list is not available for language Ukrainian.". A good code is a commented code. $\endgroup$
    – user64494
    Commented Sep 2, 2020 at 18:59
  • 1
    $\begingroup$ @user64494 1) Having executed the first part of your code, I obtained "RandomWord::nodict: Word list is not available for language Ukrainian." -- this should not be happening in my opinion; consider filing a bug report. And/or run your Mathematica copy with a different language localization. 2) A good code is a commented code -- Agreed. What this has to do with my post? $\endgroup$
    – Anton Antonov
    Commented Sep 2, 2020 at 19:04
  • $\begingroup$ Thank you Anton. That what I was looking for. I have updated the question to link the data. $\endgroup$
    – user72725
    Commented Sep 3, 2020 at 2:17
  • 2
    $\begingroup$ @user64494 "Your comments to your code are too poor or absent at all." -- I disagree. And if you have in mind the code for the data generation, then I would say that the data generation is not important -- note, that OP did provide actual data after I posted my answer. Also, you cannot figure out RandomWord peculiarities by reading its function page. $\endgroup$
    – Anton Antonov
    Commented Sep 3, 2020 at 12:27
  • 2
    $\begingroup$ @user64494 "I have nothing to discuss with you in such unconstructive manner." -- No, all of my responses to your comments were constructive: detailed and concrete enough. $\endgroup$
    – Anton Antonov
    Commented Sep 3, 2020 at 19:05

Your Answer

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