R Analystatistics Sweden

Suggestion for limiting the boundaries for causal effects

Sun, 24 Oct 2021 00:00:00 +0000

Congratulations to Joshua Angrist and Guido Imbens for the Nobel Prize for their work with causality. This post will also be about causality, although not from the work of Angrist or Imbens. A year ago I read The Book of Why by Judea Pearl and Dana MacKenzie. The Book of Why states that you can make causal conclusions from observational data if you know the directed acyclical graph (DAG) of the processes that has created the data. The Book of Why also states that you can not create the DAG based on data alone, i.e. you can not have the data as an input to an algorithm and get the DAG and its causal implications as output. The Book of Why also explains that Judea Pearl has studied Bayesian networks before he began his work with DAGs and causality. I hypothesise that some DAGS are more probable than other DAGs based on the statistics of the data. I am examining if there are ways to get boundaries of the causal effects that variables can have on each other within a limited system. I will use structure learning algorithms for Bayesian networks. I will take no regard to unmeasured confounders. This work is ongoing and the results are as is. I will use data from Statistics Sweden, for more information about the data see my previous posts.

Statistics Sweden use NUTS (Nomenclature des Unités Territoriales Statistiques), which is the EU’s hierarchical regional division, to specify the regions.

First, define libraries and functions.

library(tidyverse)

## -- Attaching packages --------------------------------------- tidyverse 1.3.1 --

## v ggplot2 3.3.5     v purrr   0.3.4
## v tibble  3.1.5     v dplyr   1.0.7
## v tidyr   1.1.4     v stringr 1.4.0
## v readr   2.0.2     v forcats 0.5.1

## Warning: package 'ggplot2' was built under R version 4.0.5

## Warning: package 'tibble' was built under R version 4.0.5

## Warning: package 'tidyr' was built under R version 4.0.5

## Warning: package 'readr' was built under R version 4.0.5

## Warning: package 'dplyr' was built under R version 4.0.5

## Warning: package 'forcats' was built under R version 4.0.3

## -- Conflicts ------------------------------------------ tidyverse_conflicts() --
## x dplyr::filter() masks stats::filter()
## x dplyr::lag()    masks stats::lag()

library(gtools)

## Warning: package 'gtools' was built under R version 4.0.5

library(pcalg)

## Warning: package 'pcalg' was built under R version 4.0.5

library(imputeMissings)

## Warning: package 'imputeMissings' was built under R version 4.0.5

## 
## Attaching package: 'imputeMissings'

## The following object is masked from 'package:dplyr':
## 
##     compute

library(bnlearn)

## Warning: package 'bnlearn' was built under R version 4.0.5

## 
## Attaching package: 'bnlearn'

## The following object is masked from 'package:imputeMissings':
## 
##     impute

## The following objects are masked from 'package:pcalg':
## 
##     dsep, pdag2dag, shd, skeleton

library(dagitty)

## Warning: package 'dagitty' was built under R version 4.0.4

## 
## Attaching package: 'dagitty'

## The following objects are masked from 'package:bnlearn':
## 
##     ancestors, children, descendants, parents, spouses

## The following object is masked from 'package:pcalg':
## 
##     randomDAG

library(AER)

## Warning: package 'AER' was built under R version 4.0.5

## Loading required package: car

## Warning: package 'car' was built under R version 4.0.5

## Loading required package: carData

## Warning: package 'carData' was built under R version 4.0.3

## 
## Attaching package: 'car'

## The following object is masked from 'package:gtools':
## 
##     logit

## The following object is masked from 'package:dplyr':
## 
##     recode

## The following object is masked from 'package:purrr':
## 
##     some

## Loading required package: lmtest

## Warning: package 'lmtest' was built under R version 4.0.4

## Loading required package: zoo

## Warning: package 'zoo' was built under R version 4.0.5

## 
## Attaching package: 'zoo'

## The following objects are masked from 'package:base':
## 
##     as.Date, as.Date.numeric

## Loading required package: sandwich

## Warning: package 'sandwich' was built under R version 4.0.5

## Loading required package: survival

## Warning: package 'survival' was built under R version 4.0.5

library(lavaan)

## Warning: package 'lavaan' was built under R version 4.0.5

## This is lavaan 0.6-9
## lavaan is FREE software! Please report any bugs.

library(semPlot)

## Warning: package 'semPlot' was built under R version 4.0.3

library(psych)

## Warning: package 'psych' was built under R version 4.0.5

## 
## Attaching package: 'psych'

## The following object is masked from 'package:lavaan':
## 
##     cor2cov

## The following object is masked from 'package:car':
## 
##     logit

## The following object is masked from 'package:gtools':
## 
##     logit

## The following objects are masked from 'package:ggplot2':
## 
##     %+%, alpha

readfile <- function (file1){read_csv (file1, col_types = cols(), locale = readr::locale (encoding = "latin1"), na = c("..", "NA")) %>%
  gather (starts_with("19"), starts_with("20"), key = "year", value = groupsize) %>%
  drop_na() %>%
  mutate (year_n = parse_number (year))
}

perc_women <- function(x){  
  ifelse (length(x) == 2, x[2] / (x[1] + x[2]), NA)
} 

nuts <- read.csv("nuts.csv") %>%
  mutate(NUTS2_sh = substr(NUTS2, 3, 4))

nuts %>% 
  distinct (NUTS2_en) %>%
  knitr::kable(
    booktabs = TRUE,
    caption = 'Nomenclature des Unités Territoriales Statistiques (NUTS)')

Table 1: Nomenclature des Unités Territoriales Statistiques (NUTS)
NUTS2_en
SE11 Stockholm
SE12 East-Central Sweden
SE21 Småland and islands
SE22 South Sweden
SE23 West Sweden
SE31 North-Central Sweden
SE32 Central Norrland
SE33 Upper Norrland

# normalize data
tonormest <- function(tablearg){
  norm_recipe <- recipes::recipe( ~ ., data = tablearg) %>%
     recipes::step_normalize(recipes::all_numeric())

  prepare <- recipes::prep(norm_recipe, training = tablearg)

  return (recipes::bake(prepare, new_data = tablearg))
}

# not in set
`%nin%` = Negate(`%in%`)

# create a set of arcs not allowed in model
createblacklist <- function(coln, exogenous, endogenous = NULL){
  rbind(
    expand.grid(endogenous, coln[coln %nin% endogenous]),
    expand.grid(coln[coln %nin% exogenous], exogenous))
}

# list of models in bnlearn to evaluate
bnmodels <- list(
  h2pc = function(x, blacklist = blacklist) bnlearn::h2pc(x, blacklist = blacklist),
  hpc = function(x, blacklist = blacklist) bnlearn::hpc(x, blacklist = blacklist),
  fast.iamb = function(x, blacklist = blacklist) bnlearn::fast.iamb(x, blacklist = blacklist),
  inter.iamb = function(x, blacklist = blacklist) bnlearn::inter.iamb(x, blacklist = blacklist),
  si.hiton.pc = function(x, blacklist = blacklist) bnlearn::si.hiton.pc(x, blacklist = blacklist),
  iamb.fdr = function(x, blacklist = blacklist) bnlearn::iamb.fdr(x, blacklist = blacklist),
  iamb = function(x, blacklist = blacklist) bnlearn::iamb(x, blacklist = blacklist),
  gs = function(x, blacklist = blacklist) bnlearn::gs(x, blacklist = blacklist),
  mmpc = function(x, blacklist = blacklist) bnlearn::mmpc(x, blacklist = blacklist),
  pc = function(x, blacklist = blacklist) bnlearn::pc.stable(x, blacklist = blacklist),
  hc = function(x, blacklist = blacklist) bnlearn::hc(x, blacklist = blacklist),
  tabu = function(x, blacklist = blacklist) bnlearn::tabu(x, blacklist = blacklist),
  mmhc = function(x, blacklist = blacklist) bnlearn::mmhc(x, blacklist = blacklist),
  rsmax2 = function(x, blacklist = blacklist) bnlearn::rsmax2(x, blacklist = blacklist))

# evaluate all models on a dataset given a blacklist
evaluatemodel <- function(tablearg, blacklist){
  evalslfunc <- function(f){
    sltree <- f (data.frame(map(tablearg, inttonumeric)), blacklist = blacklist)
    neltree <- as.graphNEL(sltree)
    bg <- addBgKnowledge(neltree)
    if (length(bg) == 0){return (Inf)}
    g <- dagitty(pcalg2dagitty(t(as(bg, "matrix")), colnames(tablearg), type = "dag"))
    r <- localTests(
      g,
      tablearg, "cis",
      sample.cov = lavCor(tablearg),
      sample.nobs = nrow( tablearg ),
      max.conditioning.variables = 2,
      R = 100)
    if (dim(r)[1] == 0){return (0)}
    return(mean(abs(r$estimate)))
  }

  return(data.frame(lapply(bnmodels, evalslfunc)))
}

# Change all variables of integer type to a numeric type
inttonumeric <- function(x){
  if(is.integer(x)){
    return(as.numeric(x))
  }
  else{
    return(x)
  }
}

# create a structured model from a dataset and a structured learning algorithm
createmodel <- function(tablearg, f, blacklist){
   sltree <- f (data.frame(map(tablearg, inttonumeric)), blacklist = blacklist)
   neltree <- as.graphNEL(sltree)
   bg <- addBgKnowledge(neltree)
   g <- dagitty(pcalg2dagitty(t(as(bg, "matrix")), colnames(tablearg), type = "dag"))

   return(g)
}

# change the sign from dagitty syntax to lavaan syntax
changesign <- function(s){
  if(s == "->"){
    return("~")
  }
  if (s == "--"){
    return("~~")
  }
}


# create a list of all combinations of variables, one variable from each factor from the factor analysis, and subsets thereof
allcombn <- function(gridarg){
  allcombn_worker <- function(gridarg){
    sumcomb <- vector()
    for(i in data.frame(t(gridarg))){
      subcomb <- combn(i, length(gridarg) - 1)
      for(j in data.frame(subcomb)){
        sumcomb <- rbind(sumcomb, j)
      }
    }
    return(unique(sumcomb))
  }  
  
  sumcomb <- list()
  sumcomb <- append(sumcomb, split(gridarg, seq(nrow(gridarg))))
  subcomb <- allcombn_worker(gridarg)
  if(length(data.frame(subcomb)) > 0){
    sumcomb <- append(sumcomb, allcombn(data.frame(subcomb)))
  }
  return(sumcomb)
}

# convert a list of variables, use each list element as a blacklist, find the structured learning algorithm with the lowest deviance, use that algorithm and create a model
# return:
# model with the lowest deviance
# the deviances for the different models
# the name of the algorithm with the lowest deviance 
combtodag <- function(mycomb, tablearg){
  summary_table <- vector()
  for(i in 1:length(mycomb)){
    j <- unlist(mycomb[i])
    blacklist <- createblacklist(colnames(tablearg), j)
    evaluatedmodel <- evaluatemodel(tablearg, blacklist)
    g <- createmodel(tablearg, match.fun(colnames(sort(evaluatedmodel)) [1]), blacklist)
    v <- as.character(j)
    length(v) <- 5
    summary_table <- rbind(summary_table, c(as.character(g), t(evaluatedmodel), v,  colnames(sort(evaluatedmodel)) [1]))
  }
  return(summary_table)
}

# calculate the causal effect of the variable from to variable to using all models in listofmodels using all minimal adjustment sets that are given by the model
calceffect <- function(listofmodels, from, to, tablearg){
  summary_table <- vector()
  expadjsets <- function(adjsets){
    paste0(to, " ~ ", from, " + ", paste(unlist(adjsets), collapse = " + "))
  }
  calclmeffect <- function(eq){
    (summary(lm(as.formula(eq), tablearg)) %>% broom::tidy())[2,]
  }
  for(i in 1:nrow(data.frame(listofmodels))){
    g <- as.dagitty(listofmodels[i, 1])
    exogenous <- listofmodels[i, 16:20]
    adjsets <- adjustmentSets(g, from, to)
    if(is.null(unlist(adjsets)) & (length(adjsets) == 1)){
      eq <- paste(to, " ~ ",  from)
    } else {
      if(length(adjsets) > 0){
        eq <- map(adjsets, expadjsets)
      } else{
         eq <- NULL
      }
    }
    
    if (!is.null(eq)){
      mytest <- map(unlist(eq), calclmeffect)
    } else{
      mytest <- NULL
    }

    v <- as.character(exogenous)
    length(v) <- 5
    v1 <- t(data.frame(v))
    colnames(v1) <- c("1" , "2", "3", "4", "5")
    if(!is.null(mytest)){
      summary_table <- rbind(summary_table, cbind(Reduce('rbind', mytest), t(data.frame(eq)), v1))
    }
  }
  return(summary_table)
}

# create an SEM model for each dagitty model and return a table containing the estimated parameters of the fitted model and a variety of fit measures for each model
dagitty2sem <- function(mycomb, tablearg){
  summary_table <- vector()
  summary_table2 <- vector()
  for(i in 1:nrow(data.frame(mycomb))){
    g <- as.dagitty(mycomb[i, 1])
    exogenous <- mycomb[i, 16:20]
    fit <- suppressWarnings(sem(paste(dagityy2lavaan(g, exogenous), collapse = ''), data = tablearg))
    fit_m <- fitmeasures(fit)
    v <- as.character(exogenous)
    length(v) <- 5
    sumfit <- parameterEstimates(fit)
    summary_table2 <- rbind(summary_table2, cbind(sumfit, matrix(v, ncol = 5, nrow = nrow(sumfit), byrow = TRUE)))
    summary_table <- rbind(summary_table, c(t(fit_m), v))
  }

  summary_table <- cbind(summary_table[,43:47], data.frame(map(data.frame(summary_table[,1:42]), as.numeric)))
  colnames(summary_table) <- c(c("1" , "2", "3", "4", "5"), names(fit_m))

  summary_table2 <- summary_table %>% 
    left_join(summary_table2, by = c("1" , "2", "3", "4", "5"))

  return(summary_table2)
}

# convert a model with dagitty syntax to lavaan syntax. Relations between exogenous variables will be replaced by correlations
dagityy2lavaan <- function(model_arg, exogenous){
  temp <- str_split(model_arg, "\n") %>%
    unlist()
  temp <- lapply("->|--", grep, x = temp, value = TRUE) %>%
    unlist() %>%
    data.frame() %>%
    as_tibble()
  
  colnames(temp) <- "data"

  temp <- temp %>% 
    rowwise() %>% 
    mutate(lhs = unlist(str_split(data, " "))[1]) %>% 
    mutate(rhs = unlist(str_split(data, " "))[3]) %>% 
    mutate(sign = unlist(str_split(data, " "))[2])

  # one variable can be exogenous but not both
  endorel <- 
    temp %>% dplyr::filter(!(lhs %in% exogenous & rhs %in% exogenous))
  exorel <- temp %>% 
    dplyr::filter(lhs %in% exogenous & rhs %in% exogenous)

  exorel$sign <- "--"

  temp <- data.frame(rbind(endorel, exorel)) %>%
    rowwise() %>% mutate(mydata3 = paste(rhs, changesign(sign), lhs, "\n"))

  return(temp$mydata3)
}

filtergt0_3 <- function(loadings){
  loadings <- data.frame(loadings)
  rownames(loadings) <- rownames(factorloadings)
  rownames(loadings)[which(abs(loadings) > 0.3)]
}

The data tables are downloaded from Statistics Sweden. They are saved as a comma-delimited file without heading, http://www.statistikdatabasen.scb.se/pxweb/en/ssd/.

The tables:

UF0506A1_20210926-160849.csv: Population 16-74 years of age by region, highest level of education, age and sex. Year 1985 - 2020 NUTS 2 level 2008- 10 year intervals (16-74)

000000CG_20210926-160057.csv: Average basic salary, monthly salary and women´s salary as a percentage of men´s salary by region, sector, occupational group (SSYK 2012) and sex. Year 2014 - 2020 Monthly salary All sectors.

000000CD_20210926-160259.csv: Average basic salary, monthly salary and women´s salary as a percentage of men´s salary by region, sector, occupational group (SSYK 2012) and sex. Year 2014 - 2020 Number of employees All sectors.

The data is aggregated, the size of each group is in the column groupsize.

I have also included some calculated predictors from the original data.

nremployees: The number of employees in each group defined by ssyk, edulevel, region and year

perc_women: The percentage of women within each group defined by ssyk, edulevel, region and year

perc_women_region: The percentage of women within each group defined by ssyk, year and region

regioneduyears: The average number of education years per capita within each group defined by ssyk, year and region

eduquotient: The quotient between regioneduyears for men and women

salaryquotient: The quotient between salary for men and women within each group defined by ssyk, year and region

perc_women_ssyk_region: The percentage of women within each group defined by ssyk, year and region

numedulevel <- read.csv("edulevel_1.csv") 

numedulevel[, 2] <- data.frame(c(8, 9, 10, 12, 13, 15, 22, NA))

tb <- readfile("000000CG_20210926-160057.csv") 
tb <- readfile("000000CD_20210926-160259.csv") %>% 
  left_join(tb, by = c("region", "year", "sex", "sector","occuptional  (SSYK 2012)")) 

tb <- readfile("UF0506A1_20210926-160849.csv") %>%  
  right_join(tb, by = c("region", "year", "sex")) %>%
  right_join(numedulevel, by = c("level of education" = "level.of.education")) %>%
  filter(!is.na(eduyears)) %>%  
  mutate(edulevel = `level of education`) %>%
  group_by(edulevel, region, year, sex, `occuptional  (SSYK 2012)`) %>%
  mutate(groupsize_all_ages = sum(groupsize)) %>%  
  group_by(edulevel, region, year, `occuptional  (SSYK 2012)`) %>% 
  mutate (perc_women = perc_women (groupsize_all_ages[1:2])) %>% 
  mutate (nremployees = sum(groupsize.x)) %>%
  mutate (salary = (groupsize.y[2] * groupsize.x[2] + groupsize.y[1] * groupsize.x[1])/(groupsize.x[2] + groupsize.x[1])) %>%
  group_by (sex, year, region, `occuptional  (SSYK 2012)`) %>%
  mutate(regioneduyears_sex = sum(groupsize * eduyears) / sum(groupsize)) %>%
  mutate(regiongroupsize = sum(groupsize)) %>% 
  mutate(nremployees_sex = groupsize.x) %>%
  group_by(region, year, `occuptional  (SSYK 2012)`) %>%
  mutate (sum_pop = sum(groupsize)) %>%
  mutate (regioneduyears = sum(groupsize * eduyears) / sum(groupsize)) %>%
  mutate (perc_women_region = perc_women (regiongroupsize[1:2])) %>% 
  mutate (eduquotient = regioneduyears_sex[2] / regioneduyears_sex[1]) %>% 
  mutate (salary_sex = groupsize.y) %>%
  mutate (salaryquotient = salary_sex[2] / salary_sex[1]) %>%   
  mutate (perc_women_ssyk_region = perc_women(nremployees_sex[1:2])) %>%  
  left_join(nuts %>% distinct (NUTS2_en, NUTS2_sh), by = c("region" = "NUTS2_en")) %>%
  drop_na()

summary(tb)

##     region              age            level of education     sex           
##  Length:316974      Length:316974      Length:316974      Length:316974     
##  Class :character   Class :character   Class :character   Class :character  
##  Mode  :character   Mode  :character   Mode  :character   Mode  :character  
##                                                                             
##                                                                             
##                                                                             
##      year             groupsize         year_n        sector         
##  Length:316974      Min.   :    0   Min.   :2014   Length:316974     
##  Class :character   1st Qu.: 2561   1st Qu.:2015   Class :character  
##  Mode  :character   Median : 7456   Median :2017   Mode  :character  
##                     Mean   :11676   Mean   :2017                     
##                     3rd Qu.:16443   3rd Qu.:2019                     
##                     Max.   :81358   Max.   :2020                     
##  occuptional  (SSYK 2012)  groupsize.x       year_n.x     groupsize.y    
##  Length:316974            Min.   :  100   Min.   :2014   Min.   : 20200  
##  Class :character         1st Qu.:  400   1st Qu.:2015   1st Qu.: 29100  
##  Mode  :character         Median : 1100   Median :2017   Median : 34300  
##                           Mean   : 2893   Mean   :2017   Mean   : 37470  
##                           3rd Qu.: 3000   3rd Qu.:2019   3rd Qu.: 42600  
##                           Max.   :53700   Max.   :2020   Max.   :139500  
##     year_n.y       eduyears       edulevel         groupsize_all_ages
##  Min.   :2014   Min.   : 8.00   Length:316974      Min.   :   405    
##  1st Qu.:2015   1st Qu.: 9.00   Class :character   1st Qu.: 24027    
##  Median :2017   Median :12.00   Mode  :character   Median : 56038    
##  Mean   :2017   Mean   :12.71                      Mean   : 70055    
##  3rd Qu.:2019   3rd Qu.:15.00                      3rd Qu.:111943    
##  Max.   :2020   Max.   :22.00                      Max.   :288426    
##    perc_women      nremployees         salary       regioneduyears_sex
##  Min.   :0.3575   Min.   :   600   Min.   : 20200   Min.   :11.18     
##  1st Qu.:0.4439   1st Qu.:  4800   1st Qu.: 29214   1st Qu.:11.65     
##  Median :0.4816   Median : 13080   Median : 34488   Median :11.83     
##  Mean   :0.4831   Mean   : 32797   Mean   : 37494   Mean   :11.86     
##  3rd Qu.:0.5000   3rd Qu.: 37800   3rd Qu.: 42738   3rd Qu.:12.13     
##  Max.   :0.6484   Max.   :426600   Max.   :123796   Max.   :12.64     
##  regiongroupsize  nremployees_sex    sum_pop        regioneduyears 
##  Min.   :127118   Min.   :  100   Min.   : 127118   Min.   :11.18  
##  1st Qu.:291940   1st Qu.:  400   1st Qu.: 518853   1st Qu.:11.63  
##  Median :528643   Median : 1100   Median : 722010   Median :11.85  
##  Mean   :490383   Mean   : 2893   Mean   : 878571   Mean   :11.86  
##  3rd Qu.:708813   3rd Qu.: 3000   3rd Qu.:1395157   3rd Qu.:12.01  
##  Max.   :842459   Max.   :53700   Max.   :1682100   Max.   :12.64  
##  perc_women_region  eduquotient      salary_sex     salaryquotient  
##  Min.   :0.4831    Min.   :1.000   Min.   : 20200   Min.   :0.6423  
##  1st Qu.:0.4893    1st Qu.:1.020   1st Qu.: 29100   1st Qu.:0.9333  
##  Median :0.4949    Median :1.030   Median : 34300   Median :0.9804  
##  Mean   :0.4945    Mean   :1.026   Mean   : 37470   Mean   :0.9637  
##  3rd Qu.:0.5000    3rd Qu.:1.039   3rd Qu.: 42600   3rd Qu.:1.0000  
##  Max.   :0.5014    Max.   :1.049   Max.   :139500   Max.   :1.3090  
##  perc_women_ssyk_region   NUTS2_sh        
##  Min.   :0.009346       Length:316974     
##  1st Qu.:0.384615       Class :character  
##  Median :0.500000       Mode  :character  
##  Mean   :0.518956                         
##  3rd Qu.:0.674419                         
##  Max.   :0.945274

tbtemp <- ungroup(tb) %>% dplyr::select(salary, nremployees, year_n, sum_pop, regioneduyears, perc_women_region, salaryquotient, eduquotient, perc_women_ssyk_region, `occuptional  (SSYK 2012)`)

tb_unique <- unique(tbtemp)

Data is normalised before analysis. In this way, the scale of the variables will not affect the analysis. Data is imputed by replacing NA with the median.

  tb_unique_norm <- tb_unique
  tb_unique_norm <- data.frame(data.matrix(tonormest(tb_unique)))
  tb_unique_norm <- imputeMissings::impute(tb_unique_norm, object = NULL, method = "median/mode", flag = FALSE)

I will use the package bnlearn to approximate a DAG from the data. In bnlearn, there are several algorithms for this purpose. A way to use prior knowledge together with the algorithms for structured learning in the bnlearn package is to specify a blacklist or a whitelist. Arcs in the whitelist are always included in the network. Arcs in the blacklist are never included in the network. If we don’t know a priori what arcs to include in the blacklist or whitelist then we can evaluate several models with different settings. To limit the number of models to evaluate I will do some assumptions. I will assume that the variation in the model can be expressed by using fewer variables, e.g. Principal Component Analysis, for this application I will use factor analysis. I will assume that the number of exogenous variables in the model is equal to or less than the number of factors suggested by factor analysis. I will use the Psych package’s fa.parallel function to determine the number of factors. The warning from the factor analysis is ignored. A better choice of rotation and factoring method could solve this, future improvements. The factors with loading greater than 0.3 are chosen for future processing.

   fatest <- fa.parallel(tb_unique_norm, fm = "minres", fa = "fa")

## Warning in fa.stats(r = r, f = f, phi = phi, n.obs = n.obs, np.obs = np.obs, :
## The estimated weights for the factor scores are probably incorrect. Try a
## different factor score estimation method.

## Warning in fac(r = r, nfactors = nfactors, n.obs = n.obs, rotate = rotate, : An
## ultra-Heywood case was detected. Examine the results carefully

Figure 1: Parallell Analysis Scree Plots

## Parallel analysis suggests that the number of factors =  5  and the number of components =  NA

  factoranalysis <- fa(tb_unique_norm, nfactors = fatest$nfact, rotate = "oblimin", fm = "minres")

## Loading required namespace: GPArotation

## Warning in fa.stats(r = r, f = f, phi = phi, n.obs = n.obs, np.obs = np.obs, :
## The estimated weights for the factor scores are probably incorrect. Try a
## different factor score estimation method.

## Warning in fac(r = r, nfactors = nfactors, n.obs = n.obs, rotate = rotate, : An
## ultra-Heywood case was detected. Examine the results carefully

  print(factoranalysis$loadings, cutoff = 0.3)

## 
## Loadings:
##                          MR1    MR2    MR3    MR4    MR5   
## salary                                 -0.979              
## nremployees                      0.466                     
## year_n                                         0.998       
## sum_pop                          0.996                     
## regioneduyears                   0.570                     
## perc_women_region         0.906                            
## salaryquotient                                             
## eduquotient              -0.969                            
## perc_women_ssyk_region                                0.998
## occuptional...SSYK.2012.                0.779              
## 
##                  MR1   MR2   MR3   MR4   MR5
## SS loadings    1.949 1.702 1.676 1.077 1.059
## Proportion Var 0.195 0.170 0.168 0.108 0.106
## Cumulative Var 0.195 0.365 0.533 0.640 0.746

  factorloadings <- print(factoranalysis$loadings, cutoff = 0.3)

## 
## Loadings:
##                          MR1    MR2    MR3    MR4    MR5   
## salary                                 -0.979              
## nremployees                      0.466                     
## year_n                                         0.998       
## sum_pop                          0.996                     
## regioneduyears                   0.570                     
## perc_women_region         0.906                            
## salaryquotient                                             
## eduquotient              -0.969                            
## perc_women_ssyk_region                                0.998
## occuptional...SSYK.2012.                0.779              
## 
##                  MR1   MR2   MR3   MR4   MR5
## SS loadings    1.949 1.702 1.676 1.077 1.059
## Proportion Var 0.195 0.170 0.168 0.108 0.106
## Cumulative Var 0.195 0.365 0.533 0.640 0.746

  mygrid <- expand.grid(map(data.frame(factorloadings[,1:5]), filtergt0_3)) 
  
  mygrid %>% 
    knitr::kable(
      booktabs = TRUE,
      caption = 'Table of proposed exogenous variables to evaluate')

Table 2: Table of proposed exogenous variables to evaluate
MR1	MR2	MR3	MR4	MR5
perc_women_region	nremployees	salary	year_n	perc_women_ssyk_region
eduquotient	nremployees	salary	year_n	perc_women_ssyk_region
perc_women_region	sum_pop	salary	year_n	perc_women_ssyk_region
eduquotient	sum_pop	salary	year_n	perc_women_ssyk_region
perc_women_region	regioneduyears	salary	year_n	perc_women_ssyk_region
eduquotient	regioneduyears	salary	year_n	perc_women_ssyk_region
perc_women_region	nremployees	occuptional…SSYK.2012.	year_n	perc_women_ssyk_region
eduquotient	nremployees	occuptional…SSYK.2012.	year_n	perc_women_ssyk_region
perc_women_region	sum_pop	occuptional…SSYK.2012.	year_n	perc_women_ssyk_region
eduquotient	sum_pop	occuptional…SSYK.2012.	year_n	perc_women_ssyk_region
perc_women_region	regioneduyears	occuptional…SSYK.2012.	year_n	perc_women_ssyk_region
eduquotient	regioneduyears	occuptional…SSYK.2012.	year_n	perc_women_ssyk_region

I will start by creating all possible sets and subsets from the set of five exogenous variables that were selected by the factor analysis. For each set, I will create a model from a set of structured learning algorithms from the bnlearn package. Each algorithm is evaluated against how well it minimizes the deviations from the testable implications in the model and the dataset. The function localTests from the dagitty package is used to get a numeric value of the testable implications. The mean deviation from all testable implications by localTests is used. This could favour more complex models since there are fewer testable implications in complex than in simple models. The version of localTests in my test uses a combination of categorical and continuous data. A more advanced algorithm could have been used to select the model that minimizes the deviation. The models so far are created in dagitty syntax.

From the dagitty syntax, I will create a Structural Equation Model in lavaan for each model created in the earlier step. Each SEM model is evaluated for a variety of fit measures to assess the global fit of the latent variable model. No latent variables are evaluated at this stage but you could perhaps imagine that there is a correspondence between the factor analysis and some unmeasured latent variables. The model parameters for each model is also stored for later analysis.

The table of models and the table of evaluated models are joined to allow extra comparisons.

Since the generation of dagitty models takes a while I have prepared that table in a file.

  list_of_exogenous_variables <- allcombn(mygrid)
  #table_of_dagitty_models <- combtodag(list_of_exogenous_variables, tb_unique_norm)
  table_of_dagitty_models <- read.csv("table_of_dagitty_models.csv")
  table_of_dagitty_models <- table_of_dagitty_models[,2:22] 
  table_of_sem_models <- dagitty2sem(table_of_dagitty_models, tb_unique_norm)
  
  table_of_dagitty_models_df <- data.frame(table_of_dagitty_models)

  colnames(table_of_dagitty_models_df) <- 
    c("model", 
      names(bnmodels), 
      c("1" , "2", "3", "4", "5", 
        "algorithm"))
  
  dagitty_and_sem_table <- table_of_dagitty_models_df %>% 
    left_join(table_of_sem_models, by = c("1" , "2", "3", "4", "5"))

  ggplot(dagitty_and_sem_table) + 
    geom_point(aes(x = pvalue.x, y = rmsea))

Figure 2: The figure shows that there is a tradeoff between the pvalue and the Root Mean Square Error of the model

  dagitty_and_sem_table %>% 
    mutate(deviance = as.numeric(pmin(h2pc, hpc, fast.iamb, inter.iamb, si.hiton.pc, iamb.fdr, iamb, gs, mmpc, pc,  hc, tabu, mmhc, rsmax2))) %>% 
    ggplot() + 
    geom_point(aes(x = aic, y = deviance))

Figure 3: The figure shows how the deviance measured by localTests and the model complexity measured in aic are related

From the table, we can examine how many of the models contained an arc, i.e. a relation from one variable to another. We find that the direction of the relation from quotient between the average number of education years for men and women to quotient between salary for men and women is found in 121 out of 143 tested models. The estimation of the relationship is 0.32 standard units. Only the models with a pvalue less than 0.05 are counted.

If we use the ten (arbitrary number, could be optimized) arcs that occur are most frequent in the models that I have analysed and use those arcs to create a whitelist, i.e. arcs that must be present in the model, when estimating a new model with the hills climbing algorithm we get a model that can be used to approximate the causal effects that can be estimated from the data. The plot shows the model. In this model year and percentage of women in the ssyk are exogenous variables and the rest of the variables are endogenous. When looking at the model’s parameter values and sorting it by the highest effect we find that the effect of per cent women in the region on quotient between the average number of education years for men and women is the highest of all effects between continuous variables, 79 out of 143 models has this direction of this relation.

  temp <- combn(colnames(tb_unique_norm), 2)
  list_of_var_combinations <- cbind(temp, rbind(temp[2,], temp[1,]))

  summary_table <- vector()
  for(i in data.frame(list_of_var_combinations)){
    est <- dagitty_and_sem_table %>% 
      filter(lhs == i[1], rhs == i[2], pvalue.x < 0.05) %>% 
      dplyr::select(est)
    summary_table <- rbind(
      summary_table, 
      c(i, 
        (t(summary(est))), 
        nrow(est), 
        sd(t(est))))
  }

  summary_table <- unique(cbind(summary_table[,1:8], data.frame(map(data.frame(summary_table[,9:10]), as.numeric)))) %>%
    arrange(-X1)
  
  summary_table[1:10,] %>%
    select(`1`, `2`, X1) %>%
    rename(lhs = `1`) %>%
    rename(rhs = `2`) %>%
    rename(nr_of_models = X1) %>%
    knitr::kable(
      booktabs = TRUE,
      caption = 'The ten most common arcs of all 143 models')

Table 3: The ten most common arcs of all 143 models
lhs	rhs	nr_of_models
salaryquotient	eduquotient	121
salaryquotient	perc_women_ssyk_region	111
salaryquotient	salary	110
regioneduyears	year_n	110
nremployees	perc_women_ssyk_region	104
salaryquotient	year_n	104
salary	year_n	98
occuptional…SSYK.2012.	perc_women_ssyk_region	98
salaryquotient	sum_pop	97
regioneduyears	sum_pop	95

  whitelist <- summary_table[1:10, 2:1]
  
  hctree <- hc(tb_unique_norm, whitelist = whitelist)
  
  neltree <- as.graphNEL(hctree)
  bg <- addBgKnowledge(neltree)
  if (length(bg) == 0){
    return (Inf)
  }
  
  g <- dagitty(pcalg2dagitty(t(as(bg, "matrix")), colnames(tb_unique_norm), type = "dag"))
  
  fit <- sem(paste(dagityy2lavaan(g, NULL), collapse = ''), data = tb_unique_norm)

## Warning in lav_data_full(data = data, group = group, cluster = cluster, : lavaan
## WARNING: some observed variances are (at least) a factor 1000 times larger than
## others; use varTable(fit) to investigate

  semPaths(fit, 'std', 'est', curveAdjacent = TRUE, style = "lisrel")

  r <- localTests(
    g,
    tb_unique_norm, "cis",
    sample.cov = lavCor(tb_unique_norm),
    sample.nobs = nrow( tb_unique_norm ),
    max.conditioning.variables = 2,
    R = 100)

## Warning in lav_data_full(data = data, group = group, cluster = cluster, : lavaan
## WARNING: some observed variances are (at least) a factor 1000 times larger than
## others; use varTable(fit) to investigate

  parameterEstimates(fit) %>% 
    select(lhs, op, rhs, est, pvalue) %>%
    arrange(-abs(est)) %>%
    knitr::kable(
      booktabs = TRUE,
      caption = 'Parameters for the approximate model sorted in falling effect size')

Table 3: Parameters for the approximate model sorted in falling effect size
lhs	op	rhs	est	pvalue
occuptional…SSYK.2012.	~~	occuptional…SSYK.2012.	515.4245404	0.0000000
occuptional…SSYK.2012.	~	salary	-28.6174604	0.0000000
occuptional…SSYK.2012.	~	perc_women_ssyk_region	-7.9191011	0.0000000
occuptional…SSYK.2012.	~	year_n	5.1547157	0.0000000
occuptional…SSYK.2012.	~	perc_women_region	2.9988570	0.0000000
occuptional…SSYK.2012.	~	sum_pop	1.7031739	0.0000006
year_n	~~	year_n	0.9997846	NA
perc_women_ssyk_region	~~	perc_women_ssyk_region	0.9997846	NA
sum_pop	~~	sum_pop	0.9770425	0.0000000
perc_women_region	~~	perc_women_region	0.9603644	0.0000000
salary	~~	salary	0.9556355	0.0000000
eduquotient	~	perc_women_region	-0.9015448	0.0000000
regioneduyears	~	sum_pop	0.8082339	0.0000000
salaryquotient	~~	salaryquotient	0.7302152	0.0000000
nremployees	~~	nremployees	0.7295975	0.0000000
regioneduyears	~	eduquotient	-0.6494568	0.0000000
regioneduyears	~~	regioneduyears	0.4814185	0.0000000
eduquotient	~	sum_pop	0.4493408	0.0000000
salaryquotient	~	salary	-0.3776151	0.0000000
nremployees	~	sum_pop	0.3740575	0.0000000
salaryquotient	~	eduquotient	-0.3242296	0.0000000
regioneduyears	~	year_n	0.3050356	0.0000000
regioneduyears	~	perc_women_region	-0.2773857	0.0000000
nremployees	~	eduquotient	0.2212280	0.0000000
salary	~	perc_women_ssyk_region	-0.1546639	0.0000000
salaryquotient	~	sum_pop	-0.1535919	0.0000000
perc_women_region	~	sum_pop	0.1529078	0.0000000
sum_pop	~	salary	0.1508210	0.0000000
salaryquotient	~	year_n	0.1479586	0.0000000
nremployees	~	perc_women_ssyk_region	0.1465144	0.0000000
salary	~	year_n	0.1421677	0.0000000
nremployees	~	perc_women_region	0.1329411	0.0002882
eduquotient	~~	eduquotient	0.1082249	0.0000000
regioneduyears	~	salary	-0.0952185	0.0000000
nremployees	~	salary	-0.0951437	0.0000015
perc_women_region	~	perc_women_ssyk_region	-0.0790279	0.0000001
perc_women_region	~	year_n	-0.0767289	0.0000001
salaryquotient	~	perc_women_ssyk_region	0.0693828	0.0000003
perc_women_region	~	salary	0.0474522	0.0014239
eduquotient	~	year_n	0.0283044	0.0000000
regioneduyears	~~	salaryquotient	-0.0201865	0.0204311
nremployees	~~	salaryquotient	-0.0040980	0.7020812
nremployees	~	occuptional…SSYK.2012.	0.0037042	0.0000000
salaryquotient	~	occuptional…SSYK.2012.	-0.0032636	0.0000000
regioneduyears	~	occuptional…SSYK.2012.	-0.0029127	0.0000000
nremployees	~~	regioneduyears	-0.0017782	0.8380207
perc_women_ssyk_region	~~	year_n	-0.0005915	NA

  plotLocalTestResults( r )

Figure 4: This figure shows the testable implications from localTests

  ggplot(data = tb_unique_norm, mapping = aes(x = eduquotient, y = salaryquotient)) + 
    geom_boxplot(mapping = aes(group = cut_width(eduquotient, 0.4)))

Figure 5: The figure shows how the quotient between salary for men and women is affected by the quotient between the average number of education years for men and women

  ggplot(tb_unique_norm) + 
    geom_point(aes(x = perc_women_region, y = eduquotient))

Figure 6: The figure shows how the quotient between the average number of education years for men and women is affected by the per cent women in the region

If you know the DAG it is possible to identify the sets of covariates that allow unbiased estimation of causal effects with the function adjustmentSets in the dagitty package. I will calculate the possible adjustment sets for all models created in earlier steps and compare them. Let’s start by calculating the causal effect of the quotient between the average number of education years for men and women on the quotient between salary for men and women.

  causaleffect <- calceffect(table_of_dagitty_models, "eduquotient", "salaryquotient", tb_unique_norm)
  
  causaleffect_df <- data.frame(map(causaleffect, unlist))
  
  colnames(causaleffect_df) <- colnames(causaleffect)

  dagitty_sem_and_causal_table <- dagitty_and_sem_table %>% 
    left_join(causaleffect_df, by = c("1" , "2", "3", "4", "5"))

  dagitty_sem_and_causal_table %>% 
    filter(lhs == "salaryquotient", rhs == "eduquotient") %>% 
    ggplot() + 
      geom_point(aes(x = estimate, y = pvalue.x, color = aic))

Figure 7: The figure shows the estimate for the causal effect of the quotient between the average number of education years for men and women on quotient between salary for men and women from all tested models and the pvalue and aic of the model

  dagitty_sem_and_causal_table %>% 
    mutate(modelnumber = as.integer(factor(`t(data.frame(eq))`))) %>%
    filter(lhs == "salaryquotient", rhs == "eduquotient") %>% 
    ggplot() + 
      geom_point(aes(x = modelnumber, y = estimate, color = pvalue.x))

Figure 8: The figure shows how the quotient between the average number of education years for men and women is affected by the per cent women in the region for the different covariates

  dagitty_sem_and_causal_table %>% 
    filter(lhs == "salaryquotient", rhs == "eduquotient") %>% 
    mutate(modelnumber = as.integer(factor(`t(data.frame(eq))`))) %>%
    mutate(linear_equation_with_covariates = `t(data.frame(eq))`) %>%
    group_by(modelnumber) %>%
    mutate(frequency = n()) %>%  
    arrange(modelnumber) %>%
    select(linear_equation_with_covariates, modelnumber, estimate, frequency) %>%
    unique() %>%
    knitr::kable(
      booktabs = TRUE,
      caption = 'Table showing the covariates needed for different models to calculate the effect')

Table 4: Table showing the covariates needed for different models to calculate the effect
linear_equation_with_covariates	modelnumber	estimate	frequency
salaryquotient ~ eduquotient	1	-0.3475676	13
salaryquotient ~ eduquotient + nremployees	2	-0.3438332	5
salaryquotient ~ eduquotient + nremployees + occuptional…SSYK.2012.	3	-0.3242904	1
salaryquotient ~ eduquotient + nremployees + occuptional…SSYK.2012. + perc_women_region + sum_pop + year_n	4	-0.4027556	31
salaryquotient ~ eduquotient + nremployees + occuptional…SSYK.2012. + salary + sum_pop + year_n	5	-0.3230239	7
salaryquotient ~ eduquotient + nremployees + perc_women_region + salary + sum_pop	6	-0.3621844	2
salaryquotient ~ eduquotient + nremployees + perc_women_region + sum_pop + year_n	7	-0.4259852	10
salaryquotient ~ eduquotient + nremployees + perc_women_ssyk_region + salary	8	-0.3335892	1
salaryquotient ~ eduquotient + occuptional…SSYK.2012.	9	-0.3355981	1
salaryquotient ~ eduquotient + occuptional…SSYK.2012. + perc_women_region + regioneduyears	10	-0.5848968	7
salaryquotient ~ eduquotient + occuptional…SSYK.2012. + perc_women_ssyk_region + salary + sum_pop + year_n	11	-0.3242342	31
salaryquotient ~ eduquotient + occuptional…SSYK.2012. + perc_women_ssyk_region + year_n	12	-0.3548155	2
salaryquotient ~ eduquotient + occuptional…SSYK.2012. + regioneduyears	13	-0.3497428	3
salaryquotient ~ eduquotient + occuptional…SSYK.2012. + regioneduyears + year_n	14	-0.3676810	1
salaryquotient ~ eduquotient + occuptional…SSYK.2012. + year_n	15	-0.3443816	3
salaryquotient ~ eduquotient + perc_women_region + perc_women_ssyk_region + sum_pop + year_n	16	-0.4063135	2
salaryquotient ~ eduquotient + perc_women_region + regioneduyears + sum_pop + year_n	17	-0.4235753	17
salaryquotient ~ eduquotient + perc_women_region + salary + sum_pop + year_n	18	-0.3932932	4
salaryquotient ~ eduquotient + perc_women_region + sum_pop	19	-0.3868834	11
salaryquotient ~ eduquotient + perc_women_region + sum_pop + year_n	20	-0.4106547	11
salaryquotient ~ eduquotient + perc_women_ssyk_region + salary + sum_pop	21	-0.2998376	3
salaryquotient ~ eduquotient + perc_women_ssyk_region + salary + sum_pop + year_n	22	-0.3135959	23
salaryquotient ~ eduquotient + perc_women_ssyk_region + sum_pop	23	-0.2934366	10
salaryquotient ~ eduquotient + perc_women_ssyk_region + year_n	24	-0.3671626	5
salaryquotient ~ eduquotient + regioneduyears	25	-0.3622676	2
salaryquotient ~ eduquotient + salary + sum_pop	26	-0.2923565	2
salaryquotient ~ eduquotient + salary + sum_pop + year_n	27	-0.3064032	4
salaryquotient ~ eduquotient + sum_pop	28	-0.2821068	4
salaryquotient ~ eduquotient + year_n	29	-0.3567006	5

  ggplot(tb_unique_norm) + 
    geom_point(aes(x = eduquotient, y = salaryquotient, color = perc_women_region))

Figure 9: The figure shows how quotient between salary for men and women is affected by quotient between the average number of education years for men and women and the covariate per cent women in the region

As a second example, I will calculate the causal effect of per cent women in the region on quotient between the average number of education years for men and women.

  causaleffect <- calceffect(table_of_dagitty_models, "perc_women_region", "eduquotient", tb_unique_norm)
  
  causaleffect_df <- data.frame(map(causaleffect, unlist))
  
  colnames(causaleffect_df) <- colnames(causaleffect)
  
  dagitty_sem_and_causal_table <- dagitty_and_sem_table %>% 
    left_join(causaleffect_df, by = c("1" , "2", "3", "4", "5"))

  dagitty_sem_and_causal_table %>% 
    filter(lhs == "eduquotient", rhs == "perc_women_region") %>% 
    ggplot() + 
      geom_point(aes(x = estimate, y = pvalue.x, color = aic))

Figure 10: The figure shows the estimate for the causal effect of per cent women in the region on quotient between the average number of education years for men and women

  dagitty_sem_and_causal_table %>% 
    mutate(modelnumber = as.integer(factor(`t(data.frame(eq))`))) %>%
    filter(lhs == "eduquotient", rhs == "perc_women_region") %>% 
    ggplot() + 
      geom_point(aes(x = modelnumber, y = estimate, color = aic))

Figure 11: The figure shows how the quotient between the average number of education years for men and women is affected by the per cent women in the region for the different covariates

Salaries and time series regression

Wed, 02 Jun 2021 00:00:00 +0000

In this post, I will examine Dynamic Linear Models and Time-Series Regression. I will return to data for Engineers from Statistics Sweden. Since the salaries for each year, each stratum (age group) is strongly correlated with the salary for the previous year it does not seem too distant to use a time series to represent the change of salaries throughout the period.

I will let the age represent the season in the time series. This violates the properties of a regular time series and has to be considered for the rest of the analysis. First, let´s decompose the series into its trend and seasonal patterns.

First, define libraries and functions.

library (tidyverse)
## -- Attaching packages --------------------------------------- tidyverse 1.3.1 --
## v ggplot2 3.3.3     v purrr   0.3.4
## v tibble  3.1.0     v dplyr   1.0.5
## v tidyr   1.1.3     v stringr 1.4.0
## v readr   1.4.0     v forcats 0.5.1
## Warning: package 'ggplot2' was built under R version 4.0.3
## Warning: package 'tibble' was built under R version 4.0.5
## Warning: package 'tidyr' was built under R version 4.0.5
## Warning: package 'readr' was built under R version 4.0.3
## Warning: package 'dplyr' was built under R version 4.0.5
## Warning: package 'forcats' was built under R version 4.0.3
## -- Conflicts ------------------------------------------ tidyverse_conflicts() --
## x dplyr::filter() masks stats::filter()
## x dplyr::lag()    masks stats::lag()
library(imputeTS)
## Warning: package 'imputeTS' was built under R version 4.0.5
## Registered S3 method overwritten by 'quantmod':
##   method            from
##   as.zoo.data.frame zoo
library(TSstudio)
## Warning: package 'TSstudio' was built under R version 4.0.5
library(forecast)
## Warning: package 'forecast' was built under R version 4.0.5
library(dynlm)
## Warning: package 'dynlm' was built under R version 4.0.5
## Loading required package: zoo
## Warning: package 'zoo' was built under R version 4.0.5
## 
## Attaching package: 'zoo'
## The following object is masked from 'package:imputeTS':
## 
##     na.locf
## The following objects are masked from 'package:base':
## 
##     as.Date, as.Date.numeric
library(lmtest) 
## Warning: package 'lmtest' was built under R version 4.0.4
library(sandwich)
## Warning: package 'sandwich' was built under R version 4.0.3
library(ggeffects)
## Warning: package 'ggeffects' was built under R version 4.0.5

readfile <- function (file1){
  read_csv (file1, col_types = cols(), locale = readr::locale (encoding = "latin1"), na = c("..", "NA")) %>%
    gather (starts_with("19"), starts_with("20"), key = "year", value = salary) %>%
    mutate (year_n = parse_number (year))
}

# Thanks to Grant, Stack Overflow
predNeweyWest <- function (model){
  pred_df <- data.frame(fit = predict(model))

  X_mat <- model.matrix(model)

  v_hac <- NeweyWest(model, prewhite = FALSE, adjust = TRUE)

  var_fit_hac <- rowSums((X_mat %*% v_hac) * X_mat)
  se_fit_hac <- sqrt(var_fit_hac)

  pred_df <-
    pred_df %>%
    mutate(se_fit_hac = se_fit_hac) %>%
    mutate(
      lwr_hac = fit - qt(0.975, df = model$df.residual) * se_fit_hac,
      upr_hac = fit + qt(0.975, df = model$df.residual) * se_fit_hac
    )
}

plotmodel <- function(data, pred_df, no_n = FALSE){ 
  if(no_n){
  bind_cols(
    data,
    pred_df
    ) %>%
      ggplot(aes(x = year_dec, y = salary, ymin = lwr_hac, ymax = upr_hac)) + 
      geom_point() + 
      geom_ribbon(fill = "#E41A1C", alpha = 0.3, col = NA) +
      labs(
        x = "Year",
        y = "Salary (SEK/month)",
        caption = 'Shaded region indicates HAC 95% CI.'
    )
  }
  else{
  bind_cols(
    data,
    pred_df
    ) %>%
      ggplot(aes(x = year_dec, y = salary, color = n, ymin = lwr_hac, ymax = upr_hac)) + 
      geom_point() + 
      geom_ribbon(fill = "#E41A1C", alpha = 0.3, col = NA) +
      labs(
        x = "Year",
        y = "Salary (SEK/month)",
        caption = 'Shaded region indicates HAC 95% CI.'
    )    
  }
}

assess_model <- function(model, timeseries, data, no_n = FALSE, doexp = FALSE){
  print(summary (model))

  print(coeftest(model, vcov = NeweyWest, prewhite = F, adjust = T))

  print(checkresiduals(model))
  
  if(doexp){
    pred_df <- exp(predNeweyWest(model))
  } else {
    pred_df <- predNeweyWest(model)
  }

  pred_df$year_dec <- timeseries

  plotmodel(data, pred_df, no_n)
}

The data table is downloaded from Statistics Sweden. It is saved as a comma-delimited file without heading, 000000D2_20210506-201343.csv, http://www.statistikdatabasen.scb.se/pxweb/en/ssd/.

The table: Average monthly pay (total pay), non-manual workers all sectors (SLP), SEK by occupational group (SSYK), age, sex and year. SSYK 2012 214, Year 2014 - 2019

The average age within each age group is used as a numeric value for graphical presentation and the linear model.

The number of Engineers in each stratum is downloaded separately in the file 000000CZ_20210506-201420.csv.

tb <- readfile("000000D2_20210506-201343.csv") %>%
  rowwise() %>%
  mutate(age_l = unlist(lapply(strsplit(substr(age, 1, 5), "-"), strtoi))[1]) %>%
  rowwise() %>%
  mutate(age_h = unlist(lapply(strsplit(substr(age, 1, 5), "-"), strtoi))[2]) %>%
  mutate(age_n = (age_l + age_h) / 2)

tbcount <- readfile("000000CZ_20210506-201420.csv")
tbcount$salary <- replace(tbcount$salary, is.na(tbcount$salary), 0)

tb$n <- tbcount$salary

Let’s have a look at the age distribution for the different years for men and women.

tb %>%
  ggplot () +  
    geom_point (mapping = aes(x = age_n,y = n, colour = year_n, shape = sex)) + 
  labs(
    x = "Age",
    y = "Number of Engineers"
  )

Create a time series for each gender. Time series can not have missing values, Impute missing values in time series with arima model. Women don’t have any data for the age group 65-66 year, that group is filtered away.

tb_men <- filter(tb, sex == "men")

tb_women <- filter(tb, sex == "women") %>% filter(age_n != 65.5)

summary(tb_men$salary)
##    Min. 1st Qu.  Median    Mean 3rd Qu.    Max.    NA's 
##   27300   36550   47100   43340   49500   52800       1

summary(tb_women$salary)
##    Min. 1st Qu.  Median    Mean 3rd Qu.    Max.    NA's 
##   26600   35000   44700   41293   45900   52100       1

tbts_men <- ts(tb_men$salary, start = 2014, freq = 6) %>% na_kalman("auto.arima")

tbts_women <- ts(tb_women$salary, start = 2014, freq = 5) %>% na_kalman("auto.arima")

tb_men$salary <- as.numeric(tbts_men)

tb_women$salary <- as.numeric(tbts_women)

Let’s use the decompose function from the stats package to view the trend, seasonal and random component of the time series.

decompose(tbts_men) %>% plot()


decompose(tbts_women) %>% plot()

Let´s have a look at the autocorrelation for the series. As expected the series for men shows a strong correlation with its sixth lag, i.e. the same age category the year before. The series for women shows a strong correlation with its fifth lag.

acf(tbts_men, 36)


acf(tbts_women, 30)

The partial autocorrelation function gives the partial correlation of a stationary time series with its own lagged values, regressed the values of the time series at all shorter lags.

pacf(tbts_men, 36)


pacf(tbts_women, 36)

The following plot shows the correlation between the salary and its yearly lag for three years.

ts_lags(tbts_men, c(6, 12, 18))

ts_lags(tbts_women, c(5, 10, 15))

Now, let’s fit an arima model to the time series with the auto.arima from the forecast library. The summary shows that the auto.arima has identified a SAR(2) process with drift and additionally an element of random walk. The checkresiduals function plots the residuals from the arima model, the autocorrelation of the residuals and a histogram of the residual distribution. The Ljung-Box test suggests that only white noise remains in the residual. The ggseasonplot plots the salary distribution on age for the years 2014-2019, remember that we used age as a season in this approach.

arimamodel_men <- auto.arima(tbts_men)

summary(arimamodel_men)
## Series: tbts_men 
## ARIMA(0,0,0)(2,1,0)[6] with drift 
## 
## Coefficients:
##         sar1     sar2     drift
##       -0.761  -0.6098  128.8569
## s.e.   0.158   0.1435   16.1691
## 
## sigma^2 estimated as 1163963:  log likelihood=-254.04
## AIC=516.08   AICc=517.68   BIC=521.69
## 
## Training set error measures:
##                     ME     RMSE      MAE        MPE    MAPE     MASE      ACF1
## Training set -25.68999 934.3299 573.1137 -0.1985635 1.37638 0.434177 0.2314468

checkresiduals(arimamodel_men)

## 
##  Ljung-Box test
## 
## data:  Residuals from ARIMA(0,0,0)(2,1,0)[6] with drift
## Q* = 3.9755, df = 4, p-value = 0.4093
## 
## Model df: 3.   Total lags used: 7

ggseasonplot(tbts_men)

For women, the auto.arima is not able to pick up any SAR. The best fit is according to auto.arima is a constant drift.

arimamodel_women <- auto.arima(tbts_women)

summary(arimamodel_women)
## Series: tbts_women 
## ARIMA(0,0,0)(0,1,0)[5] with drift 
## 
## Coefficients:
##          drift
##       188.0000
## s.e.   43.5542
## 
## sigma^2 estimated as 1235313:  log likelihood=-210.3
## AIC=424.59   AICc=425.14   BIC=427.03
## 
## Training set error measures:
##                    ME    RMSE     MAE         MPE     MAPE      MASE
## Training set 6.362663 994.108 699.696 -0.07692376 1.730501 0.6551461
##                     ACF1
## Training set -0.07256362

checkresiduals(arimamodel_women)

## 
##  Ljung-Box test
## 
## data:  Residuals from ARIMA(0,0,0)(0,1,0)[5] with drift
## Q* = 5.4793, df = 5, p-value = 0.3602
## 
## Model df: 1.   Total lags used: 6

ggseasonplot(tbts_women)

An AR(p) model assumes that a time series Yt can be modelled by a linear function of the first p of its lagged values. Let’s first start to model a seasonal SAR(1) model with the dynlm package. Each year the salaries increase by a fixed amount and a part that is relative to the salary size. I will use the NeweyWest function from the Sandwich package throughout this post to get heteroskedasticity- and autocorrelation-consistent error estimates.

dynmodel_men <- dynlm(ts(salary) ~ L(ts(salary), 6), data = tb_men)

assess_model(dynmodel_men, time(tbts_men)[7:36], tb_men[7:36,], no_n = TRUE) 
## 
## Time series regression with "ts" data:
## Start = 7, End = 36
## 
## Call:
## dynlm(formula = ts(salary) ~ L(ts(salary), 6), data = tb_men)
## 
## Residuals:
##     Min      1Q  Median      3Q     Max 
## -5517.7  -371.7    48.9   418.0  2600.3 
## 
## Coefficients:
##                   Estimate Std. Error t value Pr(>|t|)    
## (Intercept)      4.339e+02  1.575e+03   0.275    0.785    
## L(ts(salary), 6) 1.009e+00  3.608e-02  27.980   <2e-16 ***
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
## 
## Residual standard error: 1522 on 28 degrees of freedom
## Multiple R-squared:  0.9655, Adjusted R-squared:  0.9642 
## F-statistic: 782.9 on 1 and 28 DF,  p-value: < 2.2e-16
## 
## 
## t test of coefficients:
## 
##                    Estimate Std. Error t value Pr(>|t|)    
## (Intercept)      4.3389e+02 1.8030e+03  0.2406   0.8116    
## L(ts(salary), 6) 1.0094e+00 4.3076e-02 23.4340   <2e-16 ***
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1

## 
##  Breusch-Godfrey test for serial correlation of order up to 6
## 
## data:  Residuals
## LM test = 9.8199, df = 6, p-value = 0.1324


dynmodel_women <- dynlm(ts(salary) ~ L(ts(salary), 5), data = tb_women)

assess_model(dynmodel_women, time(tbts_women)[6:30], tb_women[6:30,], no_n = TRUE)
## 
## Time series regression with "ts" data:
## Start = 6, End = 30
## 
## Call:
## dynlm(formula = ts(salary) ~ L(ts(salary), 5), data = tb_women)
## 
## Residuals:
##     Min      1Q  Median      3Q     Max 
## -2266.8  -683.0  -148.9   501.2  3157.1 
## 
## Coefficients:
##                   Estimate Std. Error t value Pr(>|t|)    
## (Intercept)      1.323e+02  1.316e+03   0.101    0.921    
## L(ts(salary), 5) 1.020e+00  3.206e-02  31.816   <2e-16 ***
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
## 
## Residual standard error: 1126 on 23 degrees of freedom
## Multiple R-squared:  0.9778, Adjusted R-squared:  0.9768 
## F-statistic:  1012 on 1 and 23 DF,  p-value: < 2.2e-16
## 
## 
## t test of coefficients:
## 
##                    Estimate Std. Error t value Pr(>|t|)    
## (Intercept)      1.3234e+02 1.1458e+03  0.1155   0.9091    
## L(ts(salary), 5) 1.0200e+00 2.9112e-02 35.0356   <2e-16 ***
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1

## 
##  Breusch-Godfrey test for serial correlation of order up to 5
## 
## data:  Residuals
## LM test = 4.8683, df = 5, p-value = 0.4322

Now also add weights according to the number of engineers in the different strata. Note that the dynamic approach uses the information from the first year to predict the second. Weights from the first year have to be excluded. The fixed amount has decreased from 434 to 134 SEK and the relative part has increased from 0.94 % to 1.6 %. The fixed part is not statistically significant in either of these two models.

dynmodel_men <- dynlm(ts(salary) ~ L(ts(salary), 6), data = tb_men, weights = n[7:36])

assess_model(dynmodel_men, time(tbts_men)[7:36], tb_men[7:36,])
## 
## Time series regression with "ts" data:
## Start = 7, End = 36
## 
## Call:
## dynlm(formula = ts(salary) ~ L(ts(salary), 6), data = tb_men, 
##     weights = n[7:36])
## 
## Weighted Residuals:
##     Min      1Q  Median      3Q     Max 
## -164527  -12301       0   48694  129992 
## 
## Coefficients:
##                   Estimate Std. Error t value Pr(>|t|)    
## (Intercept)      1.343e+02  1.083e+03   0.124    0.902    
## L(ts(salary), 6) 1.016e+00  2.398e-02  42.392   <2e-16 ***
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
## 
## Residual standard error: 75460 on 21 degrees of freedom
## Multiple R-squared:  0.9884, Adjusted R-squared:  0.9879 
## F-statistic:  1797 on 1 and 21 DF,  p-value: < 2.2e-16
## 
## 
## t test of coefficients:
## 
##                   Estimate Std. Error t value Pr(>|t|)    
## (Intercept)      134.30571  856.80707  0.1568   0.8769    
## L(ts(salary), 6)   1.01643    0.01883 53.9780   <2e-16 ***
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1

## 
##  Breusch-Godfrey test for serial correlation of order up to 6
## 
## data:  Residuals
## LM test = 9.8199, df = 6, p-value = 0.1324


dynmodel_women <- dynlm(ts(salary) ~ L(ts(salary), 5), data = tb_women, weights = n[6:30])

assess_model(dynmodel_women, time(tbts_women)[6:30], tb_women[6:30,])
## 
## Time series regression with "ts" data:
## Start = 6, End = 30
## 
## Call:
## dynlm(formula = ts(salary) ~ L(ts(salary), 5), data = tb_women, 
##     weights = n[6:30])
## 
## Weighted Residuals:
##     Min      1Q  Median      3Q     Max 
## -106359  -30874       0   33627  144325 
## 
## Coefficients:
##                    Estimate Std. Error t value Pr(>|t|)    
## (Intercept)      -735.01210 1575.94230  -0.466    0.646    
## L(ts(salary), 5)    1.03745    0.03693  28.089   <2e-16 ***
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
## 
## Residual standard error: 60090 on 21 degrees of freedom
## Multiple R-squared:  0.9741, Adjusted R-squared:  0.9728 
## F-statistic:   789 on 1 and 21 DF,  p-value: < 2.2e-16
## 
## 
## t test of coefficients:
## 
##                     Estimate  Std. Error t value Pr(>|t|)    
## (Intercept)      -735.012099  708.461714 -1.0375   0.3113    
## L(ts(salary), 5)    1.037452    0.014893 69.6602   <2e-16 ***
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1

## 
##  Breusch-Godfrey test for serial correlation of order up to 5
## 
## data:  Residuals
## LM test = 4.8683, df = 5, p-value = 0.4322

Let’s drop the non-significant intercept. The relative salary raise increases to 1,94 % per year for men and 2,03 % for women.

dynmodel_men <- dynlm(ts(salary) ~ L(ts(salary), 6) - 1, data = tb_men, weights = n[7:36])

assess_model(dynmodel_men, time(tbts_men)[7:36], tb_men[7:36,])
## 
## Time series regression with "ts" data:
## Start = 7, End = 36
## 
## Call:
## dynlm(formula = ts(salary) ~ L(ts(salary), 6) - 1, data = tb_men, 
##     weights = n[7:36])
## 
## Weighted Residuals:
##     Min      1Q  Median      3Q     Max 
## -165299   -8902       0   47573  133181 
## 
## Coefficients:
##                  Estimate Std. Error t value Pr(>|t|)    
## L(ts(salary), 6) 1.019380   0.002739   372.1   <2e-16 ***
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
## 
## Residual standard error: 73750 on 22 degrees of freedom
## Multiple R-squared:  0.9998, Adjusted R-squared:  0.9998 
## F-statistic: 1.385e+05 on 1 and 22 DF,  p-value: < 2.2e-16
## 
## 
## t test of coefficients:
## 
##                   Estimate Std. Error t value  Pr(>|t|)    
## L(ts(salary), 6) 1.0193798  0.0020172  505.35 < 2.2e-16 ***
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1

## 
##  Breusch-Godfrey test for serial correlation of order up to 6
## 
## data:  Residuals
## LM test = 9.9529, df = 6, p-value = 0.1266


dynmodel_women <- dynlm(ts(salary) ~ L(ts(salary),5) - 1, data = tb_women, weights = n[6:30])

assess_model(dynmodel_women, time(tbts_women)[6:30], tb_women[6:30,])
## 
## Time series regression with "ts" data:
## Start = 6, End = 30
## 
## Call:
## dynlm(formula = ts(salary) ~ L(ts(salary), 5) - 1, data = tb_women, 
##     weights = n[6:30])
## 
## Weighted Residuals:
##     Min      1Q  Median      3Q     Max 
## -103209  -32580       0   36088  146345 
## 
## Coefficients:
##                  Estimate Std. Error t value Pr(>|t|)    
## L(ts(salary), 5) 1.020343   0.004217   241.9   <2e-16 ***
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
## 
## Residual standard error: 59020 on 22 degrees of freedom
## Multiple R-squared:  0.9996, Adjusted R-squared:  0.9996 
## F-statistic: 5.853e+04 on 1 and 22 DF,  p-value: < 2.2e-16
## 
## 
## t test of coefficients:
## 
##                   Estimate Std. Error t value  Pr(>|t|)    
## L(ts(salary), 5) 1.0203429  0.0035569  286.86 < 2.2e-16 ***
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1

## 
##  Breusch-Godfrey test for serial correlation of order up to 5
## 
## data:  Residuals
## LM test = 4.9459, df = 5, p-value = 0.4225

Now, let’s compare with a linear model. The relative salary raise increases to 1,92 % per year for men and 2.06 % for women.

model_men <- lm(log(salary) ~ year_n + age_n + I(age_n^2), data = tb_men, weights = n)

assess_model(model_men, time(tbts_men), tb_men, doexp = TRUE)
## 
## Call:
## lm(formula = log(salary) ~ year_n + age_n + I(age_n^2), data = tb_men, 
##     weights = n)
## 
## Weighted Residuals:
##     Min      1Q  Median      3Q     Max 
## -3.5386 -0.1234  0.0000  0.7387  2.7634 
## 
## Coefficients:
##               Estimate Std. Error t value Pr(>|t|)    
## (Intercept) -2.925e+01  3.086e+00  -9.479 2.08e-09 ***
## year_n       1.917e-02  1.530e-03  12.534 9.23e-12 ***
## age_n        5.160e-02  2.286e-03  22.569  < 2e-16 ***
## I(age_n^2)  -4.670e-04  2.581e-05 -18.094 4.24e-15 ***
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
## 
## Residual standard error: 1.694 on 23 degrees of freedom
## Multiple R-squared:  0.9898, Adjusted R-squared:  0.9885 
## F-statistic: 746.4 on 3 and 23 DF,  p-value: < 2.2e-16
## 
## 
## t test of coefficients:
## 
##                Estimate  Std. Error t value  Pr(>|t|)    
## (Intercept) -2.9252e+01  1.8119e+00 -16.145 4.852e-14 ***
## year_n       1.9171e-02  9.0239e-04  21.244 < 2.2e-16 ***
## age_n        5.1595e-02  1.6460e-03  31.347 < 2.2e-16 ***
## I(age_n^2)  -4.6705e-04  1.7897e-05 -26.097 < 2.2e-16 ***
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1

## 
##  Breusch-Godfrey test for serial correlation of order up to 7
## 
## data:  Residuals
## LM test = 6.7232, df = 7, p-value = 0.4583
## Don't know how to automatically pick scale for object of type ts. Defaulting to continuous.


model_women <- lm(log(salary) ~ year_n + age_n + I(age_n^2), data = tb_women, weights = n)

assess_model(model_women, time(tbts_women), tb_women, doexp = TRUE)
## 
## Call:
## lm(formula = log(salary) ~ year_n + age_n + I(age_n^2), data = tb_women, 
##     weights = n)
## 
## Weighted Residuals:
##      Min       1Q   Median       3Q      Max 
## -2.31829 -0.34720  0.05136  0.89951  2.33846 
## 
## Coefficients:
##               Estimate Std. Error t value Pr(>|t|)    
## (Intercept) -3.228e+01  4.347e+00  -7.427 1.50e-07 ***
## year_n       2.063e-02  2.154e-03   9.580 1.71e-09 ***
## age_n        5.521e-02  3.330e-03  16.577 2.77e-14 ***
## I(age_n^2)  -5.202e-04  3.912e-05 -13.298 2.77e-12 ***
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
## 
## Residual standard error: 1.288 on 23 degrees of freedom
## Multiple R-squared:  0.9798, Adjusted R-squared:  0.9771 
## F-statistic: 371.4 on 3 and 23 DF,  p-value: < 2.2e-16
## 
## 
## t test of coefficients:
## 
##                Estimate  Std. Error  t value  Pr(>|t|)    
## (Intercept) -3.2285e+01  3.9562e+00  -8.1605 3.045e-08 ***
## year_n       2.0631e-02  1.9667e-03  10.4903 3.075e-10 ***
## age_n        5.5206e-02  2.7439e-03  20.1196 4.246e-16 ***
## I(age_n^2)  -5.2025e-04  3.3832e-05 -15.3777 1.357e-13 ***
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1

## 
##  Breusch-Godfrey test for serial correlation of order up to 7
## 
## data:  Residuals
## LM test = 11.678, df = 7, p-value = 0.1117
## Don't know how to automatically pick scale for object of type ts. Defaulting to continuous.

Now also add the SAR(2). The summary shows that the R-squared bumps up a few notches for men, although it does not show that the second year lag is significant. However, the sandwich package assures us that the SAR(2) process is significant at the 95 % level. For women, the second year lag is not significant in the summary nor the HAC error estimate.

dynmodel_men <- dynlm(ts(salary) ~ L(ts(salary), 6) + L(ts(salary), 12) - 1, data = tb_men, weights = n[13:36])

assess_model(dynmodel_men, time(tbts_men)[13:36], tb_men[13:36,]) 
## 
## Time series regression with "ts" data:
## Start = 13, End = 36
## 
## Call:
## dynlm(formula = ts(salary) ~ L(ts(salary), 6) + L(ts(salary), 
##     12) - 1, data = tb_men, weights = n[13:36])
## 
## Weighted Residuals:
##     Min      1Q  Median      3Q     Max 
## -127942  -17989       0   42788  123721 
## 
## Coefficients:
##                   Estimate Std. Error t value Pr(>|t|)   
## L(ts(salary), 6)    0.7282     0.2371   3.071  0.00692 **
## L(ts(salary), 12)   0.2985     0.2417   1.235  0.23356   
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
## 
## Residual standard error: 69840 on 17 degrees of freedom
## Multiple R-squared:  0.9999, Adjusted R-squared:  0.9999 
## F-statistic: 6.4e+04 on 2 and 17 DF,  p-value: < 2.2e-16
## 
## 
## t test of coefficients:
## 
##                   Estimate Std. Error t value  Pr(>|t|)    
## L(ts(salary), 6)   0.72822    0.11497  6.3338 7.484e-06 ***
## L(ts(salary), 12)  0.29855    0.11741  2.5427   0.02102 *  
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1

## 
##  Breusch-Godfrey test for serial correlation of order up to 5
## 
## data:  Residuals
## LM test = 3.9255, df = 5, p-value = 0.5602


dynmodel_women <- dynlm(ts(salary) ~ L(ts(salary), 5) + L(ts(salary), 10) - 1, data = tb_women, weights = n[11:30])

summary (dynmodel_women)
## 
## Time series regression with "ts" data:
## Start = 11, End = 30
## 
## Call:
## dynlm(formula = ts(salary) ~ L(ts(salary), 5) + L(ts(salary), 
##     10) - 1, data = tb_women, weights = n[11:30])
## 
## Weighted Residuals:
##     Min      1Q  Median      3Q     Max 
## -110096  -37862   -1787   33549  134747 
## 
## Coefficients:
##                   Estimate Std. Error t value Pr(>|t|)    
## L(ts(salary), 5)   0.96703    0.23193   4.169 0.000723 ***
## L(ts(salary), 10)  0.05749    0.23683   0.243 0.811298    
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
## 
## Residual standard error: 63340 on 16 degrees of freedom
## Multiple R-squared:  0.9996, Adjusted R-squared:  0.9996 
## F-statistic: 2.14e+04 on 2 and 16 DF,  p-value: < 2.2e-16

coeftest(dynmodel_women, vcov = NeweyWest, prewhite = F, adjust = T)
## 
## t test of coefficients:
## 
##                   Estimate Std. Error t value  Pr(>|t|)    
## L(ts(salary), 5)  0.967032   0.122156  7.9164 6.354e-07 ***
## L(ts(salary), 10) 0.057485   0.125308  0.4588    0.6526    
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1

Estimating causal effects from aggregated data

Tue, 18 May 2021 00:00:00 +0000

The publically available datasets from Statistics Sweden are aggregated tables. Groups with fewer than five records are filtered out not to have any individual data being made public.

In this post, I am going to investigate with what precision it is possible to estimate the causal effect of predictors using aggregated data. I will use the dataset CPS1988 which is contained in the AER library. Cross-section data originating from the March 1988 Current Population Survey by the US Census Bureau.

I will estimate the average treatment effect on wage for ethnicity and experience respectively. I will subclassify the predictors’ education and experience. I will balance on the observed confounders and make no attempts to handle unobserved covariates. I will not try to draw any conclusions on causal effects based on SUTVA assumptions.

First, define libraries and functions.

library (tidyverse)
## -- Attaching packages --------------------------------------- tidyverse 1.3.1 --
## v ggplot2 3.3.3     v purrr   0.3.4
## v tibble  3.1.0     v dplyr   1.0.5
## v tidyr   1.1.3     v stringr 1.4.0
## v readr   1.4.0     v forcats 0.5.1
## Warning: package 'ggplot2' was built under R version 4.0.3
## Warning: package 'tibble' was built under R version 4.0.5
## Warning: package 'tidyr' was built under R version 4.0.5
## Warning: package 'readr' was built under R version 4.0.3
## Warning: package 'dplyr' was built under R version 4.0.5
## Warning: package 'forcats' was built under R version 4.0.3
## -- Conflicts ------------------------------------------ tidyverse_conflicts() --
## x dplyr::filter() masks stats::filter()
## x dplyr::lag()    masks stats::lag()
library (AER)
## Warning: package 'AER' was built under R version 4.0.5
## Loading required package: car
## Warning: package 'car' was built under R version 4.0.3
## Loading required package: carData
## Warning: package 'carData' was built under R version 4.0.3
## 
## Attaching package: 'car'
## The following object is masked from 'package:dplyr':
## 
##     recode
## The following object is masked from 'package:purrr':
## 
##     some
## Loading required package: lmtest
## Warning: package 'lmtest' was built under R version 4.0.4
## Loading required package: zoo
## Warning: package 'zoo' was built under R version 4.0.5
## 
## Attaching package: 'zoo'
## The following objects are masked from 'package:base':
## 
##     as.Date, as.Date.numeric
## Loading required package: sandwich
## Warning: package 'sandwich' was built under R version 4.0.3
## Loading required package: survival
## Warning: package 'survival' was built under R version 4.0.5
library (bnlearn)
## Warning: package 'bnlearn' was built under R version 4.0.3
library (PerformanceAnalytics)
## Loading required package: xts
## Warning: package 'xts' was built under R version 4.0.3
## 
## Attaching package: 'xts'
## The following objects are masked from 'package:dplyr':
## 
##     first, last
## 
## Attaching package: 'PerformanceAnalytics'
## The following object is masked from 'package:graphics':
## 
##     legend
library (tableone)
## Warning: package 'tableone' was built under R version 4.0.4
library (Matching)
## Warning: package 'Matching' was built under R version 4.0.5
## Loading required package: MASS
## 
## Attaching package: 'MASS'
## The following object is masked from 'package:dplyr':
## 
##     select
## ## 
## ##  Matching (Version 4.9-9, Build Date: 2021-03-15)
## ##  See http://sekhon.berkeley.edu/matching for additional documentation.
## ##  Please cite software as:
## ##   Jasjeet S. Sekhon. 2011. ``Multivariate and Propensity Score Matching
## ##   Software with Automated Balance Optimization: The Matching package for R.''
## ##   Journal of Statistical Software, 42(7): 1-52. 
## ##
library (WeightIt)
## Warning: package 'WeightIt' was built under R version 4.0.5
library (lavaan)
## Warning: package 'lavaan' was built under R version 4.0.5
## This is lavaan 0.6-8
## lavaan is FREE software! Please report any bugs.
library (tidySEM)
## Registered S3 methods overwritten by 'tidySEM':
##   method              from           
##   print.mplus.model   MplusAutomation
##   print.mplusObject   MplusAutomation
##   summary.mplus.model MplusAutomation
## 
## Attaching package: 'tidySEM'
## The following objects are masked from 'package:bnlearn':
## 
##     nodes, nodes<-
library (cobalt)
## Warning: package 'cobalt' was built under R version 4.0.4
##  cobalt (Version 4.3.1, Build Date: 2021-03-30 09:50:18 UTC)
library (jtools)
## Warning: package 'jtools' was built under R version 4.0.5
## 
## Attaching package: 'jtools'
## The following object is masked from 'package:tidySEM':
## 
##     get_data

# Argument: Vector with binned values; Value: Numeric vector where each value is the mean of the binwidth
unbin_bin <- function(x){
  unbin_x <- function(x) (parse_number(unlist(strsplit(as.character(x), ",")))[1] + parse_number(unlist(strsplit(as.character(x), ",")))[2])/2

  unlist(map(x, unbin_x))
}

data(CPS1988)

CPS1988_n <- CPS1988 %>%
  mutate(education = as.numeric(education)) %>%
  mutate(experience = as.numeric(experience)) %>%
  mutate(region = as.numeric(region)) %>%
  mutate(smsa = as.numeric(smsa)) %>%
  mutate(parttime = as.numeric(parttime)) %>%
  mutate(ethnicity = as.numeric(ethnicity))

The correlation chart shows that many predictors are correlated with the response variable but also that many predictors are correlated with each other.

chart.Correlation(CPS1988_n, histogram = TRUE, pch = 19)

A Directed Ascyclical Graph (DAG) is a useful tool to identify backdoor paths, confounders, mediators and colliders. A DAG is usually constructed by expert knowledge in the problem domain. There are also algorithms for Bayesian networks that can estimate a DAG based on the statistical properties of the data, these estimations need to be validated against expert knowledge. I will estimate a DAG using a Bayesian network, the Hill Climbing (HC) algorithm.

hcmodel <- hc(CPS1988 %>%
  mutate(education = as.numeric(education)) %>%
  mutate(experience = as.numeric(experience)))

plot(hcmodel)

Structural Equation Modeling (SEM) is a tool to represent a system of regressions. I will use Lavaan to represent the DAG from the Bayesian network above.

semmodel = '
  education ~ wage
  wage ~ parttime
  experience ~ wage
  experience ~ parttime
  wage ~ ethnicity
  region ~ ethnicity
  region ~ smsa
  wage ~ smsa
  wage ~ region
  education ~ region
  education ~ parttime
  education ~ smsa
  smsa ~ ethnicity
  experience ~ education
  experience ~ ethnicity
  parttime ~ ethnicity
  '

semfit <- sem(semmodel,
  data =  CPS1988_n)
## Warning in lav_data_full(data = data, group = group, cluster = cluster, : lavaan
## WARNING: some observed variances are (at least) a factor 1000 times larger than
## others; use varTable(fit) to investigate

graph_sem(model = semfit)

Since ethnicity is a binary variable I will use the Match algorithm to find individuals that are as similar as possible from the two groups African American and Caucasian. I will do a greedy matching based on Mahalanobis distance.

xvars <- c("education", "experience", "smsa", "region", "parttime")

print(CreateTableOne(vars = xvars, strata = "ethnicity", data = CPS1988, test = FALSE), smd = TRUE)
##                         Stratified by ethnicity
##                          cauc          afam          SMD   
##   n                      25923          2232               
##   education (mean (SD))  13.13 (2.90)  12.33 (2.77)   0.284
##   experience (mean (SD)) 18.15 (13.04) 18.74 (13.51)  0.044
##   smsa = yes (%)         19095 (73.7)   1837 (82.3)   0.210
##   region (%)                                          0.644
##      northeast            6073 (23.4)    368 (16.5)        
##      midwest              6486 (25.0)    377 (16.9)        
##      south                7468 (28.8)   1292 (57.9)        
##      west                 5896 (22.7)    195 ( 8.7)        
##   parttime = yes (%)      2280 ( 8.8)    244 (10.9)   0.072

greedymatch <- Match(Tr = as.integer(CPS1988$ethnicity) - 1, M = 1, X = data.frame(data.matrix(CPS1988[xvars])), replace = FALSE)

matched <- CPS1988[unlist(greedymatch[c("index.treated", "index.control")]), ]

print(CreateTableOne(vars = xvars, strata = "ethnicity", data = matched, test = FALSE), smd = TRUE)
##                         Stratified by ethnicity
##                          cauc          afam          SMD   
##   n                       2232          2232               
##   education (mean (SD))  12.33 (2.76)  12.33 (2.77)   0.001
##   experience (mean (SD)) 18.71 (13.44) 18.74 (13.51)  0.003
##   smsa = yes (%)          1837 (82.3)   1837 (82.3)  <0.001
##   region (%)                                          0.003
##      northeast             368 (16.5)    368 (16.5)        
##      midwest               375 (16.8)    377 (16.9)        
##      south                1293 (57.9)   1292 (57.9)        
##      west                  196 ( 8.8)    195 ( 8.7)        
##   parttime = yes (%)       244 (10.9)    244 (10.9)  <0.001

matched <- matched %>% mutate(ethnicity_n = as.integer(ethnicity) - 1)

t.test(matched$wage[matched$ethnicity_n == 1] - matched$wage[matched$ethnicity_n == 0])
## 
##  One Sample t-test
## 
## data:  matched$wage[matched$ethnicity_n == 1] - matched$wage[matched$ethnicity_n == 0]
## t = -12.989, df = 2231, p-value < 2.2e-16
## alternative hypothesis: true mean is not equal to 0
## 95 percent confidence interval:
##  -131.18979  -96.77381
## sample estimates:
## mean of x 
## -113.9818

Another way to estimate the causal effect of ethnicity on wage is by calculating the propensity score. By regressing on the treatment, i.e. the variable that we want to calculate the effect for, we can reduce the selection bias by balancing on the covariates. Below you can see the balancing before and after using the propensity score.

W.out <- weightit(ethnicity ~ education + experience + smsa + region + parttime, 
  data = CPS1988, method = "ebal")

model_lm_ethnicity <- lm(wage ~ ethnicity, data = CPS1988, weights = W.out$weights)

bal.tab(ethnicity ~ education + experience + smsa + region + parttime, 
  data = CPS1988, estimand = "ATT", m.threshold = .05)
## Balance Measures
##                     Type Diff.Un      M.Threshold.Un
## education        Contin. -0.2909 Not Balanced, >0.05
## experience       Contin.  0.0435     Balanced, <0.05
## smsa_yes          Binary  0.0864 Not Balanced, >0.05
## region_northeast  Binary -0.0694 Not Balanced, >0.05
## region_midwest    Binary -0.0813 Not Balanced, >0.05
## region_south      Binary  0.2908 Not Balanced, >0.05
## region_west       Binary -0.1401 Not Balanced, >0.05
## parttime_yes      Binary  0.0214     Balanced, <0.05
## 
## Balance tally for mean differences
##                     count
## Balanced, <0.05         2
## Not Balanced, >0.05     6
## 
## Variable with the greatest mean difference
##   Variable Diff.Un      M.Threshold.Un
##  education -0.2909 Not Balanced, >0.05
## 
## Sample sizes
##      cauc afam
## All 25923 2232

bal.tab(W.out, m.threshold = .05, disp.v.ratio = TRUE)
## Call
##  weightit(formula = ethnicity ~ education + experience + smsa + 
##     region + parttime, data = CPS1988, method = "ebal")
## 
## Balance Measures
##                     Type Diff.Adj     M.Threshold V.Ratio.Adj
## education        Contin.   0.0001 Balanced, <0.05      0.7731
## experience       Contin.   0.0000 Balanced, <0.05      0.9613
## smsa_yes          Binary   0.0000 Balanced, <0.05           .
## region_northeast  Binary   0.0000 Balanced, <0.05           .
## region_midwest    Binary  -0.0000 Balanced, <0.05           .
## region_south      Binary  -0.0000 Balanced, <0.05           .
## region_west       Binary  -0.0000 Balanced, <0.05           .
## parttime_yes      Binary   0.0001 Balanced, <0.05           .
## 
## Balance tally for mean differences
##                     count
## Balanced, <0.05         8
## Not Balanced, >0.05     0
## 
## Variable with the greatest mean difference
##   Variable Diff.Adj     M.Threshold
##  education   0.0001 Balanced, <0.05
## 
## Effective sample sizes
##                cauc   afam
## Unadjusted 25923.   2232. 
## Adjusted   25833.39 1233.1

Estimate the causal effect of experience on wage by calculating the propensity score.

W.out <- weightit(experience ~ ethnicity + education + smsa + region + parttime,
  data = CPS1988, method = "ebal")

model_lm_experience <- lm(wage ~ experience, data = CPS1988, weights = W.out$weights)

bal.tab(experience  ~ ethnicity + education + smsa + region + parttime,
  data = CPS1988, estimand = "ATT", m.threshold = .05)
## Balance Measures
##                     Type Corr.Un
## ethnicity_afam    Binary  0.0121
## education        Contin. -0.2867
## smsa_yes          Binary -0.0397
## region_northeast  Binary  0.0251
## region_midwest    Binary -0.0166
## region_south      Binary  0.0114
## region_west       Binary -0.0212
## parttime_yes      Binary -0.0942
## 
## Sample sizes
##     Total
## All 28155

bal.tab(W.out, m.threshold = .05, disp.v.ratio = TRUE)
## Call
##  weightit(formula = experience ~ ethnicity + education + smsa + 
##     region + parttime, data = CPS1988, method = "ebal")
## 
## Balance Measures
##                     Type Corr.Adj Diff.Adj     M.Threshold
## ethnicity_afam    Binary       -0       -0 Balanced, <0.05
## education        Contin.       -0        0 Balanced, <0.05
## smsa_yes          Binary       -0       -0 Balanced, <0.05
## region_northeast  Binary        0        0 Balanced, <0.05
## region_midwest    Binary        0        0 Balanced, <0.05
## region_south      Binary       -0       -0 Balanced, <0.05
## region_west       Binary       -0       -0 Balanced, <0.05
## parttime_yes      Binary        0        0 Balanced, <0.05
## 
## Balance tally for target mean differences
##                     count
## Balanced, <0.05         8
## Not Balanced, >0.05     0
## 
## Variable with the greatest target mean difference
##   Variable Diff.Adj     M.Threshold
##  education        0 Balanced, <0.05
## 
## Effective sample sizes
##               Total
## Unadjusted 28155.  
## Adjusted   25793.54

Let’s now investigate how aggregating the numerical predictors in the data affects the precision when estimating the causal effect on wage. I will also filter out groups with less than 5 persons in them so that any individual can not be identified in the material. The binning and filtering reduces the original dataset by 98.9 %. By expanding the reduced dataset the original dataset can be estimated.

CPS1988_refi <- CPS1988 %>%
  mutate(education = as.numeric(education)) %>%
  mutate(experience = as.numeric(experience)) %>%
  mutate(education = cut_interval(education, 5)) %>%
  mutate(experience = cut_interval(experience, 5)) %>%
  group_by(education, experience, ethnicity, smsa, region, parttime) %>%
  mutate (wage = mean(wage)) %>%
  group_by(wage, education, experience, ethnicity, smsa, region, parttime) %>% 
  tally() %>%
  mutate(experience = unbin_bin(experience)) %>%
  mutate(education = unbin_bin(education)) %>%
  filter(n > 4)  

dim(CPS1988_refi)
## [1] 302   8

CPS1988_refiexp <- CPS1988_refi[rep(seq(nrow(CPS1988_refi)), CPS1988_refi$n),]

dim(CPS1988_refiexp) 
## [1] 27797     8

How has the reduction affected the DAG? It is not possible to use weights in the hc algorithm. Therefore I will use the expanded table based on the data in the aggregated table.

hcmodel_refiexp <- hc(dplyr::select(CPS1988_refiexp %>%
  mutate(education = as.numeric(education)) %>%
  mutate(experience = as.numeric(experience)), -n))

plot(hcmodel_refiexp)

For comparison, I will plot the coefficients for ethnicity for the linear model based on the original data, aggregated data and the expanded data. I will use robust (Heteroskedasticity-Consistent) error estimates.

model <- lm(wage ~ ethnicity, data = CPS1988)

model_refi <- lm(wage ~ ethnicity, data = CPS1988_refi, weights = n)

model_refiexp <- lm(wage ~ ethnicity, data = CPS1988_refiexp)

plot_summs(model, model_refi, model_refiexp, robust = "HC1", 
  model.names = c(
    "Original dataset", 
    "Reduced dataset using weights", 
    "Expanded dataset"))
## Loading required namespace: broom.mixed
## Warning in checkMatrixPackageVersion(): Package version inconsistency detected.
## TMB was built with Matrix version 1.3.2
## Current Matrix version is 1.2.18
## Please re-install 'TMB' from source using install.packages('TMB', type = 'source') or ask CRAN for a binary version of 'TMB' matching CRAN's 'Matrix' package

Now let’s estimate the causal effect of ethnicity on wage using propensity scores. I will use the expanded dataset since I did not get any reasonable results using the argument s.weights in weightit.

W.out <- weightit(ethnicity ~ education + experience + smsa + region + parttime,
  data = CPS1988_refiexp, method = "ebal")

model_refiexp <- lm(wage ~ ethnicity, data = CPS1988_refiexp, weights = W.out$weights)

coeftest(model_refiexp, vcov = vcovHC, type = "HC1")
## 
## t test of coefficients:
## 
##                Estimate Std. Error t value  Pr(>|t|)    
## (Intercept)    616.8706     1.4634 421.541 < 2.2e-16 ***
## ethnicityafam -133.7648     6.1773 -21.654 < 2.2e-16 ***
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1

bal.tab(ethnicity ~ education + experience + smsa + region + parttime,
  data = CPS1988_refiexp, estimand = "ATT", m.threshold = .05)
## Balance Measures
##                     Type Diff.Un      M.Threshold.Un
## education        Contin. -0.2050 Not Balanced, >0.05
## experience       Contin. -0.0567 Not Balanced, >0.05
## smsa_yes          Binary  0.0995 Not Balanced, >0.05
## region_northeast  Binary -0.0784 Not Balanced, >0.05
## region_midwest    Binary -0.0800 Not Balanced, >0.05
## region_south      Binary  0.3059 Not Balanced, >0.05
## region_west       Binary -0.1475 Not Balanced, >0.05
## parttime_yes      Binary -0.0052     Balanced, <0.05
## 
## Balance tally for mean differences
##                     count
## Balanced, <0.05         1
## Not Balanced, >0.05     7
## 
## Variable with the greatest mean difference
##      Variable Diff.Un      M.Threshold.Un
##  region_south  0.3059 Not Balanced, >0.05
## 
## Sample sizes
##      cauc afam
## All 25732 2065

bal.tab(W.out, m.threshold = .05, disp.v.ratio = TRUE)
## Call
##  weightit(formula = ethnicity ~ education + experience + smsa + 
##     region + parttime, data = CPS1988_refiexp, method = "ebal")
## 
## Balance Measures
##                     Type Diff.Adj     M.Threshold V.Ratio.Adj
## education        Contin.   0.0001 Balanced, <0.05      0.6710
## experience       Contin.   0.0000 Balanced, <0.05      0.8969
## smsa_yes          Binary   0.0000 Balanced, <0.05           .
## region_northeast  Binary   0.0000 Balanced, <0.05           .
## region_midwest    Binary   0.0001 Balanced, <0.05           .
## region_south      Binary  -0.0000 Balanced, <0.05           .
## region_west       Binary  -0.0001 Balanced, <0.05           .
## parttime_yes      Binary  -0.0000 Balanced, <0.05           .
## 
## Balance tally for mean differences
##                     count
## Balanced, <0.05         8
## Not Balanced, >0.05     0
## 
## Variable with the greatest mean difference
##        Variable Diff.Adj     M.Threshold
##  region_midwest   0.0001 Balanced, <0.05
## 
## Effective sample sizes
##               cauc    afam
## Unadjusted 25732.  2065.  
## Adjusted   25650.5 1094.35

plot_summs(model_lm_ethnicity, model_refiexp, scale = TRUE, robust = "HC1", 
  model.names = c(
    "Original dataset", 
    "Expanded dataset"))

Let’s compare the coefficients for experience for the linear model based on the original data, aggregated data and the expanded data.

model <- lm(wage ~ experience, data = CPS1988)

model_refi <- lm(wage ~ experience, data = CPS1988_refi, weights = n)

model_refiexp <- lm(wage ~ experience, data = CPS1988_refiexp)

plot_summs(model, model_refi, model_refiexp, robust = "HC1",
  model.names = c(
    "Original dataset", 
    "Reduced dataset using weights", 
    "Expanded dataset"))

Let’s estimate the causal effect of ethnicity on wage using propensity scores. I will use the expanded dataset since I did not get any reasonable results using the argument s.wights in weightit.

W.out <- weightit(experience ~ ethnicity + education + smsa + region + parttime,
  data = CPS1988_refiexp, method = "ebal")

model_refiexp <- lm(wage ~ experience, data = CPS1988_refiexp, weights = W.out$weights)

coeftest(model_refiexp, vcov = vcovHC, type = "HC1")
## 
## t test of coefficients:
## 
##              Estimate Std. Error t value  Pr(>|t|)    
## (Intercept) 452.45062    2.25958 200.237 < 2.2e-16 ***
## experience    8.60394    0.14098  61.029 < 2.2e-16 ***
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1

bal.tab(experience ~ ethnicity + education + smsa + region + parttime,
  data = CPS1988_refiexp, estimand = "ATT", m.threshold = .05)
## Balance Measures
##                     Type Corr.Un
## ethnicity_afam    Binary -0.0143
## education        Contin. -0.2736
## smsa_yes          Binary -0.0339
## region_northeast  Binary  0.0256
## region_midwest    Binary -0.0156
## region_south      Binary  0.0092
## region_west       Binary -0.0202
## parttime_yes      Binary -0.1072
## 
## Sample sizes
##     Total
## All 27797

bal.tab(W.out, m.threshold = .05, disp.v.ratio = TRUE)
## Call
##  weightit(formula = experience ~ ethnicity + education + smsa + 
##     region + parttime, data = CPS1988_refiexp, method = "ebal")
## 
## Balance Measures
##                     Type Corr.Adj Diff.Adj     M.Threshold
## ethnicity_afam    Binary       -0       -0 Balanced, <0.05
## education        Contin.       -0       -0 Balanced, <0.05
## smsa_yes          Binary       -0       -0 Balanced, <0.05
## region_northeast  Binary        0        0 Balanced, <0.05
## region_midwest    Binary        0        0 Balanced, <0.05
## region_south      Binary       -0       -0 Balanced, <0.05
## region_west       Binary       -0       -0 Balanced, <0.05
## parttime_yes      Binary        0       -0 Balanced, <0.05
## 
## Balance tally for target mean differences
##                     count
## Balanced, <0.05         8
## Not Balanced, >0.05     0
## 
## Variable with the greatest target mean difference
##   Variable Diff.Adj     M.Threshold
##  education       -0 Balanced, <0.05
## 
## Effective sample sizes
##               Total
## Unadjusted 27797.  
## Adjusted   25618.89

plot_summs(model_lm_experience, model_refiexp, robust = "HC1",
  model.names = c(
    "Original dataset", 
    "Expanded dataset"))

Per cent who are women in different occupational groups in Sweden, feature importance

Sun, 24 May 2020 00:00:00 +0000

In a previous post, I analysed the feature importance for the per cent of engineers in Sweden who are women. I found that the size of the region is a feature that is significant for the per cent of engineers in Sweden who are women. In this post, I will analyse the feature importance of different occupational groups in Sweden. I will use an ensemble of linear models in my analysis.

Statistics Sweden use NUTS (Nomenclature des Unités Territoriales Statistiques), which is the EU’s hierarchical regional division, to specify the regions.

Please send suggestions for improvement of the analysis to ranalystatisticssweden@gmail.com.

First, define libraries and functions.

library (tidyverse)

## -- Attaching packages -------------------------------------------------- tidyverse 1.3.0 --

## v ggplot2 3.3.0     v purrr   0.3.4
## v tibble  3.0.0     v dplyr   0.8.5
## v tidyr   1.0.2     v stringr 1.4.0
## v readr   1.3.1     v forcats 0.5.0

## -- Conflicts ----------------------------------------------------- tidyverse_conflicts() --
## x dplyr::filter() masks stats::filter()
## x dplyr::lag()    masks stats::lag()

library (broom)
library (car)

## Loading required package: carData

## 
## Attaching package: 'car'

## The following object is masked from 'package:dplyr':
## 
##     recode

## The following object is masked from 'package:purrr':
## 
##     some

library (caret)

## Loading required package: lattice

## 
## Attaching package: 'caret'

## The following object is masked from 'package:purrr':
## 
##     lift

library (recipes)

## 
## Attaching package: 'recipes'

## The following object is masked from 'package:stringr':
## 
##     fixed

## The following object is masked from 'package:stats':
## 
##     step

library (PerformanceAnalytics)

## Loading required package: xts

## Loading required package: zoo

## 
## Attaching package: 'zoo'

## The following objects are masked from 'package:base':
## 
##     as.Date, as.Date.numeric

## 
## Attaching package: 'xts'

## The following objects are masked from 'package:dplyr':
## 
##     first, last

## 
## Attaching package: 'PerformanceAnalytics'

## The following object is masked from 'package:graphics':
## 
##     legend

library (ggpubr)

## Loading required package: magrittr

## 
## Attaching package: 'magrittr'

## The following object is masked from 'package:purrr':
## 
##     set_names

## The following object is masked from 'package:tidyr':
## 
##     extract

library (ipred) 
library (iml)
library (SuperLearner)

## Loading required package: nnls

## Super Learner

## Version: 2.0-26

## Package created on 2019-10-27

library (scatterplot3d)

readfile <- function (file1){read_csv (file1, col_types = cols(), locale = readr::locale (encoding = "latin1"), na = c("..", "NA")) %>%
  gather (starts_with("19"), starts_with("20"), key = "year", value = groupsize) %>%
  drop_na() %>%
  mutate (year_n = parse_number (year))
}

perc_women <- function(x){  
  ifelse (length(x) == 2, x[2] / (x[1] + x[2]), NA)
} 

nuts <- read.csv("nuts.csv") %>%
  mutate(NUTS2_sh = substr(NUTS2, 3, 4))

nuts %>% 
  distinct (NUTS2_en) %>%
  knitr::kable(
    booktabs = TRUE,
    caption = 'Nomenclature des Unités Territoriales Statistiques (NUTS)')

Table 1: Nomenclature des Unités Territoriales Statistiques (NUTS)
NUTS2_en
SE11 Stockholm
SE12 East-Central Sweden
SE21 Småland and islands
SE22 South Sweden
SE23 West Sweden
SE31 North-Central Sweden
SE32 Central Norrland
SE33 Upper Norrland

SL.lm.caret <- function(..., method = "lm", tuneLength = 3, obsWeights = obsWeights, trControl = caret::trainControl(method = "cv", number = 10, verboseIter = FALSE)){
    suppressWarnings(SL.caret(..., obsWeights = obsWeights, method = method, tuneLength = tuneLength, trControl = trControl))
}

SL.lmStepAIC.caret <- function(..., method = "lmStepAIC", tuneLength = 3, obsWeights = obsWeights, trControl = caret::trainControl(method = "cv", number = 10, verboseIter = FALSE)){
    suppressWarnings(SL.caret(..., obsWeights = obsWeights, method = method, tuneLength = tuneLength, trControl = trControl))
}  

SL.bayesglm.caret <- function(..., method = "bayesglm", tuneLength = 3, obsWeights = obsWeights, trControl = caret::trainControl(method = "cv", number = 10, verboseIter = FALSE)){
    suppressWarnings(SL.caret(..., obsWeights = obsWeights, method = method, tuneLength = tuneLength, trControl = trControl))
}  

SL.rlm.caret <- function(..., method = "rlm", tuneLength = 3, obsWeights = obsWeights, trControl = caret::trainControl(method = "cv", number = 10, verboseIter = FALSE)){
    suppressWarnings(SL.caret(..., obsWeights = obsWeights, method = method, tuneLength = tuneLength, trControl = trControl))
}

The data tables are downloaded from Statistics Sweden. They are saved as a comma-delimited file without heading, UF0506A1.csv, http://www.statistikdatabasen.scb.se/pxweb/en/ssd/.

The tables:

UF0506A1_1.csv: Population 16-74 years of age by region, highest level of education, age and sex. Year 1985 - 2018 NUTS 2 level 2008- 10 year intervals (16-74)

000000CG_1: Average basic salary, monthly salary and women´s salary as a percentage of men´s salary by region, sector, occupational group (SSYK 2012) and sex. Year 2014 - 2018 Monthly salary All sectors.

000000CD_1.csv: Average basic salary, monthly salary and women´s salary as a percentage of men´s salary by region, sector, occupational group (SSYK 2012) and sex. Year 2014 - 2018 Number of employees All sectors.

The data is aggregated, the size of each group is in the column groupsize.

I have also included some calculated predictors from the original data.

perc_women: The percentage of women within each group defined by edulevel, region and year

perc_women_region: The percentage of women within each group defined by year and region

regioneduyears: The average number of education years per capita within each group defined by year and region

eduquotient: The quotient between regioneduyears for men and women

salaryquotient: The quotient between salary for men and women within each group defined by year and region

perc_women_eng_region: The percentage of women who are engineers within each group defined by year and region

numedulevel <- read.csv("edulevel_1.csv") 

numedulevel[, 2] <- data.frame(c(8, 9, 10, 12, 13, 15, 22, NA))

tb <- readfile("000000CG_1.csv") 
tb <- readfile("000000CD_1.csv") %>% 
  left_join(tb, by = c("region", "year", "sex", "sector","occuptional  (SSYK 2012)")) 

tb <- readfile("UF0506A1_1.csv") %>%  
  right_join(tb, by = c("region", "year", "sex")) %>%
  right_join(numedulevel, by = c("level of education" = "level.of.education")) %>%
  filter(!is.na(eduyears)) %>%  
  mutate(edulevel = `level of education`) %>%
  group_by(edulevel, region, year, sex, `occuptional  (SSYK 2012)`) %>%
  mutate(groupsize_all_ages = sum(groupsize)) %>%  
  group_by(edulevel, region, year, `occuptional  (SSYK 2012)`) %>% 
  mutate (perc_women = perc_women (groupsize_all_ages[1:2])) %>% 
  mutate (suming = sum(groupsize.x)) %>%
  mutate (salary = (groupsize.y[2] * groupsize.x[2] + groupsize.y[1] * groupsize.x[1])/(groupsize.x[2] + groupsize.x[1])) %>%
  group_by (sex, year, region, `occuptional  (SSYK 2012)`) %>%
  mutate(regioneduyears_sex = sum(groupsize * eduyears) / sum(groupsize)) %>%
  mutate(regiongroupsize = sum(groupsize)) %>% 
  mutate(suming_sex = groupsize.x) %>%
  group_by(region, year, `occuptional  (SSYK 2012)`) %>%
  mutate (sum_pop = sum(groupsize)) %>%
  mutate (regioneduyears = sum(groupsize * eduyears) / sum(groupsize)) %>%
  mutate (perc_women_region = perc_women (regiongroupsize[1:2])) %>% 
  mutate (eduquotient = regioneduyears_sex[2] / regioneduyears_sex[1]) %>% 
  mutate (salary_sex = groupsize.y) %>%
  mutate (salaryquotient = salary_sex[2] / salary_sex[1]) %>%   
  mutate (perc_women_eng_region = perc_women(suming_sex[1:2])) %>%  
  left_join(nuts %>% distinct (NUTS2_en, NUTS2_sh), by = c("region" = "NUTS2_en")) %>%
  drop_na()

summary(tb)

##     region              age            level of education     sex           
##  Length:29050       Length:29050       Length:29050       Length:29050      
##  Class :character   Class :character   Class :character   Class :character  
##  Mode  :character   Mode  :character   Mode  :character   Mode  :character  
##                                                                             
##                                                                             
##                                                                             
##      year             groupsize          year_n        sector         
##  Length:29050       Min.   :   405   Min.   :2014   Length:29050      
##  Class :character   1st Qu.: 25412   1st Qu.:2015   Class :character  
##  Mode  :character   Median : 61291   Median :2016   Mode  :character  
##                     Mean   : 71345   Mean   :2016                     
##                     3rd Qu.:113524   3rd Qu.:2017                     
##                     Max.   :271889   Max.   :2018                     
##  occuptional  (SSYK 2012)  groupsize.x       year_n.x     groupsize.y    
##  Length:29050             Min.   :  100   Min.   :2014   Min.   : 20200  
##  Class :character         1st Qu.:  490   1st Qu.:2015   1st Qu.: 28900  
##  Mode  :character         Median : 1300   Median :2016   Median : 33900  
##                           Mean   : 3258   Mean   :2016   Mean   : 37066  
##                           3rd Qu.: 3400   3rd Qu.:2017   3rd Qu.: 42100  
##                           Max.   :45000   Max.   :2018   Max.   :133600  
##     year_n.y       eduyears       edulevel         groupsize_all_ages
##  Min.   :2014   Min.   : 8.00   Length:29050       Min.   :   405    
##  1st Qu.:2015   1st Qu.: 9.00   Class :character   1st Qu.: 25412    
##  Median :2016   Median :12.00   Mode  :character   Median : 61291    
##  Mean   :2016   Mean   :12.71                      Mean   : 71345    
##  3rd Qu.:2017   3rd Qu.:15.00                      3rd Qu.:113524    
##  Max.   :2018   Max.   :22.00                      Max.   :271889    
##    perc_women         suming          salary       regioneduyears_sex
##  Min.   :0.3575   Min.   :  240   Min.   : 20661   Min.   :11.18     
##  1st Qu.:0.4343   1st Qu.: 1330   1st Qu.: 29046   1st Qu.:11.63     
##  Median :0.4655   Median : 3100   Median : 34041   Median :11.78     
##  Mean   :0.4775   Mean   : 6515   Mean   : 37105   Mean   :11.83     
##  3rd Qu.:0.5132   3rd Qu.: 7400   3rd Qu.: 42068   3rd Qu.:12.09     
##  Max.   :0.6423   Max.   :60000   Max.   :113976   Max.   :12.55     
##  regiongroupsize    suming_sex       sum_pop        regioneduyears 
##  Min.   :128262   Min.   :  100   Min.   : 262870   Min.   :11.39  
##  1st Qu.:292864   1st Qu.:  490   1st Qu.: 596546   1st Qu.:11.56  
##  Median :528643   Median : 1300   Median :1057419   Median :11.82  
##  Mean   :499413   Mean   : 3258   Mean   : 998826   Mean   :11.83  
##  3rd Qu.:708813   3rd Qu.: 3400   3rd Qu.:1417931   3rd Qu.:11.93  
##  Max.   :827940   Max.   :45000   Max.   :1655215   Max.   :12.41  
##  perc_women_region  eduquotient      salary_sex     salaryquotient  
##  Min.   :0.4831    Min.   :1.019   Min.   : 20200   Min.   :0.6423  
##  1st Qu.:0.4890    1st Qu.:1.027   1st Qu.: 28900   1st Qu.:0.9144  
##  Median :0.4937    Median :1.032   Median : 33900   Median :0.9556  
##  Mean   :0.4931    Mean   :1.033   Mean   : 37066   Mean   :0.9502  
##  3rd Qu.:0.4971    3rd Qu.:1.040   3rd Qu.: 42100   3rd Qu.:0.9941  
##  Max.   :0.5014    Max.   :1.047   Max.   :133600   Max.   :1.3090  
##  perc_women_eng_region   NUTS2_sh        
##  Min.   :0.01659       Length:29050      
##  1st Qu.:0.30876       Class :character  
##  Median :0.56000       Mode  :character  
##  Mean   :0.52565                         
##  3rd Qu.:0.72414                         
##  Max.   :0.94527

tbtemp <- ungroup(tb) %>% dplyr::select(salary, suming, year_n, sum_pop, regioneduyears, perc_women_region, salaryquotient, eduquotient, perc_women_eng_region, `occuptional  (SSYK 2012)`)

tb_unique <- unique(tbtemp)

I will use SuperLearner to train the ensemble consisting of four linear models without interactions. The four models are Linear Regression (lm), Linear Regression with Stepwise Selection (lmStepAIC), Bayesian Generalized Linear Model (bayesglm) and Robust Linear Model (rlm).

summary_table = vector()
cor_table = vector()
sp_table <- vector()
rmse_table <- vector()

for (i in unique(tb_unique$`occuptional  (SSYK 2012)`)){
  temp <- filter(tb_unique, `occuptional  (SSYK 2012)` == i)
  if (dim(temp)[1] > 20){
     temp_weights = temp$suming
     temp <- dplyr::select(temp, - c(`occuptional  (SSYK 2012)`, suming))
     blueprint <- recipe(perc_women_eng_region ~ ., data = temp) %>%
       step_integer(matches("Qual|Cond|QC|Qu")) %>%
       step_center(all_numeric(), -all_outcomes()) %>%
       step_scale(all_numeric(), -all_outcomes()) %>%
       step_dummy(all_nominal(), -all_outcomes(), one_hot = TRUE)
     prepare <- prep(blueprint, training = temp)
     temp <- bake(prepare, new_data = temp)
  
     invisible(capture.output(model <- SuperLearner(
        temp$perc_women_eng_region,
        data.frame(dplyr::select(temp, -c(perc_women_eng_region))),
        family = gaussian(),
        verbose = FALSE,
        obsWeights = temp_weights,
        SL.library = list("SL.lm.caret", "SL.lmStepAIC.caret", "SL.bayesglm.caret", "SL.rlm.caret"))))

     pred <- function(object, newdata){
       predict(model, newdata=newdata, onlySL = TRUE)$pred
     }  
    
     predictor <- Predictor$new(model, 
        data = dplyr::select(temp, -perc_women_eng_region), 
        y = temp$perc_women_eng_region,
        predict.fun = pred)   
   
     imp <- FeatureImp$new(predictor, loss = "mae", n.repetitions = 30)
    
     summary_table <- rbind(summary_table, mutate(tibble(.rows = 7), importance = imp$results$importance, feature = imp$results$feature, importance.05 = imp$results$importance.05, ssyk = i))
    
     cor_table <- rbind(cor_table, mutate(tibble(.rows = 7), feature = colnames(dplyr::select(temp, -c(perc_women_eng_region))), cor = cor(dplyr::select(temp, -c(perc_women_eng_region)), temp$perc_women_eng_region), ssyk = i))
    
     sp_table <- rbind(sp_table, mutate(tibble(.rows = 4), coef = model$coef, model = names(model$coef),  ssyk = i))
    
     prs <- postResample(pred = predict(model)$pred, obs = temp$perc_women_eng_region)
    
     rmse_table <- rbind(rmse_table, mutate(tibble(.rows = 1), RMSE = prs[1], Rsquared = prs[2], MAE = prs[3], ssyk = i))    
  }
}

## Registered S3 methods overwritten by 'lme4':
##   method                          from
##   cooks.distance.influence.merMod car 
##   influence.merMod                car 
##   dfbeta.influence.merMod         car 
##   dfbetas.influence.merMod        car

The table below shows the feature values for the different occupation groups and if there is a single important feature (diff1) or if there are two important features (diff2) for the occupational group. The Rsquared value shows if the model for the occupational group does have a good fit.

summary_table %>% 
  group_by(ssyk) %>% 
  group_by(ssyk) %>% 
  dplyr::mutate(diff1 = importance.05[1] / importance[2]) %>% 
  dplyr::mutate(diff2 = importance.05[2] / importance[3]) %>% 
  left_join(cor_table, by = c("ssyk", "feature")) %>% 
  left_join(sp_table %>% spread(model, coef), by=c("ssyk")) %>% 
  left_join(rmse_table, by=c("ssyk")) %>% 
  dplyr::select(ssyk, feature, importance, importance.05, diff1, diff2, Rsquared) %>%
  knitr::kable( 
     booktabs = TRUE,
     caption = 'Feature values for different occupation groups')

Table 2: Feature values for different occupation groups
ssyk	feature	importance	importance.05	diff1	diff2	Rsquared
123 Administration and planning managers	eduquotient	3.8170179	3.2624044	0.9992710	0.9746650	0.5296568
123 Administration and planning managers	sum_pop	3.2647844	2.6462447	0.9992710	0.9746650	0.5296568
123 Administration and planning managers	salary	2.7150299	2.3345443	0.9992710	0.9746650	0.5296568
123 Administration and planning managers	regioneduyears	2.5260824	2.1015060	0.9992710	0.9746650	0.5296568
123 Administration and planning managers	salaryquotient	1.2063518	1.0434914	0.9992710	0.9746650	0.5296568
123 Administration and planning managers	perc_women_region	1.1813452	1.0858792	0.9992710	0.9746650	0.5296568
123 Administration and planning managers	year_n	1.0740710	1.0155535	0.9992710	0.9746650	0.5296568
141 Primary and secondary schools and adult education managers	regioneduyears	2.7494050	2.2970027	1.3327022	0.9503406	0.6950328
141 Primary and secondary schools and adult education managers	year_n	1.7235678	1.4984603	1.3327022	0.9503406	0.6950328
141 Primary and secondary schools and adult education managers	salary	1.5767613	1.4698417	1.3327022	0.9503406	0.6950328
141 Primary and secondary schools and adult education managers	sum_pop	1.0000000	1.0000000	1.3327022	0.9503406	0.6950328
141 Primary and secondary schools and adult education managers	perc_women_region	1.0000000	1.0000000	1.3327022	0.9503406	0.6950328
141 Primary and secondary schools and adult education managers	salaryquotient	1.0000000	1.0000000	1.3327022	0.9503406	0.6950328
141 Primary and secondary schools and adult education managers	eduquotient	1.0000000	1.0000000	1.3327022	0.9503406	0.6950328
151 Health care managers	salaryquotient	2.4538279	1.9290583	0.8094247	0.9296316	0.5799653
151 Health care managers	regioneduyears	2.3832462	2.1362284	0.8094247	0.9296316	0.5799653
151 Health care managers	salary	2.2979301	1.9260029	0.8094247	0.9296316	0.5799653
151 Health care managers	eduquotient	2.2848362	1.7029592	0.8094247	0.9296316	0.5799653
151 Health care managers	year_n	1.5379944	1.3579666	0.8094247	0.9296316	0.5799653
151 Health care managers	sum_pop	1.3662380	1.1596424	0.8094247	0.9296316	0.5799653
151 Health care managers	perc_women_region	1.0388730	1.0045578	0.8094247	0.9296316	0.5799653
153 Elderly care managers	year_n	8.1559615	6.4775973	0.9123375	1.4669946	0.8177027
153 Elderly care managers	salary	7.1000012	5.9284122	0.9123375	1.4669946	0.8177027
153 Elderly care managers	perc_women_region	4.0411955	3.4263668	0.9123375	1.4669946	0.8177027
153 Elderly care managers	salaryquotient	1.5390920	1.2329029	0.9123375	1.4669946	0.8177027
153 Elderly care managers	sum_pop	1.0000000	1.0000000	0.9123375	1.4669946	0.8177027
153 Elderly care managers	regioneduyears	1.0000000	1.0000000	0.9123375	1.4669946	0.8177027
153 Elderly care managers	eduquotient	1.0000000	1.0000000	0.9123375	1.4669946	0.8177027
159 Other social services managers	sum_pop	3.0725550	2.5099215	0.8325266	0.9953769	0.7325679
159 Other social services managers	salary	3.0148243	2.6352584	0.8325266	0.9953769	0.7325679
159 Other social services managers	regioneduyears	2.6474981	2.2659272	0.8325266	0.9953769	0.7325679
159 Other social services managers	eduquotient	2.1941589	1.9031203	0.8325266	0.9953769	0.7325679
159 Other social services managers	year_n	1.7175697	1.4021163	0.8325266	0.9953769	0.7325679
159 Other social services managers	salaryquotient	1.5834901	1.3638281	0.8325266	0.9953769	0.7325679
159 Other social services managers	perc_women_region	1.0000000	1.0000000	0.8325266	0.9953769	0.7325679
211 Physicists and chemists	eduquotient	3.1793564	2.4217960	0.8168496	1.4762352	0.7777887
211 Physicists and chemists	perc_women_region	2.9648004	2.4885379	0.8168496	1.4762352	0.7777887
211 Physicists and chemists	year_n	1.6857326	1.4429244	0.8168496	1.4762352	0.7777887
211 Physicists and chemists	regioneduyears	1.6402704	1.3256462	0.8168496	1.4762352	0.7777887
211 Physicists and chemists	sum_pop	1.5988744	1.2158115	0.8168496	1.4762352	0.7777887
211 Physicists and chemists	salary	1.5727207	1.3608653	0.8168496	1.4762352	0.7777887
211 Physicists and chemists	salaryquotient	1.3311748	1.0615814	0.8168496	1.4762352	0.7777887
214 Engineering professionals	sum_pop	3.2085990	2.5852735	1.0619019	1.1085082	0.8501315
214 Engineering professionals	regioneduyears	2.4345690	2.0768022	1.0619019	1.1085082	0.8501315
214 Engineering professionals	eduquotient	1.8735109	1.5486497	1.0619019	1.1085082	0.8501315
214 Engineering professionals	salary	1.0000000	1.0000000	1.0619019	1.1085082	0.8501315
214 Engineering professionals	year_n	1.0000000	1.0000000	1.0619019	1.1085082	0.8501315
214 Engineering professionals	perc_women_region	1.0000000	1.0000000	1.0619019	1.1085082	0.8501315
214 Engineering professionals	salaryquotient	1.0000000	1.0000000	1.0619019	1.1085082	0.8501315
218 Specialists within environmental and health protection	year_n	1.1998968	1.0271753	0.9319265	1.0204712	0.2072889
218 Specialists within environmental and health protection	sum_pop	1.1022064	1.0204712	0.9319265	1.0204712	0.2072889
218 Specialists within environmental and health protection	salary	1.0000000	1.0000000	0.9319265	1.0204712	0.2072889
218 Specialists within environmental and health protection	regioneduyears	1.0000000	1.0000000	0.9319265	1.0204712	0.2072889
218 Specialists within environmental and health protection	perc_women_region	1.0000000	1.0000000	0.9319265	1.0204712	0.2072889
218 Specialists within environmental and health protection	salaryquotient	1.0000000	1.0000000	0.9319265	1.0204712	0.2072889
218 Specialists within environmental and health protection	eduquotient	1.0000000	1.0000000	0.9319265	1.0204712	0.2072889
221 Medical doctors	regioneduyears	3.2538623	2.7126722	1.6832188	1.0066594	0.7935628
221 Medical doctors	eduquotient	1.6115981	1.4986615	1.6832188	1.0066594	0.7935628
221 Medical doctors	perc_women_region	1.4887473	1.3049164	1.6832188	1.0066594	0.7935628
221 Medical doctors	sum_pop	1.0890646	1.0519492	1.6832188	1.0066594	0.7935628
221 Medical doctors	salaryquotient	1.0136252	0.9725422	1.6832188	1.0066594	0.7935628
221 Medical doctors	salary	1.0079123	0.9912346	1.6832188	1.0066594	0.7935628
221 Medical doctors	year_n	0.9691336	0.9264889	1.6832188	1.0066594	0.7935628
222 Nursing professionals	perc_women_region	1.3570281	1.2297860	1.1599907	0.9741302	0.2680452
222 Nursing professionals	salaryquotient	1.0601688	0.9943949	1.1599907	0.9741302	0.2680452
222 Nursing professionals	eduquotient	1.0208028	0.9745776	1.1599907	0.9741302	0.2680452
222 Nursing professionals	year_n	1.0058709	0.9866984	1.1599907	0.9741302	0.2680452
222 Nursing professionals	sum_pop	1.0015554	0.9908744	1.1599907	0.9741302	0.2680452
222 Nursing professionals	salary	0.9999898	0.9996937	1.1599907	0.9741302	0.2680452
222 Nursing professionals	regioneduyears	0.9991395	0.9967976	1.1599907	0.9741302	0.2680452
223 Nursing professionals (cont.)	perc_women_region	1.7410583	1.4227133	0.8555381	0.9923183	0.6124752
223 Nursing professionals (cont.)	eduquotient	1.6629455	1.4414067	0.8555381	0.9923183	0.6124752
223 Nursing professionals (cont.)	sum_pop	1.4525648	1.3870921	0.8555381	0.9923183	0.6124752
223 Nursing professionals (cont.)	salaryquotient	1.2526913	1.1340334	0.8555381	0.9923183	0.6124752
223 Nursing professionals (cont.)	year_n	1.1251733	1.0377315	0.8555381	0.9923183	0.6124752
223 Nursing professionals (cont.)	regioneduyears	1.0772452	0.9979456	0.8555381	0.9923183	0.6124752
223 Nursing professionals (cont.)	salary	1.0064257	0.9699734	0.8555381	0.9923183	0.6124752
227 Naprapaths, physiotherapists, occupational therapists	year_n	3.3148421	2.8516422	1.2860370	1.4787861	0.5424810
227 Naprapaths, physiotherapists, occupational therapists	salary	2.2173875	1.9400838	1.2860370	1.4787861	0.5424810
227 Naprapaths, physiotherapists, occupational therapists	eduquotient	1.3119435	1.1242123	1.2860370	1.4787861	0.5424810
227 Naprapaths, physiotherapists, occupational therapists	regioneduyears	1.3023137	1.1403014	1.2860370	1.4787861	0.5424810
227 Naprapaths, physiotherapists, occupational therapists	salaryquotient	1.0993687	0.9919804	1.2860370	1.4787861	0.5424810
227 Naprapaths, physiotherapists, occupational therapists	perc_women_region	1.0570268	0.9703933	1.2860370	1.4787861	0.5424810
227 Naprapaths, physiotherapists, occupational therapists	sum_pop	0.9923096	0.9587380	1.2860370	1.4787861	0.5424810
231 University and higher education teachers	perc_women_region	6.9035680	6.1896016	1.0668866	0.8353526	0.9357939
231 University and higher education teachers	year_n	5.8015553	4.8319783	1.0668866	0.8353526	0.9357939
231 University and higher education teachers	salary	5.7843576	4.9118836	1.0668866	0.8353526	0.9357939
231 University and higher education teachers	sum_pop	4.2107594	3.2672779	1.0668866	0.8353526	0.9357939
231 University and higher education teachers	eduquotient	3.6947346	3.1285856	1.0668866	0.8353526	0.9357939
231 University and higher education teachers	regioneduyears	2.8014376	2.4699874	1.0668866	0.8353526	0.9357939
231 University and higher education teachers	salaryquotient	1.7814310	1.4686631	1.0668866	0.8353526	0.9357939
232 Vocational education teachers	perc_women_region	5.8995689	4.5458286	0.8486146	0.9931816	0.9152722
232 Vocational education teachers	salary	5.3567644	4.4992796	0.8486146	0.9931816	0.9152722
232 Vocational education teachers	regioneduyears	4.5301682	4.0344389	0.8486146	0.9931816	0.9152722
232 Vocational education teachers	year_n	2.5787996	2.2283684	0.8486146	0.9931816	0.9152722
232 Vocational education teachers	eduquotient	1.9948566	1.7227708	0.8486146	0.9931816	0.9152722
232 Vocational education teachers	salaryquotient	1.7484881	1.4137498	0.8486146	0.9931816	0.9152722
232 Vocational education teachers	sum_pop	1.1795101	1.0464747	0.8486146	0.9931816	0.9152722
233 Secondary education teachers	year_n	1.7519346	1.5963138	0.9861296	0.8798435	0.2711955
233 Secondary education teachers	salary	1.6187667	1.3647524	0.9861296	0.8798435	0.2711955
233 Secondary education teachers	perc_women_region	1.5511308	1.3237125	0.9861296	0.8798435	0.2711955
233 Secondary education teachers	eduquotient	1.4901622	1.3515191	0.9861296	0.8798435	0.2711955
233 Secondary education teachers	regioneduyears	1.1340296	1.0608823	0.9861296	0.8798435	0.2711955
233 Secondary education teachers	sum_pop	1.1115054	1.0431384	0.9861296	0.8798435	0.2711955
233 Secondary education teachers	salaryquotient	1.0011883	0.9739857	0.9861296	0.8798435	0.2711955
234 Primary- and pre-school teachers	regioneduyears	2.6651473	2.3148568	1.0820339	0.9396348	0.7919968
234 Primary- and pre-school teachers	eduquotient	2.1393570	1.8980735	1.0820339	0.9396348	0.7919968
234 Primary- and pre-school teachers	sum_pop	2.0200119	1.7615651	1.0820339	0.9396348	0.7919968
234 Primary- and pre-school teachers	year_n	1.9879886	1.7570799	1.0820339	0.9396348	0.7919968
234 Primary- and pre-school teachers	salaryquotient	1.5711047	1.3697916	1.0820339	0.9396348	0.7919968
234 Primary- and pre-school teachers	salary	1.5376109	1.3834061	1.0820339	0.9396348	0.7919968
234 Primary- and pre-school teachers	perc_women_region	1.0541899	1.0163654	1.0820339	0.9396348	0.7919968
235 Teaching professionals not elsewhere classified	eduquotient	3.4752946	3.1173913	1.1572182	1.0071504	0.7038429
235 Teaching professionals not elsewhere classified	perc_women_region	2.6938664	2.2359223	1.1572182	1.0071504	0.7038429
235 Teaching professionals not elsewhere classified	year_n	2.2200482	1.9098982	1.1572182	1.0071504	0.7038429
235 Teaching professionals not elsewhere classified	salaryquotient	1.8916217	1.6391206	1.1572182	1.0071504	0.7038429
235 Teaching professionals not elsewhere classified	regioneduyears	1.3369762	1.1453482	1.1572182	1.0071504	0.7038429
235 Teaching professionals not elsewhere classified	sum_pop	1.0086567	0.9599072	1.1572182	1.0071504	0.7038429
235 Teaching professionals not elsewhere classified	salary	1.0045400	0.9954951	1.1572182	1.0071504	0.7038429
241 Accountants, financial analysts and fund managers	perc_women_region	2.7081423	2.2326348	0.8460985	1.0919083	0.7445476
241 Accountants, financial analysts and fund managers	eduquotient	2.6387410	2.1737040	0.8460985	1.0919083	0.7445476
241 Accountants, financial analysts and fund managers	year_n	1.9907387	1.5693998	0.8460985	1.0919083	0.7445476
241 Accountants, financial analysts and fund managers	salary	1.4932763	1.3223917	0.8460985	1.0919083	0.7445476
241 Accountants, financial analysts and fund managers	regioneduyears	1.3933309	1.2289757	0.8460985	1.0919083	0.7445476
241 Accountants, financial analysts and fund managers	salaryquotient	1.0962361	1.0154278	0.8460985	1.0919083	0.7445476
241 Accountants, financial analysts and fund managers	sum_pop	0.9995289	0.9973319	0.8460985	1.0919083	0.7445476
242 Organisation analysts, policy administrators and human resource specialists	salary	4.1453246	3.4636361	1.4988404	1.0425932	0.6524219
242 Organisation analysts, policy administrators and human resource specialists	perc_women_region	2.3108772	1.9737256	1.4988404	1.0425932	0.6524219
242 Organisation analysts, policy administrators and human resource specialists	year_n	1.8930927	1.6469206	1.4988404	1.0425932	0.6524219
242 Organisation analysts, policy administrators and human resource specialists	regioneduyears	1.8639424	1.6551601	1.4988404	1.0425932	0.6524219
242 Organisation analysts, policy administrators and human resource specialists	eduquotient	1.3041251	1.2098787	1.4988404	1.0425932	0.6524219
242 Organisation analysts, policy administrators and human resource specialists	sum_pop	1.0982455	1.0016594	1.4988404	1.0425932	0.6524219
242 Organisation analysts, policy administrators and human resource specialists	salaryquotient	1.0559543	0.9813767	1.4988404	1.0425932	0.6524219
243 Marketing and public relations professionals	sum_pop	4.9569245	3.9496983	1.1206542	0.9392641	0.6445752
243 Marketing and public relations professionals	regioneduyears	3.5244578	2.8349264	1.1206542	0.9392641	0.6445752
243 Marketing and public relations professionals	salary	3.0182422	2.2538137	1.1206542	0.9392641	0.6445752
243 Marketing and public relations professionals	eduquotient	2.6524352	1.9742342	1.1206542	0.9392641	0.6445752
243 Marketing and public relations professionals	year_n	1.7174528	1.4543276	1.1206542	0.9392641	0.6445752
243 Marketing and public relations professionals	salaryquotient	1.4552259	1.2338961	1.1206542	0.9392641	0.6445752
243 Marketing and public relations professionals	perc_women_region	1.3152657	1.1626737	1.1206542	0.9392641	0.6445752
251 ICT architects, systems analysts and test managers	perc_women_region	2.7358787	2.5568847	0.9528479	1.1920886	0.4818438
251 ICT architects, systems analysts and test managers	salary	2.6834131	2.1391217	0.9528479	1.1920886	0.4818438
251 ICT architects, systems analysts and test managers	year_n	1.7944318	1.5618951	0.9528479	1.1920886	0.4818438
251 ICT architects, systems analysts and test managers	eduquotient	1.0100090	1.0001357	0.9528479	1.1920886	0.4818438
251 ICT architects, systems analysts and test managers	sum_pop	1.0047852	1.0012175	0.9528479	1.1920886	0.4818438
251 ICT architects, systems analysts and test managers	salaryquotient	0.9996955	0.9963383	0.9528479	1.1920886	0.4818438
251 ICT architects, systems analysts and test managers	regioneduyears	0.9930233	0.9888326	0.9528479	1.1920886	0.4818438
261 Legal professionals	salary	4.7549424	3.8162165	0.8451578	1.1021776	0.7483456
261 Legal professionals	sum_pop	4.5153896	3.1719595	0.8451578	1.1021776	0.7483456
261 Legal professionals	perc_women_region	2.8779023	2.5745840	0.8451578	1.1021776	0.7483456
261 Legal professionals	year_n	2.6379752	2.2504586	0.8451578	1.1021776	0.7483456
261 Legal professionals	regioneduyears	2.5557708	2.1184918	0.8451578	1.1021776	0.7483456
261 Legal professionals	eduquotient	2.0561141	1.7014956	0.8451578	1.1021776	0.7483456
261 Legal professionals	salaryquotient	1.4548882	1.2819586	0.8451578	1.1021776	0.7483456
262 Museum curators and librarians and related professionals	sum_pop	3.3548098	2.4968169	0.7595766	0.8090532	0.7594220
262 Museum curators and librarians and related professionals	eduquotient	3.2871165	2.5885880	0.7595766	0.8090532	0.7594220
262 Museum curators and librarians and related professionals	perc_women_region	3.1995277	2.8162677	0.7595766	0.8090532	0.7594220
262 Museum curators and librarians and related professionals	salary	1.9883411	1.6716447	0.7595766	0.8090532	0.7594220
262 Museum curators and librarians and related professionals	regioneduyears	1.4723407	1.3110794	0.7595766	0.8090532	0.7594220
262 Museum curators and librarians and related professionals	year_n	1.1910891	1.1044098	0.7595766	0.8090532	0.7594220
262 Museum curators and librarians and related professionals	salaryquotient	1.0596886	0.9983240	0.7595766	0.8090532	0.7594220
266 Social work and counselling professionals	year_n	2.0699805	1.8890549	1.3195137	0.9204363	0.6423319
266 Social work and counselling professionals	regioneduyears	1.4316296	1.1948843	1.3195137	0.9204363	0.6423319
266 Social work and counselling professionals	perc_women_region	1.2981716	1.0993452	1.3195137	0.9204363	0.6423319
266 Social work and counselling professionals	sum_pop	1.2974744	1.1788171	1.3195137	0.9204363	0.6423319
266 Social work and counselling professionals	salaryquotient	1.0015134	0.9980390	1.3195137	0.9204363	0.6423319
266 Social work and counselling professionals	eduquotient	1.0004463	0.9980253	1.3195137	0.9204363	0.6423319
266 Social work and counselling professionals	salary	1.0002662	0.9921359	1.3195137	0.9204363	0.6423319
311 Physical and engineering science technicians	perc_women_region	2.8239037	2.3308712	1.2124932	1.1060730	0.6129610
311 Physical and engineering science technicians	year_n	1.9223788	1.6234583	1.2124932	1.1060730	0.6129610
311 Physical and engineering science technicians	salary	1.4677678	1.2914193	1.2124932	1.1060730	0.6129610
311 Physical and engineering science technicians	salaryquotient	1.0353719	0.9889612	1.2124932	1.1060730	0.6129610
311 Physical and engineering science technicians	eduquotient	1.0236570	0.9963231	1.2124932	1.1060730	0.6129610
311 Physical and engineering science technicians	sum_pop	1.0233421	0.9919135	1.2124932	1.1060730	0.6129610
311 Physical and engineering science technicians	regioneduyears	1.0116614	0.9855591	1.2124932	1.1060730	0.6129610
331 Financial and accounting associate professionals	eduquotient	3.7511968	3.2140254	1.3911100	0.9346430	0.6495278
331 Financial and accounting associate professionals	perc_women_region	2.3104035	1.9925122	1.3911100	0.9346430	0.6495278
331 Financial and accounting associate professionals	salary	2.1318431	1.8521291	1.3911100	0.9346430	0.6495278
331 Financial and accounting associate professionals	sum_pop	1.4214195	1.2916594	1.3911100	0.9346430	0.6495278
331 Financial and accounting associate professionals	salaryquotient	1.3864519	1.1803667	1.3911100	0.9346430	0.6495278
331 Financial and accounting associate professionals	regioneduyears	1.0725493	1.0231476	1.3911100	0.9346430	0.6495278
331 Financial and accounting associate professionals	year_n	1.0156559	0.9924611	1.3911100	0.9346430	0.6495278
332 Insurance advisers, sales and purchasing agents	perc_women_region	3.8010119	3.0275822	1.5742205	1.3483567	0.7642041
332 Insurance advisers, sales and purchasing agents	sum_pop	1.9232262	1.7322825	1.5742205	1.3483567	0.7642041
332 Insurance advisers, sales and purchasing agents	salaryquotient	1.2847360	1.1413503	1.5742205	1.3483567	0.7642041
332 Insurance advisers, sales and purchasing agents	year_n	1.2196519	1.0707646	1.5742205	1.3483567	0.7642041
332 Insurance advisers, sales and purchasing agents	salary	1.0000000	1.0000000	1.5742205	1.3483567	0.7642041
332 Insurance advisers, sales and purchasing agents	regioneduyears	1.0000000	1.0000000	1.5742205	1.3483567	0.7642041
332 Insurance advisers, sales and purchasing agents	eduquotient	1.0000000	1.0000000	1.5742205	1.3483567	0.7642041
333 Business services agents	regioneduyears	3.1945994	2.5604487	1.4159454	1.0419269	0.4301719
333 Business services agents	eduquotient	1.8082963	1.4856024	1.4159454	1.0419269	0.4301719
333 Business services agents	year_n	1.4258221	1.1847659	1.4159454	1.0419269	0.4301719
333 Business services agents	sum_pop	1.1998397	1.0205232	1.4159454	1.0419269	0.4301719
333 Business services agents	salaryquotient	1.0691040	1.0183061	1.4159454	1.0419269	0.4301719
333 Business services agents	perc_women_region	1.0376611	0.9739336	1.4159454	1.0419269	0.4301719
333 Business services agents	salary	1.0005005	0.9973068	1.4159454	1.0419269	0.4301719
335 Tax and related government associate professionals	eduquotient	4.1013441	3.4857810	1.2177057	1.1768387	0.7469849
335 Tax and related government associate professionals	sum_pop	2.8625809	2.6778006	1.2177057	1.1768387	0.7469849
335 Tax and related government associate professionals	perc_women_region	2.2754185	1.9606631	1.2177057	1.1768387	0.7469849
335 Tax and related government associate professionals	salary	1.0000000	1.0000000	1.2177057	1.1768387	0.7469849
335 Tax and related government associate professionals	year_n	1.0000000	1.0000000	1.2177057	1.1768387	0.7469849
335 Tax and related government associate professionals	regioneduyears	1.0000000	1.0000000	1.2177057	1.1768387	0.7469849
335 Tax and related government associate professionals	salaryquotient	1.0000000	1.0000000	1.2177057	1.1768387	0.7469849
336 Police officers	eduquotient	6.6149010	5.4101856	1.3781681	0.9403836	0.6720628
336 Police officers	sum_pop	3.9256356	3.1250520	1.3781681	0.9403836	0.6720628
336 Police officers	salary	3.3231673	2.8227248	1.3781681	0.9403836	0.6720628
336 Police officers	regioneduyears	3.2344097	2.8043712	1.3781681	0.9403836	0.6720628
336 Police officers	perc_women_region	2.0402484	1.7876511	1.3781681	0.9403836	0.6720628
336 Police officers	year_n	1.8543180	1.6559515	1.3781681	0.9403836	0.6720628
336 Police officers	salaryquotient	1.1808364	1.0825015	1.3781681	0.9403836	0.6720628
411 Office assistants and other secretaries	perc_women_region	2.1872367	1.7804951	0.8268219	0.9425405	0.5768773
411 Office assistants and other secretaries	sum_pop	2.1534202	1.8012277	0.8268219	0.9425405	0.5768773
411 Office assistants and other secretaries	salary	1.9110349	1.5828173	0.8268219	0.9425405	0.5768773
411 Office assistants and other secretaries	year_n	1.3145981	1.1258907	0.8268219	0.9425405	0.5768773
411 Office assistants and other secretaries	salaryquotient	1.1366153	1.0368470	0.8268219	0.9425405	0.5768773
411 Office assistants and other secretaries	regioneduyears	1.1011724	1.0330416	0.8268219	0.9425405	0.5768773
411 Office assistants and other secretaries	eduquotient	1.0150045	0.9988372	0.8268219	0.9425405	0.5768773
422 Client information clerks	sum_pop	2.2556210	2.0199751	1.1114007	1.2922028	0.5754468
422 Client information clerks	regioneduyears	1.8175038	1.6419553	1.1114007	1.2922028	0.5754468
422 Client information clerks	salaryquotient	1.2706638	1.1570272	1.1114007	1.2922028	0.5754468
422 Client information clerks	salary	1.0000000	1.0000000	1.1114007	1.2922028	0.5754468
422 Client information clerks	year_n	1.0000000	1.0000000	1.1114007	1.2922028	0.5754468
422 Client information clerks	perc_women_region	1.0000000	1.0000000	1.1114007	1.2922028	0.5754468
422 Client information clerks	eduquotient	1.0000000	1.0000000	1.1114007	1.2922028	0.5754468
532 Personal care workers in health services	regioneduyears	6.6360229	5.5777322	1.6115974	0.8774912	0.8998367
532 Personal care workers in health services	eduquotient	3.4609960	2.8222051	1.6115974	0.8774912	0.8998367
532 Personal care workers in health services	salary	3.2162205	2.7855818	1.6115974	0.8774912	0.8998367
532 Personal care workers in health services	year_n	2.1602674	1.8489474	1.6115974	0.8774912	0.8998367
532 Personal care workers in health services	sum_pop	1.2635892	1.1422356	1.6115974	0.8774912	0.8998367
532 Personal care workers in health services	salaryquotient	1.0352898	0.9386980	1.6115974	0.8774912	0.8998367
532 Personal care workers in health services	perc_women_region	0.9978554	0.9931738	1.6115974	0.8774912	0.8998367
533 Health care assistants	regioneduyears	5.8197354	4.7731043	1.3421333	1.1939419	0.9165128
533 Health care assistants	eduquotient	3.5563562	3.0151663	1.3421333	1.1939419	0.9165128
533 Health care assistants	year_n	2.5253877	2.3079860	1.3421333	1.1939419	0.9165128
533 Health care assistants	sum_pop	1.6773638	1.3046246	1.3421333	1.1939419	0.9165128
533 Health care assistants	salary	1.6134876	1.4965381	1.3421333	1.1939419	0.9165128
533 Health care assistants	perc_women_region	1.3948836	1.1740007	1.3421333	1.1939419	0.9165128
533 Health care assistants	salaryquotient	1.3923600	1.1347137	1.3421333	1.1939419	0.9165128
534 Attendants, personal assistants and related workers	salary	3.5389050	3.1870397	0.9663243	0.9694028	0.6206695
534 Attendants, personal assistants and related workers	year_n	3.2981057	2.6457771	0.9663243	0.9694028	0.6206695
534 Attendants, personal assistants and related workers	regioneduyears	2.7292856	2.3165318	0.9663243	0.9694028	0.6206695
534 Attendants, personal assistants and related workers	sum_pop	2.2153663	1.9380926	0.9663243	0.9694028	0.6206695
534 Attendants, personal assistants and related workers	eduquotient	2.1263593	1.8101511	0.9663243	0.9694028	0.6206695
534 Attendants, personal assistants and related workers	perc_women_region	1.5857830	1.4075435	0.9663243	0.9694028	0.6206695
534 Attendants, personal assistants and related workers	salaryquotient	1.0341103	0.9911844	0.9663243	0.9694028	0.6206695
541 Other surveillance and security workers	salary	4.7774908	4.1261786	1.0229660	0.8534003	0.6723747
541 Other surveillance and security workers	perc_women_region	4.0335443	3.0521977	1.0229660	0.8534003	0.6723747
541 Other surveillance and security workers	year_n	3.5765135	2.9675823	1.0229660	0.8534003	0.6723747
541 Other surveillance and security workers	eduquotient	2.0845999	1.6709589	1.0229660	0.8534003	0.6723747
541 Other surveillance and security workers	sum_pop	1.8146068	1.5619745	1.0229660	0.8534003	0.6723747
541 Other surveillance and security workers	regioneduyears	1.0411189	0.9862411	1.0229660	0.8534003	0.6723747
541 Other surveillance and security workers	salaryquotient	1.0341765	0.9505941	1.0229660	0.8534003	0.6723747
962 Newspaper distributors, janitors and other service workers	sum_pop	2.7464002	2.2523244	1.1644473	0.8815180	0.7418281
962 Newspaper distributors, janitors and other service workers	perc_women_region	1.9342434	1.6159634	1.1644473	0.8815180	0.7418281
962 Newspaper distributors, janitors and other service workers	regioneduyears	1.8331599	1.5608802	1.1644473	0.8815180	0.7418281
962 Newspaper distributors, janitors and other service workers	salary	1.6450591	1.3684304	1.1644473	0.8815180	0.7418281
962 Newspaper distributors, janitors and other service workers	eduquotient	1.2975906	1.1453299	1.1644473	0.8815180	0.7418281
962 Newspaper distributors, janitors and other service workers	salaryquotient	1.0911504	1.0023219	1.1644473	0.8815180	0.7418281
962 Newspaper distributors, janitors and other service workers	year_n	1.0074452	0.9471405	1.1644473	0.8815180	0.7418281
134 Architectural and engineering managers	salary	6.6628692	5.5853307	0.9346946	0.8201284	0.9151922
134 Architectural and engineering managers	eduquotient	5.9755676	4.7127798	0.9346946	0.8201284	0.9151922
134 Architectural and engineering managers	regioneduyears	5.7463923	4.7283129	0.9346946	0.8201284	0.9151922
134 Architectural and engineering managers	perc_women_region	2.1729423	1.7202449	0.9346946	0.8201284	0.9151922
134 Architectural and engineering managers	salaryquotient	1.7104284	1.4330406	0.9346946	0.8201284	0.9151922
134 Architectural and engineering managers	sum_pop	1.5720877	1.3353975	0.9346946	0.8201284	0.9151922
134 Architectural and engineering managers	year_n	1.3342337	1.0743796	0.9346946	0.8201284	0.9151922
321 Medical and pharmaceutical technicians	sum_pop	2.7792282	2.4396571	1.3557086	0.9362958	0.4082033
321 Medical and pharmaceutical technicians	salaryquotient	1.7995439	1.5614282	1.3557086	0.9362958	0.4082033
321 Medical and pharmaceutical technicians	regioneduyears	1.6676655	1.4757725	1.3557086	0.9362958	0.4082033
321 Medical and pharmaceutical technicians	salary	1.6228142	1.3713812	1.3557086	0.9362958	0.4082033
321 Medical and pharmaceutical technicians	perc_women_region	1.2073206	1.1181762	1.3557086	0.9362958	0.4082033
321 Medical and pharmaceutical technicians	year_n	1.1558014	1.0202584	1.3557086	0.9362958	0.4082033
321 Medical and pharmaceutical technicians	eduquotient	1.0268559	0.9480420	1.3557086	0.9362958	0.4082033
351 ICT operations and user support technicians	perc_women_region	2.3485720	1.9425995	0.9224562	1.3928600	0.2801627
351 ICT operations and user support technicians	sum_pop	2.1058989	1.8259434	0.9224562	1.3928600	0.2801627
351 ICT operations and user support technicians	regioneduyears	1.3109310	1.1486190	0.9224562	1.3928600	0.2801627
351 ICT operations and user support technicians	salaryquotient	1.1923807	1.0975135	0.9224562	1.3928600	0.2801627
351 ICT operations and user support technicians	eduquotient	1.1053954	0.9764972	0.9224562	1.3928600	0.2801627
351 ICT operations and user support technicians	year_n	1.0054393	0.9660905	0.9224562	1.3928600	0.2801627
351 ICT operations and user support technicians	salary	0.9995223	0.9843242	0.9224562	1.3928600	0.2801627
432 Stores and transport clerks	sum_pop	5.3245183	4.2675746	1.9035879	0.9786471	0.7755035
432 Stores and transport clerks	regioneduyears	2.2418584	1.8267779	1.9035879	0.9786471	0.7755035
432 Stores and transport clerks	perc_women_region	1.8666360	1.5362588	1.9035879	0.9786471	0.7755035
432 Stores and transport clerks	salaryquotient	1.6103759	1.3880391	1.9035879	0.9786471	0.7755035
432 Stores and transport clerks	eduquotient	1.4745504	1.2612910	1.9035879	0.9786471	0.7755035
432 Stores and transport clerks	year_n	1.1201795	0.9753529	1.9035879	0.9786471	0.7755035
432 Stores and transport clerks	salary	1.1088593	0.9673804	1.9035879	0.9786471	0.7755035
531 Child care workers and teachers aides	perc_women_region	2.2875316	1.9727938	0.8746626	1.0323371	0.4740983
531 Child care workers and teachers aides	year_n	2.2554913	1.9691707	0.8746626	1.0323371	0.4740983
531 Child care workers and teachers aides	salary	1.9074879	1.6568279	0.8746626	1.0323371	0.4740983
531 Child care workers and teachers aides	sum_pop	1.7777613	1.5135123	0.8746626	1.0323371	0.4740983
531 Child care workers and teachers aides	regioneduyears	1.6700858	1.5224323	0.8746626	1.0323371	0.4740983
531 Child care workers and teachers aides	eduquotient	1.6139928	1.4242386	0.8746626	1.0323371	0.4740983
531 Child care workers and teachers aides	salaryquotient	1.0492472	0.9970015	0.8746626	1.0323371	0.4740983
819 Process control technicians	eduquotient	2.0817719	1.7942830	1.1691890	0.8777738	0.4932349
819 Process control technicians	year_n	1.5346389	1.2918349	1.1691890	0.8777738	0.4932349
819 Process control technicians	salaryquotient	1.4717173	1.3207021	1.1691890	0.8777738	0.4932349
819 Process control technicians	perc_women_region	1.0716159	0.9923244	1.1691890	0.8777738	0.4932349
819 Process control technicians	regioneduyears	1.0646529	1.0173561	1.1691890	0.8777738	0.4932349
819 Process control technicians	salary	1.0537050	0.9954603	1.1691890	0.8777738	0.4932349
819 Process control technicians	sum_pop	0.9959705	0.9677651	1.1691890	0.8777738	0.4932349
821 Assemblers	regioneduyears	15.1386847	12.3171157	1.3260624	0.8326956	0.8026313
821 Assemblers	sum_pop	9.2884888	6.7454161	1.3260624	0.8326956	0.8026313
821 Assemblers	perc_women_region	8.1006984	6.2366514	1.3260624	0.8326956	0.8026313
821 Assemblers	year_n	5.1637791	4.0079990	1.3260624	0.8326956	0.8026313
821 Assemblers	salaryquotient	1.5702498	1.3980286	1.3260624	0.8326956	0.8026313
821 Assemblers	salary	1.3401459	1.1613060	1.3260624	0.8326956	0.8026313
821 Assemblers	eduquotient	1.2776958	1.0033735	1.3260624	0.8326956	0.8026313

The sum of the per cent that the model was used by the SuperLearner analysing the different occupational groups.

sp_table %>%
  ggplot (aes(coef, model)) +  
    geom_col ()

Figure 1: The sum of the per cent that the model was used by the SuperLearner

The sum of the strongest feature for every occupational group.

summary_table %>% 
  arrange(desc(importance)) %>% 
  group_by(ssyk) %>% 
  slice(1) %>%
  ggplot (aes(importance, feature)) +  
    geom_col ()

Figure 2: The sum of the strongest feature for every occupational group

Let’s see what we have found. First, check the occupation groups with a single feature that is significantly stronger than all other features. Linear models will not be suitable for all occupational groups implying that the model will not have a high R squared value.

A strong signal, the average number of education years in the region, Personal care workers in health services

temp <- filter(tb_unique, `occuptional  (SSYK 2012)` == "532 Personal care workers in health services")

model <- lm(perc_women_eng_region ~ regioneduyears, weights = suming, data = temp)

temp %>%
  ggplot () +  
    geom_jitter (mapping = aes(x = regioneduyears, y = perc_women_eng_region, colour = suming)) +
    geom_abline (slope = model$coefficients[2], intercept = model$coefficients[1])  +
    labs(
      x = "Education years",
      y = "Per cent of women in the occupation"
    )

Figure 3: Personal care workers in health services, Year 2014 - 2018

summary(model)$adj.r.squared

## [1] 0.7732263

anova(model)

## Analysis of Variance Table
## 
## Response: perc_women_eng_region
##                Df  Sum Sq Mean Sq F value    Pr(>F)    
## regioneduyears  1 315.573 315.573  133.98 5.039e-14 ***
## Residuals      38  89.506   2.355                      
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1

postResample(pred = predict(model), obs = temp$perc_women_eng_region)

##       RMSE   Rsquared        MAE 
## 0.01225219 0.69069055 0.01023249

A strong signal, the average number of education years in the region, Medical doctors

temp <- filter(tb_unique, `occuptional  (SSYK 2012)` == "221 Medical doctors")

model <- lm(perc_women_eng_region ~ regioneduyears, weights = suming, data = temp)

temp %>%
  ggplot () +  
    geom_jitter (mapping = aes(x = regioneduyears, y = perc_women_eng_region, colour = suming)) +
    geom_abline(slope = model$coefficients[2], intercept = model$coefficients[1]) +
    labs(
      x = "Education years",
      y = "Per cent of women in the occupation"
    )

Figure 4: Medical doctors, Year 2014 - 2018

summary(model)$adj.r.squared

## [1] 0.8057127

anova(model)

## Analysis of Variance Table
## 
## Response: perc_women_eng_region
##                Df  Sum Sq Mean Sq F value    Pr(>F)    
## regioneduyears  1 164.765 164.765  154.44 1.385e-14 ***
## Residuals      36  38.407   1.067                      
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1

postResample(pred = predict(model), obs = temp$perc_women_eng_region)

##       RMSE   Rsquared        MAE 
## 0.01683530 0.72088034 0.01385548

A strong signal, the per cent women in the region, Insurance advisers, sales and purchasing agents

temp <- filter(tb_unique, `occuptional  (SSYK 2012)` == "332 Insurance advisers, sales and purchasing agents")

model <- lm(perc_women_eng_region ~ perc_women_region, weights = suming, data = temp)

temp %>%
  ggplot () +  
    geom_jitter (mapping = aes(x = perc_women_region, y = perc_women_eng_region, colour = suming)) +
    geom_abline(slope = model$coefficients[2], intercept = model$coefficients[1]) +
    labs(
      x = "Per cent of women in the region",
      y = "Per cent of women in the occupation"
    )

Figure 5: Insurance advisers, sales and purchasing agents, Year 2014 - 2018

summary(model)$adj.r.squared

## [1] 0.6283407

anova(model)

## Analysis of Variance Table
## 
## Response: perc_women_eng_region
##                   Df Sum Sq Mean Sq F value    Pr(>F)    
## perc_women_region  1 529.66  529.66  56.791 1.395e-08 ***
## Residuals         32 298.45    9.33                      
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1

postResample(pred = predict(model), obs = temp$perc_women_eng_region)

##       RMSE   Rsquared        MAE 
## 0.02935038 0.49206133 0.02250770

Two strong signals, population size in the region and the average number of education years in the region, Engineering professionals

temp <- filter(tb_unique, `occuptional  (SSYK 2012)` == "214 Engineering professionals")

s3d <- scatterplot3d(
  temp$sum_pop, 
  temp$regioneduyears, 
  temp$perc_women_eng_region,
  type = "h", 
  color = "blue", 
  xlab = "Population in region",
  ylab = "Education years",
  zlab = "Per cent of women in the occupation")

model <- lm(perc_women_eng_region ~ sum_pop + regioneduyears, weights = suming, data = temp)

s3d$plane3d(model)

Figure 6: Engineering professionals, Year 2014 - 2018

summary(model)$adj.r.squared

## [1] 0.8121964

anova(model)

## Analysis of Variance Table
## 
## Response: perc_women_eng_region
##                Df  Sum Sq Mean Sq F value    Pr(>F)    
## sum_pop         1 255.902 255.902 144.321 5.673e-14 ***
## regioneduyears  1  31.373  31.373  17.693 0.0001712 ***
## Residuals      35  62.060   1.773                      
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1

postResample(pred = predict(model), obs = temp$perc_women_eng_region)

##        RMSE    Rsquared         MAE 
## 0.012229213 0.835386966 0.009935413

Two strong signals, population size in the region and the per cent women in the region, Insurance advisers, sales and purchasing agents

temp <- filter(tb_unique, `occuptional  (SSYK 2012)` == "332 Insurance advisers, sales and purchasing agents")

s3d <- scatterplot3d(
  temp$sum_pop, 
  temp$perc_women_region, 
  temp$perc_women_eng_region,
  type = "h", 
  color = "blue", 
  xlab = "Population in region",
  ylab = "Per cent of women in the region",
  zlab = "Per cent of women in the occupation")

model <- lm(perc_women_eng_region ~ sum_pop + perc_women_region, weights = suming, data = temp)

s3d$plane3d(model)

Figure 7: Insurance advisers, sales and purchasing agents, Year 2014 - 2018

summary(model)$adj.r.squared

## [1] 0.6525952

anova(model)

## Analysis of Variance Table
## 
## Response: perc_women_eng_region
##                   Df Sum Sq Mean Sq F value    Pr(>F)    
## sum_pop            1 263.40 263.403  30.214 5.168e-06 ***
## perc_women_region  1 294.45 294.455  33.776 2.099e-06 ***
## Residuals         31 270.25   8.718                      
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1

postResample(pred = predict(model), obs = temp$perc_women_eng_region)

##       RMSE   Rsquared        MAE 
## 0.02638844 0.57325855 0.02034915

Two strong signals, year and the per cent women in the region, Physical and engineering science technicians

temp <- filter(tb_unique, `occuptional  (SSYK 2012)` == "311 Physical and engineering science technicians")

s3d <- scatterplot3d(
  temp$year_n, 
  temp$perc_women_region, 
  temp$perc_women_eng_region, 
  type = "h", 
  color = "blue", 
  xlab = "Year",
  ylab = "Per cent of women in the region",
  zlab = "Per cent of women in the occupation")

model <- lm(perc_women_eng_region ~ year_n + perc_women_region, weights = suming, data = temp)

s3d$plane3d(model)

Figure 8: Physical and engineering science technicians, Year 2014 - 2018

summary(model)$adj.r.squared

## [1] 0.5373011

anova(model)

## Analysis of Variance Table
## 
## Response: perc_women_eng_region
##                   Df Sum Sq Mean Sq F value    Pr(>F)    
## year_n             1  32.63  32.630  7.6503  0.009621 ** 
## perc_women_region  1 134.39 134.393 31.5091 4.127e-06 ***
## Residuals         30 127.96   4.265                      
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1

postResample(pred = predict(model), obs = temp$perc_women_eng_region)

##       RMSE   Rsquared        MAE 
## 0.01695193 0.59082239 0.01266243

Two strong signals, year and salary, Naprapaths, physiotherapists, occupational therapists

temp <- filter(tb_unique, `occuptional  (SSYK 2012)` == "227 Naprapaths, physiotherapists, occupational therapists")

s3d <- scatterplot3d(
  temp$year_n, 
  temp$salary, 
  temp$perc_women_eng_region, 
  type = "h", 
  color = "blue", 
  xlab = "Year",
  ylab = "Salary",
  zlab = "Per cent of women in the occupation")

model <- lm(perc_women_eng_region ~ year_n + salary, weights = suming, data = temp)

s3d$plane3d(model)

Figure 9: Naprapaths, physiotherapists, occupational therapists, Year 2014 - 2018

summary(model)$adj.r.squared

## [1] 0.5269917

anova(model)

## Analysis of Variance Table
## 
## Response: perc_women_eng_region
##           Df Sum Sq Mean Sq F value    Pr(>F)    
## year_n     1 5.8240  5.8240  16.077 0.0005492 ***
## salary     1 4.9902  4.9902  13.776 0.0011481 ** 
## Residuals 23 8.3317  0.3622                      
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1

postResample(pred = predict(model), obs = temp$perc_women_eng_region)

##       RMSE   Rsquared        MAE 
## 0.01261698 0.46523146 0.01003402

The number of engineers in the Swedish regions, feature importance

Mon, 04 May 2020 00:00:00 +0000

In my last post, I analysed the feature importance for the per cent of engineers in Sweden who are women. I found that the size of the region is a feature that is significant for the per cent of engineers in Sweden who are women. The size of the region is correlated to the number of engineers that works in the region. In this post, I will analyse what predictors are best to forecast the number of engineers in the region. I will use models from the caret package in my analysis.

Statistics Sweden use NUTS (Nomenclature des Unités Territoriales Statistiques), which is the EU’s hierarchical regional division, to specify the regions.

Please send suggestions for improvement of the analysis to ranalystatisticssweden@gmail.com.

First, define libraries and functions.

library (tidyverse)

## -- Attaching packages -------------------------------------------------- tidyverse 1.3.0 --

## v ggplot2 3.3.0     v purrr   0.3.4
## v tibble  3.0.0     v dplyr   0.8.5
## v tidyr   1.0.2     v stringr 1.4.0
## v readr   1.3.1     v forcats 0.5.0

## -- Conflicts ----------------------------------------------------- tidyverse_conflicts() --
## x dplyr::filter() masks stats::filter()
## x dplyr::lag()    masks stats::lag()

library (broom)
library (car)

## Loading required package: carData

## 
## Attaching package: 'car'

## The following object is masked from 'package:dplyr':
## 
##     recode

## The following object is masked from 'package:purrr':
## 
##     some

library (caret)

## Loading required package: lattice

## 
## Attaching package: 'caret'

## The following object is masked from 'package:purrr':
## 
##     lift

library (recipes)

## 
## Attaching package: 'recipes'

## The following object is masked from 'package:stringr':
## 
##     fixed

## The following object is masked from 'package:stats':
## 
##     step

library (PerformanceAnalytics)

## Loading required package: xts

## Loading required package: zoo

## 
## Attaching package: 'zoo'

## The following objects are masked from 'package:base':
## 
##     as.Date, as.Date.numeric

## 
## Attaching package: 'xts'

## The following objects are masked from 'package:dplyr':
## 
##     first, last

## 
## Attaching package: 'PerformanceAnalytics'

## The following object is masked from 'package:graphics':
## 
##     legend

library (ggpubr)

## Loading required package: magrittr

## 
## Attaching package: 'magrittr'

## The following object is masked from 'package:purrr':
## 
##     set_names

## The following object is masked from 'package:tidyr':
## 
##     extract

library (ipred) 
library (iml)
library (DALEX)

## Welcome to DALEX (version: 1.2.1).
## Find examples and detailed introduction at: https://pbiecek.github.io/ema/

## 
## Attaching package: 'DALEX'

## The following object is masked from 'package:dplyr':
## 
##     explain

library (Metrics)

## 
## Attaching package: 'Metrics'

## The following objects are masked from 'package:caret':
## 
##     precision, recall

library (auditor)

## 
## Attaching package: 'auditor'

## The following object is masked from 'package:DALEX':
## 
##     model_performance

readfile <- function (file1){read_csv (file1, col_types = cols(), locale = readr::locale (encoding = "latin1"), na = c("..", "NA")) %>%
  gather (starts_with("19"), starts_with("20"), key = "year", value = groupsize) %>%
  drop_na() %>%
  mutate (year_n = parse_number (year))
}

perc_women <- function(x){  
  ifelse (length(x) == 2, x[2] / (x[1] + x[2]), NA)
} 

nuts <- read.csv("nuts.csv") %>%
  mutate(NUTS2_sh = substr(NUTS2, 3, 4))

nuts %>% 
  distinct (NUTS2_en) %>%
  knitr::kable(
    booktabs = TRUE,
    caption = 'Nomenclature des Unités Territoriales Statistiques (NUTS)')

Table 1: Nomenclature des Unités Territoriales Statistiques (NUTS)
NUTS2_en
SE11 Stockholm
SE12 East-Central Sweden
SE21 Småland and islands
SE22 South Sweden
SE23 West Sweden
SE31 North-Central Sweden
SE32 Central Norrland
SE33 Upper Norrland

bs <- function(formula, data, indices) {
  d <- data[indices,] # allows boot to select sample 
  fit <- lm(formula, weights = tbnum_weights, data=d)
  return(coef(fit)) 
}