Mathatistics https://mathatistics.com/blog.html My personal blog where I share my experiences and my learning journey. quarto-1.2.335 Mon, 17 Mar 2025 23:00:00 GMT Merging multiple datasets Raju Rimal https://mathatistics.com/blog/posts/2025-04-28-join-with-dplyr/index.html .knitsql-table { overflow-x: scroll; }

This post explores the fundamentals of joining tables in R using the dplyr package, with a focus on both core concepts and practical edge cases. You’ll learn how keys link datasets, how different join types handle unmatched rows, and strategies for tackling real-world challenges like missing values, multi-key joins, and pre-processing with intermediate variables. To bridge the gap for database users, every join example includes its SQL equivalent. Finally, a reproducible dummy dataset is provided so you can follow along and experiment.

Example dataset

# Employees: 
#> emp_id 3 has NA dept_id; 
#> emp_id 5's dept_id (4) is missing
employees <- tibble(
  emp_id = c(1, 2, 3, 4, 5, 6),
  first_name = c(
    "Alice Susanna", "Bob", "Mary Anne", 
    "Diana", "Eve", "Frank"
  ),
  last_name = c(
    "Smith", "Johnson", "Brown", 
    "Lee", "Davis", "DeVito Jr."
  ),
  dept_id = c(1, 2, NA, 3, 4, 2),
  salary = c(
    60000, 75000, 80000, 
    90000, 65000, 70000
  )
)

print(employees)
# A tibble: 6 × 5
  emp_id first_name    last_name  dept_id salary
   <dbl> <chr>         <chr>        <dbl>  <dbl>
1      1 Alice Susanna Smith            1  60000
2      2 Bob           Johnson          2  75000
3      3 Mary Anne     Brown           NA  80000
4      4 Diana         Lee              3  90000
5      5 Eve           Davis            4  65000
6      6 Frank         DeVito Jr.       2  70000
#> Departments: 
#> - dept_id 5 has no employees
#> - dept_id 2 appears once
departments <- tibble(
  dept_id = c(1, 2, 3, 5),
  dept_name = c(
    "HR", "Engineering", "Marketing", "Finance"
  ),
  manager_first = c(
    "alice", "robert", "diana", "carol"
  ),
  manager_last = c(
    "smith", "johnson", "lee", "taylor"
  ),
  budget = c(
    500000, 1000000, 750000, 600000
  )
)

print(departments)
# A tibble: 4 × 5
  dept_id dept_name   manager_first manager_last  budget
    <dbl> <chr>       <chr>         <chr>          <dbl>
1       1 HR          alice         smith         500000
2       2 Engineering robert        johnson      1000000
3       3 Marketing   diana         lee           750000
4       5 Finance     carol         taylor        600000
library(RSQLite)
library(DBI)
con <- DBI::dbConnect(SQLite(), "database.db")
if (!RSQLite::dbExistsTable(con, "departments")) {
  dbWriteTable(con, name = "departments", value = departments)
}
if (!RSQLite::dbExistsTable(con, "employees")) {
  dbWriteTable(con, name = "employees", value = employees)
}
PRAGMA table_info(employees);
5 records
cid name type notnull dflt_value pk
0 emp_id REAL 0 NA 0
1 first_name TEXT 0 NA 0
2 last_name TEXT 0 NA 0
3 dept_id REAL 0 NA 0
4 salary REAL 0 NA 0 
PRAGMA table_info(departments);
5 records
cid name type notnull dflt_value pk
0 dept_id REAL 0 NA 0
1 dept_name TEXT 0 NA 0
2 manager_first TEXT 0 NA 0
3 manager_last TEXT 0 NA 0
4 budget REAL 0 NA 0

Mutating Joins

Mutating joins combine columns from two tables based on matching keys, preserving rows depending on the join type.

Inner Join | inner_join()

We can use inner_join() function from dplyr to inner join the data. Inner join retains only rows with matching keys in both tables. The output table contains all columns, excluding the unmatched rows from both tables.

employees %>% 
  inner_join(departments, by = "dept_id") %>% 
  select(emp_id, first_name, last_name, salary, dept_name)
# A tibble: 4 × 5
  emp_id first_name    last_name  salary dept_name  
   <dbl> <chr>         <chr>       <dbl> <chr>      
1      1 Alice Susanna Smith       60000 HR         
2      2 Bob           Johnson     75000 Engineering
3      4 Diana         Lee         90000 Marketing  
4      6 Frank         DeVito Jr.  70000 Engineering
SELECT
 emp.emp_id,
 emp.first_name,
 emp.last_name,
 emp.salary,
 dept.dept_name 
 FROM employees AS emp
  INNER JOIN departments as dept
    ON emp.dept_id = dept.dept_id;
4 records
emp_id first_name last_name salary dept_name
1 Alice Susanna Smith 60000 HR
2 Bob Johnson 75000 Engineering
4 Diana Lee 90000 Marketing
6 Frank DeVito Jr. 70000 Engineering

Here,

  • Rows with dept_id = NA (Charlie) and dept_id = 4 (Eve) were dropped (no match in departments).
  • dept_id = 5 (Finance) was dropped (no match in employees).
  • dept_id = 2 appears twice (Bob and Frank), causing row expansion.

Left Join | left_join()

Left Join Keeps all rows from the left table, adding matched columns from the right table. The unmatched rows from the left table get NA for right-table columns. The left table is preserved entirely and the right table is attached where possible.

employees |> 
  left_join(departments, by = "dept_id") |> 
  select(names(employees), dept_name)
# A tibble: 6 × 6
  emp_id first_name    last_name  dept_id salary dept_name  
   <dbl> <chr>         <chr>        <dbl>  <dbl> <chr>      
1      1 Alice Susanna Smith            1  60000 HR         
2      2 Bob           Johnson          2  75000 Engineering
3      3 Mary Anne     Brown           NA  80000 <NA>       
4      4 Diana         Lee              3  90000 Marketing  
5      5 Eve           Davis            4  65000 <NA>       
6      6 Frank         DeVito Jr.       2  70000 Engineering
SELECT 
  emp.*, dept.dept_name
  FROM employees AS emp
  LEFT JOIN departments  AS dept
    ON emp.dept_id = dept.dept_id;
6 records
emp_id first_name last_name dept_id salary dept_name
1 Alice Susanna Smith 1 60000 HR
2 Bob Johnson 2 75000 Engineering
3 Mary Anne Brown NA 80000 NA
4 Diana Lee 3 90000 Marketing
5 Eve Davis 4 65000 NA
6 Frank DeVito Jr. 2 70000 Engineering

here,

  • All employees are retained, even those with NA or unmatched dept_id.
  • dept_id = 4 (Eve) and NA (Charlie) have NA for department columns.

Right Join | right_join()

Similar to Left Join, Right join Keeps all rows from the right table, adding matched columns from the left table. The unmatched rows from the right table get NA for left-table columns. The right table is preserved entirely and the left table is attached where possible.

employees |> 
  right_join(departments, by = "dept_id")
# A tibble: 5 × 9
  emp_id first_name    last_name  dept_id salary dept_name   manager_first
   <dbl> <chr>         <chr>        <dbl>  <dbl> <chr>       <chr>        
1      1 Alice Susanna Smith            1  60000 HR          alice        
2      2 Bob           Johnson          2  75000 Engineering robert       
3      4 Diana         Lee              3  90000 Marketing   diana        
4      6 Frank         DeVito Jr.       2  70000 Engineering robert       
5     NA <NA>          <NA>             5     NA Finance     carol        
# ℹ 2 more variables: manager_last <chr>, budget <dbl>
SELECT *
  FROM employees AS emp
  RIGHT JOIN departments  AS dept
    ON emp.dept_id = dept.dept_id;
5 records
emp_id first_name last_name dept_id salary dept_id dept_name manager_first manager_last budget
1 Alice Susanna Smith 1 60000 1 HR alice smith 500000
2 Bob Johnson 2 75000 2 Engineering robert johnson 1000000
4 Diana Lee 3 90000 3 Marketing diana lee 750000
6 Frank DeVito Jr. 2 70000 2 Engineering robert johnson 1000000
NA NA NA NA NA 5 Finance carol taylor 600000

here,

  • All departments are retained, even those with unmatched dept_id. The corresponding emp_id was set to NA if not matched with items in the departments.
  • dept_id = 5 (Finance department) where carol is the manager is retained even if she des not have any matched records in employees table.

Full Join | full_join()

Full join keeps all rows from both tables, filling NA where no match exists. Output is the union of both tables, with missing values for unmatched rows. In other words, it combines all data preserving everything.

employees %>% 
    full_join(departments, by = "dept_id")
# A tibble: 7 × 9
  emp_id first_name    last_name  dept_id salary dept_name   manager_first
   <dbl> <chr>         <chr>        <dbl>  <dbl> <chr>       <chr>        
1      1 Alice Susanna Smith            1  60000 HR          alice        
2      2 Bob           Johnson          2  75000 Engineering robert       
3      3 Mary Anne     Brown           NA  80000 <NA>        <NA>         
4      4 Diana         Lee              3  90000 Marketing   diana        
5      5 Eve           Davis            4  65000 <NA>        <NA>         
6      6 Frank         DeVito Jr.       2  70000 Engineering robert       
7     NA <NA>          <NA>             5     NA Finance     carol        
# ℹ 2 more variables: manager_last <chr>, budget <dbl>
SELECT * 
FROM employees 
FULL OUTER JOIN departments 
    ON employees.dept_id = departments.dept_id;
7 records
emp_id first_name last_name dept_id salary dept_id dept_name manager_first manager_last budget
1 Alice Susanna Smith 1 60000 1 HR alice smith 500000
2 Bob Johnson 2 75000 2 Engineering robert johnson 1000000
3 Mary Anne Brown NA 80000 NA NA NA NA NA
4 Diana Lee 3 90000 3 Marketing diana lee 750000
5 Eve Davis 4 65000 NA NA NA NA NA
6 Frank DeVito Jr. 2 70000 2 Engineering robert johnson 1000000
NA NA NA NA NA 5 Finance carol taylor 600000

here,

  • Includes all employees and all departments, even unmatched ones.
  • dept_id = 5 (Finance) appears with NA for employee columns.

Filtering Joins

Filtering joins subset rows from one table based on another, without merging columns.

Semi-Join | semi_join()

Semi-Join Returns rows from the left table that have a match in the right table. It returns a subset of the left table but no columns from the right table are added. For example: filtering the employees who belongs to one of the department in the departments table based on their dept_id information.

employees %>% 
  semi_join(departments, by = "dept_id")
# A tibble: 4 × 5
  emp_id first_name    last_name  dept_id salary
   <dbl> <chr>         <chr>        <dbl>  <dbl>
1      1 Alice Susanna Smith            1  60000
2      2 Bob           Johnson          2  75000
3      4 Diana         Lee              3  90000
4      6 Frank         DeVito Jr.       2  70000
SELECT employees.* 
FROM employees 
WHERE EXISTS (
  SELECT 1 FROM departments 
  WHERE employees.dept_id = departments.dept_id
);
4 records
emp_id first_name last_name dept_id salary
1 Alice Susanna Smith 1 60000
2 Bob Johnson 2 75000
4 Diana Lee 3 90000
6 Frank DeVito Jr. 2 70000

here,

  • Keeps only employees with dept_id present in departments.
  • Drops emp_id=3 (NA) and emp_id=5 (unmatched dept_id=4).

Anti-Join | anti_join()

Anti-Join returns rows from the left table with no match in the right table. For example: filtering the employees who do not belong to any of the department in the departments table.

employees %>% 
  anti_join(departments, by = "dept_id")
# A tibble: 2 × 5
  emp_id first_name last_name dept_id salary
   <dbl> <chr>      <chr>       <dbl>  <dbl>
1      3 Mary Anne  Brown          NA  80000
2      5 Eve        Davis           4  65000
SELECT employees.* 
FROM employees 
WHERE NOT EXISTS (
  SELECT 1 FROM departments 
  WHERE employees.dept_id = departments.dept_id
);
2 records
emp_id first_name last_name dept_id salary
3 Mary Anne Brown NA 80000
5 Eve Davis 4 65000

here, only employees with dept_id not in departments (or NA) are kept.

Advanced Cases: Preprocessing and Multiple Keys

Suppose we need find the employees with their departments who are also manager in their department. Here we have two issues to deal with:

  1. We need multiple keys (fields/ variables) to join. For example: dept_id in both table and first_name/ last_name from employees table and manager_first/ manager_last from departments table.

    To solve this we can use multiple keys to join the tables. We can use semi-join or inner-join on employees table using department tables.

  2. The first_name and last_name from employees table has uppercase characters and middle name in first_name field while manager_first and manager_last from departments tables are all lowercase. We need to preprocess them before using them as a joining key.

    To solve this, we lowercase the first word from first_name and manager_first and the last word from last_name and manager_last from tables employees and departments respectively.

employees |> 
  mutate(
    fname = stringr::word(first_name, 1) |> tolower(),
    lname = stringr::word(last_name, -1) |> tolower()
  ) |> inner_join(
    departments |> mutate(
      fname = stringr::word(manager_first, 1) |> tolower(),
      lname = stringr::word(manager_last, -1) |> tolower()
    ) |> select(dept_name, fname, lname, dept_id),
    by = join_by('fname', 'lname', 'dept_id')
  ) |> select(-dept_id, -fname, -lname)
# A tibble: 2 × 5
  emp_id first_name    last_name salary dept_name
   <dbl> <chr>         <chr>      <dbl> <chr>    
1      1 Alice Susanna Smith      60000 HR       
2      4 Diana         Lee        90000 Marketing
SELECT 
  emp.emp_id, emp.first_name, emp.last_name, 
  emp.salary, dept.dept_name
FROM employees emp
JOIN departments dept ON emp.dept_id = dept.dept_id
WHERE 
    -- First name: match first word
    LOWER(SUBSTR(
      emp.first_name, 1, 
      INSTR(emp.first_name || ' ', ' ') - 1
    )) = 
    LOWER(SUBSTR(
      dept.manager_first, 1, 
      INSTR(dept.manager_first || ' ', ' ') - 1
    ))
    
    -- Last name: match last word
    AND 
    LOWER(SUBSTR(
      emp.last_name, 
      INSTR(' ' || emp.last_name, ' ') + 1
    )) = 
    LOWER(SUBSTR(
      dept.manager_last, 
      INSTR(' ' || dept.manager_last, ' ') + 1
    ));
2 records
emp_id first_name last_name salary dept_name
1 Alice Susanna Smith 60000 HR
4 Diana Lee 90000 Marketing

Since the employees table uses first_name/last_name while departments uses manager_first/manager_last, I standardized the keys by:

  1. Extracting the first word from first_name and the last word from last_name (to handle middle names/suffixes).
  2. Converting them to lowercase for case-insensitive matching.

Also, check out a post, I have used all these concepts in a real dataset.

Joins are essential for combining data in R. With dplyr, you can handle mismatched keys, missing values, and multi-column joins—just clean your keys first and verify results with anti_join(). Try these techniques on your own data, or explore more examples here.

]]> https://mathatistics.com/blog/posts/2025-04-28-join-with-dplyr/index.html Mon, 17 Mar 2025 23:00:00 GMT Melanoma Incidence in Nordic Countries Raju Rimal https://mathatistics.com/blog/posts/2023-06-20-nordic-melanoma/index.html

Introduction

Cutaneous melanoma (CM) is the most aggressive and lethal form of skin cancer. Melanoma can be cured if caught and treated early but if left untreated, it may spread to other parts and can be fatal. In the recent years, melanoma has increased dramatically in fair skinned population worldwide including Nordic countries like Norway, Denmark, and Sweden. Norway is ranked fifth in incidence and third in mortality worldwide. This increase can be an effect of increased awareness in general public and health care provider.

This article explores melanoma incidence and mortality in nordic countries by sex and their trend over 40-years period from 1980–2020. Further, I try to step through the analysis process from data collection to create plots and tables.

Data Preparation

Data on melanoma were obtained from NORDCAN Engholm et al. (2010), Association of the Nordic Cancer Registries, IARC. Using NORDCAN 2.0 API1 crude and age-adjusted rates were downloaded as JSON and converted to tabular data for further analysis. R(R Core Team 2020) software was used for data gathering, cleanup, analysis, and plotting.

The API endpoint has four placeholder type, sex, country, and cancer following design was used to create individual endpoint. These individual url are used to download the JSON file as list in R.

Code for preparing download URL 
design_map <- list(
  sex = c(Male = 1, Female = 2),
  type = c(Incidence = 0, Mortality = 1),
  cancer = c(Melanoma = 290),
  country = c(
    Denmark = 208, Finland = 246, Iceland = 352,
    Norway = 578, Sweden = 752
  )
)
label_values <- function(data, label_map, var) {
  label_vec <- label_map[[var]]
  label <- `names<-`(names(label_vec), label_vec)
  data[[var]] <- data[, label[as.character(get(var))]]
  return(data)
}

design <- do.call(crossing, design_map) %>% 
  mutate(
    url = glue::glue( 
      "https://gco.iarc.fr/gateway_prod/api/nordcan/v2/92/data/population/{type}/{sex}/({country})/({cancer})/?ages_group=5_17&year_start=1980&year_end=2020&year_grouped=0"
    )
  )

design <- design %>% 
  label_values(design_map, "sex") %>% 
  label_values(design_map, "type") %>% 
  label_values(design_map, "cancer") %>% 
  label_values(design_map, "country")
API URL:
https://gco.iarc.fr/gateway_prod/api/nordcan/v2/92/data/population/{type}/{sex}/({country})/({cancer})/?ages_group=5_17&year_start=1980&year_end=2020&year_grouped=0

Replacing the placeholders type (Incidence: 0, Mortality: 1), sex (Male: 1, Female: 2), country (Denmark: 208, Finland: 246, Iceland: 352, Norway: 578, and Sweden: 752), and cancer (Melanoma: 290) prepare the data API.

Code 
json_data = await FileAttachment("Data/nordcan.json").json()
json_data[0]
Code for data download 
if (!file.exists("Data/nordcan-json.Rds")) {
  design[, data := map(url, ~read_json(.x) %>% purrr::pluck("dataset"))]
  saveRDS(design, file = "Data/nordcan-json.Rds")
} else {
  design <- readRDS("Data/nordcan-json.Rds")
}
design <- design %>% 
  tidytable::select(sex, type, country, data)
Rate data frame 
rate_df <- design[, map_df(data, function(dta) {
  out <- data.table(
    year = map_int(dta, ~get("year", .x)),
    asr_w = map_dbl(dta, ~get("asr", .x)),
    asr_e = map_dbl(dta, ~get("asr_e", .x)),
    asr_n = map_dbl(dta, ~get("asr_n", .x)),
    crude_rate = map_dbl(dta, ~get("crude_rate", .x)),
    count = map_dbl(dta, ~get("total", .x)),
    population = map_dbl(dta, ~get("total_pop", .x)),
    cum_risk = map(dta, ~get("cum_risk", .x)) %>% 
      unlist()
  )
  if ("cum_risk" %in% names(out)) {
    out <- out %>% 
      mutate(cum_risk = as.numeric(cum_risk))
  }
  return(out)
}), by = .(sex, type, country)]
Classes 'tidytable', 'data.table' and 'data.frame': 820 obs. of  10 variables:
 $ sex       : chr  "Male" "Male" "Male" "Male" ...
 $ type      : chr  "Incidence" "Incidence" "Incidence" "Incidence" ...
 $ country   : chr  "Denmark" "Denmark" "Denmark" "Denmark" ...
 $ year      : int  1980 1981 1982 1983 1984 1985 1986 1987 1988 1989 ...
 $ asr_w     : num  11.9 10.9 12.2 13.4 13.8 ...
 $ asr_e     : num  12.7 12.1 13.1 14.5 15.3 ...
 $ asr_n     : num  13.5 13.1 14.1 15.2 16 ...
 $ crude_rate: num  12.4 12 13.1 14.3 14.8 ...
 $ count     : num  196 191 210 230 239 234 269 283 291 306 ...
 $ population: num  1585436 1593815 1601416 1609960 1618038 ...
 - attr(*, ".internal.selfref")=<externalptr>
Rate by age 
rate_by_age <- design[, map_df(data, function(dta) {
  year <- map_int(dta, ~get("year", .x))
  count_df <- map(dta, ~get("ages", .x)) %>% 
    map_dfr(as_tidytable) %>% 
    cbind(year = year) %>% 
    pivot_longer(
      cols = -"year",
      names_to = "age_group",
      values_to = "count"
    )
  pop_df <- map(dta, ~get("populations", .x)) %>% 
    map_dfr(as_tidytable) %>%
    cbind(year = year) %>% 
    pivot_longer(
      cols = -"year",
      names_to = "age_group",
      values_to = "population"
    )
  asr_df <- map(dta, ~get("age_specific_rate", .x)) %>% 
    map_dfr(as_tidytable) %>% 
    as_tidytable() %>%
    cbind(year = as.numeric(year)) %>% 
    pivot_longer(
      cols = -"year",
      names_to = "age_group",
      values_to = "asr"
    )
  out <- purrr::reduce(
    list(count_df, pop_df, asr_df),
    inner_join,
    by = c("year", "age_group")
  )
  age_lbl <- paste(
    seq(0, 85, 5),
    seq(0, 85, 5) + 4,
    sep = "-"
  )
  age_lbl[length(age_lbl)] <- "85+"
  names(age_lbl) <- 1:18

  out %>% 
    mutate(age_group = age_lbl[age_group]) %>% 
    mutate(asr = as.numeric(asr)) %>% 
    mutate(across(c(year, count, population), as.integer))

}), by = .(sex, type, country)]
Classes 'tidytable', 'data.table' and 'data.frame': 14760 obs. of  8 variables:
 $ sex       : chr  "Male" "Male" "Male" "Male" ...
 $ type      : chr  "Incidence" "Incidence" "Incidence" "Incidence" ...
 $ country   : chr  "Denmark" "Denmark" "Denmark" "Denmark" ...
 $ year      : int  1980 1981 1982 1983 1984 1985 1986 1987 1988 1989 ...
 $ age_group : chr  "0-4" "0-4" "0-4" "0-4" ...
 $ count     : int  0 0 0 0 0 0 0 0 0 0 ...
 $ population: int  164317 156964 150170 145414 139557 135827 134375 136240 138423 142597 ...
 $ asr       : num  0 0 0 0 0 0 0 0 0 0 ...
 - attr(*, ".internal.selfref")=<externalptr>

Analysis

For the following analysis, crude rates were used in visualization and modelling. Stratified by sex, country and type following plots presents the the crude_rate over the year of diagnosis. Additionally, using count and population, a poisson regression model (Equation 1) was fitted.

where, is the number of events (count), is the number of exposed (population) and is the year of diagnosis.

Additionally, using segmented regression the change points in the trend was identified and the annual percentage change (APC) and average annual percentage change (AAPC) in crude rate were calculated. For each strata, following R-code for poisson regression model and segmented regression model were used.

Data within each strata 
nested_df <- rate_df %>% 
  nest(data = -c(sex, type, country))
head(nested_df)
# A tidytable: 6 × 4
  sex   type      country data                
  <chr> <chr>     <chr>   <list>              
1 Male  Incidence Denmark <tidytable [41 × 7]>
2 Male  Incidence Finland <tidytable [41 × 7]>
3 Male  Incidence Iceland <tidytable [41 × 7]>
4 Male  Incidence Norway  <tidytable [41 × 7]>
5 Male  Incidence Sweden  <tidytable [41 × 7]>
6 Male  Mortality Denmark <tidytable [41 × 7]>

Modelling

Poisson regression model 
model <- glm(
  count ~ year + offset(log(population)),
  data = rate_df,
  family = poisson(link = "log")
)
Segmented regression model 
sgmt_model <- segmented(model, npsi = 2)
Poisson and segmented fit 
fitted_df <- nested_df %>% 
  mutate(fit = map(data, function(.data) {
    glm(
      count ~ year + offset(log(population)),
      family = poisson(link = "log"),
      data = .data
    )
  })) %>% 
  mutate(sgmt_fit = map2(data, fit, function(.data, .fit) {
    out <- segmented(.fit, seg.Z = ~year, data = .data, npsi = 2)
    if (!("segmented" %in% class(out))) {
      out <- segmented(.fit, seg.Z = ~year, data = .data, npsi = 1)
    }
    return(out)
  }))

head(fitted_df)
# A tidytable: 6 × 6
  sex   type      country data                 fit    sgmt_fit  
  <chr> <chr>     <chr>   <list>               <list> <list>    
1 Male  Incidence Denmark <tidytable [41 × 7]> <glm>  <segmentd>
2 Male  Incidence Finland <tidytable [41 × 7]> <glm>  <segmentd>
3 Male  Incidence Iceland <tidytable [41 × 7]> <glm>  <segmentd>
4 Male  Incidence Norway  <tidytable [41 × 7]> <glm>  <segmentd>
5 Male  Incidence Sweden  <tidytable [41 × 7]> <glm>  <segmentd>
6 Male  Mortality Denmark <tidytable [41 × 7]> <glm>  <segmentd>

Following plots highlighting Norway and Finland for comparison show a higher melanoma incidence and mortality rate in Norway compared to Finland. A plateau was observed in melanoma incidence in Norway in both male and female.

Crude rate plot 
cols <- RColorBrewer::brewer.pal(fitted_df[, n_distinct(country)], "Set1") 
names(cols) <- fitted_df[, unique(country)]

rate_df %>% 
  filter(country != "Iceland") %>% 
  ggplot(aes(year, crude_rate, group = country)) +
  facet_grid(
    cols = vars(sex),
    rows = vars(type),
    scales = "free_y"
  ) +
  geom_line(color = "lightgrey") +
  geom_point(
    fill = "whitesmoke", 
    shape = 21, 
    color = "lightgrey",
    stroke = 1,
    size = 1
  ) +
  geom_line(
    data = ~subset(.x, country %in% c("Finland", "Norway")),
    aes(color = country)
  ) +
  ggthemes::theme_few(base_size = 14) +
  theme(
    legend.position = "bottom",
    legend.justification = "left",
    panel.grid = element_line(color = "#f0f0f0")
  ) +
  scale_color_manual(breaks = names(cols), values = cols) +
  labs(
    x = "Year of diagnosis",
    y = "Crude rate per 100,000 person-years",
    color = "Country"
  )

Fitted values from the model 
fitted_df <- fitted_df %>% 
  mutate(
    fit_df = map(
      fit, 
      function(.fit) {
        new_data <- crossing(year = 1980:2020, population = 1e5)
        tidytable(
          year = new_data[, year],
          .fitted = predict(.fit, newdata = new_data, type = "response")
        )
      }),
    sgmt_fit_df = map(
      sgmt_fit, function(.fit) {
        new_data <- crossing(year = 1980:2020, population = 1e5)
        pred_df <- predict(
          .fit, newdata = new_data,
          type = "link", interval = "confidence"
        ) %>% exp() %>% apply(1:2, prod, 1e5) %>% 
        as_tidytable() %>% 
        rename_with(~c(".fitted", ".lower", ".upper"))
        bind_cols(year = new_data[, year], pred_df)
      })
  )
Crude rate with poisson fit 
fit_df <- fitted_df %>%
  unnest(fit_df) %>%
  filter(country != "Iceland")

plot_poisson <- function(rate_df, fit_df, countries = NULL) {
  if (is.null(countries)) {
    countries <- rate_df[, country]
  }
  rate_df %>%
    filter(country != "Iceland") %>%
    ggplot(aes(year, crude_rate, group = country)) +
    facet_grid(
      cols = vars(sex),
      rows = vars(type),
      scales = "free_y"
    ) +
    geom_line(color = "lightgrey") +
    geom_point(
      fill = "whitesmoke",
      shape = 21,
      color = "lightgrey",
      stroke = 1,
      size = 1
    ) +
    geom_line(
      data = ~ subset(fit_df, country %in% countries),
      aes(color = country, y = .fitted),
    ) +
    ggthemes::theme_few(base_size = 14) +
    theme(
      legend.position = "bottom",
      legend.justification = "left",
      panel.grid = element_line(color = "#f0f0f0")
    ) +
    scale_color_manual(breaks = names(cols), values = cols) +
    labs(
      x = "Year of diagnosis",
      y = "Crude rate per 100,000 person-years",
      color = "Country"
    )
}
plot_poisson(rate_df, fit_df, c("Finland", "Norway"))

Crude rate with poisson fit 
plot_segmented <- function(rate_df, fit_df, countries = NULL, show_poisson = T) {
  sgmt_fit_df <- fitted_df %>% 
    filter(country != "Iceland") %>% 
    unnest(sgmt_fit_df)

  if (is.null(countries)) {
    countries <- rate_df[, unique(country)]
  } else {
    sgmt_fit_df <- sgmt_fit_df %>% filter(country %in% countries)
  }

  plt <- rate_df %>% 
    filter(country != "Iceland") %>% 
    ggplot(aes(year, crude_rate, group = country)) +
    facet_grid(
      cols = vars(sex),
      rows = vars(type),
      scales = "free_y"
    ) +
    geom_line(color = "lightgrey") +
    geom_point(
      fill = "whitesmoke", 
      shape = 21, 
      color = "lightgrey",
      stroke = 1,
      size = 1
    ) +
    geom_line(
      data = ~subset(sgmt_fit_df, country %in% countries),
      aes(color = country, y = .fitted),
      linetype = if (show_poisson) "dashed" else "solid"
    ) +
    ggthemes::theme_few(base_size = 14) +
    theme(
      legend.position = "bottom",
      legend.justification = "left",
      panel.grid = element_line(color = "#f0f0f0")
    ) +
    scale_color_manual(breaks = names(cols), values = cols) +
    labs(
      x = "Year of diagnosis",
      y = "Crude rate per 100,000 person-years",
      color = "Country"
    )

    if (show_poisson) {
      plt <- plt +
        geom_line(
          data = ~subset(fit_df, country %in% countries),
          aes(color = country, y = .fitted),
          alpha = 0.5
        )
    }
    return(plt)
}
plot_segmented(rate_df, fit_df, c("Norway", "Finland"))

Crude rate with poisson fit for all countries 
plot_poisson(rate_df, fit_df)

Crude rate with poisson fit for all countries 
plot_segmented(rate_df, fit_df, show_poisson = FALSE)

Here, Norway leads with the highest rates of melanoma incidence and mortality, while Finland shines with the lowest rates across both sexes. Recently, Denmark has surged ahead of Norway and Sweden in terms of melanoma incidence.

Interestingly, Norway had a plateau in melanoma cases for a while, but most Nordic countries saw a rise in melanoma cases after 2005. The silver lining here is that all countries have experienced a drop in melanoma mortality in recent years, thanks to better detection, treatments, and awareness.

Annual percentge change (APC)

Code 
tidy_fit <- fitted_df %>% 
  transmute(tidy_fit = map(fit, function(.fit) {
    broom::tidy(.fit, exponentiate = TRUE, conf.int = TRUE) %>% 
      filter(term == "year", country != "Iceland")
  }), .by = c(sex, type, country)) %>% 
  unnest()

tidy_fit %>% 
  mutate(country = factor(country, c(
    "Finland", "Denmark",
    "Sweden", "Norway"
  ))) %>% 
  ggplot(aes(x = estimate, y = country, color = sex)) +
  facet_grid(cols = vars(type)) +
  geom_pointrange(
    aes(xmin = conf.low, xmax = conf.high),
    shape = 21,
    fill = "whitesmoke",
    position = position_dodge(width = 0.5)
  ) +
  geom_vline(xintercept = 1, linetype = 2, color = "grey") +
  scale_color_brewer(palette = "Set1") +
  expand_limits(x = 1) +
  ggthemes::theme_few(base_size = 16) +
  theme(
    panel.grid = element_line(color = "#f0f0f0"),
    legend.position = "bottom",
    legend.justification = "left"
  ) +
  labs(
    x = "Percentage change in count",
    y = NULL
  )

Calculating annual percentage change 
aapc_df <- fitted_df %>% 
  transmute(
    aapc = map(sgmt_fit, function(.fit) {
      aapc(.fit) %>% 
        t() %>% 
        as_tidytable() %>% 
        rename_with(
          ~c("estimate", "std_err", "lower", "upper")
        ) %>% 
        mutate(psi = "1980--2020") %>% 
        mutate(
          label = glue::glue(
            "{estimate} ({lower}, {upper})",
            .transformer = \(d, e) round(get(d, e), 2)
          )
        )
    }),
    apc = map(sgmt_fit, function(fit) {
      if (!"segmented" %in% class(fit)) return(NULL)
      out <- slope(fit, APC = TRUE)[[1]] %>% 
        as_tidytable(.keep_rownames = "segment")
      psi_start <- unname(c(1980, fit$psi[, "Est."], 2020))
      psi_end <- lead(psi_start, 1)
      psi_range <- glue::glue(
        "{psi_start}--{psi_end}",
        .transformer = \(d, e) round(get(d, e))
      )
      psi_range <- setdiff(psi_range, last(psi_range))
      out %>% 
        mutate(psi = psi_range) %>% 
        rename_with(
          .fn = ~c("estimate", "lower", "upper"), 
          .cols = 2:4
        ) %>% 
        mutate(label = glue::glue(
          "{estimate} ({lower}, {upper})",
          .transformer = \(d, e) round(get(d, e), 2)
        )) %>% 
        mutate(label_period = glue::glue("{label}<br>{psi}")) %>% 
        mutate(segment = gsub("slope", "", segment))
    }),
    .by = c(sex, type, country)
  )

apc <- aapc_df %>% unnest("apc")
aapc <- aapc_df %>% unnest("aapc")
Table data for APC 
apc %>% 
  filter(country %in% c("Norway", "Denmark")) %>% 
  pivot_wider(
    id_cols = c(country, segment),
    names_from = c(type, sex),
    values_from = "label_period"
  ) %>% 
  gt::gt(
    id = "apc-table",
    rowname_col = "segment",
    groupname_col = "country"
  ) %>% 
  gt::tab_spanner_delim("_") %>% 
  gt::fmt_markdown(everything()) %>% 
  gt::sub_missing(everything(), missing_text = "-") %>%
  gt::tab_stubhead("Segment") %>% 
  gt::tab_options(
    table.width = "100%",
    column_labels.font.weight = "bold",
    row_group.font.weight = "bold"
  )
Segment
Incidence
Mortality
Male Female Male Female
Denmark
1 3.54 (3.23, 3.85)
1980–2004		 2.73 (2.4, 3.06)
1980–2002		 0.63 (0.1, 1.17)
1980–2004		 0.51 (0.12, 0.91)
1980–2011
2 9.8 (7.32, 12.33)
2004–2009		 6.92 (5.96, 7.88)
2002–2011		 4.1 (0.93, 7.37)
2004–2012		 12.09 (-12.23, 43.14)
2011–2013
3 3.1 (2.53, 3.68)
2009–2020		 1.79 (1.18, 2.41)
2011–2020		 -2.15 (-4.08, -0.19)
2012–2020		 -4.08 (-7.35, -0.69)
2013–2020
Norway
1 5.49 (4.32, 6.67)
1980–1991		 3.87 (2.67, 5.09)
1980–1990		 17.12 (-0.32, 37.61)
1980–1982		 1.02 (0.19, 1.85)
1980–2000
2 0.45 (-0.44, 1.35)
1991–2002		 0.17 (-0.69, 1.04)
1990–2000		 1.78 (1.39, 2.18)
1982–2011		 2.64 (1.25, 4.05)
2000–2013
3 4.39 (4.08, 4.69)
2002–2020		 3.67 (3.39, 3.95)
2000–2020		 -2.05 (-3.87, -0.2)
2011–2020		 -5.28 (-8.41, -2.05)
2013–2020

Comparing countries

Code 
mdl_inc <- glm(
  data = rate_df,
  formula = count ~ year + sex + country,
  offset = log(population),
  family = poisson(link = "log"),
  subset = type == "Incidence"
)

broom::tidy(mdl_inc, conf.int = TRUE, exponentiate = TRUE) %>% 
  mutate(across(c(2:4, 6:7), round, 3))
# A tidytable: 7 × 7
  term           estimate std.error statistic   p.value conf.low conf.high
  <chr>             <dbl>     <dbl>     <dbl>     <dbl>    <dbl>     <dbl>
1 (Intercept)       0         0.383   -205.   0            0         0    
2 year              1.04      0        185.   0            1.04      1.04 
3 sexMale           1.01      0.004      1.90 5.68e-  2    1         1.02 
4 countryFinland    0.649     0.007    -62.6  0            0.64      0.658
5 countryIceland    0.494     0.028    -25.6  1.86e-144    0.468     0.521
6 countryNorway     1.05      0.006      8.09 5.84e- 16    1.04      1.06 
7 countrySweden     0.936     0.005    -12.1  1.41e- 33    0.926     0.946
Code 
mdl_mor <- glm(
  data = rate_df,
  formula = count ~ year + sex + country,
  offset = log(population),
  family = poisson(link = "log"),
  subset = type == "Mortality"
)

broom::tidy(mdl_mor, conf.int = TRUE, exponentiate = TRUE) %>% 
  mutate(across(c(2:4, 6:7), round, 3))
# A tidytable: 7 × 7
  term           estimate std.error statistic   p.value conf.low conf.high
  <chr>             <dbl>     <dbl>     <dbl>     <dbl>    <dbl>     <dbl>
1 (Intercept)       0         0.844    -40.9  0            0         0    
2 year              1.01      0         29.2  1.53e-187    1.01      1.01 
3 sexMale           1.46      0.01      38.0  0            1.43      1.49 
4 countryFinland    0.731     0.016    -19.2  1.67e- 82    0.708     0.755
5 countryIceland    0.611     0.061     -8.02 1.05e- 15    0.54      0.688
6 countryNorway     1.24      0.015     14.6  3.57e- 48    1.20      1.27 
7 countrySweden     1.03      0.013      2.2  2.78e-  2    1.00      1.06

Summary

In summary, melanoma trends across the Nordic countries reveal some concerning patterns. Incidence and mortality have been increasing in all countries, with Norway showing the highest mortality rate and the most substantial rise in both incidence and mortality. Denmark saw a particularly rapid increase in melanoma cases between 2002 and 2011 in women and between 2004 and 2009 in men, surpassing Norway during those periods.

However, there is a silver lining: recent years have shown a decrease in melanoma mortality rates across all the Nordic countries. This positive trend suggests that advancements in medical treatments, early detection efforts, and greater public awareness are starting to make a difference. While the rise in incidence remains a challenge, the declining mortality rates provide a hopeful perspective moving forward.

References

Engholm, Gerda, Jacques Ferlay, Niels Christensen, Freddie Bray, Marianne L. Gjerstorff, Åsa Klint, Jóanis E. Køtlum, Elínborg Ólafsdóttir, Eero Pukkala, and Hans H. Storm. 2010. “NORDCAN – a Nordic Tool for Cancer Information, Planning, Quality Control and Research.” Acta Oncologica 49 (5): 725–36. https://doi.org/ch4598.
Larønningen, S., J. Ferlay, H. Beydogan, F. Bray, G. Engholm, M. Ervik, J. Gulbrandsen, et al. 2022. “NORDCAN: Cancer Incidence, Mortality, Prevalence and Survival in the Nordic Countries, Version 9.2 (23.06.2022).” 2022. https://nordcan.iarc.fr/.
Muggeo, Vito M. R. 2008. “Segmented: An r Package to Fit Regression Models with Broken-Line Relationships.” R News 8 (1): 20–25. https://cran.r-project.org/doc/Rnews/.
Norway, Cancer Registry of. 2022. “Cancer in Norway 2021: Cancer Incidence, Mortality, Survival and Prevalence in Norway.” 0806-3621. Cancer Registry of Norway. https://www.kreftregisteret.no/globalassets/cancer-in-norway/2021/cin_report.pdf.
R Core Team. 2020. “R: A Language and Environment for Statistical Computing.” Manual. Vienna, Austria. https://www.R-project.org/.
Welch, H. Gilbert, Benjamin L. Mazer, and Adewole S. Adamson. 2021. “The Rapid Rise in Cutaneous Melanoma Diagnoses.” New England Journal of Medicine 384 (1): 72–79. https://doi.org/gm6vs4.
Whiteman, David C., Adele C. Green, and Catherine M. Olsen. 2016. “The Growing Burden of Invasive Melanoma: Projections of Incidence Rates and Numbers of New Cases in Six Susceptible Populations Through 2031.” The Journal of Investigative Dermatology 136 (6): 1161–71. https://doi.org/f8psv4.

Footnotes

  1. https://gco.iarc.fr/gateway_prod/api/nordcan/v2/92/data/population/{type}/{sex}/({country})/({cancer})/?ages_group=5_17&year_start=1980&year_end=2020&year_grouped=0↩︎

]]> https://mathatistics.com/blog/posts/2023-06-20-nordic-melanoma/index.html Mon, 19 Jun 2023 22:00:00 GMT Age Adjusted Rates in Epidemiology TheRimalaya https://mathatistics.com/blog/posts/2022-12-02-age-adjusted-rates/index.html In general, rates means how fast something is changing usually over time. In epidemiology uses it to describe how quickly a disese occurs in a population. For example, 35 cases of melanoma cases in 100,000 person per year convey a the sense of speed of spread of disease in that population. Incidence rate and mortality rate are two examples that we will discuss further below.

In epidemiology, rate measures the frequency of occurance of an event in a given population over certain period of time1.

Let us use melanoma as a outcome in the following discussion. Here, we can calculate a crude incidence rate as,

In the case of mortality rate, we can replace the numerator of above expression by the number of melanoma deaths.

Age-specific rate

Weather to understand a broder prespecitve or to compare across population, these rates are often analyzed stratified by sex and age. This also helps to remove the confounding effection of these factors. The incidence/mortality rate per age-group is usually referred to as Age-specific rates where rates are computed for each age-groups. This is often desirable since factor age has a strong effect on mortality and incidence of most disease especially the cronic one.

Age-adjusted rate

Many research articles, however presents the age-adjusted rates. Age-adjusted rates are standardized (weighted) using some standard population age-structure. For example, many european studies on melanoma uses european standard age distribution. While any reasonal studies have also used world standard population. Cancer registry in their reports sometimes uses age-structure of that country in some given year. For instance, Norway2 and Finland3 have used the their population in 2014 as standard population in their recent cancer report while Australia have used 2001 Australian population4.

Standardized (adjusted) rates makes comparison between the population possible. Figure Figure 1 shows the difference in the age distribution between world population and European population. Following table are some of the standard population often used in the study. Further on standard popuation see seer.cancer.gov5.

Standard Population by Age

Standard Population 
us2000 <- tidytable(
  `AgeGroup` = c(
    "0", "1-4", "5-9", "10-14", "15-19", 
    "20-24", "25-29", "30-34", "35-39", "40-44", "45-49", "50-54",
    "55-59", "60-64", "65-69", "70-74", "75-79", "80-84", "85+"
  ), 
  US2000 = c(
    13818, 55317, 72533, 73032, 72169, 66478, 64529, 71044, 80762, 81851, 
    72118, 62716, 48454, 38793, 34264, 31773, 26999, 17842, 15508
  )
)
std_pop <- as_tidytable(popEpi::stdpop18) %>% 
  mutate(agegroup = case_when(
    agegroup == "85" ~ "85+", 
    TRUE ~ agegroup
  )) %>% mutate(
    age = case_when(
      agegroup == "0-4" ~ list(c("0", "1-4")),
      TRUE ~ as.list(agegroup)
    )
  ) %>% unnest(age) %>% rename_with(
    ~c("Age Group", "World", "Europe", "Nordic", "AgeGroup")
  ) %>% left_join(us2000) %>% 
  tidytable::mutate(across(everything(), function(x) {
    if (x[1] == x[2]) x[2] <- NA
    return(x)
  })) %>% mutate(
    AgeGroup = c(AgeGroup[1:2], rep(NA, length(AgeGroup) - 2))
  )

gt::gt(std_pop) %>% 
  gt::sub_missing(missing_text = "") %>% 
  gt::cols_label(AgeGroup = "") %>% 
  gt::opt_vertical_padding(0.5) %>%
  gt::tab_style(
    style = gt::cell_borders(sides = "top", weight = "0"),
    locations = gt::cells_body(1:4, rows = 2)
  ) %>% 
  gt::tab_options(column_labels.font.weight = "bold") %>% 
  gt::tab_header("Standard Population by Age Group")
Standard Population by Age Group
Age Group World Europe Nordic US2000
0-4 12000 8000 5900 0 13818


1-4 55317
5-9 10000 7000 6600
72533
10-14 9000 7000 6200
73032
15-19 9000 7000 5800
72169
20-24 8000 7000 6100
66478
25-29 8000 7000 6800
64529
30-34 6000 7000 7300
71044
35-39 6000 7000 7300
80762
40-44 6000 7000 7000
81851
45-49 6000 7000 6900
72118
50-54 5000 7000 7400
62716
55-59 4000 6000 6100
48454
60-64 4000 5000 4800
38793
65-69 3000 4000 4100
34264
70-74 2000 3000 3900
31773
75-79 1000 2000 3500
26999
80-84 500 1000 2400
17842
85+ 500 1000 1900
15508
Standard population plot 
pop_data <- as_tidytable(popEpi::stdpop18) %>% 
  mutate(nordic = NULL, id = 1:n())

pop_data %>% 
  mutate(world = world * -1) %>% 
  pivot_longer(cols = c(world, europe)) %>% 
  arrange(id) %>% 
  ggplot(aes(value, reorder(agegroup, id), fill = name)) +
  geom_col(width = 1, color = "#f0f0f0", size = 0.2) +
  theme_minimal() +
  ggthemes::scale_fill_economist(labels = stringr::str_to_title) +
  theme(
    legend.position = "none",
    panel.grid.major.y = element_blank(),
    panel.grid.minor.y = element_line(color = "red")
  ) +
  scale_x_continuous(labels = abs, expand = expansion()) +
  scale_y_discrete(expand = expansion()) +
  labs(
    x = "Number of person",
    y = NULL,
    fill = "Population"
  ) +
  annotate(
    x = -Inf, y = Inf,
    geom = "text", label = "World",
    hjust = -0.5, vjust = 1.5
  ) +
  annotate(
    x = Inf, y = Inf,
    geom = "text", label = "Europe",
    hjust = 1.5, vjust = 1.5
  )

Figure 1: World and European Standard Population

Calculating age-standardized rate

The age-standardized rate (ASR) is calculated as,

where, is the weight corresponding to age-group in the reference population.

Let’s explore further with an example from melanoma cases from Australia.

Example

The following example have used the Austrailian cancer data with 5-year age-group6 after filtering melanoma cases from 1982 to 2018. The dataset has yearly count and age-specific incidence rate of melanoma for men and women.

Let us use the above European standard population to find the yearly age-standardized incidence by sex.

Age-specific Data 
std_pop <- as_tidytable(popEpi::stdpop18) %>% 
  rename_with(~c("AgeGroup", "World", "Europe", "Nordic")) %>% 
  mutate(AgeGroup = case_when(
    AgeGroup == "85" ~ "85+", 
    TRUE ~ AgeGroup
  )) %>% mutate(
    across(World:Nordic, prop.table)
  )

data <- tidytable::fread("melanoma.csv") %>% 
  mutate(AgeGroup = case_when(
    AgeGroup %in% c("85-89", "90+") ~ "85+",
    TRUE ~ AgeGroup
  ))

asp_data <- data %>% 
  left_join(
    std_pop %>% select(AgeGroup, World), 
    by = "AgeGroup"
  )

head(asp_data)
# A tidytable: 6 × 6
   Year Sex   AgeGroup Count   ASR World
  <int> <chr> <chr>    <int> <dbl> <dbl>
1  1982 Males 0-4          0   0    0.12
2  1982 Males 5-9          0   0    0.1 
3  1982 Males 10-14        6   0.9  0.09
4  1982 Males 15-19       30   4.6  0.09
5  1982 Males 20-24       52   7.7  0.08
6  1982 Males 25-29       83  13.1  0.08
Age-standardized Rate 
asp <- asp_data %>% 
  group_by(Year, Sex) %>% 
  summarize(AgeAdjRate = sum(ASR * World))

asp %>% 
  group_by(Sex) %>% 
  slice_tail(8) %>% 
  ungroup() %>% 
  tidytable::pivot_wider(
    names_from = "Year",
    values_from = "AgeAdjRate"
  ) %>% 
  gt::gt() %>% 
  gt::opt_vertical_padding(0.5) %>% 
  gt::fmt_number(columns = -1) %>% 
  gt::tab_options(table.width = "100%")
Sex 2011 2012 2013 2014 2015 2016 2017 2018
Females 28.91 29.69 30.30 30.52 30.86 32.16 31.51 32.40
Males 41.43 42.38 43.13 42.84 43.73 45.31 45.27 45.04

Now, let us compare the age-specific rates (crude rates) and age-standardized rates with a plot,

Compare the age-specific rates and age-adjusted rates

Age-specific rates vs Age-adjusted rates 
ggplot() +
  geom_line(
    data = data,
    aes(
      x = Year,
      y = ASR,
      group = AgeGroup,
      color = "Crude"
    )
  ) +
  geom_line(
    data = asp,
    aes(
      x = Year,
      y = AgeAdjRate,
      group = 1,
      color = "Age-adjusted"
    )
  ) +
  geom_text(
    data = data[Year == max(Year)],
    check_overlap = TRUE,
    size = rel(2),
    color = "#0f0f0f",
    aes(
      x = Year + 2,
      y = ASR,
      label = AgeGroup
    )
  ) +
  scale_x_continuous(breaks = scales::breaks_extended(8)) +
  scale_y_continuous(breaks = scales::breaks_extended(8)) +
  scale_color_manual(NULL, values = c("firebrick", "grey")) +
  facet_grid(cols = vars(Sex)) +
  theme_minimal() +
  theme(
    panel.border = element_rect(fill = NA, color = "darkgrey"),
    legend.position = "inside",
    legend.position.inside = c(0, 1),
    legend.justification = c(0, 1)
  ) +
  labs(
    x = "Diagnosis year",
    y = paste(
      "Age-adjusted incidence rate",
      "per 100,000 person year",
      sep = "\n"
    )
  )

Figure 2: Age-specific and Age-adjusted rate showing why age-adjustement is necessary

Compare the age-adjusted rates by sex

Age-adjusted rates by sex 
ggplot(asp, aes(x = Year, y = AgeAdjRate, color = Sex)) +
  geom_line() +
  geom_point(fill = "whitesmoke", shape = 21) +
  scale_x_continuous(breaks = scales::breaks_extended(8)) +
  scale_y_continuous(breaks = scales::breaks_extended(8)) +
  scale_color_brewer(palette = "Set1") +
  theme_minimal() +
  theme(
    panel.border = element_rect(fill = NA, color = "darkgrey"),
    legend.position = c(0, 1),
    legend.justification = c(0, 1)
  ) +
  labs(
    x = "Diagnosis year",
    y = paste(
      "Age-adjusted incidence rate",
      "per 100,000 person year",
      sep = "\n"
    )
  ) +
  expand_limits(y = 0)

Figure 3: Age-adjusted rates by sex for melanoma patients

Discussion

Figure Figure 2 shows that the incidence of melanoma has larger difference in men between the age-groups than in women and men also have a sharp increase in older age group. In addition, the Figure Figure 3 shows that males have higher age-adjusted incidence of melanoma than women in Australia and this trend is increasing over time with rapid increase before 1983 before a drop.

Age-adjusted rates are useful for comparing rates between population but it cannot give the interpretation required for comparing within a population or over a time period in that population. This is one of the reason, cancer registry uses the internal (population structure of their own population) to compute the age-adjusted rates.

Footnotes

  1. https://www.cdc.gov/csels/dsepd/ss1978/lesson3/section1.html↩︎

  2. https://www.kreftregisteret.no/globalassets/cancer-in-norway/2021/cin_report.pdf↩︎

  3. https://cancerregistry.fi/reports-and-publications/annual-report-on-cancer-in-finland/↩︎

  4. https://www.aihw.gov.au/reports/cancer/cancer-in-australia-2021/summary↩︎

  5. https://seer.cancer.gov/stdpopulations/stdpop.19ages.html↩︎

  6. https://www.aihw.gov.au/reports/cancer/cancer-data-in-australia/data↩︎

]]> https://mathatistics.com/blog/posts/2022-12-02-age-adjusted-rates/index.html Mon, 19 Jun 2023 22:00:00 GMT Simulating data for ANOVA similar to existing dataset for analysis TheRimalaya https://mathatistics.com/blog/posts/2023-02-04-simulation-anova-and-analysis/index.html Simulating data is an important tool in both education and research, and it has been extremely helpful for testing, comparing, and understanding concepts in practical and applied settings.

Often, we use Analysis of Variance (ANOVA) to analyze variances to find out if different cases result in similar outcomes and if the differences are significant. Some simple examples include:

  • The effect of different diets on the growth of fish
  • Comparing the heights of three different plant species
  • The type of flour used for baking bread

These are common examples where, in some cases, data are collected by setting up an experiment, and in other cases, they are collected through sampling. This article explains how ANOVA analyzes the variance and in what situations are they significant through both simulated and real data.

Consider the following model with groups and observations,

Here, is the effect corresponding to group and , the usual assumption of linear model. The simulation example below describes it in detail.

Simulation Example

In this simulation example, I aim to replicate specific elements of the USArrests dataset by simulating 50 cases for three types of crimes: Murder, Assault, and Rape. For each crime, I categorize individuals into three groups based on illiteracy levels and simulate their respective arrest rates. Here’s concise overview of the process and analysis steps:

Simulation Design

Simulation design 
sim_design <- tidytable(
  Illiteracy = factor(
    rep(c(1, 2, 3), 3),
    labels = c("high", "medium", "low")
  ),
  Crime = factor(
    rep(c(1, 2, 3), each = 3),
    labels = c("Murder", "Assault", "Rape")
  ),
  mean = c(11, 8, 5, 214, 190, 114, 23, 21, 19),
  sd = c(3, 4, 3, 79, 82, 55, 8, 10, 10)
)

sim_design
# A tidytable: 9 × 4
  Illiteracy Crime    mean    sd
  <fct>      <fct>   <dbl> <dbl>
1 high       Murder     11     3
2 medium     Murder      8     4
3 low        Murder      5     3
4 high       Assault   214    79
5 medium     Assault   190    82
6 low        Assault   114    55
7 high       Rape       23     8
8 medium     Rape       21    10
9 low        Rape       19    10

Since these data cannot contain negative values so instead of using rnorm available in stats package, I will use truncnorm available in GitHub. There are other options as well which can be used such as: …

If not installed, install the package as remotes::install_github("olafmersmann/truncnorm") or devtools::install_github("olafmersmann/truncnorm").

Code for Simulation, Analysis, and Plot

Let’s simulate 50 observation Arrest Rate in each levels of Illiteracy, and Crime in simulation design.

nsim <- 50
sim_data <- sim_design %>% 
  group_by(Illiteracy, Crime) %>% 
  mutate(rate = map2(mean, sd, ~tidytable(
    Rate = truncnorm::rtruncnorm(
      n = nsim, a = 0, b = Inf, mean = .x, sd = .y
    ) %>% round()
  ))) %>% 
  unnest() %>% ungroup() %>% 
  nest(.by = c(Crime))

Here, Arrest rates were generated from a normal distribution using truncnorm from truncnorm package to get only positive value and also mirroring the mean and standard deviation in USArrests. Using normal distributions ensures the synthetic data mimics the actual data’s variation and mean, making the simulations realistic.

Simulated data by group 
sim_data
# A tidytable: 3 × 2
  Crime   data                 
  <fct>   <list>               
1 Murder  <tidytable [150 × 4]>
2 Assault <tidytable [150 × 4]>
3 Rape    <tidytable [150 × 4]>
Simulated data for Murder 
head(sim_data[Crime == "Murder", data][[1]])
# A tidytable: 6 × 4
  Illiteracy  mean    sd  Rate
  <fct>      <dbl> <dbl> <dbl>
1 high          11     3     7
2 high          11     3    11
3 high          11     3     9
4 high          11     3    12
5 high          11     3    15
6 high          11     3    13
Simulated data for Assault 
head(sim_data[Crime == "Assault", data][[1]])
# A tidytable: 6 × 4
  Illiteracy  mean    sd  Rate
  <fct>      <dbl> <dbl> <dbl>
1 high         214    79   178
2 high         214    79   163
3 high         214    79   174
4 high         214    79   234
5 high         214    79   181
6 high         214    79   139
Simulated data for Rape 
head(sim_data[Crime == "Rape", data][[1]])
# A tidytable: 6 × 4
  Illiteracy  mean    sd  Rate
  <fct>      <dbl> <dbl> <dbl>
1 high          23     8    25
2 high          23     8    22
3 high          23     8    16
4 high          23     8    15
5 high          23     8    35
6 high          23     8    23

Using the simulated data above, we now fit an Anova model with Illiteracy as a factor (group) variable that affects the Arrest Rate (response variable) separately for each Crime. I have also made a density plot for the Rate variable for both simulated data and plot it with normal curve with corresponding mean and standard deviation. Following are the codes for fitting the Anova model, and creating density plot and box plot. Also we will perform a Posthoc test using Tukey’s method to make a pairwise comparison of different Illiteracy levels.

mdl_fit <- sim_data %>% 
  mutate(
    Fit = map(data, ~lm(Rate ~ Illiteracy, data = .x)),
    Summary = map(Fit, summary),
    Anova = map(Fit, anova),
    Tukey = map(Fit, aov) %>% map(TukeyHSD)
  )

mdl_est <- mdl_fit %>% 
  summarize(
    across(Summary, map, broom::tidy), 
    .by = c(Crime)
  ) %>% unnest()

mdl_fit_df <- mdl_fit %>% 
  summarize(
    across(Fit, map, broom::augment),
    .by = c(Crime)
  ) %>% unnest()

eff_df <- mdl_fit %>% 
  summarize(
    across(Fit, map, function(.fit) {
      effects::Effect("Illiteracy", .fit) %>%
        as_tidytable()
    }),
    .by = "Crime"
  ) %>% unnest()
Warning in check_dep_version(): ABI version mismatch: 
lme4 was built with Matrix ABI version 1
Current Matrix ABI version is 2
Please re-install lme4 from source or restore original 'Matrix' package
tky_df <- mdl_fit %>% 
  summarize(
    across(Tukey, function(tky) {
      map(tky, purrr::pluck, "Illiteracy") %>%
        map(as_tidytable, .keep_rownames = "terms")
    }),
    .by = "Crime"
  ) %>% unnest()
density_plot <- sim_data %>% 
  unnest(data) %>% 
  ggplot(aes(Rate, color = Illiteracy)) +
    facet_wrap(
      facets = vars(Crime),
      ncol = 3,
      scales = "free",
    ) +
    geom_density(aes(linetype = "Simulated")) +
    geom_density(
      aes(linetype = "Fitted", x = .fitted),
      data = mdl_fit_df
    ) +
    geom_rug(
      data = eff_df,
      aes(x = fit)
    ) +
    scale_linetype_manual(
      breaks = c("Simulated", "Fitted"),
      values = c("solid", "dashed")
    ) +
    scale_color_brewer(palette = "Set1") +
    theme(legend.position = "bottom") +
    labs(
      x = "Arrest Rate",
      y = "Density",
      linetype = NULL
    )
effect_plot <- mdl_fit_df %>% 
  ggplot(aes(Rate, Illiteracy)) +
    facet_grid(
      cols = vars(Crime),
      scales = "free_x"
    ) +
    geom_boxplot(
      notch = TRUE, 
      color = "grey",
      outlier.colour = "grey"
    ) +
    geom_point(
      position = position_jitter(height = 0.25),
      color = "grey",
      size = rel(0.9)
    ) +
    geom_pointrange(
      aes(
        color = "Estimated",
        xmin = lower,
        xmax = upper,
        x = fit
      ),
      data = eff_df
    ) +
    geom_point(
      aes(color = "True Mean", x = mean),
      data = sim_design
    ) +
    scale_color_brewer(
      name = "Mean",
      palette = "Set1"
    ) +
    theme(
      legend.position = "bottom"
    )
tukey_plot <- tky_df %>% 
  ggplot(aes(diff, terms)) +
    facet_grid(
      cols = vars(Crime), 
      scales = "free_x"
    ) +
    geom_pointrange(
      aes(xmin = lwr, xmax = upr, x = diff),
      shape = 21,
      fill = "whitesmoke"
    ) +
    geom_vline(
      xintercept = 0,
      linetype = "dashed",
      color = "royalblue"
    ) +
    scale_color_brewer(
      name = "Mean",
      palette = "Set1"
    ) +
    labs(
      y = "Illiteracy",
      x = "Effect difference",
      title = "Pairwise comparison of levels of illitracy"
    ) +
    expand_limits(x = 0)

Analysis

Density of simulated data 
density_plot

Here, the kernel density plots for arrest rates were shown alongside the normal density curve. This visual assessment checked the goodness of fit between simulated data and the expected normal distribution. The close match between kernel density and normal density validates that the data follows a normal distribution, confirming the simulation’s accuracy.

A one-way ANOVA output below helps to find if there is any difference between arrest rate based on illiteracy level for each crime. Here we see that in all crimes high illiteracy level was considered as reference and compared to this both medium and low illiteracy levels have lower arrest rate. This suggest that the higher illiteracy rate corresponds to higher arrest rate. However, for crimes: assault and rape, the effect of medium illiteracy rate has high p-value and can not be considered to have significant effect on arrest rate.

ANOVA output for crime: Murder 
mdl_fit[Crime == "Murder", Summary][[1]]

Call:
lm(formula = Rate ~ Illiteracy, data = .x)

Residuals:
   Min     1Q Median     3Q    Max 
 -8.44  -2.31   0.08   1.95   7.56 

Coefficients:
                 Estimate Std. Error t value Pr(>|t|)    
(Intercept)       10.9200     0.4247  25.713  < 2e-16 ***
Illiteracymedium  -2.4800     0.6006  -4.129 6.08e-05 ***
Illiteracylow     -6.0000     0.6006  -9.990  < 2e-16 ***
---
Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1

Residual standard error: 3.003 on 147 degrees of freedom
Multiple R-squared:  0.4068,    Adjusted R-squared:  0.3987 
F-statistic:  50.4 on 2 and 147 DF,  p-value: < 2.2e-16
ANOVA output for crime: Assault 
mdl_fit[Crime == "Assault", Summary][[1]]

Call:
lm(formula = Rate ~ Illiteracy, data = .x)

Residuals:
    Min      1Q  Median      3Q     Max 
-158.32  -42.22   -3.11   38.74  221.68 

Coefficients:
                 Estimate Std. Error t value Pr(>|t|)    
(Intercept)        208.32       9.64  21.609  < 2e-16 ***
Illiteracymedium    -5.00      13.63  -0.367    0.714    
Illiteracylow      -95.42      13.63  -6.999 8.51e-11 ***
---
Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1

Residual standard error: 68.17 on 147 degrees of freedom
Multiple R-squared:  0.2969,    Adjusted R-squared:  0.2873 
F-statistic: 31.03 on 2 and 147 DF,  p-value: 5.709e-12
ANOVA output for crime: Rape 
mdl_fit[Crime == "Rape", Summary][[1]]

Call:
lm(formula = Rate ~ Illiteracy, data = .x)

Residuals:
   Min     1Q Median     3Q    Max 
-20.10  -6.10  -0.11   5.56  20.90 

Coefficients:
                 Estimate Std. Error t value Pr(>|t|)    
(Intercept)        22.440      1.219  18.403  < 2e-16 ***
Illiteracymedium   -1.340      1.724  -0.777  0.43837    
Illiteracylow      -5.320      1.724  -3.085  0.00243 ** 
---
Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1

Residual standard error: 8.622 on 147 degrees of freedom
Multiple R-squared:  0.06547,   Adjusted R-squared:  0.05276 
F-statistic:  5.15 on 2 and 147 DF,  p-value: 0.006894
Boxplot with fitted and true mean 
effect_plot

Boxplots displayed arrest rate distributions within each illiteracy group stratified by crime. Points were scattered for detailed visualization, along with fitted means and confidence intervals. Here for all crimes, higher illiteracy corresponds to higher arrest rate and is more visible in murder.

Post-hoc plot comparing pairwise difference 
tukey_plot

The post-hoc plot has highlighted statistically significant differences between different levels of illiteracy. Here, all pairs of illiteracy levels differ significantly at 95% confidence level for Murder however there is not such significant difference between medium and high illiteracy level for assault and rape.

Real Data Example

Data preparation and Dataset

Here, I have used USArrests dataset excluding the crime UrbanPop and merged it with another dataset state.x77 using its Illiteracy variable for 50 states. The Illiteracy was than categorized using its quantiles into three categories low, medium, and high mimiking the simulation example above.

Merging USArrests and state.x77 
arrest <- as_tidytable(USArrests, .keep_rownames = "States") %>% 
  tidytable::left_join(
    as_tidytable(
      state.x77[, "Illiteracy", drop = FALSE],
      .keep_rownames = "States"
    ),
    by = "States"
  ) %>% 
  select(-UrbanPop) %>% 
  mutate(across(Murder:Illiteracy, as.numeric)) %>% 
  mutate(Illiteracy = cut.default(
    Illiteracy,
    breaks = quantile(Illiteracy, c(0, 1/3, 2/3, 1)),
    labels = c("low", "medium", "high"),
    include.lowest = TRUE
  )) %>% 
  mutate(Illiteracy = factor(
    Illiteracy,
    levels = c("high", "medium", "low")
  )) %>% 
  pivot_longer(
    cols = Murder:Rape,
    names_to = "Crime",
    values_to = "Rate"
  ) %>% nest(.by = c(Crime))
Data by group 
arrest
# A tidytable: 3 × 2
  Crime   data                
  <chr>   <list>              
1 Murder  <tidytable [50 × 3]>
2 Assault <tidytable [50 × 3]>
3 Rape    <tidytable [50 × 3]>
Data for crime: Murder 
head(arrest[Crime == "Murder", data][[1]], 3)
# A tidytable: 3 × 3
  States  Illiteracy  Rate
  <chr>   <fct>      <dbl>
1 Alabama high        13.2
2 Alaska  high        10  
3 Arizona high         8.1
Data for crime: Assault 
head(arrest[Crime == "Assault", data][[1]], 3)
# A tidytable: 3 × 3
  States  Illiteracy  Rate
  <chr>   <fct>      <dbl>
1 Alabama high         236
2 Alaska  high         263
3 Arizona high         294
Data for crime: Rape 
head(arrest[Crime == "Rape", data][[1]], 3)
# A tidytable: 3 × 3
  States  Illiteracy  Rate
  <chr>   <fct>      <dbl>
1 Alabama high        21.2
2 Alaska  high        44.5
3 Arizona high        31

Analysis

I am following a similar pattern as in the analysis of simulated data: distribution plot, fitting an ANOVA model, effect plot showing the fitted value with a boxplot, and a Post-hoc showing pairwise comparison of the effect of illiteracy levels on arrest rate.

Code 
ggplot(unnest(arrest), aes(Rate, color = Illiteracy)) +
  geom_density(aes(linetype = "Simulated")) +
  geom_density(
    aes(linetype = "Fitted", x = .fitted),
    data = mdl_fit_df
  ) +
  geom_rug(
    data = eff_df,
    aes(x = fit)
  ) +
  scale_linetype_manual(
    breaks = c("Simulated", "Fitted"),
    values = c("solid", "dashed")
  ) +
  scale_color_brewer(palette = "Set1") +
  theme(legend.position = "bottom") +
  labs(
    x = "Crime",
    y = "Density",
    linetype = NULL
  ) +
  facet_wrap(
    facets = vars(Crime),
    scales = "free"
  )

Kernel density alongside normal density curves for each crime shows and validates the normal distribution of the real data and help confirm the normality assumption for ANOVA, ensuring that the real data analysis aligns with the assumptions necessary for valid inference.

ANOVA output for crime: Murder 
mdl_fit[Crime == "Murder", Summary][[1]]

Call:
lm(formula = Rate ~ Illiteracy, data = .x)

Residuals:
    Min      1Q  Median      3Q     Max 
-6.7067 -2.3000 -0.3059  1.7882  7.8933 

Coefficients:
                 Estimate Std. Error t value Pr(>|t|)    
(Intercept)       11.4118     0.8084  14.116  < 2e-16 ***
Illiteracymedium  -3.9051     1.1808  -3.307  0.00181 ** 
Illiteracylow     -6.8118     1.1273  -6.043 2.32e-07 ***
---
Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1

Residual standard error: 3.333 on 47 degrees of freedom
Multiple R-squared:  0.4382,    Adjusted R-squared:  0.4143 
F-statistic: 18.33 on 2 and 47 DF,  p-value: 1.302e-06
ANOVA output for crime: Assault 
mdl_fit[Crime == "Assault", Summary][[1]]

Call:
lm(formula = Rate ~ Illiteracy, data = .x)

Residuals:
     Min       1Q   Median       3Q      Max 
-168.000  -41.792   -4.083   47.958  145.333 

Coefficients:
                 Estimate Std. Error t value Pr(>|t|)    
(Intercept)        214.00      17.53  12.208 3.51e-16 ***
Illiteracymedium   -24.33      25.60  -0.950 0.346771    
Illiteracylow      -99.83      24.44  -4.084 0.000171 ***
---
Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1

Residual standard error: 72.28 on 47 degrees of freedom
Multiple R-squared:  0.2786,    Adjusted R-squared:  0.2479 
F-statistic: 9.074 on 2 and 47 DF,  p-value: 0.0004653
ANOVA output for crime: Rape 
mdl_fit[Crime == "Rape", Summary][[1]]

Call:
lm(formula = Rate ~ Illiteracy, data = .x)

Residuals:
    Min      1Q  Median      3Q     Max 
-14.133  -6.259  -2.357   3.766  26.939 

Coefficients:
                 Estimate Std. Error t value Pr(>|t|)    
(Intercept)        23.353      2.275  10.263 1.38e-13 ***
Illiteracymedium   -1.920      3.323  -0.578    0.566    
Illiteracylow      -4.292      3.173  -1.353    0.183    
---
Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1

Residual standard error: 9.382 on 47 degrees of freedom
Multiple R-squared:  0.03766,   Adjusted R-squared:  -0.003286 
F-statistic: 0.9198 on 2 and 47 DF,  p-value: 0.4057
Code 
ggplot(unnest(arrest), aes(Rate, Illiteracy)) +
  geom_boxplot(
    notch = FALSE,
    color = "grey",
    outlier.colour = "grey"
  ) +
  geom_point(
    position = position_jitter(height = 0.25),
    color = "grey",
  ) +
  geom_pointrange(
    aes(
      xmin = lower,
      xmax = upper,
      x = fit
    ),
    color = "firebrick",
    data = eff_df
  ) +
  scale_color_brewer(
    name = "Mean",
    palette = "Set1"
  ) +
  theme(
    legend.position = "bottom"
  ) +
  facet_wrap(facets = vars(Crime), scales = "free_x")

Code 
ggplot(tky_df, aes(diff, terms)) +
  geom_pointrange(
    aes(xmin = lwr, xmax = upr, x = diff),
    shape = 21,
    fill = "whitesmoke"
  ) +
  geom_vline(
    xintercept = 0,
    linetype = "dashed",
    color = "royalblue"
  ) +
  scale_color_brewer(
    name = "Mean",
    palette = "Set1"
  ) +
  labs(
    y = "Illiteracy",
    x = "Effect difference",
    title = "Pairwise comparison of levels of illiteracy"
  ) +
  expand_limits(x = 0) +
  facet_wrap(facets = vars(Crime), scales = "free_x")

The analysis using both simulated and real datasets demonstrates the effectiveness of ANOVA in uncovering patterns. Simulating data that closely mirrors the USArrests dataset provided a controlled environment for testing and understanding variable interactions.

When applied to real data, the analysis confirmed significant differences in arrest rates across illiteracy groups, validating the method. By comparing these results, I highlighted how well-designed simulations can replicate real-world scenarios, offering valuable insights and preparing for real-world analyses.

This approach underscores the utility of combining simulated and real data, showcasing the robustness and reliability of the analytical methods used.

]]> Simulation Statistics https://mathatistics.com/blog/posts/2023-02-04-simulation-anova-and-analysis/index.html Fri, 03 Feb 2023 23:00:00 GMT How ANOVA analyze the variance TheRimalaya https://mathatistics.com/blog/posts/2021-03-29-how-anova-analyze-variance/index.html Analysis of Variance (ANOVA) is a powerful statistical tool used to analyze the variance among group means and determine whether these differences are statistically significant. It’s commonly used in various fields such as agriculture, biology, psychology, and more to test hypotheses about different groups. Below are some practical examples:

  • The effect of different diets on the growth of fishes
  • Comparing the height of three different species of a plant
  • The type of flour used for baking bread

Data for ANOVA could be collected through designed experiments or by sampling from populations. This article helps explain how ANOVA analyzes variance and identifies situations when these differences are significant, using both simulated and real data.

Often we Analysis of Variance (ANOVA) to analyze the variances to find if different cases results in similar outcome and if the difference is significant. Following are some simple examples,

Consider the following model with groups and observations,

where, represetns the effect corresponding to group and , the usual assumption of linear model. In order to better understand how ANOVA finds the differences between groups and how the group mean and their standard deviation influence the results from ANOVA, we will explore the following four cases:

Simultion design 
Design <- tidytable::bind_rows(
    Case1 = data.table(
        Group = paste("Group", 1:3, sep = ""),
        Mean = c(10, 10, 10),
        SD = c(5, 5, 5)
    ),
    Case2 = data.table(
        Group = paste("Group", 1:3, sep = ""),
        Mean = c(10, 10, 10),
        SD = c(1, 1, 1)
    ),
    Case3 = data.table(
        Group = paste("Group", 1:3, sep = ""),
        Mean = c(5, 10, 15),
        SD = c(5, 5, 5)
    ),
    Case4 = data.table(
        Group = paste("Group", 1:3, sep = ""),
        Mean = c(5, 10, 15),
        SD = c(1, 1, 1)
    ), .id = "Cases")
  • Case 1: Similar group means with high variation within the groups
  • Case 2: Similar group means with low variation within the groups
  • Case 3: Distant group means with high variation within the groups
  • Case 4: Distant group means with low variation within the groups
Cases
Group1
Group2
Group3
Mean SD Mean SD Mean SD
Case1 10 5 10 5 10 5
Case2 10 1 10 1 10 1
Case3 5 5 10 5 15 5
Case4 5 1 10 1 15 1

Fitting ANOVA model for each cases

Simulate and fit ANOVA 
generate_data <- function(mean, sd, nobs = 50) {
    Response <- rnorm(nobs, mean = mean, sd)
    tidytable(ID = 1:nobs, Response = Response)
}

Model <- Design %>% 
    mutate(Data = map2(Mean, SD, generate_data)) %>% 
    unnest() %>%
    nest(.by = "Cases") %>% 
    mutate(fit = map(data, function(dta) {
        lm(Response ~ Group, data = dta)
    }))

Model
# A tidytable: 4 × 3
  Cases data                  fit   
  <chr> <list>                <list>
1 Case1 <tidytable [150 × 5]> <lm>  
2 Case2 <tidytable [150 × 5]> <lm>  
3 Case3 <tidytable [150 × 5]> <lm>  
4 Case4 <tidytable [150 × 5]> <lm>

Distribution of data

Data distribution 
Model[, map_df(fit, broom::augment), by = Cases] %>%
  ggplot(aes(Response, Group)) +
  geom_boxplot(
    aes(fill = Group, color = Group), 
    alpha = 0.25, width = 0.25
  ) +
  geom_point(aes(fill = Group),
    position = position_jitter(height = 0.1),
    shape = 21, size = 2, stroke = 0.25, alpha = 0.25
  ) +
  stat_summary(
    fun = mean, geom = "point", aes(color = Group),
    size = 2, shape = 21, fill = "whitesmoke", stroke = 0.75
  ) +
  facet_wrap(facets = vars(Cases), scales = "free_x") +
  ggridges::geom_density_ridges(
    aes(color = Group),
    fill = NA,
    panel_scaling = FALSE
  ) +
  scale_color_brewer(palette = "Set1") +
  scale_fill_brewer(palette = "Set1") +
  theme(
    legend.position = "none"
  )

Model comparison

ANOVA for the four cases 
anova_result <- Model[, map_df(
  .x = fit,
  .f = ~ broom::tidy(anova(.x))
), by = Cases] %>% rename(
  DF = df,
  SSE = sumsq,
  MSE = meansq,
  Statistic = statistic,
  `p value` = p.value
)

anova_result %>% 
  mutate(
    Cases = case_when(
        Cases == "Case1" ~ "Case 1: Similar group means with high variation within the groups",
        Cases == "Case2" ~ "Case 2: Similar group means with low variation within the groups",
        Cases == "Case3" ~ "Case 3: Distant group means with high variation within the groups",
        TRUE ~ "Case 4: Distant group means with low variation within the groups"
    )
  ) %>% 
  gt::gt(groupname_col = "Cases", rowname_col = "term") %>%
  gt::fmt_number(columns = 4:6) %>%
  gt::fmt_number(columns = 7, decimals = 4) %>% 
  gt::sub_missing(missing_text = "") %>% 
  gt::tab_options(
    table.width = "100%",
    row_group.font.weight = "600"
  )
DF SSE MSE Statistic p value
Case 1: Similar group means with high variation within the groups
Group 2 32.09 16.05 0.64 0.5304
Residuals 147 3,704.26 25.20

Case 2: Similar group means with low variation within the groups
Group 2 1.98 0.99 1.00 0.3714
Residuals 147 146.03 0.99

Case 3: Distant group means with high variation within the groups
Group 2 1,951.86 975.93 50.15 0.0000
Residuals 147 2,860.66 19.46

Case 4: Distant group means with low variation within the groups
Group 2 2,516.51 1,258.26 1,263.82 0.0000
Residuals 147 146.35 1.00

Interpretetion

The results show a high p-value, indicating no significant difference between the groups due to high within-group variability.

Here, the p-value is still high, suggesting no significant difference, but the small variance within groups provides clearer insights compared to Case 1.

Despite the high variation within groups, the distant group means lead to a low p-value, indicating statistically significant differences among the groups.

With low within-group variation and distant means, the p-value remains extremely low, strongly indicating significant group differences.

In conclusion, ANOVA helps determine if there are significant differences between multiple group means by comparing variances within groups to variances between groups. The power of ANOVA lies in its ability to detect even subtle differences when variations are minimal within groups.

]]> Statistics ANOVA https://mathatistics.com/blog/posts/2021-03-29-how-anova-analyze-variance/index.html Sun, 28 Mar 2021 22:00:00 GMT Interpretating Biplot TheRimalaya https://mathatistics.com/blog/posts/2017-03-18-interpreting-biplot/index.html A biplot is a powerful graphical tool that represents data in two dimensions, where both the observations and variables are represented. Biplots are particularly useful for multivariate data, allowing users to examine relationships between variables and identify patterns.

Consider a data matrix with variables and observations. To explore the data further with biplot, principal component analysis (PCA) is used here.

where is the ith variable.

Principal component analysis (PCA) compresses the variance of the data matrix to create a new set of orthogonal (linearly independent) variables , where , often termed as principal components (PC) or scores. In PCA, the most variation is captured by the first component and rest in the subsequent components in decreasing order. In other words, the first principal component () captures the highest variation and second principal component () captures the maximum of remaing variation and so on.

We can use eigenvalue decomposition or singular value decompostion for this purpose.

These principle components are created using linear combination of the original variables. For example, and similarly for . Here we can estimate weights , where and using eigenvalue decomposition or singular value (SVD). These weights are also refered as loading or the matrix of these weights as rotation matrix.

Biplot plots the scores from two principal components together with loadings (weight) for each variables in the same plot. The following example uses USArrests data from datasets package in R. The dataset contains the number of arrests per 100,000 residents for assault, murder, and rape in each of the 50 US states in 1973.

Two functions prcomp and princomp in R performs the principal component analysis. The function prcomp uses SVD on data matrix while princomp uses eigenvalue decomposition on covariance or correlation matrix of the data matrix. We will use prcomp for our example.

Dataset: USArrest

Code 
USArrests <- as_tidytable(USArrests, .keep_rownames = "State")
head(USArrests)
# A tidytable: 6 × 5
  State      Murder Assault UrbanPop  Rape
  <chr>       <dbl>   <int>    <int> <dbl>
1 Alabama      13.2     236       58  21.2
2 Alaska       10       263       48  44.5
3 Arizona       8.1     294       80  31  
4 Arkansas      8.8     190       50  19.5
5 California    9       276       91  40.6
6 Colorado      7.9     204       78  38.7

Principal component analysis

Code 
pca <- prcomp(USArrests[, -1], scale. = TRUE)
str(pca)
List of 5
 $ sdev    : num [1:4] 1.575 0.995 0.597 0.416
 $ rotation: num [1:4, 1:4] -0.536 -0.583 -0.278 -0.543 -0.418 ...
  ..- attr(*, "dimnames")=List of 2
  .. ..$ : chr [1:4] "Murder" "Assault" "UrbanPop" "Rape"
  .. ..$ : chr [1:4] "PC1" "PC2" "PC3" "PC4"
 $ center  : Named num [1:4] 7.79 170.76 65.54 21.23
  ..- attr(*, "names")= chr [1:4] "Murder" "Assault" "UrbanPop" "Rape"
 $ scale   : Named num [1:4] 4.36 83.34 14.47 9.37
  ..- attr(*, "names")= chr [1:4] "Murder" "Assault" "UrbanPop" "Rape"
 $ x       : num [1:50, 1:4] -0.976 -1.931 -1.745 0.14 -2.499 ...
  ..- attr(*, "dimnames")=List of 2
  .. ..$ : NULL
  .. ..$ : chr [1:4] "PC1" "PC2" "PC3" "PC4"
 - attr(*, "class")= chr "prcomp"
Code 
score_df <- as_tidytable(pca$x) %>% 
  mutate(State = USArrests[, State])

loading_df <- as_tidytable(
  pca$rotation, 
  .keep_rownames = "Variable"
)

ggplot(score_df, aes(PC1, PC2)) +
  geom_hline(
    yintercept = 0, 
    color = "royalblue", 
    linetype = "dashed"
  ) +
  geom_vline(
    xintercept = 0, 
    color = "royalblue", 
    linetype = "dashed"
  ) +
  geom_segment(
    data = loading_df,
    aes(
      x = 0, xend = PC1 * 2,
      y = 0, yend = PC2 * 2
    ),
    color = "firebrick",
    arrow = arrow(length = unit(2, "mm"))
  ) +
  geom_text(
    data = loading_df,
    aes(
      x = PC1 * 2.6, 
      y = PC2 * 2.6, 
      label = Variable
    ),
    color = "firebrick",
    size = rel(5)
  ) +
  geom_text(
    aes(label = State), 
    check_overlap = TRUE,
    color = "gray50"
  ) +
  theme_minimal(base_size = 18) +
  theme(
    panel.background = element_rect(color = "gray50")
  )

Code 
summary(pca)
Importance of components:
                          PC1    PC2     PC3     PC4
Standard deviation     1.5749 0.9949 0.59713 0.41645
Proportion of Variance 0.6201 0.2474 0.08914 0.04336
Cumulative Proportion  0.6201 0.8675 0.95664 1.00000
Code 
var_df <- tidytable(
  PC = paste0("PC", 1:length(pca$sdev)),
  Variance = pca$sdev^2
)
ggplot(var_df, aes(PC, Variance)) +
  geom_line(group = 1) +
  geom_point(
    stroke = 1, size = 3, 
    shape = 21, fill = "whitesmoke"
  ) +
  theme_minimal(base_size = 18) +
  theme(
    panel.background = element_rect(color = "gray20")
  )

Here we see that more than 87% of variation in was captured by first two principal components (65% by the first and 25% by the second component).

Explore data using biplot

Now lets compare the scores from the first two components, observations and variables in the data matrix. From the USArrests data, lets look at the top five states with highest and lowest arrest for each of these crimes.

Code 
USArrests %>% arrange(-Murder) %>% top_n()
# A tidytable: 5 × 5
  State          Murder Assault UrbanPop  Rape
  <chr>           <dbl>   <int>    <int> <dbl>
1 Georgia          17.4     211       60  25.8
2 Mississippi      16.1     259       44  17.1
3 Florida          15.4     335       80  31.9
4 Louisiana        15.4     249       66  22.2
5 South Carolina   14.4     279       48  22.5
Code 
USArrests %>% arrange(-Assault) %>% top_n()
# A tidytable: 5 × 5
  State          Murder Assault UrbanPop  Rape
  <chr>           <dbl>   <int>    <int> <dbl>
1 North Carolina   13       337       45  16.1
2 Florida          15.4     335       80  31.9
3 Maryland         11.3     300       67  27.8
4 Arizona           8.1     294       80  31  
5 New Mexico       11.4     285       70  32.1
Code 
USArrests %>% arrange(-UrbanPop) %>% top_n()
# A tidytable: 5 × 5
  State         Murder Assault UrbanPop  Rape
  <chr>          <dbl>   <int>    <int> <dbl>
1 California       9       276       91  40.6
2 New Jersey       7.4     159       89  18.8
3 Rhode Island     3.4     174       87   8.3
4 New York        11.1     254       86  26.1
5 Massachusetts    4.4     149       85  16.3
Code 
USArrests %>% arrange(-Rape) %>% top_n()
# A tidytable: 5 × 5
  State      Murder Assault UrbanPop  Rape
  <chr>       <dbl>   <int>    <int> <dbl>
1 Nevada       12.2     252       81  46  
2 Alaska       10       263       48  44.5
3 California    9       276       91  40.6
4 Colorado      7.9     204       78  38.7
5 Michigan     12.1     255       74  35.1
Code 
USArrests %>% arrange(Murder) %>% top_n()
# A tidytable: 5 × 5
  State         Murder Assault UrbanPop  Rape
  <chr>          <dbl>   <int>    <int> <dbl>
1 North Dakota     0.8      45       44   7.3
2 Maine            2.1      83       51   7.8
3 New Hampshire    2.1      57       56   9.5
4 Iowa             2.2      56       57  11.3
5 Vermont          2.2      48       32  11.2
Code 
USArrests %>% arrange(Assault) %>% top_n()
# A tidytable: 5 × 5
  State        Murder Assault UrbanPop  Rape
  <chr>         <dbl>   <int>    <int> <dbl>
1 North Dakota    0.8      45       44   7.3
2 Hawaii          5.3      46       83  20.2
3 Vermont         2.2      48       32  11.2
4 Wisconsin       2.6      53       66  10.8
5 Iowa            2.2      56       57  11.3
Code 
USArrests %>% arrange(UrbanPop) %>% top_n()
# A tidytable: 5 × 5
  State          Murder Assault UrbanPop  Rape
  <chr>           <dbl>   <int>    <int> <dbl>
1 Vermont           2.2      48       32  11.2
2 West Virginia     5.7      81       39   9.3
3 Mississippi      16.1     259       44  17.1
4 North Dakota      0.8      45       44   7.3
5 North Carolina   13       337       45  16.1
Code 
USArrests %>% arrange(Rape) %>% top_n()
# A tidytable: 5 × 5
  State         Murder Assault UrbanPop  Rape
  <chr>          <dbl>   <int>    <int> <dbl>
1 North Dakota     0.8      45       44   7.3
2 Maine            2.1      83       51   7.8
3 Rhode Island     3.4     174       87   8.3
4 West Virginia    5.7      81       39   9.3
5 New Hampshire    2.1      57       56   9.5

Comparing these highest and lowest arrests with the biplot, we can see a pattern. The weights corresponding to PC1 for all the variables are negative and are directed towards states like Florida, Nevada, and California. These states have the highest number of arrests for all of these crimes where as states that are in the oppositve direction like Iowa, North Dakota, and Vermont have the lowest arrest.

Similarly, UrbanPop have the highest weights corresponding to PC2 so the states in that direction such as California, Hawaii, and New Jersey have highest arrest related to UrbanPop. The states in the opposite direction, i.e. with negative PC2 scores such as Mississippi, North Carolina, Vermont, and South Carolina have the lowest arrest related to UrbanPop.

The weights for all variables are negative and towards states like . So in our data these states must have the highest arrests in all these crimes where as states like New Dakota, Vermont, and Iowa have the lowest arrests.

]]> statistics machine learning data science https://mathatistics.com/blog/posts/2017-03-18-interpreting-biplot/index.html Fri, 17 Mar 2017 23:00:00 GMT Model assessment and variable selection TheRimalaya https://mathatistics.com/blog/posts/2017-03-05-model-assessment-and-variable-selection-prodecure/index.html Adding new variables to a model can introduce noise, complicating analysis. Simpler models tend to be better because they’re easier to understand and contain less noise. Statistical methods can help us choose the best variables and improve our models.

This tutorial will show you how to compare models to find the best one. Using the mtcars dataset available in R, it will explore methods for variable selection that help build efficient models with fewer variables. Here are two popular techniques for selecting the best subset of variables:

Best subset method

The best subset selection procedure identifies the optimal regression model by evaluating all possible subsets of variables. As the number of variables increases, the number of potential combinations grows exponentially. For instance, with 2 variables, there are 4 possible subsets: one with no predictors, two with single predictors, and one with both predictors. With 4 variables, the number of possible subsets jumps to 16. Consequently, fitting all possible subsets of a large number of predictors can become computationally intensive.

After fitting all possible models, they are compared based on various criteria. These criteria may include the coefficient of determination (), adjusted , Mallow’s CP, AIC, and BIC. In R, we can use the leaps package for this task. Let’s look at the mtcars example to see this in action.

Complete/full model

Fitting a complete model 
full.model <- lm(mpg ~ ., data = mtcars)
smry <- summary(full.model)
smry

Call:
lm(formula = mpg ~ ., data = mtcars)

Residuals:
    Min      1Q  Median      3Q     Max 
-3.4506 -1.6044 -0.1196  1.2193  4.6271 

Coefficients:
            Estimate Std. Error t value Pr(>|t|)  
(Intercept) 12.30337   18.71788   0.657   0.5181  
cyl         -0.11144    1.04502  -0.107   0.9161  
disp         0.01334    0.01786   0.747   0.4635  
hp          -0.02148    0.02177  -0.987   0.3350  
drat         0.78711    1.63537   0.481   0.6353  
wt          -3.71530    1.89441  -1.961   0.0633 .
qsec         0.82104    0.73084   1.123   0.2739  
vs           0.31776    2.10451   0.151   0.8814  
am           2.52023    2.05665   1.225   0.2340  
gear         0.65541    1.49326   0.439   0.6652  
carb        -0.19942    0.82875  -0.241   0.8122  
---
Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1

Residual standard error: 2.65 on 21 degrees of freedom
Multiple R-squared:  0.869, Adjusted R-squared:  0.8066 
F-statistic: 13.93 on 10 and 21 DF,  p-value: 3.793e-07

Here, we can see that the model has explained almost 86.9 percent of variation present in mpg, but non of the predictors are significant. This is a hint of having unnecessary variables that has increased model error. Using regsubsets function from leaps package, we can select a subset of predictors based on some criteria.

Selecting best subset

Selecting best subset model 
library(leaps)
best.subset <- regsubsets(
  x      = mtcars[, -1], # predictor variables
  y      = mtcars[, 1], # response variable (mpg)
  nbest  = 1, # top 1 best model
  nvmax  = ncol(mtcars) - 1, # max. number of variable (all)
  method = "exhaustive" # search all possible subset
)
bs.smry <- summary(best.subset)

We can combine following summary output with a plot created from additional estimates to get some insight. These estimates are also found in the summary object. The output show which variables are included with a star(*).

Summary of best subset 
bs.smry$outmat %>% 
  as_tidytable(.keep_rownames = "model") %>% 
  gt::gt(rowname_col = "model") %>% 
  gt::opt_vertical_padding(0.5) %>% 
  gt::opt_row_striping() %>% 
  gt::tab_options(
    column_labels.font.weight = "bold",
    stub.font.weight = "bold"
  )

bs.est <- tidytable(
  nvar   = 1:(best.subset$nvmax - 1),
  adj.r2 = round(bs.smry$adjr2, 3),
  cp     = round(bs.smry$cp, 3),
  bic    = round(bs.smry$bic, 3)
) %>% pivot_longer(
  cols = c(adj.r2:bic),
  names_to = "estimates",
  values_to = "value"
)
cyl disp hp drat wt qsec vs am gear carb
1 ( 1 ) *
2 ( 1 ) * *
3 ( 1 ) * * *
4 ( 1 ) * * * *
5 ( 1 ) * * * * *
6 ( 1 ) * * * * * *
7 ( 1 ) * * * * * * *
8 ( 1 ) * * * * * * * *
9 ( 1 ) * * * * * * * * *
10 ( 1 ) * * * * * * * * * *

We can make a plot to visualise the properties of these individual models and select a model with specific number of predictor that can give minimum BIC, or minimum CP or maximum adjusted rsquared.

Plotting Adj-Rsq, BIC, and CP 
bs.est.select <- bs.est %>%
  group_by(estimates) %>%
  filter(
    (value == max(value) & estimates == "adj.r2") |
      (value == min(value) & estimates != "adj.r2")
  )
ggplot(bs.est, aes(nvar, value, color = estimates)) +
  geom_point(shape = 21, fill = "lightgray") +
  geom_line() +
  facet_wrap(~estimates, scale = "free_y") +
  theme(legend.position = "top") +
  labs(
    x = "Number of variables in the model",
    y = "Value of Estimate"
  ) +
  scale_x_continuous(breaks = seq(0, 10, 2)) +
  geom_point(
    data = bs.est.select, fill = "red",
    shape = 21
  ) +
  geom_text(
    aes(label = paste0("nvar:", nvar, "\n", "value:", value)),
    data = bs.est.select,
    size = 3, hjust = 0, vjust = c(1, -1, -1),
    color = "black", family = "monospace"
  )

Adj-Rsq, BIC, and Mallows’ CP for models with increasing number of predictors

From these plots, we see that with 5 variables we will obtain maximum adjusted coefficient of determination (). Similarly, both BIC and Mallow CP will be minimum for models with only 3 predictor variables. With the help of table above, we can identify these variables. From the table, row corresponding to 3 variables, we see that the three predictors are wt, qsec and am. To obtain maximum adjusted , disp and hp should be added to the previous 3 predictors.

This way, we can reduce a model to few variables optimising different assessment criteria. Let look at the fit of these reduced models:

Reduced Model 
model.3 <- lm(mpg ~ wt + qsec + am, data = mtcars)
model.5 <- update(model.3, . ~ . + disp + hp)

Model summaries

Model summary of model with 3 variables 
summary(model.3)

Call:
lm(formula = mpg ~ wt + qsec + am, data = mtcars)

Residuals:
    Min      1Q  Median      3Q     Max 
-3.4811 -1.5555 -0.7257  1.4110  4.6610 

Coefficients:
            Estimate Std. Error t value Pr(>|t|)    
(Intercept)   9.6178     6.9596   1.382 0.177915    
wt           -3.9165     0.7112  -5.507 6.95e-06 ***
qsec          1.2259     0.2887   4.247 0.000216 ***
am            2.9358     1.4109   2.081 0.046716 *  
---
Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1

Residual standard error: 2.459 on 28 degrees of freedom
Multiple R-squared:  0.8497,    Adjusted R-squared:  0.8336 
F-statistic: 52.75 on 3 and 28 DF,  p-value: 1.21e-11
Model summary of model with 5 variables 
summary(model.5)

Call:
lm(formula = mpg ~ wt + qsec + am + disp + hp, data = mtcars)

Residuals:
    Min      1Q  Median      3Q     Max 
-3.5399 -1.7398 -0.3196  1.1676  4.5534 

Coefficients:
            Estimate Std. Error t value Pr(>|t|)   
(Intercept) 14.36190    9.74079   1.474  0.15238   
wt          -4.08433    1.19410  -3.420  0.00208 **
qsec         1.00690    0.47543   2.118  0.04391 * 
am           3.47045    1.48578   2.336  0.02749 * 
disp         0.01124    0.01060   1.060  0.29897   
hp          -0.02117    0.01450  -1.460  0.15639   
---
Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1

Residual standard error: 2.429 on 26 degrees of freedom
Multiple R-squared:  0.8637,    Adjusted R-squared:  0.8375 
F-statistic: 32.96 on 5 and 26 DF,  p-value: 1.844e-10

From these output, it seems that although adjusted has increased in later model, the additional variables are not significant. we can compare these two model with an ANOVA test which compares the residual variance between these two models. We can write the hypothesis as,

Model 1 and Model 2 are same vs Model 1 and Model 2 are different

where, Model 1 and Model 2 represents 3 variable and 5 variable model

Anova comparing Model with 3 and 5 variables 
anova(model.3, model.5)
Analysis of Variance Table

Model 1: mpg ~ wt + qsec + am
Model 2: mpg ~ wt + qsec + am + disp + hp
  Res.Df    RSS Df Sum of Sq      F Pr(>F)
1     28 169.29                           
2     26 153.44  2    15.848 1.3427 0.2786

The ANOVA result can not reject the hypothesis so claim that Model 1 and Model 2 are same. So, it is better to select the simpler model with 3 predictor variables.

Step-wise selection

In this section, we’ll explore another type of variable selection method, similar yet distinct from best subset selection method. We will explore forward and backward stepwise selection methods using the mtcars dataset in R. We’ll briefly compare these methods and provide insights into their application.

Forward selection starts with an empty model, and predictors are added one by one based on a selection criterion, typically the Akaike Information Criterion (AIC).

Forward selection 
# Initial empty model
initial_model <- lm(mpg ~ 1, data = mtcars)

# Full model with all predictors
full_model <- lm(mpg ~ ., data = mtcars)

# Stepwise forward selection
forward_model <- MASS::stepAIC(
  initial_model, 
  direction = "forward", 
  scope = list(lower = initial_model, upper = full_model)
)

# Summary of the forward selection model
summary(forward_model)
Start:  AIC=115.94
mpg ~ 1

       Df Sum of Sq     RSS     AIC
+ wt    1    847.73  278.32  73.217
+ cyl   1    817.71  308.33  76.494
+ disp  1    808.89  317.16  77.397
+ hp    1    678.37  447.67  88.427
+ drat  1    522.48  603.57  97.988
+ vs    1    496.53  629.52  99.335
+ am    1    405.15  720.90 103.672
+ carb  1    341.78  784.27 106.369
+ gear  1    259.75  866.30 109.552
+ qsec  1    197.39  928.66 111.776
<none>              1126.05 115.943

Step:  AIC=73.22
mpg ~ wt

       Df Sum of Sq    RSS    AIC
+ cyl   1    87.150 191.17 63.198
+ hp    1    83.274 195.05 63.840
+ qsec  1    82.858 195.46 63.908
+ vs    1    54.228 224.09 68.283
+ carb  1    44.602 233.72 69.628
+ disp  1    31.639 246.68 71.356
<none>              278.32 73.217
+ drat  1     9.081 269.24 74.156
+ gear  1     1.137 277.19 75.086
+ am    1     0.002 278.32 75.217

Step:  AIC=63.2
mpg ~ wt + cyl

       Df Sum of Sq    RSS    AIC
+ hp    1   14.5514 176.62 62.665
+ carb  1   13.7724 177.40 62.805
<none>              191.17 63.198
+ qsec  1   10.5674 180.60 63.378
+ gear  1    3.0281 188.14 64.687
+ disp  1    2.6796 188.49 64.746
+ vs    1    0.7059 190.47 65.080
+ am    1    0.1249 191.05 65.177
+ drat  1    0.0010 191.17 65.198

Step:  AIC=62.66
mpg ~ wt + cyl + hp

       Df Sum of Sq    RSS    AIC
<none>              176.62 62.665
+ am    1    6.6228 170.00 63.442
+ disp  1    6.1762 170.44 63.526
+ carb  1    2.5187 174.10 64.205
+ drat  1    2.2453 174.38 64.255
+ qsec  1    1.4010 175.22 64.410
+ gear  1    0.8558 175.76 64.509
+ vs    1    0.0599 176.56 64.654

Call:
lm(formula = mpg ~ wt + cyl + hp, data = mtcars)

Residuals:
    Min      1Q  Median      3Q     Max 
-3.9290 -1.5598 -0.5311  1.1850  5.8986 

Coefficients:
            Estimate Std. Error t value Pr(>|t|)    
(Intercept) 38.75179    1.78686  21.687  < 2e-16 ***
wt          -3.16697    0.74058  -4.276 0.000199 ***
cyl         -0.94162    0.55092  -1.709 0.098480 .  
hp          -0.01804    0.01188  -1.519 0.140015    
---
Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1

Residual standard error: 2.512 on 28 degrees of freedom
Multiple R-squared:  0.8431,    Adjusted R-squared:  0.8263 
F-statistic: 50.17 on 3 and 28 DF,  p-value: 2.184e-11

Backward selection begins with the full model, removing one predictor at a time to improve the model according to the chosen criterion, typically AIC.

Backward selection 
# Full model with all predictors
full_model <- lm(mpg ~ ., data = mtcars)

# Stepwise backward selection
backward_model <- MASS::stepAIC(
  full_model, 
  direction = "backward"
)

# Summary of the backward selection model
summary(backward_model)
Start:  AIC=70.9
mpg ~ cyl + disp + hp + drat + wt + qsec + vs + am + gear + carb

       Df Sum of Sq    RSS    AIC
- cyl   1    0.0799 147.57 68.915
- vs    1    0.1601 147.66 68.932
- carb  1    0.4067 147.90 68.986
- gear  1    1.3531 148.85 69.190
- drat  1    1.6270 149.12 69.249
- disp  1    3.9167 151.41 69.736
- hp    1    6.8399 154.33 70.348
- qsec  1    8.8641 156.36 70.765
<none>              147.49 70.898
- am    1   10.5467 158.04 71.108
- wt    1   27.0144 174.51 74.280

Step:  AIC=68.92
mpg ~ disp + hp + drat + wt + qsec + vs + am + gear + carb

       Df Sum of Sq    RSS    AIC
- vs    1    0.2685 147.84 66.973
- carb  1    0.5201 148.09 67.028
- gear  1    1.8211 149.40 67.308
- drat  1    1.9826 149.56 67.342
- disp  1    3.9009 151.47 67.750
- hp    1    7.3632 154.94 68.473
<none>              147.57 68.915
- qsec  1   10.0933 157.67 69.032
- am    1   11.8359 159.41 69.384
- wt    1   27.0280 174.60 72.297

Step:  AIC=66.97
mpg ~ disp + hp + drat + wt + qsec + am + gear + carb

       Df Sum of Sq    RSS    AIC
- carb  1    0.6855 148.53 65.121
- gear  1    2.1437 149.99 65.434
- drat  1    2.2139 150.06 65.449
- disp  1    3.6467 151.49 65.753
- hp    1    7.1060 154.95 66.475
<none>              147.84 66.973
- am    1   11.5694 159.41 67.384
- qsec  1   15.6830 163.53 68.200
- wt    1   27.3799 175.22 70.410

Step:  AIC=65.12
mpg ~ disp + hp + drat + wt + qsec + am + gear

       Df Sum of Sq    RSS    AIC
- gear  1     1.565 150.09 63.457
- drat  1     1.932 150.46 63.535
<none>              148.53 65.121
- disp  1    10.110 158.64 65.229
- am    1    12.323 160.85 65.672
- hp    1    14.826 163.35 66.166
- qsec  1    26.408 174.94 68.358
- wt    1    69.127 217.66 75.350

Step:  AIC=63.46
mpg ~ disp + hp + drat + wt + qsec + am

       Df Sum of Sq    RSS    AIC
- drat  1     3.345 153.44 62.162
- disp  1     8.545 158.64 63.229
<none>              150.09 63.457
- hp    1    13.285 163.38 64.171
- am    1    20.036 170.13 65.466
- qsec  1    25.574 175.67 66.491
- wt    1    67.572 217.66 73.351

Step:  AIC=62.16
mpg ~ disp + hp + wt + qsec + am

       Df Sum of Sq    RSS    AIC
- disp  1     6.629 160.07 61.515
<none>              153.44 62.162
- hp    1    12.572 166.01 62.682
- qsec  1    26.470 179.91 65.255
- am    1    32.198 185.63 66.258
- wt    1    69.043 222.48 72.051

Step:  AIC=61.52
mpg ~ hp + wt + qsec + am

       Df Sum of Sq    RSS    AIC
- hp    1     9.219 169.29 61.307
<none>              160.07 61.515
- qsec  1    20.225 180.29 63.323
- am    1    25.993 186.06 64.331
- wt    1    78.494 238.56 72.284

Step:  AIC=61.31
mpg ~ wt + qsec + am

       Df Sum of Sq    RSS    AIC
<none>              169.29 61.307
- am    1    26.178 195.46 63.908
- qsec  1   109.034 278.32 75.217
- wt    1   183.347 352.63 82.790

Call:
lm(formula = mpg ~ wt + qsec + am, data = mtcars)

Residuals:
    Min      1Q  Median      3Q     Max 
-3.4811 -1.5555 -0.7257  1.4110  4.6610 

Coefficients:
            Estimate Std. Error t value Pr(>|t|)    
(Intercept)   9.6178     6.9596   1.382 0.177915    
wt           -3.9165     0.7112  -5.507 6.95e-06 ***
qsec          1.2259     0.2887   4.247 0.000216 ***
am            2.9358     1.4109   2.081 0.046716 *  
---
Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1

Residual standard error: 2.459 on 28 degrees of freedom
Multiple R-squared:  0.8497,    Adjusted R-squared:  0.8336 
F-statistic: 52.75 on 3 and 28 DF,  p-value: 1.21e-11

Comparing best subset and stepwise selection method

Best subset selection considers all possible combinations of predictors and selects the model with the best performance based on a specified criterion (e.g., AIC, BIC, adjusted R²). While comprehensive, this method can be computationally expensive for datasets with a large number of predictors.

  • Best Subset Selection: Evaluates every possible model, providing the optimal model based on the criterion. It ensures the best fit but at a high computational cost.
  • Stepwise Selection (Forward and Backward): Evaluates models sequentially. It’s more computationally efficient but may not guarantee the globally optimal model.

Stepwise selection methods, whether forward or backward, provide a practical approach to model selection by adding or removing predictors based on defined criteria. While not as exhaustive as best subset selection, they offer a balance between computational efficiency and model performance. By understanding and applying these methods within the mtcars dataset, we can navigate model selection systematically and efficiently.

Glossary

  1. R-squared (R²): A statistical measure representing the proportion of the variance for the dependent variable that’s explained by the independent variables in the model. R² values range from 0 to 1, with higher values indicating better model performance.

  2. Adjusted R-squared (R² adjusted): Adjusted R² modifies R² to account for the number of predictors in the model. It provides a more accurate measure when comparing models with a different number of predictors, as it penalizes the addition of non-informative predictors.

  3. Akaike Information Criterion (AIC): AIC is an estimator of the relative quality of statistical models for a given set of data. It balances the goodness of fit of the model with the number of predictors, penalizing more complex models to avoid overfitting. Lower AIC values indicate better models.

  4. Bayesian Information Criterion (BIC): Similar to AIC, BIC also evaluates model quality but imposes a more substantial penalty for the number of predictors. BIC is used to discourage overfitting, and lower BIC values indicate a better model.

  5. Mallow’s CP: Mallow’s CP criterion assesses the trade-off between model complexity and goodness of fit. Lower values of CP are desired, with CP values close to the number of predictors plus one indicating well-fitted models.

]]> https://mathatistics.com/blog/posts/2017-03-05-model-assessment-and-variable-selection-prodecure/index.html Sat, 04 Mar 2017 23:00:00 GMT Importing and Exporting data in R TheRimalaya https://mathatistics.com/blog/posts/2017-03-01-importing-and-exporting-data-in-R/index.html Importing and loading data is a crucial skill in data analysis. R offers various methods to handle different data formats efficiently. This article covers the essential techniques for importing data into R, using datasets from different packages, and explores open data sources and useful resources.

Different Formats of Data

Data comes in various formats, each suited for different scenarios:

  • CSV (Comma Separated Values): Simple text files where values are separated by commas.
  • Excel: Commonly used .xls and .xlsx files.
  • SQL Databases: Structured data stored in tables within relational databases.
  • JSON (JavaScript Object Notation): Lightweight data interchange format.
  • HTML: Webpage data.
  • SPSS, SAS, Stata: Formats used by specialized statistical software.
  • RData and RDS: Native R formats for storing R objects.

Data Available in Different Packages

R comes with a plethora of packages that include built-in datasets, perfect for learning and practice:

Includes classic datasets like Iris, mtcars, and airquality.

library(datasets)
data(iris)
str(iris)
'data.frame':   150 obs. of  5 variables:
 $ Sepal.Length: num  5.1 4.9 4.7 4.6 5 5.4 4.6 5 4.4 4.9 ...
 $ Sepal.Width : num  3.5 3 3.2 3.1 3.6 3.9 3.4 3.4 2.9 3.1 ...
 $ Petal.Length: num  1.4 1.4 1.3 1.5 1.4 1.7 1.4 1.5 1.4 1.5 ...
 $ Petal.Width : num  0.2 0.2 0.2 0.2 0.2 0.4 0.3 0.2 0.2 0.1 ...
 $ Species     : Factor w/ 3 levels "setosa","versicolor",..: 1 1 1 1 1 1 1 1 1 1 ...

Contains datasets such as mpg for practicing data visualization.

library(ggplot2)
data(mpg)
str(mpg)
tibble [234 × 11] (S3: tbl_df/tbl/data.frame)
 $ manufacturer: chr [1:234] "audi" "audi" "audi" "audi" ...
 $ model       : chr [1:234] "a4" "a4" "a4" "a4" ...
 $ displ       : num [1:234] 1.8 1.8 2 2 2.8 2.8 3.1 1.8 1.8 2 ...
 $ year        : int [1:234] 1999 1999 2008 2008 1999 1999 2008 1999 1999 2008 ...
 $ cyl         : int [1:234] 4 4 4 4 6 6 6 4 4 4 ...
 $ trans       : chr [1:234] "auto(l5)" "manual(m5)" "manual(m6)" "auto(av)" ...
 $ drv         : chr [1:234] "f" "f" "f" "f" ...
 $ cty         : int [1:234] 18 21 20 21 16 18 18 18 16 20 ...
 $ hwy         : int [1:234] 29 29 31 30 26 26 27 26 25 28 ...
 $ fl          : chr [1:234] "p" "p" "p" "p" ...
 $ class       : chr [1:234] "compact" "compact" "compact" "compact" ...

Provides the starwars and storms datasets, useful for demonstrating data manipulation techniques.

library(dplyr)
data(starwars)
str(starwars)
tibble [87 × 14] (S3: tbl_df/tbl/data.frame)
 $ name      : chr [1:87] "Luke Skywalker" "C-3PO" "R2-D2" "Darth Vader" ...
 $ height    : int [1:87] 172 167 96 202 150 178 165 97 183 182 ...
 $ mass      : num [1:87] 77 75 32 136 49 120 75 32 84 77 ...
 $ hair_color: chr [1:87] "blond" NA NA "none" ...
 $ skin_color: chr [1:87] "fair" "gold" "white, blue" "white" ...
 $ eye_color : chr [1:87] "blue" "yellow" "red" "yellow" ...
 $ birth_year: num [1:87] 19 112 33 41.9 19 52 47 NA 24 57 ...
 $ sex       : chr [1:87] "male" "none" "none" "male" ...
 $ gender    : chr [1:87] "masculine" "masculine" "masculine" "masculine" ...
 $ homeworld : chr [1:87] "Tatooine" "Tatooine" "Naboo" "Tatooine" ...
 $ species   : chr [1:87] "Human" "Droid" "Droid" "Human" ...
 $ films     :List of 87
  ..$ : chr [1:5] "A New Hope" "The Empire Strikes Back" "Return of the Jedi" "Revenge of the Sith" ...
  ..$ : chr [1:6] "A New Hope" "The Empire Strikes Back" "Return of the Jedi" "The Phantom Menace" ...
  ..$ : chr [1:7] "A New Hope" "The Empire Strikes Back" "Return of the Jedi" "The Phantom Menace" ...
  ..$ : chr [1:4] "A New Hope" "The Empire Strikes Back" "Return of the Jedi" "Revenge of the Sith"
  ..$ : chr [1:5] "A New Hope" "The Empire Strikes Back" "Return of the Jedi" "Revenge of the Sith" ...
  ..$ : chr [1:3] "A New Hope" "Attack of the Clones" "Revenge of the Sith"
  ..$ : chr [1:3] "A New Hope" "Attack of the Clones" "Revenge of the Sith"
  ..$ : chr "A New Hope"
  ..$ : chr "A New Hope"
  ..$ : chr [1:6] "A New Hope" "The Empire Strikes Back" "Return of the Jedi" "The Phantom Menace" ...
  ..$ : chr [1:3] "The Phantom Menace" "Attack of the Clones" "Revenge of the Sith"
  ..$ : chr [1:2] "A New Hope" "Revenge of the Sith"
  ..$ : chr [1:5] "A New Hope" "The Empire Strikes Back" "Return of the Jedi" "Revenge of the Sith" ...
  ..$ : chr [1:4] "A New Hope" "The Empire Strikes Back" "Return of the Jedi" "The Force Awakens"
  ..$ : chr "A New Hope"
  ..$ : chr [1:3] "A New Hope" "Return of the Jedi" "The Phantom Menace"
  ..$ : chr [1:3] "A New Hope" "The Empire Strikes Back" "Return of the Jedi"
  ..$ : chr "A New Hope"
  ..$ : chr [1:5] "The Empire Strikes Back" "Return of the Jedi" "The Phantom Menace" "Attack of the Clones" ...
  ..$ : chr [1:5] "The Empire Strikes Back" "Return of the Jedi" "The Phantom Menace" "Attack of the Clones" ...
  ..$ : chr [1:3] "The Empire Strikes Back" "Return of the Jedi" "Attack of the Clones"
  ..$ : chr "The Empire Strikes Back"
  ..$ : chr "The Empire Strikes Back"
  ..$ : chr [1:2] "The Empire Strikes Back" "Return of the Jedi"
  ..$ : chr "The Empire Strikes Back"
  ..$ : chr [1:2] "Return of the Jedi" "The Force Awakens"
  ..$ : chr "Return of the Jedi"
  ..$ : chr "Return of the Jedi"
  ..$ : chr "Return of the Jedi"
  ..$ : chr "Return of the Jedi"
  ..$ : chr "The Phantom Menace"
  ..$ : chr [1:3] "The Phantom Menace" "Attack of the Clones" "Revenge of the Sith"
  ..$ : chr "The Phantom Menace"
  ..$ : chr [1:3] "The Phantom Menace" "Attack of the Clones" "Revenge of the Sith"
  ..$ : chr [1:2] "The Phantom Menace" "Attack of the Clones"
  ..$ : chr "The Phantom Menace"
  ..$ : chr "The Phantom Menace"
  ..$ : chr "The Phantom Menace"
  ..$ : chr [1:2] "The Phantom Menace" "Attack of the Clones"
  ..$ : chr "The Phantom Menace"
  ..$ : chr "The Phantom Menace"
  ..$ : chr [1:2] "The Phantom Menace" "Attack of the Clones"
  ..$ : chr "The Phantom Menace"
  ..$ : chr "Return of the Jedi"
  ..$ : chr [1:3] "The Phantom Menace" "Attack of the Clones" "Revenge of the Sith"
  ..$ : chr "The Phantom Menace"
  ..$ : chr "The Phantom Menace"
  ..$ : chr "The Phantom Menace"
  ..$ : chr "The Phantom Menace"
  ..$ : chr [1:3] "The Phantom Menace" "Attack of the Clones" "Revenge of the Sith"
  ..$ : chr [1:3] "The Phantom Menace" "Attack of the Clones" "Revenge of the Sith"
  ..$ : chr [1:3] "The Phantom Menace" "Attack of the Clones" "Revenge of the Sith"
  ..$ : chr [1:2] "The Phantom Menace" "Revenge of the Sith"
  ..$ : chr [1:2] "The Phantom Menace" "Revenge of the Sith"
  ..$ : chr [1:2] "The Phantom Menace" "Revenge of the Sith"
  ..$ : chr "The Phantom Menace"
  ..$ : chr [1:3] "The Phantom Menace" "Attack of the Clones" "Revenge of the Sith"
  ..$ : chr [1:2] "The Phantom Menace" "Attack of the Clones"
  ..$ : chr "Attack of the Clones"
  ..$ : chr "Attack of the Clones"
  ..$ : chr "Attack of the Clones"
  ..$ : chr [1:2] "Attack of the Clones" "Revenge of the Sith"
  ..$ : chr [1:2] "Attack of the Clones" "Revenge of the Sith"
  ..$ : chr "Attack of the Clones"
  ..$ : chr "Attack of the Clones"
  ..$ : chr [1:2] "Attack of the Clones" "Revenge of the Sith"
  ..$ : chr [1:2] "Attack of the Clones" "Revenge of the Sith"
  ..$ : chr "Attack of the Clones"
  ..$ : chr "Attack of the Clones"
  ..$ : chr "Attack of the Clones"
  ..$ : chr "Attack of the Clones"
  ..$ : chr "Attack of the Clones"
  ..$ : chr "Attack of the Clones"
  ..$ : chr [1:2] "Attack of the Clones" "Revenge of the Sith"
  ..$ : chr "Attack of the Clones"
  ..$ : chr "Attack of the Clones"
  ..$ : chr [1:2] "Attack of the Clones" "Revenge of the Sith"
  ..$ : chr "Revenge of the Sith"
  ..$ : chr "Revenge of the Sith"
  ..$ : chr [1:2] "A New Hope" "Revenge of the Sith"
  ..$ : chr [1:2] "Attack of the Clones" "Revenge of the Sith"
  ..$ : chr "Revenge of the Sith"
  ..$ : chr "The Force Awakens"
  ..$ : chr "The Force Awakens"
  ..$ : chr "The Force Awakens"
  ..$ : chr "The Force Awakens"
  ..$ : chr "The Force Awakens"
 $ vehicles  :List of 87
  ..$ : chr [1:2] "Snowspeeder" "Imperial Speeder Bike"
  ..$ : chr(0) 
  ..$ : chr(0) 
  ..$ : chr(0) 
  ..$ : chr "Imperial Speeder Bike"
  ..$ : chr(0) 
  ..$ : chr(0) 
  ..$ : chr(0) 
  ..$ : chr(0) 
  ..$ : chr "Tribubble bongo"
  ..$ : chr [1:2] "Zephyr-G swoop bike" "XJ-6 airspeeder"
  ..$ : chr(0) 
  ..$ : chr "AT-ST"
  ..$ : chr(0) 
  ..$ : chr(0) 
  ..$ : chr(0) 
  ..$ : chr "Snowspeeder"
  ..$ : chr(0) 
  ..$ : chr(0) 
  ..$ : chr(0) 
  ..$ : chr(0) 
  ..$ : chr(0) 
  ..$ : chr(0) 
  ..$ : chr(0) 
  ..$ : chr(0) 
  ..$ : chr(0) 
  ..$ : chr(0) 
  ..$ : chr(0) 
  ..$ : chr(0) 
  ..$ : chr(0) 
  ..$ : chr "Tribubble bongo"
  ..$ : chr(0) 
  ..$ : chr(0) 
  ..$ : chr(0) 
  ..$ : chr(0) 
  ..$ : chr(0) 
  ..$ : chr(0) 
  ..$ : chr(0) 
  ..$ : chr(0) 
  ..$ : chr(0) 
  ..$ : chr(0) 
  ..$ : chr(0) 
  ..$ : chr "Sith speeder"
  ..$ : chr(0) 
  ..$ : chr(0) 
  ..$ : chr(0) 
  ..$ : chr(0) 
  ..$ : chr(0) 
  ..$ : chr(0) 
  ..$ : chr(0) 
  ..$ : chr(0) 
  ..$ : chr(0) 
  ..$ : chr(0) 
  ..$ : chr(0) 
  ..$ : chr(0) 
  ..$ : chr(0) 
  ..$ : chr(0) 
  ..$ : chr(0) 
  ..$ : chr(0) 
  ..$ : chr(0) 
  ..$ : chr(0) 
  ..$ : chr(0) 
  ..$ : chr(0) 
  ..$ : chr(0) 
  ..$ : chr(0) 
  ..$ : chr "Flitknot speeder"
  ..$ : chr(0) 
  ..$ : chr(0) 
  ..$ : chr "Koro-2 Exodrive airspeeder"
  ..$ : chr(0) 
  ..$ : chr(0) 
  ..$ : chr(0) 
  ..$ : chr(0) 
  ..$ : chr(0) 
  ..$ : chr(0) 
  ..$ : chr(0) 
  ..$ : chr(0) 
  ..$ : chr "Tsmeu-6 personal wheel bike"
  ..$ : chr(0) 
  ..$ : chr(0) 
  ..$ : chr(0) 
  ..$ : chr(0) 
  ..$ : chr(0) 
  ..$ : chr(0) 
  ..$ : chr(0) 
  ..$ : chr(0) 
  ..$ : chr(0) 
 $ starships :List of 87
  ..$ : chr [1:2] "X-wing" "Imperial shuttle"
  ..$ : chr(0) 
  ..$ : chr(0) 
  ..$ : chr "TIE Advanced x1"
  ..$ : chr(0) 
  ..$ : chr(0) 
  ..$ : chr(0) 
  ..$ : chr(0) 
  ..$ : chr "X-wing"
  ..$ : chr [1:5] "Jedi starfighter" "Trade Federation cruiser" "Naboo star skiff" "Jedi Interceptor" ...
  ..$ : chr [1:3] "Naboo fighter" "Trade Federation cruiser" "Jedi Interceptor"
  ..$ : chr(0) 
  ..$ : chr [1:2] "Millennium Falcon" "Imperial shuttle"
  ..$ : chr [1:2] "Millennium Falcon" "Imperial shuttle"
  ..$ : chr(0) 
  ..$ : chr(0) 
  ..$ : chr "X-wing"
  ..$ : chr "X-wing"
  ..$ : chr(0) 
  ..$ : chr(0) 
  ..$ : chr "Slave 1"
  ..$ : chr(0) 
  ..$ : chr(0) 
  ..$ : chr "Millennium Falcon"
  ..$ : chr(0) 
  ..$ : chr(0) 
  ..$ : chr(0) 
  ..$ : chr "A-wing"
  ..$ : chr(0) 
  ..$ : chr "Millennium Falcon"
  ..$ : chr(0) 
  ..$ : chr(0) 
  ..$ : chr(0) 
  ..$ : chr [1:3] "Naboo fighter" "H-type Nubian yacht" "Naboo star skiff"
  ..$ : chr(0) 
  ..$ : chr(0) 
  ..$ : chr(0) 
  ..$ : chr "Naboo Royal Starship"
  ..$ : chr(0) 
  ..$ : chr(0) 
  ..$ : chr(0) 
  ..$ : chr(0) 
  ..$ : chr "Scimitar"
  ..$ : chr(0) 
  ..$ : chr(0) 
  ..$ : chr(0) 
  ..$ : chr(0) 
  ..$ : chr(0) 
  ..$ : chr(0) 
  ..$ : chr(0) 
  ..$ : chr(0) 
  ..$ : chr(0) 
  ..$ : chr(0) 
  ..$ : chr(0) 
  ..$ : chr(0) 
  ..$ : chr(0) 
  ..$ : chr "Jedi starfighter"
  ..$ : chr(0) 
  ..$ : chr "Naboo fighter"
  ..$ : chr(0) 
  ..$ : chr(0) 
  ..$ : chr(0) 
  ..$ : chr(0) 
  ..$ : chr(0) 
  ..$ : chr(0) 
  ..$ : chr(0) 
  ..$ : chr(0) 
  ..$ : chr(0) 
  ..$ : chr(0) 
  ..$ : chr(0) 
  ..$ : chr(0) 
  ..$ : chr(0) 
  ..$ : chr(0) 
  ..$ : chr(0) 
  ..$ : chr(0) 
  ..$ : chr(0) 
  ..$ : chr(0) 
  ..$ : chr "Belbullab-22 starfighter"
  ..$ : chr(0) 
  ..$ : chr(0) 
  ..$ : chr(0) 
  ..$ : chr(0) 
  ..$ : chr(0) 
  ..$ : chr(0) 
  ..$ : chr "X-wing"
  ..$ : chr(0) 
  ..$ : chr(0)

Offers datasets for applied statistics, including the Boston housing data.

library(MASS)
data(Boston)
str(Boston)
'data.frame':   506 obs. of  14 variables:
 $ crim   : num  0.00632 0.02731 0.02729 0.03237 0.06905 ...
 $ zn     : num  18 0 0 0 0 0 12.5 12.5 12.5 12.5 ...
 $ indus  : num  2.31 7.07 7.07 2.18 2.18 2.18 7.87 7.87 7.87 7.87 ...
 $ chas   : int  0 0 0 0 0 0 0 0 0 0 ...
 $ nox    : num  0.538 0.469 0.469 0.458 0.458 0.458 0.524 0.524 0.524 0.524 ...
 $ rm     : num  6.58 6.42 7.18 7 7.15 ...
 $ age    : num  65.2 78.9 61.1 45.8 54.2 58.7 66.6 96.1 100 85.9 ...
 $ dis    : num  4.09 4.97 4.97 6.06 6.06 ...
 $ rad    : int  1 2 2 3 3 3 5 5 5 5 ...
 $ tax    : num  296 242 242 222 222 222 311 311 311 311 ...
 $ ptratio: num  15.3 17.8 17.8 18.7 18.7 18.7 15.2 15.2 15.2 15.2 ...
 $ black  : num  397 397 393 395 397 ...
 $ lstat  : num  4.98 9.14 4.03 2.94 5.33 ...
 $ medv   : num  24 21.6 34.7 33.4 36.2 28.7 22.9 27.1 16.5 18.9 ...

Contains datasets ideal for regression, ANOVA, and generalized linear models.

library(carData)
data(MplsStops)
str(MplsStops)
'data.frame':   51920 obs. of  14 variables:
 $ idNum         : Factor w/ 61212 levels "16-395258","16-395296",..: 6823 6824 6825 6826 6827 6828 6829 6830 6831 6832 ...
 $ date          : POSIXct, format: "2017-01-01 00:00:42" "2017-01-01 00:03:07" ...
 $ problem       : Factor w/ 2 levels "suspicious","traffic": 1 1 2 1 2 2 1 2 2 2 ...
 $ MDC           : Factor w/ 2 levels "MDC","other": 1 1 1 1 1 1 1 1 1 1 ...
 $ citationIssued: Factor w/ 2 levels "NO","YES": NA NA NA NA NA NA NA NA NA NA ...
 $ personSearch  : Factor w/ 2 levels "NO","YES": 1 1 1 1 1 1 1 1 1 1 ...
 $ vehicleSearch : Factor w/ 2 levels "NO","YES": 1 1 1 1 1 1 1 1 1 1 ...
 $ preRace       : Factor w/ 8 levels "Black","White",..: 3 3 3 3 3 3 3 3 3 3 ...
 $ race          : Factor w/ 8 levels "Black","White",..: 3 3 2 4 2 4 1 7 2 1 ...
 $ gender        : Factor w/ 3 levels "Female","Male",..: 3 2 1 2 1 2 2 1 2 2 ...
 $ lat           : num  45 45 44.9 44.9 45 ...
 $ long          : num  -93.2 -93.3 -93.3 -93.3 -93.3 ...
 $ policePrecinct: int  1 1 5 5 1 1 1 2 2 4 ...
 $ neighborhood  : Factor w/ 87 levels "Armatage","Audubon Park",..: 11 20 84 84 20 20 20 51 59 28 ...

Importing Different Data Formats into R

Before diving into examples, let’s introduce some useful packages for data import:

  • haven: For SPSS, SAS, and Stata files.
  • data.table: Efficient data manipulation and import.
  • readxl: For reading Excel files.
  • jsonlite: For importing JSON files.

Here is how you can import different data formats into R:

data <- read.csv("data/airtravel.csv")
head(data)
  Month X1958 X1959 X1960
1   JAN   340   360   417
2   FEB   318   342   391
3   MAR   362   406   419
4   APR   348   396   461
5   MAY   363   420   472
6   JUN   435   472   535
library(readxl)
data <- read_excel("data/Melanoma.xlsx")
head(data)
# A tibble: 6 × 7
   time status   sex   age  year thickness ulcer
  <dbl>  <dbl> <dbl> <dbl> <dbl>     <dbl> <dbl>
1    10      3     1    76  1972      6.76     1
2    30      3     1    56  1968      0.65     0
3    35      2     1    41  1977      1.34     0
4    99      3     0    71  1968      2.9      0
5   185      1     1    52  1965     12.1      1
6   204      1     1    28  1971      4.84     1
library(DBI)
con <- dbConnect(RSQLite::SQLite(), "data/medal.db")
data <- dbGetQuery(con, "SELECT * FROM Olympic2024")
head(data)
               Team              Olympic No Gold Silver Bronze Total
1 Afghanistan (AFG)       Combined total 16    0      0      2     2
2 Afghanistan (AFG) Summer Olympic Games 16    0      0      2     2
3 Afghanistan (AFG) Winter Olympic Games  0    0      0      0     0
4     Albania (ALB)       Combined total 15    0      0      2     2
5     Albania (ALB) Summer Olympic Games 10    0      0      2     2
6     Albania (ALB) Winter Olympic Games  5    0      0      0     0
library(jsonlite)
data <- fromJSON("data/sdg-goals.json")
str(data, list.len = 2)
'data.frame':   17 obs. of  6 variables:
 $ goal     :List of 17
  ..$ : int 1
  ..$ : int 2
  .. [list output truncated]
 $ title    :List of 17
  ..$ : chr "End poverty in all its forms everywhere"
  ..$ : chr "End hunger, achieve food security and improved nutrition and promote sustainable agriculture"
  .. [list output truncated]
  [list output truncated]
library(rvest)
# url <- "https://en.wikipedia.org/wiki/Booker_Prize"
url <- "data/Booker-Prize.html"
data <- read_html(url) %>%
    html_node(".wikitable") %>%
    html_table()
head(data)
# A tibble: 6 × 5
   Year Author              Title                   `Genre(s)`       hideCountry
  <int> <chr>               <chr>                   <chr>            <chr>      
1  1969 P. H. Newby[62]     Something to Answer For Literary fiction UK         
2  1970 Bernice Rubens[63]  The Elected Member      Literary fiction UK         
3  1971 V. S. Naipaul[64]   In a Free State         Literary fiction UK TTO     
4  1972 John Berger[65]     G.                      Experimental li… UK         
5  1973 J. G. Farrell[66]   The Siege of Krishnapur Literary fiction UK IRL     
6  1974 Nadine Gordimer[67] The Conservationist     Literary fiction ZAF

We can load RData file with load function and Rds file using readRDS function. RData file can contain multiple R objects and when loaded we can find the objects saved in RData file in R environment.

load("data/cancer.rds")
head(cancer)
  inst time status age sex ph.ecog ph.karno pat.karno meal.cal wt.loss
1    3  306      2  74   1       1       90       100     1175      NA
2    3  455      2  68   1       0       90        90     1225      15
3    3 1010      1  56   1       0       90        90       NA      15
4    5  210      2  57   1       1       90        60     1150      11
5    1  883      2  60   1       0      100        90       NA       0
6   12 1022      1  74   1       1       50        80      513       0
popmort <- readRDS("data/popmort.rds")
str(popmort)
 'ratetable' num [1:110, 1:2, 1:81] 1.47e-04 1.52e-05 7.92e-06 5.51e-06 4.44e-06 ...
 - attr(*, "dimnames")=List of 3
  ..$ age : chr [1:110] "0" "1" "2" "3" ...
  ..$ sex : chr [1:2] "male" "female"
  ..$ year: chr [1:81] "1940" "1941" "1942" "1943" ...
 - attr(*, "type")= num [1:3] 2 1 4
 - attr(*, "cutpoints")=List of 3
  ..$ : num [1:110] 0 365 730 1096 1461 ...
  ..$ : NULL
  ..$ : Date[1:81], format: "1940-01-01" "1941-01-01" ...
 - attr(*, "summary")=function (R)  
  ..- attr(*, "srcref")= 'srcref' int [1:8] 7 13 15 3 13 3 7 15
  .. ..- attr(*, "srcfile")=Classes 'srcfilecopy', 'srcfile' <environment: 0x5d4b1a8a8440> 
library(haven)
spss_file <- read_sav("data/melanoma.sav")
head(spss_file)
# A tibble: 6 × 14
  sex          age stage     mmdx  yydx surv_mm surv_yy status  subsite year8594
  <dbl+lbl>  <dbl> <dbl+lb> <dbl> <dbl>   <dbl>   <dbl> <dbl+l> <dbl+l> <dbl+lb>
1 2 [Female]    81 1 [Loca…     2  1981    26.5     2.5 2 [Dea… 1 [Hea… 0 [Diag…
2 2 [Female]    75 1 [Loca…     9  1975    55.5     4.5 2 [Dea… 1 [Hea… 0 [Diag…
3 2 [Female]    78 1 [Loca…     2  1978   178.     14.5 2 [Dea… 3 [Lim… 0 [Diag…
4 2 [Female]    75 0 [Unkn…     8  1975    29.5     2.5 1 [Dea… 4 [Mul… 0 [Diag…
5 2 [Female]    81 0 [Unkn…     7  1981    57.5     4.5 2 [Dea… 1 [Hea… 0 [Diag…
6 2 [Female]    75 1 [Loca…     9  1975    19.5     1.5 1 [Dea… 2 [Tru… 0 [Diag…
# ℹ 4 more variables: dx <date>, exit <date>, agegrp <dbl+lbl>, id <dbl>
stata_file <- read_dta("data/colon.dta")
head(stata_file)
# A tibble: 6 × 14
  sex          age stage     mmdx  yydx surv_mm surv_yy status  subsite year8594
  <dbl+lbl>  <dbl> <dbl+lb> <dbl> <dbl>   <dbl>   <dbl> <dbl+l> <dbl+l> <dbl+lb>
1 2 [Female]    77 3 [Dist…     3  1977    16.5     1.5 1 [Dea… 2 [Tra… 0 [Diag…
2 2 [Female]    78 1 [Loca…     7  1978    82.5     6.5 2 [Dea… 1 [Coe… 0 [Diag…
3 1 [Male]      78 3 [Dist…    10  1978     1.5     0.5 1 [Dea… 3 [Des… 0 [Diag…
4 1 [Male]      76 3 [Dist…    10  1976     1.5     0.5 1 [Dea… 3 [Des… 0 [Diag…
5 1 [Male]      80 1 [Loca…    12  1980     8.5     0.5 1 [Dea… 3 [Des… 0 [Diag…
6 2 [Female]    75 1 [Loca…    11  1975    23.5     1.5 1 [Dea… 1 [Coe… 0 [Diag…
# ℹ 4 more variables: agegrp <dbl+lbl>, dx <date>, exit <date>, id <dbl>
sas_file <- read_xpt("data/mpg.xpt")
head(sas_file)
# A tibble: 6 × 11
  manufacturer model displ  year   cyl trans      drv     cty   hwy fl    class 
  <chr>        <chr> <dbl> <dbl> <dbl> <chr>      <chr> <dbl> <dbl> <chr> <chr> 
1 audi         a4      1.8  1999     4 auto(l5)   f        18    29 p     compa…
2 audi         a4      1.8  1999     4 manual(m5) f        21    29 p     compa…
3 audi         a4      2    2008     4 manual(m6) f        20    31 p     compa…
4 audi         a4      2    2008     4 auto(av)   f        21    30 p     compa…
5 audi         a4      2.8  1999     6 auto(l5)   f        16    26 p     compa…
6 audi         a4      2.8  1999     6 manual(m5) f        18    26 p     compa…

Exporting Data to Different Formats in R

R also allows you to export data to various formats:

write.csv(data, "data.csv")
library(writexl)
write_xlsx(data, "data.xlsx")
library(DBI)
con <- dbConnect(RSQLite::SQLite(), "example.db")
dbWriteTable(con, "tablename", data)
library(jsonlite)
write_json(data, "data.json")
library(xml2)
write_html(as_xml_document(as.character(data)), "data.html")
save(data, file = "data.RData")
saveRDS(data, "data.rds")
library(haven)
write_sav(data, "data.sav") # SPSS file
library(haven)
write_dta(data, "data.dta") # Stata file
library(haven)
write_xpt(data, "data.xpt") # SAS file

Available Open Data

There are numerous open data sources available for free use:

Useful Online Resources

Here are some essential resources to deepen your understanding:

  • Dataset in R: Datasets from different package with CSV link and documentation
  • R for Data Science: A comprehensive guide covering data import techniques.
  • RDocumentation: Detailed documentation on R packages and functions.
  • Quick-R: A quick reference for reading and writing data.
  • Tidyverse Blog: Articles and tutorials on data science using Tidyverse packages.
  • DataCamp: Online courses on various topics, including data import in R.
]]> Data Science Tutorials R Programming https://mathatistics.com/blog/posts/2017-03-01-importing-and-exporting-data-in-R/index.html Tue, 28 Feb 2017 23:00:00 GMT