在 Mathematica 中绘制数轴答案

【问题标题】：Plotting a number line in Mathematica在 Mathematica 中绘制数轴
【发布时间】：2011-07-23 01:22:19
【问题描述】：

我想在 Mathematica 的数轴上绘制一个简单的区间。我该怎么做？

【问题讨论】：

你能准确描述你想要什么吗？你想要开放和封闭的点还是开放的括号和封闭的括号？您只需要相关数字还是重要数字之间的一系列数字？
演示Number Line Solutions to Absolute Value Equations and Inequalities很好地绘制了一个简单的区间。

【解决方案1】：

要绘制开放或封闭间隔，您可以执行以下操作：

intPlot[ss_, {s_, e_}, ee_] := Graphics[{Red, Thickness[.01],
   Text[Style[ss, Large, Red, Bold], {s, 0}],
   Text[Style[ee, Large, Red, Bold], {e, 0}],
   Line[{{s, 0}, {e, 0}}]},
  Axes -> {True, False},
  AxesStyle -> Directive[Thin, Blue, 12],
  PlotRange -> {{ s - .2 Abs@(s - e), e + .2 Abs@(s - e)}, {0, 0}},
  AspectRatio -> .1]

intPlot["[", {3, 4}, ")"]

编辑

以下是@Simon 所做的不错的扩展，可能被我再次宠坏了，试图解决重叠间隔问题。

intPlot[ss_, {s_, e_}, ee_] := intPlot[{{ss, {s, e}, ee}}]
intPlot[ints : {{_String, {_?NumericQ, _?NumericQ}, _String} ..}] :=
 Module[{i = -1, c = ColorData[3, "ColorList"]},
  With[
   {min = Min[ints[[All, 2, 1]]], max = Max[ints[[All, 2, 2]]]},
   Graphics[Table[
     With[{ss = int[[1]], s = int[[2, 1]], e = int[[2, 2]], ee = int[[3]]}, 
       {c[[++i + 1]], Thickness[.01],
       Text[Style[ss, Large, c[[i + 1]], Bold], {s, i}], 
       Text[Style[ee, Large, c[[i + 1]], Bold], {e, i}],
       Line[{{s, i}, {e, i}}]}], {int, ints}], 
    Axes -> {True, False}, 
    AxesStyle -> Directive[Thin, Blue, 12], 
    PlotRange -> {{min - .2 Abs@(min - max), max + .2 Abs@(min - max)}, {0, ++i}}, 
    AspectRatio -> .2]]]

(*Examples*)

intPlot["[", {3, 4}, ")"]
intPlot[{{"(", {1, 2}, ")"}, {"[", {1.5, 4}, ")"}, 
        {"[", {2.5, 7}, ")"}, {"[", {1.5, 4}, ")"}}]

【讨论】：

+1，但你介意我编辑上面的内容以概括多个间隔吗？
@Simon 重叠间隔会破坏情节。我认为为此需要另一种可视化策略:(
是的。我只在非重叠间隔上测试了我对您的代码的修改。您需要先手动简化/减少...
@Simon 无论如何，如果您认为这是一种改进，请随时编辑我的答案或发布新答案！
经过反思，它会破坏您答案的清晰度。 Here's我在 pastebin 上的代码扩展。

【解决方案2】：

这是另一种尝试，它使用更传统的白色和黑色圆圈绘制数字线，尽管您可以轻松更换任何您想要的图形元素。

它依赖LogicalExpand[Simplify@Reduce[expr, x]] 和Sort 将表达式转换为类似于替换规则可以处理的规范形式。这没有经过广泛的测试，可能有点脆弱。例如，如果给定的 expr 减少到 True 或 False，我的代码不会优雅地死掉。

numLine[expr_, x_Symbol:x, range:{_, _}:{Null, Null}, 
  Optional[hs:_?NumericQ, 1/30], opts:OptionsPattern[]] := 
 Module[{le = {LogicalExpand[Simplify@Reduce[expr, x]]} /. Or -> List,
   max, min, len, ints = {}, h, disk, hArrow, lt = Less|LessEqual, gt = Greater|GreaterEqual},
  If[TrueQ@MatchQ[range, {a_, b_} /; a < b],
   {min, max} = range,
   {min, max} = Through[{Min, Max}@Cases[le, _?NumericQ, \[Infinity]]]];
  len =Max[{max - min, 1}]; h = len hs;
  hArrow[{x1_, x2_}, head1_, head2_] := {{Thick, Line[{{x1, h}, {x2, h}}]},
                                         Tooltip[head1, x1], Tooltip[head2, x2]};
  disk[a_, ltgt_] := {EdgeForm[{Thick, Black}], 
    Switch[ltgt, Less | Greater, White, LessEqual | GreaterEqual, Black], 
    Disk[{a, h}, h]};
  With[{p = Position[le, And[_, _]]}, 
       ints = Extract[le, p] /. And -> (SortBy[And[##], First] &); 
       le = Delete[le, p]];   
  ints = ints /. (l1 : lt)[a_, x] && (l2 : lt)[x, b_] :> 
     hArrow[{a, b}, disk[a, l1], disk[b, l2]];
  le = le /. {(*_Unequal|True|False:>Null,*)
     (l : lt)[x, a_] :> (min = min - .3 len; 
       hArrow[{a, min}, disk[a, l], 
        Polygon[{{min, 0}, {min, 2 h}, {min - Sqrt[3] h, h}}]]),
     (g : gt)[x, a_] :> (max = max + .3 len; 
       hArrow[{a, max}, disk[a, g], 
        Polygon[{{max, 0}, {max, 2 h}, {max + Sqrt[3] h, h}}]])};
  Graphics[{ints, le}, opts, Axes -> {True, False}, 
   PlotRange -> {{min - .1 len, max + .1 len}, {-h, 3 h}},
   GridLines -> Dynamic[{{#, Gray}} & /@ MousePosition[
                           {"Graphics", Graphics}, None]], 
   Method -> {"GridLinesInFront" -> True}]
  ]

（注意：我最初尝试使用Arrow 和Arrowheads 来绘制线条 - 但由于Arrowheads 自动根据包围图形的宽度重新调整箭头，这让我非常头疼.)

好的，一些例子：

numLine[0 < x], 
numLine[0 > x]
numLine[0 < x <= 1, ImageSize -> Medium]

numLine[0 < x <= 1 || x > 2, Ticks -> {{0, 1, 2}}]

numLine[x <= 1 && x != 0, Ticks -> {{0, 1}}]

GraphicsColumn[{
  numLine[0 < x <= 1 || x >= 2 || x < 0],
  numLine[0 < x <= 1 || x >= 2 || x <= 0, x, {0, 2}]
  }]

编辑：让我们将上面的输出与Wolfram|Alpha的输出进行比较

WolframAlpha["0 < x <= 1 or x >= 2 or x < 0", {{"NumberLine", 1}, "Content"}]
WolframAlpha["0 < x <= 1 or x >= 2 or x <= 0", {{"NumberLine", 1}, "Content"}]

注意（在 Mathematica 会话或 W|A 网站上查看上述内容时）重要点上的精美工具提示和灰色动态网格线。我窃取了这些想法并将它们合并到上面编辑过的numLine[] 代码中。

WolframAlpha 的输出不是一个普通的Graphics 对象，因此很难修改其Options 或使用Show 组合。要查看 Wolfram|Alpha 可以返回的各种数字线对象，请运行 WolframAlpha["x>0", {{"NumberLine"}}] - “内容”、“单元格”和“输入”都返回基本相同的对象。无论如何，要从

获取图形对象

wa = WolframAlpha["x>0", {{"NumberLine", 1}, "Content"}]

例如，您可以运行

Graphics@@First@Cases[wa, GraphicsBox[__], Infinity, 1]

然后我们可以修改图形对象，将它们组合成一个网格得到

【讨论】：

谢谢！昨晚我还记得 Wolfram|Alpha 可以绘制数字线；例如0<x<=1 or x>2
很好，但是:) 为什么为什么我要下载输出的 Mathematica 笔记本，如果它不可用？

【解决方案3】：

这是一个使用RegionPlot 的丑陋解决方案。开放限制用虚线表示，封闭限制用实线表示

numRegion[expr_, var_Symbol:x, range:{xmin_, xmax_}:{0, 0}, opts:OptionsPattern[]] :=
            Module[{le=LogicalExpand[Reduce[expr,var,Reals]],
                    y, opendots, closeddots, max, min, len},
 opendots =   Cases[Flatten[le/.And|Or->List], n_<var|n_>var|var<n_|var>n_:>n];
 closeddots = Cases[Flatten[le/.And|Or->List], n_<=var|n_>=var|var<=n_|var>=n_:>n];
 {max, min} = If[TrueQ[xmin < xmax], {xmin, xmax}, 
                 {Max, Min}@Cases[le, _?NumericQ, Infinity] // Through];
 len = max - min;
 RegionPlot[le && -1 < y < 1, {var, min-len/10, max+len/10}, {y, -1, 1},
            Epilog -> {Thick, Red, Line[{{#,1},{#,-1}}]&/@closeddots,
                       Dotted, Line[{{#,1},{#,-1}}]&/@opendots},
            Axes -> {True,False}, Frame->False, AspectRatio->.05, opts]]

一个减少绝对值的例子：

numRegion[Abs[x] < 2]

可以使用任何变量：

numRegion[0 < y <= 1 || y >= 2, y]

Reduces 无关的不等式，比较以下：

GraphicsColumn[{numRegion[0 < x <= 1 || x >= 2 || x < 0],
                numRegion[0 < x <= 1 || x >= 2 || x <= 0, x, {0, 2}]}]

【讨论】：

【解决方案4】：

从 Mathematica 10 开始，NumberLinePlot 可用。

【讨论】：

【解决方案5】：

之前的丑陋解决方案帮助我开发了 InequalityPlot 函数来解决和绘制两个变量中的不等式。

InequalityPlot[ineq_, {x_Symbol, xmin_, xmax_},{y_Symbol, ymin_, ymax_},
  opts : OptionsPattern[Join[Options[ContourPlot],
    Options[RegionPlot], {CurvesColor -> RGBColor[1, .4, .2]}]]] :=
 Module[{le = LogicalExpand[ineq], opencurves, closedcurves, curves},
  opencurves = Cases[Flatten[{le /. And | Or -> List}],
   lexp_ < rexp_ | lexp_ > rexp_ | lexp_ < rexp_ | lexpr_ > rexp_ :>
    {lexp == rexp, Dashing[Medium]}];
  closedcurves = Cases[Flatten[{le /. And | Or -> List}],
   lexp_ <= rexp_ | lexp_ >= rexp_ | lexp_ <= rexp_ | lexp_ >= rexp_ :>
    {lexp == rexp, Dashing[None]}];
  curves = Join[opencurves, closedcurves];
  Show[  RegionPlot[ineq, {x, xmin, xmax}, {y, ymin, ymax},
    BoundaryStyle -> None,
    Evaluate[Sequence @@ FilterRules[{opts}, Options[RegionPlot]]]],
   ContourPlot[First[#] // Evaluate, {x, xmin, xmax}, {y, ymin, ymax},
      ContourStyle -> Directive[OptionValue[CurvesColor], Last[#]],
      Evaluate[Sequence @@ FilterRules[{opts},
         Options[ContourPlot]]]] & /@ curves  ]
 ]

这里有两个例子：

InequalityPlot[0.5 <= x^2 + y^2 < 1, {x, -1, 1}, {y, -1, 1}]

InequalityPlot[x^2 + y^2 < 0.5 && x + y <= 0.5,{x, -1, 1}, {y, -1, 1}]

【讨论】：

【解决方案6】：

做一个普通的Plot，并设置Axes -> {True, False}（如果存在则隐藏边界框，通常不存在）。适当调整图像大小或纵横比。

例如

Plot[
    Piecewise[{
        {0, And[0<x, x<1]}
    }],
    {x,-1,2},
    Axes -> {True, False}        
]

您可以使用Show 将其与开闭点的想象结合起来。

如果您没有正确设置线宽或类似参数，您可能需要将 Indeterminate 或其他一些特殊值作为第二个参数传递给 Piecewise（否则默认为 0）的可能性很小绘图风格；或者，或者，但更可靠的是，将值设置为 999 和 PlotRange -> {{-1,2},{-.1,.1}}。

【讨论】：

您的代码不起作用。您缺少一个绘图域，您的 Piecewise 等效于函数 f(x)=0...
@Simon：我在回答中警告过这一点。感谢您提及情节域。