Wolfram 分析：您知道奥运奖牌的价值吗?

WolframChina

发布于 2022-03-29 21:10:46

2580

发布于 2022-03-29 21:10:46

文章被收录于专栏：WOLFRAMWOLFRAM

想必大家都在早晚刷屏北京冬奥会，作为“狼粉”的我们也来刷刷 Wolfram 语言能为奥运会干点啥吧。

上面的奥运环就是用 Wolfram 语言写的哦：

circ = Cases[
    ParametricPlot3D[{Cos[t], Sin[t], Cos[3 t]}, {t, 0, 2 Pi}], _Line,
     Infinity][[1, 1]];
min = 2;
max = 3;
colorNames = {"Gold", "Emerald", "Blue", "Black", "Red", "Maroon", 
   "Orange", "Brown", "Purple"};
colors = Interpreter["Color"] /@ colorNames;
coloriter = 1;
Graphics3D[
 Table[{Directive[Black, Glow[colors[[coloriter++]]]], 
   Tube[Composition[
      TranslationTransform[{12 (max - i) + 24 j, 11 (i - min), 0}/10],
       RotationTransform[Mod[i, 2]*Pi/3, {0, 0, 1}]] /@ circ, 
    1/8]}, {i, min, max}, {j, 1, i}], Method -> {"TubePoints" -> 30}, 
 ViewPoint -> {0, 0, Infinity}, Boxed -> False]

你要是在 Mathematica 中用鼠标稍微旋转一下，就成下面这样了：

这背后的环相锁和 3D 的原理请参见社区的讨论。稍作改动还可以画出不同的环数。

奧運環

下面这个是用 Wolfram 语言中的 UnityLink 制作的奥运环：

代码太长就不贴了，大家请移步Wolfram社区：https://community.wolfram.com/groups/-/m/t/2325991 下载或查看源代码。

Wolfram 知識庫

Wolfram 知识库里有很多令人兴奋的历史数据。

您知道吗，2008年是中国获取金牌和奖牌数量最多的一年，虽然总的奖牌数量低于美国，但是含金量确是第一哦！

美国拿了最多的奖牌。但是问任何体育迷，从小联盟的 tee-ball 到世界级的比赛，你会听到同样的重复：整个社区都参与了运动员的培养。考虑到这句格言，我不禁想知道：一个国家的人口规模是否与其奥运选手的成功相关？美国、中国和俄罗斯都是人口相当多的国家，但如果除以人口规模，他们赢了多少奖牌呢？

幸运的是，我們可以使用单击窗格右上角的 + 按钮时可用的输出选项之一，以一种很好的可计算形式轻松获取数据以供 Wolfram 语言进行分析。通过选择“Computable Data”，Wolfram 语言将创建我們需要的代码并将结果作为列表提供给我。

然后我们利用2008年的人口数据：

medals = Drop[%, 1];
populationIn2008[nation_] := CountryData[nation, {"Population", 2008}]
medalsPerPop = 
  Table[{row[[1]], row[[-1]]/populationIn2008[row[[1]]]}, {row, 
    medals}];
sortedPerPop = Reverse[SortBy[medalsPerPop, Last]];
(*The five highest and the five lowest nations in terms of medals per \
person*)
{sortedPerPop[[1 ;; 5]], sortedPerPop[[-5 ;; -1]]} // TableForm

牙買加的总奖牌数量是第20位，但人均奖牌数量却是第一。

Money

让我们考虑一下：如果牙買加获得的不是奖牌，而是获得金牌的金属的总市场价格，该怎么計算呢？使用美国地质调查局关于矿产和材料商品的数据（https : // pubs . usgs . gov/sir/2012/5188/tables/），这是一个很容易估算的问题——包括铜在内的金属的价值全年波动很大，而且奥运会奖牌的构成因奥运会主办国而异。对于金属的成分，我使用了当时各种不同的文章（特别是这篇文章：https://www.forbes.com/sites/anthonydemarco/2012/07/26/a-closer-look-at-the-olympic-gold-medal/?sh=617ebaa86d27）来得出一个合理的估计。尽管奖牌组成的数据以克为单位，而 USGS 的数据以金衡盎司为单位，但 Wolfram 语言可以轻松地为我处理单位转换。

usgsData[filename_] := 
 UnitConvert[
  Quantity[Cases[Import[filename], {2008., __}, Infinity][[1]][[3]], 
   "USDollars"/"TroyOunces"], "USDollars"/"Grams"]
   prices = AssociationMap[
  usgsData[StringJoin[#, ".xlsx"]] &, {"gold", "silver", "copper", 
   "zinc", "tin"}]

<|"gold" -> Quantity[28.0837, ("USDollars")/("Grams")], 
 "silver" -> Quantity[0.482261, ("USDollars")/("Grams")], 
 "copper" -> Quantity[10.2613, ("USDollars")/("Grams")], 
 "zinc" -> Quantity[0.0285904, ("USDollars")/("Grams")], 
 "tin" -> Quantity[0.362982, ("USDollars")/("Grams")]|>

注意到上面的数据中铜的文件单位不一致，所以单独计算铜：

usgsCopperData[filename_] := 
 UnitConvert[
  Quantity[Cases[Import[filename], {2008., __}, Infinity][[1]][[3]], 
   "USCents"/"Pounds"], "USDollars"/"Grams"

copperPrice = usgsData["copper.xlsx"]
Quantity[0.00703634, ("USDollars")/("Grams")]

最後看看把獎牌換成美元是多少：

medalGrosses = 
 Table[{row[[1]], 
   costOfGoldMedal*row[[2]] + costOfSilverMedal*row[[3]] + 
    costOfBronzeMedal*row[[4]]}, {row, medals}]

中国的奖牌数虽然屈居第二，但是价值却超过奖牌数第一的美国！

奖牌分布

Wolfram|Alpha， Wolfram 庞大的知识库还有啥数据呢？

我们来看看2020年中国的奖牌数分布：

medalsBySport[country_, year_, more_ : 99] := 
 With[{waResults = 
    WolframAlpha[
     country <> " at the " <> ToString[year] <> 
      " summer olympics", {{"OlympicMedalistResults:OlympicData", 
       All}, {"Title", "ComputableData"}}, 
     PodStates -> {ToString[more] <> 
        "@OlympicMedalistResults:OlympicData__More"}, 
     TimeConstraint -> Infinity]}, {Last[#1], 
     Length[Last[#2]] - 1} & @@@ 
   GatherBy[waResults[[2 ;;]], #[[1, 1]] &]]

chartifyMedalsBySport[results_] := 
 PieChart[Last /@ results, 
  ChartLabels -> Placed[First /@ results, "RadialCallout"], 
  ChartStyle -> 54]

medalsBySport["China", 2020]~SortBy~Last

{{"Basketball", 1}, {"Cycling", 1}, {"Fencing", 1}, {"Taekwondo", 
  1}, {"Boxing", 2}, {"Karate", 2}, {"Sailing", 
  2}, {"Synchronised swimming", 2}, {"Canoeing", 3}, {"Rowing", 
  3}, {"Wrestling", 4}, {"Track & field", 5}, {"Badminton", 
  6}, {"Swimming", 6}, {"Table tennis", 7}, {"Weightlifting", 
  8}, {"Gymnastics", 11}, {"Shooting", 11}, {"Diving", 12}}

2020年奧運會中国拿到奖牌数最多的前六名運動是跳水、射击、体操、举重、乒乓球、游泳、羽毛球。

最后我们看一下自 1984 年以来中国获得的奖牌数的分布：

olympicyears = Range[1984, 2020, 4]
allChinaMedals = medalsBySport["China", #] & /@ olympicyears;
aggregateMedals[allMedals_] := {First[First[#]], Total[Last /@ #]} & /@
   GatherBy[Flatten[allMedals, 1], First]
aggregateMedals[allChinaMedals]~SortBy~Last;
chartifyMedalsBySport[%]