#' Test and Control Selector for Groups/Individuals, with Mixed Input Variables/Metrics.
#'
#' Randomly select test groups/individuals and create matching control
#' groups/individuals by using Euclidean distance on scaled numeric variables,
#' or with Gower's method for datasets with numeric and categorical variables.
#' This function can handle both numeric and categorical as well as just numeric
#' variables with Gower's methodology from cluster::daisy() function.
#'
#' The data frame must contain the group/individual labels in the first column
#' and the other variables must be in levels, in other words not scaled.
#'
#' @details In the case where duplicates arise in the Control, the function iterates
#' through the test control list until there are no duplicates in the Control.
#' In each iteration, it re-ranks the remaining possible control groups/individuals
#' and matches to the test on the lowest distance.
#'
#' You can supply a data frame of pre-selected test groups/individuals to the
#' parameter test_list and the function will provide you with a list of control
#' groups/individuals.
#'
#' @param df data frame of numeric, or mixed inputs. First column must have group/individuals names, 1 line per group/individuals.
#' @param n size of the test group, and matching control group. Defaults to 10. Will be ignored if df provide to the "test_list" parameter.
#' @param test_list df with one column named "TEST." This has a list of members in the current test. Defaults to NULL.
#' @return If the "n" parameter is used, the function outputs a data frame with a list of randomized test groups/individuals from the supplied df with matching control groups/individuals, a 1 to 1 match.
#' If a data frame is supplied to the "test_list" parameter, 1 to 1 matching control stores will be created for the groups/individuals in the "TEST" column supplied to the "test_list" parameter.
#' @examples
#' library(dplyr)
#' library(magrittr)
#' df <- datasets::USArrests %>% dplyr::mutate(state = base::row.names(datasets::USArrests)) %>%
#' base::cbind(datasets::state.division) %>%
#' dplyr::select(state, dplyr::everything())
#'
#' TEST_CONTROL_LIST <- TestContR::match_mixed(df, n = 15)
#' @importFrom magrittr %>%
#' @importFrom rlang .data
#' @export
##----PART #1---------------------------------------------------------
# CREATE A RANKED LIST OF MATCHES BASED ON DISTANCE.
# Libraries loaded in BUILD_METRICS.R script
# require(reshape2)
# require(tidyverse)
match_mixed <- function ( df, n = 10 , test_list = NULL ) {
# Prep for Distance: Convert column #1 to rownames and factor character variables
df <- as.data.frame(df)
df_scaled <- df[,-1] %>% dplyr::mutate_if( is.character, as.factor ) # Scaling happens in daisy()
#----Scale the Data and Build the Distant Matrix----
#----Convert column #1 to rownames----
DF_DIST <- cluster::daisy(df_scaled, stand = TRUE) # Scaling happens here for numeric and factor
attr(DF_DIST,"Labels") <- as.factor(df[,1]) # column and row names here
# Convert to Matrix
DF_RANK_BASE <- as.matrix(DF_DIST)
# Keep the full matrix for addressing duplicates: Force NA to diagonal
diag(DF_RANK_BASE) <- NA
#----Produce list of one to one distance Metric----
DF_RANK_BASE_1 <- reshape2::melt(DF_RANK_BASE)
names(DF_RANK_BASE_1) <- c("CONTROL","TEST","DIST_Q")
DF_DIST_FINAL <- DF_RANK_BASE_1 %>% stats::na.omit() %>%
dplyr::arrange(.data$TEST,.data$DIST_Q,.data$CONTROL)
##----PART #2----------------------------------------------------------
# RANDOMLY SELECT THE LIST/DF OF THE TEST AND CONTROL GROUPS
#set.seed(17)
if( is.null((test_list)) ) {
DF_TEST <- df %>% dplyr::sample_n(size = n) # Sample size of test
} else {
names(test_list) <- c("TEST")
DF_TEST <- as.data.frame(test_list['TEST'])
}
# Test and Control List
DF_DIST_REDUCED <- DF_DIST_FINAL %>% dplyr::filter(!.data$CONTROL %in% (DF_TEST[,1])) %>%
dplyr::filter(.data$TEST %in% (DF_TEST[,1]))
CONTROL_STR_LIST <- DF_DIST_REDUCED %>%
dplyr::group_by(.data$TEST) %>%
dplyr::mutate(DIST_RANK = dplyr::min_rank(.data$DIST_Q)) %>%
dplyr::filter(.data$DIST_RANK <= 1) %>%
dplyr::select(-.data$DIST_RANK) %>%
dplyr::ungroup() %>%
dplyr::mutate(GROUP = dplyr::row_number(.data$TEST))
# Create list of Dupes
DUPES_LIST <- CONTROL_STR_LIST %>% dplyr::group_by(.data$CONTROL) %>%
dplyr::summarise(control_cnt = n()) %>%
dplyr::filter(.data$control_cnt > 1)
# Run While loop over the list of duplicates, until no more dupes remain
i = 0
while (nrow(DUPES_LIST) > 0) {
# Count the number of iterations
i = i + 1
print(sprintf("The %sth de-duping iteration started", i))
# rank the duplicate control stores and keep the minimum rank
rank_dupes <- DUPES_LIST %>%
dplyr::inner_join(CONTROL_STR_LIST) %>%
dplyr::group_by(.data$CONTROL) %>%
dplyr::mutate(rank = dplyr::min_rank(.data$DIST_Q)) %>%
dplyr::filter(.data$rank > 1)
# Remove the duplicate from remaining distance list
DF_DIST_FINAL_TEMP <- DF_DIST_REDUCED %>% dplyr::anti_join(rank_dupes, by = "CONTROL")
# Remove the duplicate data from CONTROL_STR_LIST distance list
CONTROL_STR_LIST_TEMP <-CONTROL_STR_LIST %>% dplyr::left_join(rank_dupes)
CONTROL_STR_LIST_TEMP <- CONTROL_STR_LIST_TEMP %>%
dplyr::mutate(CONTROL = dplyr::if_else(is.na(rank) == TRUE, .data$CONTROL, NULL),
DIST_Q = dplyr::if_else(is.na(rank) == TRUE, .data$DIST_Q,NULL))
# select new minimum from the remaining list
TEST_DUPES_TEMP <- CONTROL_STR_LIST_TEMP %>% dplyr::filter(is.na(.data$DIST_Q)) %>% dplyr::select(.data$TEST)
CONT_DUPES_TEMP <- CONTROL_STR_LIST_TEMP %>% dplyr::filter(!is.na(.data$CONTROL)) %>% dplyr::select(.data$CONTROL)
DIST_REMAINING <- DF_DIST_FINAL_TEMP %>% dplyr::inner_join(TEST_DUPES_TEMP, by = 'TEST') %>%
dplyr::anti_join(CONT_DUPES_TEMP, by = 'CONTROL') %>%
dplyr::group_by(.data$TEST) %>%
dplyr::arrange(.data$TEST, .data$DIST_Q) %>%
dplyr::mutate(rank = dplyr::min_rank(.data$DIST_Q)) %>%
dplyr::filter(.data$rank == 1)
# Add new control to test stores with missing controls stores
CONTROL_STR_LIST <- CONTROL_STR_LIST_TEMP %>% dplyr::left_join(DIST_REMAINING, by = 'TEST') %>%
dplyr::mutate( CONTROL = dplyr::coalesce(.data$CONTROL.x, .data$CONTROL.y),
DIST_Q = dplyr::coalesce(.data$DIST_Q.x, .data$DIST_Q.y)) %>%
dplyr::select(.data$CONTROL, .data$TEST, .data$DIST_Q, .data$GROUP)
# re-move all test and control stores from the current dist df
DF_DIST_FINAL <- DF_DIST_FINAL_TEMP %>% dplyr::anti_join(CONTROL_STR_LIST, by = "CONTROL")
# re-build the Dupes_list
DUPES_LIST <- CONTROL_STR_LIST %>% dplyr::group_by(.data$CONTROL) %>%
dplyr::summarise(control_cnt = n()) %>%
dplyr::filter(.data$control_cnt > 1)
# ends when DUPES_LIST is nrow() = 0
print(sprintf("The %sth de-duping iteration complete.", i))
}
# Output list of Test and Controls
return(CONTROL_STR_LIST)
# assign( CONTROL_STR_LIST, paste0("Randomized Selection_seed_",rand_num), envir = .GlobalEnv #)
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.