Mengisi Area antara empat Halflines di ProbabilityScalePlot

Question

Gambar berikut menunjukkan bagaimana saya membuat Grafik Weibull untuk memvisualisasikan kekuatan sampel.

Kode dan data yang dibutuhkan ada di bawah. Dalam Epilog ProbabilityScalePlot saya memplot interval kepercayaan untuk data. Saya melakukan ini dengan 4 Garis Setengah berbeda.

halflines={HalfLine[{6.11461, 0}, {-1, -14.1021}], 
 HalfLine[{6.11461, 0}, {1, 22.9597}], 
 HalfLine[{6.15032, 0}, {1, 14.1021}], 
 HalfLine[{6.15032, 0}, {-1, -22.9597}]}

strength={422.918, 488.943, 436.838, 420.08, 481.187, 430.53, 433.959, \
414.308, 468.762, 470.08, 459.893, 428.151, 423.193, 421.472, \
484.492, 463.508, 428.949, 497.333, 470.477, 402.887, 471.617, \
433.492, 415.18, 420.383, 474.359, 447.246, 445.556, 480.03, 459.678, \
448.732}

ProbabilityScalePlot[strength, "Weibull", AspectRatio -> 1.25, 
 PlotRange -> {{300, 600}, {0.5, 99.5}},
 GridLines -> {Range[300, 600, 50], {0.1, 1, 10, 50, 63, 2, 90, 99}},
 Epilog -> {Orange, halflines}]

Saya ingin membuat Filling antara empat HalfLines dengan Opacity rendah untuk presentasi yang lebih bagus. Terima kasih sebelumnya!

Answer 1

psp = ProbabilityScalePlot[strength, "Weibull", AspectRatio -> 1.25, 
   PlotRange -> {{300, 600}, {0.5, 99.5}}, 
   GridLines -> {Range[300, 600, 50], {0.1, 1, 10, 50, 63, 2, 90,  99}}, 
   Epilog -> {Orange, halflines}];

prange = PlotRange[psp] + {{-1, 1}, {-1, 1}};

1. Membangun dua ConicHullRegions dari dua pasang halflines dan mengambil RegionIntersectiondari mereka RegionDifferences dari persegi panjang:

chrs = ConicHullRegion[{#[[1, 1]]}, {#[[1, 2]], #[[2, 2]]}] & /@ 
   Partition[halflines, 2];

regint = RegionIntersection @@ 
   (RegionDifference[Rectangle @@ Transpose[prange], 
       DiscretizeGraphics @ Graphics[#, PlotRange -> prange]] & /@ chrs);

Show[psp, 
 Prolog -> {Show[regint][[1]] /. p_Polygon :> 
    {EdgeForm[], Opacity[.75, LightGreen], p}}]

2. Buat Piecewisefungsi menggunakan RegionMember+ RegionUnionuntuk masing-masing dari dua pasang halfline dan Plotkeduanya dengan opsi Filling:

toPiecewise = FullSimplify[RegionMember[RegionUnion @@ #][{x, y}], {x, y} ∈  Reals] /.
    And[a_, b_] :> {y /. Solve[b, y][[1]], a} /. Or -> (Piecewise[{##}] &) &;

g1[x_] := Evaluate @ toPiecewise @ halflines[[;; 2]]
g2[x_] := Evaluate @ toPiecewise @ halflines[[3 ;;]]

Show[psp, Prolog -> First @ Plot[{g1[x], g2[x]}, {x, ## & @@ prange[[1]]}, 
    PlotStyle -> None, Filling -> {1 -> {{2}, Opacity[.5, LightGreen]}}, 
    Exclusions -> None]]

3. Proses halflinesuntuk mendapatkan koordinat garis dan menyusunnya kembali untuk digunakan dengan Polygonatau FilledCurve:

lcoords = {#, Reverse @ #2} & @@ (SortBy[Last][MeshCoordinates @
   DiscretizeGraphics[Graphics @ #, PlotRange -> prange]] & /@ Partition[halflines, 2]);

Show[psp, Prolog -> {EdgeForm[], Opacity[.5, LightGreen], Polygon[Join @@lcoords]}]

Show[psp,  Prolog -> {EdgeForm[], Opacity[.5, LightGreen], FilledCurve[Line/@ lcoords]}]

gambar yang sama

Answer 2

Clear["`*"];
strength = {422.918, 488.943, 436.838, 420.08, 481.187, 430.53, 
   433.959, 414.308, 468.762, 470.08, 459.893, 428.151, 423.193, 
   421.472, 484.492, 463.508, 428.949, 497.333, 470.477, 402.887, 
   471.617, 433.492, 415.18, 420.383, 474.359, 447.246, 445.556, 
   480.03, 459.678, 448.732};
fig = ProbabilityScalePlot[strength, "Weibull", AspectRatio -> 1.25, 
   PlotRange -> {{300, 600}, {0.5, 99.5}}, 
   GridLines -> {Range[300, 600, 50], {0.1, 1, 10, 50, 63, 2, 90, 
      99}}];
a0 = {6.11461, 0};
a1 = {-1, -14.1021};
a2 = {1, 22.9597};
b0 = {6.15032, 0};
b1 = {1, 14.1021};
b2 = {-1, -22.9597};
reg = RegionIntersection[RegionUnion[HalfPlane[a0, a1, {1, 0}],
    HalfPlane[a0, a2, {1, 0}]],
   RegionUnion[HalfPlane[b0, b1, {-1, 0}],
    HalfPlane[b0, b2, {-1, 0}]]];
Show[fig, 
 RegionPlot[reg, BoundaryStyle -> Orange, 
  PlotStyle -> Directive[Yellow, Opacity[0.1]]]]

Diperbarui

Kita dapat membangun suatu daerah dengan mendeformasi kurva parametrik menjadi kurva {f[y],y}parametrik lain {g[y],y}dengan (1-t)*{f[y],y} + t*{g[y],y}tampilan seperti di bawah ini:

Clear["`*"];
f[y_] = Sin[y];
g[y_] = Sqrt[1 + y^2];
ParametricPlot[{{f[y], y}, {g[y], y}}, {y, -2 Pi, 2 Pi}]
ParametricPlot[(1 - t)*{f[y], y} + t*{g[y], y}, {t, 0, 
  1}, {y, -2 Pi, 2 Pi}, MeshFunctions -> (#3 &), Mesh -> 10]
GraphicsRow[{%%, %}]

Clear["`*"];
strength = {422.918, 488.943, 436.838, 420.08, 481.187, 430.53, 
   433.959, 414.308, 468.762, 470.08, 459.893, 428.151, 423.193, 
   421.472, 484.492, 463.508, 428.949, 497.333, 470.477, 402.887, 
   471.617, 433.492, 415.18, 420.383, 474.359, 447.246, 445.556, 
   480.03, 459.678, 448.732};
fig = ProbabilityScalePlot[strength, "Weibull", AspectRatio -> 1.25, 
   PlotRange -> {{300, 600}, {0.5, 99.5}}, 
   GridLines -> {Range[300, 600, 50], {0.1, 1, 10, 50, 63, 2, 90, 
      99}}];
x1 = 6.11461;
x2 = 6.15032;
k1 = 14.1021;
k2 = 22.9597;
f[y_] := Piecewise[{{x1 + y/k2, y >= 0}, {x1 + y/k1, y < 0}}];
g[y_] := Piecewise[{{x2 + y/k1, y >= 0}, {x2 + y/k2, y < 0}}];
lines = ParametricPlot[{{f[y], y}, {g[y], y}}, {y, -6, 2}, 
   PlotStyle -> {{Thick, Orange}, {Thick, Red}}];
reg = ParametricPlot[{t*f[y] + (1 - t)*g[y], y}, {t, 0, 1}, {y, -6, 
    2}, PlotPoints -> 100, 
   PlotStyle -> Directive[Green, Opacity[0.1]]];
Show[fig, reg, lines]