Maazin Ansari

Accounts - Gnucash with PostgreSQL

2023-11-02T00:00:00-05:00

The first step to managing your personal finances is to have a practical chart of accounts. Think of all the financial institutions you interact with: banks, credit cards, your employer, utility companies, insurance providers. Each of them represents an account with a balance that increases or decreases over time.

Create an account

From the accounts tab in Gnucash, right click and select New Account.... Your first one will be your main bank account, an asset account. Give it a name and confirm the currency. In the Opening Balance tab, enter the current balance and today's date.

In the database

You can see your new account in the database by querying the accounts table.

SELECT * FROM accounts

Notice your new account has a parent_guid that matches the guid of another account. This is how account hierarchies are maintained.

Types of accounts

To summarize the Gnucash Concepts Guide, everything in the accounting world can fit into five groups, or account types. Here are some ideas for accounts you can create.

I will regularly update this page to provide links to more detailed posts for the examples below.

Assets
Liabiliies
- mortgages and loans
- credit cards
- utility and medical bills
Income
Expenses
- Living costs: rent, groceries, gasoline, utilities, insurance premiums
- Everyday purchases: travel, entertainment, shopping
- Taxes and fees
- Interest paid
- Discounts
Equity
- Opening balances
- Everything else, technical accounts, miscellaneous

If all these accounts seem like too much for you, just create the accounts you need now. Do not feel compelled to preemptively make accounts without any transactions to put in them. As you become more comfortable with the basic principles of Gnucash, you will be able to create and rearrange accounts to fit your needs.

Account codes

You may find it helpful to assign codes to your accounts. If you plan to use SQL for analysis, a practical coding can make it easier to group accounts together in your queries. For example, when I want to query all my credit card accounts I use the regular expression ^201/d00 since I set up all my credit card accounts to start with 201.

Account codes need not be entirely numeric. You can use abbreviations or shorthand codes.

Database Tables - Gnucash with PostgreSQL

2023-08-20T00:00:00-05:00

The following materials were created by me based on my own experience and observations of Gnucash. I have removed a lot of detail to make the diagrams easier to read. A more complete entity relationship diagram exists on the official Gnucash Wiki.

Basic transactions

Basic transactions work like this:

A transaction row is created in transactions with a new key.
Two or more transaction splits are created in splits with the same transaction key.
These splits are each assigned an account from the account table.

The splits table is at the center of this snowflake schema. It stores the details of every transaction split, such as the transaction it belongs to, the account, and the amount.
The transactions table is like the header table for splits. It contains high-level information such as the date, currency, and description.
The accounts table is the main dimension table for splits. It contains the account-level details, such as name, account code, and primary currency.
The commodities table contains currencies and traded commodities such as stocks. In this diagram, it is only used for currencies.
The slots table is used as a miscellaneous dimension table. It contains additional details for rows in other tables. I have included the slots table three times in this diagram to show the different kinds of information it contains. For example, it can be linked to transactions to get the transaction-level notes, or it can be linked to accounts to get the account-level notes or the account color.

In Gnucash, globally unique identifiers (guid) are used as keys. Technically, their data type is varchar(32). This means they are strings of length 32. They are randomly generated and contain only the hex digits 0-9 and a-f.

Budgets

Gnucash has a budgeting functionality that allows you to set budget amounts for each account across any time period. This is mainly tracked by four tables.

budgets is the header table for the budgets.
recurrences contains the calendar settings for the budget.
budget_amounts contains the budget amount for each account during a particular period.
accounts is the same account table as before with the account-level details.

Scheduled transactions

Gnucash also allows you to create recurring transactions with the scheduled transactions editor. In the database, this process is a little complex. The tables schedxactions and recurrences contain the scheduling and calendar settings. You might notice the core transactions-splits-accounts relationship from the first diagram. There are some important distinctions for scheduled transactions:

The accounts, splits, and transactions here are templates that don't appear in the GUI
The accounts are children of the Template Root account rather than the Root Account. Their names are randomly generated varchar(32) hex strings.
The splits for each template transaction belong to one template account. Normally transactions contains splits for two different accounts.

In addition to the scheduling tables and the core transaction relationship, the slots table plays a major part in this functionality. It joins to splits and to itself to get the key details about the scheduled transaction: the real accounts and the numeric amounts.

Currency rates

Coming soon...

Business tables

Coming much later...

Setup - Gnucash with PostgreSQL

2023-08-07T00:00:00-05:00

This post is the first in a series of tutorials on personal finance with SQL. The goal is to teach technical data analysis techniques in a way that benefits you immediately. The datasets you interact with will be your own financial data, and the analyses you perform can be used for yourself.

Download and install

To get started, you will need to download the following software

Gnucash
PostgreSQL
pgAdmin (or other SQL query tool)
Postgres.app (recommended for macOS)

The installation instructions vary depending on your operating system. The official instructions tend to be easy to follow. There are also video tutorials available on YouTube.

Set up PostgreSQL

Follow the installation instructions for PostgreSQL and use the default settings.

Depending on your operating system, you may need to download and install pgAdmin separately. If you are using macOS, I recommend you also install the Postgres.app. This will make it easier to connect to your Gnucash database in the future.

Open pgAdmin

You will need to set a password the first time you open pgAdmin. This is not the same as the postgres user password you set when you installed PostgreSQL. You will only use this password when you want to use pgAdmin.

In the Browser panel, you will see one server Local which has one database postgres. There is also a postgres role ("user") in the Local server. To avoid confusion in the future, we will create a new role u_gnucash and a new database db_gnucash

Create a new role

Select the postgres database and open a new query window. Create a new u_gnucash role with the statement below

CREATE ROLE u_gnucash WITH
  LOGIN
  SUPERUSER
  INHERIT
  CREATEDB
  CREATEROLE
  NOREPLICATION
  PASSWORD 'your password';

The PASSWORD parameter is optional. If you omit it in the statement, you can always set a password at a later time.

Create a new database

CREATE DATABASE db_gnucash WITH 
    OWNER = u_gnucash
    ENCODING = 'UTF8'
    LC_COLLATE = 'en_US.UTF-8'
    LC_CTYPE = 'en_US.UTF-8'
    TABLESPACE = pg_default
    CONNECTION LIMIT = -1;

This database will not have any tables or data yet. We will need to set up Gnucash next.

Set up Gnucash

Gnucash is an open source bookkeeping application that has a neat graphical user interface, and a simple database underneath. We will be taking advantage of both in later guides. Depending on the problem you are trying to solve, you might find the GUI is the better tool, and other times you might find it easier to look directly in the database.

With Gnucash open click File > Save As.... Change the data format from XML to Postgres. Enter the following connection details:

Host: localhost
Database: db_gnucash
Username: u_gnucash
Password: The password you created above

If you are using macOS, make sure the server is still running in Postrgres.app

Click Save As. Gnucash will automatically create the necessary tables to get started.

Check

To confirm the setup was successful, go back to pgAdmin and refresh db_gnucash. Expand the tree to Schemas > public > Tables and you will see 24 tables.

In the next post we will explore what these tables mean and how they are related to each other.

Duelling Idiots - Bulb

2019-03-05T00:00:00-06:00

There are several parts to this problem, culminating with a Markov Chain. So, I'll take it slow and only do the first part here.

The Problem

Imagine there are $N$ switches in series to form a row of switches. Then, put $N$ such rows in parallel to form a sheet of $N^2$ switches. Finally, put $N$ of these sheets in series, with a lightbulb, to form complicated circuit with $N^3$ total switches.

The above schematic shows what this circuit looks like when $N=3$.

Each switch is, independently, open or closed, with probability $p$. What is the probability $P_1(N,p)$ that the bulb will glow?

If the sheets are connected in parallel, what is the probability $P_2(N,p)$ that the bulb will glow?

Circuit Basics

The bulb will glow if the circuit is closed. The circuit is closed if there is at least one unbroken path from the negative terminal, through the switches, through the bulb, and to the positive terminal of the battery.

In a row of switches in series, all switches must be closed. When the rows are connected in parallel, at least one row in the sheet must be closed, but it is not necessary for all rows to be closed. Similarly, when the sheets are connected in parallel, at least one must be closed. When the sheets are connected in series, all sheets must be closed.

Analytical Solution

Now that we know how circuits work, we can start finding the exact solution. Let's start with the individual switches connected in series.

An individual switch has a probability $p$ of being closed. Now we connect $N$ independent and identical switches in series. The probability the whole series is closed is

$$ p_1 \times ... \times p_N = \color{#377eb8}{p^N} $$

And the probability the series is open is just the opposite

$$1-\color{#377eb8}{p^N}$$

Now we connect $N$ of these series in parallel to make a sheet. If zero series are closed, then the sheet is open. If more than zero series are closed (i.e. at least one is closed), then the sheet is closed. The probability of zero series closed (all series open) is

$$(1-\color{#377eb8}{p^N})_1 \times ... \times (1-\color{#377eb8}{p^N})_N = \color{#d95f02}{(1-\color{#377eb8}{p^N})^N}$$

This is also the probability of the sheet being open. And the probability the sheet is closed is the opposite

$$ 1 - \color{#d95f02}{(1-\color{#377eb8}{p^N})^N} $$

Almost there.

Finally, we connect $N$ of these sheets to make an incredibly complicated circuit. If we connect the sheets in series, all $N$ sheets must be closed. Like we did in the first step, we can multiply together the probabilities of each sheet being closed

$$ \begin{align*} P_1(N,p) &= (1 - \color{#d95f02}{(1-\color{#377eb8}{p^N})^N})_1 \times ... \times (1 - \color{#d95f02}{(1-\color{#377eb8}{p^N})^N})_N \\ &= \bf{[1 - (1-p^N)^N]^N} \end{align*} $$

If we connect the sheets in parallel, at least one sheet must be closed. This one is trickier, because we need to think with opposites again. The probability zero sheets are closed (all sheets open) is

$$ \color{#d95f02}{(1-\color{#377eb8}{p^N})^N}_1 \times ... \times \color{#d95f02}{(1-\color{#377eb8}{p^N})^N}_N = (\color{#d95f02}{(1-\color{#377eb8}{p^N})^N})^N $$

And the probability more than zero sheets (at least one) are closed is the opposite

$$ P_2(N,p) = \bf{1 - (1-p^N)^{N^2}} $$

Series vs. Parallel

The two probabilities look similar, but they are very different. The plot below shows how $P_1$ and $P_2$ compare for different values of $N$ and $p$.

Connecting the sheets in parallel gives the bulb a much higher chance of glowing than connecting them in series, for any value of $N$ and $p$.

I added the red and blue lines to show two more scenarios: putting the $N^3$ switches in parallel (red) and putting the $N^3$ switches in series (blue). The difference between series and parallel is more pronounced. It is extremely unlikely for the bulb to glow if the switches are in series, unless $p$ is almost 1. Conversely, the bulb will almost always glow if the switches are in parallel, unless $p$ is almost 0.

For a fixed $p$, $P_1$ decreases sharply as $N$ increases. This makes sense because it becomes less likely that all the sheets are closed as we add more sheets to the series.

What I found surprising is that $P_2$ increases first, then decreases after a certain $N$. My interpretation is that when there are more sheets, it is more likely that at least one will be closed. However, each sheet also has $N$ rows in series, and when a row gets longer, it is less likely all switches in the row will be closed. Eventually, the effect of longer series outweighs the effect of more sheets in parallel.

Note that $P_1$ and $P_2$ are equal to $p$ when $N=1$, because when $N=1$, there is just one switch in the circuit.

Visualizing Log-transformed Data

2018-07-18T00:00:00-05:00

The first thing I do when I have a clean data set is plot the variables (columns) as histograms. Along with the standard summary statistics, histograms give a quick overview of the distribution of the data. Sometimes the data spans several orders of magnitude, and I can't see any pattern from the histogram or the summary statistics. In these cases, the histogram of the logarithm of the data may be useful.

One downside of log-transformations is the loss of human interpretability. To maintain some interpretability, I use untransformed labels instead of the transformed labels that would appear by default.

I am using my personal Google location history data. This is my first post using this data set. There's a lot more that can be done with it, so I plan on writing more in-depth analyses in the future. A quick Google search for "google location history data" will yield countless blog posts showing you how to obtain, clean, and analyze your own location history from Google. Here's one I used.

Untransformed data

With this data set, I first wanted to understand how frequently I was being tracked. Each observation (row) has a timestamp. The difference in time between two consecutive observations will give me the time between each record. The new variable t_diff_s is the time in seconds since the previous observation, i.e. the current time minus the lag. I manually assign 0 to the first observation, since there is no previous row to subtract.

I could have also calculated the time until the next observation, i.e. the lead minus the current time, and assigned 0 to the last observation. This is a decision that comes down to how you want to interpret the data.

PTS_df$t_diff_s = PTS_df$time - lag(PTS_df$time)
PTS_df$t_diff_s[1] = 0
PTS_df$t_diff_s = as.double(PTS_df$t_diff_s)

From the summary, we can see right away t_diff_s has a very large range. Time between records is anywhere between a few milliseconds and several hours.

data.frame(min = PTS_df$t_diff_s %>% sort() %>% head(3),
           max = PTS_df$t_diff_s %>% sort() %>% tail(3))

##           min      max
## 1 0.000000000 52432.46
## 2 0.003000021 54089.61
## 3 0.005000114 68356.00

##    Min. 1st Qu.  Median    Mean 3rd Qu.    Max. 
##     0.0   132.4   199.1  1400.7   585.3 68356.0

The wide range and strong right skew is seen in the histogram, too. We can also see that most observations were sampled less than 200 seconds apart.

hist(PTS_df$t_diff_s,
     breaks = 50,
     main = "Histogram of\ntime between observations",
     xlab = "time in seconds")

Transformed data

The above histogram isn't very useful because the visible time scale is on the order of a few hours. Most of the values are on the order of just a few minutes, so it would be more helpful to see the data at this granularity, while also preserving the full range. A reasonable solution would be to plot the histogram of log(t_diff_s):

hist(log(PTS_df$t_diff_s),
     breaks = 50,
     main = "Histogram of\nlog(time between observations)",
     xlab = "log(time)")

Better labels

By scaling the x-axis logarithmically, smaller values are more dispersed and larger values are bunched together. The distribution looks much less skewed now, but the labels on the x-axis don't make sense. To make the axis more clear, I place labels at predetermined points with the axis() function. The location of the labels need to be log-transformed. The labels' text are untransformed.

time_hist = function(x, col = 0) {
    h = hist(log(x),
             axes = FALSE,
             main = "Histogram of\nlog(time between observations)",
             xlab = "time between points",
             col = col,
             breaks = 100) 
    axis(side = 1,

         # labels at log-transformed points 
         at =  log(c(0.01, 0.1, 1, 10, 60, 120, 600, 3600, 21600)), 

         # text of labels is untransformed points
         labels = paste0(c(0.01, 0.1, 1, 10, 60, 120, 600, 3600, 21600), "s"),

         cex.axis = 0.75,
         padj = -2,
         hadj = 1,
         las = 1)
    axis(2)
    return(h)
}

h = time_hist(PTS_df$t_diff_s)

Now we can better interpret the distribution of t_diff_s. Most values fall between two and ten minutes (120 — 600 seconds). The most common sampling interval lengths are between 134 and 164 seconds. A few observations were taken less than one second apart. Some observations were recorded over 6 hours (21600 seconds) after the previous one.

When we think about time, especially the time that t_diff_s represents, the log-transformed histogram fits our intuition the best. There is an apparent pattern that also coincides with how we might subconsciously think about the data.

The range of the x-axis of the untransformed histogram leads us to mentally group the values into hours-long clusters. A millisecond (0.1s), 5 minutes (300s), and one hour (3600s) are all grouped together in the lowest group, while five hours (18000s) and fifteen hours (54000s) are visually separate.

While this isn't necessarily wrong, it is an unusual way to think about time. The log-transformed histogram data better shows us visual groupings that we are familiar with: milliseconds, seconds, minutes, and hours.

hcols = rep("#FFFFFF", length(h$mids))
hcols[h$mids < 0] = "#edf8fb"
hcols[h$mids >= 0] = "#bdc9e1"
hcols[h$mids >= log(60)] = "#67a9cf"
hcols[h$mids >= log(60*60)] = "#02818a"
h = time_hist(PTS_df$t_diff_s, col = hcols)
legend("left",
       legend = c("milliseconds", "seconds", "minutes", "hours"),
       fill = c("#edf8fb", "#bdc9e1", "#67a9cf", "#02818a"),
       bty = "n")

For future analyses, this information will help me determine which observations are reliable enough to keep, and which ones I can remove due to redundancy.

The code I used for this is available on my GitHub. I also included a simulated data set, timestamps.csv.

d = density(log(PTS_df$t_diff_s))

# means are directly sampled
logmeans = sample(x = PTS_df$t_diff_s, size = 1000, replace = TRUE) %>% log() 
# standard deviation is the kernel bandwidth
logx = rnorm(n = 1000, mean = logmeans, sd = d$bw)

x = exp(logx)
timestamps = ymd_hms("2018-01-01 00:00:00.00") + seconds(x)
write.csv(sort(timestamps), "timestamps.csv")

Duelling Idiots

2018-03-05T00:00:00-06:00

The previous post was just a warmup for the rest of the book. This is the first real puzzle. The code for my solutions and the book's original solution are available on my GitHub.

The Problem

Two individuals, A and B, will participate in a duel, which has the following setup:

A six-chamber gun is loaded with one bullet. The cylinder is spun so the bullet is essentially randomized.
A aims at B and pulls the trigger. The gun has a 1/6 chance of firing the bullet.
If the gun does not fire, B takes the gun, spins the cylinder, then pulls the trigger at A. Again, the gun has a 1/6 chance of firing.
The duelists take turns spinning the cylinder and pulling the trigger until the bullet is fired.

The problem asks:

What is the probability A wins the duel?
What is the expected length of the duel? That is, how many trigger pulls / turns will the duel last?

Analytical Solution

On each of A's turns, There is a 1/6 chance A wins and a 5/6 chance the duel continues. A can only win on an odd-numbered turn (1, 3, 5, ...), and B can only win on an even-numbered turn (2, 4, 6, ...). A cannot win if B wins first. The probability A wins is the total probability of winning on any odd-numbered turn. This can be expressed as the infinite sum

\begin{align*}

P(A) = & \frac{1}{6} + && \text{A wins on turn 1}\ & \frac{5}{6}\frac{5}{6}\frac{1}{6} + && \text{A misses, B misses, A wins on turn 3}\ & \frac{5}{6}\frac{5}{6}\frac{5}{6}\frac{5}{6}\frac{1}{6} + && \text{A misses, B misses, A misses, B misses, A wins on turn 5}\\ & ... \end{align*}

$$ P(A) = \sum_{i=0}^{\infty} \Big(\frac{5}{6}\Big)^{2i} \Big(\frac{1}{6}\Big) $$

This is a geometric series, so it must converge. Factoring out $\frac{1}{6}$ gives

$$ \begin{align*} P(A) &= \frac{1}{6}\sum_{i=0}^{\infty} \Big(\frac{5}{6}\Big)^{2i} \\ &= \frac{1}{6}\sum_{i=0}^{\infty} \Big(\Big(\frac{5}{6}\Big)^2\Big)^{i} \\ &= \frac{1}{6}\sum_{i=0}^{\infty} \Big(\frac{25}{36}\Big)^{i} \\\\ &= \frac{1}{6}\frac{1}{1-\frac{25}{36}} = \frac{1}{6}\frac{36}{11} \\ P(A) &= \frac{6}{11} \approx 0.54545 \end{align*} $$

So, A has a slight advantage over B in this duel.

The answer to the second question is a lot easier. This duel is a sequence of independent Bernoulli trials ($p=\frac{1}{6}$). So, the number of trials, or turns, until the bullet is fired (a "success") follows a geometric distribution. The expected value of a geometric distribution is $\frac{1}{p}=6$.

I used the following code to simulate a duel.

set.seed(20180207)

# one duel ----
did_fire = function(prob = 1/6) {
    shot = runif(1)
    return(shot <= prob)
}

duel = function(shooters = c("A", "B")) {
    turn = 0
    nshooters = length(shooters)

    # repeat until a shot is fired
    while (TRUE) {
        # first shooter is A (2 - 1 mod 2 = 1)
        # second shooter is B (2 - 2 mod 2 = 2)
        turn = turn + 1 # pass gun to next shooter
        shooter = shooters[nshooters - turn %% nshooters]

        # pull trigger
        if ( did_fire() ) {
            return(list(shooter, turn))
        }
    }
}

# result is 2 x N matrix. Row 1 is winner. Row 2 is number of turns.
N = 10000
simulations = replicate(N, duel(), simplify = TRUE)

# results ----
# How many times A won
a_1 = mean(simulations[1,] == "A")

# Average number of turns 
average_1 = mean(unlist(simulations[2,]))

The plots below show the frequencies of a duelist winning on a particular turn. The one on the left is from my simulation. The one on the right is based on the book's simulation.

I get the same results as the book, albeit a bit slower.

	prob	average	time
nahin	0.5410000	5.9364	0.3570000
me	0.5514000	5.9644	0.4325931
theoretical	0.5454545	6.0000	NA

New Rules

To give B a more fair chance the rules are modified. On the first turn A pulls the trigger once. The cylinder is spun and B pulls the trigger twice. A pulls three times, B pulls four, and so on until there is a winner. By these rules, the duel will last at most 6 turns.

With these new rules, what is the probability A wins the duel?

It's harder to solve this problem analytically. This is where simulations become useful. My simulation below simulates a duel 10,000 times and records the winners.

duel_2 = function(shooters = c("A", "B"), prob = 1/6) {
    p = prob
    turn = 0
    pulls = 0
    nshooters = length(shooters)

    # repeat until a shot is fired
    while (TRUE) {
        # first shooter is A (2 - 1 mod 2 = 1)
        # second shooter is B (2 - 2 mod 2 = 2)
        turn = turn + 1 # pass gun to next shooter
        pulls = turn * (turn + 1)/2 # shooter gets same number of pulls  + 1
        shooter = shooters[nshooters - turn %% nshooters]

        # pull trigger
        if ( did_fire(prob = p) ) {
            return(list(shooter, turn, pulls))
        }
        else {
            p = p + prob
        }
    }
}

simulations_2 = replicate(N, duel_2(), simplify = TRUE)
# results ----
# How many times A won
a_2 = mean(simulations_2[1,] == "A")

The book's solution is a little more abstract, and it runs much faster. Instead of simulating duels and counting wins, it simulates an infinite sum as the total probability A wins, and checks for convergence. Still, our answers are similar: A has a 52% chance of winning the duel.

	prob	time
nahin	0.5239191	0.0140000
me	0.5267000	0.1816361

Duelling Idiots - Introduction

2018-02-12T00:00:00-06:00

Introduction

A few years ago I found a book at a bookstore. The book, Duelling Idiots and Other Probability Puzzlers by Paul J. Nahin, is a collection of probability puzzles. I recently started going through these puzzles and decided to document my progress and share my solutions.

This is the first in a series of posts where I solve the problems from the book. I'll solve them analytically first, then verify them with simulations. Nahin provided MATLAB code for the solutions, so I will also try to rewrite his original MATLAB code in R. My solutions will be added to GitHub as I complete them.

These puzzles are a little more advanced than the classic balls-in-the-urn or poker hand problems They require basic knowledge of calculus and advanced understanding of probability and statistics.

With that said, though, the first problem is a warm-up, so its solution isn't as long or complicated as the others.

The Embarrasing Question

Researchers are asking subjects an embarrasing Yes/No question. To ensure the subjects don't lie, the team sets up the following surveying procedure:

Subject enters a private room with a piece of paper, and flips a fair coin
- If heads: Write the answer (Yes/No) on the paper
- If tails: Flip the coin again
  - If heads: Write "Yes" on the paper
  - If tails: Write "No" on the paper
The subject turns in a piece of paper with a "Yes" or "No" on it, not knowing the results of the coin flip(s)
Once all subjects turn in their papers, the researchers estimate $p$, the proportion who truthfully answered "Yes" to the question.

The researchers have 6,230 papers with "Yes" written on them, and 3,770 with "No". What is $p$?

The procedure is outlined in the probability tree below:

The tree assumes the coin flips are independent of each other, and are independent of the subjects' response to the question. The black numbers on each branch indicate the conditional probability of the event occuring. The red numbers indicate the joint probability of each of the four outcomes.

We want to solve for $p$, which is $P(\text{Yes} | \text{heads first})$. We are given $P(\text{Yes}) = \frac{6230}{10000}$ and we know a coin lands on heads with probability 0.5.

$$ \begin{align*} P(\text{Yes}) &= P(\text{heads first}\cap \text{Yes} ) + P(\text{heads second}) &= 6230/10000 \\ & = 0.5p + 0.25 &= 6230/10000 \\ \end{align*} $$

Solving for $p$:

$p = 0.746$

To verify the solution, here is a simulation of the problem, using the $p=0.746$.

simulate_EQ = function(p = 0.746, N = 10000) {
    pop = sample(c("yes", "no"), size = N, prob = c(p, 1-p), replace = TRUE)
    results = rep("no", N)
    for (i in 1:N) {
        flip1 = rbinom(1, size = 1, p = 0.5) # 1 = heads, 0 = tails
        if (flip1) results[i] = pop[i]
        else {
            flip2 = rbinom(1, size = 1, p = 0.5)
            if (flip2) results[i] = "yes"
        }
    }
    return(results)
}

s = sum(simulate_EQ() == "yes")

print(s)

## [1] 6228

The simulation produces 6228 "Yes"s, very close the original problem's 6230.

Un Año de Despacito

2018-01-14T00:00:00-06:00

La canción de Luis Fonsi, Despacito ft. Daddy Yankee fue la canción de 2017. Lanzado en el principio de enero, la canción fue un éxito en Latinoamérica. Después de que se involucró Justin Bieber, dominaba las listas musicales alrededor del mundo.

El videoclip de la versión original se publicó en YouTube el 12 de enero, 2017, hace un año. En solo 97 días, el vídeo recibió un mil millones de vistas. El 4 de agosto- solo 7 meses después de su publicación- el vídeo se convirtió en el primer vídeo en la historia de YouTube en alcanzar 3 mil millones de vistas.

En este artículo voy a analizar cómo el videoclip creció tan rápido. Identifico las tendencias semanales y los momentos cuando las vistas crecían más rápido. Actualmente, no tengo mucha experiencia con las series temporales, así que esto será principalmente un análysis visual.

Los datos, scripts, y gráficos adicionales están disponibles en mi GitHub.

Obtener los datos

YouTube ofrece estadísticas del vídeo en algunos vídeos. No estoy seguro de qué determina si un vídeo tiene las estadísticas activadas, pero parece que la mayoría de los videoclips de canciones las tienen. Esto es el gráfico de vistas diarias de Despacito:

Podemos extraer los datos del código HTML.

Es importante notar que las estadísticas del vídeo solo están disponibles en el diseño de YouTube anterior. Por alguna razón, YouTube quitó las estadísticas del vídeo en su nuevo diseño.

Cuando estás en la página del videoclip y ya has abierto las estadísticas del vídeo, haz clic con el botón secundario alrededor del gráfico y elige Inspect Element. Busca stats-chart-gviz en el código HTML. Haz clic en las flechas hasta que encuentres la etiqueta <table>. Haz clic con el botón secundario y elige Copy > Copy element y pégalo en un editor de texto y guardar como un archivo .html.

Limpiar los datos

Ahora nuestros datos están en forma de una tabla HTML. Tenemos que obtener las fechas y los valores de la tabla para hacer nuestros proprios gráficos. Necesitamos el paquete XML para esto. Específicamente, necesitamos la función readHTMLTable() para leer los datos como una hoja de datos. Luego, creamos nuevas columnas date y views que contienen las fechas y los números de vistas en formatos adecuados.

Es importante notar que yo extraí los datos de la página inglés de YouTube. Los scripts en GitHub en su forma actual no funcionan si extraes los datos de YouTube de otro idioma.

# Cleaning ----
# This script only works for data taken from the English language YouTube site.
despacito_table = readHTMLTable("despacito_table.html")
despacito_df = despacito_table[[1]]
despacito_df[["date"]] = strptime(as.character(despacito_df[["Date"]]), "%b %d, %Y") %>% as.Date
despacito_df[["views"]] = gsub(",", "", despacito_df[["value"]]) %>% as.numeric

Añadimos más columnas para facilitar el análysis y producir gråficos.

# Cumulative views
despacito_df[["cumviews"]] = cumsum(despacito_df[["views"]])

# Change in views from previous day
change = despacito_df[["views"]] - c(despacito_df[1, "views"], despacito_df[-nrow(despacito_df), "views"])
despacito_df[["change"]] = change

# Add year, month, day of week
despacito_df[["year"]] = year(despacito_df[["date"]])
despacito_df[["month"]] = month(despacito_df[["date"]], label = TRUE)
despacito_df[["wday"]] = factor(weekdays(despacito_df[["date"]]),
                           levels= c("Monday", "Tuesday", "Wednesday", "Thursday", "Friday", "Saturday", "Sunday"))

Análysis

Ahora tenemos los datos limpiados, y podemos producir algunos gráficos.

Estos gráficos son los mismos que produce YouTube, con ciertos hitos marcados. Podemos ver algunas pautas interesantes:

Picos semanales los viernes y sábados
Caída de vistas diarias en febrero que pica de nuevo en marzo
Caída de vistas diarias a mediados de abril
Las vistas diarias aumentaban a lo largo del verano, y decrecían después de agosto, y otra vez en deciembre.

Cuando vi este gráfico por la primera vez, presumí que la caída de vistas en febrero era por la Cuaresma. Pero cuando marqué los días festivos, no había correlación.

Todavía, este gráfico muestra coincidencias con otros días festivos. Las vistas diarias bajaron y se establecieron durante la Semana Santa (9 - 15 de abril). El videoclip también fue popular en la Nochebuena y la Nochevieja, aunque no habían tantas vistas el resto de diciembre.

El aumento de la popularidad del videoclip puede seguir cuando la canción era popular en otros lugares. En México, la canción superó Los 40 el 11 de febrero. En EEUU, llegó a número 1 en Hot Latin Songs de Billboard para la semana de 18 de febrero.

Sospeché que la canción se habría levantado cuando el remix de Justin Bieber salió el 16 de abril. Las vistas sí aumentaron después de esa fecha, pero no se puede identificar si es por Justin Bieber o por la Pascua.

El 15 de mayo, la canción llegó a número 1 en Billboard's Hot 100, donde se quedaría por muchas semanas a lo largo del verano. Otra vez, no se puede ver un aumento significativo en esa fecha.

Después de que superó 3 mil millones de vistas, un hito sin precedentes, la popularidad del videoclip disminuyó. Quizás los jóvenes ya no tenían tiempo para reproducirlo. Aun cuando la canción ganó 4 premios de Latin Grammys en noviembre, las vistas diarias seguían la típica tendencia.

Me interesa explicar los días que no siguen la tendencia. Para identificar anomalías, hice este gráfico que muestra la diferencia de vistas del día anterior.

El gráfico también muestra que las vistas diarias aumentan los viernes y sábados, y bajan los domingos y lunes. Hay algunas excepciones notables. El único sábado cuando las vistas disminuyó era el 1 de febrero. El único viernes cuando las vistas disminuyó era el 14 de abril- Viernes Santo.

También hay algunos picos peculiares. Primero, el miércoles 8 de marzo, 2017. No puedo encontrar nada para explicar por qué había tantas vistas ese miércoles. Presiento que el algoritmo de sugerencias de YouTube escondió el vídeo desde 1 de febrero hasta 8 de marzo. Así que la gente no podía encontrar el vídeo por sus sugerencias.

Los otros picos considerables son de los domingos de la Nochebuena y la Nochevieja. No es típico tener más vistas el domingo que el sábado.

Predecir las vistas

Ahora intento predecir el número de vistas en el futuro. Un modelo de efectos principales con factores $\alpha$ y $\beta$ tiene la forma

$$ y_{ijk} = \mu +\alpha_i+\beta_j+e_{ijk} $$

donde $\mu$ es el promedio general, $\alpha_i$ y $\beta_j$ son los efectos principales de los factores, y $e_{ijk}$ es el error. Para las vistas del videoclip, presumo que el número de vistas en un día particular depende de solo el mes y el día de la semana.

$$ \text{views}_{ijk} = \mu +\text{month}_i+\text{wday}_j+e_{ijk} $$

Es fácil hacer esto en R.

view_mod = lm(views ~ factor(month, ordered = FALSE) + wday, data = despacito_df)
summary(view_mod)[["coefficients"]]

##                                     Estimate Std. Error    t value
## (Intercept)                        6101017.5   368686.2 16.5479942
## factor(month, ordered = FALSE)Feb   504094.8   437943.9  1.1510488
## factor(month, ordered = FALSE)Mar  4354379.6   427075.1 10.1958162
## factor(month, ordered = FALSE)Apr  7317787.7   430508.1 16.9980251
## factor(month, ordered = FALSE)May  9987258.8   426805.1 23.4000478
## factor(month, ordered = FALSE)Jun 11658600.7   430508.3 27.0810138
## factor(month, ordered = FALSE)Jul 13765615.4   426940.1 32.2425001
## factor(month, ordered = FALSE)Aug 11478848.1   426940.1 26.8863215
## factor(month, ordered = FALSE)Sep  5599158.5   430508.3 13.0059252
## factor(month, ordered = FALSE)Oct  2287510.1   426805.1  5.3596133
## factor(month, ordered = FALSE)Nov   704704.9   430508.1  1.6369144
## factor(month, ordered = FALSE)Dec -1384111.2   427075.1 -3.2409078
## wdayTuesday                          74460.1   326885.8  0.2277863
## wdayWednesday                       278608.4   327092.7  0.8517719
## wdayThursday                        659271.2   327196.1  2.0149112
## wdayFriday                         2110548.1   327196.1  6.4504076
## wdaySaturday                       3672752.2   327094.4 11.2284172
## wdaySunday                         1415449.2   326990.9  4.3287110
##                                        Pr(>|t|)
## (Intercept)                        1.009681e-45
## factor(month, ordered = FALSE)Feb  2.505070e-01
## factor(month, ordered = FALSE)Mar  1.614956e-21
## factor(month, ordered = FALSE)Apr  1.548200e-47
## factor(month, ordered = FALSE)May  2.839371e-73
## factor(month, ordered = FALSE)Jun  1.723188e-87
## factor(month, ordered = FALSE)Jul 2.831538e-106
## factor(month, ordered = FALSE)Aug  9.381737e-87
## factor(month, ordered = FALSE)Sep  9.256291e-32
## factor(month, ordered = FALSE)Oct  1.526429e-07
## factor(month, ordered = FALSE)Nov  1.025575e-01
## factor(month, ordered = FALSE)Dec  1.307217e-03
## wdayTuesday                        8.199470e-01
## wdayWednesday                      3.949298e-01
## wdayThursday                       4.468707e-02
## wdayFriday                         3.759610e-10
## wdaySaturday                       3.726519e-25
## wdaySunday                         1.966222e-05

El resumen muestra los coeficientes del modelo. El (Intercept) es la base de referencia a la que los otros coeficientes comparan. Aquí es enero y lunes. Entonces, el coeficiente para febrero se puede interpretar como "504094.8 más vistas en febrero que en enero."

Mi interpretación puede ser equivocada. Traté de verificar los valores con otros métodos, y no podía replicar los resultos. Además, me habría gustado que el resumen reflejara la forma del modelo arriba, (i.e. sin el intercepto). Usando - 1 quita el intercepto y añade enero, pero no incluye lunes. Si alguién tenga sugerencias, por favor contáctame.

A pesar de la interpretación, el modelo predice bien las vistas. Mira los valores ajustados (rojo) y los valores reales (negro).

Ahora si queremos predecir cuando el vídeo llegará 5, 6, o 7 mil millones de vistas, creamos una hoja de datos que tiene el mes y el día de fechas en el futuro.

future_days = seq.Date(ymd("2018-01-13"), ymd("2020-01-01"), by = "day")
future_df = data.frame(month = month(future_days, label = TRUE),
                       wday = wday(future_days, label = TRUE, abbr = FALSE))

Luego, predecimos el número de vistas en cada uno de estas fechas. La suposición principal es que el vídeo seguirá el mismo pauta en el futuro.

future_views = predict(view_mod, newdata = future_df)

Usamos la función de la suma cumulativa para ver las vistas acumulativas en cada fecha.

future_total = cumsum(future_views) + despacito_df[nrow(despacito_df), "cumviews"] # Adding current total

Por fin vemos las fechas cuando los hitos ocurrirán.

future_milestones = c(t_5b = future_days[which(future_total >= 5e9)][1],
                      t_6b = future_days[which(future_total >= 6e9)][1],
                      t_7b = future_days[which(future_total >= 7e9)][1],
                      t_8b = future_days[which(future_total >= 8e9)][1],
                      t_9b = future_days[which(future_total >= 9e9)][1],
                      t_10b = future_days[which(future_total >= 1e10)][1])
print(future_milestones)

##         t_5b         t_6b         t_7b         t_8b         t_9b 
## "2018-02-24" "2018-05-10" "2018-07-04" "2018-08-23" "2018-11-19" 
##        t_10b 
## "2019-03-25"

Según este modelo, el videoclip de Despacito llegará a 5 mil millones de vistas el 24 de febrero, 2018 y 10 mil millones el 25 de marzo, 2019. No creo que este modelo sirva muy bien después de unos meses. Los datos que uso son del primer año de esta canción, cuando era nueva y su popularidad estaba en su máximo. Ya ha completado su dominación en las listas musicales alrededor del mundo. El año 2018 tendrá canciones y videoclips más populares, y este vídeo será una reliquia del pasado. Todavía yo volveré en marzo para ver que precisas eran mis predicciones.

Referencias

https://www.youtube.com/watch?v=kJQP7kiw5Fk

https://es.wikipedia.org/wiki/Despacito

https://www.billboard.com/articles/columns/chart-beat/7793159/luis-fonsi-daddy-yankee-despacito-justin-bieber-number-one

http://los40.com.mx/lista40/2017/6

One Year of Despacito

2018-01-13T00:00:00-06:00

Luis Fonsi's Despacito ft. Daddy Yankee was the song of 2017. Released in early January, the song became an instant hit in Latin America. After Justin Bieber got involved, it dominated charts around the world.

The music video for the original Spanish-language version was published on YouTube on January 12, 2017, one year ago today. In just 97 days, the video received one billion views. Views kept coming in, and by August 4- just 7 months after its release- the video became the first video in YouTube history to break 3 billion.

In this post I will analyze how the music video grew so fast. I will identify weekly trends and moments where the view count grew rapidly. Currently, I don't have much experience with time series, so this analysis will be mostly visual.

Data, scripts, and additional plots are available on my GitHub.

Getting the data

YouTube provides video statistics for some of its videos. I'm not sure what determines whether a video has statistics enabled, but it seems most music videos have them. Here's what the daily view graph looks like for Despacito:

We can get the data we need directly from the HTML used to create this table.

It's important to note video statistics are only available in the previous YouTube format. For some reason, YouTube removed the video statistics in their new layout.

Once you're at the page and you have opened the video statistics, right-click somewhere around the chart and inspect element. You won't be able to right-click the actual graphic itself, but the axis labels should work. Look for stats-chart-gviz in the HTML. Click the arrows until you find the <table> tag. Right-click and select Copy > Copy element and paste it into a text editor and save it as an .html file.

Cleaning the data

Now our data is saved as an HTML table. We need to get the dates and values from it to make our own graphs. We'll need the XML package for this. Specifically, we use the readHTMLTable() function to read the data as a dataframe. Then, we create new date and views columns that contain the date and number of views in appropriate formats.

# Cleaning ----
# This script only works for data taken from the English language YouTube site.
despacito_table = readHTMLTable("despacito_table.html")
despacito_df = despacito_table[[1]]
despacito_df[["date"]] = strptime(as.character(despacito_df[["Date"]]), "%b %d, %Y") %>% as.Date
despacito_df[["views"]] = gsub(",", "", despacito_df[["value"]]) %>% as.numeric

Let's add more columns to make analysis and plotting easier later on.

# Cumulative views
despacito_df[["cumviews"]] = cumsum(despacito_df[["views"]])

# Change in views from previous day
change = despacito_df[["views"]] - c(despacito_df[1, "views"], despacito_df[-nrow(despacito_df), "views"])
despacito_df[["change"]] = change

# Add year, month, day of week
despacito_df[["year"]] = year(despacito_df[["date"]])
despacito_df[["month"]] = month(despacito_df[["date"]], label = TRUE)
despacito_df[["wday"]] = factor(weekdays(despacito_df[["date"]]),
                           levels= c("Monday", "Tuesday", "Wednesday", "Thursday", "Friday", "Saturday", "Sunday"))

Analysis

Now that we have cleaned data, we can make some plots.

These plots are the same as the ones YouTube generates, with certain view milestones marked. From this we can see some interesting patterns:

Weekly spikes on Fridays and Saturdays
Drop in views per day in February that spikes again in March
Drop in views per day in mid-April
Views per day continued growing through the summer, then dropped after August, then again in December.

When I first saw this plot, I assumed the drop in views in February was due to people limiting music during Lent. But when I marked major holidays on the plot, the correlation wasn't there.

Still, this plot shows coincidences with other holidays. Views dropped and steadied during Holy Week (April 9 - 15). The video was also popular on Christmas Eve and New Year's Eve, though not so much the rest of December.

The rise in the video's popularity could follow when the song was popular elsewhere. The song first topped Mexico's Los 40 on February 11. In the US, the song sat at number 1 on Billboard's Hot Latin Songs for the week of February 18.

I suspected the song to have received a boost when the Justin Bieber remix came out on April 16. Views did spike after that date, but it's hard to tell if it's from the remix, or from the end of Lent.

On May 15, the song hit number 1 on Billboard's Hot 100, where it would sit for several weeks through the summer. Again, there isn't a significant increase in views around that time.

After the video hit an unprecedented 3 billion views, its popularity dropped. Perhaps as kids were going back to school, there were fewer people playing it than in the summer. Even when the song won 4 awards at the Latin Grammys in November, daily views followed the same pattern.

I'm interested in explaining the days that don't follow the trend. To better identify anomalies, I made a bar plot that colors the days of the week.

This plot better shows that daily views increase on Friday and Saturday, then drop Sunday and Monday. There are some notable exceptions. The only Saturday where views dropped was February 1. The only Friday where views dropped was April 14- Good Friday.

There are also some unusual days where views spiked. First, there was a spike on Wednesday March 8, 2017. I cannot find anything that could explain why views spiked so much on that Wednesday. My hunch is that YouTube's suggestion algorithm effectively hid the video from February 1 to March 8, so people did not find it through their suggested videos.

The other major spikes were the Sundays of Christmas Eve and New Year's Eve.

Predicting future views

Now for a crude attempt at predicting views in the future. A main effects model with factors $\alpha$ and $\beta$ has the form

$$ y_{ijk} = \mu +\alpha_i+\beta_j+e_{ijk} $$

where $\mu$ is the overall mean, $\alpha_i$ and $\beta_j$ are the main effects of the factors, and $e_{ijk}$ is the error. For the music video views, I am assuming the number of views on a certain day depends on only the month and day of the week.

$$ \text{views}_{ijk} = \mu +\text{month}_i+\text{wday}_j+e_{ijk} $$

This is easy to do in R.

view_mod = lm(views ~ factor(month, ordered = FALSE) + wday, data = despacito_df)
summary(view_mod)[["coefficients"]]

##                                     Estimate Std. Error    t value
## (Intercept)                        6101017.5   368686.2 16.5479942
## factor(month, ordered = FALSE)Feb   504094.8   437943.9  1.1510488
## factor(month, ordered = FALSE)Mar  4354379.6   427075.1 10.1958162
## factor(month, ordered = FALSE)Apr  7317787.7   430508.1 16.9980251
## factor(month, ordered = FALSE)May  9987258.8   426805.1 23.4000478
## factor(month, ordered = FALSE)Jun 11658600.7   430508.3 27.0810138
## factor(month, ordered = FALSE)Jul 13765615.4   426940.1 32.2425001
## factor(month, ordered = FALSE)Aug 11478848.1   426940.1 26.8863215
## factor(month, ordered = FALSE)Sep  5599158.5   430508.3 13.0059252
## factor(month, ordered = FALSE)Oct  2287510.1   426805.1  5.3596133
## factor(month, ordered = FALSE)Nov   704704.9   430508.1  1.6369144
## factor(month, ordered = FALSE)Dec -1384111.2   427075.1 -3.2409078
## wdayTuesday                          74460.1   326885.8  0.2277863
## wdayWednesday                       278608.4   327092.7  0.8517719
## wdayThursday                        659271.2   327196.1  2.0149112
## wdayFriday                         2110548.1   327196.1  6.4504076
## wdaySaturday                       3672752.2   327094.4 11.2284172
## wdaySunday                         1415449.2   326990.9  4.3287110
##                                        Pr(>|t|)
## (Intercept)                        1.009681e-45
## factor(month, ordered = FALSE)Feb  2.505070e-01
## factor(month, ordered = FALSE)Mar  1.614956e-21
## factor(month, ordered = FALSE)Apr  1.548200e-47
## factor(month, ordered = FALSE)May  2.839371e-73
## factor(month, ordered = FALSE)Jun  1.723188e-87
## factor(month, ordered = FALSE)Jul 2.831538e-106
## factor(month, ordered = FALSE)Aug  9.381737e-87
## factor(month, ordered = FALSE)Sep  9.256291e-32
## factor(month, ordered = FALSE)Oct  1.526429e-07
## factor(month, ordered = FALSE)Nov  1.025575e-01
## factor(month, ordered = FALSE)Dec  1.307217e-03
## wdayTuesday                        8.199470e-01
## wdayWednesday                      3.949298e-01
## wdayThursday                       4.468707e-02
## wdayFriday                         3.759610e-10
## wdaySaturday                       3.726519e-25
## wdaySunday                         1.966222e-05

The summary shows the coefficients of the model. The (Intercept) is the baseline to which all other coefficients are compared. Here the baseline is January and Monday. So, the estimated coefficient for February can be interpreted as "504094.8 more views in February than in January."

Sidenote: My interpretation here might be wrong. I tried verifying the values with other methods, and couldn't replicate the results. Also, I would've liked for the summary to reflect the form of the main effects model above, (i.e. without the intercept). Using - 1 gets rid of the intercept and includes January, but not Monday. If anyone has any suggestions for me, please feel free to reach out.

Regardless of its interpretation, the model does a decent job at predicting. Take a look at the fitted values (in red) compared to the true values.

Now if we want to predict when the video will reach 5, 6, or 7 billion views, we'll first need to create a data frame of predictors that contains the month and day of future dates.

future_days = seq.Date(ymd("2018-01-13"), ymd("2020-01-01"), by = "day")
future_df = data.frame(month = month(future_days, label = TRUE),
                       wday = wday(future_days, label = TRUE, abbr = FALSE))

Next, we predict the number of views on each of those days, assuming views follow the same pattern in the future as in 2017.

future_views = predict(view_mod, newdata = future_df)

Then, we'll take the cumulative sum to see the total views on each date.

future_total = cumsum(future_views) + despacito_df[nrow(despacito_df), "cumviews"] # Adding current total

Finally, we can see the dates where certain view milestones will occur.

future_milestones = c(t_5b = future_days[which(future_total >= 5e9)][1],
                      t_6b = future_days[which(future_total >= 6e9)][1],
                      t_7b = future_days[which(future_total >= 7e9)][1],
                      t_8b = future_days[which(future_total >= 8e9)][1],
                      t_9b = future_days[which(future_total >= 9e9)][1],
                      t_10b = future_days[which(future_total >= 1e10)][1])
print(future_milestones)

##         t_5b         t_6b         t_7b         t_8b         t_9b 
## "2018-02-24" "2018-05-10" "2018-07-04" "2018-08-23" "2018-11-19" 
##        t_10b 
## "2019-03-25"

With this model, the music video for Despacito will reach 5 billion views on February 24, 2018 and 10 billion on March 25, 2019. I don't expect this model to perform very well beyond a few months. The data I used was from the first year of the song, when it was new and its popularity was at its peak. It has already completed its reign over charts around the world. 2018 may have hotter songs and music videos, and this video will be a relic of the past. Still, I'll be back in March to check how well these predictions held up.

References

https://www.youtube.com/watch?v=kJQP7kiw5Fk

https://en.wikipedia.org/wiki/Despacito

https://www.billboard.com/articles/columns/chart-beat/7793159/luis-fonsi-daddy-yankee-despacito-justin-bieber-number-one

http://los40.com.mx/lista40/2017/6

100-Year Flood Part 1

2018-01-12T00:00:00-06:00

In this two-part post, I play around with some data in R to show the statistics behind parameter estimation and the 100-year flood. This is mostly me following along with posts from other blogs to get familiar with R, RMarkdown, and blogging.

In this first part, I'll show how the hundred year flood is calculated from data. In Part 2, I'll go into more detail on the 100-year flood, do some simulations, and verify our solution in Part 1.

Parameter Estimation

The data I use here comes from Problem 6² in

Ross, Sheldon M. “Chapter 7: Parameter Estimation.” Introduction to Probability and Statistics for Engineers and Scientists, 5th ed., Elsevier, AP, 2014, pp. 285–286.

River floods are often measured by their discharges $(\text{ft}^3/\text{s})$ The value $v$ is said to be the value of a 100-year flood if $P(D \geq v) = 0.01$ where $D$ is the discharge of the largest flood in a randomly selected year.

The table below gives the flood discharges of the largest floods of the Blackstone River in Woonsocket, RI, in each year from 1929 to 1965.

Assuming that these discharges follow a log-normal distribution, estimate the value of a 100-year flood.

year	discharge
1929	4750
1930	1970
1931	8220
1932	4530
1933	5780
1934	6560
1935	7500
1936	15000
1937	6340
1938	15100
1939	3840
1940	5860
1941	4480
1942	5330
1943	5310
1944	3830
1945	3410
1946	3830
1947	3150
1948	5810
1949	2030
1950	3620
1951	4920
1952	4090
1953	5570
1954	9400
1955	32900
1956	8710
1957	3850
1958	4970
1959	5398
1960	4780
1961	4020
1962	5790
1963	4510
1964	5520
1965	5300

The plot below displays the above table as a graph. The average discharge of the largest flood during this period is around 6,000 $\text{ft}^3/\text{s}$. There was an unusually large flood in 1955, with well over 30,000 $\text{ft}^3/\text{s}$ of discharge.

plot(floods, type = "h", lwd = 2,
     main = "Largest floods of the Blackstone River")

Distribution of discharges

The problem tells us to assume discharge follows a log-normal distribution. So, $D \sim \text{Lognormal}(\mu, \sigma)$. Two notable properties of the log-normal distribution are that it takes positive values and it is positively skewed. Looking at the histogram of discharges, we can see both are true: discharges cannot be less than 0 and high-discharge floods are much less frequent than low-discharge floods.

hist(floods[["discharge"]], nclass = 25, freq = TRUE, xlab = "discharge", main = "")

The next step is to determine which log-normal distribution this data comes from. In other words, what are the parameters for this distribution?

Log-normal distribution

$$f(x) = \frac{1}{x\sigma\sqrt{2π}} \exp\Big(-\frac{(\ln x - \mu)^2}{2 \sigma^2}\Big)$$

The log-normal distribution is similar to the normal distribution in that it has two parameters, $\mu$ and $\sigma$. We need to estimate both.

The following sections show how to estimate the parameters for the log-normal distribution, using four different methods I found in a paper on log-normal parameter estimation¹.

Maximum Likelihood Estimates

$$ \hat{\mu}=\frac{\sum \ln x_i}{n} = \overline{\ln x_i} $$

mu_hat = mean(log(floods[["discharge"]]))

$$ \hat{\sigma}^2 = \frac{\sum_i^n (\ln x_i - \hat{\mu})^2}{n} $$

sigma_hat = (log(floods[["discharge"]]) - mu_hat)^2 %>% mean %>% sqrt

Method of Moments Estimates

$$ \tilde{\sigma}^2= \ln{\sum_{i=1}^nx_i^2} - 2\ln{\sum_{i=1}^nx_i}+\ln(n) $$

sigma_tilde = ((floods[["discharge"]]^2 %>% sum %>% log) -
    2 * (floods[["discharge"]] %>% sum %>% log) +
    log(nrow(floods))) %>%
    sqrt

$$ \tilde{\mu}= {\ln \sum_{i=1}^n x_i}-\ln(n)-\frac{\tilde{\sigma}^2}{2} $$

mu_tilde = (floods[["discharge"]] %>% sum %>% log) -
            log(nrow(floods)) - 
            (sigma_tilde)^2 / 2

Serfling Robust Estimates and Finney Efficient Estimates

The next two methods are a little more complex.

The Serfling method computes a sample statistic for all $n\choose k$ permutations of the data, then selects the median as the estimate.

I made slight modifications to the algorithm for the sake of computation speed. First, I only use 10,000 permutations. Serfling and Ginos limit the number of permutations to 10^7^, but I found even that was too high for R. Second, I did not intentionally use unique permutations. Instead I drew random samples of $k=9$ from the data. I didn't check if all 10,000 were unique. Maybe later I'll make a post investigating how much accuracy my method compromises for speed.

source("serfling.R")

serfling_estimates = serfling_estimate_1(floods[["discharge"]])
mu_hat_serf = serfling_estimates[[1]]
sigma_hat_serf = serfling_estimates[[2]]

The Finney method uses adjusted versions of the sample mean and variance to estimate $\mu$ and $\sigma$.

source("finney.R")

finney_estimates = finney_estimate_1(floods[["discharge"]])
mu_hat_finney = finney_estimates[[1]]
sigma_hat_finney = finney_estimates[[2]]

Estimated distributions

Since we now have parameters, we have distributions. We can plot the four probability density functions with the histogram to see how well they fit with the data.

Note that the Finney efficient estimates are very similar to the maximum likelihood estimates.

	Mu	Sigma
MLE	8.594057	0.5116531
MOM	8.593508	0.5118573
Serfling	8.505484	0.7142709
Finney	8.586239	0.4270907

Now we can determine the value $v$ for which $P(D \geq v) = 0.01$ or equivalently $P(D < v) = 0.99$

v_mle = qlnorm(p = 0.99, meanlog = mu_hat, sdlog = sigma_hat)

v_mom = qlnorm(p = 0.99, meanlog = mu_tilde, sdlog = sigma_tilde)

v_serf = qlnorm(p = 0.99, meanlog = mu_hat_serf, sdlog = sigma_tilde)

v_finney = qlnorm(p = 0.99, meanlog = mu_hat_finney, sdlog = sigma_hat_finney)

	v
MLE	17753.54
MOM	26033.18
Serfling	28222.70
Finney	17752.23

From the data, we see that in only one year, 1955, was the value exceeded.

In the next post, I'll look at how likely this is: to have one such flood in a 37-year period.

References

Ginos, Brenda Faith, "Parameter Estimation for the Lognormal Distribution" (2009). All Theses and Dissertations. 1928. http://scholarsarchive.byu.edu/etd/1928 ↩
Ross, Sheldon M. “Chapter 7: Parameter Estimation.” Introduction to Probability and Statistics for Engineers and Scientists, 5th ed., Elsevier, AP, 2014, pp. 285–286. ↩

100-Year Flood Part 2

2018-01-12T00:00:00-06:00

In Part 1, I estimated $v$, the value of the 100-year flood for Blackstone River in Woonsocket, RI. The result using maximum likelihood estimation was 17754 $\text{ft}^3/\text{s}$. What does that mean, and is it accurate?

Background

This article is based on this series of posts by Tony Ladson. They are really easy to follow if you don't have much experience with hydrology, probability, or R.

The value of the 100-year flood was calculated to be 17754. This can be worded in different ways:

In a single year, there is a 1% chance the discharge of the largest flood will exceed 17754.
In a 100-year period, the discharge is expected to be (or exceed) 17754 in one of the years.
A flood with a discharge of at least 17754 $\text{ft}^3/\text{s}$ is expected to occur once in a hundred years.

It's not accurate to say the 100-year flood will occur once every 100 years. The important word is expected. In a 100-year period, it's possible for zero 100-year floods to occur. It's also possible 37 100-year floods occur.

Number of 100-year floods in 37 years

plot(floods, type = "h", lwd = 2)
title("Largest floods
      of the Blackstone River
      1929-1965", cex = 0.75)
abline(h = v_mle, col = "red")

Looking at our original data, the 100-year flood was exceeded once in the 37-year period. How likely is it to have exactly one such flood in a 37-year period? We aren't considering the volume of the flood. That is, we aren't asking how likely it is to have a flood with a discharge of 32900 (the maximum), or what discharge is expected. We are only concerned with how many are expected to occur in a random 37-year period.

Expectation

The number of 100-year floods $X$ in a $n$-year period follows a binomial distribution:

$$ P(X=k)= {n \choose k}p^k(1-p)^{n-k} $$

Here $n=37$ (number of years) and $p=0.01$ (Defined in Part 1 as $P(D \geq v)$). The number of floods (or number of years where the 100-year flood occurs) $k$ can be any number from 0 to 37, as the flood can occur 0, 1, 2,..., or 37 times in a 37-year period.

Since $n$ is large (37) and $p$ is small (0.01) we can approximate the binomial distribution with a Poisson distribution.

$$ P(X=k) = \frac{e^{-\lambda}\lambda^k}{k!} $$

Here the parameter $\lambda$ is approximated with $np = 37\times0.01=0.37$. With this approximation, $k$ can be larger than 37, but the probabilities will be so small they're essentially 0.

# P(X = 38)
dpois(x = 38, lambda = 1)

## [1] 7.03372e-46

Simulation

Knowing the log-normal distribution, we can simulate 37 years of flooding to see if it matches our result and what we expect.

Count simulation

We can simulate the number of 100-year floods occuring in a 37-year period by simulating binomial and Poisson processes 1000 times.

set.seed(2018)
N = 1000
# Binomial
bFloods = rbinom(n = N, size = 37, prob = 0.01)
b_table = table(bFloods)/N ; b_table

## bFloods
##     0     1     2     3     4 
## 0.697 0.257 0.038 0.007 0.001

# Poisson
pFloods = rpois(n = N, lambda = 37*0.01)
p_table = table(pFloods)/N ; p_table

## pFloods
##     0     1     2     3     4 
## 0.696 0.258 0.039 0.006 0.001

Log-normal simulation

Another way to simulate the number of 100-year floods is to simulate 37-year periods and count how many floods exceed 17754. This involves an extra step compared to the previous method, and I'm only doing it for demonstration.

Let's start with a matrix to store simulations of flood discharges. Each column is a simulation (1000 total) and each row will represent a year of flooding (37 total).

N = 1000
m = replicate(n = N, expr = rlnorm(n = 37, meanlog = mu_hat, sdlog = sigma_hat)) %>% as.matrix

Now, let's count how many 100-year floods occured in the 1000 37-year periods. In other words, for each column (simulation), how many rows (years) exceed 17754? Then we'll make a table to see how frequent the counts are.

sim_counts = apply(X = m, # apply to the matrix m
                   MARGIN = 2, # for each column...
                   FUN = function(x) sum(x > v_mle)) # ...count the number of years > v_mle
sim_table = table(sim_counts)/N; sim_table

## sim_counts
##     0     1     2     3     4 
## 0.677 0.261 0.050 0.011 0.001

The following graph compares the expected probabilities and the simulated probabilities. The red and blue bars show the expected and simulated counts, respectively. The yellow bars show the counts using simulated floods.

In a 37-year period, it's much more likely to have zero 100-year floods than to have one. Still, the probability of exactly one is high, about 26%.

Method	Probability of exactly 1 100-year flood in 37 years
Expected Binomial Counts	0.25767
Simulated Binomial Counts	0.257
Expected Poisson Counts	0.25557
Simulated Poisson Counts	0.258
Counts of Simulated Floods	0.261

References

Ladson, Tony. "The 100 year flood." tonyladson | Hydrology, Natural Resources and R. June 7, 2015. https://tonyladson.wordpress.com/2015/06/07/the-100-year-flood/.

https://water.usgs.gov/edu/100yearflood.html

https://water.usgs.gov/edu/100yearflood-basic.html