Trouvez des grappes de corrélations positives

Question

J'ai une matrice carrée qui montre les relations entre 71 plantes: 1 est un positif, -1 est négatif, 0 n'est pas concluant et les blancs sont inconnus:

J'aimerais trouver les plus grands groupes d'usines qui n'ont qu'une relation positive sans aucune relation négative entre aucun des membres.

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

L'ensemble complet:

https://pastebin.com/06krccza

J'ai pu savoir qui créer un graphique d'adjacence pondérée en utilisant:

Générer un graphique de réseau social à partir d'un fichier CSV

Cependant, je recherche quelque chose qui simplifie les relations et où je peux choisir des groupes de bons matchs.

Answer 1

Ingérer les données, faire une matrice des corrélations, faire une liste avec les noms des plantes:

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

(*70*)

Associez les corrélations et les distances:

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

Notez que pour traiter la condition principale, non triviale de la question

[...] trouver les plus grands groupes d'usines qui n'ont qu'une relation positive sans aucune relation négative entre aucun des membres.

les distances aDistsqui correspondent à des corrélations négatives sont de (très) grands nombres.

Faites un graphique des voisins les plus proches:

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

Rechercher des cliques / clusters:

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

Examinez les longueurs des clusters:

Tally[Length /@ lsClqs]

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

Vérifiez que les clusters trouvés n'ont pas de corrélations négatives

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

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

Examinez la corrélation négative et / ou supprimez-la:

Select[aHasNegativeCor, ! # &]

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

Résultat final:

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

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

Première réponse

Un code qui pourrait aider ces questions.

Puisque les données n'ont pas été fournies, faisons quelques-unes:

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 &]
   ];

Faites un graphique avec les corrélations positives uniquement:

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

Rechercher des communautés graphiques:

 CommunityGraphPlot[gr, VertexLabels -> "Name"]

Si vous fournissez les données réelles, des réponses plus adéquates pourraient être données.