Anonymising the data

Load data

library(knitr)
opts_chunk$set(fig.width = 12, fig.height = 12, cache = F, warning = F, message = F)

source("0_helpers.R")
load("full_data.rdata")

set some defaults

diary = diary %>% 
  mutate(
  included = included_all,
  fertile = if_else(is.na(prc_stirn_b_squished), prc_stirn_b_backward_inferred, prc_stirn_b_squished),
  contraceptive_methods = factor(contraceptive_method, levels = 
  c("barrier_or_abstinence", "fertility_awareness", "none",  "hormonal")),
  relationship_status_clean = factor(relationship_status_clean),
  cohabitation = factor(cohabitation),
  certainty_menstruation = as.numeric(as.character(certainty_menstruation))
)  %>% group_by(person) %>% 
  mutate(
      fertile_mean = mean(fertile, na.rm = T)
  )

cleaning

These fields were stored as text, but can be simplified.

diary = diary %>% mutate(
  want_more_info = as.integer(want_more_info),
  trying_to_get_pregnant = if_else(trying_to_get_pregnant == 'yes', 1, 0),
  had_sex_with_partner_yet = if_else(had_sex_with_partner_yet == 'yes', 1, 0),
  breast_feeding_in_last_3_months = if_else(breast_feeding_in_last_3_months == 'yes', 1, 0),
  hormonal_medication_in_last_3_months = if_else(hormonal_medication_in_last_3_months == 'yes', 1, 0),
  pill_in_last_3_months = if_else(pill_in_last_3_months == 'yes', 1, 0)
)

remove free-text fields

Free text fields often have unique values and can contain things like IDs, addresses, free-text responses to questions, etc.

# first I look only at character columns (they tend to have most unique values)
diary %>% select_if(is.character) %>% 
  gather(variable, value) %>%  # putting this in long format allows me to easily 
  group_by(variable) %>% 
  summarise(n = n_nonmissing(value), n_dist = n_distinct(value)) %>% # summarise frequencies of values
  pander() # and display them

# of course manual inspection (for me, using View() ) is important too

# same thing for factors shows no rare unique values 
diary %>% select_if(is.factor) %>% 
  gather(variable, value) %>% 
  group_by(variable) %>% 
  summarise(n = n_nonmissing(value), n_dist = n_distinct(value)) %>%
  arrange(n_dist) %>% 
  pander()

# diary %>% select_if(is.character) %>% names() %>% cat(sep=", -")

# here I remove all columns that have text fields which might betray someone's identity
diary = diary %>% select(-session, -session_id, -session_id.vorab, -short, -sess_day, -session_id.abschluss, -short_session, -vpn, -session_id.nachbe_other_hormonal,
          -pills,-other_pill_name, -religion, -relationship_status, -postal_code, -children, -method_meeting,  -meaning_study, -medicament_2, -special_days, -illness_2, -change_contraception_2, -feedback_for_us, -name_hormonal, -hypothesis_guessed, -children_narrow_categories,  -special_events)

Dates and times

diary %>% select_if(is.instant) %>% 
  gather(variable, value) %>% 
  group_by(variable) %>% 
  summarise(n = n_nonmissing(value), n_dist = n_distinct(value)) %>%
  arrange(n_dist) %>% 
  pander()

diary = diary %>% 
  # remove all datetime we don't need
  select(-starts_with("created")) %>% 
  select(-starts_with("modified")) %>% 
  select(-starts_with("expired")) %>% 
  select(-first_day, -first_diary_date, -cyklus_1, -last_menstruation, -next_menstrual_onset, -menstrual_onset_date_inferred, -last_diary_date, -menstruation_dates, -next_menstrual_onset_inferred, -last_menstrual_onset) %>% 

    mutate( # we do want to know whether they finished a survey, but can't know when
    ended = !is.na(ended),
    ended.vorab = !is.na(ended.vorab),
    ended.abschluss = !is.na(ended.abschluss),
    ended.nachbe_other_hormonal = !is.na(ended.nachbe_other_hormonal)
    )

a similar problem exists for intervals, but we might need these and I can easily round them. Here I unfortunately didn’t store them as type interval, so I have to look through all numeric types

# diary %>% select_if(is.interval) %>% 
#   gather(variable, value) %>% 
#   group_by(variable) %>% 
#   summarise(n = n_nonmissing(value), n_dist = n_distinct(value)) %>%
#   arrange(n_dist) %>% 
#   pander()

The Hmisc::cut2 function allows me to group variables into g groups and try to make no group contain fewer than m values.

diary = diary %>% 
  mutate(
    time_for_response = Hmisc::cut2(time_for_response, g = 10, m = 30),
    time_of_response = Hmisc::cut2(time_of_response, g = 10, m = 30),
    time_since_last_response = Hmisc::cut2(time_since_last_response, cuts = 10, m = 30),
    biggest_diff = Hmisc::cut2(biggest_diff, g = 10, m = 30),
    avg_diff = Hmisc::cut2(avg_diff, g = 10, m = 300),
    days_responded_percentage = Hmisc::cut2(days_responded_percentage, g = 10, m = 300)
    )

finding rare values

Although rare values won’t allow anyone to identify many participants, it is important to protect privacy for all participants. In our case especially, a potential attacker might know that e.g. his girlfriend uses a pill with a rare gestagen and identify her like this.

To this end, I wrote the function below. It gives (depending on the last argument) the rarest value and how frequent it is. I included the group variable, because a lot of demographic data is duplicated in my diary data.

commonness_rarest_value = function(x, group, give_value = FALSE) {
  df = data.frame(x = x, group = group) %>% unique()
  counts = table(df$x)
  ret = counts[which.min(counts)]
  if (give_value) names(ret) else ret
}

diary %>% gather(variable, value, -person) %>% 
  group_by(variable) %>% 
  summarise(n = n_nonmissing(value), n_dist = n_distinct(value), lc_val = commonness_rarest_value(value, person, T), lc_freq = commonness_rarest_value(value, person, F)) %>% 
  arrange(desc(lc_freq/(n_dist+lc_freq))) %>% 
  pander()

# drop
diary = diary %>% 
  # durations redundant with total duration, use age group, sex orientation has overly rare categories
  select(-duration_relationship_months,-duration_relationship_years, -age, -sex_orientation
)

## round/group
diary = diary %>% mutate(
  # height = round_any(height, 5), # rounding would be nice but leaves extreme values out there
  # weight = round_any(weight, 5),
  # BMI = round_any(BMI, 2),
  duration_relationship_total = round_any(duration_relationship_total/12, 0.3)
  # first_time = round_any(first_time, 3)
) %>% 
  select(
    -estrogen_ug_per_kg # derived factors from weight can allow people to recompute weight
    )

## cap
na_if_lt = function(x, lt) {
  x = as.numeric(x)
  if_else(x < lt, NA_real_, x)
}
na_if_gt = function(x, gt) {
  x = as.numeric(x)
  if_else(x > gt, NA_real_, x)
}
diary = diary %>% mutate(
  RCD = na_if_lt(RCD, -40),
  RCD_rel_to_ovulation = na_if_lt(RCD_rel_to_ovulation, -20),
  RCD_inferred = na_if_gt(na_if_lt(RCD_inferred, -40), 30),
  RCD_for_merge = na_if_gt(RCD_for_merge, 50),
  FCD = na_if_gt(FCD, 40),
  day_number = na_if_gt(day_number, 40),
  menstrual_onset_days_since = na_if_gt(menstrual_onset_days_since, 40),
  menstrual_onset_days_until = na_if_lt(menstrual_onset_days_until, -40),
  minimum_cycle_length_diary = na_if_gt(minimum_cycle_length_diary, 40),
  took_days = na_if_gt(took_days, 40),
  timespan = na_if_gt(timespan, 40),
  mean_cycle_length_diary = na_if_gt(mean_cycle_length_diary, 40),
  median_cycle_length_diary = na_if_gt(mean_cycle_length_diary, 40),
  cycle_length_diary = na_if_gt(mean_cycle_length_diary, 40),
  last_lag = na_if_gt(last_lag, 40),
  number_sexual_partner = na_if_gt(number_sexual_partner, 30)
)

check if we did a good job

diary %>% gather(variable, value, -person) %>% 
  group_by(variable) %>% 
  summarise(n = n_nonmissing(value), n_dist = n_distinct(value), lc_val = commonness_rarest_value(value, person, T), lc_freq = commonness_rarest_value(value, person, F)) %>% 
  arrange(desc(lc_freq/(n_dist+lc_freq))) %>% 
  pander()

finding rare combinations

Ideally, no participant should be uniquely identified, but this is not realistic. Instead, I look for unique combinations of demographic variables.

cut_to_number = function(x, group = NULL, m = 40) { 
  if(!is.null(group)) {
    df = data.frame(x = x, group = group) %>% unique()
  } else {
    df = data.frame(x = x)
  }
    cuts = Hmisc::cut2(df$x, m = m, onlycuts = T) # cut on person level
    as.numeric(as.character(Hmisc::cut2(x, cuts = cuts, levels.mean = T)))
  }

unique_combos = diary %>% 
  group_by(age_group, height, weight, religion_clean, duration_relationship_total) %>% 
  summarise(n = n()) %>% 
  ungroup() %>% 
  arrange(desc(n)) %>% 
  filter(n < 7)

nrow(unique_combos)

## [1] 198

diary = diary %>% 
  mutate(
    religion_clean = recode(religion_clean, "Judentum" = "other", "Islam" = "other", "Buddhismus" = "other", .missing = "other"),
    weight = cut_to_number(weight,person, m = 50),
    height = cut_to_number(height,person, m = 50),
    first_time = cut_to_number(first_time, person),
    duration_relationship_total = cut_to_number(duration_relationship_total, person, m = 50)
  )

unique_combos = diary %>% 
  group_by(age_group, height, weight, religion_clean, duration_relationship_total) %>% 
  summarise(n = n()) %>% 
  ungroup() %>% 
  arrange(desc(n)) %>% 
  filter(n < 7)

nrow(unique_combos)

## [1] 186

# unique_combos %>%
#   pander()


diary = diary %>% left_join(unique_combos %>% select(-n) %>% mutate(too_unique = T))

diary = diary %>% mutate(
  too_unique = if_else(is.na(too_unique), F, too_unique),
  age_group = if_else(!too_unique, age_group, NA_integer_),
  height = if_else(too_unique, NA_real_, height),
  weight = if_else(too_unique, NA_real_, weight),
  religion_clean = if_else(!too_unique, religion_clean, NA_character_),
  duration_relationship_total = if_else(too_unique, NA_real_, duration_relationship_total)
)

Make one version with the less sensitive data

diary_noep = diary %>% select(-starts_with("SOI")) %>% select(-starts_with("extra_pair")) %>% select(-number_sexual_partner, -trying_to_get_pregnant, -has_not_had_sex_yet, -had_sex_with_partner_yet, -first_time)

Save

save(diary_noep, file = "diary_restricted_anonymised.rdata")
haven::write_sav(diary_noep, path = "diary_restricted_anonymised.sav")

## Error in if (any(bad_lengths)) {: missing value where TRUE/FALSE needed

save(diary, file = "diary_anonymised.rdata")
haven::write_sav(diary, path = "diary_anonymised.sav")

## Error in if (any(bad_lengths)) {: missing value where TRUE/FALSE needed