---
title: "Report Canberra Distance"
output: word_document
params:
  distances: NA
  p_values: NA
---

```{r echo=FALSE, message=FALSE, warning=FALSE}

ccanberra <- function(dataset, formula, plot = TRUE, 
                      min_group_size = 3, method = "average", max_index_sample = NULL, automatic_encoding = FALSE, na_removal = FALSE, grouping_stat = 'mean') {
  
  if (!is.data.frame(dataset))
    stop("The input must be a data frame.")
  
  grouping_vars <- all.vars(formula)
  if (length(grouping_vars) == 0)
    stop("At least one grouping variable must be specified in the formula.")
  if (!all(grouping_vars %in% names(dataset)) && !("index" %in% grouping_vars))
    stop("Some grouping variables are not present in the dataset.")
  
  if (!("index" %in% grouping_vars) && !missing(method)) {
    message("When grouping variable is not index, we use all agglomeration methods")
  }
  
  if (!("index" %in% grouping_vars) && !missing(max_index_sample)) {
    message("max_index_sample is total when we specify grouping_vars")
  }
  
  if (("index" %in% grouping_vars) && !missing(grouping_stat)) {
    message("grouping_stat is only available with factors.")
  }
  
  if (grouping_stat != 'median' && grouping_stat != 'mean' && grouping_stat != 'SDS') {
    stop("grouping_stat must be 'median', 'mean' or 'SDS'")
  }
  
  if (automatic_encoding == TRUE) {
    dataset_factors <- sapply(dataset, is.factor)
    dataset[dataset_factors] <- lapply(dataset[dataset_factors], as.numeric)
  }
  
  # If the user specified "~index", use the individual mode.
  if ("index" %in% grouping_vars) {
    if (!("index" %in% names(dataset))) {
      message("Formula '~index' was used. In 'index' mode, 'min_group_size' is always 1.")
    }
    
    # In this case, grouping is performed for each row (i.e., each observation is its own group).
    # Predictors are all variables except for "index"
    # Perform missing values remotion on rows
    if (na_removal == TRUE) {
      dataset_imputed <- na.omit(dataset)
    } else {
      dataset_imputed <- dataset
    }
    
    if (!missing(max_index_sample)) {
      n_total <- nrow(dataset_imputed)
      if (n_total > max_index_sample) {
        message("Dataset of ", n_total, " rows. A random sampling of ", max_index_sample, " observations is performed.")
        set.seed(111)
        idx_sample <- sample(seq_len(n_total), max_index_sample)
        dataset_imputed <- dataset_imputed[idx_sample, ]
      }
    }
    
    # identify numeric columns
    numeric_cols <- sapply(dataset_imputed, is.numeric)
    
    # In this case, grouping is performed for each row (i.e., each observation is its own group).
    # Predictors are all variables except for "index".
    predictors <- setdiff(names(dataset_imputed)[numeric_cols], "index")
    data_for_dist <- as.matrix(dataset_imputed[, predictors])
    
    D <- dist(data_for_dist, method = 'canberra')
    
    if (plot) {
      hc <- hclust(D, method = method)
      plot(hc, main = "Cluster Dendrogram on index using ccanberra")
      (x <- identify(hc))
      print(hclust(D, method = method))
    }
    
    return(list(index = list(distances = as.matrix(D))))
  }
  
  dt <- as.data.frame(dataset)
  if (na_removal == TRUE) {
    dt <- na.omit(dt)
  } else {
    dt <- dt
  }
  
  result <- list()
  plot_list <- list()
  
  for (grouping_var in grouping_vars) {
    groups <- split(dt, dt[[grouping_var]])
    group_sizes <-  sapply(groups, nrow)
    valid_groups <- groups[group_sizes >= min_group_size]
    
    if (length(valid_groups) < 2) {
      warning(paste("Not enough valid groups for grouping variable:", grouping_var, "- skipping."))
      next
    }
    
    group_names <- names(valid_groups)
    n <- length(valid_groups)
    
    if (grouping_stat == 'mean') {
      
      means <-  lapply(valid_groups, function(dt_group) {
        num_cols <- dt_group[sapply(dt_group, is.numeric)]
        colMeans(num_cols)
      })
      
      distances <- matrix(0, nrow = n, ncol = n)
      rownames(distances) <- colnames(distances) <- group_names
      for (i in 1:n) {
        for (j in i:n) {
          if (i == j) next
          
          vec_i <- means[[i]]
          vec_j <- means[[j]]
          
          dissimilarity <- (sum(abs(vec_i - vec_j))) / sum(abs(vec_i) + abs(vec_j))
          
          distances[i, j] <- round(dissimilarity, digits = 7)
          distances[j, i] <- distances[i, j]
        }
      }
      
      if (plot) {
        dist_obj <- as.dist(distances)
        if (attr(dist_obj, "Size") > 2) {
          op <- par(mfrow = c(3,3))
          hc <- hclust(as.dist(dist_obj), method = 'ward.D')
          print(hc)
          hc1 <- hclust(as.dist(dist_obj), method = 'ward.D2')
          print(hc1[["labels"]])
          hc2 <- hclust(as.dist(dist_obj), method = 'single')
          hc3 <- hclust(as.dist(dist_obj), method = 'complete')
          hc4 <- hclust(as.dist(dist_obj), method = 'average')
          hc5 <- hclust(as.dist(dist_obj), method = 'mcquitty')
          hc6 <- hclust(as.dist(dist_obj), method = 'median')
          hc7 <- hclust(as.dist(dist_obj), method = 'centroid')
          plot(hc, main = " ")
          plot(hc1, main = " ")
          plot(hc2, main = " ")
          plot(hc3, main = " ")
          plot(hc4, main = " ")
          plot(hc5, main = " ")
          plot(hc6, main = " ")
          plot(hc7, main = " ")
          mtext(paste("Dendrograms on mean values of groups in", grouping_var, "with various agglomeration methods using ccanberra"), side = 3, line = -2, outer = TRUE, cex = 1, font = 2)
          par(mfrow = c(1,1))
        } else {
          message(paste("Skipping plot for", grouping_var, "not enough items to cluster"))
        }
      }
    } else if (grouping_stat == 'median') {
      
      medians <-  lapply(valid_groups, function(dt_group) {
        num_cols <- dt_group[sapply(dt_group, is.numeric)]
        colMedians(as.matrix(num_cols))
      })
      
      distances <- matrix(0, nrow = n, ncol = n)
      rownames(distances) <- colnames(distances) <- group_names
      for (i in 1:n) {
        for (j in 1:n) {
          if (i == j) next
          median_i <- medians[[i]]
          median_j <- medians[[j]]
          
          dissimilarity <- (sum(abs(median_i - median_j))) / sum(abs(median_i) + abs(median_j))
          
          distances[i, j] <- round(dissimilarity, digits = 7)
          distances[j, i] <- distances[i, j]
        }
      }
      
      if (plot) {
        dist_obj <- as.dist(distances)
        if (attr(dist_obj, "Size") > 2) {
          op <- par(mfrow = c(3,3))
          hc <- hclust(as.dist(dist_obj), method = 'ward.D')
          print(hc)
          hc1 <- hclust(as.dist(dist_obj), method = 'ward.D2')
          print(hc1[["labels"]])
          hc2 <- hclust(as.dist(dist_obj), method = 'single')
          hc3 <- hclust(as.dist(dist_obj), method = 'complete')
          hc4 <- hclust(as.dist(dist_obj), method = 'average')
          hc5 <- hclust(as.dist(dist_obj), method = 'mcquitty')
          hc6 <- hclust(as.dist(dist_obj), method = 'median')
          hc7 <- hclust(as.dist(dist_obj), method = 'centroid')
          plot(hc, main = " ")
          plot(hc1, main = " ")
          plot(hc2, main = " ")
          plot(hc3, main = " ")
          plot(hc4, main = " ")
          plot(hc5, main = " ")
          plot(hc6, main = " ")
          plot(hc7, main = " ")
          mtext(paste("Dendrograms on median values of groups in", grouping_var, "with various agglomeration methods using ccanberra"), side = 3, line = -2, outer = TRUE, cex = 1, font = 2)
          par(mfrow = c(1,1))
        } else {
          message(paste("Skipping plot for", grouping_var, "not enough items to cluster"))
        }
      }
    } else if (grouping_stat == 'SDS') {
      sds <-  lapply(valid_groups, function(dt_group) {
        num_cols <- dt_group[sapply(dt_group, is.numeric)]
        colSds(as.matrix(num_cols))
      })
      
      distances <- matrix(0, nrow = n, ncol = n)
      rownames(distances) <- colnames(distances) <- group_names
      for (i in 1:n) {
        for (j in 1:n) {
          if (i == j) next
          sds_i <- sds[[i]]
          sds_j <- sds[[j]]
          
          dissimilarity <- (sum(abs(sds_i - sds_j))) / sum(abs(sds_i) + abs(sds_j))
          
          distances[i, j] <- round(dissimilarity, digits = 7)
          distances[j, i] <- distances[i, j]
        }
      }
      
      if (plot) {
        dist_obj <- as.dist(distances)
        if (attr(dist_obj, "Size") > 2) {
          op <- par(mfrow = c(3,3))
          hc <- hclust(as.dist(dist_obj), method = 'ward.D')
          print(hc)
          hc1 <- hclust(as.dist(dist_obj), method = 'ward.D2')
          print(hc1[["labels"]])
          hc2 <- hclust(as.dist(dist_obj), method = 'single')
          hc3 <- hclust(as.dist(dist_obj), method = 'complete')
          hc4 <- hclust(as.dist(dist_obj), method = 'average')
          hc5 <- hclust(as.dist(dist_obj), method = 'mcquitty')
          hc6 <- hclust(as.dist(dist_obj), method = 'median')
          hc7 <- hclust(as.dist(dist_obj), method = 'centroid')
          plot(hc, main = " ")
          plot(hc1, main = " ")
          plot(hc2, main = " ")
          plot(hc3, main = " ")
          plot(hc4, main = " ")
          plot(hc5, main = " ")
          plot(hc6, main = " ")
          plot(hc7, main = " ")
          mtext(paste("Dendrograms on standard deviation values of groups in", grouping_var, "with various agglomeration methods using ccanberra"), side = 3, line = -2, outer = TRUE, cex = 1, font = 2)
          par(mfrow = c(1,1))
        } else {
          message(paste("Skipping plot for", grouping_var, "not enough items to cluster"))
        }
      }
      
    }
    result[[grouping_var]] <- list(distances = distances)
  }
  return(result)
}

pvaluesccanb <- function(dataset, formula, pvalue.method = "permutation", seed = NULL, min_group_size = 3, num_replicas = 1000, automatic_encoding = FALSE, na_removal = FALSE, grouping_stat = 'mean') {
  
  if (!is.data.frame(dataset)) {
    stop("The input must be a data frame.")
  }
  
  grouping_vars <- all.vars(formula)
  if (length(grouping_vars) == 0) {
    stop("At least one grouping variable must be specified in the formula.")
  }
  
  if (!all(grouping_vars %in% names(dataset)) && !identical(grouping_vars, "index")) {
    stop("Some grouping variables are not present in the dataset.")
  }
  
  if ("index" %in% grouping_vars && pvalue.method %in% c("bootstrap", "permutation")) {
    stop("p_values calculation not possible. '", pvalue.method, "' method does not make sense with 'index'")
  }
  
  result_list <- list()
  plot_list <- list()
  excluded_message <- list()
  
  for (idx in seq_along(grouping_vars)) {
    grouping_var <- grouping_vars[idx]
    
    # Canberra
    canberra_results <- ccanberra(dataset, as.formula(paste("~", grouping_var)), plot = FALSE, min_group_size = min_group_size, automatic_encoding = automatic_encoding, na_removal = na_removal, grouping_stat = grouping_stat)
    distances <- canberra_results[[grouping_var]]$distances
    
    n <- nrow(distances)
    
    null_distances_list <- list()
    
    if (!is.null(seed)) {
      set.seed(seed)
    }
    
    message(paste("Running", pvalue.method, "for", grouping_var, "..."))
    
    prev_p_values <- NULL
    actual_replicas <- 0
    
    for (k in 1:num_replicas) {
      actual_replicas <- k
      
      # Null data generation (Permutation or Bootstrap)
      if (pvalue.method == "permutation") {
        permuted_data <- dataset
        permuted_data[[grouping_var]] <- sample(permuted_data[[grouping_var]], replace = FALSE)
        
        permuted_results <- ccanberra(permuted_data,
                                      as.formula(paste("~", grouping_var)), plot = FALSE, min_group_size = min_group_size, automatic_encoding = automatic_encoding, na_removal = na_removal, grouping_stat = grouping_stat)
        
        if (!is.null(permuted_results) && !is.null(permuted_results[[grouping_var]])) {
          null_distances_list[[k]] <- permuted_results[[grouping_var]]$distances
        } else {
          null_distances_list[[k]] <- NULL
        }
        
      } else if (pvalue.method == "bootstrap") {
        # CORRECTION BUG
        bootstrap_sample <- sample(nrow(dataset), replace = TRUE)
        bootstrap_data <- dataset[bootstrap_sample, ] 
        
        bootstrap_results <- ccanberra(bootstrap_data,
                                       as.formula(paste("~", grouping_var)), plot = FALSE, min_group_size = min_group_size, automatic_encoding = automatic_encoding, na_removal = na_removal, grouping_stat = grouping_stat)
        
        if (!is.null(bootstrap_results) && !is.null(bootstrap_results[[grouping_var]])) {
          null_distances_list[[k]] <- bootstrap_results[[grouping_var]]$distances
        } else {
          null_distances_list[[k]] <- NULL
        }
      }
      
      # CHECK EARLY STOPPING 
      if (k >= 500 && k %% 500 == 0) {
        
        # Calculate pvalue matrix on metrics until now
        current_p_values <- matrix(NA, nrow = n, ncol = n)
        
        for (i in 1:n) {
          for (j in i:n) {
            if (i == j) next
            
            obs_dist <- distances[i, j]
            reps <- sapply(null_distances_list[1:k], function(m) {
              if (!is.null(m) && nrow(m) >= i && ncol(m) >= j && !is.na(m[i, j])) {
                return(m[i, j])
              } else {
                return(NA)
              }
            })
            
            valid_reps <- reps[!is.na(reps)]
            if (length(valid_reps) > 0) {
              current_p_values[i, j] <- mean(valid_reps >= obs_dist)
              current_p_values[j, i] <- current_p_values[i, j]
            }
          }
        }
        
        # If we have a previous matrix
        if (!is.null(prev_p_values)) {
          max_diff <- max(abs(current_p_values - prev_p_values), na.rm = TRUE)
          
          if (max_diff < 0.0001) {
            message(paste0("   -> Early stopping at replica ", k, 
                           ": max variation p-value = ", round(max_diff, 4), " (< ", 0.0001, ")"))
            break
          }
        }
        
        prev_p_values <- current_p_values
      }
    }
    
    p_values <- matrix(NA, nrow = n, ncol = n)
    rownames(p_values) <- colnames(p_values) <- rownames(distances)
    
    for (i in 1:n) {
      for (j in i:n) {
        if (i == j) next
        
        obs_dist <- distances[i, j]
        reps <- sapply(null_distances_list[1:actual_replicas], function(m) {
          if (!is.null(m) && nrow(m) >= i && ncol(m) >= j && !is.na(m[i, j])) {
            return(m[i, j])
          } else {
            return(NA)
          }
        })
        
        valid_reps <- reps[!is.na(reps)]
        if (length(valid_reps) == 0) {
          p_values[i, j] <- NA
        } else {
          p_values[i, j] <- round(mean(valid_reps >= obs_dist), digits = 7)
        }
        p_values[j, i] <- p_values[i, j]
      }
    }
    
    result_list[[grouping_var]] <- p_values
    
    excluded_groups <- canberra_results[[grouping_var]]$excluded_groups
    if (length(excluded_groups) > 0 && is.null(excluded_message[[grouping_var]])) {
      excluded_message[[grouping_var]] <- paste("Grouping variable", grouping_var,
                                                "- excluded groups due to insufficient size:",
                                                paste(excluded_groups, collapse = ", "))
      message(excluded_message[[grouping_var]])
    }
  }
  
  return(result_list)
}

distances <- params$distances  # Replace with your actual distances data
p_values <- params$p_values    # Replace with your actual p_values data

if (!is.null(distances) && !all(is.na(distances))) {
  cat(" --- Distances --- \n")
  print(distances)
} else {
  print("No distances available")
}

if (!is.null(p_values) && !all(is.na(p_values))) {
   cat(" --- P-values --- \n")
   print(p_values)
} else {
  print("No p_values available")
}
```

```{r echo=FALSE, fig.width=15, fig.height=10}
if (!is.null(distances) && length(distances) > 0) {
  
  processed_vars <- c()
  
  for (grouping_var in names(distances)) {
    
    if (grouping_var %in% processed_vars) next
    processed_vars <- c(processed_vars, grouping_var)
    
    current_item <- distances[[grouping_var]]
    dist_matrix <- current_item$distances
    
    if (is.null(dist_matrix)) next
    
    dist_obj <- as.dist(dist_matrix)
    
    if(attr(dist_obj, "Size") > 2) {
      cat(paste("\n\n### Dendrograms for the variable: ", grouping_var, "\n\n"))
      
      par(mfrow = c(3,3))
      hc <- hclust(dist_obj, method = 'ward.D')
      hc1 <- hclust(dist_obj, method = 'ward.D2')
      hc2 <- hclust(dist_obj, method = 'single')
      hc3 <- hclust(dist_obj, method = 'complete')
      hc4 <- hclust(dist_obj, method = 'average')
      hc5 <- hclust(dist_obj, method = 'mcquitty')
      hc6 <- hclust(dist_obj, method = 'median')
      hc7 <- hclust(dist_obj, method = 'centroid')
      plot(hc, main = " ")
      plot(hc1, main = " ")
      plot(hc2, main = " ")
      plot(hc3, main = " ")
      plot(hc4, main = " ")
      plot(hc5, main = " ")
      plot(hc6, main = " ")
      plot(hc7, main = " ")
      mtext(paste("Dendrograms of groups in", grouping_var, "with various agglomeration methods, with Canberra distance"), side = 3, line = -2, outer = TRUE, cex = 1, font = 2)
      par(mfrow = c(1,1))
      
      cat("\n**Labels**\n")
      print(hc1[['labels']])
      cat("\n")
    } else {
      message(paste("Skipping plot for", grouping_var, "not enough items to cluster"))
    }
  }
}
```