CAdist <- function(df, nPC = NULL, graph = TRUE){

  #===============================================================================
  # GENERATE DISTANCE MATRIX WITH CORRESPONDENCE ANALYSiS (CA) (Fr: Analyse Factorielle des Correspondances)
  #
  # Authors : A.COULON
  # Last update : 23 october 2018
  #
  # Arguments:
  # df	      The ceramic contingence table
  # nPC       The number of principal component to keep
  # graph     Logical for print or not the plot of the CA
  #
  #===============================================================================

  if(!is.table(df)){
    if(is.matrix(df)){df <- as.data.frame(df)}
    if(!is.data.frame(df)){stop("df is not a data frame.")}
  }

  if(FALSE %in% (df == trunc(df))){stop("The data frame must contain integers.")}
  max <- min( nrow(df)-1,ncol(df)-1)

  if(!is.null(nPC)){
    if(nPC == "max"){nPC <- max}
    if(nPC > max){
      message("nPC must be less than: ",max+1,".")
      nPC <- max
    }
  }else{
    tmp <- FactoMineR::CA(df, graph=graph)

    x <- paste0(rownames(tmp$eig)," (",arrondi(tmp$eig[,3],1),"%)")
    Eigen_value <- tmp$eig[,1]
    df2 <- data.frame(x,Eigen_value)
    df2 <- within(df2,Principal_Component <- factor(x,levels = x))

    p <- plotly::plot_ly(df2,
      x = ~Principal_Component,
      y = ~Eigen_value,
      type = "bar"
    )
    print(p)
    if(interactive()){
      OK <- TRUE
      while(OK){
        nPC <- as.integer(readline("Select the number of axes:"))
        if(is.na(nPC) || nPC < 1 || nPC > max){
          message("must be a integer between 1 and ",max)
        }else{
          OK <- FALSE
        }
      }
    }else{
      stop("Need a nPC value.")
    }

  }
  df.CA <- FactoMineR::CA(df, ncp = nPC, graph = graph)
  dist <- dist(df.CA$row$coord) / max(dist(df.CA$row$coord))
  #dist <- dist(scale(df.CA$row$coord)) / max(dist(scale(df.CA$row$coord)))
  return(D=dist)
}

adjacency <- function(network){

  #===============================================================================
  # GENERATE DISTANCE MATRIX WITH NETWORK
  #
  # Authors : A.COULON
  # Last update : 23 october 2018
  #
  # Arguments:
  # raw	      The data frame with the stratigraphic element and the relation with the other
  #
  #===============================================================================

  #data.frame ?
  if(!is.data.frame(network)){stop("network data must be a data.frame.")}
  #number of col  ?
  if(length(network[1,])!=2){stop("network must have 2 colunms.")}
  M <- matrix(0,ncol = length(network[,1]),nrow = length(network[,1]),dimnames = list(network[,1],network[,1]))
  diag(M) <- 1
  for(i in 1:length(network[,1])){
    rel <- as.character(network[i,2])
    rel <- strsplit(rel,",")
    for(elt in rel[[1]]){
      j <- which(network[,1] == elt)
      M[i,j] <- 1
      M[j,i] <- 1
    }
  }
  D <- 1 - M
  return(D=as.dist(D))
}

overlap <- function(temporal){

  #===============================================================================
  # GENERATE DISSIMILARITY MATRIX WITH TEMPORAL
  #
  # Authors : A.COULON
  # Last update : 23 october 2018
  #
  # Arguments:
  # temporal	      The data frame
  #
  #===============================================================================

  indice <- function(inf1,sup1,inf2,sup2){
    if(inf2 == inf1 && inf1 == sup2 && inf1 == sup1){
      return(1)
    }
    if(sup1 < inf1 || inf2 > sup2){
      return(99)
    }
    #we define the bound of the total overlap as follow : min of lower bounds and max of upper bounds
    total_overlap_inf <- min(inf1,inf2)
    total_overlap_sup <- max(sup1,sup2)

    #The overlap is the difference between the bounds
    total_overlap <- total_overlap_sup - total_overlap_inf

    #we define the bound of the within overlap as follow : max of lower bounds and min of upper bounds
    within_overlap_inf <- max(inf1,inf2)
    within_overlap_sup <- min(sup1,sup2)

    #The overlap is the difference between the bounds
    within_overlap <- within_overlap_sup - within_overlap_inf

    #the overlap index is the ratio between the within overlap and the total overlap
    i <- within_overlap / total_overlap
    return(i)
  }

  df <- as.data.frame(temporal)
  #we create a square matrix of the same size as the number of rows
  overlap_matrix <- matrix(nrow = length(df[,1]), ncol = length(df[,1]))

  #we look each couple i j and compute the overlap index for this couple and save the value in the matrix[i,j]
  for(i in 1:(length(df[,1])-1)){
    for(j in (i+1):length(df[,1])){
      #recuperation of the elements rows i and j
      ens1 <- df[i,]
      ens2 <- df[j,]
      #compute the overlap index
      ind <- indice(ens1[1,2],ens1[1,3],ens2[1,2],ens2[1,3])
      #if(ind < 0){ind <- 0}
      if(ind==99){stop("The upper and lower bound are not in the correct column (sup1 < inf1 || inf2 > sup2).")}
      #if(ind <= 0){ind <- 0}
      #if(ind > 0){ind <- 1}
      #fill the matrix
      overlap_matrix[i,j] <- overlap_matrix[j,i] <- ind
    }
  }

  #fill the diag with 1
  diag(overlap_matrix) <- 1
  #[-1,1] to [0,2] (2 mean identical time range)
  overlap_matrix <- overlap_matrix + 1
  #inversion of values (high values now mean distant elements)
  overlap_matrix <- 2 - overlap_matrix
  #[0,2] to [0,1]
  overlap_matrix <- overlap_matrix / 2
  rownames(overlap_matrix) <- colnames(overlap_matrix) <- df[,1]
  return(D=overlap_matrix)
}

perioclust <- function(D1,D2,alpha="EstimateAlphaForMe",k=NULL,title="notitle",method="complete",suppl_plot=TRUE) {
  #===============================================================================
  # CAH CLASSIFICATION USING TWO DIST MATRIX
  #
  # Authors : A.COULON, L.BELLANGER and P.HUSI
  # Last update : 23 october 2018
  #
  # Arguments:
  # D1	       The fisrt distance matrix. Archeological context: stratigraphic or timerange distance.
  # D2	       The second distance matrix. Archeological context: ceramic distance.
  # alpha	     The mixing parameter.
  # k          The number of clusters.
  # title	     The title to print on the dendrogram (optionnal).
  # method     The method to use in hclust (see doc).
  # suppl_plot Logical for plot the WSS and average sil plot.
  #
  #===============================================================================

  sort = TRUE
  if(is.null(labels(D1))){
    sort <- FALSE
  }
  if(is.null(labels(D2))){
    sort <- FALSE
  }

  METHODS <- c("ward.D","single","complete","average","mcquitty","median","centroid","ward.D2")
  if (method == "ward") {
    message("The \"ward\" method has been renamed to \"ward.D\"; note new avaible method \"ward.D2\"")
    method <- "ward.D"
  }
  i.meth <- pmatch(method, METHODS)
  if (is.na(i.meth))
    stop("invalid clustering method", paste("", method))
  if (i.meth == -1)
    stop("ambiguous clustering method", paste("", method))

  method <- METHODS[i.meth]
  cont <- NULL
  Number_of_groups <- c()
  y <- c()
  yend <- c()
  xend <- c()
  if(!"dist" %in% class(D2)){
    #matrix ?
    if(!is.matrix(D2)){
      if(length(D2[1,]) == 3){
        message("generation of a temporal dissimilarities matrix.")
        D2 <- overlap(D2)
      }else{
        message("generation of a stratigraphic dissimilarities matrix.")
        D2 <- adjacency(D2)
        #diag = 0 ?
        if(sum(diag(D2)) != 0){
          stop("D2: The diagonal must be equal to 0.")
        }
      }
    }

    #symetric ?
    if(!isSymmetric(D2)){
      stop("D2 is not symmetric.")
    }
    if(!dim(D2)[1] == dim(D2)[2]){stop("D2 not a square matrix.")}
  }

  if(!"dist" %in% class(D1)) {
    #matrix ?
    if(!is.matrix(D1)){
      if(is.data.frame(D1)){cont <- D1;EPPM <- TRUE}else{EPPM <- FALSE}
      message("generation of a ceramic distances matrix.")
      D1 <- as.matrix(CAdist(D1,nPC="max",graph=FALSE))
    }
    #diag = 0 ?
    if(sum(diag(D1)) != 0){
      stop("D1: The diagonal must be equal to 0.")
    }
    #symetric ?
    if(!isSymmetric(D1)){
      stop("D1 is not symmetric.")
    }
    if(!dim(D1)[1] == dim(D1)[2]){stop("D1 not a square matrix.")}
  }

  D1 <- as.matrix(D1)
  max <- dim(D1)[1]
  D2 <- as.matrix(D2)

  if(FALSE %in% (sort(rownames(D1)) == sort(rownames(D2)))){
    warning("The names of D1 and D2 are not the same.")
    sort <- FALSE
  }
  if(FALSE %in% (sort(colnames(D1)) == sort(colnames(D2)))){
    warning("The names of D1 and D2 are not the same.")
    sort <- FALSE
  }
  if(FALSE %in% (sort(rownames(D1)) == sort(colnames(D2)))){
    warning("The names of D1 and D2 are not the same.")
    sort <- FALSE
  }

  if(!length(D1) == length(D2)){stop("D1 and D2 have not the same size.")}
  #dist (positive matrix) ?
  if(min(D1) < 0){stop("D1 is not positive.")}
  if(min(D2) < 0){stop("D2 is not positive.")}

  #normalization
  if(max(D1) != 0){
    D1 <- D1 / max(D1)
  }
  if(max(D2) != 0){
    D2 <- D2 / max(D2)
  }
  #create mixing matrix
  D1 <- as.dist(D1)
  D2 <- as.dist(D2)
  D1 <- as.matrix(D1)
  D2 <- as.matrix(D2)

  #sort labels
  if (sort) {
    D1.Tmp <- D1[sort(labels(D1)[[1]]),sort(labels(D1)[[1]])]
    D2.Tmp <- D2[sort(labels(D2)[[1]]),sort(labels(D2)[[1]])]
    D1 <- as.dist(D1.Tmp)
    D2 <- as.dist(D2.Tmp)
  }

  #no alpha
  if(alpha == "EstimateAlphaForMe"){
    # sa <- hclustcompro_select_alpha(D1, D2, method = method, resampling = FALSE)
    weight = optim_select_alpha(data =  list(D1, D2), method = method)
    alpha = weight$solution[1]
    # alpha <- sa$alpha[1]
    # sa <- list(alpha.plot = NULL,conf = NULL)
  }else{
    # sa <- list(alpha.plot = NULL,conf = NULL)
  }
  #alpha 0-1 ?
  if(alpha > 1 || alpha < 0){stop("alpha must be between 0 and 1.")}
  

  #mixt matrix
  D_alpha <- (alpha)*D1 + (1-alpha)*D2
  message("\nThe mixing parameter is ",alpha,". The mixing matrix is made of ",arrondi((alpha)*100,2),"% of D1 and ",
      arrondi((1-alpha)*100,2),"% of D2.\n\n")
  D_alpha <- as.dist(D_alpha)

  #CAH
  tree <- SPARTAAS::hclust(d=list(as.dist(D1),as.dist(D2)),method=method,weight=c(alpha,1-alpha))

  if(title == "notitle"){
    title <- paste("Dendrogram with alpha =",alpha)
  }
  subtitle <- paste("The mixing matrix is made of ",arrondi((alpha)*100,2),"% of D1 and ",
                    arrondi((1-alpha)*100,2),"% of D2.")

  D <- as.matrix(D_alpha)
  n <- length(D[,1])

  #wss sil value
  if(suppl_plot){
    if(length(D[,1]) > 20){n <- 20}
    wss <- c()
    sil <- c()
    for ( i in 2:(n-1)){
      cutree <- stats::cutree(tree,i)
      res <- fpc::cluster.stats(D,cutree)
      wss <- c(wss,res$within.cluster.ss)
      sil <- c(sil,res$avg.silwidth)
    }
    #wss
    Within_Sum_of_Square <- rbind(seq(2,(n-1)),wss)
    color_wss <- elbow_finder(seq(2,(n-1)),wss)
    dataplot <- t(Within_Sum_of_Square)
    dataplot <- as.data.frame(dataplot)
    colnames(dataplot) <- c("Number_of_groups","Within_Sum_of_Square")
    q <- ggplot2::ggplot(dataplot,aes(x=Number_of_groups, y=Within_Sum_of_Square)) +
      ggplot2::geom_point(aes(color=color_wss)) +
      ggplot2::scale_colour_gradientn(colours=c("brown1", "chartreuse3")) +
      ggplot2::geom_line(linetype = 3) +
      ggplot2::scale_x_continuous(breaks = dataplot$Number_of_groups ,
                                  labels = dataplot$Number_of_groups ) +
      ylim(0,max(wss)+1) +
      labs(title = "Within Sum of Square" , subtitle = "Partition evaluation") +
      ggplot2::theme(legend.position="none")

    #silhouette
    Average_Sil_Width <- rbind(seq(2,(n-1)),sil)
    dataplot <- t(Average_Sil_Width)
    dataplot <- as.data.frame(dataplot)
    dataplot <- na.omit(dataplot)
    colnames(dataplot) <- c("Number_of_groups", "Average_Sil_Width")
    p <- ggplot2::ggplot(dataplot,aes(x = Number_of_groups, y = Average_Sil_Width)) +
      ggplot2::geom_point(aes(color=Average_Sil_Width)) +
      ggplot2::scale_colour_gradientn(colours=c("brown1", "chartreuse3")) +
      ggplot2::geom_line(linetype = 3) + ylim(0,1) +
      ggplot2::scale_x_continuous(breaks = dataplot$Number_of_groups,
                                  labels = dataplot$Number_of_groups) +
      labs(title = "Average Silhouette Width", subtitle = "Partition evaluation") +
      ggplot2::theme(legend.position="none")

    # Nouvelle page
    grid::grid.newpage()
    # Creer la mise en page : nrow = 2, ncol = 2
    grid::pushViewport(viewport(layout = grid.layout(2, 2)))
    # Une fonction pour definir une region dans la mise en page
    define_region <- function(row, col){
      grid::viewport(layout.pos.row = row, layout.pos.col = col)
    }

    # Arranger les graphiques dans la fenetre
    hc <- tree
    hcdata <- ggdendro::dendro_data(tree, type="rectangle")
    dendrogram <- ggplot2::ggplot() + ggplot2::ggtitle(title) + ylim(-0.2, max(tree$height)) + ylab("height") + xlab("") +
      ggplot2::geom_segment(data=segment(hcdata), aes(x=x, y=y, xend=xend, yend=yend)) +
      ggplot2::geom_text(data=label(hcdata), aes(x=x,y=y,label=label,hjust=1,angle=90,fontface="bold",cex=1.5),
                         size=3) +
      ggplot2::theme(axis.title.x=element_blank(),
                     axis.text.x=element_blank(),
                     axis.ticks.x=element_blank())

    print(dendrogram, vp = define_region(1:2, 1))
    print(p, vp = define_region(1, 2))
    print(q, vp = define_region(2, 2))

    if(is.null(k)){
      if(interactive()){
        OK <- TRUE
        while(OK){
          k <- as.integer(readline("Select the number of clusters:"))
          if(is.na(k) || k < 1 || k > max){
            message("must be a integer between 1 and ",max)
          }else{
            OK <- FALSE
          }
        }
      }else{
        stop("No interactive session. Use parameter k to set clusters.")
      }
    }
  }else{
    if(is.null(k)){
      plot(tree,h = -1,main = title,sub = subtitle,xlab = paste0("D_alpha, method: \"",method,"\""))
      if(interactive()){
        OK <- TRUE
        while(OK){
          k <- as.integer(readline("Select the number of clusters:"))
          if(is.na(k) || k < 1 || k > max){
            message("must be a integer between 1 and ",max)
          }else{
            OK <- FALSE
          }
        }
      }else{
        stop("No interactive session. Use parameter k to set clusters.")
      }
    }
  }


  plot(tree,h = -1, main = title,sub = subtitle,xlab = paste0("D_alpha, method: \"",method,"\""))
  stats::rect.hclust(tree, k = k, border = colorspace::rainbow_hcl(k, c = 80, l = 60, start = 0, end = 360 * (k-1) / k))
  cluster <- stats::cutree(tree, k = k)
  height <- tree$height[length(tree$height) - k + 2]
  order <- unique(cluster[tree$order])
  for(i in 1:length(order)){
    if(i != order[i] && i < order[i]){
      cluster[cluster == i] <- 0
      cluster[cluster == order[i]] <- i
      cluster[cluster == 0] <- order[i]
      order <- unique(cluster[tree$order])
    }
  }
  col <- colorspace::rainbow_hcl(length(unique(cluster)),
                     c = 80, l = 60, start = 0,
                     end = 360*(length(unique(cluster))-1)/(length(unique(cluster))))
  for(i in 1:length(unique(cluster))){
    x <- mean(which(cluster[tree$order] == sort(unique(cluster))[i]))

    if(length(unique(cluster)) > 338){
      symb_letter <- sort(unique(cluster))[i]
    }else{
      symb_letter <- Int2Alpha(sort(unique(cluster))[i])
    }
    mtext(symb_letter, side = 1, line = .5, at = x, col = col[i], cex = 1.5)
  }
  cutree <- grDevices::recordPlot()

  return(
    structure(
      list(
        D1 = D1,
        D2 = D2,
        D_alpha = D_alpha,
        alpha = alpha,
        alpha.plot = NULL,
        conf_alpha = NULL,
        tree = tree,
        cluster = cluster,
        cutree = cutree,
        call = match.call(),
        cont = cont,
        wss = q,
        avg_sil = p
      ),
      class = c("perioclust_cl","list")
    )
  )
}

hclustcompro_cutree <- function(tree, k, main="", sub="", xlab="", ylab="", reorder=FALSE, letter=FALSE){
  method <- tree$method
  if(main==""){    main <- "Cluster Dendrogram"  }
  if(sub==""){     sub  <- paste0("method: \"",method,"\"")  }
  if(xlab==""){    xlab <- "d"  }
  if(ylab==""){    ylab <- "Height"  }
  plot(tree,h = -1, main = main, sub = sub, xlab = xlab)
  stats::rect.hclust(tree, k = k, border = colorspace::rainbow_hcl(k, c = 80, l = 60, start = 0, end = 360 * (k-1) / k))
  cluster <- stats::cutree(tree, k = k)

  if(reorder){
    order <- unique(cluster[tree$order])
    for(i in 1:length(order)){
      if(i != order[i] && i < order[i]){
        cluster[cluster == i] <- 0
        cluster[cluster == order[i]] <- i
        cluster[cluster == 0] <- order[i]
        order <- unique(cluster[tree$order])
      }
    }
    if(letter){
      cluster <- unlist(lapply(cluster,Int2Alpha))
    }
    col <- colorspace::rainbow_hcl(length(unique(cluster)),
                      c = 80, l = 60, start = 0,
                      end = 360*(length(unique(cluster))-1)/(length(unique(cluster)))
    )
    for(i in 1:length(unique(cluster))){
      x <- mean(which(cluster[tree$order] == sort(unique(cluster))[i]))
      mtext(unique(cluster[tree$order])[i], side = 1, line = .5, at = x, col = col[i], cex = 1.5)
    }
  }else{
    if(letter){
      cluster <- unlist(lapply(cluster,Int2Alpha))
    }
    col <- colorspace::rainbow_hcl(length(unique(cluster)),
                     c = 80, l = 60, start = 0,
                     end = 360*(length(unique(cluster))-1)/(length(unique(cluster)))
    )
    for(i in 1:length(unique(cluster))){
      x <- mean(which(cluster[tree$order] == unique(cluster[tree$order])[i]))
      mtext(unique(cluster[tree$order])[i], side = 1, line = .5, at = x, col = col[i], cex = 1.5)
    }
  }
  return(cluster)
}


perioclust_subdivide <- function(perioclust_cl,cluster,nb_class){

  # test
  if("perioclust_cl" != class(perioclust_cl)[1]){stop("Not a hclustcompro object.")}
  if(length(cluster) != length(nb_class)){stop("cluster and nb_cluster must have the same length.")}
  title <- paste("Cluster Dendrogram with alpha =",perioclust_cl$alpha)
  subtitle <- paste("The mixing matrix is made of ",arrondi((perioclust_cl$alpha)*100,2),"% of D1 and ",
                    arrondi((1-perioclust_cl$alpha)*100,2),"% of D2.")
  xlab <- paste("D_alpha, method: \"ward.D2\"")
  if(!is.null(perioclust_cl$oldcluster)){
    perioclust_cl$cluster <- perioclust_cl$oldcluster
  }
  k <- length(unique(perioclust_cl$cluster))
  color <- colorspace::rainbow_hcl(k, c = 80, l = 60, start = 0,
                       end = 360*(k-1)/(k))
  plot(perioclust_cl$tree, h=-1, main = title, sub = subtitle, xlab=xlab)
  stats::rect.hclust(perioclust_cl$tree,k = k,border = color)
  clusters <- c()

  cmpt <- 0
  for(i in 1:length(cluster)){
    where <- cluster[i]
    sk <- nb_class[i]
    number <- length(perioclust_cl$cluster[perioclust_cl$cluster == where])
    if(!sk %in% seq(2,(number-1)) ){stop("You try to create more sub cluster than possible.")}
    #col2 <- rainbow_hcl((k+sk-1), c = 80, l = 60, start = 0, end = 360*((k+sk-1)-1)/(k+sk-1)) 
    # add
    col <- colorspace::rainbow_hcl(k, c = 80, l = 60, start = 0,
                                end = 360*(k-1)/(k))
    col <- col[where]
    color <- append(color, rep(col,sk-1), after = where+cmpt)
    cmpt <- cmpt + sk-1
    #end
    if(length(perioclust_cl$cluster[perioclust_cl$cluster == where]) < sk){
      stop("There is not enought element in this class to create ",sk," sub-classes.")
    }
    subdiv <- sub_div(perioclust_cl$tree,perioclust_cl$cluster,where,sk)
    step <- subdiv$step
    clusters <- fusion(clusters,subdiv$cluster)

    #for color 
    nbcluster <- stats::cutree(perioclust_cl$tree,h=perioclust_cl$tree$height[step])
    order <- unique(nbcluster[perioclust_cl$tree$order])
    for(i in 1:length(order)){
      if(i != order[i] && i < order[i]){
        nbcluster[nbcluster == i] <- 0
        nbcluster[nbcluster == order[i]] <- i
        nbcluster[nbcluster == 0] <- order[i]
        order <- unique(nbcluster[perioclust_cl$tree$order])
      }
    }
    
    nb <- which(perioclust_cl$cluster == where)
    nb <- nbcluster[nb]
    which <- sort(unique(nb))
    stats::rect.hclust(perioclust_cl$tree,h = perioclust_cl$tree$height[step+1],which = which,
                border = col)  #col2[seq(where,where+sk-1)])
  }
  #col2 <- rainbow_hcl(length(unique(clusters)), c = 80, l = 60, start = 0,
  #                   end = 360*(length(unique(clusters))-1)/(length(unique(clusters))))
  for(i in 1:length(unique(clusters))){
    col <- color[i]
    x <- mean(which(clusters[perioclust_cl$tree$order] == sort(unique(clusters))[i]))
    # col2[i], cex=1.5)
    graphics::mtext(Int2Alpha(sort(unique(clusters))[i]), side = 1, line = .5, at = x, col = col, cex=1.5)
  }
  cutree <- grDevices::recordPlot()
  return(
    structure(
      list(
        D1 = perioclust_cl$D1,
        D2 = perioclust_cl$D2,
        D_alpha = perioclust_cl$D_alpha,
        alpha = perioclust_cl$alpha,
        tree = perioclust_cl$tree,
        cluster = clusters,
        oldcluster = perioclust_cl$cluster,
        cutree = cutree,
        call = match.call(),
        cont = perioclust_cl$cont
      ),
      class = c("perioclust_cl","list")
    )
  )
}

seriograph <- function(cont, order = NULL, insert = NULL, show = "both", permute = TRUE){

  show <- tolower(show)
  SHOWS <- c("both", "frequency", "eppm")
  i.show <- pmatch(show, SHOWS)
  if (is.na(i.show))
    stop("invalid show method", paste("", show))
  if (i.show == -1)
    stop("ambiguous show method", paste("", show))

  show <- SHOWS[i.show]
  if(show == "eppm"){
    show <- "EPPM"
  }

  if(class(cont)[1] == "perioclust_cl"){
    if(is.null(cont$cont)){
      stop("We don't find contingency table in perioclust_cl object.")
    }else{
      perioclust_cl <- cont
      cont <- perioclust_cl$cont
    }
    remove <- Int2Alpha(sort(unique(perioclust_cl$cluster)))
    if(is.null(order)){
      order <- Int2Alpha(sort(unique(perioclust_cl$cluster)))
    }
    remove <- remove[!remove %in% order]
    if(length(remove) >= 1){
      remove <- Alpha2Int(remove)
    }
    Cluster <- c(0)

    split <- Alpha2Int(order)
    seq <- perioclust_cl$cluster
    if(length(remove) >= 1){
      removeseq <- which(seq %in% remove)
      for(i in 1:length(removeseq)){
        seq[removeseq[i]] <- 900 + i
      }
    }

    c <- 0
    d <- 1
    pelt <- 0
    for (i in 1:length(split)) {
      elt <- as.numeric(split[i])
      felt <- as.numeric(split[i+1])
      if(elt != as.integer(elt)){
        if(as.integer(elt) != as.integer(pelt)){
          c <- c + 1
          d <- 1
        }
        seq[perioclust_cl$cluster == elt] <- as.numeric(paste0(c,".",d))
        d <- d + 1
      }else{
        c <- c + 1
        seq[perioclust_cl$cluster == elt] <- c
        d <- 1
      }
      pelt <- elt
    }
    message("Distribution of elements in the different clusters:\n")

    if(length(remove) >= 1){
      removeseq <- which(seq >= 900)
      seq2 <- seq[-removeseq]
      print(seq2)
    }else{
      print(seq)
    }

    cont <- cont[sort(labels(cont)[[1]]),]
    cont2 <- dplyr::mutate(cont, Cluster = factor(seq))
    cont2 <- dplyr::group_by(cont2, Cluster)
    cont2 <- dplyr::summarise_all(cont2, list(sum=sum))
    cont2 <- as.data.frame(cont2)
    rownames(cont2) <- cont2[,1]
    cont2 <- cont2[,-1]
    if(length(remove) >= 1){
      remove <- which(rownames(cont2) >= 900)
      cont2 <- cont2[-remove,]
    }
    cont2 <- cont2[order(as.numeric(rownames(cont2)),decreasing = T),]
    rownames(cont2) <- order

    if(!is.null(insert)){
      #insert hiatus
      ignore <- FALSE
      if(is.list(insert)){
        if(!is.numeric(insert[[1]])){
          if(!is.numeric(insert[[2]])){
            warning("Insert must contain integers corresponding to the position where to insert Hiatus.")
            ignore <- TRUE
          }else{
            tmp <- insert[[1]]
            insert[[1]] <- insert[[2]]
            insert[[2]] <- tmp
          }
        }
        if(!ignore){
          if(FALSE %in% (insert[[1]] == trunc(insert[[1]])) ){
            warning("Insert must contain integers corresponding to the position where to insert Hiatus.")
            ignore <- TRUE
          }else{
            if(!is.character(insert[[2]])){
              warning("Insert must contain labels as a character vector in the list.")
              ignore <- TRUE
            }
          }
        }
        if(!ignore){
          insert[[1]] <- length(cont2[,1]) - insert[[1]]
          label <- make.names(insert[[2]],unique=TRUE)
          for (i in length(insert[[1]]):1){
            after <- sort(insert[[1]])[i]
            if(after < length(cont2[,1]) && after >= 1 && after == trunc(after)){
              cont2 <- rbind(cont2[1:after,], label = rep(0,length(cont2[1,])),
                             cont2[(after+1):length(cont2[,1]),])
              row.names(cont2)[after+1] <- label[i]
            }else{
              warning("Some positions are outside the range. Ex: ",(length(cont2[,1]) - after))
            }
          }
        }
      }else{
        if(is.vector(insert)){
          if(!is.numeric(insert)){
            warning("Insert must contain integers corresponding to the position where to insert Hiatus.")
            ignore <- TRUE
          }
          if(!ignore){
            if(FALSE %in% (insert[[1]] == trunc(insert[[1]])) ){
              warning("Insert must contain integers corresponding to the position where to insert Hiatus.")
              ignore <- TRUE
            }
          }
          if(!ignore){
            insert <- length(cont2[,1]) - insert
            label <- "Hiatus"
            insert <- sort(insert)
            for (i in length(insert):1){
              if(insert[i] < length(cont2[,1]) && insert[i] >= 1 && insert[i] == trunc(insert[i])){
                cont2 <- rbind(cont2[1:insert[i],], label = rep(0,length(cont2[1,])),
                               cont2[(insert[i]+1):length(cont2[,1]),])
                if(length(insert)== 1){
                  row.names(cont2)[insert[i]+1] <- label
                }else{
                  row.names(cont2)[insert[i]+1] <- paste0(label, ".", (length(insert) + 1 - i) )
                }
              }else{
                warning("Some positions are outside the range. Ex: ",(length(cont2[,1]) - insert[i]))
              }
            }
          }
        }else{
          stop("insert must be a list of two vector (position after which to insert and label)
               or a vector (position)")
        }
      }
    }
    res <- plot_EPPM(cont2,show,permute)
    return(
      structure(
        list(
          seriograph = res$seriograph,
          contingency = res$contingency,
          frequency = res$frequency,
          EPPM = res$EPPM,
          EPM = res$EPM
        ),
        class = "seriograph"
      )
    )

  }else{
    #test data.frame
    if(!is.data.frame(cont)){
      cont <- as.data.frame(cont)
      if(!is.data.frame(cont)){stop("cont must be a data frame.")}
      if(!FALSE %in% (cont == trunc(cont))){stop("A contingency table must contains integers values.")}
    }
    cont2 <- cont

    #order
    if(!is.null(order)){
      new_order <- rep(NA,length(order))

      for(i in 1:length(order)){
        new_order[i] <- which(labels(cont2)[[1]] == order[i])
      }
      cont2 <- cont2[new_order,]

      #for (i in 1:length(order)){
      #  order[i] <- which(rownames(cont2) == order[i])
      #}
      #cont2 <- cont2[order(as.numeric(order),decreasing = F),]
    }

    if(!is.null(insert)){
      #insert hiatus
      ignore <- FALSE
      if(is.list(insert)){
        if(!is.numeric(insert[[1]])){
          if(!is.numeric(insert[[2]])){
            warning("Insert must contain integers corresponding to the position where to insert Hiatus.")
            ignore <- TRUE
          }else{
            tmp <- insert[[1]]
            insert[[1]] <- insert[[2]]
            insert[[2]] <- tmp
          }
        }
        if(!ignore){
          if(FALSE %in% (insert[[1]] == trunc(insert[[1]])) ){
            warning("Insert must contain integers corresponding to the position where to insert Hiatus.")
            ignore <- TRUE
          }else{
            if(!is.character(insert[[2]])){
              warning("Insert must contain labels as a character vector in the list.")
              ignore <- TRUE
            }
          }
        }
        if(!ignore){
          insert[[1]] <- length(cont2[,1]) - insert[[1]]
          label <- make.names(insert[[2]],unique=TRUE)
          for (i in length(insert[[1]]):1){
            after <- sort(insert[[1]])[i]
            if(after < length(cont2[,1]) && after >= 1 && after == trunc(after)){
              cont2 <- rbind(cont2[1:after,], label = rep(0,length(cont2[1,])),
                             cont2[(after+1):length(cont2[,1]),])
              row.names(cont2)[after+1] <- label[i]
            }else{
              warning("Some positions are outside the range. Ex: ",(length(cont2[,1]) - after))
            }
          }
        }
      }else{
        if(is.vector(insert)){
          if(!is.numeric(insert)){
            warning("Insert must contain integers corresponding to the position where to insert Hiatus.")
            ignore <- TRUE
          }
          if(!ignore){
            if(FALSE %in% (insert[[1]] == trunc(insert[[1]])) ){
              warning("Insert must contain integers corresponding to the position where to insert Hiatus.")
              ignore <- TRUE
            }
          }
          if(!ignore){
            insert <- length(cont2[,1]) - insert
            label <- "Hiatus"
            insert <- sort(insert)
            for (i in length(insert):1){
              if(insert[i] < length(cont2[,1]) && insert[i] >= 1 && insert[i] == trunc(insert[i])){
                cont2 <- rbind(cont2[1:insert[i],], label = rep(0,length(cont2[1,])),
                               cont2[(insert[i]+1):length(cont2[,1]),])
                if(length(insert)== 1){
                  row.names(cont2)[insert[i]+1] <- label
                }else{
                  row.names(cont2)[insert[i]+1] <- paste0(label,".",(length(insert)+1 - i))
                }
              }else{
                warning("Some positions are outside the range. Ex: ",(length(cont2[,1]) - insert[i]))
              }
            }
          }
        }else{
          stop("insert must be a list of two vector (position after which to insert and label)
               or a vector (position)")
        }
      }
    }
    res <- plot_EPPM(cont2,show,permute)
    return(
      structure(
        list(
          seriograph = res$seriograph,
          contingency = res$contingency,
          frequency = res$frequency,
          EPPM = res$EPPM,
          EPM = res$EPM
        ),
        class = "seriograph"
      )
    )
  }
}


print.perioclust_cl <- function(x, ...){

  cat("     perioclust | perioclust_cl

Alpha:",x$alpha,"

call: ")
  print(x$call)
  cat("
value:
      .. $D1          The first dissimilarities matrix
      .. $D2          The second dissimilarities matrix
      .. $D_alpha     The mixing dissimilarities matrix
      .. $alpha       The mixing parameter
      .. $tree        An object of class hclust (see ?hclust)

If you ran perioclust like this: classif <- perioclust(...)
select another number of cluster on the plot:
> plot(classif$tree, h = -1)
> rect.hclust(classif$tree, k = k) #with k the number of cluster

documentation:
> ?perioclust
      ")
}

hclustcompro_detail_resampling <- function(D1, D2 = NULL, acc = 2, method = "complete", iter = 5){

  #===============================================================================
  # CAH CLASSIFICATION USING TWO DIST MATRIX
  #
  # Authors : A.COULON, L.BELLANGER and P.HUSI
  # Last update : 23 october 2018
  #
  # Arguments:
  # D1	                  The fisrt distance matrix. Archeological context: stratigraphic distance.
  # D2	                  The second distance matrix. Archeological context: ceramic distance.
  # acc	                  The accuracy to round.
  # method                The method to use in hclust (see doc)
  # iter                   The number of replication for each element
  #
  #===============================================================================
  METHODS <- c("ward.D", "single", "complete", "average", "mcquitty",
               "median", "centroid", "ward.D2")
  if (method == "ward") {
    message("The \"ward\" method has been renamed to \"ward.D\"; note new avaible method \"ward.D2\"")
    method <- "ward.D"
  }
  i.meth <- pmatch(method, METHODS)
  if (is.na(i.meth))
    stop("invalid clustering method", paste("", method))
  if (i.meth == -1)
    stop("ambiguous clustering method", paste("", method))

  method <- METHODS[i.meth]
  if(!is.numeric(acc)) {stop("acc must be numeric!")}
  if(acc < 1) {
    acc <- 1;
    message("The minimal value allowed for acc is 1.")
  }

  if(class(D1)[1] == "perioclust_cl"){
    if(is.null(D1$D1) || is.null(D1$D2)){
      stop("We don't find dissmilarities matrices in perioclust_cl object.")
    }else{
      D2 <- D1$D2
      D1 <- D1$D1
    }
  }else{
    if(is.null(D1) || is.null(D2)){
      stop("We don't find dissmilarities in D1 and D2 arguments.")
    }
    #test
    if(!"dist" %in% class(D1)){
      #matrix ?
      if(!is.matrix(D1)){
        message("generation of a ceramic distances matrix.")
        D1 <- as.matrix(CAdist(D1, nPC="max", graph=FALSE))
      }
      #diag = 0 ?
      if(sum(diag(D1)) != 0){
        stop("D1: in distance matrix the diagonal is equal to 0.")
      }
      #symetric ?
      if(!isSymmetric(D1)){
        stop("D1 is not symmetric.")
      }
    }
    if(!"dist" %in% class(D2)){
      #matrix ?
      if(!is.matrix(D2)){
        if(length(D2[1,]) == 3){
          message("generation of a temporal dissimilarities matrix.")
          D2 <- overlap(D2)
        }else{
          message("generation of a stratigraphic dissimilarities matrix.")
          D2 <- adjacency(D2)
          #diag = 0 ?
          if(sum(diag(D2)) != 0){
            stop("D2: The diagonal must be equal to 0.")
          }
        }
      }

      #symetric ?
      if(!isSymmetric(D2)){
        stop("D2 is not symmetric.")
      }
    }
    if(!length(D1[,1]) == length(D1[1,])){stop("D1 not a square matrix.")}
    if(!length(D2[,1]) == length(D2[1,])){stop("D2 not a square matrix.")}
    #dist (positive matrix) ?
    if(min(D1) < 0){stop("D1 not a matrix dissimilarity (positive).")}
    if(min(D2) < 0){stop("D2 not a matrix distance (positive).")}
    if(median(D2) != 0 && median(D2) != 1){
      if(median(D1) == 0 || median(D1) == 1){
        message("We switch the two matrices. Stratigraphic data must be in D1 and ceramic data in D2.")
        tmp <- D1
        D1 <- D2
        D2 <- tmp
      }
    }
    #normalization
    if(max(D1) != 0){
      D1 <- D1 / max(D1)
    }
    if(max(D2) != 0){
      D2 <- D2 / max(D2)
    }
    #create mixing matrix
    D1 <- as.dist(D1)
    D2 <- as.dist(D2)
    D1 <- as.matrix(D1)
    D2 <- as.matrix(D2)
    #sort labels
    D1.Tmp <- D1[sort(labels(D1)[[1]]), sort(labels(D1)[[1]])]
    D2.Tmp <- D2[sort(labels(D2)[[1]]), sort(labels(D2)[[1]])]
    D1 <- as.matrix(D1.Tmp)
    D2 <- as.matrix(D2.Tmp)
  }

  save_lines <- NULL
  alpha_seq <- seq(0,1,0.01)

  D1save <- as.matrix(D1)
  D2save <- as.matrix(D2)

  #echantillonnage
  if(iter == "max"){iter <- length(D1save[1,])}
  if(!is.numeric(iter)){stop("iter must be numeric.")}
  if(iter < 1){iter <- 1; message("iter must be higher than 1.")
  warning("iter: must be between 1 and the number of elements.")}
  if(iter > length(D1save[1,])-1){
    if(iter > length(D1save[1,])){
      message("iter can't be higher than the number of element: ",length(D1save[1,]),".")
      warning("iter must be between 1 and the number of elements.")
    }
    iter <- length(D1save[1,])-1
  }

  cat("Resampling process:\n")
  #creation barre de progression(pb)
  pb <- utils::txtProgressBar(min = 0, max = length(D1save[1,]), style = 3)
  df <- NULL
  for (i in 1:length(D1save[1,])){
    for(j in sample((1:(length(D1save[,1])))[-i],iter,replace=FALSE)){
      if(iter == 1 && i == j){
        if(j == 1){j <- j + 1}else{j <- j - 1}
      }
      list <- generateClone(D1save, D2save, i, j)
      D1 <- list[[1]]
      D2 <- list[[2]]
      dist.dend <- c()
      for(alpha in alpha_seq){
        Mdist <- (alpha) * D1 + (1-alpha) * D2
        mixt.dist <- as.dist(Mdist)
        tree <- fastcluster::hclust(mixt.dist, method=method)
        new <- corCriterion(tree, D1, D2)
        dist.dend <- c(dist.dend, new)
      }
      if(is.null(df)){
        df <- data.frame(alpha = alpha_seq, height = dist.dend)
      }else{
        df <- cbind(df,dist.dend)
      }
    }
    mean <- unlist(lapply(as.data.frame(t(df[-1])),mean))
    if(is.null(save_lines)){
      save_lines <- cbind(df$alpha,mean)
    }else{
      save_lines <- cbind(save_lines,mean)
    }
    df <- NULL
    utils::setTxtProgressBar(pb, i)
  }
  close(pb)

  colnames(save_lines) <- c("alpha",rownames(D1save))
  rownames(save_lines) <- c()

  p <- plotly::plot_ly()
  for (k in 2:length(colnames(save_lines))) {
    p <- plotly::add_lines(p,x=save_lines[,1],y=save_lines[,k],name=colnames(save_lines)[k])
  }
  p
}

print.selectAlpha_obj <- function(x, ...){

  cat("        select Alpha | selectAlpha_obj

Estimated alpha:",x$alpha,"

call: ")
  print(x$call)
  cat("
value:
      .. $alpha             The estimate value of the parameter alpha (min CorCrit_alpha).
      .. $alpha.plot        The CorCrit for all the possible alpha.
    if resampling = TRUE
      .. $sd                The standard deviation.
      .. $conf              The confidence interval of alpha.
      .. $boxplot           The boxplot of the distribution.
      .. $values            All the potential alpha values obtained from clones.

documentation:
> ?hclustcompro_select_alpha
")
}

summary.selectAlpha_obj <- function(object, ...){
  cat("Estimate Alpha:",object$alpha,"    ( sd:",object$sd,")
Confidence interval: [",object$conf[1],";",object$conf[2],"]

Estimation calculated with",NROW(object$values),"observations.

?hclustcompro_select_alpha for details.
")
}

print.seriograph <- function(x, ...){
  cat("")
}

hclustcompro_select_alpha <- function(D1,D2, acc = 2, method = "complete", resampling = TRUE, iter = 5, suppl_plot = TRUE){

  #===============================================================================
  # CAH CLASSIFICATION USING TWO OR MORE DIST MATRIX
  #
  # Authors : A.COULON, L.BELLANGER and P.HUSI
  # Last update : 20 octobre 2025
  #
  # Arguments:
  # D1	                  The fisrt distance matrix.
  # D2	                  The second distance matrix.
  # acc             	    The accuracy to round.
  # resampling            Logical if we have to calculate confidence interval with resampling strategy
  # method                The method to use in hclust (see doc)
  #
  #===============================================================================

  METHODS <- c("ward.D", "single", "complete", "average", "mcquitty",
               "median", "centroid", "ward.D2")
  if (method == "ward") {
    message("The \"ward\" method has been renamed to \"ward.D\"; note new avaible method \"ward.D2\"")
    method <- "ward.D"
  }
  i.meth <- pmatch(method, METHODS)
  if (is.na(i.meth))
    stop("invalid clustering method", paste("", method))
  if (i.meth == -1)
    stop("ambiguous clustering method", paste("", method))
  method <- METHODS[i.meth]

  cor_ <- function(alpha) {
    c1 <- c()
    c2 <- c()
    for (elt in alpha){
      Mdist <- (elt)*D1 + (1-elt)*D2
      mixt.dist <- as.dist(Mdist)
      a_tree <- fastcluster::hclust(mixt.dist, method=method)
      da <- stats::cophenetic(a_tree)
      c1 <- c(c1, cor(as.dist(D1), da))
      c2 <- c(c2, cor(as.dist(D2), da))
    }
    return(list(c1,c2))
  }

  corCriterion_clone <- function(alpha, a, b) {
    res <- c()
    D1bis <- rbind(D1,clone=D1[a,])
    D1bis <- cbind(D1bis,clone=c(D1[a,],0))
    D2bis <- rbind(D2,clone=D2[b,])
    D2bis <- cbind(D2bis,clone=c(D2[b,],0))
    for (elt in alpha){
      Mdist <- (elt)*D1bis + (1-elt)*D2bis
      mixt.dist <- as.dist(Mdist)
      a_tree <- fastcluster::hclust(mixt.dist,method=method)
      da <- stats::cophenetic(a_tree)
      res <- c(res,abs(cor(as.dist(D1bis),da) - cor(as.dist(D2bis),da)))
    }
    return(res)
  }

  if(!is.numeric(acc)) {stop("acc must be numeric!")}
  if(acc < 1) {
    acc <- 1;
    message("The minimal value allowed for acc is 1.")
  }
  if(acc > 3) {
    message("If this take too much time reduce the acc. Try default acc=2.")
  }
  seq_acc <- 10^(-acc)
  #test
  if(!"dist" %in% class(D1)){
    #matrix ?
    if(!is.matrix(D1)){
      message("generation of distances matrix.")
      D1 <- as.matrix(CAdist(D1, nPC="max", graph=FALSE))
    }
    #diag = 0 ?
    if(sum(diag(D1)) != 0){
      stop("D1: The diagonal must be 0.")
    }
    #symetric ?
    if(!isSymmetric(D1)){
      stop("D1 is not symmetric.")
    }
    if(!length(D1[,1]) == length(D1[1,])){stop("D1 not a square matrix.")}
  }
  if(!"dist" %in% class(D2)){
    #matrix ?
    if(!is.matrix(D2)){
      if(length(D2[1,]) == 3){
        message("generation of a temporal dissimilarities matrix.")
        D2 <- overlap(D2)
      }else{
        message("generation of a stratigraphic dissimilarities matrix.")
        D2 <- adjacency(D2)
        #diag = 0 ?
        if(sum(diag(D2)) != 0){
          stop("D2: The diagonal must be 0.")
        }
      }
    }
    #symetric ?
    if(!isSymmetric(D2)){
      stop("D2 is not symmetric.")
    }
    if(!length(D2[,1]) == length(D2[1,])){stop("D2 not a square matrix.")}
  }

  D1 <- as.matrix(D1)
  D2 <- as.matrix(D2)
  #dist (positive matrix) ?
  if(min(D1) < 0){stop("D1 not a dissimilarity matrix (positive).")}
  if(min(D2) < 0){stop("D2 not a distance matrix (positive).")}
  if(median(D2) != 0 && median(D2) != 1){
    if(median(D1) == 0 || median(D1) == 1){
      message("We switch the two matrices. Stratigraphic data must be in D1 and ceramic data in D2.")
      tmp <- D1
      D1 <- D2
      D2 <- tmp
    }
  }
  #normalization
  if(max(D1) != 0){
    D1 <- D1 / max(D1)
  }
  if(max(D2) != 0){
    D2 <- D2 / max(D2)
  }
  #create mixing matrix
  D1 <- as.dist(D1)
  D2 <- as.dist(D2)
  D1 <- as.matrix(D1)
  D2 <- as.matrix(D2)
  #sort labels
  D1.Tmp <- D1[sort(labels(D1)[[1]]), sort(labels(D1)[[1]])]
  D2.Tmp <- D2[sort(labels(D2)[[1]]), sort(labels(D2)[[1]])]
  D1 <- as.matrix(D1.Tmp)
  D2 <- as.matrix(D2.Tmp)

  #resampling check
  if(iter == "max"){iter <- length(D1[1,])}
  if(!is.numeric(iter)){stop("iter must be numeric.")}
  if(!is.logical(resampling)){stop("resampling must be TRUE or FALSE.")}
  if(iter < 1){iter <- 1; message("iter must be higher than 1.")
  warning("iter: must be between 1 and the number of elements.")}
  if(iter > length(D1[1,])-1){
    if(iter > length(D1[1,])){
      message("iter can't be higher than the number of element: ",length(D1[1,]),".")
      warning("iter: must be between 1 and the number of elements.")
    }
    iter <- length(D1[1,])-1
  }

  if(suppl_plot){
    #estime alpha
    ## TODO: use cor_ and calc corcrit
    correlation_curve <- cor_(seq(0, 1, seq_acc))
    #corCrit <- c()
    #for(i in seq(0,1,seq_acc)){corCrit <- c(corCrit,corCriterion_(i))}
    corCrit <- abs(correlation_curve[[1]] - correlation_curve[[2]])

    index <- which(corCrit == min(corCrit))
    alpha <- seq(0,1,seq_acc)[index]

    add_text_resamp <- ""
    if(resampling){
      #echantillonnage
      cat("\nResampling process:\n")
      pb <- utils::txtProgressBar(min = 0, max = length(D1[1,]), style = 3)
      set <- c()
      res <- c()
      for (i in 1:length(D1[1,])){
        for(j in sample((1:(length(D1[,1])))[-i], iter, replace=FALSE)){
          if(i!=j){
            tmp <- stats::optimize(corCriterion_clone, lower=0, upper=1, a=i, b=j)
            set <- c(set, tmp$minimum)
          }
        }
        utils::setTxtProgressBar(pb, i)
      }

      res <- set
      sd <- arrondi(sd(res), acc)
      box <- quantile(res, c(0,0.025,0.25,0.5,0.75,0.975,1))
      conf <- c(arrondi(box[2], acc), arrondi(box[6], acc))
      values <- arrondi(res, acc)

      BoxPlotValue <- boxplot(
        res,
        horizontal = TRUE,
        range = 0,
        main="boxplot: Distribution of all the potentials values of alpha.",
        xlab=expression(alpha),
        xaxt="n"
      )
      axis(
        side = 1,
        at = c(box[1], box[3], box[4], box[5], box[7]),
        labels = arrondi(c(box[1], box[3], box[4], box[5], box[7]), acc)
      )
      points(arrondi(mean(res), acc), 1, col="red")
      text(arrondi(mean(res),acc), 1.3,
           bquote(hat(alpha)^"*" == .(arrondi(mean(res),acc))))
      boxplot <- grDevices::recordPlot()

      add_text_resamp <- paste(" The IC95% is calculated with",iter,'*',length(D1[1,]),
                               "clones out of",length(D1[1,])-1,"*",length(D1[1,]),"available.")
    }

    ## TODO: re-use calc corcrit instead of running twice corCriterion_
    plot(
      seq(0,1,seq_acc),corCrit,type="l",
      xlab = expression(alpha),
      ylab = expression(CorCrit[alpha]),
      ylim=c(0,1),
      axes = TRUE,
      main = "Select alpha",
      sub = paste0("method: ", method, ".", add_text_resamp),
      xaxp = c(0, 1, 5),
      mgp= c(2, 1, 0),
      col = "slateblue2",
      xaxt= "n",
      lwd=1
    )
    ## TODO: re-use value from calc corcrit
    #correlation_curve <- cor_(seq(0,1,seq_acc))
    lines(seq(0, 1, seq_acc), correlation_curve[[1]], lty=3, col="grey60")
    lines(seq(0, 1, seq_acc), correlation_curve[[2]], lty=3, col="grey60")
    axis(
      side = 1,
      at = c(.1,.2,.3,.4,.5,.6,.7,.8,.9),
      labels = rep("", 9),
      col = "grey"
    )
    axis(
      side = 1,
      at = arrondi(alpha, acc),
      labels = rep("", length(alpha)),
      col = "slateblue2"
    )
    if(resampling){
      axis(
        side = 1,
        at = c(0, arrondi(box[2], acc), arrondi(box[6], acc), 1),
        labels = c(0, arrondi(box[2], acc), arrondi(box[6], acc), 1)
      )
      abline(v = arrondi(box[6], acc), col = "gray50", lty=3, lwd=2)
      abline(v = arrondi(box[2], acc), col = "gray50", lty=3, lwd=2)
      close(pb)
    }else{
      axis(
        side = 1,
        at = c(0,1),
        labels = c(0,1)
      )
    }

    for(i in 1:length(alpha)){
      graphics::mtext(arrondi(alpha[i],acc),side = 1,line = .4,at = arrondi(alpha[i],acc),col = "slateblue2")
    }
    alpha.plot <- grDevices::recordPlot()

    if(resampling){
      return(structure(
        list(alpha = arrondi(alpha, acc),
             alpha.plot = alpha.plot,
             sd = sd,
             conf = conf,
             boxplot = boxplot,
             values = values
        ),
        class = c("selectAlpha_obj","list")
      )
      )
    }else{
      return(structure(
        list(alpha = arrondi(alpha,acc),
             alpha.plot = alpha.plot,
             more = "Need resampling = TRUE!"
        ),
        class = c("selectAlpha_obj", "list")
      )
      )
    }
  }else{

    #estime alpha
    correlation_curve <- cor_(seq(0, 1, seq_acc))
    #corCrit <- c()
    #for(i in seq(0,1,seq_acc)){corCrit <- c(corCrit,corCriterion_(i))}
    corCrit <- abs(correlation_curve[[1]] - correlation_curve[[2]])

    index <- which(corCrit == min(corCrit))
    alpha <- seq(0, 1, seq_acc)[index]

    if(resampling){
      pb <- utils::txtProgressBar(min = 0, max = length(D1[1,]), style = 3)
      set <- c()
      res <- c()
      for (i in 1:length(D1[1,])){
        for(j in sample((1:(length(D1[,1])))[-i], iter, replace=FALSE)){
          if(i!=j){
            tmp <- stats::optimize(corCriterion_clone, lower=0, upper=1, a=i, b=j)
            set <- c(set, tmp$minimum)
          }
        }
        utils::setTxtProgressBar(pb, i)
      }
      conf <- arrondi(quantile(set, c(0.025,0.975)), acc)
      close(pb)
      return(structure(
        list(alpha = arrondi(alpha, acc),
             conf = conf,
             more = "Need suppl_plot = TRUE!"
        ),
        class = c("selectAlpha_obj","list")
      )
      )
    }else{
      return(structure(
        list(alpha = arrondi(alpha, acc),
             more = "Need suppl_plot = TRUE!"
        ),
        class = c("selectAlpha_obj","list")
      )
      )
    }


  }

}

optim_select_alpha <- function(data = list(), acc = 2, method = "complete", algo = "NLOPT_GN_ORIG_DIRECT_L"){

  #============================================================================
  # Optimisation (NLOPT) des poids de chaque source
  #
  # Authors : A.COULON
  # Last update : 25 november 2025
  #
  # Arguments:
  # data      liste des matrices de distances
  # acc       nombre de chiffre après la virgule
  # method    stratégie d'aggrégation utilisée par hclust()
  #
  #============================================================================

  ALGO <- c("NLOPT_GN_ISRES", "NLOPT_GN_ORIG_DIRECT_L")
  i.algo <- pmatch(algo, ALGO)
  if (is.na(i.algo))
    stop("invalid algorithm", paste("", algo))
  if (i.algo == -1)
    stop("ambiguous algorithm", paste("", algo))
  algo <- ALGO[i.algo]

  METHODS <- c("ward.D", "single", "complete", "average", "mcquitty",
               "median", "centroid", "ward.D2")
  if (method == "ward") {
    message("The \"ward\" method has been renamed to \"ward.D\"; note new avaible method \"ward.D2\"")
    method <- "ward.D"
  }
  i.meth <- pmatch(method, METHODS)
  if (is.na(i.meth))
    stop("invalid clustering method", paste("", method))
  if (i.meth == -1)
    stop("ambiguous clustering method", paste("", method))
  method <- METHODS[i.meth]

  if(!is.numeric(acc)) {stop("acc must be numeric!")}
  if(acc < 1) {
    acc <- 1;
    message("The minimal value allowed for acc is 1.")
  }

  ## number of sources
  K <- length(data)

  for(i in 1:K){

    #test
    if(!"dist" %in% class(data[[i]])){
      #matrix
      if(!"matrix" %in% class(data[[i]])){
        stop("data contain objets that are neither matrix nor dist objet.")
      }
      #diag = 0 ?
      if(sum(diag(data[[i]])) != 0){
        stop("Distance matrix diagonal must be 0.")
      }
      #symetric ?
      if(!isSymmetric(data[[i]])){
        stop("data is not symmetric.")
      }
      if(!length(data[[i]][,1]) == length(data[[i]][1,])){stop("Not a square matrix.")}
    }

    #normalization of matrix
    if(max(data[[i]]) != 0){
      data[[i]] <- data[[i]] / max(data[[i]])
    }
    #sort labels
    data[[i]] <- as.matrix(data[[i]])
    D_Tmp <- data[[i]][sort(labels(data[[i]])[[1]]),sort(labels(data[[i]])[[1]])]
    data[[i]] <- as.dist(D_Tmp)
  }

  ## objective function
  eval_f0 <- function(x, data, method) {
    x_tmp <- c(x, 1-sum(x) )

    ## Map multiply the weight (here x_tmp) on each matrix (here data), result is a list of weighted matrices
    DIST <- Map(`*`, data, x_tmp)
    ## Reduce apply + operator to the first two matrices of the list, then adds the thirds, and so on (sum)
    DIST <- Reduce(`+`, DIST)

    ## hclust and cophenetic distances
    tree <- stats::hclust(d=as.dist(DIST), method=method)
    D_coph <- stats::cophenetic(tree)

    ## correlation between each sources and D_coph
    correlation <- sapply(data, cor, y = D_coph)
    ## symetric matrix: absolute difference between each sources
    diff_matrix <- abs(outer(correlation, correlation, `-`))
    ## lower triangle
    diff_matrix_triangle <- diff_matrix[lower.tri(diff_matrix, diag=F)]
    ## sum of each abs diff between sources
    res <- sum( diff_matrix_triangle )

    return(res)
  }

  ## constraint function
  eval_g0 <- function(x, data, method) {
    ## Inequality: sum(x) < 1
    # g(x) must be < 0 when good -> so, sum(x)-1 < 0
    return(sum(x)-1)
  }

  # note: we are searching for x values (weight), x length is K-1, (K: number of sources)
  # because the last weight is deduced by 1-sum(x)
  res <- nloptr::nloptr(
    x0 = rep(1/(K), K-1),   ## weight 1/K for each of K-1 first sources
    eval_f = eval_f0,       # i.e. for 2 sources: rep(1/2, 1); for 3 rep(1/3, 2)...
    lb = rep(0, K-1),
    ub = rep(1, K-1),
    eval_g_ineq = eval_g0,
    opts = list("algorithm" = algo, ## NLOPT_GN_ISRES NLOPT_GN_ORIG_DIRECT_L
                "xtol_rel" = 1.0e-3,
                "maxeval" = 10000),
    data = data,
    method = method
  )

  ## first K-1 weight and the last (1-sum(x))
  solution = c(res$solution, 1 - sum(res$solution))

  return(list(
      res_nlopt = res,
      solution = arrondi(solution, acc)
    )
  )
}

timerange <- function(data, cluster = NULL, add = NULL, density = NULL, color = NULL, reorder = FALSE){

  ## test
  if(is.null(cluster)){cluster <- rep(1,dim(data)[1])}
  if(!is.data.frame(data)){stop("data must be a data.frame.")}
  if(!is.null(add)){
    if(!is.data.frame(add)){stop("add must be a data.frame (even if there is only one column).")}
  }
  if(!is.vector(cluster)){stop("cluster must be a vector.")}
  if(!is.null(density)){
    if(!is.vector(density)){stop("cluster must be a vector.")}
  }

  ## call fonction overlap plot
  df <- cbind(data,cluster)
  res <- overlap_plot(df,add,density,color,reorder_color = reorder)

  return(structure(list(order = res$order, plot = res$plot, density = res$density, cluster = res$reorder_cluster), class = c("temp_obj", "list")))
}


hclustcompro <- function(d, method = "complete", weight = NULL){

  #============================================================================
  # hclustcompro multivues
  #
  # Authors : A.COULON
  # Last update : 25 november 2025
  #
  #============================================================================

  METHODS <- c("ward.D", "single", "complete", "average", "mcquitty",
               "median", "centroid", "ward.D2")
  if (method == "ward") {
    message("The \"ward\" method has been renamed to \"ward.D\"; note new avaible method \"ward.D2\"")
    method <- "ward.D"
  }
  i.meth <- pmatch(method, METHODS)
  if (is.na(i.meth))
    stop("invalid clustering method", paste("", method))
  if (i.meth == -1)
    stop("ambiguous clustering method", paste("", method))
  method <- METHODS[i.meth]

  if("list" %in% class(d)){
    ## number of sources
    K <- length(d)

    ## If the last weight is missing we can deduce him (as sum(weight)=1)
    if(length(weight) == K-1){
      weight = c(weight,1-sum(weight))
    }

    if(length(weight) != K){
      message("weight were missing or not the same length as d. We calculate them base on corcrit.")
      weight = optim_select_alpha(d,2,method)$solution
    }

    if(sum(weight)!=1){
      message("sum of weight not equal to 1. We recalculate them base on corcrit.")
      weight = optim_select_alpha(d,2,method)$solution
    }

    for(i in 1:K){

      #test
      if(!"dist" %in% class(d[[i]])){
          stop("d not a dist object or a list of dist object.")
      }

      #normalization of matrix
      if(max(d[[i]]) != 0){
        d[[i]] <- d[[i]] / max(d[[i]])
      }
      #sort labels
      d[[i]] <- as.matrix(d[[i]])
      D_Tmp <- d[[i]][sort(labels(d[[i]])[[1]]),sort(labels(d[[i]])[[1]])]
      d[[i]] <- as.dist(D_Tmp)
    }

    ## Map multiply the weight on each matrix (here list d), result is a list of weighted matrices
    DIST <- Map(`*`, d, weight)
    ## Reduce apply + operator to the first two matrices of the list, then adds the thirds, and so on (sum)
    DIST <- Reduce(`+`, DIST)

    ## hclust and cophenetic distances
    d=as.dist(DIST)
  }
  fastcluster::hclust(d, method)
}


hclust <- function(d, method = "complete", members = NULL, weight = NULL){

  #============================================================================
  # hclustcompro multivues
  #
  # Authors : A.COULON
  # Last update : 25 november 2025
  #
  #============================================================================

  METHODS <- c("ward.D", "single", "complete", "average", "mcquitty",
               "median", "centroid", "ward.D2")
  if (method == "ward") {
    message("The \"ward\" method has been renamed to \"ward.D\"; note new avaible method \"ward.D2\"")
    method <- "ward.D"
  }
  i.meth <- pmatch(method, METHODS)
  if (is.na(i.meth))
    stop("invalid clustering method", paste("", method))
  if (i.meth == -1)
    stop("ambiguous clustering method", paste("", method))
  method <- METHODS[i.meth]

  if("list" %in% class(d)){
    ## number of sources
    K <- length(d)

    ## If the last weight is missing we can deduce him (as sum(weight)=1)
    if(length(weight) == K-1){
      weight = c(weight,1-sum(weight))
    }

    if(length(weight) != K){
      message("weight were missing or not the same length as d. We calculate them base on corcrit.")
      weight = optim_select_alpha(d,2,method)$solution
    }

    if(sum(weight)!=1){
      message("sum of weight not equal to 1. We recalculate them base on corcrit.")
      weight = optim_select_alpha(d,2,method)$solution
    }

    for(i in 1:K){

      #test
      if(!"dist" %in% class(d[[i]])){
          stop("d not a dist object or a list of dist object.")
      }

      #normalization of matrix
      if(max(d[[i]]) != 0){
        d[[i]] <- d[[i]] / max(d[[i]])
      }
      #sort labels
      d[[i]] <- as.matrix(d[[i]])
      D_Tmp <- d[[i]][sort(labels(d[[i]])[[1]]),sort(labels(d[[i]])[[1]])]
      d[[i]] <- as.dist(D_Tmp)
    }

    ## Map multiply the weight on each matrix (here list d), result is a list of weighted matrices
    DIST <- Map(`*`, d, weight)
    ## Reduce apply + operator to the first two matrices of the list, then adds the thirds, and so on (sum)
    DIST <- Reduce(`+`, DIST)

    ## hclust and cophenetic distances
    d=as.dist(DIST)
  }
  fastcluster::hclust(d, method, members)
}
