5
$\begingroup$

I have a list of pairs of functions that intersect at one point, as shown in the image. I am attempting to remove pairs where the domain of both functions in the pair lie on one side of the intersection point, such as in the case of (4, 5, 6). Therefore, the expected output should be the third three pairs (1, 2, 3).

Does anyone have any ideas on how to accomplish this?

One method that comes to mind is selecting a point from each line of the pair, such as point A from line 1 and point B from line 2, which are different from the intersection point. After selecting these points, we can check whether the product (xA - XM) * (xB - XM) is positive or not. Here, M refers to the intersection point of the two lines. If the product is positive, then the pair lies on the same side and can be removed. However, I have noticed that this method does not work well with pair 3, so I am still searching for a more effective solution.

enter image description here

   functions = {
   {ConditionalExpression[-x + 9, x <= 4], 
    ConditionalExpression[2 x - 3, x >= 4]}, {ConditionalExpression[
     2.5 x \[Minus] 5.5, x <= 3], 
    ConditionalExpression[\[Minus]x + 5, 
     x >= 3]}, {ConditionalExpression[3 x + 10, x <= 5], 
    ConditionalExpression[\[Minus]5 x + 30, 
     x <= 4]}, {ConditionalExpression[-0.5 x + 5, x >= 8], 
    ConditionalExpression[0.5 x \[Minus] 3, 
     x >= 8]}, {ConditionalExpression[x, 0 <= x <= 1], 
    ConditionalExpression[\[Minus]0.5 x + 1.5, 
     x <= 1]}, {ConditionalExpression[x, x <= 1], 
    ConditionalExpression[\[Minus]0.5 x + 1.5, x <= 1]}};

(*Plot[Evaluate@Flatten@functions, {x, \
-0,10},GridLines\[Rule]Automatic];*)
(*expected output is the third three pairs*)
(*expectedOut ={{ConditionalExpression[-x+9, x<= 4 \
],ConditionalExpression[2x-3, x>= 4 ] },
 {ConditionalExpression[2.5x\[Minus]5.5, x<= 3 \
],ConditionalExpression[\[Minus]x+5, x>=3 ] },
{ConditionalExpression[3x+10, x<= 5 \
],ConditionalExpression[\[Minus]5x+30, x<=4 ] }};*)

EDIT:

I've added one more pair to the list above to address this case. As you can see, the domains of both functions lie on the same side of the intersection point. However, the current approach used by rhermans - checking whether two functions have the same domains - doesn't work for this particular case.

Plot[{ConditionalExpression[x, 0 <= x <= 1], 
  ConditionalExpression[\[Minus]0.5 x + 1.5, x <= 1]}, {x, -5, 5}]

enter image description here

New Update (05-Jul-2023):

Unfortunately, my posted answer does not actually solve the issue. For example, consider the pairs 3 and 4 in the image below (newly added). It only happens to be correct when the sample points are located on two different sides (left and right) of the intersection point. However, it would yield incorrect results if the sample points are on the same side (either left or right) as the intersection point.

In the combined domain of the two functions in a pair, the combined domain of pairs 1, 2, 3, and 4 are lying on both sides (left and right) of the intersection point. Consequently, I would like to retain these pairs, while pairs 5 and 6 should be eliminated. Therefore, the expected outcome should consist of the first four pairs.

functions = {
   {ConditionalExpression[-x + 9, x <= 4], 
    ConditionalExpression[2 x - 3, x >= 4]},
   {ConditionalExpression[2.5 x \[Minus] 5.5, x <= 3], 
    ConditionalExpression[\[Minus]x + 5, x >= 3]},
   {ConditionalExpression[3 x + 10, x <= 5], 
    ConditionalExpression[\[Minus]5 x + 30, x <= 4]},
   {ConditionalExpression[3 x, 5 <= x <= 9], 
    ConditionalExpression[20 + 1/2 x, x >= 8]},
   {ConditionalExpression[-0.5 x + 5, x >= 8], 
    ConditionalExpression[0.5 x \[Minus] 3, x >= 8]},
   {ConditionalExpression[x, 0 <= x <= 1], 
    ConditionalExpression[\[Minus]0.5 x + 1.5, x <= 1]},
   {ConditionalExpression[x, x <= 1], 
    ConditionalExpression[\[Minus]0.5 x + 1.5, x <= 1]}
   };
Plot[Evaluate@functions, {x, -0, 10}, GridLines -> Automatic]

enter image description here

$\endgroup$

4 Answers 4

5
$\begingroup$

Visualize the functions

$PlotTheme={"Scientific"};
Plot[
Evaluate@functions
, {x, -19,19}
, PlotLegends->Automatic
, PlotRange->{-25,25}
]

enter image description here

Define a test.

test[{f1_,f2_ }]:=Not@SameQ[FunctionDomain[f1,x],FunctionDomain[f2,x]]

Apply the test

test /@ functions
(* {True,True,True,False,False,True} *)

Visualize selection

Plot[
Evaluate@Select[functions, test]
, {x, -19,19}
, PlotLegends->Automatic
, PlotRange->{-25,25}
]

enter image description here

$\endgroup$
5
  • $\begingroup$ Thanks. The code looks pretty clean, but I'm not entirely sure if it always works correctly since it doesn't seem to take the intersection point into account. I'm just thinking about a scenario where it might not work. $\endgroup$
    – hana
    Mar 1, 2023 at 17:36
  • 1
    $\begingroup$ @hana it does work with your example. If you were to extend the examples to edge cases we can address the issue that may appear. Otherwise you are making us guess. $\endgroup$
    – rhermans
    Mar 1, 2023 at 17:37
  • $\begingroup$ Could it be modified to remove this case as well? {ConditionalExpression[x, 0 <= x <= 1], ConditionalExpression[\[Minus]0.5 x + 1.5, x <= 1]} $\endgroup$
    – hana
    Mar 1, 2023 at 17:44
  • 1
    $\begingroup$ @hana please edit your question if you want to modify the goal. Comments is not for that. $\endgroup$
    – rhermans
    Mar 1, 2023 at 17:48
  • $\begingroup$ Done. Technically, it's not an exception since the principle of removal remains the same. However, considering the range same does not always work. $\endgroup$
    – hana
    Mar 1, 2023 at 17:52
2
$\begingroup$

I'll share the solution I came up with several days ago. It may not be the most concise, but it does work. To start, let's visualize the functions:

Plot[#, {x, -10, 10}, PlotRange -> {{-10, 10}, {-10, 30}}, 
   GridLines -> Automatic] & /@ functions

enter image description here

Then, we can write a function to determine whether a given point lies on one side of the function's domains.

ClearAll[removeQ];
removeQ[{function1_, function2_}] := 
 Module[{intersectPoint, point1, point2, cond},
  intersectPoint = 
   Rationalize[ 
    x /. Solve[{function1[[1]] == function2[[1]], function1[[2]], 
        function2[[2]]}, x][[1, 1]]];
  point1 = 
   RandomPoint[
     ImplicitRegion[
      function1[[2]] && 
       x != intersectPoint && (-10 < x < 10), {x}]][[1]];
  point2 = 
   RandomPoint[
     ImplicitRegion[
      function2[[2]] && 
       x != intersectPoint && (-10 < x < 10), {x}]][[1]];
  cond = (point1 - intersectPoint)*(point2 - intersectPoint);
  If[cond > 0, False, True]
  ]


removeQ /@ functions
(* {True, True, True, False, False, False} *)
$\endgroup$
1
$\begingroup$

My attempt:

test[{f1_, f2_}] := !SameQ[Head[Reduce@{FunctionRange[f1, x, y], FunctionRange[f2, x, y]}], Equal]

Plot[Evaluate@Select[Map[Rationalize, functions, {2}], test], {x, 0, 10}, GridLines -> Automatic]

enter image description here

$\endgroup$
1
  • $\begingroup$ Thank you. Unfortunately, it does not work for these two cases. Both of them return "False" while it should be "True". test[{ConditionalExpression[-x, x <= -1], ConditionalExpression[ 1, -1 <= x <= 0]}] and test[{ConditionalExpression[x, 1/2 <= x <= 1], ConditionalExpression[x, x >= 1]}] $\endgroup$
    – hana
    Jul 11, 2023 at 9:58
1
$\begingroup$
functions2 = Join[functions, 
 {{ConditionalExpression[x, 1/2 <= x <= 1], 
   ConditionalExpression[1 - x, 0 <= x <= 1/2]}, 
  {ConditionalExpression[x, 1/2 <= x <= 1], 
   ConditionalExpression[x, x >= 1/2]}}];

Using the functions xBounds and pred from this answer:

xBounds = First @ RegionBounds @
  ImplicitRegion[Or @@ Map[FunctionDomain[{#, 0 <= x <= 10}, x] &] @ #, {x}] &;

pred = FreeQ[{a_Real, a_}] @ N[# /. (List /@ Thread[x -> xBounds[#]])] &;


pred /@ functions2
{True, True, True, True, False, False, False, True, False}  
selected = Select[pred] @ functions2;

Plot[Evaluate @ Flatten @ selected, {x, 0, 10},
 GridLines -> Automatic, ImageSize -> Large,  Frame -> True, 
 Axes -> False,
 PlotLegends -> LineLegend[Flatten@selected, 
   LegendLayout -> (Grid[Map[Row[#, Spacer[5]] &] /@ Partition[#, 2], 
        Alignment -> {Left, Center},
        Dividers -> All,
        FrameStyle -> Directive[AbsoluteThickness[1/2], Gray]] &)]]

enter image description here

styles = Flatten[If[MemberQ[selected, #], 
     {#, #} & @ AbsoluteThickness[2], 
     {#, #} & @ Directive[AbsoluteThickness[5], CapForm["Round"], 
        JoinForm["Round"], Opacity[.5]]] & /@ functions2];

Plot[Evaluate @ Flatten @ functions2, {x, 0, 10}, 
  PlotStyle -> styles,GridLines -> Automatic, ImageSize -> Large, 
  Frame -> True, Axes -> False,
  PlotLegends -> LineLegend[
    Flatten[If[pred @ #, #, 
        Highlighted[#, Background -> None] & /@ #] & /@ functions2], 
    LegendLayout -> (Grid[Map[Row[#, Spacer[5]] &] /@ Partition[#, 2], 
         Alignment -> {Left, Center}, Dividers -> All,             
         FrameStyle -> Directive[AbsoluteThickness[1/2], Gray]] &)]] 

enter image description here

$\endgroup$
3
  • $\begingroup$ Thank you. It's very nice presentaion. The only shortcoming is that not dealing with coline. $\endgroup$
    – hana
    Jul 19, 2023 at 18:58
  • $\begingroup$ can you explain "not dealing with coline"? $\endgroup$
    – kglr
    Jul 19, 2023 at 19:13
  • 1
    $\begingroup$ Sorry, I meant to say colinear lines. I just checked it again and it seems that you actually coved that case as well. {ConditionalExpression[x, 1/2 <= x <= 1], ConditionalExpression[x, x >= 1]}. $\endgroup$
    – hana
    Jul 19, 2023 at 19:22

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge you have read our privacy policy.

Not the answer you're looking for? Browse other questions tagged or ask your own question.