R/sub_sampling.R

In AntonioJBT/episcout: Quickly Clean, Explore and Visualise Large Epidemiological Datasets

############
# Sub-sample from a large dataset
# Weighted, no replacement, based on a binary outcome variable

# # Sample data creation (assuming you have a large dataset)
# set.seed(123)
# data_f <- data.frame(
#   id = 1:10000,
#   outcome = sample(c(0, 1), 10000, replace = TRUE, prob = c(0.7, 0.3)),  # outcome variable with weights
#   other_var = rnorm(10000)
# )

# Variable for weighting:
outcome_var <- 'd_death_30'

# Weighting didn't work
# So split the datasets and sampled separately

# Generate weights:
# For binary variable to balance sub-sample:
# weights <- ifelse(data_f[[outcome_var]] == 1,
#                   1 / sum(data_f[[outcome_var]] == 1),
#                   1 / sum(data_f[[outcome_var]] == 0)
#                   )

# total_1 <- sum(data_f[[outcome_var]] == 1)
# total_0 <- sum(data_f[[outcome_var]] == 0)
# weights <- ifelse(data_f[[outcome_var]] == 1, 1 / total_1, 1 / total_0)
# sum(weights)

# # Normalize the weights to sum to 1:
# weights <- weights / sum(weights)
# sum(weights)
# head(weights)


# Split data based on outcome variable:
data_f_0 <- data_f[data_f[[outcome_var]] == 0, ]
data_f_1 <- data_f[data_f[[outcome_var]] == 1, ]
dim(data_f_0)
dim(data_f_1)

# Calculate percent needed of the total size, var defined in other script:
# perc_needed <- 0.0001
sample_size <- perc_needed * nrow(data_f)
sample_size
sample_size_0 <- round(perc_needed * nrow(data_f_0))
sample_size_1 <- round(perc_needed * nrow(data_f_1))

# Sample without replacement using the normalized weights
set.seed(123)  # for reproducibility

# For each subset get sub-sample:
sample_indices_0 <- sample(1:nrow(data_f_0), size = sample_size_0, replace = FALSE)
sample_indices_1 <- sample(1:nrow(data_f_1), size = sample_size_1, replace = FALSE)

length(sample_indices_0)
length(sample_indices_1)

# Actual sub-samples:
data_f_sub_0 <- data_f_0[sample_indices_0, ]
data_f_sub_1 <- data_f_1[sample_indices_1, ]

# Join datasets:
data_f_sub <- rbind(data_f_sub_0, data_f_sub_1)

dim(data_f_sub)
str(data_f_sub)
epi_head_and_tail(data_f_sub)


# Check distribution of var of interest:
table(data_f[[outcome_var]])
table(data_f_sub[[outcome_var]])
prop.table(table(data_f[[outcome_var]]))
prop.table(table(data_f_sub[[outcome_var]]))
############