Mathematica в действии, блог Осипова Романа

Исследование произвольной функции методами математического анализа в системе Mathematica

Нажмите, чтобы скачать данный пост в виде ноутбука Mathematica...

Общее количество использованных в посте встроенных функций или символов: 139

Список имен используемых встроенных функций и символов в порядке их появления в коде:
SetDelayed (:=) | Pattern (:) | Blank (_) | Optional (:) | Function (&) | If | SameQ (===) | Head | Slot (#) | List ({...}) | ReplaceAll (/.) | Reduce | And (&&, ∧) | Element (∈) | Reals | Unequal (!=, ≠) | Denominator | Rule (->, ->) | Or (||, ∨) | Apply (@@) | Cases | FullForm | Flatten | Equal (==) | Alternatives (|) | Inequality | BlankNullSequence (___) | LessEqual (<=, ≤) | Less (<) | GreaterEqual (>=, ≥) | Greater (>) | Infinity | FullSimplify | Plus (+) | Times (*, ×) | GeneratedParameters | Subscript | N | Join | Quiet | Check | False | Limit | Block | CompoundExpression (;) | Set (=) | Map (/@) | Not (!, ¬) | Identity | RuleDelayed (:>, :->) | DeleteDuplicates | FreeQ | Part ([[…]]) | Direction | DirectedInfinity | Span (;;) | All | Symbol | Power (^) | NumericQ | Append | Length | Darker | Red | Thick | Dashed | Tooltip | Line | TraditionalForm | D (∂) | Pane | Alignment | Center | Scrollbars | True | ToRules | Panel | Grid | Style | Row | FontFamily | Bold | TextAlignment | TableForm | ItemStyle | Directive | Background | None | LightGray | White | ItemSize | Automatic | Plot | ImageSize | PlotStyle | ColorFunction | Orange | Blue | Green | PlotLegends | Placed | LineLegend | Wedge (∧) | DownArrow (↓) | Union (∪) | UpArrow (↑) | Intersection (∩) | Bottom | ColorFunctionScaling | Exclusions | PlotPoints | Epilog | AbsolutePointSize | Black | Point | Magenta | Simplify | Brown | String ("...") | Sequence | GridLines | GridLinesStyle | Gray | FrameTicksStyle | AxesStyle | Arrowheads | AxesLabel | Italic | ToString | Frame | LightOrange | Dividers | Rational | Sin | Cos | E (e) | ArcTan | Log | BesselJ

Задача полного исследования функции с помощью методов математического анализа является крайне важной и в целом весьма сложной задачей, так как она требует большого количества вычислений и знаний по работе с понятиями математического анализа (вычисление производных, пределов), решения уравнений, неравенств, сравнения между собой чисел и многое другое.

В данном посте я привожу созданные мной функции для поиска всех необходимых значений и свойств произвольной функции. Все функции, созданные для данного поста реализованы в системе Mathematica, что еще раз демонстрирует безграничную мощь, гибкость и простоту использования этого матического пакета.

Область определения функции

закрыть

DefinitionDomain[expr_, variable_: x] := If[Head[#] === List, #, List[#]] &@(Reduce[Element[expr, Reals] && Denominator[expr] != 0, variable, Reals] /. Or -> List)

Область значений функции

закрыть

RangeValues[expr_, variable_: x] := Reduce[Or @@ Cases[FullForm@ Flatten[Reduce[y == expr, variable, Reals] /. And | Or -> List], Inequality[___, y, ___] | LessEqual[_, y, _] | Less[_, y, _] | y <= _ | y >= _ | y > _ | y < _ | y == _, Infinity], y, Reals]

Выяснение того, к какому классу функций — четных или нечетных, принадлежит функция

закрыть

OddEvenTest[expr_, variable_: x] := If[FullSimplify[expr - (expr /. variable -> -variable) === 0], "четная", If[FullSimplify[expr + (expr /. variable -> -variable) === 0], "нечетная", "общего вида"]]

Периодичность функции

закрыть

Periodicity[expr_, variable_] := If[Periodic`PeriodicFunctionQ[expr, variable], {"функция периодична", Periodic`PeriodicFunctionPeriod[expr, variable]}, "функция не периодична"]

Поиск нулей функции (точек пересечения с осью абсцисс)

закрыть

FunctionZeros[expr_, {min_, max_}, variable_: x] := Flatten@{Reduce[expr == 0, variable, Reals, GeneratedParameters -> (Subscript[\[Lambda], #] &)], {#, N[#]} &@ Reduce[{expr == 0, min <= variable <= max}, variable, Reals]}

Значение функции в нуле (пересечение с осью ординат)

закрыть

FunctionValueInZero[expr_, variable_: x] := If[FullSimplify[ And @@ DefinitionDomain[expr, variable]~Join~{variable == 0}] || Quiet@Check[Element[expr /. variable -> 0, Reals], False], {expr /. variable -> 0}, If[Element[#, Reals], {#, "limit"}, {"не существует"}] &@ Limit[expr, x -> 0]]

Поиск вертикальных асимптот функции

закрыть

VerticalAsymptotes[expr_, variable_: x] := Quiet@Block[{points, limits, val, val1, val2}, points = If[Head[#] === List, #, List[#]] &@(Reduce[{Element[variable, Reals]}~ Join~(Not /@ DefinitionDomain[expr, variable]), variable, Reals] /. Or -> List); limits = Identity @@ (FullForm[points] /. {\!\(\*TagBox[StyleBox[RowBox[{"variable", "<", "val_"}],ShowSpecialCharacters->False,ShowStringCharacters->True,NumberMarks->True],FullForm]\) | variable <= val_ :> {{val, 1}}, \!\(\*TagBox[StyleBox[RowBox[{"variable", ">", "val_"}],ShowSpecialCharacters->False,ShowStringCharacters->True,NumberMarks->True],FullForm]\) | variable >= val_ :> {{val, -1}}, ((val1_ < variable < val2_) | (val1_ < variable <= val2_) | (val1_ <= variable < val2_) | (val1_ <= variable <= val2_) | (Inequality[ val1_, Less, variable, Less, val2_]) | (Inequality[val1_, LessEqual, variable, LessEqual, val2_]) | (LessEqual[ val1_, variable, val2_]) :> {{val1, -1}, {val2, 1}}), (variable == val_ :> {{val, 1}, {val, -1}})}); DeleteDuplicates[ Flatten[If[ And @@ (FreeQ[ Limit[expr, variable -> #[[1]], Direction -> #[[2]]], Infinity | DirectedInfinity] & /@ #), {}, #[[;; , 1]]] & /@ limits]] /. {Symbol[]} -> {}]

Поиск наклонных и горизонтальных асимптот функции

закрыть

InclinedAsymptotes[expr_, {xMin_, xMax_}, variable_: x] := Block[{kP, bP, kN, bN, asymptotes}, (kP = Limit[expr/variable, variable -> Infinity]; kN = Limit[expr/variable, variable -> -Infinity]; If[NumericQ[kP], bP = Limit[expr - kP*variable, variable -> Infinity]; If[NumericQ[bP], asymptotes = {kP*variable + bP}, asymptotes = {}], asymptotes = {}]; If[NumericQ[kN], bN = Limit[expr - kN*variable, variable -> -Infinity]; If[NumericQ[bN], asymptotes = Append[asymptotes, kN*variable + bN], asymptotes], asymptotes]; If[Length[asymptotes] == 2, {DeleteDuplicates@asymptotes, DeleteDuplicates@{Darker@Red, Thick, Dashed, Tooltip[Line[{{xMin, asymptotes[[1]] /. variable -> xMin}, {xMax, asymptotes[[1]] /. variable -> xMax}}], TraditionalForm@(y == asymptotes[[1]])], Tooltip[Line[{{xMin, asymptotes[[2]] /. variable -> xMin}, {xMax, asymptotes[[2]] /. variable -> xMax}}], TraditionalForm@(y == asymptotes[[2]])]}}, If[Length[asymptotes] == 1, {asymptotes, {Darker@Red, Dashed, Thick, Tooltip[Line[{{xMin, asymptotes[[1]] /. variable -> xMin}, {xMax, asymptotes[[1]] /. variable -> xMax}}], TraditionalForm@(y == asymptotes[[1]])]}}, asymptotes]])]

Поиск точек экстремума

закрыть

ExtremumPoints[expr_, {min_, max_}, variable_: x] := Flatten@{Reduce[{D[expr, variable] == 0 || 1/D[expr, variable] == 0, Element[expr, Reals]}, variable, Reals, GeneratedParameters -> (Subscript[\[Mu], #] &)], {#, N[#]} &@ Reduce[{D[expr, variable] == 0 || 1/D[expr, variable] == 0, Element[expr, Reals], min <= variable <= max}, variable, Reals]}

Поиск точек перегиба

закрыть

InflectionPoints[expr_, {min_, max_}, variable_: x] := Flatten@{Reduce[{D[expr, {variable, 2}] == 0 || 1/D[expr, {variable, 2}] == 0, Element[expr, Reals]}, variable, Reals, GeneratedParameters -> (Subscript[\[Xi], #] &)], {#, N[#]} &@Reduce[{D[expr, {variable, 2}] == 0 || 1/D[expr, {variable, 2}] == 0, Element[expr, Reals], min <= variable <= max}, variable, Reals]}

Создание функции, создающий отчет по анализу произвольной функции

закрыть

fixSize[object_, height_] := Pane[object, {380, height}, Alignment -> {Center, Center}, Scrollbars -> {True, True}]

закрыть

pointsFromRules[rules_, variable_: x] := variable /. List[ToRules[rules]]

закрыть

FullFunctionAnalysis[expr_, {min_, max_}, makePlot_: True, variable_: x] := Block[{d1, d2, FunctionZeros$, ExtremumPoints$, InflectionPoints$, FunctionValueInZero$, VerticalAsymptotes$, InclinedAsymptotes$}, d1 = D[expr, variable]; d2 = D[expr, {variable, 2}]; Panel@Grid[{{Style[ Row[{"Исследование функции ", Style[TraditionalForm[expr], Red]}], FontFamily -> "Myriad Pro Cond", 30]}, {If[ DefinitionDomain[expr, variable] === {False}, Style[ Row[{Style["Область значений: ", 20, Bold], Style[Row[{variable, "\[Element]\[EmptySet]"}], 20, Bold], "\nФункция не определена ни в одной точке множества \\[DoubleStruckCapitalR], дальнейшее иссследование невозможно"}], 20, FontFamily -> "Myriad Pro Cond"], FunctionZeros$ = FunctionZeros[expr, {min, max}, variable]; ExtremumPoints$ = Quiet[ExtremumPoints[expr, {min, max}, variable]]; InflectionPoints$ = Quiet[InflectionPoints[expr, {min, max}, variable]]; FunctionValueInZero$ = FunctionValueInZero[expr, variable]; VerticalAsymptotes$ = VerticalAsymptotes[expr, variable]; InclinedAsymptotes$ = InclinedAsymptotes[expr, {min, max}, variable]; Grid[{{"Область определения:", fixSize[ TraditionalForm[(DefinitionDomain[expr, variable] /. List -> Or /. {Or[True] -> Row[{variable, "\[Element]\[DoubleStruckCapitalR]"}], Or[False] -> Row[{variable, "\[Element]\[EmptySet]"}]})], 80]}, {"Область значений:", fixSize[ TraditionalForm[ Quiet[Check[RangeValues[expr, variable], "аналитические значения не удается найти"]] /. True -> "y\[Element]\[DoubleStruckCapitalR]"], 80]}, {"Нули функции:", fixSize[ TraditionalForm[ FunctionZeros$[[1]] /. False -> Row[{variable, "\[Element]\[EmptySet]"}] /. True -> Row[{variable, "\[Element]\[DoubleStruckCapitalR]"}]], 80]}, {Style[ Row[{"Нули функции на отрезке\n[", min, "; ", max, "]:"}], TextAlignment -> Center], fixSize[ TableForm[TraditionalForm /@ FunctionZeros$[[{2, 3}]]], 80]}, {"Функция в нуле:", fixSize[ TraditionalForm[ If[Length[#] == 1, #[[1]], Row[{"\!\(\*UnderscriptBox[\(lim\), \(x \[Rule] \0\)]\)(", expr, ")=", #[[1]]}]]], 80] &@ FunctionValueInZero$}, {"Периодичность:", fixSize[ If[Length[#] == 0, Periodicity[expr, variable], Row[{#[[1]], "\n", "наименьший период равен ", TraditionalForm[#[[2]]]}]] &@ Periodicity[expr, variable], 80]}, {"Четность/нечетность:", fixSize[OddEvenTest[expr, variable], 80]}, {"Вертикальные асимптоты:", fixSize[ If[Length[#] == 0, "отсутствуют", TableForm[TraditionalForm[variable == #] & /@ #]] &@ VerticalAsymptotes$, 80]}, {"Наклонные асимптоты:", fixSize[ If[Length[#] == 0, "отсутствуют", TableForm[TraditionalForm[y == #] & /@ #[[1]]]] &@ InclinedAsymptotes$, 80]}, {"Точки экстремума:", fixSize[ If[Head[#] === Reduce, "аналитические значения не удается найти", TraditionalForm@(# /. False -> Row[{variable, "\[Element]\[EmptySet]"}])] &@ ExtremumPoints$[[1]], 80]}, {Style[ Row[{"Точки экстремума на отрезке\n [", min, "; ", max, "]:"}], TextAlignment -> Center], fixSize[ TableForm[ TraditionalForm /@ (ExtremumPoints$[[{2, 3}]] /. False -> Row[{variable, "\[Element]\[EmptySet]"}])], 80]}, {"Точки перегиба:", fixSize[ If[Head[#] === Reduce, "аналитические значения не удается найти", TraditionalForm@(# /. False -> Row[{variable, "\[Element]\[EmptySet]"}])] &@ InflectionPoints$[[1]], 80]}, {Style[ Row[{"Точки перегиба на отрезке\n [", min, "; ", max, "]:"}], TextAlignment -> Center], fixSize[ TableForm[ TraditionalForm /@ (InflectionPoints$[[{2, 3}]] /. False -> Row[{variable, "\[Element]\[EmptySet]"}])], 80]}}, ItemStyle -> Directive[FontFamily -> "Myriad Pro Cond", 20], Background -> {None, {None, {LightGray, White}}}, ItemSize -> {{15, 34}, Automatic}, Alignment -> {Center, Center}]]}, {Quiet@ Plot[expr, {variable, min, max}, ImageSize -> 580, PlotStyle -> Thick, ColorFunction -> Function[{x, y}, If[d2 > 0 && d1 > 0, Red, If[d2 < 0 && d1 > 0, Orange, If[d2 > 0 && d1 < 0, Blue, Green]]]], PlotLegends -> Placed[LineLegend[{Red, Orange, Blue, Green}, {"y'>0\[Wedge]y''>0 | \[DownArrow] \[Union]", "y'>0\[Wedge]y''<0 | \[UpArrow] \[Intersection]", "y'<0\[Wedge]y''>0 | \[DownArrow] \[Union]", "y'<0\[Wedge]y''<0 | \[UpArrow] \[Intersection]"}], Bottom], ColorFunctionScaling -> False, Exclusions -> expr, PlotPoints -> 1300, Epilog -> Quiet[{{AbsolutePointSize[7], Black, Point[{#, 0}], AbsolutePointSize[3], White, Tooltip[Point[{#, 0}], {#, 0}]} & /@ If[Length[FunctionZeros$[[2]]] == 0, {}, pointsFromRules[FunctionZeros$[[2]]]], {AbsolutePointSize[9], Magenta, Point[{#, Quiet@Check[Simplify[expr /. variable -> #], 10^10]}], AbsolutePointSize[5], White, Tooltip[ Point[{#, Quiet@Check[Simplify[expr /. variable -> #], 10^10]}], {#, Simplify[Simplify[expr /. variable -> #]]}]} & /@ If[Length[ExtremumPoints$[[2]]] == 0, {}, pointsFromRules[ExtremumPoints$[[2]]]], {AbsolutePointSize[11], Brown, Point[{#, Quiet@Check[Simplify[expr /. variable -> #], 10^10]}], AbsolutePointSize[7], White, Tooltip[ Point[{#, Quiet@Check[Simplify[expr /. variable -> #], 10^10]}], {#, Quiet@Check[Simplify[expr /. variable -> #], 10^10]}]} & /@ If[Length[InflectionPoints$[[2]]] == 0, {}, pointsFromRules[ InflectionPoints$[[2]]]], {AbsolutePointSize[7], Darker@Green, Point[{0, #}], AbsolutePointSize[3], White, Tooltip[Point[{0, #}], {0, #}]} & /@ If[Length[FunctionValueInZero$] == 0 || Head[FunctionValueInZero$[[1]]] === String, Sequence[{}], FunctionValueInZero$], If[Length[InclinedAsymptotes$] == 0, Sequence[{}], InclinedAsymptotes$[[2]]]}], GridLines -> If[Length[VerticalAsymptotes$] == 0, None, {VerticalAsymptotes$, None}], GridLinesStyle -> Directive[Dashed, Thick, Darker@Gray], FrameTicksStyle -> Directive[Bold, 14, FontFamily -> "Myriad Pro Cond"], AxesStyle -> Arrowheads[{0, 0.03}], AxesLabel -> (Style[#, Bold, 18, Italic, FontFamily -> "Myriad Pro Cond"] & /@ {ToString@ variable, "y"}), Frame -> True]}}[[ If[makePlot, All, {1, 2}]]], Alignment -> {Center, Center}, Background -> {None, {LightOrange, None}}, Dividers -> 1, ItemSize -> 49]]

Несколько примеров работы созданных функций

Протестируем созданные функции для проведения полного анализа произвольной функции методами математического анализа с помощью примеров из задачника Демидовича (на рисунке ниже взята страница 162 из задачника, номера ниже соответствуют номерам в задачнике).

Анализ функции 1483:

закрыть

FullFunctionAnalysis[1/(1 + x) - 10/(3 x^2) + 1/(1 - x), {-6, 6}]

Анализ функции 1496*:

закрыть

FullFunctionAnalysis[Sqrt[(3 + x^4)/(1 + x^2)], {-6, 6}]

Анализ функции 1504.1:

закрыть

FullFunctionAnalysis[Sin[x]/(2 + Cos[x]), {-10, 10}]

Анализ функции 1506:

закрыть

FullFunctionAnalysis[E^(2 x - x^2), {-3, 3}]

Анализ функции 1518: x ArcTan[x]

закрыть

FullFunctionAnalysis[x ArcTan[x], {-2, 2}]

Анализ функции 1523*:

закрыть

FullFunctionAnalysis[Log[(2 - 3 x + x^2)/(1 + x^2)], {-10, 10}]

Анализ функции 1530*:

закрыть

FullFunctionAnalysis[E^(1/(1 - x^2))/(1 + x^2), {-7/2, 7/2}]

Еще несколько примеров: некоторые произвольные функции, например, и

закрыть

FullFunctionAnalysis[Cos[x] Cos[Sqrt[2] x] Cos[Sqrt[3] x], {-10, 10}]

закрыть

FullFunctionAnalysis[(2 - x + x^2 - x^3)/(1 + x^2) + ( 1 + x - x^2 + x^3)/(1 + x^4), {-6, 6}]

Построенные функции позволяют производить анализ функции, содержащей один и более произвольных параметров

закрыть

FullFunctionAnalysis[a/(b + x^2), {-6, 6}, False]

Также функции могут содержать специальные функции, например функцию Бесселя

закрыть

FullFunctionAnalysis[BesselJ[0, x], {0, 20}]

Блог принадлежит “Русскоязычной поддержке Wolfram Mathematica"©
При любом использовании материалов блога, ссылка на блог обязательна.
Создано с помощью Wolfram Mathematica 9