Modeling the income distribution

The log-logistic distribution is also known in economics as the Fisk distribution, and it is commonly used to represent income distributions. The advantage of this probability distribution is that its parameters can be easily estimated from the median income and the Gini coefficient.

Specifically, this probability distribution has two parameters, a scale parameter and a shape parameter , and the following relationships are known to hold for these parameters. Using these relationships, we can easily set the parameters of the log-logistic distribution from the median income and the Gini coefficient.

• The scale parameter equals the median income

• The shape parameter equals the reciprocal of the Gini coefficient

Data used

In this article, I use the following data published by the OECD in Society at a Glance 2024: OECD Social Indicators.

• Median household income³: Annual median equivalised disposable income, in 2021, USD at PPP rates
• Gini coefficient: Gini coefficient of household disposable income and gap between richest and poorest 10%, in 2021

First, download the data with the following code.

library(fs)
library(tidyverse)

file_median_income <- "income-distribution-from-median-and-gini-log-logistic/median_income_oecd_2021.xlsx"
if (!file_exists(file_median_income)) {
 curl::curl_download("https://stat.link/1or2b8", file_median_income)
}

file_gini_coefficient <- "income-distribution-from-median-and-gini-log-logistic/gini_coefficient_oecd_2021.xlsx"
if (!file_exists(file_gini_coefficient)) {
 curl::curl_download("https://stat.link/3f18vc", file_gini_coefficient)
}

Visualizing the income distribution

First, load the necessary data from the downloaded Excel files.

library(readxl)

median_income <- read_excel(
  file_median_income,
  sheet = "Data4.1",
  range = cell_limits(ul = c(12, 1), lr = c(NA, 3)),
  col_names = c("country_name", "country_code", "median_income_usd_ppp"),
  col_types = c(rep("text", 2), "numeric")
) |>
  drop_na(country_name) |>
  arrange(country_name)

gini_coefficient <- read_excel(
  file_gini_coefficient,
  sheet = "data",
  range = cell_limits(ul = c(12, 4), lr = c(NA, 5)),
  col_names = c("country_name", "gini_coefficient"),
  col_types = c("text", "numeric")
) |>
  drop_na(country_name) |>
  arrange(country_name)

The loaded data are as follows.

median_income

gini_coefficient

Next, join the loaded data and compute the parameters of the log-logistic distribution.

income_distribution_params <- median_income |>
  inner_join(gini_coefficient, by = join_by(country_name)) |>
  mutate(
    scale_param = median_income_usd_ppp,
    shape_param = 1 / gini_coefficient,
    .keep = "unused"
  )
income_distribution_params

Next, visualize the income distribution for each country. In the code below, I plot the income distribution of the G7 countries using the probability density function of the log-logistic distribution.

data_income_distribution_params <- income_distribution_params |>
  # G7
  filter(
    country_name %in%
      c(
        "Canada",
        "France",
        "Germany",
        "Italy",
        "Japan",
        "United Kingdom",
        "United States"
      )
  ) |>
  expand_grid(
    income = seq(0, 150000, by = 1000)
  ) |>
  mutate(
    density = VGAM::dfisk(
      income,
      scale = scale_param,
      shape1.a = shape_param
    )
  ) |>
  select(!c(scale_param, shape_param))

plot_income_distribution <- data_income_distribution_params |>
  ggplot(aes(x = income, y = density, color = country_name)) +
  geom_line() +
  scale_x_continuous(labels = scales::dollar_format(prefix = "$", big.mark = ",", accuracy = 1)) +
  scale_y_continuous(labels = scales::comma_format(accuracy = 0.0001)) +
  labs(
    title = "Estimated income distribution of OECD countries (log-logistic distribution)",
    x = "Income (USD PPP)",
    y = "Probability density",
    color = "Country"
  ) +
  theme_minimal()

plotly::ggplotly(plot_income_distribution)

Conclusion

In this article, I introduced a method for reconstructing an income distribution from its median and Gini coefficient using the log-logistic distribution. By using the log-logistic distribution, we can capture the overall shape of an income distribution from just these two statistics: the median income and the Gini coefficient.

Note that this method may differ from the actual income distribution. To estimate a more accurate income distribution, additional data and a more complex model would be required.

Example

Let’s turn the following data process into a step-by-step data process. This process uses the penguins data to calculate the average weight of penguins by island, species and year.

library(tidyverse)

as_tibble(penguins) |>
  select(species, island, body_mass, year) |>
  filter(!is.na(body_mass)) |>
  mutate(
    # Convert body_mass to kg
    body_mass = units::set_units(body_mass, g) |>
      units::set_units("kg")
  ) |> 
  summarise(
    mean_body_mass = mean(body_mass),
    .by = c(island, species, year)
  ) |> 
  arrange(island, species, year)

# A tibble: 15 × 4
   island    species    year mean_body_mass
   <fct>     <fct>     <int>           [kg]
 1 Biscoe    Adelie     2007           3.62
 2 Biscoe    Adelie     2008           3.63
 3 Biscoe    Adelie     2009           3.86
 4 Biscoe    Gentoo     2007           5.07
 5 Biscoe    Gentoo     2008           5.02
 6 Biscoe    Gentoo     2009           5.14
 7 Dream     Adelie     2007           3.67
 8 Dream     Adelie     2008           3.76
 9 Dream     Adelie     2009           3.65
10 Dream     Chinstrap  2007           3.69
11 Dream     Chinstrap  2008           3.8 
12 Dream     Chinstrap  2009           3.72
13 Torgersen Adelie     2007           3.76
14 Torgersen Adelie     2008           3.86
15 Torgersen Adelie     2009           3.49

library(adverbial)

data_wrangler <- step_by_step(
  c(
    select_step = "Select columns from the data frame",
    filter_step = "Filter rows from data frames",
    mutate_step = "Mutate columns in the data frame",
    summarise_step = "Summarise the data frame",
    arrange_step = "Order rows in the data frame"
  )
)

select_step <- as_step(select, "select_step")
filter_step <- as_step(filter, "filter_step")
mutate_step <- as_step(mutate, "mutate_step")
summarise_step <- as_step(summarise, "summarise_step")
arrange_step <- as_step(arrange, "arrange_step")

data_wrangler(as_tibble(penguins))

# Steps:
# ☒ 1. select_step:    Select columns from the data frame
# ☐ 2. filter_step:    Filter rows from data frames
# ☐ 3. mutate_step:    Mutate columns in the data frame
# ☐ 4. summarise_step: Summarise the data frame
# ☐ 5. arrange_step:   Order rows in the data frame
# ℹ Please call `select_step()` to continue.
#
# A tibble: 344 × 8
   species island    bill_len bill_dep flipper_len body_mass sex     year
 * <fct>   <fct>        <dbl>    <dbl>       <int>     <int> <fct>  <int>
 1 Adelie  Torgersen     39.1     18.7         181      3750 male    2007
 2 Adelie  Torgersen     39.5     17.4         186      3800 female  2007
 3 Adelie  Torgersen     40.3     18           195      3250 female  2007
 4 Adelie  Torgersen     NA       NA            NA        NA <NA>    2007
 5 Adelie  Torgersen     36.7     19.3         193      3450 female  2007
 6 Adelie  Torgersen     39.3     20.6         190      3650 male    2007
 7 Adelie  Torgersen     38.9     17.8         181      3625 female  2007
 8 Adelie  Torgersen     39.2     19.6         195      4675 male    2007
 9 Adelie  Torgersen     34.1     18.1         193      3475 <NA>    2007
10 Adelie  Torgersen     42       20.2         190      4250 <NA>    2007
# ℹ 334 more rows

data_wrangler(as_tibble(penguins)) |> 
  select_step(species, island, body_mass, year) |>
  filter_step(!is.na(body_mass)) |>
  mutate_step(
    # Convert body_mass to kg
    body_mass = units::set_units(body_mass, g) |>
      units::set_units("kg")
  ) |> 
  # You can use another function during the step-by-step process.
  as_step(head)(n = 3)

# Steps:
# ☒ 1. select_step:    Select columns from the data frame
# ☒ 2. filter_step:    Filter rows from data frames
# ☒ 3. mutate_step:    Mutate columns in the data frame
# ☐ 4. summarise_step: Summarise the data frame
# ☐ 5. arrange_step:   Order rows in the data frame
# ℹ Please call `summarise_step()` to continue.
#
# A tibble: 3 × 4
  species island    body_mass  year
* <fct>   <fct>          [kg] <int>
1 Adelie  Torgersen      3.75  2007
2 Adelie  Torgersen      3.8   2007
3 Adelie  Torgersen      3.25  2007

data_wrangler(as_tibble(penguins)) |> 
  select_step(species, island, body_mass, year) |>
  filter_step(!is.na(body_mass)) |>
  mutate_step(
    # Convert body_mass to kg
    body_mass = units::set_units(body_mass, g) |>
      units::set_units("kg")
  ) |> 
  summarise_step(
    mean_body_mass = mean(body_mass),
    .by = c(island, species, year)
  ) |> 
  arrange_step(island, species, year) |> 
  end_step()

# A tibble: 15 × 4
   island    species    year mean_body_mass
 * <fct>     <fct>     <int>           [kg]
 1 Biscoe    Adelie     2007           3.62
 2 Biscoe    Adelie     2008           3.63
 3 Biscoe    Adelie     2009           3.86
 4 Biscoe    Gentoo     2007           5.07
 5 Biscoe    Gentoo     2008           5.02
 6 Biscoe    Gentoo     2009           5.14
 7 Dream     Adelie     2007           3.67
 8 Dream     Adelie     2008           3.76
 9 Dream     Adelie     2009           3.65
10 Dream     Chinstrap  2007           3.69
11 Dream     Chinstrap  2008           3.8 
12 Dream     Chinstrap  2009           3.72
13 Torgersen Adelie     2007           3.76
14 Torgersen Adelie     2008           3.86
15 Torgersen Adelie     2009           3.49

Conclusion

adverbial package provides a way of breaking down data processing tasks into smaller, more manageable steps. This approach allows users to understand the overall workflow and adapt it to their needs. The aim is to eliminate the need for workers to remember each mentally demanding step of data processing.

Implementing the Cobb-Douglas Utility Function

A utility function can be thought of as a function that takes a vector of quantities consumed as its argument and returns utility (a scalar value). On the other hand, when defining a utility function, we need to set parameters in advance, such as elasticity parameters, in addition to the quantity vector.

Since the parameters differ depending on the utility function, we define the utility function as the abstract type AbstractEconomicUtility, and define the Cobb-Douglas utility function CobbDouglasUtility as a subtype of it. We define CobbDouglasUtility as a type that holds the elasticity parameter weights.

abstract type AbstractEconomicUtility end

struct CobbDouglasUtility <: AbstractEconomicUtility
    weights::Vector{Float64}
end

Next, by defining function-like objects, we make it possible to compute utility by calling f(quantities) for a utility function type f. Note that since the utility function’s parameters can be obtained from the type f, the function’s only argument is quantities. This allows us to call the same code, f(quantities), for various utility function types f.

With this, we can define the Cobb-Douglas utility function.

function(f::CobbDouglasUtility)(quantities)
    return prod(quantities .^ f.weights)
end

# Define the utility function
cobb_douglas = CobbDouglasUtility([0.3, 0.4, 0.3])

# Compute utility
cobb_douglas([2., 3., 5.])

3.0963389922845703

Next, as in the previous article, we define the Marshallian demand function, demand_marshallian().

With demand_marshallian(), we can find the analytical solution to the utility maximisation problem for the Cobb-Douglas utility function.

function demand_marshallian(
  f::CobbDouglasUtility;
  prices,
  income
)
  return income * f.weights / sum(f.weights) ./ prices
end

demand_marshallian (generic function with 1 method)

quantities_analytical_cobb_douglas = demand_marshallian(
  cobb_douglas;
  prices = [1., 2., 3.],
  income = 100.
)

3-element Vector{Float64}:
 30.0
 20.0
 10.0

Numerical Solution to the Utility Maximisation Problem

By slightly modifying the code from the previous article, we can solve the utility maximisation problem numerically.

In the previous article, we defined code specific to the Cobb-Douglas utility function. However, the function demand_marshallian_numerical below takes the abstract type AbstractEconomicUtility as its argument, allowing the same code to be used for a variety of utility functions.

import Pkg
Pkg.add("JuMP")
Pkg.add("Ipopt")

using JuMP
using Ipopt

function demand_marshallian_numerical(
  f::AbstractEconomicUtility;
  prices::Vector{Float64},
  income::Float64
)
    n = length(prices)
    model = Model(Ipopt.Optimizer)
    set_silent(model)
    @variable(model, quantities[1:n] >= 0)
    @objective(model, Max, f(quantities))
    @constraint(model, sum(prices .* quantities) <= income)
    optimize!(model)
    return value.(quantities)
end

demand_marshallian_numerical (generic function with 1 method)

By applying demand_marshallian_numerical() to the cobb_douglas defined above, we can confirm, as in the previous article, that the analytical and numerical solutions to the Cobb-Douglas utility maximisation problem approximately agree.

quantities_numerical_cobb_douglas = demand_marshallian_numerical(
  cobb_douglas;
  prices = [1., 2., 3.],
  income = 100.
)

******************************************************************************
This program contains Ipopt, a library for large-scale nonlinear optimization.
 Ipopt is released as open source code under the Eclipse Public License (EPL).
         For more information visit https://github.com/coin-or/Ipopt
******************************************************************************

3-element Vector{Float64}:
 30.000000297265974
 20.00000019590169
 10.000000099089569

quantities_analytical_cobb_douglas

3-element Vector{Float64}:
 30.0
 20.0
 10.0

Implementing the CES Utility Function

To get a feel for the benefits of using constructors, let’s implement a utility function other than the Cobb-Douglas type.

Below, let’s implement the CES utility function. The CES utility function is a generalisation of the Cobb-Douglas utility function and has a parameter substitution that represents the degree of substitutability. As with the Cobb-Douglas utility function, the CES utility function can be defined as follows.

I’ll skip the derivation of the Marshallian demand function, but by specifying the argument type f::CESUtility, we can change the behaviour of demand_marshallian() depending on the utility function. This mechanism is called multiple dispatch.

struct CESUtility <: AbstractEconomicUtility
    substitution::Float64
    weights::Vector{Float64}
end

function(f::CESUtility)(quantities)
    return sum(f.weights .* quantities .^ f.substitution) ^ (1 / f.substitution)
end

function demand_marshallian(
  f::CESUtility;
  prices,
  income
)
  return f.weights .^ (1 / (1 - f.substitution)) .* prices .^ (1 / (f.substitution - 1)) *
    income / sum(f.weights .^ (1 / (1 - f.substitution)) .* prices .^ (f.substitution / (f.substitution - 1)))
end

demand_marshallian (generic function with 2 methods)

ces = CESUtility(0.5, [0.3, 0.4, 0.3])
ces([2., 3., 5.])

3.196603520188051

By applying demand_marshallian() and demand_marshallian_numerical() to the ces defined above, we can find the analytical and numerical solutions to the CES utility maximisation problem.

quantities_analytical_ces = demand_marshallian(
  ces;
  prices = [1., 2., 3.],
  income = 100.
)

quantities_numerical_ces = demand_marshallian_numerical(
  ces;
  prices = [1., 2., 3.],
  income = 100.
)

3-element Vector{Float64}:
 45.00000043558223
 20.000000194987294
  5.000000053970371

quantities_analytical_ces

3-element Vector{Float64}:
 45.0
 20.000000000000004
  4.999999999999999

Summary

In this article, I showed that by extending the utility maximisation problem introduced in my previous article using Julia’s constructors, we can use the same code for a variety of utility functions.

By taking advantage of this mechanism, whenever we implement a new utility function, we can automatically check the consistency between the analytical and numerical solutions to the optimisation problem, which is expected to make it easier to implement tests for utility functions¹.

Smoothing using Bayes’ theorem

Assume that the count data follows a Poisson distribution, and that the true value of the proportion follows a Gamma distribution, which is the conjugate prior of the Poisson distribution.

Then, using Bayes’ theorem, the posterior distribution of — that is, the distribution of given the observed value — is as follows.

Therefore, the expected value of the posterior distribution of can be expressed by the following simple formula, and by using this formula we can remove the observation noise (i.e., smooth the data).

On the other hand, to perform this kind of smoothing, we need to determine the values of and . Below, we describe a method for estimating the prior distribution parameters and from the observed values.

Estimating prior distribution parameters with empirical Bayes

Empirical Bayes is a method for estimating the parameters of the prior distribution (empirically) from the observed values. Possible approaches for estimating the prior distribution parameters with empirical Bayes include the method of moments and maximum likelihood estimation; below, we describe the approach using maximum likelihood estimation.

Before performing maximum likelihood estimation, let’s first check the distribution that follows. is considered to follow a mixture of the Gamma and Poisson distributions, as shown below. Normally, computing a mixture distribution requires integral calculus, but it is known that the mixture of the Gamma and Poisson distributions follows a negative binomial distribution. Therefore, we derive the probability distribution of in advance, as follows.

From the formula above, we can see that follows a negative binomial distribution as shown below. Note, however, that there are several ways to parameterize the negative binomial distribution, so some care is needed. The parameterization used here is the same as Stan’s NegBinomial2.

In this way, we find that follows a common probability distribution called the negative binomial distribution, which means we can perform maximum likelihood estimation using existing functions provided in R. Below, using experimentally created test data, we perform maximum likelihood estimation with the glm.nb() function from R’s MASS package, and use it to smooth the proportion data.

A worked example of smoothing

library(tidyverse)

theme_set(theme_bw())

set.seed(1234)

# Sample size
n <- 1e4

# Proportion (true value)
alpha_true <- 5
beta_true <- 50
rate_true <- rgamma(n, shape = alpha_true, rate = beta_true)

tibble(rate_true = rate_true) |>
  ggplot(aes(rate_true)) +
  geom_histogram(binwidth = 1e-2)

# Population (denominator)
x <- 1:100
population <- sample(x, n, replace = TRUE)

# Count data (numerator)
count <- rpois(n, rate_true * population)

data <- tibble(
  population = population,
  rate_true = rate_true,
  count = count
)
head(data, n = 10)

data_crude <- data |>
  mutate(
    rate_crude = count / population
  )
head(data_crude, n = 10)

data_crude |>
  ggplot(aes(population, rate_crude)) +
  geom_point()

data_crude |>
  ggplot(aes(rate_true, rate_crude, color = population)) +
  geom_point() +
  geom_abline(color = "red") +
  scale_color_viridis_c(option = "turbo") +
  tune::coord_obs_pred()

Smoothing using the negative binomial distribution

Now, let’s perform smoothing using the negative binomial distribution. Here, we perform maximum likelihood estimation using the glm.nb() function from R’s MASS package, which is readily available. glm.nb() lets us estimate a generalized linear model in which the response variable follows a negative binomial distribution.

The parameters of the negative binomial distribution can be estimated with simple code like the following. Here, we specify log(population) as an offset term so that the expected value is proportional to population.

model <- MASS::glm.nb(
  count ~ offset(log(population)),
  data = data
)

Next, we obtain the parameters of the Gamma distribution from model, which stores the output of glm.nb(). The Gamma distribution’s can be obtained from model$theta. We can see that the estimated value of , alpha_estimated, roughly matches the true value, alpha_true.

alpha_estimated <- model$theta

alpha_true

[1] 5

alpha_estimated

[1] 5.014545

Also, the Gamma distribution’s can be obtained from the relationship for shown above, as follows. Although is output once for each sample, we can see that the estimated values of , beta_estimated, are all nearly identical, and that they roughly match the true value, beta_true.

mu <- predict(model, type = "response")
beta_estimated <- alpha_estimated * population / mu

beta_true

[1] 50

all(near(beta_estimated, beta_estimated[[1]]))

[1] TRUE

head(beta_estimated)

       1        2        3        4        5        6 
50.07359 50.07359 50.07359 50.07359 50.07359 50.07359 

Finally, let’s use the estimated Gamma distribution parameters and to smooth the proportion. We reproduce the smoothing formula below for reference. We compute the smoothed proportion, rate_smoothed, following this formula, and draw the same kind of plots as before. As a result, we can see that there is no tendency for the proportion to be over- or under-estimated even when population is small, confirming that the small number problem has been resolved.

data_smoothed <- data |>
  mutate(
    rate_smoothed = (count + alpha_estimated) / (population + beta_estimated)
  )
head(data_smoothed, n = 10)

data_smoothed |>
  ggplot(aes(population, rate_smoothed)) +
  geom_point()

data_smoothed |>
  ggplot(aes(rate_true, rate_smoothed, color = population)) +
  geom_point() +
  geom_abline(color = "red") +
  scale_color_viridis_c(option = "turbo") +
  tune::coord_obs_pred()

Conclusion

In this article, we explained a smoothing method using empirical Bayes as an approach for dealing with the small number problem in proportion data. The phenomenon where the variability of proportion data becomes large when the denominator, such as the population, is small is likely to be a problem in practice as well. In such cases, one option is to exclude data with a small denominator based on some threshold, but the method described in this article has the advantage of allowing us to make use of all the data.

The glm.nb() function from the MASS package used in this article is a function for generalized linear models, so it is possible to include terms other than the denominator term, offset(log(population)), as explanatory variables. This makes it possible to reproduce situations in which varies depending on factors such as regional characteristics.

Also, although we focused on the Poisson distribution, which we consider to be highly versatile, the same framework can also be applied to the binomial distribution. In the case of the binomial distribution, if we use a Beta distribution as the prior, the smoothing formula becomes as follows. In addition, since the mixture distribution in this case is the Beta-binomial distribution, parameter estimation should be relatively straightforward using existing R packages (e.g., bbmle).

Cobb-Douglas utility function

The Cobb-Douglas utility function is defined as follows. Here, is the consumption quantity of production factor , and is the elasticity parameter of production factor .

Implementing this utility function in Julia looks like this.

function cobb_douglas(quantities; weights)
    return prod(quantities .^ weights)
end

cobb_douglas (generic function with 1 method)

By passing the consumption quantities quantities and the elasticity parameters weights to the implemented cobb_douglas function, we can compute the utility as follows.

cobb_douglas(
  [2, 3, 5],
  weights=[0.3, 0.4, 0.3]
)

3.0963389922845703

Analytical solution to the utility maximization problem

In general, a utility maximization problem is formulated as the problem of finding the consumption quantities that maximize utility given prices and income.

These consumption quantities (demand quantities) are known as the Marshallian demand functions. For the Cobb-Douglas utility function, the Marshallian demand functions are derived as follows¹. Here, is the price of production factor , and is income.

function demand_marshallian_cobb_douglas_analytical(prices, income; weights)
    return income .* weights ./ sum(weights) ./ prices
end

demand_marshallian_cobb_douglas_analytical (generic function with 1 method)

By passing the prices prices, the income income, and the elasticity parameters weights to the implemented demand_marshallian_cobb_douglas_analytical function, we can compute the demand quantities as follows.

quantities_analytical = demand_marshallian_cobb_douglas_analytical(
  [1, 2, 3],
  100,
  weights=[0.3, 0.4, 0.3]
)

3-element Vector{Float64}:
 30.0
 20.0
 10.0

Numerical solution to the utility maximization problem

Next, let’s use Julia JuMP to solve the utility maximization problem numerically. Before we start, let’s install the JuMP and Ipopt packages. Ipopt provides a solver for nonlinear optimization problems.

import Pkg
Pkg.add("JuMP")
Pkg.add("Ipopt")

The utility maximization problem with the Cobb-Douglas utility function is formulated as follows. With JuMP, we can easily describe and numerically solve the utility maximization problem using the cobb_douglas function we already defined.

using JuMP
using Ipopt

function demand_marshallian_cobb_douglas_numerical(prices, income; weights)
    n = length(prices)
    model = Model(Ipopt.Optimizer)
    set_silent(model)
    @variable(model, quantities[1:n] >= 0) # Define consumption quantities as variables
    @objective(model, Max, cobb_douglas(quantities; weights)) # Maximize utility
    @constraint(model, sum(prices .* quantities) <= income) # Budget constraint
    optimize!(model)
    return value.(quantities)
end

demand_marshallian_cobb_douglas_numerical (generic function with 1 method)

In this formulation of the utility maximization problem, we are doing the following.

1. Using the @variable macro to define the consumption quantities quantities as variables
2. Using the @objective macro to define the objective function that maximizes utility
3. Using the @constraint macro to define the budget constraint

Now, let’s use the implemented demand_marshallian_cobb_douglas_numerical function to find the numerical solution.

quantities_numerical = demand_marshallian_cobb_douglas_numerical(
  [1, 2, 3],
  100,
  weights=[0.3, 0.4, 0.3]
)

******************************************************************************
This program contains Ipopt, a library for large-scale nonlinear optimization.
 Ipopt is released as open source code under the Eclipse Public License (EPL).
         For more information visit https://github.com/coin-or/Ipopt
******************************************************************************

3-element Vector{Float64}:
 30.000000297265974
 20.00000019590169
 10.000000099089569

The final results are as follows, and we can see that the numerical solution almost matches the analytical solution.

quantities_numerical

3-element Vector{Float64}:
 30.000000297265974
 20.00000019590169
 10.000000099089569

quantities_analytical

3-element Vector{Float64}:
 30.0
 20.0
 10.0

Summary

In this article, I used Julia JuMP to solve a utility maximization problem based on the Cobb-Douglas utility function.

We confirmed that Julia JuMP makes it easy to formulate and numerically solve nonlinear optimization problems.

With Julia JuMP, simple functions can be used as-is as objective functions and the like, so it may also be useful for implementing economic models.

Before tidying an Excel file

Before getting into the main topic, there’s one thing I’d like to note: check whether the data you want to use for analysis is available in a more machine-readable format.

Excel files are convenient for viewing data, but they are often not very machine-readable. Therefore, it’s advisable to check in advance whether the data is available in a more suitable format. For example, e-Stat, Japan’s portal site for government statistics, sometimes lets you use its API to obtain data that is more machine-readable than a typical Excel file.

The “gap between humans and machines” in data formats

Data that is easy for us to read isn’t necessarily easy for a machine to read. A classic example of this is weekly weather forecast data¹.

For example, let’s say we have the following dummy weekly weather forecast data. If a human looks at this data, they can immediately understand that it’s “weather by region and date.” However, it may be surprisingly difficult for a machine to mechanically grasp the following:

• That the column names from the second column onward represent dates
• That the values in the columns from the second column onward represent weather

library(tidyverse)

region <- c("Sapporo", "Tokyo", "Nagoya", "Osaka", "Fukuoka", "Naha")
date <- seq(ymd("2024-12-20"), ymd("2024-12-26"), by = "day") |>
  format("%m/%d")
weather <- c("🌞", "⛅", "☔")

set.seed(1234)
weather_forecast <- expand_grid(region = region, date = date) |>
  mutate(weather = sample(weather, n(), replace = TRUE))

weather_forecast_wider <- weather_forecast |>
  pivot_wider(names_from = date, values_from = weather)
weather_forecast_wider

To make it clearer that the data above represents “weather by region and date,” data like the following is more suitable. In this data, the observed value—weather—is properly mapped to the axes (dimensions) of region and date, and this kind of long-format data is called tidy data. However, if data in this long format were shown on the news, most people would probably find it hard to read².

weather_forecast

Why does this “gap between humans and machines” arise?

The figure below shows the long-format data above plotted as a scatter plot with ggplot2. Comparing this scatter plot with the table shown earlier, you can see that they look quite similar. For us, a table with axes in both the vertical and horizontal directions may be more intuitive to understand than one with only a vertical axis.

weather_forecast |>
  ggplot(aes(date, region, label = weather)) +
  geom_text() +
  scale_x_discrete(position = "top") +
  scale_y_discrete(limits = rev)

Interpreting the table structure of an Excel file

With this “gap between humans and machines” in mind, let’s interpret the table structure of an actual Excel file.

With this “gap between humans and machines” in mind, let’s interpret the table structure of an actual Excel file. If the data is as simple as “weather by region and date,” the table structure isn’t too complex. But what about data such as “population by year, region, sex, and age group,” for example? Let’s actually look at this Excel file published on e-Stat. The image below shows an excerpt of the top part of the Excel file.

Leaving aside the explanatory text at the top of the data, we can see it has the following data format. If we color-code the axes (dimensions)—year, region, sex, and age—in light blue (■), and the type/unit of the observed values—population, population ratio, and sex ratio—in blue (■), we get the figure shown below. To summarize the details of the data format:

• Columns 1 and 2 store the axis (dimension) information for region and age group, respectively
• The part corresponding to the column names from column 3 onward mixes axis (dimension) information with observed-value information
  • Rows 1 and 3 store the axis (dimension) information for year and sex, respectively
  • Rows 2 and 4 record the type and unit of the observed values—population, population ratio, and sex ratio, respectively

When tidying an Excel file, it’s important to keep the following points in mind:

• When column names span multiple rows, you need to sort out in advance whether the information in each row corresponds to an axis (dimension) or to an observed value
• To avoid duplicate column names, some column names are often abbreviated, or cells are merged

Tidying an Excel file with readxl

Now, let’s actually tidy an Excel file. Below, I show the code for tidying the “population by year, region, sex, and age” Excel file introduced above.

The readxl package is useful for reading Excel files³. Here, since we’ll use the readxl package to tidy the Excel file, let’s load the readxl and tidyverse packages in advance.

# Install packages as needed
# install.packages("pak")
# pak::pak("readxl")
# pak::pak("tidyverse")

library(readxl)
library(tidyverse)

library(fs)

exdir <- "tips-tidying-excel-data-with-r"
dir_create(exdir)

destfile <- path(exdir, "population_by_year_sex_age_class", ext = "xlsx")
if (!file_exists(destfile)) {
  curl::curl_download(
    "https://www.e-stat.go.jp/stat-search/file-download?statInfId=000001085927&fileKind=0",
    destfile = destfile
  )
}

# Location of the Excel file downloaded in advance
file <- "tips-tidying-excel-file-with-r/population_by_year_sex_age_class.xlsx"
sheet <- "da03"

data_col_names <- read_excel(
  file,
  sheet = sheet, # Sheet name
  skip = 10, # Skip the explanatory section
  n_max = 5, # Only read the column-name section
  col_names = FALSE,
  col_types = "text",
  .name_repair = "minimal"
) |>
  # Transpose, then convert to a data frame
  t() |>
  as_tibble(
    .name_repair = ~ c("year", "value_type", "sex", "", "value_unit")
  ) |>
  select(year, value_type, sex, value_unit) |>

  # Exclude the first two rows (region and age group)
  slice_tail(n = -2)

head(data_col_names, n = 10)

data_col_names <- data_col_names |>
  # Extract only the Gregorian year number
  mutate(
    year = year |>
      str_extract("^\\d+(?=年$)") |>
      as.integer(),

    # Replace with an empty string if value_unit is "-"
    value_unit = if_else(value_unit == "-", "", value_unit)
  ) |>

  # Fill in NA values in year and value_type
  fill(year, value_type)

head(data_col_names, n = 10)

col_names <- data_col_names |>
  unite("value_type", value_type, value_unit, sep = "") |>
  unite("col_name", year, sex, value_type, sep = "/") |>
  pull(col_name)
col_names <- c("region", "age_class", col_names)

head(col_names, n = 10)

 [1] "region"                           "age_class"                       
 [3] "1920/総数/人口（人）"             "1920/男/人口（人）"              
 [5] "1920/女/人口（人）"               "1920/総数/年齢，男女別割合（％）"
 [7] "1920/男/年齢，男女別割合（％）"   "1920/女/年齢，男女別割合（％）"  
 [9] "1920/NA/人口性比"                 "1925/総数/人口（人）"            

data <- read_excel(
  file,
  sheet = sheet,
  skip = 10 + 5,
  col_names = col_names,
  col_types = "text",
  .name_repair = "minimal"
) |>

  # Remove duplicate columns found at the end (likely a mistake made when the original data was created)
  select(all_of(vctrs::vec_unique_loc(col_names)))

head(data, n = 10)

data <- data |>
  pivot_longer(
    !c(region, age_class),
    names_to = c("year", "sex", ".value"),
    names_sep = "/",
    names_transform = list(
      sex = \(x)
        x |>
          na_if("NA")
    )
  ) |>
  # Convert the population, percentage-by-age-and-sex, and sex-ratio columns to numeric
  mutate(across(c(`人口（人）`, `年齢，男女別割合（％）`, 人口性比), \(x) {
    parse_number(x, na = "-")
  })) |>
  relocate(year, region, sex, age_class)

head(data, n = 10)

data_population <- data |>
  drop_na(sex) |>
  select(!人口性比)

head(data_population, n = 5)

data_sex_ratio <- data |>
  filter(is.na(sex)) |>
  select(!c(sex, `人口（人）`, `年齢，男女別割合（％）`))

head(data_sex_ratio, n = 5)

Tidying an Excel file with tidyxl and unpivotr

Next, I’ll introduce how to tidy an Excel file using the tidyxl and unpivotr packages.

With the readxl package, we needed to go through many steps: creating column names, reading the data, and converting it to tidy data. With the tidyxl and unpivotr packages, by using long-format data that expands the Excel file’s table into “values by row and column,” we can tidy data more flexibly and efficiently than with readxl.

First, let’s load the packages we’ll need.

# Install packages as needed
# install.packages("pak")
# pak::pak("tidyxl")
# pak::pak("unpivotr")
# pak::pak("tidyverse")

library(tidyxl)
library(unpivotr)
library(tidyverse)

cells <- xlsx_cells(file, sheets = sheet)

head(cells, n = 10)

data2 <- cells |>
  # Exclude the first 10 rows, which are the explanatory section
  filter(row > 10) |>

  # Column 1 represents region (on the left side, as seen from the data)
  behead("left", "region") |>

  # Column 2 represents age group (on the left side, as seen from the data)
  behead("left", "age_class") |>

  # Row 1 represents the calendar year (up-left side, as seen from the data)
  filter(row != 10 + 1 | str_detect(character, "^\\d+年$")) |> # Remove Japanese-era years
  behead("up-left", "year") |>

  # Row 2 represents the value type (up-left side, as seen from the data)
  behead("up-left", "value_type") |>

  # Row 3 represents sex (up side, as seen from the data)
  behead("up", "sex") |>

  # Row 5 represents the unit (up side, as seen from the data)
  behead("up", ".") |> # Assign a placeholder name to the blank row 4 (to be removed later)
  behead("up", "value_unit") |>

  select(year, region, age_class, sex, value_type, value_unit, numeric)

head(data2, n = 5)

data2 <- data2 |>
  # Create the value_type column, same as when using readxl
  mutate(value_unit = if_else(value_unit == "-", "", value_unit)) |>
  unite("value_type", value_type, value_unit, sep = "") |>

  # Remove duplicates
  slice_head(n = 1, by = c(year, region, age_class, sex, value_type)) |>

  # Expand the value type into columns to create wide-format data
  pivot_wider(names_from = value_type, values_from = numeric)

head(data2, n = 10)

Summary

In this article, I introduced some tips for tidying Excel files. As approaches to data tidying, I introduced the method using the readxl package and the method using the tidyxl and unpivotr packages. In either case, interpreting the table structure of the data is important.

If you have any suggestions for improvement, additional content, or questions about the data-tidying workflow introduced in this article, I’d appreciate your comments.

References

• Let’s Smartly Format Municipal Data in R (aggregating municipal mergers, designated cities, etc.)

Visualization results of municipal mergers by prefecture

Below are the visualization results of municipal mergers. If you notice any issues with the data, I’d appreciate it if you could let me know in the comments. Please note that in some places the labels overlap and are hard to read.

library(tidyverse)
library(tidygraph)
library(ggraph)

date_end <- ymd("2024-04-01")

graph_city <- jpcity:::graph_city$graph_city |>

  activate(nodes) |>
  filter(!node_is_isolated(),
         is.infinite(interval) | int_end(interval) <= date_end) |>
  arrange(desc(interval)) |>

  replace_na(list(city_desig_name = "",
                  city_name = "")) |>
  mutate(city_name = str_c(city_desig_name, city_name)) |>
  select(!city_desig_name) |>

  mutate(group = group_components()) |>

  activate(edges) |>
  filter(!type %in% c("分離", "分割"))

jpcity::parse_pref(1:47) |>
  walk(\(pref) {
    pref_name <- jpcity::pref_name(pref)

    plot <- graph_city |>
      activate(nodes) |>
      filter(pref_name == .env$pref_name) |>

      create_layout("fabric") |>

      # It's possible to align label positions with chronology, but this is omitted since it makes the graph harder to read
      # mutate(y = int_start(interval)) |>

      ggraph() +
      geom_edge_diagonal(color = "gray",
                         arrow = arrow(length = unit(2, 'mm')),
                         end_cap = circle(8, 'mm')) +
      geom_node_label(aes(label = city_name,
                          fill = as_factor(group)),
                      size = 3,
                      show.legend = FALSE) +
      scale_fill_hue(l = 100) +
      coord_flip() +

      labs(title = pref_name) +
      theme_void()

    print(plot)
  })

What should you watch out for when analyzing municipal data?

What should you be careful about when analyzing statistical data broken down by municipality? Below, I’ll introduce three main points to watch out for.

library(tidyverse)
library(jpcity)

get_city("2020-01-01") |> 
  jpcity:::city_data() |> 
  mutate(n = n(),
         .by = c(city_desig_name, city_name)) |> 
  filter(n > 1) |> 
  arrange(desc(n), city_desig_name, city_name) |> 
  select(!c(starts_with("city_desig_name"), n)) |> 
  rmarkdown::paged_table()

tibble(city_after = get_city("2020-01-01"),
       city_before = city_after |> 
         city_convert("2020-01-01", "1970-04-01")) |> 
  mutate(size_city_before = vctrs::list_sizes(city_before)) |> 
  slice_max(size_city_before, 
            n = 1) |> 
  select(!size_city_before) |> 
  unnest(city_before) |> 
  mutate(city_code_before = city_code(city_before),
         city_name_before = city_name(city_before),
         city_code_after = city_code(city_after),
         city_name_after = city_name(city_after),
         .keep = "unused") |> 
  rmarkdown::paged_table()

tibble(city = find_city("横浜市", "2020-01-01") |> 
         city_desig_merge() |> 
         vctrs::vec_unique(),
       city_desig = city |> 
         city_desig_split()) |> 
  unnest(city_desig) |> 
  mutate(city_code = city_code(city),
         city_name = city_name(city),
         city_desig_code = city_code(city_desig),
         city_desig_name = city_name(city_desig),
         .keep = "unused") |> 
  rmarkdown::paged_table()

Smartly formatting municipal data in R

With the points above in mind, let’s introduce how to smartly format municipal data using R. In fact, all of the examples shown above are based on information published by e-Stat in “Search Municipalities” and “Search Municipal Merger Information”.

However, “Search Municipal Merger Information” describes changes to municipality codes due to mergers and other events in text form, which makes it difficult to use directly for data formatting.

So, to make it easy to perform haichi-bungō processing and map between the cities and wards of designated cities without having to do this kind of complex data formatting, I created a new package called jpcity². Incidentally, all of the tables shown above were created using the jpcity package. Since jpcity is registered on CRAN, it can be installed by running the code below. From here, I’ll briefly explain how to use jpcity.

install.packages("jpcity")

library(tidyverse)
library(jpcity)

city <- tibble(city_parsed = parse_city("15222", "2020-01-01"),
               city_found = find_city("上越市", "2020-01-01"))

city

# A tibble: 1 × 2
  city_parsed          city_found          
  <city>               <city>              
1 15222 [新潟県上越市] 15222 [新潟県上越市]

city |> 
  select(city_parsed) |> 
  mutate(city_converted = city_parsed |> 
           city_convert("2020-01-01", "2000-01-01")) |> 
  unnest(city_converted)

# A tibble: 14 × 2
   city_parsed          city_converted        
   <city>               <city>                
 1 15222 [新潟県上越市] 15521 [新潟県安塚町]  
 2 15222 [新潟県上越市] 15522 [新潟県浦川原村]
 3 15222 [新潟県上越市] 15525 [新潟県大島村]  
 4 15222 [新潟県上越市] 15526 [新潟県牧村]    
 5 15222 [新潟県上越市] 15541 [新潟県柿崎町]  
 6 15222 [新潟県上越市] 15542 [新潟県大潟町]  
 7 15222 [新潟県上越市] 15543 [新潟県頸城村]  
 8 15222 [新潟県上越市] 15544 [新潟県吉川町]  
 9 15222 [新潟県上越市] 15546 [新潟県中郷村]  
10 15222 [新潟県上越市] 15548 [新潟県板倉町]  
11 15222 [新潟県上越市] 15549 [新潟県清里村]  
12 15222 [新潟県上越市] 15550 [新潟県三和村]  
13 15222 [新潟県上越市] 15561 [新潟県名立町]  
14 15222 [新潟県上越市] 15222 [新潟県上越市]  

# Split the designated city into its wards
city_desig <- tibble(city = parse_city("14100", "2020-01-01"),
                     city_desig = city_desig_split(city)) |> 
  unnest(city_desig)
city_desig

# A tibble: 14 × 2
   city                   city_desig                      
   <city>                 <city>                          
 1 14100 [神奈川県横浜市] 14101 [神奈川県横浜市鶴見区]    
 2 14100 [神奈川県横浜市] 14102 [神奈川県横浜市神奈川区]  
 3 14100 [神奈川県横浜市] 14103 [神奈川県横浜市西区]      
 4 14100 [神奈川県横浜市] 14104 [神奈川県横浜市中区]      
 5 14100 [神奈川県横浜市] 14105 [神奈川県横浜市南区]      
 6 14100 [神奈川県横浜市] 14106 [神奈川県横浜市保土ケ谷区]
 7 14100 [神奈川県横浜市] 14107 [神奈川県横浜市磯子区]    
 8 14100 [神奈川県横浜市] 14108 [神奈川県横浜市金沢区]    
 9 14100 [神奈川県横浜市] 14109 [神奈川県横浜市港北区]    
10 14100 [神奈川県横浜市] 14110 [神奈川県横浜市戸塚区]    
11 14100 [神奈川県横浜市] 14111 [神奈川県横浜市港南区]    
12 14100 [神奈川県横浜市] 14112 [神奈川県横浜市旭区]      
13 14100 [神奈川県横浜市] 14113 [神奈川県横浜市緑区]      
14 14100 [神奈川県横浜市] 14114 [神奈川県横浜市瀬谷区]    

# Merge the wards of the designated city back into the city (showing only the first few rows)
city_desig |>
  select(city_desig) |> 
  mutate(city = city_desig_merge(city_desig)) |> 
  head()

# A tibble: 6 × 2
  city_desig                       city                  
  <city>                           <city>                
1 14101 [神奈川県横浜市鶴見区]     14100 [神奈川県横浜市]
2 14102 [神奈川県横浜市神奈川区]   14100 [神奈川県横浜市]
3 14103 [神奈川県横浜市西区]       14100 [神奈川県横浜市]
4 14104 [神奈川県横浜市中区]       14100 [神奈川県横浜市]
5 14105 [神奈川県横浜市南区]       14100 [神奈川県横浜市]
6 14106 [神奈川県横浜市保土ケ谷区] 14100 [神奈川県横浜市]

Summary

In this article, I introduced points to watch out for when analyzing municipal data, and how to smartly format municipal data in R using the jpcity package. If you have any requests, bug reports, or questions about the jpcity package, feel free to reach out via GitHub or the comment section below.

Causal discovery with LiNGAM

LiNGAM (Linear Non-Gaussian Acyclic Model) is one of the representative causal discovery methods, and it seems to be increasingly used in practice in recent years, being implemented in commercial software and other tools. As its name suggests, LiNGAM is a method that can reveal causal relationships from data when the functional form is linear and the error terms follow a non-Gaussian (non-normal) distribution.

LiNGAM can be used via the Python lingam package or the R pcalg package, and simply feeding a data frame into the functions provided by these packages lets you easily estimate a causal graph. A causal graph is a network structure built by treating observed variables as nodes and causal relationships as arrows. In particular, causal discovery typically estimates a causal graph in the form of a DAG (Directed Acyclic Graph).

As an example of a causal graph, I created the following causal graph related to running a restaurant business. In practice, profit is likely to fluctuate due to various factors such as the day of the week, weather, and the location of the store, so it is expected that even more complex causal relationships would be the subject of analysis.

flowchart LR
  ingredient-quality --> food-deliciousness
  ingredient-quality --> cost
  chef-skill --> food-deliciousness
  chef-skill --> wages
  food-deliciousness --> customer-count
  food-deliciousness --> spend-per-customer
  customer-count --> revenue
  spend-per-customer --> revenue
  revenue --> profit
  cost --> expenses
  wages --> expenses
  fixed-costs --> expenses
  expenses --> profit

The effect of functional form on LiNGAM estimation

LiNGAM is a method that estimates causal relationships under the assumption that the functional form is linear and the error terms follow a non-Gaussian distribution. Therefore, if the functional form is not linear (or is difficult to approximate linearly), incorrect causal relationships may be estimated. Packages and commercial software make it easy to run LiNGAM, but users need to understand that these assumptions exist before using LiNGAM.

Here, let’s apply LiNGAM to data with a simpler causal relationship than the causal graph shown above. Specifically, we will check how the results of LiNGAM change when a nonlinear function is placed in fun in the flowchart below.

Note that in this article, we use Direct LiNGAM, the most common variant of LiNGAM, with a uniform distribution (a non-Gaussian distribution) for the error terms. We also ignore any causal relationships whose coefficient has an absolute value less than 0.001.

flowchart LR
  x11 --> add1(+)
  x12 --> add1
  add1 --> x21
  x21 --> fun2(fun)
  x22 --> fun2
  fun2 --> x31
style fun2 stroke:red,color:red

Before estimating the causal graph, let’s prepare a data frame with 1,000 rows and columns x11, x12, and x22, along with functions for causal discovery.

import numpy as np
import os
import pandas as pd
import lingam

rng = np.random.default_rng(1234)

n = 1000
data = pd.DataFrame({
  'x11': 1 + rng.random(n),
  'x12': 2 + rng.random(n),
  'x22': 3 + rng.random(n)
})

# Function that returns the DirectLiNGAM result as a data frame
def discover_causality(data):
  model = lingam.DirectLiNGAM()
  model.fit(data)

  return pd.DataFrame(
    model.adjacency_matrix_,
    columns=data.columns,
    index=data.columns
  )\
  .reset_index(names = 'node_to')\
  .melt(
    id_vars='node_to',
    var_name='node_from'
  )\
  .pipe(lambda df: df[np.logical_not(np.isclose(df.value, 0, rtol=0, atol=1e-3))])\
  .reindex(columns=['node_from', 'node_to', 'value'])

# Function that writes a mermaid file
def write_mermaid(df, file):
  with open(file, 'w') as f:
    f.write('flowchart LR\n')
    for row in df.itertuples():
      f.write('  {}-->|{:.3f}|{}\n'.format(row.node_from, row.value, row.node_to))

# Output folder
dir = 'be-careful-with-function-forms-in-lingam'
if not os.path.exists(dir):
  os.makedirs(dir)

data_nonlinear_prod = data\
 .assign(
    x21=lambda df: df.x11 + df.x12 + rng.random(n),
    x31=lambda df: df.x21 * df.x22 + rng.random(n),
  )

causality_nonlinear_prod = discover_causality(data_nonlinear_prod)
print(causality_nonlinear_prod)

   node_from node_to     value
3        x11     x21  0.975641
8        x12     x21  0.999905
14       x22     x31  4.524066
19       x21     x31  3.477884

write_mermaid(causality_nonlinear_prod, os.path.join(dir, 'dag_lingam_nonlinear_prod.mmd'))

flowchart LR
  x11-->|0.976|x21
  x12-->|1.000|x21
  x22-->|4.524|x31
  x21-->|3.478|x31

data_nonlinear_power = data\
 .assign(
    x21=lambda df: df.x11 + df.x12 + rng.random(n),
    x31=lambda df: df.x21 ** df.x22 + rng.random(n),
  )

causality_nonlinear_power = discover_causality(data_nonlinear_power)
print(causality_nonlinear_power)

   node_from node_to     value
1        x11     x12 -0.147973
3        x11     x21  0.832946
8        x12     x21  0.798157
17       x21     x22 -0.400541
22       x31     x22  0.002306

write_mermaid(causality_nonlinear_power, os.path.join(dir, 'dag_lingam_nonlinear_power.mmd'))

flowchart LR
  x11-->|-0.148|x12
  x11-->|0.833|x21
  x12-->|0.798|x21
  x21-->|-0.401|x22
  x31-->|0.002|x22

Summary

In this article, we showed that applying LiNGAM to data with nonlinear functions can result in incorrect causal relationships being estimated. Therefore, when applying LiNGAM, it is important to confirm that the causal relationships can be expressed linearly.

On the other hand, it seems rare to be in a situation where causal relationships are unknown, yet it is known that they can be expressed linearly. Therefore, careful identification of causal relationships is required, through means such as verifying linearity after the fact or conducting experiments.

Web scraping for dynamic sites in R

rvest is a popular package for web scraping in R, bur it could not be used for dynamic sites where the contents changes with the operations on the browser.

Therefore, for scraping dynamic sites in R, you needed to use other packages such as RSelenium with rvest and had the following issues.

• When using Selenium, it is troublesome to set up the environment (e.g., you need to download the driver in advance, etc.).

• We couldn’t seamlessly apply rvest functions to HTML from other packages.

In rvest 1.0.4, however, a new read_html_live() function has been added to allow dynamic site scraping with rvest alone. By using read_html_live(), you can automate browser operations with methods such as $click() and $type(). Not only that, but you can seamlessly call rvest functions such as html_elements() and html_attr() with read_html_live().

read_html_live() uses chromote package for Google Chrome automation internally. Therefore to use the function, you need to install Google Chrome (browser) and chromote (R package) beforehand.

Let’s use read_html_live()

From here, let’s use read_html_live() to perform the same process in this RSelenium tutorial.

This tutorial automates the process of collecting information from local TV stations in this site. This process requires a search for U.S. zip codes.

By using read_html_live(), the code to access the site in RSelenium can be rewritten in rvest as follows.

# RSelenium
# Source: https://joshuamccrain.com/tutorials/web_scraping_R_selenium.html
library(RSelenium)

rD <- rsDriver(browser="firefox", port=4545L, verbose=F)
remDr <- rD[["client"]]
remDr$navigate("https://www.fcc.gov/media/engineering/dtvmaps")

⏬

# rvest
library(rvest)
library(tidyverse)

html <- read_html_live("https://www.fcc.gov/media/engineering/dtvmaps")

You can use the $view() method to see the LiveHTML object. You can also select elements on the site by Ctrl+Shift+C and then right-click⏩Copy⏩Copy selector to copy the CSS selector, and use it as an argument to $type() or $click().

# rvest
html$view()

Next, enter the zip code in the center form and click the Go! button. Here, the code in RSelenium can be rewritten in rvest as follows.

# RSelenium
# Source: https://joshuamccrain.com/tutorials/web_scraping_R_selenium.html
zip <- "30308"
remDr$findElement(using = "id", value = "startpoint")$sendKeysToElement(list(zip))
remDr$findElements("id", "btnSub")[[1]]$clickElement()

⏬

# rvest
zip <- "30308"
html$type("#startpoint", zip)
html$click("#btnSub")

Finally, let’s check we got the same data as in the RSelenium tutorial above.

# rvest
html |> 
  html_elements("table.tbl_mapReception") |> 
  insistently(chuck)(3) |> 
  html_table() |> 
  select(!c(1, IA)) |> 
  rename_with(str_to_lower) |> 
  rename(ch_num = `ch#`) |> 
  slice_tail(n = -1) |> 
  filter(callsign != "")

Summary

As above, by using read_html_live() that was added in rvest 1.0.4, we found that seamless scraping of static and dynamic sites is possible with rvest alone. In addition, it should be noted that rvest’s code was simpler than RSelenium’s.

In addition to rvest, a web scraping package called selenider is also being developed for R. It is expected that the development of such packages will make web scraping in R even more convenient!

How do we reduce errors in data preprocessing?

It is said that 80% of the time required for data analysis is spent on preprocessing. Even though preprocessing determines the quality of subsequent data analysis, the more time spent on pre-processing means the probability of making mistakes is also high.

Preprocessing tasks include “extraction,” “aggregation,” and “joining (merging)” of data frames. Among these, data joining is a task that tends to make the code longer and more prone to errors. And since the data frames needed for analysis are rarely combined into one, joining data frames is a widespread process.

Typical mistakes that tend to occur when joining data frames are as follows¹,

• The keys of the data frame to be joined are not “MECE”
• Mistaken keys to join data frames

If you have experienced any mistakes or near-misses in joining data frames, you may be better off relying on some sort of package instead of letting them go unattended. Besides, even if there were no mistakes, we tend to be skeptical about whether we did the right thing in the past.

This article introduces the R dm package, a powerful solution to the problems of errors and skepticism in joining data frames.

Relational data model with dm

The relational data model provided by dm manages the relationships among multiple data on our behalf.

This article describes the use and advantages of the relational data model provided by dm. the Star Wars data set provided by the repurrrsive package. For this purpose, let’s use the Star Wars dataset provided by the repurrrsive package. tidyverse, dm, and repurrrsive packages must be pre-loaded.

library(tidyverse)
library(dm)

Warning: package 'dm' was built under R version 4.6.1

library(repurrrsive)

Warning: package 'repurrrsive' was built under R version 4.6.1

The Star Wars dataset provided by repurrrsive includes the followings².

data(package = "repurrrsive") |> 
  chuck("results") |> 
  as_tibble() |> 
  filter(str_starts(Item, "sw_")) |> 
  pull(Item)

[1] "sw_films"     "sw_people"    "sw_planets"   "sw_species"   "sw_starships"
[6] "sw_vehicles" 

This article will illustrate the use of the relational data model through the following two analytical examples. These examples require dealing with relationships among multiple data sets.

1. Basic: Building a relational data model with dm
2. Application: Extending the model and validating keys with dm

films <- tibble(film = sw_films) |> 
  unnest_wider(film) |> 
  select(url, title, characters)
people <- tibble(person = sw_people) |>
  unnest_wider(person) |> 
  select(url, name, homeworld, species)
planets <- tibble(planet = sw_planets) |>
  unnest_wider(planet) |> 
  select(url, name)

films

people

planets

flowchart TB
  films.characters --> people.url
  people.homeworld --> planets.url
  subgraph films
    films.url[url]
    films.title[title]
    films.characters[List of characters] 
  end
  subgraph people
    people.url[url]
    people.name[name]
    people.homeworld[homeworld]
  end
  subgraph planets
    planets.url[url]
    planets.name[name]
  end

flowchart TB
  films_x_characters.url --> films.url
  films_x_characters.characters ---> people.url
  people.homeworld --> planets.url
  subgraph films_x_characters
    films_x_characters.url[url]
    films_x_characters.characters[characters]
  end
  subgraph films
    films.url[url]
    films.title[title]
  end
  subgraph people
    people.url[url]
    people.name[name]
    people.homeworld[homeworld]
  end
  subgraph planets
    planets.url[url]
    planets.name[name]
  end

# Create films_x_characters and remove characters column from films
films_x_characters <- films |> 
  select(url, characters) |> 
  unnest_longer(characters)
films <- films |> 
  select(!characters)

films_x_characters

dm_starwars_1 <- dm(films, people, planets, films_x_characters) |> 
  
  # 1. Add primary keys
  dm_add_pk(films, url) |>
  dm_add_pk(people, url) |>
  dm_add_pk(planets, url) |>
  dm_add_pk(films_x_characters, c(url, characters)) |>
  
  # 2. Add foreign keys
  dm_add_fk(films_x_characters, url, films) |> 
  dm_add_fk(films_x_characters, characters, people) |>
  dm_add_fk(people, homeworld, planets) 

dm_starwars_1

── Metadata ────────────────────────────────────────────────────────────────────
Tables: `films`, `people`, `planets`, `films_x_characters`
Columns: 10
Primary keys: 4
Foreign keys: 3

dm_draw(dm_starwars_1)

data_films_x_characters_1 <- dm_starwars_1 |> 
  dm_flatten_to_tbl(films_x_characters,
                    .recursive = TRUE) 

Renaming ambiguous columns: %>%
  dm_rename(people, name.people = name) %>%
  dm_rename(planets, name.planets = name)

data_films_x_characters_1

data_films_x_characters_1 |> 
  mutate(name.planets = fct_lump_n(name.planets, 7,
                                   ties.method = "first") |> 
           fct_relevel("Other", 
                       after = Inf)) |> 
  count(title, name.planets) |> 
  mutate(prop = n / sum(n),
         .by = title,
         .keep = "unused") |> 
  ggplot(aes(fct_rev(title), prop,
             fill = name.planets)) +
  geom_col(position = position_stack(reverse = TRUE)) +
  geom_text(aes(label = if_else(prop < 5e-2, 
                                "",
                                scales::label_percent(accuracy = 1)(prop))),
            position = position_stack(vjust = 0.5,
                                      reverse = TRUE)) +
  scale_x_discrete("Title") +
  scale_y_continuous("Composition of the characters' home planets",
                     labels = scales::percent) +
  scale_fill_brewer("Planet Name",
                    palette = "Set2") +
  coord_flip() +
  theme(legend.position = "bottom") +
  guides(fill = guide_legend(nrow = 2,
                             byrow = TRUE))

species <- tibble(species = sw_species) |> 
  unnest_wider(species) |> 
  select(url, name)

species

dm_starwars_2 <- dm_starwars_1 |> 
  dm(species) |> 
  dm_add_pk(species, url) |> 
  dm_add_fk(people, species, species)

dm_draw(dm_starwars_2)

dm_starwars_2_wrong_data <- dm_starwars_1 |> 
  dm(species = species |> 
       slice(-1)) |> 
  dm_add_pk(species, url) |> 
  dm_add_fk(people, species, species)

dm_starwars_2_wrong_pk <- dm_starwars_1 |> 
  dm(species) |> 
  dm_add_pk(species, name) |> 
  dm_add_fk(people, species, species)

print(dm_examine_constraints(dm_starwars_2))

ℹ All constraints satisfied.

print(dm_examine_constraints(dm_starwars_2_wrong_data))

! Unsatisfied constraints:

• Table `people`: foreign key `species` into table `species`: values of `people$species` not in `species$url`: http://swapi.co/api/species/5/ (1)

print(dm_examine_constraints(dm_starwars_2_wrong_pk))

! Unsatisfied constraints:

• Table `people`: foreign key `species` into table `species`: values of `people$species` not in `species$name`: http://swapi.co/api/species/1/ (35), http://swapi.co/api/species/2/ (5), http://swapi.co/api/species/12/ (3), http://swapi.co/api/species/15/ (2), http://swapi.co/api/species/22/ (2), …

dm_starwars_2 |> 
  dm_flatten_to_tbl(films_x_characters,
                    .recursive = TRUE) |> 
  mutate(name.species = name.species |> 
           fct_na_value_to_level("Other") |> 
           fct_lump_n(7,
                      ties.method = "first") |> 
           fct_relevel("Other", 
                       after = Inf)) |> 
  count(title, name.species) |> 
  mutate(prop = n / sum(n),
         .by = title,
         .keep = "unused") |> 
  ggplot(aes(fct_rev(title), prop,
             fill = name.species)) +
  geom_col(position = position_stack(reverse = TRUE)) +
  geom_text(aes(label = if_else(prop < 5e-2, 
                                "",
                                scales::label_percent(accuracy = 1)(prop))),
            position = position_stack(vjust = 0.5,
                                      reverse = TRUE)) +
  scale_x_discrete("Title") +
  scale_y_continuous("Composition of the characters' races",
                     labels = scales::percent) +
  scale_fill_brewer("Species name",
                    palette = "Set2") +
  coord_flip() +
  theme(legend.position = "bottom") +
  guides(fill = guide_legend(nrow = 2,
                             byrow = TRUE))

Summary

In this article, we have shown how to build a relational data model using dm. Once a relational data model is built using dm, it is no longer necessary to manage relationships among data by oneself, and data can be automatically joined using dm_flatten_to_tbl(). In addition, dm provides other useful functions to enhance the quality of data preprocessing, such as adding data to the model with dm() and checking key constraints with dm_examine_constraints().

References

• dm package site
• Preprocessing Compendium [Practical SQL/R/Python techniques for data analysis] (in Japanese)
• starwarsdb
  • Star Wars relational data model available for download from CRAN

Introduction

I recently learned that the integrate() function in R’s stats package¹ can perform numerical integration of one-dimensional functions. So in this article, referring to this article, I tried calculating the area of a circle using integration.

A function to draw a semicircle

A function that draws a semicircle of radius can be expressed as Equation 1. Written in R, this becomes the semicircle() function.

semicircle <- function(x, radius) {
  sqrt(radius^2 - x^2)
}

Let’s use the semicircle() function we implemented to draw a semicircle with radius .

radius <- 5
curve(semicircle(x, radius), -radius, radius,
      asp = 1) # Set the aspect ratio to 1:1

Calculating the area of a circle with numerical integration

Next, let’s use the stats::integrate() function to numerically integrate the semicircle() function we just wrote. For radius , we can confirm that the integral is approximately equal to the area of a semicircle, .

# Set the radius to 5
radius <- 5
integrate(semicircle, -radius, radius, # Integrate over the range from -radius to radius
          radius = radius)

39.26991 with absolute error < 2.5e-08

pi * 5^2 / 2

[1] 39.26991

Therefore, we can write circle_area_approx(), which approximately computes the area of a circle, as follows (the result of the numerical integration is stored in the value element of the return value of stats::integrate()).

circle_area_approx <- function(radius) {
  out <- integrate(semicircle, -radius, radius,
                   radius = radius)
  out$value * 2
}

circle_area_approx(5)

[1] 78.53982

Finally, let’s compare the approximate values from circle_area_approx() with the theoretical values from circle_area_true() () over the range .

The calculation confirms that the approximate and theoretical circle areas are nearly equal.

circle_area_true <- function(radius) {
  pi * radius ^ 2
}

data <- data.frame(radius = 1:10)
data$circle_area_approx <- sapply(data$radius, circle_area_approx)
data$circle_area_true <- sapply(data$radius, circle_area_true)
knitr::kable(data)

Conclusion

We have seen that the stats::integrate() function makes it easy to perform numerical integration of one-dimensional functions.

# OK
integrate(dnorm, -Inf, Inf)

1 with absolute error < 9.4e-05

# Not OK
integrate(dnorm, -1e6, 1e6)

0 with absolute error < 0

Talk Overview

At the LT (Lightning Talk) session of the 108th Tokyo.R Study Meetup (#TokyoR), I introduced the jpstat package, an R package for using the e-Stat API¹.

LT stands for Lightning Talks, which are short presentations. At Tokyo.R, each speaker was given 5 minutes.

The presentation slides from the day are available here.

About Creating the Slides

I have used Quarto for things like GitHub READMEs and building websites, but this was my first time trying to create slides with it.

Referring to the following pages, I tried making a trial slide deck to introduce my own jpstat package, and found that it was surprisingly easy to create slides, so I decided to go ahead and present it at the R study meetup.

• https://quarto.org/docs/presentations/

• https://quarto.org/docs/presentations/revealjs/

The source code is available here. The Quarto content is written in this qmd (Quarto Markdown) file.

Below, I’ll introduce the features I found especially useful when creating slides with Quarto and reveal.js.

```{r}
#| echo: true
#| code-line-numbers: "2-3"

estat(statsDataId = "0003343671") |>
  activate(cat01) |>
  filter(str_detect(name, "チョコレート"))
```

---
title: "e-Stat🤝R"
subtitle: "Tokyo.R #108"
author: UchidaMizuki
date: "2023-09-02"
footer: <https://github.com/UchidaMizuki/jpstat>
format:
  revealjs
---

Summary

I found that Quarto makes it easy to create presentation materials that are just the right fit for a Lightning Talk.

By the way, I had already been publishing pages created with Quarto to GitHub Pages, and this time I was able to easily publish the reveal.js slides as well by using the Publish Command².

What is Bayes’ theorem?

In this article, I would like to explain the importance of Bayes’ theorem, one of the most famous theorems in statistics, using the PCR testing that became widespread during the COVID-19 pandemic as an example.

Bayes’ theorem can be expressed as shown in Equation 1.

Equation 1 shows the following:

• The probability that an observed result was caused by
• is proportional () to the product of the probability that cause occurs and the probability that result occurs given cause

Let’s use a more familiar example. Suppose we define:

• Cause : whether or not someone is infected with COVID-19
• Result : the diagnostic result from a PCR test or similar test

With this in mind, Equation 1 can be rewritten as Equation 2.

Why is Bayes’ theorem important?

Let’s think about the importance of Bayes’ theorem based on Equation 2. In fact, all three probabilities that appear in the version of Bayes’ theorem shown in Equation 2 correspond to very important indicators (see the table below). In other words, Equation 2 tells us that even if a test’s accuracy (sensitivity and specificity) is high, the positive predictive value will be low if the pre-test probability is low.

Probability	Corresponding indicator in the medical field
	Post-test probability: called the posterior probability in statistics Positive predictive value (PPV): probability of actually being infected when diagnosed positive Negative predictive value (NPV): probability of actually being uninfected when diagnosed negative
	Sensitivity: probability that an infected person is diagnosed positive ↔︎ related to false negatives Specificity: probability that an uninfected person is diagnosed negative ↔︎ related to false positives
	Pre-test probability: called the prior probability in statistics The proportion of infected individuals among those tested

For example, let’s consider the following situation:

• Both sensitivity and specificity are 99% (false negatives and false positives each occur with a 1% probability)
• The pre-test probability is 1% (1 out of every 100 people tested is infected, and the remaining 99 are uninfected)

In this case, the probability of being infected given a positive diagnosis, , and the probability of being uninfected given a positive diagnosis, , are given by Equation 3.

From Equation 3, we can see that and are equal, meaning the positive predictive value is 50%. In other words, among the people tested who receive a positive diagnosis, only 1 in 2 is actually infected.

In this way, using Bayes’ theorem reveals an important relationship: even if a test’s accuracy (sensitivity and specificity) is high, the positive predictive value will be low if the pre-test probability is low.

Summary

Using the PCR testing that became widespread during the COVID-19 pandemic as an example, we explained the importance of Bayes’ theorem.

If you are interested in more realistic calculation examples, we also recommend reading this column published by the Statistics Bureau (in Japanese).

What Is the “Vote-Value Disparity”?

Since it’s currently election season¹, I’d like to use open data to quantify the “vote-value disparity,” an issue that often comes up.

The “vote-value disparity” usually refers to the fact that the number of eligible voters per elected representative differs by region (electoral district) — in other words, the number of votes needed to elect one representative differs by region. For example, in the 2022 House of Councillors election, the “vote-value disparity” is said to have reached a maximum of 3.03 times².

Currently, urban and rural areas in Japan are said to have the relationship shown in the table below, and it has been pointed out that the “vote-value disparity” causes problems such as reduced economic efficiency — for example, new Shinkansen lines being built in rural areas while Tokyo’s commuter rush remains unresolved³.

On the other hand, rural social issues are expected to become even more serious in the future due to factors such as the continued concentration of population in Tokyo. For this reason, there are also concerns that making the “value of a vote” completely equal could actually work against — or “disadvantage” — rural areas.

As this shows, correcting the “vote-value disparity” is by no means a simple task, but it can be said that efforts toward correcting it need to continue.

Quantifying the Generational “Vote-Value Disparity”

The regional “vote-value disparity” is commonly quantified as being some number of times larger (relative to urban areas), but the generational “vote-value disparity” does not seem to have been quantified much so far.

A simple approach to quantification would be to divide the population of each age group by some reference population. However, this kind of method fails to account for the fact that people pass away as they age, and would end up producing an evaluation along the lines of “the population is small, so the value of a vote for those aged 100 and over is low.”

So, I’ll try to quantify the generational “vote-value disparity” using the 2020 Population Census and the 2020 Life Tables. A life table is “a set of indicators, such as the probability that a person of a given age will die within one year, calculated under the assumption that the mortality conditions observed over a certain period will not change in the future”⁷.

Please note that the generational “vote-value disparity” shown below is merely a simplified estimate based on open data.

library(tidyverse)
library(fs)
library(arrow)
library(readxl)
library(jpstat)

theme_set(theme_light())

dir_create("quantify-vote-disparity-between-generations")

# Using the jpstat package to download the 2020 Population Census data
if (!file_exists("quantify-vote-disparity-between-generations/pop_2020.parquet")) {
  # Note: the jpstat package requires an API key because it uses the e-Stat API
  # Run Sys.setenv(ESTAT_API_KEY = "your appId") beforehand
  census_2020 <- estat(statsDataId = "https://www.e-stat.go.jp/dbview?sid=0003445139")

  pop_2020 <- census_2020 |>
    activate(tab) |>
    select() |>

    activate(cat01) |>
    filter(name == "うち日本人") |>
    select() |>

    activate(cat02) |>
    rekey("sex") |>
    filter(name %in% c("男", "女")) |>
    select(name) |>

    activate(cat03) |>
    rekey("age") |>
    select(name) |>

    activate(area) |>
    filter(name == "全国") |>
    select() |>

    activate(time) |>
    select() |>

    collect(n = "pop")

  pop_2020 <- pop_2020 |>
    filter(str_detect(age_name, "^\\d+歳$") | age_name == "100歳以上") |>
    mutate(sex = as_factor(sex_name),
           age = case_when(str_detect(age_name, "^\\d+歳$") ~ age_name |>
                             str_extract("\\d+"),
                           age_name == "100歳以上" ~ "100--Inf") |>
             as_factor(),
           pop = parse_number(pop),
           .keep = "unused") |>
    relocate(sex, age, pop)

  write_parquet(pop_2020, "quantify-vote-disparity-between-generations/pop_2020.parquet")
}

# 23rd Life Tables (male)
file_lifetable_male_2020 <- "quantify-vote-disparity-between-generations/lifetable_male_2020.xlsx"
if (!file_exists(file_lifetable_male_2020)) {
  curl::curl_download("https://www.e-stat.go.jp/stat-search/file-download?statInfId=000032173232&fileKind=0", file_lifetable_male_2020)
}

# 23rd Life Tables (female)
file_lifetable_female_2020 <- "quantify-vote-disparity-between-generations/lifetable_female_2020.xlsx"
if (!file_exists(file_lifetable_female_2020)) {
  curl::curl_download("https://www.e-stat.go.jp/stat-search/file-download?statInfId=000032173233&fileKind=0", file_lifetable_female_2020)
}

col_names_lifetable <- read_excel(file_lifetable_male_2020,
                        range = "B3:J5",
                        col_names = as.character(1:9)) |>
  t() |>
  as_tibble(.name_repair = \(x) c("col_name_1", "col_name_2", "col_name_3")) |>
  unite("col_name", starts_with("col_name"),
        na.rm = TRUE) |>
  mutate(col_name = col_name |>
           str_remove_all("\\s")) |>
  pull(col_name)

range_lifetable <- "B6:J127"

lifetable_male_2020 <- read_excel(file_lifetable_male_2020,
                                  range = range_lifetable,
                                  col_names = col_names_lifetable)

lifetable_female_2020 <- read_excel(file_lifetable_female_2020,
                                    range = range_lifetable,
                                    col_names = col_names_lifetable)

static_pop_2020 <- list(男 = lifetable_male_2020,
                        女 = lifetable_female_2020) |>
  bind_rows(.id = "sex") |>
  rename(age = 年齢_x,
         static_pop = 定常人口_nLx_人) |>
  select(sex, age, static_pop) |>
  filter(str_ends(age, "年")) |>
  mutate(sex = as_factor(sex),
         age = age |>
           str_extract("^\\d+") |>
           parse_integer(),
         # Aggregate ages 100 and over
         age = if_else(age >= 100,
                       "100--Inf",
                       as.character(age)) |>
           as_factor()) |>
  summarise(static_pop = sum(static_pop),
            .by = c(sex, age))

write_parquet(static_pop_2020, "quantify-vote-disparity-between-generations/static_pop_2020.parquet")

# Replace ages 100 and over with the number 100
as_integer_age <- function(age) {
  if_else(age == "100--Inf",
          100,
          parse_integer(as.character(age),
                        na = "100--Inf"))
}

pop_2020 <- read_parquet("quantify-vote-disparity-between-generations/pop_2020.parquet") |>
  mutate(age = as_integer_age(age))
static_pop_2020 <- read_parquet("quantify-vote-disparity-between-generations/static_pop_2020.parquet") |>
  mutate(age = as_integer_age(age))

ratio_pop_static_pop <- static_pop_2020 |>
  filter(age == 0) |>
  select(!age) |>
  left_join(pop_2020 |>
              filter(age == 0) |>
              select(!age),
            by = join_by(sex)) |>
  mutate(ratio_pop_static_pop = pop / static_pop,
         .keep = "unused")

static_pop_2020 <- static_pop_2020 |>
  left_join(ratio_pop_static_pop,
            by = join_by(sex)) |>
  mutate(pop = static_pop * ratio_pop_static_pop,
         .keep = "unused")

pop_2020 |>
  mutate(pop = if_else(sex == "男",
                       -pop,
                       pop)) |>
  ggplot(aes(age, pop,
             fill = sex)) +
  geom_col() +
  geom_line(data = static_pop_2020 |>
               mutate(pop = if_else(sex == "男",
                                    -pop,
                                    pop)),
            aes(group = sex,
                color = "Stationary population\n(reference)")) +
  scale_x_continuous("Age",
                     breaks = seq(0, 100, 10)) +
  scale_y_continuous("Population [thousands]",
                     labels = \(x) {
                       scales::label_comma(scale = 1e-3)(abs(x))
                     }) +
  scale_fill_manual("Sex",
                    values = c(男 = "cornflowerblue",
                               女 = "lightcoral")) +
  scale_color_manual(NULL,
                     values = c(`Stationary population\n(reference)` = "red")) +
  coord_flip() +
  guides(fill = guide_legend(order = 1),
         color = guide_legend(order = 2))

Summary

Using the open data of the Population Census and the Life Tables, I quantified the generational “vote-value disparity.”

In fact, it’s said that low voter turnout among young people is also a major factor behind the generational “vote-value disparity.” Going forward, it will likely be necessary to deepen the discussion around the generational “vote-value disparity” while also proposing more appealing policies that raise voter turnout among the young.

About this app

I built a web app for working with Japanese grid square (mesh) data using R Shiny.

A grid square is a division of (Japanese) regions into roughly square cells based on longitude and latitude, and it is commonly used as an aggregation unit for statistical data.

The app I built provides some of the functionality of the R package jpgrid. The app offers the following features:

1. Generate grid square data by municipality
2. Generate grid square data from tabular data containing grid code strings
3. Generate grid square data from tabular data containing longitude/latitude

App features

library(jpgrid)
library(tidyverse)

JGD2011 <- 6668

grid_city_2020 |>
  filter(city_name_ja %in% c("千葉市中央区", "千葉市花見川区", "千葉市稲毛区")) |>
  grid_as_sf(crs = 6668) |> 
  ggplot(aes(fill = city_name_ja)) +
  geom_sf() +
  scale_fill_brewer(palette = "Set2")

Conclusion

I introduced a web app for grid square data built with R Shiny.

The jpgrid package used to build this app provides many other features not included in the app. For details, please see here.

For example, there is geometry_to_grid(), which converts geometries into grid squares.

I encourage you to try using the jpgrid package for your grid square data analysis as well.

japan <- rnaturalearth::ne_countries(country = "japan",
                                     scale = "medium",
                                     returnclass = "sf")
grid_japan <- japan |> 
  geometry_to_grid("80km") |> 
  dplyr::first() |> 
  grid_as_sf(crs = sf::st_crs(japan))

japan |> 
  ggplot() +
  geom_sf() +
  geom_sf(data = grid_japan,
          fill = "transparent")

About this article

Referring to the population pyramid transition animation published by the National Institute of Population and Social Security Research (IPSS), I tried creating an animation like the one below using ggplot2 in R.

Getting time-series data from the Population Census

First, let’s get the time-series data on population by sex and 5-year age group from the Population Census, published on e-Stat, using R’s jpstat package.

To use the e-Stat API from the jpstat package, you need to obtain an application ID (appId).

library(tidyverse)
library(jpstat)

# Replace this with your own appId
Sys.setenv(ESTAT_API_KEY = "Your appId")

census <- estat(statsDataId = "https://www.e-stat.go.jp/dbview?sid=0003410380")

pop <- census |>
  activate(tab) |>
  filter(name == "人口") |>
  select() |>

  # Extract sex
  activate(cat01) |>
  rekey("sex") |>
  filter(name %in% c("男", "女")) |>
  select(name) |>

  # Extract age class
  activate(cat02) |>
  rekey("ageclass") |>
  filter(str_detect(name, "^\\d+～\\d+歳$") |
           name == "85歳以上" |
           name == "110歳以上") |>
  select(name) |>

  # Extract year
  activate(time) |>
  rekey("year") |>
  filter(str_detect(name, "^\\d+年$")) |>
  select(name) |>

  # Get e-Stat data
  collect(n = "pop") |>

  rename_with(~ .x |>
                str_remove("_name$")) |>
  mutate(sex = as_factor(sex),
         year = parse_number(year),

         # Get the minimum age for each age class
         age_from = ageclass |>
           str_extract("^\\d+") |>
           stringi::stri_trans_nfkc() |>
           as.integer(),

         # Treat "85歳以上" as the highest age class
         ageclass = case_when(age_from >= 85 ~ "85歳以上",
                              TRUE ~ ageclass) |>
           as_factor(),

         # Add age group
         agegroup = case_when(between(age_from, 0, 10) ~ "Youth population",
                              between(age_from, 15, 60) ~ "Working-age population",
                              between(age_from, 65, 70) ~ "Young-old population",
                              age_from >= 75 ~ "Old-old population") |>
           as_factor(),
         pop = parse_number(pop)) |>

  # Aggregate the "85歳以上" population
  group_by(year, sex, ageclass, agegroup) |>
  summarise(pop = sum(pop),
            .groups = "drop")

The total number of data is 796.

knitr::kable(head(pop))

Creating the population pyramid animation

By using R’s gganimate package, you can turn a ggplot2 graph into an animation.

library(gganimate)

Warning: package 'gganimate' was built under R version 4.6.1

# Data for displaying age groups
agegroup <- pop |>
  group_by(sex, agegroup) |>
  summarise(ageclass = mean(as.integer(ageclass)),
            .groups = "drop") |>
  mutate(hjust = case_when(sex == "男" ~ 1.25,
                           sex == "女" ~ -0.25))

poppyramid <- pop |>

  # Convert male population to negative values to create the population pyramid
  mutate(pop = if_else(sex == "男", -pop, pop)) |>

  ggplot(aes(ageclass, pop,
             group = sex,
             fill = agegroup)) +
  geom_col(show.legend = FALSE) +
  geom_text(data = agegroup,
            aes(label = agegroup,
                hjust = hjust),
            y = 0) +
  scale_x_discrete(NULL) +
  scale_y_continuous("Population [thousands]",

                     # Convert labels to absolute values in thousands
                     labels = purrr::compose(scales::label_comma(scale = 1e-3), abs)) +
  scale_fill_brewer(palette = "Set2") +
  coord_flip() +
  facet_wrap(~ sex,
             scales = "free_x") +
  labs(title = "Year {frame_time %/% 5 * 5}") +
  theme(plot.title = element_text(hjust = 0.5)) +

  # Convert to animation
  transition_time(year)

# Change width and height
animate(poppyramid,
        width = 800,
        height = 600,
        units = "px",
        res = 150,
        renderer = gifski_renderer())

About this article

This article is Day 12 of the “R Advent Calendar 2022”.

Last year marked 150 years since the establishment of government statistics in Japan (Chronology of statistics in the Heisei and Reiwa eras). More recently, it has become possible to browse and download a wide variety of government statistical data through the Portal Site of Official Statistics of Japan (e-Stat).

e-Stat also provides a convenient API (see the usage guide here; please check the terms of use beforehand. Before using the API, you also need to complete user registration).

In this article, I introduce how to use the e-Stat API efficiently with R’s jpstat package.

About e-Stat

e-Stat organizes a wide variety of government statistical databases. Here, let’s take a look at the database on sleep duration from the results of the 2015 National Health and Nutrition Survey.

Opening the database displays a statistical table as shown below, and you can download the data from the “Download” button in the upper right.

Clicking the “Select display items” button in the upper left lets you choose which data items (age group, sex, etc.) to display.

For example, if you want to select age groups, clicking the “Select items” button for age group brings up a screen like the one below, where you can choose the age groups.

After selecting the display items, clicking the “Download” button lets you download only the data for the selected items.

In this way, e-Stat makes it easy to extract and download data. However, if you want to improve the reproducibility of your data-retrieval work or make programmatic data extraction and retrieval more efficient, using the e-Stat API is recommended.

Using the e-Stat API with the jpstat package

To perform, via the e-Stat API, the same data extraction and download process described above for e-Stat, you need to follow steps like these.

1. Retrieve metadata and set parameters: retrieve and select the display item data, and set the API parameters corresponding to the selected items
2. Retrieve statistical data: retrieve the selected data and format it into a table

The jpstat package was developed to carry out this series of tasks efficiently in R¹. The jpstat package can be installed from CRAN.

Here, with the goal of plotting sleep duration by sex and age group, let’s retrieve data from the sleep duration database (2015) introduced above. First, load the required packages.

install.packages("jpstat")

library(tidyverse)
library(jpstat)

# Replace this with your own appId
Sys.setenv(ESTAT_API_KEY = "Your appId")

estat_sleeptime_2015 <- estat(statsDataId = "https://www.e-stat.go.jp/dbview?sid=0003224282")

# View and select the metadata
estat_sleeptime_2015 |>
  activate(cat01) |>
  filter(name != "総数")

# ☐ tab:   表章項目     [2] <code, name, level, unit>
# ☒ cat01: 年齢階級     [6] <code, name, level, parentCode>
# ☐ cat02: 睡眠の質     [8] <code, name, level, parentCode>
# ☐ cat03: 性別         [3] <code, name, level, parentCode>
# ☐ cat04: 平均睡眠時間 [6] <code, name, level, parentCode>
# ☐ time:  時間軸(年次) [1] <code, name, level>
# 
# A tibble: 6 × 5
# Stickers: .estat_rowid
  .estat_rowid code  name      level parentCode
*        <int> <chr> <chr>     <chr> <chr>     
1            2 160   20歳-29歳 2     100       
2            3 170   30歳-39歳 2     100       
3            4 180   40歳-49歳 2     100       
4            5 190   50歳-59歳 2     100       
5            6 210   60歳-69歳 2     100       
6            7 220   70歳以上  2     100       

estat_sleeptime_2015_filtered <- estat_sleeptime_2015 |>

  # Tabulation item
  activate(tab) |>
  filter(name == "人数") |>

  # Age group
  activate(cat01) |>
  filter(name != "総数") |>

  # Sleep quality
  activate(cat02) |>
  filter(name == "総数") |>

  # Sex
  activate(cat03) |>
  filter(name %in% c("男性", "女性"))

data_sleeptime_2015 <- estat_sleeptime_2015_filtered |>

  # Retrieve the data and convert to numeric
  collect(n = "person") |>
  mutate(person = parse_number(person))

The total number of data is 72.

knitr::kable(head(data_sleeptime_2015, 10))

data_sleeptime_2015 <- estat_sleeptime_2015 |>
  activate(tab) |>
  filter(name == "人数") |>
  select() |>

  activate(cat01) |>
  rekey("ageclass") |>
  filter(name != "総数") |>
  select(name) |>

  activate(cat02) |>
  filter(name == "総数") |>
  select() |>

  activate(cat03) |>
  rekey("sex") |>
  filter(name %in% c("男性", "女性")) |>
  select(name) |>

  activate(cat04) |>
  rekey("sleeptime") |>
  select(name) |>

  activate(time) |>
  select() |>

  collect(n = "person") |>
  mutate(person = parse_number(person))

The total number of data is 72.

knitr::kable(head(data_sleeptime_2015, 10))

data_sleeptime_2015 |>
  mutate(ageclass_name = as_factor(ageclass_name),
         sex_name = as_factor(sex_name),
         sleeptime_name = as_factor(sleeptime_name)) |>
  group_by(ageclass_name, sex_name) |>
  mutate(prop = person / sum(person)) |>
  ungroup() |>
  ggplot(aes(ageclass_name, prop,
             fill = fct_rev(sleeptime_name))) +
  geom_col() +
  geom_text(aes(label = if_else(prop > 0.05,
                                scales::label_percent(accuracy = 1)(prop),
                                "")),
            position = position_stack(vjust = 0.5)) +
  scale_x_discrete("Age group") +
  scale_y_continuous("Proportion",
                     labels = scales::label_percent(accuracy = 1)) +
  scale_fill_brewer("Sleep duration",
                    palette = "Spectral") +
  facet_wrap(~ sex_name) +
  guides(x = guide_axis(n.dodge = 2))

Summary

In this article, I introduced how to efficiently retrieve Japanese statistical data using the e-Stat API and the jpstat package.

Retrieving statistical data in R improves the reproducibility and efficiency of your work. The jpstat package is also convenient because it lets you retrieve and reshape data at the same time. I encourage you to give it a try.

Preparing sample data

To compare CSV and Parquet, let’s first prepare sample data typical of data analysis. This time, we’ll create sample data from who (World Health Organization (WHO) tuberculosis data) provided by the tidyr package.

In recent years, the concept of tidy data has become widespread in data analysis. Tidy data is data in which each variable forms a single column, and each observation (value) forms a single row.

So, can who be considered tidy data? who has many columns such as "new_sp_m014" through "newrel_f65", but each of these columns actually contains multiple variables, such as the diagnosis result (sp or sel), gender (m or f), and age group (014 or 65). Therefore, who is not tidy data. So, following this article, we’ll transform it into who_longer, which is tidy data.

In data analysis, who_longer, being tidy data, is easier to work with than who. However, we can see that who_longer (about 400,000 rows) has roughly 50 times more rows than who (about 7,000 rows). Therefore, storing data like who_longer, which is tidy data, as a text file such as CSV results in a large increase in file size.

In this way, we can see that while tidy data is well-suited for data analysis, it is not well-suited for storage as a text file like CSV. However, this data storage problem can be solved by using Parquet.

Here, let’s compare who, which is not tidy data, with who_longer, which is tidy data.

library(tidyverse)
library(fs)

levels_gender <- c("f", "m")
levels_age <- c("014", "1524", "2534", "3544", "4554", "5564", "65")

who_longer <- who |> 
  pivot_longer(cols = new_sp_m014:newrel_f65,
               names_to = c("diagnosis", "gender", "age"), 
               names_pattern = "new_?(.*)_(.)(.*)",
               names_transform = list(gender = ~ .x |> 
                                        readr::parse_factor(levels = levels_gender),
                                      age = ~ .x |> 
                                        readr::parse_factor(levels = levels_age,
                                                            ordered = TRUE)),
               values_to = "count")

# Before tidying
print(who, n = 5)

# A tibble: 7,240 × 60
  country   iso2  iso3   year new_sp_m014 new_sp_m1524 new_sp_m2534 new_sp_m3544
  <chr>     <chr> <chr> <dbl>       <dbl>        <dbl>        <dbl>        <dbl>
1 Afghanis… AF    AFG    1980          NA           NA           NA           NA
2 Afghanis… AF    AFG    1981          NA           NA           NA           NA
3 Afghanis… AF    AFG    1982          NA           NA           NA           NA
4 Afghanis… AF    AFG    1983          NA           NA           NA           NA
5 Afghanis… AF    AFG    1984          NA           NA           NA           NA
# ℹ 7,235 more rows
# ℹ 52 more variables: new_sp_m4554 <dbl>, new_sp_m5564 <dbl>,
#   new_sp_m65 <dbl>, new_sp_f014 <dbl>, new_sp_f1524 <dbl>,
#   new_sp_f2534 <dbl>, new_sp_f3544 <dbl>, new_sp_f4554 <dbl>,
#   new_sp_f5564 <dbl>, new_sp_f65 <dbl>, new_sn_m014 <dbl>,
#   new_sn_m1524 <dbl>, new_sn_m2534 <dbl>, new_sn_m3544 <dbl>,
#   new_sn_m4554 <dbl>, new_sn_m5564 <dbl>, new_sn_m65 <dbl>, …

# After tidying
print(who_longer, n = 5)

# A tibble: 405,440 × 8
  country     iso2  iso3   year diagnosis gender age   count
  <chr>       <chr> <chr> <dbl> <chr>     <fct>  <ord> <dbl>
1 Afghanistan AF    AFG    1980 sp        m      014      NA
2 Afghanistan AF    AFG    1980 sp        m      1524     NA
3 Afghanistan AF    AFG    1980 sp        m      2534     NA
4 Afghanistan AF    AFG    1980 sp        m      3544     NA
5 Afghanistan AF    AFG    1980 sp        m      4554     NA
# ℹ 405,435 more rows

Saving CSV and Parquet files

In R, you can save CSV files with write_csv(). Similarly, you can save Parquet files with write_parquet() from the arrow package. Let’s try saving who_longer as both CSV and Parquet.

As you can see, both CSV and Parquet make it easy to save data.

library(arrow)

# Save as CSV
write_csv(who_longer, "who_longer.csv")

# Save as Parquet
write_parquet(who_longer, "who_longer.parquet")

Advantages of Parquet compared to CSV

From here, we’ll compare the saved CSV and Parquet files of who_longer and introduce the advantages of Parquet over CSV.

# CSV
file_size("who_longer.csv")

14.1M

# Parquet
file_size("who_longer.parquet")

161K

units::set_units(file_size("who_longer.parquet") / file_size("who_longer.csv")) |> 
  units::set_units(`%`)

1.116534 [%]

# Read CSV
read_csv("who_longer.csv",
         col_types = cols(.default = "c",
                          year = "i",
                          count = "i"))

# Read Parquet
read_parquet("who_longer.parquet")

read_parquet("who_longer.parquet",
             as_data_frame = FALSE) |> 
  filter(country == "Japan",
         !is.na(count)) |> 
  group_by(country, year, diagnosis) |> 
  summarise(count = sum(count),
            .groups = "drop") |> 
  collect()

# A tibble: 33 × 4
   country  year diagnosis count
   <chr>   <dbl> <chr>     <dbl>
 1 Japan    1995 sp        14367
 2 Japan    1996 sp        12867
 3 Japan    1997 sp        13571
 4 Japan    1998 sp        11935
 5 Japan    2001 sp        11408
 6 Japan    2002 sp        10807
 7 Japan    2003 sp        10843
 8 Japan    2004 sp        10471
 9 Japan    1999 sp        12909
10 Japan    2000 sp        11853
# ℹ 23 more rows

dir_create("who_longer_byage")
who_longer |> 
  group_by(age) |> 
  group_walk(~ .x |> 
               write_parquet(str_glue("who_longer_byage/who_longer_{.y$age}.parquet")),
  .keep = TRUE)

open_dataset("who_longer_byage") |> 
  filter(country == "Japan",
         !is.na(count)) |> 
  group_by(country, year, diagnosis) |> 
  summarise(count = sum(count),
            .groups = "drop") |> 
  collect()

# A tibble: 33 × 4
   country  year diagnosis count
   <chr>   <dbl> <chr>     <dbl>
 1 Japan    1995 sp        14367
 2 Japan    1996 sp        12867
 3 Japan    1997 sp        13571
 4 Japan    1998 sp        11935
 5 Japan    2001 sp        11408
 6 Japan    2002 sp        10807
 7 Japan    2003 sp        10843
 8 Japan    2004 sp        10471
 9 Japan    2005 sp        10931
10 Japan    2006 sp        10159
# ℹ 23 more rows

import pandas as pd

pd.read_parquet('who_longer.parquet')

            country iso2 iso3    year diagnosis gender   age   count
0       Afghanistan   AF  AFG  1980.0        sp      m   014     NaN
1       Afghanistan   AF  AFG  1980.0        sp      m  1524     NaN
2       Afghanistan   AF  AFG  1980.0        sp      m  2534     NaN
3       Afghanistan   AF  AFG  1980.0        sp      m  3544     NaN
4       Afghanistan   AF  AFG  1980.0        sp      m  4554     NaN
...             ...  ...  ...     ...       ...    ...   ...     ...
405435     Zimbabwe   ZW  ZWE  2013.0       rel      f  2534  4649.0
405436     Zimbabwe   ZW  ZWE  2013.0       rel      f  3544  3526.0
405437     Zimbabwe   ZW  ZWE  2013.0       rel      f  4554  1453.0
405438     Zimbabwe   ZW  ZWE  2013.0       rel      f  5564   811.0
405439     Zimbabwe   ZW  ZWE  2013.0       rel      f    65   725.0

[405440 rows x 8 columns]

Summary

So far, we’ve introduced the advantages of Parquet available in both R and Python. Parquet is well-suited for storing and aggregating tidy data, which has become widespread in data analysis in recent years.

In addition, packages such as sfarrow, which can save data from the sf package (used for handling geographic data) as Parquet, have also recently appeared.

By using Parquet instead of CSV, data analysis is expected to become even easier.