https://community.wolfram.com RSS Feed for Wolfram Community showing any discussions tagged with Operations Research sorted by most likes. https://community.wolfram.com/groups/-/m/t/2026904 ![frontimage][1] &[Wolfram Notebook][2] [1]: https://community.wolfram.com//c/portal/getImageAttachment?filename=imagefront.jpg&userId=1316061 [2]: https://www.wolframcloud.com/obj/88bd85e6-8a15-4fe1-ab85-7da71b0ce10b Claudio Chaib 2020-07-14T02:04:22Z https://community.wolfram.com/groups/-/m/t/820972 ![Cops and Robbers (or Zombies and Humans): pursuit-evasion games][1] ![Cops and Robbers (or Zombies and Humans): pursuit-evasion games][2] Cops and Robbers is a mathematical game in which pursuers (cops) attempt to capture evaders (robbers). The game is one of many [pursuit-evasion games][3], each of which is governed by a [different][4] set of rules. The general goal of these problems is to determine the number of pursuers required to capture a given number of evaders. The GIFs above show two versions of the game. The first is similar to the standard Cops and Robbers rendition, and the second is best described as "Zombies and Humans". In both versions, an evader moves in the direction that gets it furthest away from the pursuers (focusing more on the closer pursuers), and a pursuer moves in the direction that gets it closest to the evaders (focusing more on the closer evaders). - In the first simulation, members of both groups have a constant speed. - In the second simulation, members of a group move more quickly the closer they are to members of the opposite group, and slower when further away. Additional sources not linked above: ------------------------------------ - [How to make a point's position time-dependent given a formula for the next step?][5] - [Cops and Robbers (see also attached)][6] ---------- [*Originally published at FOURIEST SERIES*][7] Code: ----- &[Wolfram Notebook][8] [1]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ezgif-940093865.gif&userId=11733 [2]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ezgif-1908683973.gif&userId=11733 [3]: https://en.wikipedia.org/wiki/Pursuit-evasion [4]: https://en.wikipedia.org/wiki/Pursuit-evasion#Continuous_formulation [5]: http://mathematica.stackexchange.com/q/40375/13 [6]: http://math.bard.edu/student/pdfs/tina-zhang.pdf [7]: http://fouriestseries.tumblr.com/post/96488907348/cops-and-robbers-and-zombies-and-humans [8]: https://www.wolframcloud.com/obj/7c3e870f-23e6-4f77-a093-eea0bc35a1ba Brian Weinstein 2016-03-10T20:14:42Z https://community.wolfram.com/groups/-/m/t/478669 Here's today's New York Times 4x4 KenKen solved in Mathematica. The approach is to first construct all possible arrays with different numbers in each row, from that select all arrays that have different numbers in each column, then apply the constraints on various cells. For this particular example, it was not necessary to apply all the constraints to get the unique answer. It is necessary to take the absolute value of some difference and ratio constraints, since it the order of the difference or ratio is not known. Dimensions[p4 = Permutations[Range[4]]] Out[1]= {24, 4} Dimensions[a1 = Flatten[Outer[List, p4, p4, p4, p4, 1], 3]] Out[2]= {331776, 4, 4} Dimensions[ a2 = Select[ a1, (And @@ (And @@ Unequal[Sequence @@ #] &) /@ Transpose[#]) &]] Out[3]= {576, 4, 4} Dimensions[a3 = Select[a2, #[[1, 1]]*#[[1, 2]]*#[[2, 2]] == 12 &]] Out[4]= {112, 4, 4} Dimensions[a4 = Select[a3, Abs[Log[#[[1, 3]]/#[[1, 4]]]] == Log[2] &]] Out[5]= {64, 4, 4} In[6]:= Dimensions[ a5 = Select[ a4, #[[2, 1]] + #[[3, 1]] + #[[3, 2]] + #[[4, 1]] == 11 &]] Out[6]= {8, 4, 4} In[7]:= Dimensions[a6 = Select[a5, Abs[#[[2, 3]] - #[[3, 3]]] == 2 &]] Out[7]= {6, 4, 4} In[8]:= Dimensions[a7 = Select[a6, #[[2, 4]] == 2 &]] Out[8]= {1, 4, 4} In[10]:= a7 Out[10]= {{{1, 3, 2, 4}, {3, 4, 1, 2}, {4, 2, 3, 1}, {2, 1, 4, 3}}} Frank Kampas 2015-04-13T20:56:51Z https://community.wolfram.com/groups/-/m/t/1378496 Theory of Games has an impressive development during the last 70 years both as a domain of applied mathematics and a part of various important domains of human activity. It's somewhat strange that Mathematica doesn't include any functionality related to game theory. Our project intends to initiate a game theory Mathematica package. At the first initiation stage of the project development, we consider strategic finite (multi-matrix) games and some solution concepts: Nash equilibrium, Stackelberg equilibrium, and MaxMin strategies: Game statement ------------------------------------- A strategic game is defined by the tuple: $$\Gamma = \langle N, \{X_i\}_{i\in N}, \{f_i (x)\}_{i\in N}\rangle,$$ where $N=\{1,2,...,n\}$ is a set of players, $X_i$ is a set of strategies of player $i\in N$ and $f_i:X\rightarrow R$ is a player's $i\in N$ payoff function defined on the Cartesian product $X = \times_{i \in N} X_i$. Elements of $X$ are called outcomes of the game (strategy profiles). An outcome $x^*\in X$ of is a Nash equilibrium (shortly NE) of $\Gamma$ if $$f_i ( x_i, x_{-i}^*) \le f_i ( x^*_i, x_{-i}^* ), \forall x_i \in X_i,\,\, \forall i \in N,$$ where $$x_{-i}^* = (x^*_1, x^*_2, ..., x^*_{i-1}, x^*_{i+1}, ..., x^*_n),$$ $$x_{-i}^* \in X_{-i}=X_1 \times X_2 \times ... \times X_{i-1} \times X_{i+1} \times ... \times X_n,$$ $$(x_i,x_{-i}^*) = (x^*_1, x^*_2, ..., x^*_{i-1},x_i, x^*_{i+1}, ..., x^*_n)\in X.$$ We study Nash equilibrium sets as an intersection of best response mapping graphs [5,1, 2], i.e. the intersection of the sets: $$Gr_i=\{(x_i,x_{-i})\in X: x_{-i}\in X_{-i}, x_i\in {\rm Arg}\max_{x_i\in X_i} f_i(x_i,x_{-i})\},\,\, i\in N.$$ Theorem 1. The outcome $x^*\in X$ is a Nash equilibrium if and only if $x^*\in \bigcap_{i \in N}Gr_i$. Theorem 1 stands for a main method that we will use to find Nash equilibrium set. So, we are looking to finding Nash equilibrium sets as the intersection of best response mapping graphs, both in pure and mixed strategy games. Package design ------------------------------------- We have designed package structure and features that have to be applied to all its functions, their titles and options. Main functions of the package a `GameTheory[]` and `GameTheoryPlot[]`. There is an idea to recall them `GameSolve[]` and `GameSolvePlot[]`. Formal parameters of the functions are initial data of the games, as well all the concepts that specifies a concrete game theory problem: testOptionValue["Criteria" -> crit, {"Maximize", "Minimize"}]; testOptionValue["Strategy" -> type, {"Pure", "Mixed"}]; testOptionValue["Concept" -> concept, {"NashEquilibrium", "MaxMin", "StackelbergEquilibrium"}] We have created algorithms and corresponding codes that solve problems of Nash equilibrium set finding, as well as MaxMin solutions computing. In this context we need to mention the following functions: pureNashEquilibria[matr_] := ... maxMin[matr_] :=... pureStackelbergEquilibria[matr_] :=... We have also programmed the code that solves two-matrix mixed strategy games. mixedNashEquilibria[m_] := ... The package includes, withal, a function that plot Nash equilibrium set in $2\times 2$ mixed strategy games. game2x2Plot[m_]:= ... Some private functions and their application ------------------------------------- For the problem of Nash equilibrium set computing the main function is: bestResponse[m_]:=With[{ind=indexSets[Dimensions[m[[1]]]]}, Intersection@@Table[ Flatten[ Thread/@Table[ Replace[i, All:>maxPositions@m[[player,Sequence@@i]], {1}], {i, Tuples[ind[[player]]]} ], 1 ], {player, Length[m]} ] ] The notation `m` is for payoff matrices of the players. `Length[m]` gives the number of players. `Tuples[]` gives all possible tuples formed by player strategies. `maxPositions[]` gives positions on which maximal values are obtained. The intersection of all `Length[m]` lists of players offers the set of Nash equilibria. In practice, this function is called by `GameTheory[]` as in the following examples: In[1]:= Clear[a, b] a = {{2, 2, 3}, {7, 2, 2}, {1, 1, 4}}; b = {{5, 6, 1}, {5, 2, 3}, {3, 5, 7}}; MatrixForm /@ {a, b}; In[2]:= GameTheory[{a, b}, Method -> {"Criteria" -> "Maximize", "Concept" -> "NashEquilibrium", "Strategy" -> "Pure"}] Out[2]= {<|"Player 1" -> 1, "Player 2" -> 2|> -> {2, 6}, <|"Player 1" -> 2, "Player 2" -> 1|> -> {7, 5}, <|"Player 1" -> 3, "Player 2" -> 3|> -> {4, 7}} Another private function is: (* ------ MaxMin strategies ------ *) maxMin[matr_]:=Module[{dim=Dimensions[matr[[1]]], min, ind, tuples, payoffTuples},(*matr\[LeftDoubleBracket]1\[RightDoubleBracket] has the same dimensions as all other m\[LeftDoubleBracket]2\[RightDoubleBracket],...,m\[LeftDoubleBracket]n\[RightDoubleBracket]*) Table[ min=Table[0,dim[[player]]]; Do[ ind=Table[Range[dim[[j]]],{j,Length[matr]}]; (* list of strategy sets *) ind[[player]]={str}; (* strategy set of the player is set simply formed by one element: {str} *) tuples=Tuples[ind]; (* generate the tuples *) payoffTuples=Table[matr[[player,Sequence@@t]],{t,tuples}]; (* the variable player gives the matrix of the player; other indeces give the payoff value *) min[[str]]=Min[payoffTuples], (* for every player *) {str,dim[[player]]} ]; "Player "<>ToString[player] -> <|"Strategy"->maxPositions[min],"Payoff"->min[[maxPositions[min]]][[1]]|>, {player,Length[matr]} ] ] It is used to compute MaxMin strategies. This concept is more simple in comparison with the Nash equilibrium. It needs finding for every fixed strategy of the player the worst response of the other players. After knowing all such worst responses, every player computes the best from them, that being the MaxMin strategy. The following example illustrates how the function is applied really for the same above matrices: In[3]:= GameTheory[{a, b}, Method -> {"Criteria" -> "Maximize", "Concept" -> "MaxMin", "Strategy" -> "Pure"}] Out[3]= {"Player 1" -> <|"Strategy" -> {1, 2}, "Payoff" -> 2|>, "Player 2" -> <|"Strategy" -> {1}, "Payoff" -> 3|>} Sure, the function solves the above problems for an arbitrary number of players: ------------------------------------------------------------------ 5 player game --------------------------------------------------------------- In[4]:= Clear[a, b, c, d, e] a = RandomInteger[{-10, 1000}, {5, 5, 5, 5, 5}]; b = RandomInteger[{-10, 1000}, {5, 5, 5, 5, 5}]; c = RandomInteger[{-10, 1000}, {5, 5, 5, 5, 5}]; d = RandomInteger[{-10, 1000}, {5, 5, 5, 5, 5}]; e = RandomInteger[{-10, 1000}, {5, 5, 5, 5, 5}]; MatrixForm /@ {a, b, c, d, e}; In[5]:= GameTheory[{a, b, c, d, e}, Method -> {"Criteria" -> "Maximize", "Concept" -> "MaxMin", "Strategy" -> "Pure"}] Out[5]= {"Player 1" -> <|"Strategy" -> {5}, "Payoff" -> -7|>, "Player 2" -> <|"Strategy" -> {1, 5}, "Payoff" -> -7|>, "Player 3" -> <|"Strategy" -> {2}, "Payoff" -> -7|>, "Player 4" -> <|"Strategy" -> {4}, "Payoff" -> -8|>, "Player 5" -> <|"Strategy" -> {3}, "Payoff" -> -8|>} In[6]:= GameTheory[{a, b, c, d, e}, Method -> {"Criteria" -> "Maximize", "Concept" -> "NashEquilibrium", "Strategy" -> "Pure"}] Out[6]= {<|"Player 1" -> 1, "Player 2" -> 1, "Player 3" -> 2, "Player 4" -> 2, "Player 5" -> 4|> -> {807, 935, 772, 829, 986}, <|"Player 1" -> 3, "Player 2" -> 1, "Player 3" -> 5, "Player 4" -> 5, "Player 5" -> 3|> -> {824, 939, 621, 776, 874}} It is important to remark here that not all pure strategy games have Nash equilibria. But, all mixed-strategy games have Nash equilibria. Next private function solve the problem of Nash equilibrium set finding in two-matrix mixed-strategy games: mixedNashEquilibria[m_]:=With[{a=m[[1]],b=m[[2]]}, NESet={}; Do[ \[DoubleStruckCapitalU]=Range[i+1,Dimensions[a][[1]]]; Do[ Do[ If[X[b,i,j,\[DoubleStruckCapitalI],{}]==0,Break,Continue]; \[DoubleStruckCapitalV]=Range[j+1,Dimensions[a][[2]]]; Do[ If[Y[a,i,j,\[DoubleStruckCapitalI],\[DoubleStruckCapitalJ]]!=0&&X[b,i,j,\[DoubleStruckCapitalI],\[DoubleStruckCapitalJ]]!=0, NESet=AppendTo[NESet,{XOut[b,i,j,\[DoubleStruckCapitalI],\[DoubleStruckCapitalJ]],YOut[a,i,j,\[DoubleStruckCapitalI],\[DoubleStruckCapitalJ]]}], Break ], {\[DoubleStruckCapitalJ],Subsets[\[DoubleStruckCapitalV]]} ], {j,Dimensions[a][[2]]} ], {\[DoubleStruckCapitalI],Subsets[\[DoubleStruckCapitalU]]} ], {i,Dimensions[a][[1]]} ]; DeleteDuplicates@NESet ] The intersection method used for two-matrix mixed strategy games is described in details in [2]. Next, we illustrate its working out in the above form codding: Clear[a, b] a = {{2, 2, 3}, {7, 2, 2}, {1, 1, 4}}; b = {{5, 6, 1}, {5, 2, 3}, {3, 5, 7}}; MatrixForm /@ {a, b}; ![enter image description here][1] For some strategic games it is possible to present graphically the set of Nash equilibria [6]. All the code is very large, so we present here only on function used to manipulate all graphics objects appearing in the final image: game2x2Plot[m_]:=Module[{matr=m}, {{{\[DoubleStruckA]11,\[DoubleStruckA]12},{\[DoubleStruckA]21,\[DoubleStruckA]22}},{{\[DoubleStruckB]11,\[DoubleStruckB]12},{\[DoubleStruckB]21,\[DoubleStruckB]22}}}=matr; Manipulate[ Grid[{{Graphics[{Thick, Blue,g1[a11-a12-a21+a22,a12-a22], Green,g2[b11-b12-b21+b22,b21-b22], Red,PointSize[Large],nes[a11-a12-a21+a22,a12-a22,b11-b12-b21+b22,b21-b22]}, PlotRange->{{0,1},{0,1}},Axes->True,AxesLabel->{"\!\(\*SubscriptBox[\(x\), \(1\)]\)","\!\(\*SubscriptBox[\(y\), \(1\)]\)"}, ImageSize->{300,300}]},{" "},{Text@Style["Reference Nash Equilibria",Bold]}, {Text@Style[nes[a11-a12-a21+a22,a12-a22,b11-b12-b21+b22,b21-b22][[1,1]],Bold]}},ItemSize->{Automatic,{10,1,1,3}},Alignment->{Center,Top} ], Style["Matrix A",Bold], {{a11,\[DoubleStruckA]11,"\!\(\*SubscriptBox[\(a\), \(11\)]\)"},-10,10,1,Appearance-> "Labeled",ImageSize->Tiny}, {{a12,\[DoubleStruckA]12,"\!\(\*SubscriptBox[\(a\), \(12\)]\)"},-10,10,1,Appearance-> "Labeled",ImageSize->Tiny}, {{a21,\[DoubleStruckA]21,"\!\(\*SubscriptBox[\(a\), \(21\)]\)"},-10,10,1,Appearance-> "Labeled",ImageSize->Tiny}, {{a22,\[DoubleStruckA]22,"\!\(\*SubscriptBox[\(a\), \(22\)]\)"},-10,10,1,Appearance-> "Labeled",ImageSize->Tiny}, Delimiter,{{NonAntagonistic,True, "NonAntagonistic"},{True,False}}, Delimiter,Style["Matrix B",Bold], {{b11,\[DoubleStruckB]11,"\!\(\*SubscriptBox[\(b\), \(11\)]\)"},-10,10,1,Enabled->NonAntagonistic,Appearance-> "Labeled",ImageSize->Tiny}, {{b12,\[DoubleStruckB]12,"\!\(\*SubscriptBox[\(b\), \(12\)]\)"},-10,10,1,Enabled->NonAntagonistic,Appearance-> "Labeled",ImageSize->Tiny}, {{b21,\[DoubleStruckB]21,"\!\(\*SubscriptBox[\(b\), \(21\)]\)"},-10,10,1,Enabled->NonAntagonistic,Appearance-> "Labeled",ImageSize->Tiny}, {{b22,\[DoubleStruckB]22,"\!\(\*SubscriptBox[\(b\), \(22\)]\)"},-10,10,1,Enabled->NonAntagonistic,Appearance-> "Labeled",ImageSize->Tiny}, Delimiter, Style["Matrices A and B",Bold], Dynamic[ TableForm[ {{ToString[a11]<>" , "<>ToString[If[NonAntagonistic,b11,b11=-a11]], ToString[a12]<>" , "<>ToString[If[NonAntagonistic,b12,b12=-a12]]}, {ToString[a21]<>" , "<>ToString[If[NonAntagonistic,b21,b21=-a21]], ToString[a22]<>" , "<>ToString[If[NonAntagonistic,b22,b22=-a22]]}}, TableHeadings->{{"1","2"},{" 1"," 2"}}, TableSpacing->{2,2} ] ], SaveDefinitions->True ] ] In practice, the function is used at it follows: Clear[a, b] a = {{5, 3}, {7, 2}}; b = {{3, 6}, {5, 3}}; MatrixForm /@ {a, b}; GameTheoryPlot[{a, b}] ![enter image description here][2] Conclusions ------------------------------------- We have passed only a first pre-initial state of the package construction. There is a lot of things that must be done to establish a successful game theory package. We can only emphasised here some other stages. So, we intend to develop the package in several successive stages and directions: 1. At the first initiation stage we plan to enlarge the number of strategic form game theory problems solved by the package, and to include more plotting possibilities. 2. At the second stage we intend to develop package functionality in order to solve extensive form games, and to include their abundant plotting functionality. 3. At the third stage, we are considering adding support for cooperative games. 4. At the fourth stage, we plan to consider differential games and control. 5. Next stages will include multi-criteria mixtures of simultaneous and sequential games, as well as a lot of applied problems from all the human activity. Bibliography ----------- 1. [Ungureanu, Valeriu, Nash equilibria set computing in finite extended games, CSJM, 2006, Vol. 14, No. 3 (42), pp. 345-365.][3] 2. [Ungureanu, Valeriu, "Pareto-Nash-Stackelberg Game and Control Theory", Springer International Publishing, 2018, XXI + 343 pp.][4] 3. [Ungureanu, Valeriu, Nash equilibrium set function in dyadic mixed-strategy games, CSJM v .25, n .1 (73), 2017.][5] 4. [Nash J.F., Noncooperative game, Annals of Mathematics, 54, 1951, pp. 280-295.][6] 5. Sagaidac, M., and Ungureanu, V., Operational research, Chi\sinau, CEP USM, 2004, 296 p. (in Romanian) 6. [Ungureanu, V., Nash Equilibrium Sets in Dyadic Bimatrix Mixed-Strategy Games,][7] [1]: http://community.wolfram.com//c/portal/getImageAttachment?filename=TwoMatrixMixedStrategyGame.png&userId=159033 [2]: http://community.wolfram.com//c/portal/getImageAttachment?filename=game2x2Image.png&userId=159033 [3]: http://www.math.md/files/csjm/v14-n3/v14-n3-%28pp345-365%29.pdf [4]: https://www.springer.com/gp/book/9783319751504 [5]: http://www.math.md/files/csjm/v25-n1/v25-n1-%28pp3-20%29.pdf [6]: https://www.jstor.org/stable/1969529?seq=1#page_scan_tab_contents [7]: http://community.wolfram.com/groups/-/m/t/892544?p_p_auth=LiMRfo3d Valeriu Ungureanu 2018-07-11T16:36:01Z https://community.wolfram.com/groups/-/m/t/598249 Packing ellipses into a circumscribing circle is more complex than packing circles, since there is no formula for the minimum distance between two ellipses or the maximum distance from the center of the circumscribing circle to an ellipse. This is overcome by embedding constraints using Lagrange multipliers into the problem to locate the most distant point from the origin of an ellipse and the points on pairs of ellipses closest to each other. A result of a packing, showing the ellipses and the determined points is shown here: ![enter image description here][1] [1]: http://community.wolfram.com//c/portal/getImageAttachment?filename=EllipsePackingUsingEmbeddedLagrangeMultipliers.jpg&userId=29126 The complete calculation is in the attached notebook. The optimization was carried out as a local search using MathOptimizer Professional http://www.wolfram.com/products/applications/mathoptpro as FindMinimum does not converge for the calculation. Frank Kampas 2015-10-26T13:32:54Z https://community.wolfram.com/groups/-/m/t/220551 I just published a blog post proclaiming the implementation of the function MosaicPlot that gives visual representation of the contingencies of categorical variables in a list of records. The blog post has examples and explanations: [url=http://mathematicaforprediction.wordpress.com/2014/03/17/mosaic-plots-for-data-visualization/]http://mathematicaforprediction.wordpress.com/2014/03/17/mosaic-plots-for-data-visualization/[/url] If we consider the census income data set known as the [url=http://archive.ics.uci.edu/ml/datasets/Census+Income]"adult data set"[/url] that is summarized in this table: [img=width: 800px; height: 375px;]http://mathematicaforprediction.files.wordpress.com/2014/03/adult-census-income-data-summary.png[/img] we visualize the co-occurence of (categorical variable) values with mosaic plots like this one: [img=width: 500px; height: 506px;]http://mathematicaforprediction.files.wordpress.com/2014/03/adult-census-income-data-sex-education-colored-mosaic-plot.png[/img] By comparing the sizes of the rectangles corresponding to values “Bachelors”, “Doctorate”, “Masters”, and “Some-college” on the “sex vs. education” mosaic plot we can see that the fraction of men that have finished college is larger than the fraction of women that have finished college. We can further subdivide the rectangles according the co-occurrence frequencies with a third categorical variable. We are going to choose that third variable to be “income”, the values of which can be seen as outcomes or consequents of the values of the first two variables of the mosaic plot. [img=width: 550px; height: 509px;]http://mathematicaforprediction.files.wordpress.com/2014/03/adult-census-income-data-sex-education-income-colored-mosaic-plot.png[/img] From the mosaic plot "sex vs. education vs. income" we can make the following observations.1. Approximately 75% of the males with doctorate degrees or with a professional school degree earn more than $50000 per year.2. Approximately 60% of the females with a doctorate degree earn more than $50000 per year.3. Approximately 45% of the females with a professional school degree earn more than $50000.4. Across all education type females are (much) less likely to earn more than $50000 per year. Anton Antonov 2014-03-17T21:29:53Z https://community.wolfram.com/groups/-/m/t/1703087 Hello community. I have created a function and would like to know if it is worth submitting in Function Repository or if there is already something simpler that does this same job? If anyone can give any opinion on this I will be very grateful. I modestly have created a function that can interleave two lists by alternating their terms (unlike Riffle, which only fits the terms into gaps, this function does this keeping the same number of terms as it replaces them by both functions simultaneously). - It works like this: If the third term inside the function ("c_") is {} the function does this automatically in a 1 to 1 pattern of each group: Alternate[a_, b_] := Alternate[a, b, {}] Alternate[a_, b_, c_] := PadRight[a* PadRight[ Take[Flatten@Table[If[c == {}, {1, 0}, c], Count[a, _]], Min[Count[a, _], Count[b, _]]], Count[a, _], 1], Max[Count[a, _], Count[b, _]]] + PadRight[b* PadRight[ Take[Flatten@Table[Abs[If[c == {}, {1, 0}, c] - 1], Count[b, _]], Min[Count[a, _], Count[b, _]]], Count[b, _], 1], Max[Count[a, _], Count[b, _]]] r = {2, 4, 6, 8, 10, 12, 14, 16, 18, 20}; s = {3, 5, 7, 9, 11, 13, 15, 17, 19, 21}; Alternate[r, s] Alternate[s, r] ![ie1][1] The function works even with lists of different sizes, keeping the terms in excess unchanged: p = {2, 4, 6, 8, 10, 12, 14, 16, 18, 20}; q = {3, 5, 7, 9, 11, 13, 15, 17}; Alternate[p, q] Alternate[q, p] ![ie2][2] Or you can change the third term ("c") in the function to any pattern (eg: {0,1,1,1}). Where "1" refers to the first term ("a") from within the function while "0" refers to the term ("b") from within the function: t = {2, 4, 6, 8, 10, 12, 14, 16, 18, 20}; u = {3, 5, 7, 9, 11, 13, 15, 17}; Alternate[t, u, {0, 1, 1, 1}] Alternate[u, t, {0, 1, 1, 1}] ![ie3][3] I would like to know if is this a good idea or there is a simpler way to do this? Is it worth sending a repository request? Thank you. [1]: https://community.wolfram.com//c/portal/getImageAttachment?filename=ie1.png&userId=1316061 [2]: https://community.wolfram.com//c/portal/getImageAttachment?filename=ie2.png&userId=1316061 [3]: https://community.wolfram.com//c/portal/getImageAttachment?filename=ie3.png&userId=1316061 Claudio Chaib 2019-06-12T19:48:51Z https://community.wolfram.com/groups/-/m/t/1907256 # Introduction Last weekend -- 2020-03-20 ÷ 2020-03-22 -- I participated in [the (Germany-centric) hackathon WirVsVirus](https://wirvsvirushackathon.org). (I friend of mine who lives in Germany asked me to team up and sign up. Participated together with Balint Badonfai and Diego Zviovich.) [Our idea proposal](https://github.com/antononcube/SystemModeling/blob/master/Projects/Coronavirus-propagation-dynamics/org/WirVsVirus-Hackathon-work-plan.org) was accepted, [listed in the dedicated overview table (see item 806)](https://airtable.com/shrs71ccUVKyvLlUA/tbl6Br4W3IyPGk1jt/viw7AlEju6qFtXJqL?blocks=hide). The title of our hackathon project is: **“Geo-spatial-temporal Economic Model for COVID-19 Propagation and Management in Germany”** [Nearly a dozen of people enlisted to help](https://devpost.com/software/geo-raumlich-zeitliches-wirtschaftsmodell-fur-covid-19). (We communicated through Slack.) ```mathematica WebImage["https://devpost.com/software/geo-raumlich-zeitliches-\ wirtschaftsmodell-fur-covid-19"] ```  Multiple people helped with the discussion of ideas, directions where to find data, with actual data gathering, and related documented analysis. Of course, just discussing the proposed solutions was already a great help! # What was accomplished ## Work plans The following mind-map reflects pretty well what was planned and done:  There is also a related [org-mode file with the work plan](https://github.com/antononcube/SystemModeling/blob/master/Projects/Coronavirus-propagation-dynamics/org/WirVsVirus-Hackathon-work-plan.org). ## Data I obtained Germany city data with Mathematica’s build-in functions and used it to heuristically derive a traveling patterns graph, [AA1]. Here is the data: ```mathematica dsCityRecords = ResourceFunction["ImportCSVToDataset"][ "https://raw.githubusercontent.com/antononcube/SystemModeling/master/Data/dfGermanyCityRecords.csv"]; Dimensions[dsCityRecords] (*{12538, 6}*) ``` Here is Geo-histogram of that data: ```mathematica cellRadius = Quantity[70, "Kilometers"]; aCoordsToPopulations = AssociationThread[Values /@ Normal[dsCityRecords[All, {"Lat", "Lon"}]], Normal[dsCityRecords[All, "Population"]]]; GeoHistogram[aCoordsToPopulations, cellRadius, ColorFunction -> (Opacity[#, Blue] &), PlotLegends -> Automatic] ```  We considered a fair amount of other data. But because of the time limitations of the hackathon we had to use only the one above. ## Single-site models During the development phase I used the model SEI2R, but since we wanted to have a “geo-spatial-temporal epidemiological economics model” I productized the implementation of SEI2HR-Econ, [AAp1]. Here are the stocks, rates, and equations of SEI2HR-Econ: ```mathematica Magnify[ModelGridTableForm[SEI2HREconModel[t]], 0.85] ```  ## Multi-site SEI2R (SEI2HR-Econ) over a hexagonal grid graph I managed to follow through with a large part of [the work plan for the hackathon](https://github.com/antononcube/SystemModeling/blob/master/Projects/Coronavirus-propagation-dynamics/org/WirVsVirus-hackathon-Geo-spatial-temporal-model-mind-map.pdf) and make multi-site scaled model that “follows the money”, [[AA1](https://github.com/antononcube/SystemModeling/blob/master/Projects/Coronavirus-propagation-dynamics/Documents/WirVsVirus-hackathon-Multi-site-SEI2R-over-a-hexagonal-grid-graph.md)]. Here is a diagram that shows the travelling patterns graph and solutions at one of the nodes:  Here is an interactive interface for studying and investigating the solution results:  For more details see the notebook [[AA1](https://github.com/antononcube/SystemModeling/blob/master/Projects/Coronavirus-propagation-dynamics/Documents/WirVsVirus-hackathon-Multi-site-SEI2R-over-a-hexagonal-grid-graph.md)]. Different parameters can be set in the “Parameters” section. Especially of interest are the quarantine related parameters: start, duration, effect on contact rates and traffic patterns. I also put simulations results code and programmed visualization routines in R, [AA2]. (In order other members of team to be able to explore the results.) # References \[DP1\] [47_wirtschaftliche Auswirkung_Geo-spatial-temp-econ-modell](https://devpost.com/software/geo-raumlich-zeitliches-wirtschaftsmodell-fur-covid-19), DevPost. \[WRI1\] Wolfram Research, Inc., [Germany city data records](https://github.com/antononcube/SystemModeling/blob/master/Data/dfGermanyCityRecords.csv), (2020), [SystemModeling at GitHub](https://github.com/antononcube/SystemModeling). \[AA1\] Anton Antonov, ["WirVsVirus hackathon multi-site SEI2R over a hexagonal grid graph"](https://github.com/antononcube/SystemModeling/blob/master/Projects/Coronavirus-propagation-dynamics/Documents/WirVsVirus-hackathon-Multi-site-SEI2R-over-a-hexagonal-grid-graph.md), (2020), [SystemModeling at GitHub](https://github.com/antononcube/SystemModeling). \[AA2\] Anton Antonov, ["WirVsVirus-Hackathon in R"](https://github.com/antononcube/SystemModeling/tree/master/Projects/Coronavirus-propagation-dynamics/R/WirVsVirus-Hackathon), (2020), [SystemModeling at GitHub](https://github.com/antononcube/SystemModeling). \[AAp1\] Anton Antonov, ["Epidemiology models Mathematica package"](https://github.com/antononcube/SystemModeling/blob/master/Projects/Coronavirus-propagation-dynamics/WL/EpidemiologyModels.m), (2020), [SystemsModeling at GitHub](https://github.com/antononcube/SystemModeling). Anton Antonov 2020-03-24T21:59:30Z https://community.wolfram.com/groups/-/m/t/1895675 *MODERATOR NOTE: coronavirus resources & updates:* https://wolfr.am/coronavirus &[Wolfram Notebook][1] [1]: https://www.wolframcloud.com/obj/75ec2a4b-b7bd-4c7f-9a14-6e543085fc0e Anton Antonov 2020-03-10T20:51:05Z https://community.wolfram.com/groups/-/m/t/1762584 <h2>Introduction</h2> On Friday 9th August 2019, Britain suffered one of the worst power outages in recent years. Over 1 million people in England and Wales were cut off from power for nearly 9 hours, preventing numerous rail services from running during the rush hour. ![Photograph of the distruption in King's Cross station][1] Was this a statistical misfortune, or a systemic failure which caused the recent power outages? <h2>Getting the data</h2> To obtain the information required to do analysis of the events leading up to the catastrophic power outage, we will we will use a fantastic website, [GridWatch Templar][3], which has realtime data as to the different power supplies, resources and frequencies. From the download page, I downloaded all the data from 27th May 2011 to the current time. Be patient; it will take a considerable amount of time to download the entire dataset (and as it is too large, I have not attached this csv file to this page). Also, as we will be carrying out analysis on such a large dataset, some cells will take a considerable amount of time to run. <h2>Analysis of the frequencies</h2> First, we import the dataset: ``` In[1]: data = Import["D:\\Programming\\GridWatch\\gridwatch.csv"]; ``` The data which it contains: ``` In[2]: data[[1]] Out[2]: {"id", "timestamp", "demand", "frequency", "coal", "nuclear", "ccgt", \ "wind", "pumped", "hydro", "biomass", "oil", "solar", "ocgt", \ "french_ict", "dutch_ict", "irish_ict", "ew_ict", "nemo", "other", \ "north_south", "scotland_england"} ``` To look at the frequencies: ``` In[3]: frequencies = If[#[[4]] == 0, Nothing, {DateObject[#[[2]]], #[[4]]}] & /@ data[[2 ;;]]; ``` To show the minimum value: ``` In[4]: MinimalBy[frequencies, Last] Out[4]: {{DateObject[{2019, 8, 9, 15, 55, 37}, "Instant", "Gregorian", 1.], 48.889}} In[5]: DateListPlot[frequencies, PlotRange -> All, AxesLabel -> {"Time", "Hz"}] ``` ![The date plot][4] This is not particularly enlightening; although it does show how dramatic the recent drop of frequency is. In fact, it is known that if the frequency drops below 49.5 Hz, a blackout will occur - and this is the first time it has happened (at least since 2011). Let's dive deeper - we'll use a normal distribution in approximation to the distribution: ``` In[6]: distribution = NormalDistribution[Mean[Last /@ frequencies], StandardDeviation[Last /@ frequencies]] Out[6]: NormalDistribution[50.0012, 0.0584802] ``` Now plotting it gives: ``` In[7]: Show[Histogram[Last /@ newfreqs, Automatic, "ProbabilityDensity"], Plot[PDF[distribution, x], {x, 49.7, 50.3}, PlotStyle -> Thick]] ``` This returns: ![histogram][5] Observe how quickly this tapers off. Assuming the frequencies follow that normal distribution, the probability of this occurring is: ``` In[8]: Probability[freq <= 49.5, freq \[Distributed] distribution] Out[8]: 5.1191*10^-18 ``` So we can be very confident that this was not just a statistical mishap - there was a genuine, systemic cause for this event to occur (see the comment below for explanation of this). Now let's take a closer look at what happened that day. <h2>Focusing in further</h2> A National Grid spokesperson said: > The root cause of yesterday’s issue was not with our system but was a rare and unusual event, the almost simultaneous loss of two large generators, one gas and one offshore wind, at 4.54pm. We are still working with the generators to understand what caused the generation to be lost. (courtesy of the [the Guardian][2] for this report). We will verify this report below. First, we will zoom in on the interval between one day before and one day after the event occurred. ``` In[9]: timeinterval = Select[data[[2;;]], DateObject[{2019, 8, 9, 15, 55, 37}, "Instant", "Gregorian", 1.`] - Quantity[1, "Days"] <= DateObject[#[[2]]] <= DateObject[{2019, 8, 9, 15, 55, 37}, "Instant", "Gregorian", 1.`] + Quantity[1, "Days"] &] ``` (This specific time interval data is attached to this post). To visualise it the frequencies: ``` In[11]: timeintervalfreqs = {DateObject[#[[2]]], #[[4]]} & /@ timeinterval; In[12]: DateListPlot[Out[51], PlotRange -> All, Epilog -> {Red, Text[Style["\[SixPointedStar]", 20], #] & /@ {{DateObject[{2019, 8, 9, 15, 55, 37}, "Instant", "Gregorian", 1.`], 48.889`}}}] ``` which shows: ![2 day interval][6] Now let's look at the specific types of energy generation: ``` In[13]: DateListPlot[ Table[{DateObject[#[[2]]], #[[k]]} & /@ timeinterval, {k, 5, 21}], PlotLegends -> data[[1]][[5 ;;]], PlotRange -> All] ``` which returns ![nuclear, coal etc.][7] Now let's reduce down to the two energy sources which were mentioned in the report: namely, gas (or CCGT, OCGT), and offshore wind. ``` In[14]: indices = {3, 7, 8, 14}; DateListPlot[ Table[{DateObject[#[[2]]], #[[k]]} & /@ timeinterval, {k, indices}], PlotLegends -> data[[1]][[indices]], PlotRange -> All, Epilog -> {Directive[{Thick, Red, Dashed}], Line[{{DateObject[{2019, 8, 9, 15, 55, 37}, "Instant", "Gregorian", 1.`], 0}, {DateObject[{2019, 8, 9, 15, 55, 37}, "Instant", "Gregorian", 1.`], 40000}}]}] ``` ![graph_6][8] This clearly shows a drop in CCGT and wind power (and also the demand) subsequent to the incident. Finding peaks for the CCGT data to find when the drop occurs: ``` In[15]: ccgtdata = {AbsoluteTime[#[[2]]], -#[[8]]} & /@ timeinterval; In[16]: inter = Interpolation[ccgtdata[[All, 1]]]; In[17]: peaks = FindPeaks[ccgtdata[[All, 2]]]; In[18]: peak = Select[{inter[#1], #2} & @@@ peaks, #[[1]] >= AbsoluteTime[ DateObject[{2019, 8, 9, 15, 55, 37}, "Instant", "Gregorian", 1.`]] &][[1, 1]] (*This calculates the first trough since the event took place*) Out[18]: 3774356135 ``` This means that, 20 minutes after the frequency collapses, the CCGT (and the Wind power) supply decrease dramatically. <h2>Conclusion</h2> At 3:55 PM GMT +1 (so really 4:55 PM, confirming the report - this is on account of BST) on Friday the 9th of August, for the first time since 2011 (and probably many years before), frequency reached levels below 49.5 Hz, at which point blackouts would take place, affecting nearly 1 million people and disrupting multiple rail services across England and Wales. According to the National Grid, this had almost happened 3 times before this one took place; our data can confirm this (see the graph below input 5). We can be certain that this was not a statistical oddity; in fact, around 20 minutes later, we begin to see that the CCGT and offshore wind supplies decrease, which confirms the report stating that both had cut out simultaneously. Hopefully this will never happen again. With this dataset at hand, it seems likely that these outages could be more foreseen in the future. [1]: https://community.wolfram.com//c/portal/getImageAttachment?filename=image1.jpg&userId=1719931 [2]: https://www.theguardian.com/business/2019/aug/10/uk-energy-watchdog-demands-answers-after-major-power-cut-england-wales [3]: https://gridwatch.templar.co.uk/ [4]: https://community.wolfram.com//c/portal/getImageAttachment?filename=graph_1.jpg&userId=1719931 [5]: https://community.wolfram.com//c/portal/getImageAttachment?filename=graph_2.jpg&userId=1719931 [6]: https://community.wolfram.com//c/portal/getImageAttachment?filename=graph_4.jpg&userId=1719931 [7]: https://community.wolfram.com//c/portal/getImageAttachment?filename=graph_3.PNG&userId=1719931 [8]: https://community.wolfram.com//c/portal/getImageAttachment?filename=graph_6.PNG&userId=1719931 Henry Jaspars 2019-08-13T18:25:04Z https://community.wolfram.com/groups/-/m/t/1065416 Is anyone interested in and actively using Wolfram to do Deep Learning research? I am doing research in all areas of Deep Learning with my focus currently on VGG style of convolution neural networks (CNN). I will be branching out very soon to RLN, RNN, and GAN research very soon. I would like to be able to compare experiences and lessons learned using Wolfram in these areas. Thanks for any interest in discussions on Deep Learning. Bryan Minor 2017-04-18T17:29:38Z https://community.wolfram.com/groups/-/m/t/944004 # Introduction The main goals of this post/document are: **i)** to demonstrate how to create versions and combinations of classifiers utilizing different perspectives, **ii)** to apply the Receiver Operating Characteristic (ROC) technique into evaluating the created classifiers (see \[[2](https://en.wikipedia.org/wiki/Receiver_operating_characteristic),[3](https://ccrma.stanford.edu/workshops/mir2009/references/ROCintro.pdf)\]) and **iii)** to illustrate the use of the *Mathematica* packages \[[5](https://github.com/antononcube/MathematicaForPrediction/blob/master/ROCFunctions.m),[6](https://github.com/antononcube/MathematicaForPrediction/blob/master/ClassifierEnsembles.m)\]. The concrete steps taken are the following: 1. Obtain data: *Mathematica* built-in or external. Do some rudimentary analysis. 2. Create an ensemble of classifiers and compare its performance to the individual classifiers in the ensemble. 3. Produce classifier versions with from changed data in order to explore the effect of records outliers. 4. Make a bootstrapping classifier ensemble and evaluate and compare its performance. 5. Systematically diminish the training data and evaluate the results with ROC. 6. Show how to do classifier interpolation utilizing ROC. In the steps above we skip the necessary preliminary data analysis. For the datasets we use in this document that analysis has been done elsewhere. (See [,,,].) Nevertheless, since ROC is mostly used for binary classifiers we want to analyze the class labels distributions in the datasets in order to designate which class labels are "positive" and which are "negative." ## ROC plots evaluation (in brief) Assume we are given a binary classifier with the class labels ***P*** and ***N*** (for "positive" and "negative" respectively). Consider the following measures True Positive Rate (TPR): $$ TPR:= \frac {correctly \: classified \: positives}{total \: positives}. $$ and False Positive Rate (FPR): $$ FPR:= \frac {incorrectly \: classified \: negatives}{total \: negatives}. $$ Assume that we can change the classifier results with a parameter $\theta$ and produce a plot like this one: [![AdultDatasetEnsembleClassifier][14]][14] For each parameter value $\theta _{i}$ the point ${TPR(\theta _{i}), FPR(\theta _{i})}$ is plotted; points corresponding to consecutive $\theta _{i}$'s are connected with a line. We call the obtained curve *the ROC curve* for the classifier in consideration. The ROC curve resides in *the ROC space* as defined by the functions FPR and TPR corresponding respectively to the $x$-axis and the $y$-axis. The ideal classifier would have its ROC curve comprised of a line connecting \{0,0\} to \{0,1\} and a line connecting \{0,1\} to \{1,1\}. Given a classifier the ROC point closest to \{0,1\}, generally, would be considered to be the best point. # Used packages These commands load the used *Mathematica* packages \[[4](https://github.com/antononcube/MathematicaForPrediction/blob/master/MathematicaForPredictionUtilities.m),[5](https://github.com/antononcube/MathematicaForPrediction/blob/master/ROCFunctions.m),6\]: Import["https://raw.githubusercontent.com/antononcube/MathematicaForPrediction/master/MathematicaForPredictionUtilities.m"] Import["https://raw.githubusercontent.com/antononcube/MathematicaForPrediction/master/ROCFunctions.m"] Import["https://raw.githubusercontent.com/antononcube/MathematicaForPrediction/master/ClassifierEnsembles.m"] # Data used ## The Titanic dataset These commands load the Titanic data (that is shipped with *Mathematica*). data = ExampleData[{"MachineLearning", "Titanic"}, "TrainingData"]; columnNames = (Flatten@*List) @@ ExampleData[{"MachineLearning", "Titanic"}, "VariableDescriptions"]; data = ((Flatten@*List) @@@ data)[[All, {1, 2, 3, -1}]]; trainingData = DeleteCases[data, {___, _Missing, ___}]; Dimensions[trainingData] (* {732, 4} *) RecordsSummary[trainingData, columnNames] [![Records1][1]][1] data = ExampleData[{"MachineLearning", "Titanic"}, "TestData"]; data = ((Flatten@*List) @@@ data)[[All, {1, 2, 3, -1}]]; testData = DeleteCases[data, {___, _Missing, ___}]; Dimensions[testData] (* {314, 4} *) RecordsSummary[testData, columnNames] [![Records2][2]][2] nTrainingData = trainingData /. {"survived" -> 1, "died" -> 0, "1st" -> 0, "2nd" -> 1, "3rd" -> 2, "male" -> 0, "female" -> 1}; # Classifier ensembles This command makes a classifier ensemble of two built-in classifiers "NearestNeighbors" and "NeuralNetwork": aCLs = EnsembleClassifier[{"NearestNeighbors", "NeuralNetwork"}, trainingData[[All, 1 ;; -2]] -> trainingData[[All, -1]]] [![Classifier][3]][3] A classifier ensemble of the package \[[6](https://github.com/antononcube/MathematicaForPrediction/blob/master/ClassifierEnsembles.m)\] is simply an association mapping classifier IDs to classifier functions. The first argument given to `EnsembleClassifier` can be `Automatic`: SeedRandom[8989] aCLs = EnsembleClassifier[Automatic, trainingData[[All, 1 ;; -2]] -> trainingData[[All, -1]]]; With `Automatic` the following built-in classifiers are used: Keys[aCLs] (* {"NearestNeighbors", "NeuralNetwork", "LogisticRegression", "RandomForest", "SupportVectorMachine", "NaiveBayes"} *) ## Classification with ensemble votes Classification with the classifier ensemble can be done using the function `EnsembleClassify`. If the third argument of `EnsembleClassify` is "Votes" the result is the class label that appears the most in the ensemble results. EnsembleClassify[aCLs, testData[[20, 1 ;; -2]], "Votes"] (* "died" *) The following commands clarify the voting done in the command above. Map[#[testData[[20, 1 ;; -2]]] &, aCLs] Tally[Values[%]] (* <|"NearestNeighbors" -> "died", "NeuralNetwork" -> "survived", "LogisticRegression" -> "survived", "RandomForest" -> "died", "SupportVectorMachine" -> "died", "NaiveBayes" -> "died"|> *) (* {{"died", 4}, {"survived", 2}} *) ## Classification with ensemble averaged probabilities If the third argument of `EnsembleClassify` is "`ProbabilitiesMean`" the result is the class label that has the highest mean probability in the ensemble results. EnsembleClassify[aCLs, testData[[20, 1 ;; -2]], "ProbabilitiesMean"] (* "died" *) The following commands clarify the probability averaging utilized in the command above. Map[#[testData[[20, 1 ;; -2]], "Probabilities"] &, aCLs] Mean[Values[%]] (* <|"NearestNeighbors" -> <|"died" -> 0.598464, "survived" -> 0.401536|>, "NeuralNetwork" -> <|"died" -> 0.469274, "survived" -> 0.530726|>, "LogisticRegression" -> <|"died" -> 0.445915, "survived" -> 0.554085|>, "RandomForest" -> <|"died" -> 0.652414, "survived" -> 0.347586|>, "SupportVectorMachine" -> <|"died" -> 0.929831, "survived" -> 0.0701691|>, "NaiveBayes" -> <|"died" -> 0.622061, "survived" -> 0.377939|>|> *) (* <|"died" -> 0.61966, "survived" -> 0.38034|> *) ## ROC for ensemble votes The third argument of `EnsembleClassifyByThreshold` takes a rule of the form *label->threshold*; the fourth argument is eighter "Votes" or "ProbabiltiesMean". The following code computes the ROC curve for a range of votes. rocRange = Range[0, Length[aCLs] - 1, 1]; aROCs = Table[( cres = EnsembleClassifyByThreshold[aCLs, testData[[All, 1 ;; -2]], "survived" -> i, "Votes"]; ToROCAssociation[{"survived", "died"}, testData[[All, -1]], cres]), {i, rocRange}]; ROCPlot[rocRange, aROCs, "PlotJoined" -> Automatic, GridLines -> Automatic] [![Ensemble1][4]][4] ## ROC for ensemble probabilities mean If we want to compute ROC of a range of probability thresholds we `EnsembleClassifyByThreshold` with the fourth argument being "ProbabilitiesMean". EnsembleClassifyByThreshold[aCLs, testData[[1 ;; 6, 1 ;; -2]], "survived" -> 0.2, "ProbabilitiesMean"] (* {"survived", "survived", "survived", "survived", "survived", "survived"} *) EnsembleClassifyByThreshold[aCLs, testData[[1 ;; 6, 1 ;; -2]], "survived" -> 0.6, "ProbabilitiesMean"] (* {"survived", "died", "survived", "died", "died", "survived"} *) The implementation of `EnsembleClassifyByThreshold` with "ProbabilitiesMean" relies on the `ClassifierFunction` signature: `ClassifierFunction[__][record_, "Probabilities"]` Here is the corresponding ROC plot: rocRange = Range[0, 1, 0.025]; aROCs = Table[( cres = EnsembleClassifyByThreshold[aCLs, testData[[All, 1 ;; -2]], "survived" -> i, "ProbabilitiesMean"]; ToROCAssociation[{"survived", "died"}, testData[[All, -1]], cres]), {i, rocRange}]; rocEnGr = ROCPlot[rocRange, aROCs, "PlotJoined" -> Automatic, PlotLabel -> "Classifier ensemble", GridLines -> Automatic] [![Ensemble2][5]][5] ## Comparison of the ensemble classifier with the standard classifiers This plot compares the ROC curve of the ensemble classifier with the ROC curves of the classifiers that comprise the ensemble. rocGRs = Table[ aROCs1 = Table[( cres = ClassifyByThreshold[aCLs[[i]], testData[[All, 1 ;; -2]], "survived" -> th]; ToROCAssociation[{"survived", "died"}, testData[[All, -1]], cres]), {th, rocRange}]; ROCPlot[rocRange, aROCs1, PlotLabel -> Keys[aCLs][[i]], PlotRange -> {{0, 1.05}, {0.6, 1.01}}, "PlotJoined" -> Automatic, GridLines -> Automatic], {i, 1, Length[aCLs]}]; GraphicsGrid[ArrayReshape[Append[Prepend[rocGRs, rocEnGr], rocEnGr], {2, 4}, ""], Dividers -> All, FrameStyle -> GrayLevel[0.8], ImageSize -> 1200] [![Ensemble3][6]][6] Let us plot all ROC curves from the graphics grid above into one plot. For that the single classifier ROC curves are made gray, and their threshold callouts removed. We can see that the classifier ensemble brings very good results for $\theta = 0.175$ and none of the single classifiers has a better point. Show[Append[rocGRs /. {RGBColor[___] -> GrayLevel[0.8]} /. {Text[p_, ___] :> Null} /. ((PlotLabel -> _) :> (PlotLabel -> Null)), rocEnGr]] [![EnsembleFull][7]][7] # Classifier ensembles by bootstrapping There are several ways to produce ensemble classifiers using [bootstrapping](https://en.wikipedia.org/wiki/Bootstrapping_(statistics)) or [jackknife](https://en.wikipedia.org/wiki/Jackknife_resampling) resampling procedures. First, we are going to make a bootstrapping classifier ensemble using one of the `Classify` methods. Then we are going to make a more complicated bootstrapping classifier with six methods of `Classify`. ## Bootstrapping ensemble with a single classification method First we select a classification method and make a classifier with it. clMethod = "NearestNeighbors"; sCL = Classify[trainingData[[All, 1 ;; -2]] -> trainingData[[All, -1]], Method -> clMethod]; The following code makes a classifier ensemble of 12 classifier functions using resampled, slightly smaller (10%) versions of the original training data (with `RandomChoice`). SeedRandom[1262]; aBootStrapCLs = Association@Table[( inds = RandomChoice[Range[Length[trainingData]], Floor[0.9*Length[trainingData]]]; ToString[i] -> Classify[trainingData[[inds, 1 ;; -2]] -> trainingData[[inds, -1]], Method -> clMethod]), {i, 12}]; Let us compare the ROC curves of the single classifier with the bootstrapping derived ensemble. rocRange = Range[0.1, 0.9, 0.025]; AbsoluteTiming[ aSingleROCs = Table[( cres = ClassifyByThreshold[sCL, testData[[All, 1 ;; -2]], "survived" -> i]; ToROCAssociation[{"survived", "died"}, testData[[All, -1]], cres]), {i, rocRange}]; aBootStrapROCs = Table[( cres = EnsembleClassifyByThreshold[aBootStrapCLs, testData[[All, 1 ;; -2]], "survived" -> i]; ToROCAssociation[{"survived", "died"}, testData[[All, -1]], cres]), {i, rocRange}]; ] (* {6.81521, Null} *) Legended[ Show[{ ROCPlot[rocRange, aSingleROCs, "ROCColor" -> Blue, "PlotJoined" -> Automatic, GridLines -> Automatic], ROCPlot[rocRange, aBootStrapROCs, "ROCColor" -> Red, "PlotJoined" -> Automatic]}], SwatchLegend @@ Transpose@{{Blue, Row[{"Single ", clMethod, " classifier"}]}, {Red, Row[{"Boostrapping ensemble of\n", Length[aBootStrapCLs], " ", clMethod, " classifiers"}]}}] [![Bootsrap1][8]][8] We can see that we get much better results with the bootstrapped ensemble. ## Bootstrapping ensemble with multiple classifier methods This code creates an classifier ensemble using the classifier methods corresponding to `Automatic` given as a first argument to `EnsembleClassifier`. SeedRandom[2324] AbsoluteTiming[ aBootStrapLargeCLs = Association@Table[( inds = RandomChoice[Range[Length[trainingData]], Floor[0.9*Length[trainingData]]]; ecls = EnsembleClassifier[Automatic, trainingData[[inds, 1 ;; -2]] -> trainingData[[inds, -1]]]; AssociationThread[Map[# <> "-" <> ToString[i] &, Keys[ecls]] -> Values[ecls]] ), {i, 12}]; ] (* {27.7975, Null} *) This code computes the ROC statistics with the obtained bootstrapping classifier ensemble: AbsoluteTiming[ aBootStrapLargeROCs = Table[( cres = EnsembleClassifyByThreshold[aBootStrapLargeCLs, testData[[All, 1 ;; -2]], "survived" -> i]; ToROCAssociation[{"survived", "died"}, testData[[All, -1]], cres]), {i, rocRange}]; ] (* {45.1995, Null} *) Let us plot the ROC curve of the bootstrapping classifier ensemble (in blue) and the single classifier ROC curves (in gray): aBootStrapLargeGr = ROCPlot[rocRange, aBootStrapLargeROCs, "PlotJoined" -> Automatic]; Show[Append[rocGRs /. {RGBColor[___] -> GrayLevel[0.8]} /. {Text[p_, ___] :> Null} /. ((PlotLabel -> _) :> (PlotLabel -> Null)), aBootStrapLargeGr]] [![BootsrapFull][9]][9] Again we can see that the bootstrapping ensemble produced better ROC points than the single classifiers. # Damaging data This section tries to explain why the bootstrapping with resampling to smaller sizes produces good results. In short, the training data has outliers; if we remove small fraction of the training data we might get better results. The procedure described in this section can be used in conjunction with the procedures described in the guide for importance of variables investigation \[[7](https://github.com/antononcube/MathematicaForPrediction/blob/master/MarkdownDocuments/Importance-of-variables-investigation-guide.md)\]. ## Ordering function Let us replace the categorical values with numerical in the training data. There are several ways to do it, here is a fairly straightforward one: nTrainingData = trainingData /. {"survived" -> 1, "died" -> 0, "1st" -> 0, "2nd" -> 1, "3rd" -> 2, "male" -> 0, "female" -> 1}; ## Decreasing proportions of females First, let us find all indices corresponding to records about females. femaleInds = Flatten@Position[trainingData[[All, 3]], "female"]; The following code standardizes the training data corresponding to females, finds the mean record, computes distances from the mean record, and finally orders the female records indices according to their distances from the mean record. t = Transpose@Map[Rescale@*Standardize, N@Transpose@nTrainingData[[femaleInds, 1 ;; 2]]]; m = Mean[t]; ds = Map[EuclideanDistance[#, m] &, t]; femaleInds = femaleInds[[Reverse@Ordering[ds]]]; The following plot shows the distances calculated above. ListPlot[Sort@ds, PlotRange -> All, PlotTheme -> "Detailed"] [![FemaleRecord][10]][10] The following code removes from the training data the records corresponding to females according to the order computed above. The female records farthest from the mean female record are removed first. AbsoluteTiming[ femaleFrRes = Association@ Table[cl -> Table[( inds = Complement[Range[Length[trainingData]], Take[femaleInds, Ceiling[fr*Length[femaleInds]]]]; cf = Classify[trainingData[[inds, 1 ;; -2]] -> trainingData[[inds, -1]], Method -> cl]; cfPredictedLabels = cf /@ testData[[All, 1 ;; -2]]; {fr, ToROCAssociation[{"survived", "died"}, testData[[All, -1]], cfPredictedLabels]}), {fr, 0, 0.8, 0.05}], {cl, {"NearestNeighbors", "NeuralNetwork", "LogisticRegression", "RandomForest", "SupportVectorMachine", "NaiveBayes"}}]; ] (* {203.001, Null} *) The following graphics grid shows how the classification results are affected by the removing fractions of the female records from the training data. The results for none or small fractions of records removed are more blue. GraphicsGrid[ArrayReshape[ Table[ femaleAROCs = femaleFrRes[cl][[All, 2]]; frRange = femaleFrRes[cl][[All, 1]]; ROCPlot[frRange, femaleAROCs, PlotRange -> {{0.0, 0.25}, {0.2, 0.8}}, PlotLabel -> cl, "ROCPointColorFunction" -> (Blend[{Blue, Red}, #3/Length[frRange]] &), ImageSize -> 300], {cl, Keys[femaleFrRes]}], {2, 3}], Dividers -> All] [![FemaleGrid][11]][11] We can see that removing the female records outliers has dramatic effect on the results by the classifiers "NearestNeighbors" and "NeuralNetwork". Not so much on "LogisticRegression" and "NaiveBayes". ## Decreasing proportions of males The code in this sub-section repeats the experiment described in the previous one males (instead of females). maleInds = Flatten@Position[trainingData[[All, 3]], "male"]; t = Transpose@Map[Rescale@*Standardize, N@Transpose@nTrainingData[[maleInds, 1 ;; 2]]]; m = Mean[t]; ds = Map[EuclideanDistance[#, m] &, t]; maleInds = maleInds[[Reverse@Ordering[ds]]]; ListPlot[Sort@ds, PlotRange -> All, PlotTheme -> "Detailed"] [![MaleRecord][12]][12] AbsoluteTiming[ maleFrRes = Association@ Table[cl -> Table[( inds = Complement[Range[Length[trainingData]], Take[maleInds, Ceiling[fr*Length[maleInds]]]]; cf = Classify[trainingData[[inds, 1 ;; -2]] -> trainingData[[inds, -1]], Method -> cl]; cfPredictedLabels = cf /@ testData[[All, 1 ;; -2]]; {fr, ToROCAssociation[{"survived", "died"}, testData[[All, -1]], cfPredictedLabels]}), {fr, 0, 0.8, 0.05}], {cl, {"NearestNeighbors", "NeuralNetwork", "LogisticRegression", "RandomForest", "SupportVectorMachine", "NaiveBayes"}}]; ] (* {179.219, Null} *) GraphicsGrid[ArrayReshape[ Table[ maleAROCs = maleFrRes[cl][[All, 2]]; frRange = maleFrRes[cl][[All, 1]]; ROCPlot[frRange, maleAROCs, PlotRange -> {{0.0, 0.35}, {0.55, 0.82}}, PlotLabel -> cl, "ROCPointColorFunction" -> (Blend[{Blue, Red}, #3/Length[frRange]] &), ImageSize -> 300], {cl, Keys[maleFrRes]}], {2, 3}], Dividers -> All] [![MaleGrid][13]][13] # Classifier interpolation Assume that we want a classifier that for a given representative set of $n$ items (records) assigns the positive label to an exactly $n_p$ of them. (Or very close to that number.) If we have two classifiers, one returning more positive items than $n_p$, the other less than $n_p$, then we can use geometric computations in the ROC space in order to obtain parameters for a classifier interpolation that will bring positive items close to $n_p$; see \[3\]. Below is given *Mathematica* code with explanations of how that classifier interpolation is done. Assume that by prior observations we know that for a given dataset of $n$ items the positive class consists of $\approx 0.09 n$ items. Assume that for a given unknown dataset of $n$ items we want $0.2 n$ of the items to be classified as positive. We can write the equation: $$ {FPR} * ((1-0.09) * n) + {TPR} * (0.09 * n) = 0.2 * n ,$$ which can be simplified to $$ {FPR} * (1-0.09) + {TPR} * 0.09 = 0.2 .$$ ## The two classifiers Consider the following two classifiers. cf1 = Classify[trainingData[[All, 1 ;; -2]] -> trainingData[[All, -1]], Method -> "RandomForest"]; cfROC1 = ToROCAssociation[{"survived", "died"}, testData[[All, -1]], cf1[testData[[All, 1 ;; -2]]]] (* <|"TruePositive" -> 82, "FalsePositive" -> 22, "TrueNegative" -> 170, "FalseNegative" -> 40|> *) cf2 = Classify[trainingData[[All, 1 ;; -2]] -> trainingData[[All, -1]], Method -> "LogisticRegression"]; cfROC2 = ToROCAssociation[{"survived", "died"}, testData[[All, -1]], cf2[testData[[All, 1 ;; -2]]]] (* <|"TruePositive" -> 89, "FalsePositive" -> 37, "TrueNegative" -> 155, "FalseNegative" -> 33|> *) ## Geometric computations in the ROC space Here are the ROC space points corresponding to the two classifiers, cf1 and cf2: p1 = Through[ROCFunctions[{"FPR", "TPR"}][cfROC1]]; p2 = Through[ROCFunctions[{"FPR", "TPR"}][cfROC2]]; Here is the breakdown of frequencies of the class labels: Tally[trainingData[[All, -1]]] %[[All, 2]]/Length[trainingData] // N (* {{"survived", 305}, {"died", 427}} {0.416667, 0.583333}) *) We want to our classifier to produce $38$% people to survive. Here we find two points of the corresponding constraint line (on which we ROC points of the desired classifiers should reside): sol1 = Solve[{{x, y} \[Element] ImplicitRegion[{x (1 - 0.42) + y 0.42 == 0.38}, {x, y}], x == 0.1}, {x, y}][[1]] sol2 = Solve[{{x, y} \[Element] ImplicitRegion[{x (1 - 0.42) + y 0.42 == 0.38}, {x, y}], x == 0.25}, {x, y}][[1]] (* {x -> 0.1, y -> 0.766667} {x -> 0.25, y -> 0.559524} *) Here using the points q1 and q2 of the constraint line we find the intersection point with the line connecting the ROC points of the classifiers: {q1, q2} = {{x, y} /. sol1, {x, y} /. sol2}; sol = Solve[ {{x, y} \[Element] InfiniteLine[{q1, q2}] \[And] {x, y} \[Element] InfiniteLine[{p1, p2}]}, {x, y}]; q = {x, y} /. sol[[1]] (* {0.149753, 0.69796} *) Let us plot all geometric objects: Graphics[{PointSize[0.015], Blue, Tooltip[Point[p1], "cf1"], Black, Text["cf1", p1, {-1.5, 1}], Red, Tooltip[Point[p2], "cf2"], Black, Text["cf2", p2, {1.5, -1}], Black, Point[q], Dashed, InfiniteLine[{q1, q2}], Thin, InfiniteLine[{p1, p2}]}, PlotRange -> {{0., 0.3}, {0.6, 0.8}}, GridLines -> Automatic, Frame -> True] ![Classifier-Interpolation-geometric-objects][15] ## Classifier interpolation Next we find the ratio of the distance from the intersection point q to the cf1 ROC point and the distance between the ROC points of cf1 and cf2. k = Norm[p1 - q]/Norm[p1 - p2] (* 0.450169 *) The classifier interpolation is made by a weighted random selection based on that ratio (using `RandomChoice`): SeedRandom[8989] cres = MapThread[If, {RandomChoice[{1 - k, k} -> {True, False}, Length[testData]], cf1@testData[[All, 1 ;; -2]], cf2@testData[[All, 1 ;; -2]]}]; cfROC3 = ToROCAssociation[{"survived", "died"}, testData[[All, -1]], cres]; p3 = Through[ROCFunctions[{"FPR", "TPR"}][cfROC3]]; Graphics[{PointSize[0.015], Blue, Point[p1], Red, Point[p2], Black, Dashed, InfiniteLine[{q1, q2}], Green, Point[p3]}, PlotRange -> {{0., 0.3}, {0.6, 0.8}}, GridLines -> Automatic, Frame -> True] ![Classifier-Interpolation-single-results][16] We can run the process multiple times in order to convince ourselves that the interpolated classifier ROC point is very close to the constraint line most of the time. p3s = Table[( cres = MapThread[If, {RandomChoice[{1 - k, k} -> {True, False}, Length[testData]], cf1@testData[[All, 1 ;; -2]], cf2@testData[[All, 1 ;; -2]]}]; cfROC3 = ToROCAssociation[{"survived", "died"}, testData[[All, -1]], cres]; Through[ROCFunctions[{"FPR", "TPR"}][cfROC3]]), {1000}]; Show[{SmoothDensityHistogram[p3s, ColorFunction -> (Blend[{White, Green}, #] &), Mesh -> 3], Graphics[{PointSize[0.015], Blue, Tooltip[Point[p1], "cf1"], Black, Text["cf1", p1, {-1.5, 1}], Red, Tooltip[Point[p2], "cf2"], Black, Text["cf2", p2, {1.5, -1}], Black, Dashed, InfiniteLine[{q1, q2}]}, GridLines -> Automatic]}, PlotRange -> {{0., 0.3}, {0.6, 0.8}}, GridLines -> Automatic, Axes -> True, AspectRatio -> Automatic] ![Classifier-Interpolation-1000-results][17] # References \[1\] Leo Breiman, Statistical Modeling: The Two Cultures, (2001), Statistical Science, Vol. 16, No. 3, 199\[Dash]231. \[2\] Wikipedia entry, Receiver operating characteristic. URL: http://en.wikipedia.org/wiki/Receiver_operating_characteristic . \[3\] Tom Fawcett, An introduction to ROC analysis, (2006), Pattern Recognition Letters, 27, 861\[Dash]874. ([Link to PDF](Link to PDF).) \[4\] Anton Antonov, [MathematicaForPrediction utilities](https://github.com/antononcube/MathematicaForPrediction/blob/master/MathematicaForPredictionUtilities.m), (2014), source code [MathematicaForPrediction at GitHub](https://github.com/antononcube/MathematicaForPrediction), package [MathematicaForPredictionUtilities.m](https://raw.githubusercontent.com/antononcube/MathematicaForPrediction/master/MathematicaForPredictionUtilities.m). \[5\] Anton Antonov, [Receiver operating characteristic functions Mathematica package](https://github.com/antononcube/MathematicaForPrediction/blob/master/ROCFunctions.m), (2016), source code [MathematicaForPrediction at GitHub](https://github.com/antononcube/MathematicaForPrediction), package [ROCFunctions.m](https://raw.githubusercontent.com/antononcube/MathematicaForPrediction/master/ROCFunctions.m). \[6\] Anton Antonov, [Classifier ensembles functions Mathematica package](https://github.com/antononcube/MathematicaForPrediction/blob/master/ClassifierEnsembles.m), (2016), source code [MathematicaForPrediction at GitHub](https://github.com/antononcube/MathematicaForPrediction), package [ClassifierEnsembles.m](https://raw.githubusercontent.com/antononcube/MathematicaForPrediction/master/ClassifierEnsembles.m). \[7\] Anton Antonov, "[Importance of variables investigation guide](https://github.com/antononcube/MathematicaForPrediction/blob/master/Documentation/Importance-of-variables-investigation-guide.pdf)", (2016), [MathematicaForPrediction at GitHub](https://github.com/antononcube/MathematicaForPrediction), https://github.com/antononcube/MathematicaForPrediction, folder [Documentation](https://github.com/antononcube/MathematicaForPrediction/tree/master/Documentation). [1]:http://i.imgur.com/WDNgwNf.png [2]:http://i.imgur.com/G6DD5DD.png [3]:http://i.imgur.com/annEj2s.png [4]:http://i.imgur.com/c4pPgnq.png [5]:http://i.imgur.com/JZ6JpfY.png [6]:http://i.imgur.com/C9ZBbEv.png [7]:http://i.imgur.com/jmdC521.png [8]:http://i.imgur.com/faspQpc.png [9]:http://i.imgur.com/IZLiMer.png [10]:http://i.imgur.com/XMPsiNO.png [11]:http://i.imgur.com/BkDTZXD.png [12]:http://i.imgur.com/bZY8pL3.png [13]:http://i.imgur.com/Te2kDxh.png [14]:http://i.imgur.com/OcCFBBH.png [15]:http://i.imgur.com/brboKWy.png [16]:http://i.imgur.com/uP4aexV.png [17]:http://i.imgur.com/8cZHK2o.png Anton Antonov 2016-10-15T17:12:50Z https://community.wolfram.com/groups/-/m/t/3055705 &[Wolfram Notebook][1] [1]: https://www.wolframcloud.com/obj/b1da2e64-8dfd-491e-95ee-a00662e000bf Anton Antonov 2023-10-25T19:28:53Z https://community.wolfram.com/groups/-/m/t/1358396 Caveat: this may be more of a math problem than a Mathematica-specific problem, but I thought some in this group might have insight. A solved problem is moving from a map in which there are districts with boundaries to a representation of that map as a network in which the vertices are the districts and edges represent shared boundaries between districts. fr = UndirectedGraph[ NestGraph[#["BorderingCountries"] &, Entity["Country", "France"], 3]] But what about the inverse problem: how does one move from a network to a map which is consistent with that network. There are likely to be an infinite number of such maps, but how does one even find a single exemplar. I'm thinking this is actually quite a difficult problem, but perhaps some people here might have insight on the matter and how such an exercise might be tackled using Mathematica. Seth Chandler 2018-06-19T13:27:01Z https://community.wolfram.com/groups/-/m/t/138207 Following up on Bernat's posting here [url=http://community.wolfram.com/groups/-/m/t/136023?p_p_auth=2Af2XNsw]http://community.wolfram.com/groups/-/m/t/136023?p_p_auth=2Af2XNsw[/url], I attempted my first cut on simulating an ant colony hunting for food. The code runs too slow, it processes 3.5 cycles (ticks) per second for 25 ants. Would be very grateful for ideas on how to:[list=1] [*]Improve performance of the code. [*]Mathematica Functions/Ideas for adding diffusion to the pheromone field (represented by a matrix) without adding excessive performance cost (played with converting the matrix to an image > blurring > converting it back to a matrix) which adds and excessive time penalty. [/list]Hope the code is clear enough. As written it takes 517 seconds in my PC.[mcode](*Define the world size*) ymax = 200; xmax = 400; (*Locate the colony somwhere in the world*) nest = {RandomInteger[{1, xmax}], RandomInteger[{1, ymax}]}; maxAnts = 25; ticks = 1; maxSteps = 2000; maxSpeed = 6; maxAngle = 13 \[Pi]/16; maxFoodPiles = 8; smellRange = 12; pheromoneDeposit = 1; foodMultiplier = 1000; pheromoneMultiplier = 10; fieldCaptureInterval = 10; discriminationFactor = 16; noFood = 0; withFood = 1; antSymbol = \[Infinity]; evaporationRate = ConstantArray[(1 - 0.005), {xmax, ymax}]; pheromoneField = ConstantArray[0., {xmax, ymax}]; pheromoneField[[First@nest, Last@nest]] = 100000; (*Added a lot of pheromone at the nest to 'help' the ants \ get back to the nest*) foodField = ConstantArray[0., {xmax, ymax}]; (*Scatter the food in the world*) foodPiles = Transpose[{RandomInteger[{1, xmax}, maxFoodPiles], RandomInteger[{1, ymax}, maxFoodPiles]}]; (foodField[[#[[1]], #[[2]]]] = 10) & /@ foodPiles; (*We'll record the history of the fields in these variables*) pheromoneHistory = {pheromoneField}; foodHistory = {foodField}; (*Functions*) (*Find out all positions that the ant will step as it moves \ forward/Keep ants within the world*) calculateLoc[location_, direction_, steps_] := Module[{loc, result = {}}, Do[loc = Flatten[ location + Round[{temp*Cos[direction], temp*Sin[direction]}]]; loc = Min[#] & /@ Transpose[{loc, {xmax, ymax}}]; loc = Max[#] & /@ Transpose[{loc, {1, 1}}]; result = Append[result, loc], {temp, steps}]; result] (*Return the distribution probability of the direction that the ant \ will head to*) (*It will add the smell of pheromones + food if no food is being \ carried *) probDist[location_, direction_, hasFood_, range_, angle_, steps_] := Module[{dist, total, bins, vals}, dist = Flatten[ Table[{direction + y , Flatten[location + Round[{x*Cos[direction + y ], x*Sin[direction + y ]}]]}, {y, -angle/2, angle/2, angle/steps}, {x, 1, range, 1}], 1]; dist = DeleteCases[dist, Alternatives[{_, {a_ /; a < 1, _}}, {_, {a_ /; a > xmax, _}}, {_, {_, b_ /; b < 1}}, {_, {_, b_ /; b > ymax}}]]; (dist[[#, 2]] = ((1 - hasFood) foodMultiplier foodField[[ First@dist[[#, 2]], Last@dist[[#, 2]]]] + pheromoneField[[First@dist[[#, 2]], Last@dist[[#, 2]]]])) & /@ Range[Length[dist]]; bins = Union[dist[[All, 1]]]; vals = Cases[dist, {#, y_} -> y] & /@ bins; vals = (Total[#] & /@ vals); total = Total[vals]; If[total == 0, UniformDistribution[{direction - angle/2, direction + angle/2}], EmpiricalDistribution[Rule[vals, bins]]]] (*Routine Determines where the ant should head next*) (*Also updates the pheromone field*) update[agent[id_, symbol_, location_, direction_, hasFood_]] := Module[{temp, dist, dir, speed, loc, path, status, foundDestination, multiplier}, dir = RandomVariate[ probDist[location, direction, hasFood, smellRange, maxAngle, discriminationFactor]]; speed = RandomVariate[UniformDistribution[{1, maxSpeed}], 1]; loc = calculateLoc[location, dir, speed]; status = hasFood; If[status == noFood, multiplier = 1; foundDestination = Select[loc, foodField[[#[[1]], #[[2]]]] > 0 &]; If[Length@foundDestination != 0, status = withFood; dir = dir + \[Pi]; multiplier = pheromoneMultiplier; foundDestination = First@foundDestination; foodField[[foundDestination[[1]], foundDestination[[2]]]] = foodField[[foundDestination[[1]], foundDestination[[2]]]] - 1;], multiplier = pheromoneMultiplier; foundDestination = Cases[loc, nest]; If[Length@foundDestination != 0, status = noFood; dir = dir + \[Pi]; multiplier = 1;] ] (pheromoneField[[#[[1]], #[[2]]]] = pheromoneField[[#[[1]], #[[2]]]] + multiplier pheromoneDeposit) & /@ loc; agent[id, symbol, Last@loc, dir, status]] update[agentList_List] := Module[{set = update[#] & /@ agentList}, pheromoneField = evaporationRate pheromoneField; If[Mod[ticks, fieldCaptureInterval] == 0, pheromoneHistory = Append[pheromoneHistory, pheromoneField]; foodHistory = Append[foodHistory, foodField];]; ticks++; set] (*Routines to display the ants in the animate section. Regretably \ can't be used due to memory leak*) display[agent[id_, symbol_, location_, direction_, hasFood_]] := Text[Rotate[symbol, direction], location] display[list_] := Module[{lst = display[#] & /@ list}, Graphics[lst]] (*initialize ants*) (*Initialize the colony - in which direction will the ants start \ walking out*) ants = Table[ agent[id, antSymbol, nest, RandomVariate[UniformDistribution[{0, 2 \[Pi]}]], noFood], {id, maxAnts}]; antHistory = NestList[update, ants, maxSteps]; // AbsoluteTiming (*Did the ants eat the food? Check status of the food piles and how \ the pheromone field changed with time*) foodField[[#[[1]], #[[2]]]] & /@ foodPiles Manipulate[ Show[ColorNegate@ImageRotate@Image@pheromoneHistory[[i]], Graphics[{Red, PointSize[Large], Point[nest], PointSize[Medium], Blue, Point[foodPiles]}]], {i, 1, Length@pheromoneHistory, 1}] [/mcode][img=width: 800px; height: 557px;]/c/portal/getImageAttachment?filename=ants.gif&userId=78214[/img] Diego Zviovich 2013-10-12T21:08:11Z https://community.wolfram.com/groups/-/m/t/2920790 &[Wolfram Notebook][1] [1]: https://www.wolframcloud.com/obj/580db34a-30e4-447b-8db2-9df739ad718e Anton Antonov 2023-05-17T15:18:40Z https://community.wolfram.com/groups/-/m/t/2674963 ![enter image description here][1] &[Wolfram Notebook][2] [1]: https://community.wolfram.com//c/portal/getImageAttachment?filename=Image20221027223559.png&userId=20103 [2]: https://www.wolframcloud.com/obj/2ce060cf-f735-44ef-89d5-2a5de94db174 Jindřich Michalik 2022-10-27T20:36:50Z https://community.wolfram.com/groups/-/m/t/941017 ## Introduction This post is for the package \[[2](https://github.com/antononcube/MathematicaForPrediction/blob/master/ROCFunctions.m)\] that provides *Mathematica* implementations of [Receiver Operating Characteristic](https://en.wikipedia.org/wiki/Receiver_operating_characteristic) (ROC) functions calculation and plotting. The ROC framework is used for analysis and tuning of binary classifiers, \[[3](https://en.wikipedia.org/wiki/Receiver_operating_characteristic)\]. (The classifiers are assumed to classify into a positive/true label or a negative/false label. ) The function `ROCFuntions` gives access to the individual ROC functions through string arguments. Those ROC functions are applied to special objects, called ROC Association objects. Each ROC Association object is an `Association` that has the following four keys: "TruePositive", "FalsePositive", "TrueNegative", and "FalseNegative" . Given two lists of actual and predicted labels a ROC Association object can be made with the function `ToROCAssociation` . For more definitions and example of ROC terminology and functions see \[[3](https://en.wikipedia.org/wiki/Receiver_operating_characteristic),[4](https://ccrma.stanford.edu/workshops/mir2009/references/ROCintro.pdf)\]. ## Minimal example Note that here although we use both of the provided Titanic training and test data, the code is doing only training. The test data is used to find the best tuning parameter (threshold) through ROC analysis. ### Get packages These commands load the packages \[[1](https://github.com/antononcube/MathematicaForPrediction/blob/master/MathematicaForPredictionUtilities.m),[2](https://github.com/antononcube/MathematicaForPrediction/blob/master/ROCFunctions.m)\]: Import["https://raw.githubusercontent.com/antononcube/MathematicaForPrediction/master/MathematicaForPredictionUtilities.m"] Import["https://raw.githubusercontent.com/antononcube/MathematicaForPrediction/master/ROCFunctions.m"] ### Using Titanic data Here is the summary of the Titanic data used below: titanicData = (Flatten@*List) @@@ExampleData[{"MachineLearning", "Titanic"}, "Data"]; columnNames = (Flatten@*List) @@ExampleData[{"MachineLearning", "Titanic"}, "VariableDescriptions"]; RecordsSummary[titanicData, columnNames] [![Titanic1][1]][1] This variable dependence grid shows the relationships between the variables. Magnify[#, 0.7] &@VariableDependenceGrid[titanicData, columnNames] [![VariableDependencies][7]][7] ### Get training and testing data data = ExampleData[{"MachineLearning", "Titanic"}, "TrainingData"]; data = ((Flatten@*List) @@@ data)[[All, {1, 2, 3, -1}]]; trainingData = DeleteCases[data, {___, _Missing, ___}]; Dimensions[trainingData] (* {732, 4} *) data = ExampleData[{"MachineLearning", "Titanic"}, "TestData"]; data = ((Flatten@*List) @@@ data)[[All, {1, 2, 3, -1}]]; testData = DeleteCases[data, {___, _Missing, ___}]; Dimensions[testData] (* {314, 4} *) ### Replace categorical with numerical values trainingData = trainingData /. {"survived" -> 1, "died" -> 0, "1st" -> 0, "2nd" -> 1, "3rd" -> 2, "male" -> 0, "female" -> 1}; testData = testData /. {"survived" -> 1, "died" -> 0, "1st" -> 1, "2nd" -> 2, "3rd" -> 3, "male" -> 0, "female" -> 1}; ### Do linear regression lfm = LinearModelFit[{trainingData[[All, 1 ;; -2]], trainingData[[All, -1]]}] [![Regression1][2]][2] ### Get the predicted values modelValues = lfm @@@ testData[[All, 1 ;; -2]]; Histogram[modelValues, 20] [![Prediction1][3]][3] RecordsSummary[modelValues] [![Prediction2][4]][4] ### Obtain ROC associations over a set of parameter values testLabels = testData[[All, -1]]; thRange = Range[0.1, 0.9, 0.025]; aROCs = Table[ToROCAssociation[{1, 0}, testLabels, Map[If[# > \[Theta], 1, 0] &, modelValues]], {\[Theta], thRange}]; ### Evaluate ROC functions for given ROC association N @ Through[ROCFunctions[{"PPV", "NPV", "TPR", "ACC", "SPC", "MCC"}][aROCs[[3]]]] (* {0.513514, 0.790698, 0.778689, 0.627389, 0.53125, 0.319886} *) ### Standard ROC plot ROCPlot[thRange, aROCs, "PlotJoined" -> Automatic, "ROCPointCallouts" -> True, "ROCPointTooltips" -> True, GridLines -> Automatic] [![ROCPlot1][5]][5] ### Plot ROC functions wrt to parameter values rocFuncs = {"PPV", "NPV", "TPR", "ACC", "SPC", "MCC"}; rocFuncTips = Map[# <> ", " <> (ROCFunctions["FunctionInterpretations"][#]) &, rocFuncs]; ListLinePlot[ MapThread[Tooltip[Transpose[{thRange, #1}], #2] &, {Transpose[Map[Through[ROCFunctions[rocFuncs][#]] &, aROCs]], rocFuncTips}], Frame -> True, FrameLabel -> Map[Style[#, Larger] &, {"threshold, \[Theta]", "rate"}], PlotLegends -> rocFuncTips, GridLines -> Automatic] [![ROCPlot2][6]][6] ### Finding the intersection point of PPV and TPR We want to find a point that provides balanced positive and negative labels success rates. One way to do this is to find the intersection point of the ROC functions PPV (positive predictive value) and TPR (true positive rate). Examining the plot above we can come up with the initial condition for $x$. ppvFunc = Interpolation[Transpose@{thRange, ROCFunctions["PPV"] /@ aROCs}]; tprFunc = Interpolation[Transpose@{thRange, ROCFunctions["TPR"] /@ aROCs}]; FindRoot[ppvFunc[x] - tprFunc[x] == 0, {x, 0.2}] (* {x -> 0.3} *) ### Area under the ROC curve The Area Under the ROC curve (AUROC) tells for a given range of the controlling parameter "what is the probability of the classifier to rank a randomly chosen positive instance higher than a randomly chosen negative instance, (assuming 'positive' ranks higher than 'negative')", [3,4] Calculating AUROC is easy using the Trapezoidal quadrature formula: N@Total[Partition[Sort@Transpose[{ROCFunctions["FPR"] /@ aROCs, ROCFunctions["TPR"] /@ aROCs}], 2, 1] /. {{x1_, y1_}, {x2_, y2_}} :> (x2 - x1) (y1 + (y2 - y1)/2)] (* 0.474513 *) It is also implemented in \[[2](https://github.com/antononcube/MathematicaForPrediction/blob/master/ROCFunctions.m)\]: N@ROCFunctions["AUROC"][aROCs] (* 0.474513 *) ## References \[1\] Anton Antonov, [MathematicaForPrediction utilities](https://github.com/antononcube/MathematicaForPrediction/blob/master/MathematicaForPredictionUtilities.m), (2014), source code [MathematicaForPrediction at GitHub](https://github.com/antononcube/MathematicaForPrediction), package [MathematicaForPredictionUtilities.m](https://raw.githubusercontent.com/antononcube/MathematicaForPrediction/master/MathematicaForPredictionUtilities.m). \[2\] Anton Antonov, [Receiver operating characteristic functions Mathematica package](https://github.com/antononcube/MathematicaForPrediction/blob/master/ROCFunctions.m), (2016), source code [MathematicaForPrediction at GitHub](https://github.com/antononcube/MathematicaForPrediction), package [ROCFunctions.m](https://raw.githubusercontent.com/antononcube/MathematicaForPrediction/master/ROCFunctions.m) . \[3\] Wikipedia entry, [Receiver operating characteristic](http://en.wikipedia.org/wiki/Receiver_operating_characteristic). \[4\] Tom Fawcett, [An introduction to ROC analysis](https://ccrma.stanford.edu/workshops/mir2009/references/ROCintro.pdf), (2006), Pattern Recognition Letters, 27, 861-874. [1]:http://i.imgur.com/VTVyV9P.png [2]:http://i.imgur.com/d663I98.png [3]:http://i.imgur.com/bBXsDp2.png [4]:http://i.imgur.com/mzWjhZc.png [5]:https://i.imgur.com/Sam8wX5.png [6]:https://i.imgur.com/lrGRgJp.png [7]:http://i.imgur.com/DSkPQOH.png Anton Antonov 2016-10-12T13:21:04Z https://community.wolfram.com/groups/-/m/t/2333107 &[Wolfram Notebook][1] [1]: https://www.wolframcloud.com/obj/54323170-e51a-47ca-a4d4-3516daa04d8d Arnoud Buzing 2021-08-02T17:06:46Z https://community.wolfram.com/groups/-/m/t/3763738 ![Evaluating Black-Box Physics Through Optical Emulation][1] &[Wolfram Notebook][2] [1]: https://community.wolfram.com//c/portal/getImageAttachment?filename=bracelet.png&userId=3760415 [2]: https://www.wolframcloud.com/obj/a69cbbc1-44d8-4d3b-a1e1-2029814fd159 Hubert Kołcz 2026-07-17T12:40:37Z