# R Code for the Synthesis and Processing of UKPDS-OM2 Simulation Results 
# Created: 04/01/18; Last Modified: 11/18/18

# Introduction & Rationale ------------------------------------------------

# NOTE 111818: The code now detects the path where the script is located, eliminating 
# the need for the user to change this manually upon downloading the script for the 
# first time.
# 
# The intent of this script is to automate the processing of simulation results generated
# by the UKPDS-OM2. Although the necessary transition probabilities can in principle be
# derived manually (i.e., in MS Excel), given the large number of simulations being run,
# this is not really a viable approach.

# It should be noted that because of the mass of data considered here, the task is
# effectively divided in half. That is, we process 32 of the 64 UKPDS-OM2 simulation
# worksheets at a time, only integrating the two sets of results at the end.

# NOTE 090818: Streamlined and annotated code.

# Initialization ----------------------------------------------------------

# The next line of code clears the variable list, if required.
rm(list=ls())

# Call required libraries
library(rvest); library(dplyr); library(stringr); library(tidyr); library(httr)
library(gsubfn); library(magrittr); library(purrr); library(reshape2); library(readxl)
library(data.table); library(here)

Model_Path <- here()
# String for date last modified
LM <- "_042019"
# Filename for output
Filename <- "UKPDS_OM2_Results_Processing"
# Paths for output
RDA <- paste0(Model_Path, "/R_Objects/")
UKPDS_OM2 <- paste0(Model_Path, "/UKPDS_OM2/")

Outputs_Path_A = paste0(UKPDS_OM2, "Outputs/OutputA/")
Outputs_Path_B = paste0(UKPDS_OM2, "Outputs/OutputB/")

# Move output to appropriate folders --------------------------------------

# By default, the UKPDS-OM2 saves simulation results in the same place as the
# input sheets. We'd like to move them to a secondary location before 
# processing them.

# Here is where the files initially are.
parent.folder <- paste0(UKPDS_OM2, "Input_Sheets/")

# Compile a list of all files in the parent folder that have a "1" or "2" in 
# their name, followed by two digits, followed by " Outputs". This reflects
# the approach described in the Introduction whereby we work with half the
# simulation data at a time.
files_A <- list.files(path = parent.folder, full.names = T, recursive = T, 
                    include.dirs = T, pattern = "1\\d{2} Outputs|2\\d{2} Outputs")
# Now we create new "artificial" file pathways that indicate where we'd like
# to put the files. The function BASELINE strips out the actual name of each
# file (as distinct from its location).
newnames_A <- paste0(UKPDS_OM2, "Outputs/OutputA/", basename(files_A))

# We do the same thing with the second set of 32 workbooks.
files_B <- list.files(path = parent.folder, full.names = T, recursive = T, 
                      include.dirs = T, pattern = "3\\d{2} Outputs|4\\d{2} Outputs")
newnames_B <- paste0(UKPDS_OM2, "Outputs/OutputB/", basename(files_B))

# Now we move the files by effectively renaming them.
# https://stackoverflow.com/questions/37551587/copying-specific-files-from-multiple-sub-directories-into-a-single-folder-in-r
mapply(file.rename, from=files_A, to=newnames_A)
mapply(file.rename, from=files_B, to=newnames_B)

# Set up table of transition probabilities --------------------------------

Gender_Comb = c("Male", "Female")
Ethnicity_Comb = c("Caucasian","Afro-Caribbean","Asian-Indian")
Age_Comb = as.character(seq(1:69)+26)
Duration_Comb = as.character(seq(1:70))
Adhere_Comb = c("Adherent", "Non-Adherent")

# Now we set up the table of transition probabilities. We start by explicitly listing all
# possible combinations of each individual factor in which we are interested.
Factors <- list(Gender = Gender_Comb, Ethnicity = Ethnicity_Comb,
                Age = Age_Comb, Duration = Duration_Comb,
                AD_LTPA_P1 = Adhere_Comb, AD_LTPA_P2 = Adhere_Comb, 
                AD_DIET_P1 = Adhere_Comb, AD_DIET_P2 = Adhere_Comb,
                AD_MEDS_P1 = Adhere_Comb, AD_MEDS_P2 = Adhere_Comb)
Factors2 <- list(Gender = Gender_Comb, Ethnicity = Ethnicity_Comb,
                 Age = Age_Comb)

# We also produce labels for each column.
Headers <- c("Gender", "Ethnicity", "Age", "Duration", "Per_1_Adherence_LTPA", 
             "Per_2_Adherence_LTPA", "Per_1_Adherence_Diet", "Per_2_Adherence_Diet",
             "Per_1_Adherence_Medication", "Per_2_Adherence_Medication")
Headers2 <- c("Ethnicity","Gender","Age")
Headers3 <- setdiff(Headers, c(Headers2, "Duration"))

# The remarkable function EXPAND.GRID now generates a dataframe, the rows of which include
# all possible combinations of the factors listed above.
TP <- expand.grid(Factors, stringsAsFactors = FALSE)
# Apply the column labels produced above.
colnames(TP) <- Headers

# 102618: I found an error here, whereby data was not merged properly because of how the
# UKPDS-OM2 results were sorted. In particular, the data appears to have been sorted on
# character values (i.e., alphabetically), whereas a custom sort was applied to UKPDS-OM2
# output. Thus, for example, the UKPDS-OM2 input sheets associated the first 69 records
# with Caucasian males, whereas the code below associated these observations with Afro-
# Caribbean Females. To address the issue, we ensured UKPDS_Extracts was constructed with
# strings set as factors, so that they would ultimately be arranged in the same order as
# they appear in Gender_Comb and Ethnicity_Comb. We then converted them back to strings
# at the end to avoid errors emerging later in the code.
UKPDS_Extracts <- expand.grid(Ethnicity_Comb, Gender_Comb, Age_Comb, stringsAsFactors = T)
colnames(UKPDS_Extracts) <- Headers2
UKPDS_Extracts <- UKPDS_Extracts %>% arrange(Gender, Ethnicity, Age)
UKPDS_Extracts[1:3] <- sapply(UKPDS_Extracts[1:3], as.character)

Combinations <- expand.grid(Adhere_Comb, Adhere_Comb, Adhere_Comb, Adhere_Comb, Adhere_Comb,
                            Adhere_Comb)
colnames(Combinations) <- Headers3
Combinations <- Combinations %>% 
  arrange(Per_1_Adherence_LTPA, Per_2_Adherence_LTPA, Per_1_Adherence_Diet, 
          Per_2_Adherence_Diet, Per_1_Adherence_Medication, 
          Per_2_Adherence_Medication)

List_Combos_A <- vector("list", length(list.files(path = Outputs_Path_A, pattern = "*.xlsx")))
List_Combos_B <- vector("list", length(list.files(path = Outputs_Path_B, pattern = "*.xlsx")))

for (i in 1:length(list.files(path = Outputs_Path_A, pattern = "*.xlsx"))){
  List_Combos_A[[i]] <- Combinations[i,]
  List_Combos_B[[i]] <- Combinations[i+32,]
  # https://stackoverflow.com/questions/11121385/repeat-rows-of-a-data-frame/11121463
  # https://stackoverflow.com/questions/15143829/repeat-the-values-of-a-row-in-matrix-n-number-of-times
  List_Combos_A[[i]] <- 
    List_Combos_A[[i]][rep(seq_len(nrow(List_Combos_A[[i]])), 
                         each=length(Gender_Comb)*length(Ethnicity_Comb)*length(Age_Comb)*
                           length(Duration_Comb)),]
  List_Combos_B[[i]] <- 
    List_Combos_B[[i]][rep(seq_len(nrow(List_Combos_B[[i]])), 
                           each=length(Gender_Comb)*length(Ethnicity_Comb)*length(Age_Comb)*
                             length(Duration_Comb)),]
}

T2DM_Duration <- paste(seq(1:70)); Extract_Headers <- c(Headers2, T2DM_Duration)

# Import Data from UKPDS-OM2 Output (Part A) ---------------------------------------

# https://stackoverflow.com/questions/5758084/loop-in-r-to-read-many-files
# https://stackoverflow.com/questions/2471188/converting-a-matrix-to-a-list
# Generate a list including the name of all files that end in ".xlsx" (i.e., basically
# everything in the folder). Setting StringsAsFactors to FALSE prevents the list
# entries from being classified as factors, which we do not want.
Output_A.00 <- as.list(data.frame(t(list.files(path = Outputs_Path_A, pattern = "*.xlsx")),
                                  stringsAsFactors = F))

# Create three new dataframes that will hold the results collected from the UKPDS-OM2
# simulations. These will be structured based on Output_A.00. In addition, we will
# strip out the redundant elements in each list so that we're left only with the 
# treatment combination identifiers (i.e., the three digit number that indicates what
# combination of health actions was taken by the individual).
Output4_A.00 <- Output3_A.00 <- Output2_A.00 <- Output_A.00 %>%
  lapply(., function(x) gsub("UKPDS_Outcomes_Model_","",x)) %>%
  lapply(., function(x) gsub(" Outputs.xlsx","",x))

# ... however, right now the identifiers are classified as VALUES, whereas we want
# to use them as LABELS for each list entry. So, we copy the former into the latter.
names(Output2_A.00) <- Output2_A.00; names(Output3_A.00) <- Output3_A.00;
names(Output4_A.00) <- Output4_A.00

# https://stackoverflow.com/questions/7201341/how-can-2-strings-be-concatenated
# https://stackoverflow.com/questions/38197705/read-multiple-xlsx-files-with-multiple-sheets-into-one-r-data-frame
# Now we fill in the templates by extracting cell ranges from the spreadsheets
# containing the results of the UKPDS-OM2 simulations:
# - Output2 contains data about T2DM's impact on the risk of all-cause mortality
# - Output3 contains data about T2DM's impact on expected utility
# - Output4 contains data about T2DM's impact on workplace absenteeism
for (i in 1:length(Output_A.00)){
  Output2_A.00[[i]] <- read_xlsx(path = paste0(Outputs_Path_A, Output_A.00[[i]]), 
                                 sheet = "All death", range = "B17:BS430", col_names = as.character(c(1:70)))
  Output3_A.00[[i]] <- read_xlsx(path = paste0(Outputs_Path_A, Output_A.00[[i]]), 
                                 sheet = "Outputs", range = "V17:CM430", col_names = as.character(c(1:70)))
  Output4_A.00[[i]] <- read_xlsx(path = paste0(Outputs_Path_A, Output_A.00[[i]]), 
                                 sheet = "Outputs", range = "FF17:HW430", col_names = as.character(c(1:70)))}

# We need to process the data, however, before it is usable.
Output2_A.00 <- Output2_A.00 %>%
  # First, we bind the information in each spreadsheet to UKPDS_Extracts, which 
  # identifies the ethnicity, gender, and age of each individual from the
  # original UKPDS-OM2 input sheet.
  lapply(., function(x) cbind(UKPDS_Extracts,x)) %>%
  # Now insert column headers. It took awhile to make this work, possibly because the
  # operation could not be completed within the body of the function itself (i.e., 
  # within the parentheses), requiring more sophisticated syntax with respect to
  # application of the LAPPLY function.
  lapply(., function(x) {colnames(x) <- Extract_Headers; x}) %>%
  # Next, we restructure each dataframe in such a way that all values are contained
  # in a single column - whereas right now each column indexes a different T2DM 
  # duration.
  lapply(., function(x) melt(x, id.vars=c("Ethnicity","Gender","Age"), 
                             variable.name = "Duration", value.name = "Probability")) %>%
  # https://stackoverflow.com/questions/38826565/list-rename-specific-data-frames-column-with-lapply
  # https://stackoverflow.com/questions/33567101/using-lapply-to-change-column-names-of-a-list-of-data-frames
  # Convert the age variable in each dataframe to an integer
  lapply(., function(x) {x[,3] <- as.integer(x[,3]); x}) %>%
  # Convert the duration variable in each dataframe to an integer
  lapply(., function(x) {x[,4] <- as.integer(x[,4]); x})

# We apply the similar steps to the two other lists. The only difference relates to
# the type of information the list was originally intended to hold.
Output3_A.00 <- Output3_A.00 %>%
  lapply(., function(x) cbind(UKPDS_Extracts,x)) %>%
  lapply(., function(x) {colnames(x) <- Extract_Headers; x}) %>%
  lapply(., function(x) melt(x, id.vars=c("Ethnicity","Gender","Age"), 
                             variable.name = "Duration", value.name = "Expected_Utility")) %>%
  lapply(., function(x) {x[,3] <- as.integer(x[,3]); x}) %>%
  lapply(., function(x) {x[,4] <- as.integer(x[,4]); x})

Output4_A.00 <- Output4_A.00 %>%
  lapply(., function(x) cbind(UKPDS_Extracts,x)) %>%
  lapply(., function(x) {colnames(x) <- Extract_Headers; x}) %>%
  lapply(., function(x) melt(x, id.vars=c("Ethnicity","Gender","Age"), 
                             variable.name = "Duration", value.name = "Annual_Absences")) %>%
  lapply(., function(x) {x[,3] <- as.integer(x[,3]); x}) %>%
  lapply(., function(x) {x[,4] <- as.integer(x[,4]); x})

# Having restructured the dataframes, we now carry out some additional processing.
# https://stackoverflow.com/questions/20473952/r-multiple-functions-into-lapply
Output2_A.01 <- Output2_A.00 %>%
  lapply(., function(x) {x <- x %>% 
    group_by(Ethnicity, Gender, Age) %>%
    # For the next steps, calculations are to be undertaken by group, where
    # each group is defined by ethnicity, gender, and starting age.
    arrange(Duration, .by_group =TRUE) %>%
    # EF_Survival (i.e., "Event-Free Survival") for any duration of T2DM is
    # calculated as 1 minus the sum of event rates in previous years and this
    # year. Again, this calculation is undertaken within each group.
    # https://stackoverflow.com/questions/27275363/r-cumsum-per-group-in-dplyr
    mutate(EF_Survival = 1-cumsum(Probability)) %>%
    # TO COME
    mutate(Transition = ifelse(Duration>1,
                  ifelse(is.nan(Probability/lag(EF_Survival,1)),0,
                         Probability/lag(EF_Survival,1)),Probability)) %>%
    ungroup(.); x})

# We don't need to carry out the same operations with the other two lists
# (since they don't contain probabilities), but "go through the motions" to
# ensure they are ordered the same way.
Output3_A.01 <- Output3_A.00 %>%
  lapply(., function(x) {x <- x %>% 
    group_by(Ethnicity, Gender, Age) %>%
    arrange(Duration, .by_group =TRUE) %>%
    ungroup(.); x})

Output4_A.01 <- Output4_A.00 %>%
  lapply(., function(x) {x <- x %>% 
    group_by(Ethnicity, Gender, Age) %>%
    arrange(Duration, .by_group =TRUE) %>%
    ungroup(.); x})

# Having undertaken all necessary calculations, we now join them into a single dataframe.
# Note the use of the MAPPLY function. This is required because we are now performing
# operations involving two sets of lists, and need a function that ensures these are
# always aligned as we progress through each pair (or trio!) of dataframes.
# https://stackoverflow.com/questions/20609484/combine-two-lists-of-dataframes-dataframe-by-dataframe
Output5_A.00 <- mapply(cbind, Output2_A.01, Output3_A.01, Output4_A.01, SIMPLIFY = FALSE)
# Now we do something similar to link the simulation results to each possible combination
# of health behaviour.
Output5_A.00 <- mapply(cbind, Output5_A.00, List_Combos_A, SIMPLIFY = FALSE)
# As with mortality, it's necessary to adjust utility to account for mortality within the
# cohort.
Output5_A.00 <- Output5_A.00 %>%
  lapply(., function (x) 
    {x <- x %>%
      # Get rid of columns that were carried over from Output3_A.01 and Output4_A.01,
      # but that contain duplicate information (i.e., ethnicity, gender, and age).
      subset(select = -c(8:11, 13:16)) %>%
      mutate(Adjusted_Utility = 
               ifelse(Duration>1,
                      # For T2DM durations > 1, if the calculation results in an error
                      # (presumably because everyone in the cohort is dead), set adjusted
                      # utility to zero. Otherwise, adjusted utility is expected utility
                      # divided by the average of the proportion of the original cohort
                      # surviving to this year and past this year.
                      ifelse(is.nan(Expected_Utility/((EF_Survival+lag(EF_Survival,1))/2)),
                             0, 
                             # 102718: I encountered an issue where people were choosing
                             # non-permissible courses of action in the optimal policy
                             # because their rewards for taking the prescribed courses of
                             # action were large negative values. Upon further 
                             # investigation, I determined this was because a single value
                             # in the UKPDS-OM2 output was negative, meaning the total
                             # reward would also be negative, no matter how much leisure
                             # and consumption the individual enjoyed. I addressed this
                             # by setting Adjusted Utility to 0 anytime the calculated
                             # value was found to be less than 0; this should be suffient
                             # to compel the action we want without detracting from the
                             # implication that T2DM has progressed so far that the
                             # individual's HRQoL is extremely low.
                             ifelse(Expected_Utility/((EF_Survival+lag(EF_Survival,1))/2)<0,
                                    0,
                                    Expected_Utility/((EF_Survival+lag(EF_Survival,1))/2))),
                      # For T2DM duration = 1, adjusted utility is expected utility
                      # dividined by the average of the proportion of the original cohort
                      # surviving to this year (i.e., 1) and past this year.
                      Expected_Utility/((1+EF_Survival)/2))); x})

# https://stackoverflow.com/questions/45607725/how-do-i-reorder-columns-for-all-data-frames-in-a-list-in-r
# Rearrange some columns for ease of comprehension.
Output5_A.00 <- lapply(Output5_A.00, FUN = function(x){x[,c(1:2, 10:15, 3:9, 16)]})
# Convert the first 10 columns within each dataframe to characters.
Output5_A.00 <- lapply(Output5_A.00, FUN = function(x)
  {x[1:10] <- sapply(x[1:10], as.character); x})
# Note that the following two lines, which I attempted to apply first, did not work
# (Error in Output5_A.00[[x]] : invalid subscript type 'list').
# Output5_A.00 <- lapply(Output5_A.00, FUN = function(x)
#   {Output5_A.00[[x]][1:10] <- sapply(Output5_A.00[[x]][1:10], as.character); x})

# Lump the (empty) transition probability matrix together with the construct we've
# produced in preparation for a grand merge that will bring everything together.
# https://stackoverflow.com/questions/33177118/append-a-data-frame-to-a-list
Table_A.00 <- c(list(TP), Output5_A.00)
# Now we carry out the merge, joining on every field except the data in which we're
# interested.
Output6_A.00 <- Reduce(function(x,y) merge(x,y, by = 
                                        c("Gender", "Ethnicity", "Age", "Duration", 
                                          "Per_1_Adherence_LTPA", "Per_2_Adherence_LTPA",
                                          "Per_1_Adherence_Diet", "Per_2_Adherence_Diet",
                                          "Per_1_Adherence_Medication",
                                          "Per_2_Adherence_Medication"), 
                                      all.x = TRUE), Table_A.00, accumulate = FALSE)

# Now to create column headers for this monstrosity. First, the prefix, which indicates
# what type of data we're working with.
CNames.x_A.00 <- matrix(c("Rate","Surv","Trans","EU","Abs","AU"))
# Second, the suffix, which indicates which treatment combination we are looking at.
# Note that we are only looking at 32 of these combinations at a time (192*6 + 10 =
# 202, which is the number of columns in Output6_A.00).
CNames.y_A.00 <- matrix(seq(1:length(list.files(path = Outputs_Path_A, pattern = "*.xlsx"))))
# Take all possible combinations of the two sets of strings.
CNames.01_A.00 <- expand.grid(CNames.x_A.00, CNames.y_A.00, stringsAsFactors = FALSE)
# Convert the integers in the second column of CNames.01_A.00 to strings, so that
# we can safely concatenate with the strings in the first column.
CNames.01_A.00$Var2 <- as.character(CNames.01_A.00$Var2)
# Now create a new columns that combines the strings in the first two columns.
CNames.01_A.00 <- CNames.01_A.00 %>%
  mutate(NewColNames = paste(Var1, Var2, sep = "_"))
# Append the 10 "identifier" columns that denote the characteristics of the
# individual and the actions they've taken with respect to their health.
NewColNames_A.00 <- c(Headers, CNames.01_A.00$NewColNames)
# Assign the new column labels.
colnames(Output6_A.00) <- NewColNames_A.00

# Bear in mind that there is exactly one value in each row for each data type.
# So, summing the values in each of the 32 columns corresponding to each type
# really just aggregates information rather than carrying out a meaningful
# operation.
Output6_A.00$Rate <- rowSums(Output6_A.00[,seq(11,ncol(Output6_A.00),6)], na.rm = TRUE)
Output6_A.00$EF_Survival <- rowSums(Output6_A.00[,seq(12,ncol(Output6_A.00),6)], na.rm = TRUE)
Output6_A.00$Probability <- rowSums(Output6_A.00[,seq(13,ncol(Output6_A.00),6)], na.rm = TRUE)
Output6_A.00$Expected_Utility <- rowSums(Output6_A.00[,seq(14,ncol(Output6_A.00),6)], na.rm = TRUE)
Output6_A.00$Annual_Absences <- rowSums(Output6_A.00[,seq(15,ncol(Output6_A.00),6)], na.rm = TRUE)
Output6_A.00$Adjusted_Utility <- rowSums(Output6_A.00[,seq(16,ncol(Output6_A.00),6)], na.rm = TRUE)

rm(List_Combos_A, Output_A.00, Output2_A.00, Output2_A.01, Output3_A.00, Output3_A.01,
   Output4_A.00, Output4_A.01, Output5_A.00, Table_A.00)

# Import Data from UKPDS-OM2 Output (Part B) ---------------------------------------

Output_B.00 <- as.list(data.frame(t(list.files(path = Outputs_Path_B, pattern = "*.xlsx")),
                                  stringsAsFactors = F))

Output4_B.00 <- Output3_B.00 <- Output2_B.00 <- Output_B.00 %>%
  lapply(., function(x) gsub("UKPDS_Outcomes_Model_","",x)) %>%
  lapply(., function(x) gsub(" Outputs.xlsx","",x))

names(Output2_B.00) <- Output2_B.00; names(Output3_B.00) <- Output3_B.00;
names(Output4_B.00) <- Output4_B.00

for (i in 1:length(Output_B.00)){
  Output2_B.00[[i]] <- read_xlsx(path = paste0(Outputs_Path_B, Output_B.00[[i]]), 
                                 sheet = "All death", range = "B17:BS430", col_names = as.character(c(1:70)))
  Output3_B.00[[i]] <- read_xlsx(path = paste0(Outputs_Path_B, Output_B.00[[i]]), 
                                 sheet = "Outputs", range = "V17:CM430", col_names = as.character(c(1:70)))
  Output4_B.00[[i]] <- read_xlsx(path = paste0(Outputs_Path_B, Output_B.00[[i]]), 
                                 sheet = "Outputs", range = "FF17:HW430", col_names = as.character(c(1:70)))}

Output2_B.00 <- Output2_B.00 %>%
  lapply(., function(x) cbind(UKPDS_Extracts,x)) %>%
  lapply(., function(x) {colnames(x) <- Extract_Headers; x}) %>%
  lapply(., function(x) melt(x, id.vars=c("Ethnicity","Gender","Age"), 
                             variable.name = "Duration", value.name = "Probability")) %>%
  lapply(., function(x) {x[,3] <- as.integer(x[,3]); x}) %>%
  lapply(., function(x) {x[,4] <- as.integer(x[,4]); x})

Output3_B.00 <- Output3_B.00 %>%
  lapply(., function(x) cbind(UKPDS_Extracts,x)) %>%
  lapply(., function(x) {colnames(x) <- Extract_Headers; x}) %>%
  lapply(., function(x) melt(x, id.vars=c("Ethnicity","Gender","Age"), 
                             variable.name = "Duration", value.name = "Expected_Utility")) %>%
  lapply(., function(x) {x[,3] <- as.integer(x[,3]); x}) %>%
  lapply(., function(x) {x[,4] <- as.integer(x[,4]); x})

Output4_B.00 <- Output4_B.00 %>%
  lapply(., function(x) cbind(UKPDS_Extracts,x)) %>%
  lapply(., function(x) {colnames(x) <- Extract_Headers; x}) %>%
  lapply(., function(x) melt(x, id.vars=c("Ethnicity","Gender","Age"), 
                             variable.name = "Duration", value.name = "Annual_Absences")) %>%
  lapply(., function(x) {x[,3] <- as.integer(x[,3]); x}) %>%
  lapply(., function(x) {x[,4] <- as.integer(x[,4]); x})

Output2_B.01 <- Output2_B.00 %>%
  lapply(., function(x) {x <- x %>% 
    group_by(Ethnicity, Gender, Age) %>%
    arrange(Duration, .by_group =TRUE) %>%
    mutate(EF_Survival = 1-cumsum(Probability)) %>%
    mutate(Transition = ifelse(Duration>1,
                               ifelse(is.nan(Probability/lag(EF_Survival,1)),0,
                                      Probability/lag(EF_Survival,1)),Probability)) %>%
    ungroup(.); x})

Output3_B.01 <- Output3_B.00 %>%
  lapply(., function(x) {x <- x %>% 
    group_by(Ethnicity, Gender, Age) %>%
    arrange(Duration, .by_group =TRUE) %>%
    ungroup(.); x})

Output4_B.01 <- Output4_B.00 %>%
  lapply(., function(x) {x <- x %>% 
    group_by(Ethnicity, Gender, Age) %>%
    arrange(Duration, .by_group =TRUE) %>%
    ungroup(.); x})

Output5_B.00 <- mapply(cbind, Output2_B.01, Output3_B.01, Output4_B.01, SIMPLIFY = FALSE)
Output5_B.00 <- mapply(cbind, Output5_B.00, List_Combos_B, SIMPLIFY = FALSE)
Output5_B.00 <- Output5_B.00 %>%
  lapply(., function (x) 
  {x <- x %>%
    subset(select = -c(8:11, 13:16)) %>%
    mutate(Adjusted_Utility = 
             ifelse(Duration>1,
                    ifelse(is.nan(Expected_Utility/((EF_Survival+lag(EF_Survival,1))/2)),
                           0,
                           ifelse(Expected_Utility/((EF_Survival+lag(EF_Survival,1))/2)<0,
                                  0,
                                  Expected_Utility/((EF_Survival+lag(EF_Survival,1))/2))),
                    Expected_Utility/((1+EF_Survival)/2))); x})

Output5_B.00 <- lapply(Output5_B.00, FUN = function(x){x[,c(1:2, 10:15, 3:9, 16)]})
Output5_B.00 <- lapply(Output5_B.00, FUN = function(x)
{x[1:10] <- sapply(x[1:10], as.character); x})

Table_B.00 <- c(list(TP), Output5_B.00)
Output6_B.00 <- Reduce(function(x,y) merge(x,y, by = 
                                             c("Gender", "Ethnicity", "Age", "Duration", 
                                               "Per_1_Adherence_LTPA", "Per_2_Adherence_LTPA",
                                               "Per_1_Adherence_Diet", "Per_2_Adherence_Diet",
                                               "Per_1_Adherence_Medication",
                                               "Per_2_Adherence_Medication"), 
                                           all.x = TRUE), Table_B.00, accumulate = FALSE)

CNames.x_B.00 <- matrix(c("Rate","Surv","Trans","EU","Abs","AU"))
CNames.y_B.00 <- matrix(seq(1:length(list.files(path = Outputs_Path_B, pattern = "*.xlsx"))))
CNames.01_B.00 <- expand.grid(CNames.x_B.00, CNames.y_B.00, stringsAsFactors = FALSE)
CNames.01_B.00$Var2 <- as.character(CNames.01_B.00$Var2)
CNames.01_B.00 <- CNames.01_B.00 %>%
  mutate(NewColNames = paste(Var1, Var2, sep = "_"))
NewColNames_B.00 <- c(Headers, CNames.01_B.00$NewColNames)
colnames(Output6_B.00) <- NewColNames_B.00

Output6_B.00$Rate <- rowSums(Output6_B.00[,seq(11,ncol(Output6_B.00),6)], na.rm = TRUE)
Output6_B.00$EF_Survival <- rowSums(Output6_B.00[,seq(12,ncol(Output6_B.00),6)], na.rm = TRUE)
Output6_B.00$Probability <- rowSums(Output6_B.00[,seq(13,ncol(Output6_B.00),6)], na.rm = TRUE)
Output6_B.00$Expected_Utility <- rowSums(Output6_B.00[,seq(14,ncol(Output6_B.00),6)], na.rm = TRUE)
Output6_B.00$Annual_Absences <- rowSums(Output6_B.00[,seq(15,ncol(Output6_B.00),6)], na.rm = TRUE)
Output6_B.00$Adjusted_Utility <- rowSums(Output6_B.00[,seq(16,ncol(Output6_B.00),6)], na.rm = TRUE)

rm(List_Combos_B, Output_B.00, Output2_B.00, Output2_B.01, Output3_B.00, Output3_B.01,
   Output4_B.00, Output4_B.01, Output5_B.00, Table_B.00)

# Save results ------------------------------------------------------------

# Strip out everything but the essential elements.
Output6a <- subset(Output6_A.00, select = c(1:10, 203:208))
# Now save the file to the R_Objects folder.
save(Output6a, file = paste(RDA, Filename, LM, "_a", ".Rda", sep = ""))

Output6b <- subset(Output6_B.00, select = c(1:10, 203:208))
save(Output6b, file = paste(RDA, Filename, LM, "_b", ".Rda", sep = ""))

# Now we have everything we need, so we can clear the work environment. Before
# we do so, however, there are a handful of elements we want to retain. We
# now enumerate these.
Items_Retained <- c("Output6a", "Output6b", "LM", "Filename", "RDA")
# We can proceed to clear the workspace, targeting for elimination the set
# difference between all items currently found there and the ones we'd like to
# keep.
# https://stackoverflow.com/questions/6190051/how-can-i-remove-all-objects-but-one-from-the-workspace-in-r
rm(list=setdiff(ls(),Items_Retained))

# We want to retain these column names because we'll be using them again soon
# - after deleting the columns to which they currently belong.
Output6_colnames <- c("Rate", "EF_Survival", "Probability", "Expected_Utility",
                     "Annual_Absences", "Adjusted_Utility")

# Join the two halves of Output6 together ...
Output6 <- cbind(Output6a, Output6b)
# ... but strip away the second set of identifier columns, which are redundant.
Output6 <- subset(Output6, select = c(1:16, 27:32))
Output6 %<>%
  # Create a new set of columns that sums the values across the two halves of
  # Output 6. This works because for any given row and any given type of
  # information (i.e., those listed in "Output6_colnames" above), at most one
  # contains non-zero values ...
  mutate(Rate.F = Rate + Rate.1, EF_Survival.F = EF_Survival + EF_Survival.1,
         Probability.F = Probability + Probability.1,
         Expected_Utility.F = Expected_Utility + Expected_Utility.1,
         Annual_Absences.F = Annual_Absences + Annual_Absences.1,
         Adjusted_Utility.F = Adjusted_Utility + Adjusted_Utility.1) %>%
  # ... and once we've done this, we can get rid of the original columns.
  subset(., select = -c(11:22))
# Now let's rename these new columns appropriately, using the vector of column
# names we just stored.
Output6 %<>%
  rename("Rate" = "Rate.F", "EF_Survival" = "EF_Survival.F", "Probability" = 
           "Probability.F", "Expected_Utility" = "Expected_Utility.F",
         "Annual_Absences" = "Annual_Absences.F", "Adjusted_Utility" = 
           "Adjusted_Utility.F")

# We're done. Now we just need to save our results.
save(Output6, file = paste(RDA, Filename, LM, ".Rda", sep = ""))