AW: Numerischer Fehler

["Stefan Fuhrer" <stefan.fuhrer@XXXXXXX.com>]

Hallo Udo,
Zuerst besten Dank für diese sehr ausführliche Hilfe! Ich werde aber noch
ein paar Stunden investieren, um zu verstehen was da genau abgeht, da
einiges komplett neu ist für mich. Ich hoffe dies heute Abend machen zu
können.

Grues stefan

-----Ursprüngliche Nachricht-----
Von: Udo und Susanne Krause [mailto:su.krause@XXXXXXX.ch] 
Gesendet: Sonntag, 20. März 2011 14:19
An: Stefan Fuhrer; Markus van Almsick
Cc: demug@XXXXXXX.ch
Betreff: Re: Numerischer Fehler

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,4
6->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,6
8->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->4
7,48->46,49->49,50->29,51->49,52->52,53->1,54->54,55->23,56->56,57->47,58->5
8,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.