Re: Numerischer Fehler

["Udo und Susanne Krause" <su.krause@XXXXXXX.ch>]

Hoi mitenand,

> könnte es sein, dass data= Round[data,10^(-6)] Dein Problem löst?!

das ist so, aber dadurch ist jeder data-Wert gerundet, d.h. verändert.  
Hier ist eine Funktion fuhrerIdentify[]

In[142]:= Clear[fuhrerIdentify, partEuclid]
partEuclid[v1_?VectorQ, v2_?VectorQ] :=
  Norm[Most[v1] - Most[v2]] /; Length[v1] == Length[v2];
fuhrerIdentify::tuples =
  "Parameter t = `1`, but only `2` elements present!";
fuhrerIdentify::mod =
  "You can not identify exactly `1`-tuples from the data!";
fuhrerIdentify::res =
  "There will be `1` `2`-tuple(s) and one `3`-tuple in the result.";
fuhrerIdentify[d_ (* data *),
  t_Integer?Positive (* tuple size *),
  verB_: False (* verbose *)] :=
 Module[{r = Flatten[d, 1], rt = 0, rL = 0, t0 = t, rW = {}, x = {}},
   (* prepare *)
   rL = Length[r];
   r = Flatten /@ Transpose[{r, Range[rL]}];
   rW = r;
   (* check *)
   If[t > rL,
    Message[fuhrerIdentify::tuples, t, rL];
    t0 = rL
    ];
   If[Mod[rL, t0] != 0,
    Message[fuhrerIdentify::mod, t0];
    Message[fuhrerIdentify::res, Floor[rL/t0], t0, Mod[rL, t0]]
    ];
   (* work *)
   While[t0 > 1 && Length[rW] > 0,
    x = Nearest[rW, rW[[1]], t0, DistanceFunction -> partEuclid];
    rW = Complement[rW, x];
    (* First[x] === rW[[1]] *)
    r = r /. Thread[Rule[Rest[x], Table[First[x], {Length[x] - 1}]]];
    rt = Max[rt, partEuclid[Last[x], First[x]]]
    ];
   (* report *)
   If[TrueQ[verB],
    If[t0 > 1,
     Print["Trennschärfe = ", rt],
     Print["Trennschärfe > ", rt]
     ];
    Print["Identifications: ",
     Rule @@@ Transpose[{Range[rL], Last /@ r}]]
    ];
   Partition[Most /@ r, Most[Rest[Dimensions[d]]]]
   ] /; ArrayQ[d, _, NumericQ] && ArrayDepth[d] > 1

die in einer Datenmenge auf dem vorletzten Niveau Tupel identifiziert,  
fakultativ über die grösste verwendete Rundung berichtet und die  
Ersetzungen auflistet. fuhrerIdentify[] gibt kein eindeutiges Resultat.


In[149]:= fuhrerIdentify[data, 3, True];

Trennschärfe = 0.24858

Identifications:  
{1->1,2->33,3->27,4->36,5->11,6->38,7->9,8->33,9->9,10->38,11->11,12->36,13->13,14->13,15->15,16->15,17->17,18->17,19->19,20->19,21->21,22->21,23->24,24->24,25->46,26->45,27->27,28->45,29->29,30->29,31->31,32->31,33->33,34->9,35->27,36->36,37->11,38->38,39->19,40->17,41->15,42->31,43->13,44->21,45->45,46->46,47->72,48->46,49->63,50->29,51->63,52->64,53->1,54->1,55->24,56->56,57->72,58->69,59->59,60->59,61->56,62->56,63->63,64->64,65->66,66->66,67->66,68->59,69->69,70->64,71->69,72->72}

Proben:

In[152]:= With[{t = 12},
 (* nur bei Teilbarkeit kann die leere Liste herauskommen *)
 Cases[Tally[Flatten[fuhrerIdentify[data, t], 1]],
  Except[{{_, _, _}, t}]]
 ]

Out[152]= {}

und der corpus delicti:

In[153]:= fuhrerIdentify[data, 2, True];

Trennschärfe = 2.22045*10^-16

Identifications:  
{1->1,2->2,3->3,4->4,5->5,6->6,7->7,8->2,9->9,10->6,11->11,12->4,13->13,14->14,15->15,16->16,17->17,18->18,19->16,20->20,21->18,22->22,23->23,24->14,25->25,26->26,27->27,28->26,29->29,30->30,31->30,32->32,33->7,34->9,35->27,36->3,37->11,38->5,39->20,40->17,41->15,42->32,43->13,44->22,45->25,46->46,47->47,48->46,49->49,50->29,51->49,52->52,53->1,54->54,55->23,56->56,57->47,58->58,59->54,60->60,61->56,62->62,63->52,64->64,65->65,66->62,67->65,68->60,69->69,70->64,71->69,72->58}

10^(-6) wäre also recht grob gerundet und zum Schluss der Graph:


Clear[dataneu, pointsneu, gneu]
dataneu = fuhrerIdentify[data, 2];
pointsneu = Map[ToExpression, dataneu, {2}];
gneu = Sort[Apply[UndirectedEdge, pointsneu, {1}]];
Graph[gneu]

Gruss
Udo.