Introduction

This case study in R demonstrates a method I used to resample a dataset to remove bias within it. We were examining allometric scaling of the human torso. For any specific measurement, \(X_i\) the allometric scaling law can be applied such that: \[\begin{equation} \tag{1} X_i = \alpha_iH^{\beta_i} \end{equation}\] Where \(\alpha\) and \(\beta\) are parameters and \(H\) is the height of the individual. Unfortunately in this dataset there was bias, the body mass index was not independent of height (plotted below). This exercise attempted to randomly remove individuals from the dataset to remove this bias, but to do so as efficiently as possible.

Original Document

The R markdown code can be found on github

The Dataset

The dataset obtained via a data sharing agreement with the LIFE-Adult-Study. The element we accessed consisted of almost 10,000 individual body scans from which size data could be obtained. I have not included loading the dataset in this markdown document but separate data frames were loaded containing the measurement information and the gender information. Resampling was done on a per gender basis.

The Code

Many of the standard libraries were loaded for data manipulation and visualisation

library(dplyr)
library(ggplot2)
library(gridExtra)
library(data.table)
#Load saved data
load('c:\\saved_DAT.Rdata')

Trimmed down data frames were created for simpler operation, the unique key of each data frame was named the same to make union operations easier to code

Dat_Gender_trim <- data.table(SIC = Dat_Gender$SIC,GENDER = Dat_Gender$ADULT_PROB_GENDER,AGE = Dat_Gender$ADULT_PROB_AGE)
Dat_Measures_trim <- data.table(SIC = Dat_Measures$BS_SIC, WAIST_GTH = Dat_Measures$BS_WAIST_GTH, HEIGHT = Dat_Measures$BS_HT, BMI = Dat_Measures$BS_BMI)
names(Dat_Measures_trim)[names(Dat_Measures_trim) == "Dat_Measures.BS_SIC"]<-"Dat_Measures.SIC"

A single data table was created by performing a union operation so Gender could be combined with measures (BMI etc.)

setkey(Dat_Gender_trim,SIC)
setkey(Dat_Measures_trim,SIC)
Dat <- Dat_Gender_trim[Dat_Measures_trim]

The Bias

As can be observed, BMI tends to decrease with height rather than being independent

Resampling

To correct from this, random individuals were removed from the sample if they reduce the bias available. Simply, a random individual is selected. If the gradient is lower post-removal then they are taken from the sample. If not then another random individual is selected.

One_at_time = function(Dat_sample){
  original_SIC <- Dat_sample$SIC
  n_orig <- nrow(Dat_sample) # number of rows in original sample
  f <- lm(BMI ~ HEIGHT, data = Dat_sample) # The original linear fit
  mbest <- f$coefficients[2] # The original gradient
  m <- 100 # place holder for gradient of that iteration
  while(abs(mbest) > 0.00001){ # Will continue removing samples until the gradient is lower than 1 in 100,000
    n <- nrow(Dat_sample)
    while(abs(m)>abs(mbest)){
      samp <- sample(n,n-1)
      Dat_test <- Dat_sample[samp,]
      
      # Find gradient of BMI~Height
      f <- lm(BMI ~ HEIGHT, data = Dat_test)
      m <- f$coefficients[2]
      if (abs(m)>abs(mbest)) {
        print("Not improved, trying another sample")
      }
    }
    Dat_sample <- Dat_test
    mbest <- m
    disp_string <- paste("Size of sample: ",n, " Best gradient: ", m," % reduction: ",100*(1- n/n_orig)) 
    
    m<- 100 # reset gradient value
        print(disp_string) # Print some information regarding each iteration
  }
  removed_SIC <-original_SIC[!(original_SIC %in% Dat_sample$SIC)]
  return(list(removed_SIC,Dat_sample))
}

We can create a sampled data frame which has gone through the resampling algorithm

output_female <- One_at_time(Dat_Female)
Removed_females <- output_female[[1]]
Removed_females <- Dat_Female[(Dat_Female$SIC %in% Removed_females),]
Dat_Female_sampled <- output_female[[2]]
output_male <- One_at_time(Dat_Male)
Removed_males <- output_male[[1]]
Removed_males <- Dat_Male[(Dat_Male$SIC %in% Removed_males),]
Dat_Male_sampled <- output_male[[2]]

and compare it with the original cohort.

The full female cohort contained 5317 samples. After re-sampling this was reduced to 3901, a reduction of 27 %.

The full male cohort contained 4824 samples. After re-sampling this was reduced to 4185, a reduction of 13 %.

Let’s examine the mean BMI values for different height ranges, for the original data and the resampled data

The original data: female
height_range n BMI
(140,160] 1521 28.50493
(160,180] 3718 26.28349
(180,200] 78 25.37179
The resampled data: female
height_range n BMI
(140,160] 1145 27.09869
(160,180] 2701 26.82303
(180,200] 55 26.87273
The original data: male
height_range n BMI
(150,170] 1071 28.35107
(170,190] 3611 27.52617
(190,210] 142 27.52817
The resampled data: female
height_range n BMI
(150,170] 925 27.82270
(170,190] 3137 27.67612
(190,210] 123 28.16260

If we look at the linear fit of Height~BMI then the gradient is effectively flat. Pearson R values for are 8.9890292^{-6} for the resampled female cohort and -9.0790528^{-6} for the resampled male cohort.

Next Steps

Once we have the resampled data set we can find the representative coefficients \(\alpha\) and \(\beta\) in the cohort using a transformation of equation 1: \[\begin{equation} \tag{2} ln(X_i) = ln(\alpha_i) + \beta_i\cdot ln(H) \end{equation}\] A regression line through a plot of \(ln(X_i)\) and \(ln(H)\) gives \(\beta\) as the gradient and \(ln(\alpha)\) as the intercept. The function below could be used for this purpose

get_allometric_coefficients = function(data,name_of_variable){
  variable_vector = data[,name_of_variable]
  linear_model <- lm(log(variable_vector) ~ log(data$HEIGHT), data = data)
  return(linear_model$coefficients)
}