#=============================================================================#
# File Name: HPPT-classification-functions.R
# Original Creator: ktto
# Date Created: 2022 Sept 19
# Description: Source code to derive HPPT classifications
# Required Packages:
# - dplyr, readr, tidyr
#=============================================================================#

if (!require(dplyr)) install.packages(dplyr); library(dplyr)
if (!require(readr)) install.packages(readr); library(readr)
if (!require(tidyr)) install.packages(tidyr); library(tidyr)

# GENERAL FUNCTIONS -----

#=================#
# Custom rounding method so rounding behaves as expected
#-----------------#
# `x` = numeric value or vector
# `digits` = number of digits to round to
#-----------------#
# Example: Compare round(1.125,2) and rnd(1.125, 2)
#=================#
rnd <- function(x, digits) {
  dscale <- 10^digits
  z <- trunc((abs(x) * dscale) + 0.5 + sqrt(.Machine$double.eps))
  (z * sign(x)) / dscale
}

#=================#
# Given a sorted vector, returns the value(s) at the middle position of the
# vector
#-----------------#
# sorted_values : a vector of values, assumed to be sorted
#-----------------#
# If provided a vector with an odd number of values, returns the single
# value in the middle position of the vector. If provided a vector with
# an even number of values, returns the two values in the middle position
# of the vector
#=================#
get_median <- function(sorted_values) {
  n <- length(sorted_values)
  if (n %% 2 == 1) {
    sorted_values[ceiling(n / 2)]
  } else if (n %% 2 == 0) {
    i <- n / 2
    j <- i + 1
    sorted_values[i:j]
  }
}

#=================#
# Converts columns to numeric. If the values are given as a range
# or mixture, the minimum value will be returned.
#-----------------#
# `dt` = data frame
# `col_nm` = name of column in dt to be converted (string)
# `na.values` = values to be interpreted as NA
# `match_pattern` = pattern used to identify ranges or mixtures
#=================#
to_num <- function(dt, col_nm, na.values = c("Not available"),
                   match_pattern) {
  # Pull column values as vector
  cdat <- dt[[col_nm]]
  # Initialize output vector
  new <- vector(mode = "numeric", length = length(cdat))
  
  # Identify missing values
  na_match <- which(cdat %in% na.values)
  # Identify values to be split
  to_split <- grep(match_pattern, cdat)
  
  # Assign missing values as NA
  new[na_match] <- as.numeric(NA)
  # Split and return the minimum value
  new[to_split] <- sapply(strsplit(cdat[to_split], match_pattern), function(x) min(parse_number(x), na.rm = T))
  # Add in standard numeric values
  new[-c(na_match, to_split)] <- as.numeric(cdat[-c(na_match, to_split)])
  return(new)
}


# WEIGHT OF EVIDENCE SCORE -----
#=================#
# Derives WoE extrapolated clasifications and derives WoE score
# based on individual scoring schema.
#-----------------#
# `dt` = tibble
# `call_col` = Name of the column containing active/inactive calls
# `conc_col` = Name of the column containing numeric concentrations
# `dsa_col` = Name of the column containing numeric DSAs
# `dsa1_col` = Name of the column containing numeric DSA1+
# `group_col` = Name of the column with group identifiers (usually chemical identifier)
# `inactive_name` = The string or value in `call_col` corresponding to inactive calls
# `active_name` = The string or value in `call_col` corresponding to active calls
#=================#
hppt_woe_ec_indiv <- function(dt, call_col, conc_col, dsa_col, dsa1_col, group_col = NULL,
                              inactive_name = "Inactive", active_name = "Active") {
  classes_sorted <- c("NC", "NC/1B", "NC/1", "1B", "1B+", "POS", "1A-", "1A")
  woe_ec_scores <- c("NC" = 0, "NC/1B" = 0.5, "NC/1" = NA, "1B" = 1, "1B+" = 1.25, "POS" = 1.5, "1A-" = 1.75, "1A" = 2)
  dt <- dt %>%
    group_by({{ group_col }}) %>%
    mutate(
      ec = case_when(
        {{ call_col }} == inactive_name & is.na({{ conc_col }}) ~ "NC/1",
        {{ call_col }} == inactive_name & {{ conc_col }} < 25 & is.na({{ dsa_col }}) ~ "NC/1",
        {{ call_col }} == inactive_name & {{ conc_col }} < 25 & {{ dsa_col }} <= 375 ~ "NC/1",
        {{ call_col }} == inactive_name & {{ conc_col }} < 25 & {{ dsa_col }} > 375 ~ "NC/1B",
        {{ call_col }} == inactive_name & {{ conc_col }} >= 25 ~ "NC",
        {{ call_col }} == active_name & is.na(dsa1_new) ~ "POS",
        {{ call_col }} == active_name & {{ dsa1_col }} > 625 ~ "1B",
        {{ call_col }} == active_name & {{ dsa1_col }} > 500 & {{ dsa1_col }} <= 625 ~ "1B+",
        {{ call_col }} == active_name & {{ dsa1_col }} > 375 & {{ dsa1_col }} <= 500 ~ "1A-",
        {{ call_col }} == active_name & {{ dsa1_col }} <= 375 ~ "1A"
      ),
      ec = factor(ec, levels = classes_sorted),
      woe_score = woe_ec_scores[ec]
    ) %>%
    ungroup()
  return(dt)
}

#=================#
# Derives overall reference classification from overall WoE score
#-----------------#
# `dt` = tibble
# `group_col` = Name of the column with group identifiers (usually chemical identifier)
# `indiv_woe_score_col` = Column name containing the individual WoE scores.
#=================#
# Note: Here, we use true NA to indicate no data were available to derive
# WoE scores. As such, when the WoE score is NA, the extrapolated classification
# will also be NA because there is nothing to evaluate. "Not applicable" is used
# when the classification table specifies "na", indicating that there exist
# data to evaluate, but it is not informative.
#=================#
hppt_woe_class <- function(dt, group_col = NULL, indiv_woe_score_col = woe_score) {
  dt <- dt %>%
    group_by({{ group_col }}) %>%
    summarize(overall_woe_score = rnd(mean({{ indiv_woe_score_col }}, na.rm = T), digits = 2)) %>%
    ungroup() %>%
    mutate(
      overall_woe_score = ifelse(is.nan(overall_woe_score), as.character(NA), overall_woe_score),
      woe_ghs_bin = case_when(
        is.na(overall_woe_score) ~ as.character(NA),
        overall_woe_score <= 0.25 ~ "NC",
        overall_woe_score <= 0.75 ~ "Not applicable",
        overall_woe_score <= 2 ~ "1"
      ),
      woe_ghs_sub = case_when(
        is.na(overall_woe_score) ~ as.character(NA),
        overall_woe_score <= 0.25 ~ "NC",
        overall_woe_score <= 0.75 ~ "Not applicable",
        overall_woe_score <= 1.49 ~ "1B",
        overall_woe_score == 1.50 ~ "Not applicable",
        overall_woe_score <= 2 ~ "1A"
      ),
      woe_ghs_border = case_when(
        is.na(overall_woe_score) ~ as.character(NA),
        overall_woe_score <= 0.25 ~ "NC",
        overall_woe_score <= 0.75 ~ "NC/1B",
        overall_woe_score <= 1.25 ~ "1B",
        overall_woe_score <= 1.75 ~ "1",
        overall_woe_score <= 2 ~ "1A"
      )
    )
  return(dt)
}

# MEDIAN-LIKE LOCATION PARAMETER -----
#=================#
# Derives the MLLP value
#-----------------#
# middle_values : The extrapolated classification value(s) being evaluated
#-----------------#
# Returns a single MLLP value
#=================#
mllp_logic <- function(middle_values) {
  val_num <- na.omit(suppressWarnings(as.numeric(middle_values)))
  val_med <- median(val_num, na.rm = T)
  out <- case_when(
    !is.na(val_med) ~ as.character(val_med),
    any(middle_values == "POS") ~ "POS",
    any(middle_values == "NC/1B") ~ "NC/1B",
    any(middle_values == "NC") ~ "NC",
    all(middle_values == "NC/1") ~ "NC/1"
  )
  return(out)
}

#=================#
# Helper function to derive the GHS categorizations using the MLLP paradigm
#-----------------#
# mllp_bin : The MLLP value used for binary classification
# mllp_sub : The MLLP value used for sub and border classification
#-----------------#
# Returns the 3 GHS classifications
#=================#
mllp_cat <- function(mllp_bin, mllp_sub) {
  mllp_ghs_bin <- mllp_ghs_sub <- mllp_ghs_border <- NA
  mllp_bin_num <- suppressWarnings(as.numeric(mllp_bin))
  mllp_sub_num <- suppressWarnings(as.numeric(mllp_sub))
  
  mllp_ghs_bin <- case_when(
    is.na(mllp_bin) ~ as.character(NA),
    mllp_bin == "NC" ~ "NC",
    mllp_bin %in% c("NC/1B", "NC/1") ~ "Not applicable",
    mllp_bin == "POS" ~ "1",
    !is.na(mllp_bin_num) ~ "1"
  )
  
  mllp_ghs_sub <- case_when(
    is.na(mllp_sub) ~ as.character(NA),
    mllp_sub == "NC" ~ "NC",
    mllp_sub %in% c("NC/1B", "NC/1") ~ "Not applicable",
    !is.na(mllp_sub_num) & mllp_sub_num > 500 ~ "1B",
    !is.na(mllp_sub_num) & mllp_sub_num <= 500 ~ "1A"
  )
  
  mllp_ghs_border <- case_when(
    is.na(mllp_sub) ~ as.character(NA),
    mllp_sub == "NC" ~ "NC",
    mllp_sub == "NC/1" ~ "Not applicable",
    mllp_sub == "NC/1B" ~ "NC/1B",
    !is.na(mllp_sub_num) & mllp_sub_num > 625 ~ "1B",
    !is.na(mllp_sub_num) & mllp_sub_num > 375 ~ "1",
    !is.na(mllp_sub_num) & mllp_sub_num <= 375 ~ "1A"
  )
  
  out <- c(
    MLLP_GHS_bin = mllp_ghs_bin,
    MLLP_GHS_sub = mllp_ghs_sub,
    MLLP_GHS_border = mllp_ghs_border
  )
  return(out)
}

#=================#
# Derives MLLP values to be used for classification. This function takes in
# 3 vectors that should be equal length and sorted the same, so that
# values in the same position in each 3 vector correspond to the same record.
# The MLLP for binary classification uses "POS" for determining the median
# whereas sub and border classifications do not use "POS". Therefore,
# there will be two different MLLP values reported. One for binary (MLLP_Bin)
# and one for both sub and border (MLLP_sub).
#-----------------#
# dsa_vec : A vector of all DSA values for a given chemical
# dsa1_vec : A vector of all DSA1+ values for a given chemical
# ec_vec : A vector of all extrapolated classifications for a given chemical
#=================#
# Note, true NA is used for cases when a chemical only as ambiguous negative
# classifications, as these are not meant to be evaluated with MLLP.
#=================#
mllp_score <- function(dsa_vec, dsa1_vec, ec_vec) {
  # Sort the vectors by EC and DSA1+
  # ec_vec <- factor(ec_vec, levels = c("NC", "NC/1B", "NC/1", "1B", "1B+", "POS", "1A-", "1A"))
  ec_vec <- factor(ec_vec, levels = c("NC", "NC/1", "NC/1B", "1B", "1B+", "POS", "1A-", "1A"))
  new_ord <- order(ec_vec, dsa1_vec, decreasing = c(F, T))
  dsa_vec <- dsa_vec[new_ord]
  dsa1_vec <- dsa1_vec[new_ord]
  ec_vec <- ec_vec[new_ord]
  
  # Derive the median DSA1+
  pos_med <- median(dsa1_vec, na.rm = T)
  
  # Create a vector for evaluation. If a DSA1+ value exists, the value returned
  # is the DSA1+ value, otherwise it is the EC
  for_median <- ifelse(!is.na(dsa1_vec), as.character(dsa1_vec), as.character(ec_vec))
  
  # If the chemical only has ambiguous negative classifications, return NA
  if (all(ec_vec %in% c("NC/1", "NC/1B"))) {
    out <- c(MLLP_bin = as.character(NA), MLLP_sub = as.character(NA))
    # If the available individual test result outcomes are only NC or NC/1B,
    # the overall MLLP is NC. Added NC/1 to logic.
  } else if (all(ec_vec %in% c("NC", "NC/1B", "NC/1"))) {
    out <- c(MLLP_bin = "NC", MLLP_sub = "NC")
  } else {
    # Create logical vectors to determine whether values should be included
    # in the GHS classification scheme
    use_bin <- vector(mode = "logical", length = length(ec_vec))
    # For binary classification, use all positive results
    use_bin[ec_vec %in% c("1B", "1B+", "POS", "1A-", "1A")] <- T
    # For any negative results, compare to the median of the positive DSA1+ values
    use_bin[ec_vec %in% c("NC", "NC/1B", "NC/1") & (is.na(dsa_vec) | is.na(pos_med))] <- F
    use_bin[ec_vec %in% c("NC", "NC/1B", "NC/1") & dsa_vec < pos_med] <- F
    use_bin[ec_vec %in% c("NC", "NC/1B", "NC/1") & dsa_vec >= pos_med] <- T
    # For sub and border classifications, the ambiguous POS is not used.
    use_sub <- use_bin
    use_sub[ec_vec == "POS"] <- F
    
    # Subset the values for evaluation
    for_bin <- for_median[use_bin]
    n_bin <- length(for_bin)
    for_sub <- for_median[use_sub]
    n_sub <- length(for_sub)
    
    # If there are no values left to evaluate, return NA
    if (n_bin == 0) { # If n_bin is 0,
      out <- c(MLLP_bin = as.character(NA), MLLP_sub = as.character(NA))
      # out <- c(MLLP_bin = "Not applicable", MLLP_sub = "Not applicable")
      # If there is only one value to be evaluated, return that value as the MLLP
    } else if (n_bin == 1) {
      if (n_sub == 0) {
        # out <- c(MLLP_bin = for_bin, MLLP_sub = "Not applicable")
        out <- c(MLLP_bin = for_bin, MLLP_sub = as.character(NA))
      } else if (n_sub == 1) {
        out <- c(MLLP_bin = for_bin, MLLP_sub = for_sub)
      }
    } else {
      bin_middle <- get_median(for_bin)
      sub_middle <- get_median(for_sub)
      if (length(bin_middle) == 1) {
        out_bin <- bin_middle
      } else if (length(bin_middle) == 2) {
        out_bin <- mllp_logic(bin_middle)
      }
      if (length(sub_middle) == 1) {
        out_sub <- sub_middle
      } else if (length(sub_middle) == 2) {
        out_sub <- mllp_logic(sub_middle)
      }
      out <- c(MLLP_bin = out_bin, MLLP_sub = out_sub)
    }
  }
  cats <- mllp_cat(out["MLLP_bin"], out["MLLP_sub"])
  out <- c(out, cats)
  return(data.frame(t(out)))
}

#=================#
# Function to derive the MLLP scores and corresponding GHS classes
#-----------------#
# `dt` = tibble
# `dsa_col` = Name of the column containing numeric DSAs
# `dsa1_col` = Name of the column containing numeric DSA1+
# `ec_col` = Name of the column containing the individual extrapolated classes
# `group_col` = Name of the column with group identifiers (usually chemical identifier)
#=================#
mllp <- function(dt, dsa_col, dsa1_col, ec_col, group_col = NULL) {
  dt <- dt %>%
    group_by({{ group_col }}) %>%
    summarize(mllp_score(
      dsa_vec = {{ dsa_col }},
      dsa1_vec = {{ dsa1_col }},
      ec_vec = {{ ec_col }}
    )) %>%
    ungroup()
  return(dt)
}

# MEDIAN SENSITISATION POTENCY ESTIMATE -----
#=================#
# Derives the MSPE value
#-----------------#
# middle_values : The extrapolated classification value(s) being evaluated
#-----------------#
# Returns a single MSPE value
#=================#
mspe_logic <- function(middle_values) {
  val_num <- na.omit(suppressWarnings(as.numeric(middle_values)))
  val_med <- median(val_num, na.rm = T)
  out <- case_when(
    !is.na(val_med) ~ as.character(val_med),
    any(middle_values == "POS") ~ "POS",
    any(middle_values == "NC/1B") ~ "NC/1B",
    any(middle_values == "NC") ~ "NC"
  )
  return(out)
}

#=================#
# Helper function to derive the GHS categorizations using the MSPE paradigm
#-----------------#
# `mspe_val` : The MSPE value used for classification
#-----------------#
# Returns the 3 GHS classifications
#=================#
mspe_cat <- function(mspe_val) {
  mspe_ghs_bin <- mspe_ghs_sub <- mspe_ghs_border <- NA
  mspe_num <- suppressWarnings(as.numeric(mspe_val))
  
  mspe_ghs_bin <- case_when(
    is.na(mspe_val) ~ as.character(NA),
    mspe_val == "NC" ~ "NC",
    mspe_val == "NC/1B" ~ "Not applicable",
    !is.na(mspe_num) | mspe_val == "POS" ~ "1"
  )
  
  mspe_ghs_sub <- case_when(
    is.na(mspe_val) ~ as.character(NA),
    mspe_val == "NC" ~ "NC",
    mspe_val == "NC/1B" ~ "Not applicable",
    !is.na(mspe_num) & mspe_num > 500 ~ "1B",
    mspe_val == "POS" ~ "Not applicable",
    !is.na(mspe_num) & mspe_num <= 500 ~ "1A"
  )
  
  mspe_ghs_border <- case_when(
    is.na(mspe_val) ~ as.character(NA),
    mspe_val == "NC" ~ "NC",
    mspe_val == "NC/1B" ~ "NC/1B",
    !is.na(mspe_num) & mspe_num > 625 ~ "1B",
    !is.na(mspe_num) & mspe_num <= 375 ~ "1A",
    !is.na(mspe_num) & mspe_num <= 500 ~ "1",
    mspe_val == "POS" ~ "1"
  )
  
  out <- c(
    MSPE_GHS_bin = mspe_ghs_bin,
    MSPE_GHS_sub = mspe_ghs_sub,
    MSPE_GHS_border = mspe_ghs_border
  )
  return(out)
}

#=================#
# Derives MSPE values to be used for classification. This function takes in
# 3 vectors that should be equal length and sorted the same, so that
# values in the same position in each 3 vector correspond to the same record.
#-----------------#
# dsa_vec : A vector of all DSA values for a given chemical
# dsa1_vec : A vector of all DSA1+ values for a given chemical
# ec_vec : A vector of all extrapolated classifications for a given chemical
#=================#
mspe_score <- function(dsa_vec, dsa1_vec, ec_vec) {
  # Sort the vectors by EC and DSA1+
  ec_vec <- factor(ec_vec, levels = c("NC", "NC/1B", "NC/1", "1B", "1B+", "POS", "1A-", "1A"))
  new_ord <- order(ec_vec, dsa1_vec, decreasing = c(F, T))
  dsa_vec <- dsa_vec[new_ord]
  dsa1_vec <- dsa1_vec[new_ord]
  ec_vec <- ec_vec[new_ord]
  
  # Derive the median DSA1+
  pos_med <- median(dsa1_vec, na.rm = T)
  
  # Create a vector for evaluation. If a DSA1+ value exists, the value returned
  # is the DSA1+ value, otherwise it is the EC
  for_median <- ifelse(!is.na(dsa1_vec), as.character(dsa1_vec), as.character(ec_vec))
  
  # If the chemical only has ambiguous negative classifications, return NA
  if (all(ec_vec == "NC/1") | all(ec_vec == "NC/1B")) {
    out <- as.character(NA)
    # If there are one or more NC results and all other test outcomes are NC/1B, the MSPE is NC.
  } else if (all(ec_vec %in% c("NC", "NC/1B"))) {
    out <- "NC"
  } else {
    # Create logical vectors to determine whether values should be included
    # in the GHS classification scheme
    use_val <- vector(mode = "logical", length = length(ec_vec))
    # NC/1 test results were completely excluded from the assessment
    use_val[ec_vec == "NC/1"] <- F
    # Positive test results with a POS outcome (i.e. without an available DSA1+
    # value) are included when determining the position of the median
    use_val[ec_vec %in% c("1B", "1B+", "POS", "1A-", "1A")] <- T
    # Assuming the MSPE method follows MLLP method for filtering negative results
    use_val[ec_vec %in% c("NC", "NC/1B") & (is.na(dsa_vec) | is.na(pos_med))] <- F
    use_val[ec_vec %in% c("NC", "NC/1B") & dsa_vec < pos_med] <- F
    use_val[ec_vec %in% c("NC", "NC/1B") & dsa_vec >= pos_med] <- T
    
    # Subset the values for evaluation
    for_mspe <- for_median[use_val]
    n_mspe <- length(for_mspe)
    
    # Label whether the values need to be evaluated for equal 1A and 1B
    check_equal <- !is.na(pos_med) & any(ec_vec == "NC/1B") & all(ec_vec != "NC")
    
    # If there are no values left to evaluate, return NA
    if (n_mspe == 0) {
      out <- as.character(NA)
      # out <- "Not applicable"
      # If only one value, record the value
    } else if (n_mspe == 1) {
      out <- for_mspe
    } else if (check_equal) {
      # If there are one or more positive results in addition to one or more
      # NC/1B results, but there is no clear NC result, the median DSA1+ of the
      # positive results with numerical values is taken as the MSPE. However,
      # in all of these cases in which the number of 1A (incl. 1A-) study
      # results equals that of the 1B (incl. 1B+) results, the MSPE is POS.
      
      class_1a <- sum(ec_vec %in% c("1A-", "1A") & !is.na(dsa1_vec))
      class_1b <- sum(ec_vec %in% c("1B", "1B+") & !is.na(dsa1_vec))
      
      if (class_1a == class_1b) {
        out <- "POS"
      } else {
        for_mspe <- na.omit(dsa1_vec)
        val_middle <- get_median(for_mspe)
        if (length(val_middle) == 1) {
          out <- val_middle
        } else if (length(val_middle) == 2) {
          out <- mspe_logic(val_middle)
        }
      }
    } else {
      val_middle <- get_median(for_mspe)
      if (length(val_middle) == 1) {
        out <- val_middle
      } else if (length(val_middle) == 2) {
        out <- mspe_logic(val_middle)
      }
    }
  }
  cats <- mspe_cat(out)
  out <- c(MSPE = out, cats)
  return(data.frame(t(out)))
}

#=================#
# Function to derive the MSPE scores and corresponding GHS classes
#-----------------#
# `dt` = tibble
# `dsa_col` = Name of the column containing numeric DSAs
# `dsa1_col` = Name of the column containing numeric DSA1+
# `ec_col` = Name of the column containing the individual extrapolated classes
# `group_col` = Name of the column with group identifiers (usually chemical identifier)
#=================#
mspe <- function(dt, dsa_col, dsa1_col, ec_col, group_col = NULL) {
  dt %>%
    group_by({{ group_col }}) %>%
    summarize(mspe_score(
      dsa_vec = {{ dsa_col }},
      dsa1_vec = {{ dsa1_col }},
      ec_vec = {{ ec_col }}
    )) %>%
    ungroup()
}

# OVERALL WEIGHT OF EVIDENCE ----
#=================#
# Derives GHS classifications for all 3 methods
#-----------------#
# `dt` = tibble
# `call_col` = Name of the column containing active/inactive calls
# `conc_col` = Name of the column containing numeric concentrations
# `dsa_col` = Name of the column containing numeric DSAs
# `dsa1_col` = Name of the column containing numeric DSA1+
# `group_col` = Name of the column with group identifiers (usually chemical identifier)
# `inactive_name` = The string or value in `call_col` corresponding to inactive calls
# `active_name` = The string or value in `call_col` corresponding to active calls
#=================#
hppt_ghs_class <- function(dt, call_col, conc_col, dsa_col, dsa1_col,
                           group_col = NULL, inactive_name = "Inactive", active_name = "Active") {
  ec_indiv <- dt %>%
    group_by({{ group_col }}) %>%
    hppt_woe_ec_indiv(
      call_col = {{ call_col }},
      conc_col = {{ conc_col }},
      dsa_col = {{ dsa_col }},
      dsa1_col = {{ dsa1_col }},
      group_col = {{ group_col }},
      inactive_name = inactive_name,
      active_name = active_name
    )
  
  woe_class <- hppt_woe_class(
    dt = ec_indiv,
    group_col = {{ group_col }},
    indiv_woe_score_col = woe_score
  )
  
  m_class <- ec_indiv %>%
    group_by({{ group_col }}) %>%
    summarize(
      mllp_score(
        dsa_vec = {{ dsa_col }},
        dsa1_vec = {{ dsa1_col }},
        ec_vec = ec
      ),
      mspe_score(
        dsa_vec = {{ dsa_col }},
        dsa1_vec = {{ dsa1_col }},
        ec_vec = ec
      )
    )
  
  by_col <- as_label(enquo(group_col))
  out <- full_join(woe_class, m_class, by = by_col)
  out <- list(
    ec_indiv = ec_indiv,
    overall_classes = out
  )
  return(out)
}

#=================#
# Derives overall ghs classifications
#-----------------#
# `hppt_ghs_class_list` = list of length 2, returned from `hppt_ghs_class`
# `group_col` = Name of the column with group identifiers (usually chemical identifier)
#=================#
hppt_overall_classification <- function(hppt_ghs_class_list, group_col) {
  # Convert column names to lowercase
  names(hppt_ghs_class_list$overall_classes) <- tolower(names(hppt_ghs_class_list$overall_classes))
  group_col <- as_label(enquo(group_col))
  # For each substance, count the number of tests and tally the 
  # extrapolated classifications
  overall_classes <- hppt_ghs_class_list$ec_indiv %>%
    group_by(across(all_of(group_col))) %>%
    mutate(N = n()) %>%
    group_by(across(all_of(group_col)), N, ec) %>%
    summarize(n_class = n(), .groups = "keep") %>%
    ungroup() %>%
    pivot_wider(names_from = ec, values_from = n_class, values_fill = 0) %>%
    full_join(hppt_ghs_class_list$overall_classes, by = group_col)
  
  # If a substance has the same classification for the three methods, that
  # classification is set as the overall classification. Otherwise, no
  # overall classification is defined for the substance.
  ctype <- paste("ghs", c("bin", "sub", "border"), sep = "_")
  
  for (i in ctype) {
    coltmp <- grep(i, names(overall_classes), value = T)
    overall_classes <- overall_classes %>%
      rowwise() %>%
      mutate_at(coltmp, list(~ifelse(. == "Not applicable", NA, .))) %>%
      mutate(
        tmp_list = list(c(!!!syms(coltmp))),
        tmp_cname = case_when(
          all(is.na(tmp_list)) ~ as.character(NA),
          length(unique(na.omit(tmp_list))) == 1 ~ na.omit(tmp_list)[1],
          T ~ as.character(NA)
        )
      ) %>%
      select(-tmp_list) %>%
      rename_with(~ paste0("overall_", i), tmp_cname) %>%
      ungroup()
  }
  
  out <- overall_classes %>%
    select(all_of(group_col),
           starts_with("overall_ghs"),
           mllp_value_bin = mllp_bin,
           mllp_value_sub = mllp_sub,
           mllp_ghs_bin, mllp_ghs_sub, mllp_ghs_border,
           mspe_value = mspe,
           mspe_ghs_bin, mspe_ghs_sub, mspe_ghs_border,
           woe_value = overall_woe_score,
           woe_ghs_bin, woe_ghs_sub, woe_ghs_border,
           total_tests = N,
           levels(hppt_ghs_class_list$ec_indiv$ec)
    )
  
  return(out)
}

#=================#
# Resolves discordant GHS sub and GHS border outcomes
#-----------------#
# `ec_indiv` = tibble output from `hppt_ghs_class()` containing individual 
#    extrapolated classifications
# `repro_dsa1` = reproducibility tibble output from `hppt_repro()` for DSA1+
# `repro_dsa05` = reproducibility tibble output from `hppt_repro()` for DSA5%
# `ghs_sub` = logical, whether to resolve GHS sub outcomes
# `ghs_border` = logical, whether to resolve GHS border outcomes
#=================#
hppt_resolve_overall <- function(dsa1_overall = NULL, dsa05_overall = NULL, ghs_sub = T, ghs_border = T, group_col) {
  doDSA1 <- !is.null(dsa1_overall)
  doDSA05 <- !is.null(dsa05_overall)
  
  if (ghs_sub) {
    sub_cols <- c("woe_ghs_sub", "mllp_ghs_sub", "mspe_ghs_sub")
    if (doDSA05) {
      dsa05_discord <- apply(dsa05_overall[sub_cols], 1, function(x) length(unique(na.omit(x))) > 1)
      dsa05_1a <- apply(dsa05_overall[c("1A", "1A-")], 1, function(x) any(x > 0))
      
      dsa05_overall[dsa05_discord & dsa05_1a,"overall_ghs_sub"] <- "1A"
    }
    
    if (doDSA1) {
      dsa1_discord <- apply(dsa1_overall[sub_cols], 1, function(x) length(unique(na.omit(x))) > 1)
      dsa1_1a <- apply(dsa1_overall[c("1A", "1A-")], 1, function(x) any(x > 0))
      
      dsa1_overall[dsa1_discord & dsa1_1a,"overall_ghs_sub"] <- "1A"
      
      if (doDSA05) {
        dsa1_discord_05 <- dsa1_discord & !dsa1_1a
        if (any(dsa1_discord_05)) {
          idx <- which(dsa1_discord_05)
          for (i in idx) {
            newOA <- dsa05_overall %>% filter(if_all(group_col, ~ . == i)) %>% pull(overall_ghs_sub)
            print(newOA)
            if (!is.na(newOA)) {
              dsa1_overall[i,"overall_ghs_sub"] <- newOA
            }
          }
        }
      }
      
    }
  }
  
  if (ghs_border) {
    border_cols <- c("woe_ghs_border", "mllp_ghs_border", "mspe_ghs_border")
    if (doDSA05) {
      dsa05_overall <- dsa05_overall %>%
        rowwise() %>%
        mutate(
          tmp_list = list(c(!!!syms(border_cols))),
          tmp_border = length(unique(na.omit(tmp_list))),
          overall_ghs_border = case_when(
            tmp_border <= 1 ~ overall_ghs_border,
            tmp_border == 3 ~ case_when(
              all(c("1A", "1", "1B") %in% tmp_list) ~ "1",
              all(c("1", "1B", "NC/1B") %in% tmp_list) ~ "1B",
              all(c("1B", "NC/1B", "NC") %in% tmp_list) ~ "NC/1B"
            ),
            tmp_border == 2 ~ case_when(
              all(c("1A", "1") %in% tmp_list) ~ "1A",
              all(c("1A", "1B") %in% tmp_list) ~ "1",
              all(c("1", "1B") %in% tmp_list) ~ "1B",
              all(c("1", "NC/1B") %in% tmp_list) ~ "1B",
              all(c("1B", "NC/1B") %in% tmp_list) ~ "1B",
              all(c("1B", "NC") %in% tmp_list) ~ "NC/1B",
              all(c("NC/1B", "NC") %in% tmp_list) ~ "NC"
            )
          )
        ) %>%
        ungroup() %>%
        select(-tmp_list, -tmp_border)
    }
    
    if (doDSA1) {
      dsa1_overall <- dsa1_overall %>%
        rowwise() %>%
        mutate(
          tmp_list = list(c(!!!syms(border_cols))),
          tmp_border = length(unique(na.omit(tmp_list))),
          overall_ghs_border = case_when(
            tmp_border <= 1 ~ overall_ghs_border,
            tmp_border == 3 ~ case_when(
              all(c("1A", "1", "1B") %in% tmp_list) ~ "1",
              all(c("1", "1B", "NC/1B") %in% tmp_list) ~ "1B",
              all(c("1B", "NC/1B", "NC") %in% tmp_list) ~ "NC/1B"
            ),
            tmp_border == 2 ~ case_when(
              all(c("1A", "1") %in% tmp_list) ~ "1A",
              all(c("1A", "1B") %in% tmp_list) ~ "1",
              all(c("1", "1B") %in% tmp_list) ~ "1B",
              all(c("1", "NC/1B") %in% tmp_list) ~ "1B",
              all(c("1B", "NC/1B") %in% tmp_list) ~ "1B",
              all(c("1B", "NC") %in% tmp_list) ~ "NC/1B",
              all(c("NC/1B", "NC") %in% tmp_list) ~ "NC"
            )
          )
        ) %>%
        ungroup() %>%
        select(-tmp_list, -tmp_border)
    }
  }
  
  return(list(dsa1_overall = dsa1_overall, dsa05_overall = dsa05_overall))
}

#=================#
# Derives reproducibility for GHS_BIN and GHS_SUB. 
#-----------------#
# `hppt_ghs_table` = table with overall GHS classifications, returned from `hppt_overall_classification`
#=================#
hppt_repro <- function(hppt_ghs_table, group_col) {
  # Reproducibility is calculated for ghs_bin and ghs_sub. Reproducibility of 
  # GHS_BIN is the fraction of all HPPT results for a substance with an
  # unambiguous classification of 1 or NC that is equal to the overall 
  # binary classification. Reproducibility of GHS_SUB is the fraction of 
  # all HPPT results for a substance with an unambiguous classification (1A, 1B, NC)
  # that is equal to the overall sub classification.
  
  # GHS BIN
  hppt_ghs_table$n_bin <- rowSums(hppt_ghs_table[,c("NC", "1B", "1B+", "POS","1A-", "1A")], na.rm = T)
  bin1 <- which(hppt_ghs_table$overall_ghs_bin == "1")
  bin0 <- which(hppt_ghs_table$overall_ghs_bin == "NC")
  
  hppt_ghs_table$repro_ghs_bin <- NA
  hppt_ghs_table$repro_ghs_bin[bin1] <- 100 * rowSums(hppt_ghs_table[bin1, c("1B", "1B+", "POS","1A-", "1A")])/hppt_ghs_table[bin1,"n_bin", drop = T]
  hppt_ghs_table$repro_ghs_bin[bin0] <- 100 * (hppt_ghs_table[bin0, "NC", drop = T]/hppt_ghs_table[bin0, "n_bin", drop = T])
  
  # GHS SUB
  sub1a <- which(hppt_ghs_table$overall_ghs_sub == "1A")
  sub1b <- which(hppt_ghs_table$overall_ghs_sub == "1B")
  subnc <- which(hppt_ghs_table$overall_ghs_sub == "NC")
  
  hppt_ghs_table$n_sub <- rowSums(hppt_ghs_table[,c("NC", "1B", "1B+","1A-", "1A")], na.rm = T)
  hppt_ghs_table$n_sub[sub1a] <- hppt_ghs_table$n_sub[sub1a] + hppt_ghs_table[["NC/1B"]][sub1a]
  
  hppt_ghs_table$repro_ghs_sub <- NA
  hppt_ghs_table$repro_ghs_sub[sub1a] <- 100 * rowSums(hppt_ghs_table[sub1a, c("1A-", "1A")])/hppt_ghs_table[sub1a,"n_sub", drop = T]
  hppt_ghs_table$repro_ghs_sub[sub1b] <- 100 * rowSums(hppt_ghs_table[sub1b, c("1B+", "1B")])/hppt_ghs_table[sub1b,"n_sub", drop = T]
  hppt_ghs_table$repro_ghs_sub[subnc] <- 100 * (hppt_ghs_table[subnc, "NC", drop = T]/hppt_ghs_table[subnc,"n_sub", drop = T])
  
  hppt_ghs_table %>%
    select(
      {{ group_col }},
      starts_with("overall_ghs"),
      starts_with("repro_"),
      starts_with("mllp_"),
      starts_with("mspe_"),
      starts_with("woe_"),
      total_tests,
      total_tests_repro_bin = n_bin,
      total_tests_repro_sub = n_sub,
      all_of(c("NC", "NC/1B", "NC/1", "1B", "1B+", "POS","1A-", "1A"))
    )
}