Introduction
Expands previous models to release songs at different times.
suppressWarnings(library(tidyverse))
POP <- "pop"
JAZZ <- "jazz"
ROCK <- "rock"
HAPPY <- "happy"
SAD <- "sad"
name_vector <- c(POP,ROCK,JAZZ)
starts <- c(50, 25, 20)
names(starts) <- name_vector
durations <- c(10,13,4)
names(durations) <- name_vector
# maximum number of weeks a song lasts, e.g. the length of the simulation in weeks
MAX_DURATION <- 24
# standard deviation, around a mean value of 1, for the amount of noise
# .25 seems to be a pretty good value
RANDOMNESS_FACTOR <- .25
# creates a song listens shape
generate_shape <- function(start_week,last_week,max_weeks) {
# initialize to all zeros
result <- rep(0,max_weeks)
# add the declining sequence, needs to be one longer, because the decline includes zero
result[start_week:last_week] <- seq(1,0,length.out=(last_week-start_week+1))
result
}
# trend boost vector, starting in the 6th week and lasting four weeks
trend_boost <- rep(1.0,length.out = MAX_DURATION)
trend_boost[c(6,7,8,9,16,17,18,19,20)] <- 3.0
trend_df <- data.frame(week=1:MAX_DURATION,trend=trend_boost)
plot_songs <- function (song_data) {
ggplot() +
geom_col(data=song_data,aes(x=week,y=listens,fill=song_genre)) +
geom_smooth(data=song_data,aes(x=week,y=listens,fill=song_name),
fill=NA,color="dimgray",method="loess") +
geom_col(data=trend_df,aes(x=week,y=trend)) +
coord_cartesian(ylim=c(0,80)) +
facet_wrap( ~ song_name)
}
make_song_data <- function (first_week,name,genre,trend) {
# retrieve parameters from the vector, based on the genre.
start_at <- starts[genre]
duration <- durations[genre]
# randomness is a vector with a random multiplier for each week
randomness <- rnorm(MAX_DURATION,mean=1,sd=RANDOMNESS_FACTOR)
# this is a vector of declining values
declining <- generate_shape(first_week,first_week+duration,MAX_DURATION)
# our vector of listens multiplies a flat initial value by randomness by declining
listens <- start_at * randomness * declining
# add the effect of the trend, if the song is effected by the trend, again multiplying
if (trend) listens <- trend_boost * listens
#make these into integers
listens <- floor (listens)
# we use this built-in R function, cumsum, to accumulate the listens
cum_listens <- cumsum(listens)
#ok, now we can make a dataframe for this song, and add it to our overall dataframe
data.frame(song_name = name,
song_genre = genre,
song_trend = trend,
week = 1:MAX_DURATION,
listens = listens,
cumulative_listens = cum_listens)
}
plot_songs <- function (song_data) {
ggplot() +
geom_col(data=song_data,aes(x=week,y=listens,fill=song_genre)) +
#geom_smooth(data=song_data,aes(x=week,y=listens,fill=song_name),
# fill=NA,color="dimgray",method="loess") +
geom_col(data=trend_df,aes(x=week,y=trend)) +
coord_cartesian(ylim=c(0,80)) +
facet_wrap( ~ song_name)
}
some sample data
Below I generate 9 songs in a 3x3 grid: * Each is released at a different week. * Although the exactly weekly data has randomness added, the height and width are specified by genre. * I made two of rock songs respond to a trend (trend is shown by black bars on the bottom)
song_listens_df= suppressWarnings(
bind_rows(
make_song_data(1,"pop1",POP,FALSE),
make_song_data(1,"rock on",ROCK,FALSE),
make_song_data(4,"jazzy jones",JAZZ,FALSE),
make_song_data(8,"jazzy fool",JAZZ,FALSE),
make_song_data(11,"jaz no more",JAZZ,FALSE), make_song_data(4,"rock sad",ROCK,TRUE),
make_song_data(9,"pop2",POP,FALSE),
make_song_data(9,"pop3",POP,FALSE),
make_song_data(11,"rock sadder",ROCK,TRUE),
))
plot_songs(song_listens_df)

In the above example, jazz songs clearly have low listens. The three pop songs do pretty well. Can you tell what mood is boosting rock songs? Note that the low black indicators reveal where the mood is trending…
Cumulative Listens
Plotting cumulative listens is kind of interesting. To my eyes, you can clearly see that songs in two genres always end up with roughly the same number of listens, even if they start in different weeks. But songs in a different genre get very different listens, depending on whether they are on-trend or not.
ggplot(data=song_listens_df) +
geom_line(aes(x=week,y=cumulative_listens,color=song_genre),size=1) +
coord_cartesian(ylim=c(0,350)) +
facet_wrap( ~ song_name)

LS0tCnRpdGxlOiAiTXVzaWMgR2FtZSAtLSBSZWxlYXNpbmcgYXQgZGlmZmVyZW50IHRpbWVzIgpvdXRwdXQ6IGh0bWxfbm90ZWJvb2sKLS0tCgojIEludHJvZHVjdGlvbgoKRXhwYW5kcyBwcmV2aW91cyBtb2RlbHMgdG8gcmVsZWFzZSBzb25ncyBhdCBkaWZmZXJlbnQgdGltZXMuCgoKYGBge3J9CnN1cHByZXNzV2FybmluZ3MobGlicmFyeSh0aWR5dmVyc2UpKQoKClBPUCA8LSAicG9wIgpKQVpaIDwtICJqYXp6IgpST0NLIDwtICJyb2NrIgpIQVBQWSA8LSAiaGFwcHkiClNBRCAgPC0gInNhZCIKCm5hbWVfdmVjdG9yIDwtIGMoUE9QLFJPQ0ssSkFaWikKc3RhcnRzIDwtIGMoNTAsIDI1LCAyMCkKbmFtZXMoc3RhcnRzKSA8LSBuYW1lX3ZlY3RvcgpkdXJhdGlvbnMgPC0gYygxMCwxMyw0KQpuYW1lcyhkdXJhdGlvbnMpIDwtIG5hbWVfdmVjdG9yCgojIG1heGltdW0gbnVtYmVyIG9mIHdlZWtzIGEgc29uZyBsYXN0cywgZS5nLiB0aGUgbGVuZ3RoIG9mIHRoZSBzaW11bGF0aW9uIGluIHdlZWtzCk1BWF9EVVJBVElPTiA8LSAyNAoKIyBzdGFuZGFyZCBkZXZpYXRpb24sIGFyb3VuZCBhIG1lYW4gdmFsdWUgb2YgMSwgZm9yIHRoZSBhbW91bnQgb2Ygbm9pc2UKIyAuMjUgc2VlbXMgdG8gYmUgYSBwcmV0dHkgZ29vZCB2YWx1ZQpSQU5ET01ORVNTX0ZBQ1RPUiA8LSAuMjUKCiMgY3JlYXRlcyBhIHNvbmcgbGlzdGVucyBzaGFwZQpnZW5lcmF0ZV9zaGFwZSA8LSBmdW5jdGlvbihzdGFydF93ZWVrLGxhc3Rfd2VlayxtYXhfd2Vla3MpIHsKICAjIGluaXRpYWxpemUgdG8gYWxsIHplcm9zCiAgcmVzdWx0IDwtIHJlcCgwLG1heF93ZWVrcykgCiAgIyBhZGQgdGhlIGRlY2xpbmluZyBzZXF1ZW5jZSwgbmVlZHMgdG8gYmUgb25lIGxvbmdlciwgYmVjYXVzZSB0aGUgZGVjbGluZSBpbmNsdWRlcyB6ZXJvCiAgcmVzdWx0W3N0YXJ0X3dlZWs6bGFzdF93ZWVrXSA8LSBzZXEoMSwwLGxlbmd0aC5vdXQ9KGxhc3Rfd2Vlay1zdGFydF93ZWVrKzEpKQogIHJlc3VsdAp9CgojIHRyZW5kIGJvb3N0IHZlY3Rvciwgc3RhcnRpbmcgaW4gdGhlIDZ0aCB3ZWVrIGFuZCBsYXN0aW5nIGZvdXIgd2Vla3MKdHJlbmRfYm9vc3QgPC0gcmVwKDEuMCxsZW5ndGgub3V0ID0gTUFYX0RVUkFUSU9OKQp0cmVuZF9ib29zdFtjKDYsNyw4LDksMTYsMTcsMTgsMTksMjApXSA8LSAzLjAKdHJlbmRfZGYgPC0gZGF0YS5mcmFtZSh3ZWVrPTE6TUFYX0RVUkFUSU9OLHRyZW5kPXRyZW5kX2Jvb3N0KQoKbWFrZV9zb25nX2RhdGEgPC0gZnVuY3Rpb24gKGZpcnN0X3dlZWssbmFtZSxnZW5yZSx0cmVuZCkgewogIAogICMgcmV0cmlldmUgcGFyYW1ldGVycyBmcm9tIHRoZSB2ZWN0b3IsIGJhc2VkIG9uIHRoZSBnZW5yZS4KICBzdGFydF9hdCA8LSBzdGFydHNbZ2VucmVdCiAgZHVyYXRpb24gPC0gZHVyYXRpb25zW2dlbnJlXQoKICMgcmFuZG9tbmVzcyBpcyBhIHZlY3RvciB3aXRoIGEgcmFuZG9tIG11bHRpcGxpZXIgZm9yIGVhY2ggd2VlawogcmFuZG9tbmVzcyA8LSBybm9ybShNQVhfRFVSQVRJT04sbWVhbj0xLHNkPVJBTkRPTU5FU1NfRkFDVE9SKQogCiAjIHRoaXMgaXMgYSB2ZWN0b3Igb2YgZGVjbGluaW5nIHZhbHVlcwogZGVjbGluaW5nIDwtIGdlbmVyYXRlX3NoYXBlKGZpcnN0X3dlZWssZmlyc3Rfd2VlaytkdXJhdGlvbixNQVhfRFVSQVRJT04pCiAKICMgb3VyIHZlY3RvciBvZiBsaXN0ZW5zIG11bHRpcGxpZXMgYSBmbGF0IGluaXRpYWwgdmFsdWUgYnkgcmFuZG9tbmVzcyBieSBkZWNsaW5pbmcKIGxpc3RlbnMgPC0gc3RhcnRfYXQgKiByYW5kb21uZXNzICogZGVjbGluaW5nCiAKICMgYWRkIHRoZSBlZmZlY3Qgb2YgdGhlIHRyZW5kLCBpZiB0aGUgc29uZyBpcyBlZmZlY3RlZCBieSB0aGUgdHJlbmQsIGFnYWluIG11bHRpcGx5aW5nCiBpZiAodHJlbmQpIGxpc3RlbnMgPC0gdHJlbmRfYm9vc3QgKiBsaXN0ZW5zCiAKICNtYWtlIHRoZXNlIGludG8gaW50ZWdlcnMKIGxpc3RlbnMgPC0gZmxvb3IgKGxpc3RlbnMpCiAgICAgICAgICAgICAgICAgICAgICAKICMgd2UgdXNlIHRoaXMgYnVpbHQtaW4gUiBmdW5jdGlvbiwgY3Vtc3VtLCB0byBhY2N1bXVsYXRlIHRoZSBsaXN0ZW5zCiBjdW1fbGlzdGVucyA8LSBjdW1zdW0obGlzdGVucykKCiAjb2ssIG5vdyB3ZSBjYW4gbWFrZSBhIGRhdGFmcmFtZSBmb3IgdGhpcyBzb25nLCBhbmQgYWRkIGl0IHRvIG91ciBvdmVyYWxsIGRhdGFmcmFtZQogZGF0YS5mcmFtZShzb25nX25hbWUgPSBuYW1lLAogICAgICAgICAgICBzb25nX2dlbnJlID0gZ2VucmUsCiAgICAgICAgICAgIHNvbmdfdHJlbmQgPSB0cmVuZCwKICAgICAgICAgICAgd2VlayA9IDE6TUFYX0RVUkFUSU9OLAogICAgICAgICAgICBsaXN0ZW5zID0gbGlzdGVucywKICAgICAgICAgICAgY3VtdWxhdGl2ZV9saXN0ZW5zID0gY3VtX2xpc3RlbnMpCn0KCnBsb3Rfc29uZ3MgPC0gZnVuY3Rpb24gKHNvbmdfZGF0YSkgewogIGdncGxvdCgpICsKICAgICAgICBnZW9tX2NvbChkYXRhPXNvbmdfZGF0YSxhZXMoeD13ZWVrLHk9bGlzdGVucyxmaWxsPXNvbmdfZ2VucmUpKSArIAogICAgICAgICNnZW9tX3Ntb290aChkYXRhPXNvbmdfZGF0YSxhZXMoeD13ZWVrLHk9bGlzdGVucyxmaWxsPXNvbmdfbmFtZSksCiAgICAgICAgIyAgICAgICAgICAgIGZpbGw9TkEsY29sb3I9ImRpbWdyYXkiLG1ldGhvZD0ibG9lc3MiKSArCiAgICAgICAgZ2VvbV9jb2woZGF0YT10cmVuZF9kZixhZXMoeD13ZWVrLHk9dHJlbmQpKSArCiAgICAgICAgY29vcmRfY2FydGVzaWFuKHlsaW09YygwLDgwKSkgKwogICAgICAgIGZhY2V0X3dyYXAoIH4gc29uZ19uYW1lKQp9CgoKYGBgCgojIHNvbWUgc2FtcGxlIGRhdGEKCkJlbG93IEkgZ2VuZXJhdGUgOSBzb25ncyBpbiBhIDN4MyBncmlkOgoqIEVhY2ggaXMgcmVsZWFzZWQgYXQgYSBkaWZmZXJlbnQgd2Vlay4KKiBBbHRob3VnaCB0aGUgZXhhY3RseSB3ZWVrbHkgZGF0YSBoYXMgcmFuZG9tbmVzcyBhZGRlZCwgdGhlIGhlaWdodCBhbmQgd2lkdGggYXJlIHNwZWNpZmllZCBieSBnZW5yZS4KKiBJIG1hZGUgdHdvIG9mIHJvY2sgc29uZ3MgcmVzcG9uZCB0byBhIHRyZW5kICh0cmVuZCBpcyBzaG93biBieSBibGFjayBiYXJzIG9uIHRoZSBib3R0b20pCgpgYGB7cn0Kc29uZ19saXN0ZW5zX2RmPSBzdXBwcmVzc1dhcm5pbmdzKAogIGJpbmRfcm93cygKICAgICAgbWFrZV9zb25nX2RhdGEoMSwicG9wMSIsUE9QLEZBTFNFKSwKICAgICAgbWFrZV9zb25nX2RhdGEoMSwicm9jayBvbiIsUk9DSyxGQUxTRSksCiAgICAgIG1ha2Vfc29uZ19kYXRhKDQsImphenp5IGpvbmVzIixKQVpaLEZBTFNFKSwKICAgICAgbWFrZV9zb25nX2RhdGEoOCwiamF6enkgZm9vbCIsSkFaWixGQUxTRSksCiAgICAgIG1ha2Vfc29uZ19kYXRhKDExLCJqYXogbm8gbW9yZSIsSkFaWixGQUxTRSksICAgICAgbWFrZV9zb25nX2RhdGEoNCwicm9jayBzYWQiLFJPQ0ssVFJVRSksCiAgICAgIG1ha2Vfc29uZ19kYXRhKDksInBvcDIiLFBPUCxGQUxTRSksCiAgICAgIG1ha2Vfc29uZ19kYXRhKDksInBvcDMiLFBPUCxGQUxTRSksICAgICAgCiAgICAgIG1ha2Vfc29uZ19kYXRhKDExLCJyb2NrIHNhZGRlciIsUk9DSyxUUlVFKSwKICAgICAgCiAgKSkKCgpwbG90X3NvbmdzKHNvbmdfbGlzdGVuc19kZikKYGBgCgpJbiB0aGUgYWJvdmUgZXhhbXBsZSwgamF6eiBzb25ncyBjbGVhcmx5IGhhdmUgbG93IGxpc3RlbnMuIFRoZSB0aHJlZSBwb3Agc29uZ3MgZG8gcHJldHR5IHdlbGwuIENhbiB5b3UgdGVsbCB3aGF0IG1vb2QgaXMgYm9vc3Rpbmcgcm9jayBzb25ncz8gTm90ZSB0aGF0IHRoZSBsb3cgYmxhY2sgaW5kaWNhdG9ycyByZXZlYWwgd2hlcmUgdGhlIG1vb2QgaXMgdHJlbmRpbmcuLi4KCgojIEN1bXVsYXRpdmUgTGlzdGVucwoKUGxvdHRpbmcgY3VtdWxhdGl2ZSBsaXN0ZW5zIGlzIGtpbmQgb2YgaW50ZXJlc3RpbmcuIFRvIG15IGV5ZXMsIHlvdSBjYW4gY2xlYXJseSBzZWUgdGhhdCBzb25ncyBpbiB0d28gZ2VucmVzIGFsd2F5cyBlbmQgdXAgd2l0aCByb3VnaGx5IHRoZSBzYW1lIG51bWJlciBvZiBsaXN0ZW5zLCBldmVuIGlmIHRoZXkgc3RhcnQgaW4gZGlmZmVyZW50IHdlZWtzLiBCdXQgc29uZ3MgaW4gYSBkaWZmZXJlbnQgZ2VucmUgZ2V0IHZlcnkgZGlmZmVyZW50IGxpc3RlbnMsIGRlcGVuZGluZyBvbiB3aGV0aGVyIHRoZXkgYXJlIG9uLXRyZW5kIG9yIG5vdC4KCmBgYHtyfQogZ2dwbG90KGRhdGE9c29uZ19saXN0ZW5zX2RmKSArCiAgICAgICAgZ2VvbV9saW5lKGFlcyh4PXdlZWsseT1jdW11bGF0aXZlX2xpc3RlbnMsY29sb3I9c29uZ19nZW5yZSksc2l6ZT0xKSArIAogICAgICAgIGNvb3JkX2NhcnRlc2lhbih5bGltPWMoMCwzNTApKSArCiAgICAgICAgZmFjZXRfd3JhcCggfiBzb25nX25hbWUpCmBgYAoK