Annovera

#
# An R script to visualize the sales trajectory of TherapeuticsMD's Annovera
#
# (c) 2019 Germain Garand <[email protected]>
#
# This is for information purposes only. Any calculation performed herein could be
# wrong and/or misrepresent reality. Use at your own risk.
#
# License: Creative Commons BY-NC 2.0

Sys.setlocale("LC_TIME", "C")

# common ratio of the geometric progression to use as comparator
geom_ratio <- 1.15

# Optionally, assume the geometric progression will gradually slow down to a lower value
geom_min_ratio <- 1.13
start_decay_after_n_week <- 12
decay_pace <- 0.01

a <- c(
    "2019/10/18","2019/10/25",
    "2019/11/1","2019/11/8","2019/11/15","2019/11/22","2019/11/29",
    "2019/12/6", "2019/12/13", "2019/12/20", "2019/12/27",
    "2020/01/03", "2020/01/10", "2020/01/17", "2020/01/24", "2020/01/31",
    "2020/02/07", "2020/02/14", "2020/02/21", "2020/02/28"
)
a <- as.Date(a, "%Y/%m/%d")
b <- c(
     15,28,
     87,71,135,112,109,
     73, 109, 74, 145,
     71, 81, 121, 133, 192,
     183, 271, 225, 239
)
c <- c(1:length(b))
d <- c(1:(length(b)+2))
g <- c( rep(geom_ratio, start_decay_after_n_week), seq(from=geom_ratio, to=geom_min_ratio, by=-decay_pace ))

if (length(g) < length(a)+1) {
  g <- c( g, rep(geom_min_ratio, (length(b)+1)-length(g)) )
} else if (length(g) > length(b)+1) {
  g <- head(g, length(b)+1)
}

message("Geometric ratios: ", paste(g," "))

z=b[1]
x=c(z)
for( i in g) {
  z=i*z
  x=c(x, z)
}

# the ordinary guess is that symphony only captures 1/3rd of Annovera scripts.
#b <- b*3
#x <- x*3
e <- data.frame(a,b)
names(e) <- c("Week", "Scripts")

f <- data.frame(d,x)
names(f) <- c("Week", "Geometric")

p <- (geom_ratio-1)*100
pm <- (geom_min_ratio-1)*100
if (p == pm) {
  main_legend <- paste("Annovera Weekly Scripts vs.", p , "% Compounded Growth Curve", sep='')
} else {
  main_legend <- paste("Annovera Weekly vs.", p ,"% -> ",pm ,"% Sliding Compounded Growth", sep='')
}
#main_legend <- paste( main_legend, "\nSH Data scaled 200% (current best guess)")

t = length(a)-1
cwgr = ( ((b[t]+b[t+1])/2) / b[1] )^(1/t)-1

msg = paste("Total scripts: ", sum(e$Scripts),
            " 4Q19: ", sum(head(e$Scripts,13)),
            " 1Q20: ",sum(tail(e$Scripts,-13)),
            " Mean: ", floor(mean(e$Scripts)),
            " CWGR: ", round(cwgr*100), "%")

png("annovera.png",width=480,height=480)
plot(Scripts ~ Week, e, type = 'l', col='blue', ylim=c(head(b,1),max(x,b)), main=main_legend, sub= msg,
#paste("CWGR: ", round(cwgr*100), "%"),
 col.sub='red')
par(new=TRUE)
plot(Geometric ~ Week, f, type='l', ylim=c(head(b,1),max(x,b)),axes=FALSE, ann=FALSE,col='violet')
axis(4, round(f$Geometric), col='violet', col.axis='violet')
legend("top", inset=.05, c("Annovera scripts","Geometric reference"), fill=c("blue","violet"), title="Symph. Health data")
dev.off()