Sende diese Email erneut aufgrund folgender Korrekturen:
1. Erscheinen auf der Mathgroup Liste ist nun der 21. Mai.
2. Austausch des Notebooks im Anhang durch PNG Bild.
Hallo Udo,
vielen Dank für Deine Antwort.
Ich muss allerdings gestehen, dass ich sie nicht sofort verstanden habe
und mich nach Olivers Antwort auch nicht mehr darum bemüht habe, da sie
etwas kompliziert aussieht.
Daher möchte ich hier noch ein etwas einfacheres Beispiel zum Entfernen
von Punkten zeigen, welches ich basierend auf der Lösung von Oliver und
Daniel von der MathGroup Liste entwickelt habe:
==
(*RemovePoints.nb*)
Needs["DifferentialEquations`InterpolatingFunctionAnatomy`"];
n = 6; y = RandomReal[{-1, 1}, n];
f[r_] = Interpolation[y][r];
points = Select[First[InterpolatingFunctionCoordinates[f[r][[0]]]],
Not[.4 n < # < .7 n] &];
(*points = Select[f[r][[0]][[3, 1]], Not[.4 n < # < .7 n] &];*)
f2[r_] = Interpolation[
Transpose[{Transpose[{points}], f[points], f'[points]}]][r];
Show[
Plot[f[r], {r, 1, n}, PlotRange -> {{1, n}, {-1.5, 1.5}}],
Plot[f2[r], {r, 1, n}, PlotStyle -> Hue[0.9]],
ListPlot[y, PlotStyle -> PointSize[0.03]],
ListPlot[Transpose[{points, f[points]}],
PlotStyle -> {PointSize[0.02], Hue[0.9]}]]
==
Die auskommentierte Zeile zeigt noch eine alternative kürzere Lösung
ohne das Paket `InterpolatingFunctionAnatomy`. Allerdings sorgt jedoch
dieses Pakets für die Kompatibilität zu anderen Mathematica-Version.
(http://reference.wolfram.com/mathematica/tutorial/NDSolvePackages.html)
Man kann dieses Beispiel jetzt auch über die Mathgroup Liste (21. Mai)
finden: http://forums.wolfram.com/mathgroup/archive/2010/May/ .
Noch einmal vielen Danke und viele Grüße
Frank
On 2010-05-17 20:25, Udo und Susanne Krause wrote:
> Wenn man den letzten Punkt in Piecewise[] einschliesst, wird die erste
> Ableitung dortselbst ordentlich:
>
>
> Clear[breitlingWegbedungen]
> breitlingWegbedungen[f_InterpolatingFunction, l_List] :=
> Block[{x, x1, x2, x3, x4},
> {x1, x2, x3, x4} = l;
> Check[f[x1], Return[$Failed]];
> Check[f[x2], Return[$Failed]];
> Check[f[x3], Return[$Failed]];
> Check[f[x4], Return[$Failed]];
> FunctionInterpolation[
> Piecewise[{{f[x], x1 <= x < x2},
> {(f[x2] (x3 - x) + f[x3] (x - x2))/(x3 - x2) ,
> x2 <= x < x3}, {f[x], x3 <= x <= x4}}, 0], {x, x1, x4},
> InterpolationPoints -> Floor[x4 - x1]^2, MaxRecursion -> 12
> ]
> ] /; VectorQ[l, NumericQ] && Less @@ l
>
>
> Gruss++
> Udo.
>
> On Mon, 17 May 2010 10:39:11 +0200, Frank Breitling <fbreitling@XXXXXXX.de>
> wrote:
>
>> Hallo,
>>
>> ich habe eine Interpolating Function die in einem kleinen Intervall
>> viele ungenaue Werte enthält. Daher würde ich gerne alle Werte in diesem
>> Intervall entfernen.
>> Ich habe es bereits mit Piecewise und Condition (/;) versucht, das
>> Intervall zu korrigieren. Eine so definierte Funktion verursacht aber
>> dann auf Grund ihrer komplexeren Gestalt Probleme in meinen weiteren
>> Rechnungen.
>> Daher möchte ich die ursprüngliche InterpolatingFuction behalten und nur
>> die problematischen Punkte entfernen.
>> Wie ginge das?
>>
>> Viele Grüße
>>
>> Frank
>>
>>
>
RemovePoints.png
Description: PNG image
