Explore la cinematografía

Utilice Wolfram Knowledgebase para estudiar el costo por minuto y los recibos de taquilla para las películas lanzadas desde el año 2000. Además, explore el tiempo de proyección promedio de estas películas, que, de manera inusual entre los objetos hechos por el hombre, parece seguir la denominada ley de distribución estable.

Utilice una clase de entidades implícitamente definida para seleccionar las películas lanzadas desde el cambio de milenio.

In[1]:=

Length[movies = EntityClass["Movie", EntityProperty["Movie", "ReleaseDate"] -> Between[{DateObject[{2000}], DateObject[{2015}]}]] // EntityList]

Out[1]=

Recupere los títulos de película, los géneros, tiempos de proyección, presupuestos de producción y totales de taquilla.

In[2]:=

movieData = EntityValue[ movies, {EntityProperty["Movie", "Name"], EntityProperty["Movie", "Genres"], EntityProperty["Movie", "Runtime"], EntityProperty["Movie", "ReleaseDate"], EntityProperty["Movie", "ProductionBudget"], EntityProperty["Movie", "DomesticBoxOfficeGross"]}];

El costo por minuto de una película estrenada es una función altamente fluctuante en el tiempo.

In[3]:=

costPerMinute = TimeSeries[{#[[1, 4]], Mean[#5/#3 & @@@ #]} & /@ Split[SortBy[ Cases[movieData, {_, _, _Quantity, _DateObject, _Quantity, _}], \ #[[4]] &], #1[[4]] === #2[[4]] &]];

In[4]:=

DateListLogPlot[costPerMinute, FrameLabel -> Automatic, PlotLabel -> "average cost per minute", AxesOrigin -> {DateObject[{2000, 1, 1}], 0}]

Out[4]=

Sin embargo, promediado en un mes, algunas periodicidades del costo por minuto son visibles. En particular, las líneas verdes denotan el Cuatro de Julio y las líneas en morado denotan el Día de Acción de Gracias en el siguiente gráfico.

In[5]:=

DateListPlot[MovingAverage[costPerMinute, Quantity[1, "Months"]], FrameLabel -> Automatic, PlotLabel -> "average cost per minute", AxesOrigin -> {DateObject[{2000, 1, 1}], 0}, GridLines -> {Join[{#, Darker[Green]} & /@ Table[DateObject[{y, 7, 4}], {y, 2000, 2015}], {#, Darker[Purple]} & /@ Table[DateObject@ WolframAlpha[ "Thanksgiving " <> IntegerString[y], {{"Result", 1}, "ComputableData"}], {y, 2000, 2015}]], None}]

Out[5]=

Como se muestra en el gráfico logarítmico, los recibos de taquilla por minuto constituyen una función aún más fluctuante.

In[6]:=

profitPerMinute = TimeSeries[{#[[1, 4]], Mean[#6/#3 & @@@ #]} & /@ Split[SortBy[ Cases[movieData, {_, _, _Quantity, _DateObject, _, _Quantity}], \ #[[4]] &], #1[[4]] === #2[[4]] &]];

In[7]:=

DateListLogPlot[MovingAverage[profitPerMinute, Quantity[1, "Months"]], FrameLabel -> Automatic, PlotLabel -> "box office receipts per film minute", AxesOrigin -> {DateObject[{2000, 1, 1}], 0}, PlotRange -> {{DateObject[{2000, 1, 1}], DateObject[{2015, 12, 31}]}, All}]

Out[7]=

El promedio de proyección de las películas ha sido bastante constante en los últimos 15 años.

In[8]:=

averageRuntimes = {#[[1, 1]], Mean[#[[All, -1]]]} & /@ Split[Sort[{DateObject[{#4["Year"]}], UnitConvert[#3, "Minutes"]} & @@@ Cases[movieData, {_, _, _Quantity, _DateObject, _, _}]], #1[[ 1]] === #2[[1]] &];

In[9]:=

DateListPlot[averageRuntimes, FrameLabel -> Automatic, PlotLabel -> "average runtime", AxesOrigin -> {DateObject[{2000, 1, 1}], 0}]

Out[9]=

Viendo con más detalle, la distribución de las proyecciones de películas parece ser relativamente suave.

In[10]:=

movieRuntimes = DeleteMissing[movieData[[All, 3]]];

In[11]:=

hg = Histogram[movieRuntimes, {1, 200, 5}, "PDF", AxesLabel -> Automatic]

Out[11]=

El modelado usando un gran número de distribuciones incorporadas indica que el ajuste más cercano es proporcionado por la distribución estable de Lévy. Aquí, se calcula el ajuste usando una normal (distribución de los promedios de variables aleatorias tomadas independientemente de distribuciones independientes), lognormal (la distribución del producto multiplicativo de muchas variables aleatorias positivas independientes), y una distribución estable.

In[12]:=

edNormal = EstimatedDistribution[movieRuntimes, NormalDistribution[\[Mu], \[Sigma]]]

Out[12]=

In[13]:=

edLogNormal = EstimatedDistribution[movieRuntimes, LogNormalDistribution[\[Mu], \[Sigma]]]

Out[13]=

In[14]:=

edStable = EstimatedDistribution[movieRuntimes, StableDistribution[1, \[Alpha], \[Beta], \[Mu], \[Sigma]]]

Out[14]=

Curiosamente, la distribución estable es visualmente la que mejor se ajusta.

In[15]:=

Show[{hg, ListLinePlot[ Table[{x, #}, {x, Quantity[0, "Minutes"], Quantity[200, "Minutes"], Quantity[1, "Minutes"]}] & /@ {PDF[edNormal, x], PDF[edLogNormal, x], PDF[edStable, x]}, PlotLegends -> {"normal", "lognormal", "stable"}, Filling -> Axis, PlotRange -> All]}]

Out[15]=

Sólo muy pocos objetos hechos por el hombre obedecen a una distribución estable. Una característica de una distribución estable es la ocurrencia de valores atípicos relativamente grandes, usualmente varias veces mayores que la media. Esta característica se cumple en las películas. Aquí, una clase de entidades implícitamente definida es utilizada para seleccionar las 10 películas más largas (por tiempo de proyección) estrenadas después del 1 de enero de 2000.

In[16]:=

longest = EntityClass[ "Movie", {EntityProperty["Movie", "ReleaseDate"] -> Between[{DateObject[{2000}], DateObject[{2015}]}], EntityProperty["Movie", "Runtime"] -> TakeLargest[10]}] // EntityList

Out[16]=

Resúmalo en una retícula.

In[17]:=

With[{props = {EntityProperty["Movie", "Name"], EntityProperty["Movie", "Genres"], EntityProperty["Movie", "Runtime"], EntityProperty["Movie", "ReleaseDate"]}}, TextGrid[Prepend[EntityValue[longest, props], props], Dividers -> All, Alignment -> Left, Background -> {None, {LightBlue}}]] // TraditionalForm

Out[17]//TraditionalForm=