#' Generate a Shiny App for interactive exploration of CellChat's outputs
#'
#' @param object CellChat object
#' @param ... Other parameters of `shinyApp` function from shiny R package
#' @return A Shiny app object on the basis of one CellChat object
#' @export
#' @importFrom stringr str_split_1
# #' @importFrom plotly subplot plot_ly ggplotly add_markers highlight highlight_key plotlyOutput layout
# #' @importFrom bsicons bs_icon
#' @import shiny bslib
#'
runCellChatApp <- function(object,...) {
  # ##########################################################################
  # set some global options
  # ##########################################################################
  options(stringsAsFactors = FALSE)

  # ##########################################################################
  # some useful elements for ui.R
  # ##########################################################################
  choices_cell_groups <-levels(object@idents)
  names(choices_cell_groups) <- levels(object@idents)

  choices_pathways <- object@netP$pathways
  names(choices_pathways) <- object@netP$pathways

  # all signaling gene names
  choices_gene_names <- CellChat::extractGene(object@DB)
  # all ligand-receptor pair names
  #choices_pairLR_use <- object@DB$interaction$interaction_name
  if ("LRs" %in% names(object@net)) {
    choices_pairLR_use <- object@net$LRs
  } else {
    thresh = 0.05
    prob <- object@net$prob
    prob[object@net$pval > thresh] <- 0
    LR <- dimnames(prob)[[3]]
    LR.sig <- LR[apply(prob, 3, sum) != 0]
    choices_pairLR_use <- LR.sig
  }

  # Palettes (sequential)
  choices_palettes_sequential <- stringr::str_split_1("Blues, BuGn, BuPu, GnBu, Greens, Greys, Oranges, OrRd, PuBu, PuBuGn, PuRd, Purples, RdPu, Reds, YlGn, YlGnBu, YlOrBr, YlOrRd",", ")
  names(choices_palettes_sequential) <- choices_palettes_sequential
  choices_palettes_diverging <- stringr::str_split_1("BrBG, PiYG, PRGn, PuOr, RdBu, RdGy, RdYlBu, RdYlGn, Spectral",", ")
  names(choices_palettes_diverging) <- choices_palettes_diverging

  # ##########################################################################
  # interactive visualization
  # ##########################################################################

  # interactive Heatmap
  # [Colors (ggplot2)](http://www.cookbook-r.com/Graphs/Colors_(ggplot2)/)
  plotly_netVisual_heatmap <- function(obj_heatmap,palette.heatmap,direction.heatmap=1) {
    gg_heatmap <- obj_heatmap@matrix %>%
      as.data.frame() %>%
      mutate(row = rownames(.)) %>%
      tidyr::pivot_longer(
        data = .,
        cols = colnames(.)[-length(colnames(.))],
        names_to = "column",
        values_to = "value"
      ) %>%
      ggplot() +
      geom_tile(aes(row, column, fill = value),
                width = 0.95,
                height = 0.95) +
      # guides(fill=guide_legend(title=obj_heatmap@row_title))+
      labs(title = '',
           x = '',
           y = obj_heatmap@row_title,
           # I can't set the direction of the legend title, I thick it's a bug
           # fill = obj_heatmap@column_title,
      ) +
      scale_fill_distiller(
        palette = palette.heatmap,
        na.value = 'white',
        direction = direction.heatmap,
      ) +
      theme_minimal()+
      theme(axis.title.y = element_text(size = 14))

    # ggplot transpose the matrix, so we need use colSums to calc the 'rowSums'
    # of the matrix
    gg_right <- obj_heatmap@matrix %>%
      colSums(abs(.)) %>%
      tibble(row_sum = ., sources_name = names(.)) %>%
      ggplot() +
      geom_bar(aes(x = sources_name, y = row_sum, fill = sources_name),
               stat = 'identity') +
      labs(title = '',
           x = '',
           y = '',) +
      guides(fill = FALSE) +
      scale_fill_brewer(palette = "Set1", direction = 1) +
      theme_minimal() +
      coord_flip()

    gg_top <- obj_heatmap@matrix %>%
      rowSums(abs(.)) %>%
      tibble(col_sum = ., sources_name = names(.)) %>%
      ggplot() +
      # use fill to set the columns' colors
      geom_bar(aes(x = sources_name, y = col_sum, fill = sources_name),
               stat = 'identity') +
      labs(title = obj_heatmap@column_title,
           x = '',
           y = '',) +
      guides(fill = FALSE)+
      scale_fill_brewer(palette = "Set1", direction = 1) +
      # theme() function should be used behind the theme_*()
      theme_minimal()+
      theme(plot.title = element_text(hjust = 0.5,size = 14))

    return(plotly::subplot(
      gg_top,
      plotly::plotly_empty(),
      gg_heatmap,
      gg_right,
      nrows = 2,
      heights = c(0.2, 0.8),
      widths = c(0.8, 0.2),
      margin = 0,
      shareX = TRUE,
      shareY = TRUE,
      titleX = TRUE,
      titleY = TRUE
    )
    )
  }

  # interactive DimPlot
  plotly_DimPlot <- function (object,
                              color.use = NULL,
                              group.by = NULL,
                              sample.use = NULL,
                              reduction = NULL,
                              sources.use = NULL,
                              targets.use = NULL,
                              idents.use = NULL,
                              alpha = 1,
                              title.name = NULL,
                              point.size = 1)
  {
    if (is.null(group.by)) {
      labels <- object@idents
    } else {
      labels = object@meta[, group.by]
      labels <- factor(labels)
    }
    if (length(names(object@dr)) == 0) {
      stop("Please check `addReduction` to add a new reduced space into `object@dr`. \n")
    }
    if (!is.null(reduction)) {
      coords <- object@dr[[reduction]]
    } else {
      if ("umap" %in% names(object@dr)) {
        coords <- object@dr$umap
      } else if ("tsne" %in% names(object@dr)){
        coords <- object@dr$tsne
      } else {
        stop(paste0("The `object@dr` contains the following reduced space: ", toString(names(object@dr)), ". Please specify the dimensionality reduction to use. \n"))
      }
    }
    coordinates <- as.data.frame(coords)
    samples <- object@meta$samples
    if (ncol(coordinates) >= 2) {
      coordinates <- coordinates[, c(1,2)]
      colnames(coordinates) <- c("x_cent","y_cent")
      if (length(unique(samples)) > 1) {
        if (is.null(sample.use)) {
          stop("`sample.use` should be provided for visualizing signaling on each individual sample.")
        } else if (sample.use %in% unique(samples)) {
          coordinates = coordinates[samples == sample.use, ]
          labels = labels[samples == sample.use]
        } else {
          stop("Please check the input `sample.use`, which should be the element in `meta$samples`.")
        }
      }
      # temp_coordinates = coordinates
      # coordinates[,1] = temp_coordinates[,2]
      # coordinates[,2] = temp_coordinates[,1]
    } else {
      stop("Please check the input 'object@dr' and make sure it has at least two columns.")
    }

    cells.level <- levels(labels)
    if (!is.null(idents.use)) {
      if (is.numeric(idents.use)) {
        idents.use <- cells.level[idents.use]
      }
      cell.use <- !(labels %in% idents.use)
      labels[cell.use] <- NA
      cells.level <- cells.level[cells.level %in% idents.use]
      labels <- factor(labels, levels = cells.level)
    }
    if (is.null(sources.use) & is.null(targets.use)) {
      if (is.null(color.use)) {
        color.use <- scPalette(nlevels(labels))
      }
    }
    else {
      if (is.numeric(sources.use)) {
        sources.use <- cells.level[sources.use]
      }
      if (is.numeric(targets.use)) {
        targets.use <- cells.level[targets.use]
      }
      group <- rep("Others", length(labels))
      group[(labels %in% sources.use)] <- sources.use
      group[(labels %in% targets.use)] <- targets.use
      group = factor(group, levels = c(sources.use, targets.use,
                                       "Others"))
      if (is.null(color.use)) {
        color.use.all <- scPalette(nlevels(labels))
        color.use <- color.use.all[match(c(sources.use,
                                           targets.use), levels(labels))]
        color.use[nlevels(group)] <- "grey90"
      }
      labels <- group
    }
    # print(color.use)->return a color vector
    coordinates$cell_labels <- labels

    py <- plotly::highlight_key(coordinates,~cell_labels) %>%
      plotly::plot_ly(x = ~x_cent, y = ~y_cent,marker = list(size = point.size)) %>%
      plotly::add_markers(color=~cell_labels,alpha=alpha,colors=color.use) %>%
      plotly::layout(
        title = title.name,
        yaxis = list(
          title = "",
          #autorange = "reversed",
          showgrid = FALSE,
          ticks = "",
          # ticktext = "",
          tickvals = "",
          zeroline = FALSE,
          showline = FALSE
        ),
        xaxis = list(
          title = "",
          showgrid = FALSE,
          ticks = "",
          # ticktext = "",
          tickvals = "",
          zeroline = FALSE,
          showline = FALSE
        )
      ) %>%
      plotly::highlight(on = "plotly_click",
                        off = "plotly_relayout")

    return(py)
  }

  # interactive FeaturePlot
  # https://plotly.com/r/subplots/
  plotly_FeaturePlot <-

  # interactive spatialDimPlot
  plotly_spatialDimPlot <- function (object,
                              color.use = NULL,
                              group.by = NULL,
                              sample.use = NULL,
                              sources.use = NULL,
                              targets.use = NULL,
                              idents.use = NULL,
                              alpha = 1,
                              title.name = NULL,
                              point.size = 1)
  {
    if (is.null(group.by)) {
      labels <- object@idents
    } else {
      labels = object@meta[, group.by]
      labels <- factor(labels)
    }

    coordinates <- as.data.frame(object@images$coordinates)
    samples <- object@meta$samples
    if (ncol(coordinates) == 2) {
      colnames(coordinates) <- c("x_cent","y_cent")
      if (length(unique(samples)) > 1) {
        if (is.null(sample.use)) {
          stop("`sample.use` should be provided for visualizing signaling on each individual sample.")
        } else if (sample.use %in% unique(samples)) {
          coordinates = coordinates[samples == sample.use, ]
          labels = labels[samples == sample.use]
        } else {
          stop("Please check the input `sample.use`, which should be the element in `meta$samples`.")
        }
      }
      temp_coordinates = coordinates
      coordinates[,1] = temp_coordinates[,2]
      coordinates[,2] = temp_coordinates[,1]
    } else {
      stop("Please check the input 'coordinates' and make sure it is a two column matrix.")
    }

    cells.level <- levels(labels)
    if (!is.null(idents.use)) {
      if (is.numeric(idents.use)) {
        idents.use <- cells.level[idents.use]
      }
      cell.use <- !(labels %in% idents.use)
      labels[cell.use] <- NA
      cells.level <- cells.level[cells.level %in% idents.use]
      labels <- factor(labels, levels = cells.level)
    }
    if (is.null(sources.use) & is.null(targets.use)) {
      if (is.null(color.use)) {
        color.use <- scPalette(nlevels(labels))
      }
    }
    else {
      if (is.numeric(sources.use)) {
        sources.use <- cells.level[sources.use]
      }
      if (is.numeric(targets.use)) {
        targets.use <- cells.level[targets.use]
      }
      group <- rep("Others", length(labels))
      group[(labels %in% sources.use)] <- sources.use
      group[(labels %in% targets.use)] <- targets.use
      group = factor(group, levels = c(sources.use, targets.use,
                                       "Others"))
      if (is.null(color.use)) {
        color.use.all <- scPalette(nlevels(labels))
        color.use <- color.use.all[match(c(sources.use,
                                           targets.use), levels(labels))]
        color.use[nlevels(group)] <- "grey90"
      }
      labels <- group
    }
    # print(color.use)->return a color vector
    coordinates$cell_labels <- labels

    py <- plotly::highlight_key(coordinates,~cell_labels) %>%
      plotly::plot_ly(x = ~x_cent, y = ~y_cent,marker = list(size = point.size)) %>%
      plotly::add_markers(color=~cell_labels,alpha=alpha,colors=color.use) %>%
      plotly::layout(
        title = title.name,
        yaxis = list(
          autorange = "reversed",
          title = "",
          showgrid = FALSE,
          ticks = "",
          # ticktext = "",
          tickvals = "",
          showline = FALSE
        ),
        xaxis = list(
          title = "",
          showgrid = FALSE,
          ticks = "",
          # ticktext = "",
          tickvals = "",
          showline = FALSE
        )
      ) %>%
      plotly::highlight(on = "plotly_click",
                off = "plotly_relayout")

    return(py)
  }

  # interactive spatialFeaturePlot
  # https://plotly.com/r/subplots/
  plotly_spatialFeaturePlot <- function (object,
                                  features = NULL,
                                  signaling = NULL,
                                  pairLR.use = NULL,
                                  sample.use = NULL,
                                  enriched.only = TRUE,
                                  thresh = 0.05,
                                  do.group = TRUE,
                                  color.heatmap = "Reds",
                                  n.colors = 8,
                                  direction = -1,
                                  do.binary = FALSE,
                                  cutoff = NULL,
                                  color.use = NULL,
                                  alpha = 1,
                                  point.size = 0.8,
                                  legend.size = 3,
                                  legend.text.size = 8,
                                  shape.by = 16,
                                  plot_nrows = 1,
                                  show.legend = TRUE,
                                  show.legend.combined = FALSE){
    coords <- as.data.frame(object@images$coordinates)
    samples <- object@meta$samples
    cell_labels <- object@idents
    data <- as.matrix(object@data)
    meta <- object@meta

    if (ncol(coords) == 2) {
      colnames(coords) <- c("x_cent","y_cent")
      if (length(unique(samples)) > 1) {
        if (is.null(sample.use)) {
          stop("`sample.use` should be provided for visualizing signaling on each individual sample.")
        } else if (sample.use %in% unique(samples)) {
          coords = coords[samples == sample.use, ]
          meta = meta[samples == sample.use, ]
          data = data[, samples == sample.use]
        } else {
          stop("Please check the input `sample.use`, which should be the element in `meta$samples`.")
        }
      }
      temp_coords = coords
      coords[,1] = temp_coords[,2]
      coords[,2] = temp_coords[,1]
    } else {
      stop("Please check the input 'coordinates' and make sure it is a two column matrix.")
    }

    # add idents info

    if (length(color.heatmap) == 1) {
      colormap <- tryCatch({
        RColorBrewer::brewer.pal(n = n.colors, name = color.heatmap)
      }, error = function(e) {
        (scales::viridis_pal(option = color.heatmap, direction = -1))(n.colors)
      })
      if (direction == -1) {
        colormap <- rev(colormap)
      }
      colormap <- colorRampPalette(colormap)(99)
      colormap[1] <- "#E5E5E5"
    }
    else {
      colormap <- color.heatmap
    }
    if (is.null(features) &
        is.null(signaling) & is.null(pairLR.use)) {
      stop("Please input either features, signaling or pairLR.use.")
    }
    if (!is.null(features) & !is.null(signaling)) {
      stop("Please don't input features or signaling simultaneously.")
    }
    if (!is.null(features) & !is.null(pairLR.use)) {
      stop("Please don't input features or pairLR.use simultaneously.")
    }
    if (!is.null(signaling) & !is.null(pairLR.use)) {
      stop("Please don't input signaling or pairLR.use simultaneously.")
    }
    df <- data.frame(x = coords[, 1], y = coords[, 2],
                     cell_labels = cell_labels)

    if (!do.binary) {
      if (!is.null(signaling)) {
        res <- extractEnrichedLR(
          object,
          signaling = signaling,
          geneLR.return = TRUE,
          enriched.only = enriched.only,
          thresh = thresh
        )
        feature.use <- res$geneLR
      }
      else if (!is.null(pairLR.use)) {
        if (is.character(pairLR.use)) {
          pairLR.use <- data.frame(interaction_name = pairLR.use)
        }
        if (enriched.only) {
          if (do.group) {
            object@net$prob[object@net$pval > thresh] <- 0
            pairLR.use.name <-
              pairLR.use$interaction_name[pairLR.use$interaction_name %in%
                                            dimnames(object@net$prob)[[3]]]
            prob <- object@net$prob[, , pairLR.use.name,
                                    drop = FALSE]
            prob.sum <- apply(prob > 0, 3, sum)
            names(prob.sum) <- pairLR.use.name
            signaling.includes <- names(prob.sum)[prob.sum >
                                                    0]
            pairLR.use <- pairLR.use[pairLR.use$interaction_name %in%
                                       signaling.includes, , drop = FALSE]
          }
          else {
            pairLR.use.name <-
              pairLR.use$interaction_name[pairLR.use$interaction_name %in%
                                            dimnames(object@net$prob.cell)[[3]]]
            prob.cell <- object@net$prob.cell[, , pairLR.use.name,
                                              drop = FALSE]
            prob.sum <- apply(prob.cell > 0, 3, sum)
            names(prob.sum) <- pairLR.use.name
            signaling.includes <- names(prob.sum)[prob.sum >
                                                    0]
            pairLR.use <- pairLR.use[pairLR.use$interaction_name %in%
                                       signaling.includes, , drop = FALSE]
          }
          if (length(pairLR.use$interaction_name) == 0) {
            stop(
              paste0(
                "There is no significant communication related with the input `pairLR.use`. Set `enriched.only = FALSE` to show non-significant signaling."
              )
            )
          }
        }
        LR.pair <- object@LR$LRsig[pairLR.use$interaction_name,
                                   c("ligand", "receptor")]
        geneL <- unique(LR.pair$ligand)
        geneR <- unique(LR.pair$receptor)
        geneL <- extractGeneSubset(geneL, object@DB$complex,
                                   object@DB$geneInfo)
        geneR <- extractGeneSubset(geneR, object@DB$complex,
                                   object@DB$geneInfo)
        feature.use <- c(geneL, geneR)
      }
      else {
        feature.use <- features
      }
      if (length(intersect(feature.use, rownames(data))) >
          0) {
        feature.use <- feature.use[feature.use %in% rownames(data)]
        data.use <- data[feature.use, , drop = FALSE]
      }
      else if (length(intersect(feature.use, colnames(meta))) >
               0) {
        feature.use <- feature.use[feature.use %in% colnames(meta)]
        data.use <- t(meta[, feature.use, drop = FALSE])
      }
      else {
        stop("Please check your input! ")
      }
      if (!is.null(cutoff)) {
        cat("Applying a cutoff of ", cutoff, "to the values...",
            "\n")
        data.use[data.use <= cutoff] <- 0
      }

      numFeature = length(feature.use)
      gg <- vector("list", numFeature)

      plot_ncols <- ceiling(numFeature / plot_nrows)
      plot_width <- 1 / plot_ncols
      plot_height <- 1 / plot_nrows
      annotations_pos <- vector("list", 0)
      for (i in 1:plot_nrows) {
        for (j in 1:plot_ncols) {
          x <- (j - 0.5) * plot_width
          y <- 1-(i - 0.95) * plot_height
          annotations_pos[[length(annotations_pos)+1]] <- list(
            x=x,
            y=y
          )
        }

      }
      annotations <- vector("list", numFeature)

      for (i in seq_len(numFeature)) {
        feature.name <- feature.use[i]
        df$feature.data <- data.use[i,]
        g <-
          ggplot(data = df, aes(x, y)) + geom_point(
            aes(colour = feature.data,cell_labels=cell_labels),
            alpha = alpha,
            size = point.size,
            shape = shape.by
          ) +
          scale_colour_gradientn(
            colours = colormap,
            guide = guide_colorbar(
              title = NULL,
              ticks = T,
              label = T,
              barwidth = 0.5
            ),
            na.value = "grey90"
          ) +
          theme(legend.position = "right") + theme(
            legend.title = element_blank(),
            legend.text = element_text(size = legend.text.size),
            legend.key.size = unit(0.15, "inches")
          ) + ggtitle(feature.name) +
          theme(plot.title = element_text(
            hjust = 0.5,
            vjust = 0,
            size = 10
          )) + theme(
            panel.background = element_blank(),
            axis.ticks = element_blank(),
            axis.text = element_blank()
          ) +
          xlab(NULL) + ylab(NULL) + theme(legend.key = element_blank())
        g <- g + coord_fixed() +
          scale_y_reverse()

        gg[[i]] <- g %>% plotly::ggplotly(height = 400)

        annotations[[i]] <- list(
          x=annotations_pos[[i]]$x,
          y=annotations_pos[[i]]$y,
          text = feature.name,
          xref = "paper",
          yref = "paper",
          xanchor = "center",
          yanchor = "top",
          showarrow = FALSE,
          font = list(size = 16))
      }
      # print(annotations_pos)
      if (numFeature > 1) {
        gg <- plotly::subplot(gg, nrows = plot_nrows,margin = 0.02,shareX = FALSE,shareY = FALSE) %>%
          plotly::layout(title = '',annotations = annotations)
      }
      else {
        gg <- plotly::ggplotly(gg[[1]])
      }
    }
    else {
      # do.binary
      set_individual_legend <- function(plt) {
        # plt is a plotly plot obj
        plt_build <- plotly::plotly_build(plt)

        # get the num of traces
        len_legend <- length(plt_build$x$data)

        for (i in 1:len_legend) {
          # set legendgroup
          plt_build$x$data[[i]]$legendgroup <- feature.name
          # set legendtitle
          plt_build$x$data[[i]]$legendgrouptitle <- list(text=feature.name,font=list(size=12))
        }
        return(plt_build)
      }
      if (is.null(color.use)) {
        color.use <- ggPalette(4)
        color.use[4] <- "grey90"
      }
      color.use1 = color.use
      if (!is.null(signaling)) {
        res <- extractEnrichedLR(
          object,
          signaling = signaling,
          enriched.only = enriched.only,
          thresh = thresh
        )
        LR.pair <- object@LR$LRsig[res$interaction_name,
                                   c("ligand", "receptor")]
      }
      else if (!is.null(pairLR.use)) {
        if (is.character(pairLR.use)) {
          pairLR.use <- data.frame(interaction_name = pairLR.use)
        }
        if (enriched.only) {
          if (do.group) {
            object@net$prob[object@net$pval > thresh] <- 0
            pairLR.use.name <-
              pairLR.use$interaction_name[pairLR.use$interaction_name %in%
                                            dimnames(object@net$prob)[[3]]]
            prob <- object@net$prob[, , pairLR.use.name,
                                    drop = FALSE]
            prob.sum <- apply(prob > 0, 3, sum)
            names(prob.sum) <- pairLR.use.name
            signaling.includes <- names(prob.sum)[prob.sum >
                                                    0]
            pairLR.use <- pairLR.use[pairLR.use$interaction_name %in%
                                       signaling.includes, , drop = FALSE]
          }
          else {
            pairLR.use.name <-
              pairLR.use$interaction_name[pairLR.use$interaction_name %in%
                                            dimnames(object@net$prob.cell)[[3]]]
            prob.cell <- object@net$prob.cell[, , pairLR.use.name,
                                              drop = FALSE]
            prob.sum <- apply(prob.cell > 0, 3, sum)
            names(prob.sum) <- pairLR.use.name
            signaling.includes <- names(prob.sum)[prob.sum >
                                                    0]
            pairLR.use <- pairLR.use[pairLR.use$interaction_name %in%
                                       signaling.includes, , drop = FALSE]
          }
          if (length(pairLR.use$interaction_name) == 0) {
            stop(
              paste0(
                "There is no significant communication related with the input `pairLR.use`. Set `enriched.only = FALSE` to show non-significant signaling."
              )
            )
          }
        }
        LR.pair <- object@LR$LRsig[pairLR.use$interaction_name,
                                   c("ligand", "receptor")]
      }
      else {
        stop("Please input either `pairLR.use` or `signaling` for `binary` mode!")
      }
      geneL <- as.character(LR.pair$ligand)
      geneR <- as.character(LR.pair$receptor)
      complex_input <- object@DB$complex
      dataL <- computeExpr_LR(geneL, data, complex_input)
      dataR <- computeExpr_LR(geneR, data, complex_input)
      rownames(dataL) <- geneL
      rownames(dataR) <- geneR

      feature.use <- rownames(LR.pair)
      numFeature = nrow(LR.pair)

      if (is.null(cutoff)) {
        stop("A `cutoff` must be provided when plotting expression in binary mode! ")
      }
      gg <- vector("list", numFeature)

      # set subplot title pos
      plot_ncols <- ceiling(numFeature / plot_nrows)
      plot_width <- 1 / plot_ncols
      plot_height <- 1 / plot_nrows
      annotations_pos <- vector("list", 0)
      for (i in 1:plot_nrows) {
        for (j in 1:plot_ncols) {
          x <- (j - 0.5) * plot_width
          y <- 1-(i - 1) * plot_height
          annotations_pos[[length(annotations_pos)+1]] <- list(
            x=x,
            y=y
          )
        }

      }
      annotations <- vector("list", numFeature)

      for (i in seq_len(numFeature)) {
        feature.name <- feature.use[i]
        idx1 = dataL[i,] > cutoff
        idx2 = dataR[i,] > cutoff
        idx3 = idx1 & idx2
        group = rep("None", ncol(dataL))
        group[idx1] = geneL[i]
        group[idx2] = geneR[i]
        group[idx3] = "Both"
        group = factor(group, levels = c(geneL[i], geneR[i],
                                         "Both", "None"))
        color.use <- color.use1
        names(color.use) <- c(geneL[i], geneR[i], "Both",
                              "None")
        if (length(setdiff(levels(group), unique(group))) >
            0) {
          color.use <- color.use[names(color.use) %in% unique(group)]
          group = droplevels(group, exclude = setdiff(levels(group),
                                                      unique(group)))
        }
        df$feature.data <- group
        g <-
          ggplot(data = df, aes(x, y)) + geom_point(
            aes(colour = feature.data,cell_labels=cell_labels),
            alpha = alpha,
            size = point.size,
            shape = shape.by
          ) +
          scale_color_manual(values = color.use, na.value = "grey90") +
          theme(legend.position = "right") + theme(
            legend.title = element_blank(),
            legend.text = element_text(size = legend.text.size),
            legend.key.size = unit(0.15, "inches")
          ) + guides(color = guide_legend(override.aes = list(size = legend.size))) +
          ggtitle(feature.name) + theme(plot.title = element_text(
            hjust = 0.5,
            vjust = 0,
            size = 10
          )) + theme(
            panel.background = element_blank(),
            axis.ticks = element_blank(),
            axis.text = element_blank()
          ) +
          xlab(NULL) + ylab(NULL) + theme(legend.key = element_blank())
        g <- g + coord_fixed() +
          scale_y_reverse()

        # cat(feature.name)
        gg[[i]] <- g %>% plotly::ggplotly(
          type = 'scatter',
          mode='markers+text',
        ) %>% set_individual_legend()

        annotations[[i]] <- list(
          x=annotations_pos[[i]]$x,
          y=annotations_pos[[i]]$y,
          text = feature.name,
          xref = "paper",
          yref = "paper",
          xanchor = "center",
          yanchor = "top",
          showarrow = FALSE,
          font = list(size = 16))
      }

      if (numFeature > 1) {
        gg <- plotly::subplot(gg, nrows = plot_nrows,margin = 0.02,shareX = FALSE,shareY = FALSE) %>%
          plotly::layout(title = '',
                 annotations = annotations,
                 legend = list(tracegroupgap = 10,title=list(text=''))
          )
      }
      else {
        gg <- plotly::ggplotly(gg[[1]],
                               type = 'scatter',
                               mode = 'markers') %>%
          plotly::layout(legend = list(title = list(text = '')))
      }
    }
    return(gg)
  }

  # ##########################################################################
  # Shiny App's UI
  # ##########################################################################
  ui <- fluidPage(
    theme =  bslib::bs_theme(version = 5),
    # ##########################################################################
    # meta info of the HTML pages
    # ##########################################################################
    tags$head(
      # title
      tags$title("Interactive CellChat Explorer"),
      # icon
      tags$link(rel = "shortcut icon", type = "image/x-icon", href = "favicon.ico"),
      tags$link(rel="stylesheet",href="https://cdn.jsdelivr.net/npm/bootstrap-icons@1.10.5/font/bootstrap-icons.css"),
    ),
    tags$body(
      # ##########################################################################
      # logo and title of the website
      # ##########################################################################
      tags$nav(class="navbar navbar-light bg-light",
               div(class="container-fluid justify-content-center",
                   tags$a(
                     class="navbar-brand",href="http://www.cellchat.org/",
                     img(src="https://s2.loli.net/2023/08/08/2qjSoRACDtHByOY.png",class="d-inline",alt="",height="30"),
                     tags$p("Interactive CellChat Explorer",class="fs-1 d-inline")
                   )

               )),
      # ##########################################################################
      # 1.Basic exploration of spatial-resolved gene expression
      # ##########################################################################

      # Visualize cell groups and signaling expression
      h3(tags$i(class="bi bi-1-square-fill"),
         "Visualize cell groups and signaling expression",class="h3"),
      bslib::card(
        bslib::card_header(
          h6(tags$i(class="bi bi-bookmark"),
             "Dim Plot",class="h6")),
        layout_sidebar(
          sidebar = accordion(
            accordion_panel(
              "Numerical",
              icon = bsicons::bs_icon("sliders"),
              sliderInput(
                "dimplot_point_size",
                label = "Point size",
                min = 3,
                max = 8,
                step = 0.5,
                value = 3
              ),
              sliderInput(
                "dimplot_alpha",
                label = "Alpha",
                min = 0,
                max = 1,
                step = 0.2,
                value = 1
              ),
            )
          ),
          div(class="d-flex justify-content-center",
              plotly::plotlyOutput(outputId = "DimPlot",
                           width = 664,height = 498)
          )

        ),

      ),

      # gene expression distribution
      # https://shiny.posit.co/r/gallery/widgets/datatables-options/
      # https://shiny.posit.co/r/gallery/widgets/selectize-examples/
      navset_card_tab(
        title = h6(tags$i(class="bi bi-bookmark-dash"),
                   "Feature Plot",class="h6"),
        sidebar = NULL,
        # content
        nav_panel(
          title = "use gene names",
          layout_sidebar(
            sidebar = accordion(
              accordion_panel(
                "Select",
                icon = bsicons::bs_icon("menu-app"),
                selectizeInput(
                  inputId = 'selectize_gene_names',
                  label = 'Gene Names',
                  choices = NULL,
                  multiple = TRUE,
                  # options = list(maxItems = 4)
                ),
                numericInput(
                  "nrows_feature_plot1",
                  label = "nrows",
                  min = 1,
                  step = 1,
                  value = 1,
                ),
              ),

              accordion_panel(
                title = "Color",
                icon = tags$i(class="bi bi-palette-fill"),
                selectInput(
                  "direction_feature_plot1",
                  label = "direction",
                  choices = list("1"=1,"-1"=-1),
                  selected = 1,
                  multiple = F
                ),
                selectInput(
                  "palette_feature_plot1",
                  label = "palette",
                  choices = c(choices_palettes_diverging,choices_palettes_sequential),
                  selected = "Reds",
                  multiple = F
                ),
              ),

              accordion_panel(
                title = "Numerical",
                icon = bsicons::bs_icon("sliders"),
                numericInput(
                  "cut.off_feature_plot1",
                  label = "cut.off",
                  min = 0,
                  step = 0.1,
                  value = 0,
                ),
                sliderInput(
                  "point.size_feature_plot1",
                  label = "point.size",
                  min = 0,
                  max = 2,
                  step = 0.1,
                  value = 0.4
                )
              )

            ),
            # nav content
            div(class="d-flex justify-content-center",
                plotly::plotlyOutput(outputId = "gene_expression_distribution",width = 664,height = 498),
            ),
          )
        ),
        nav_panel(
          title = "use L-R pairs",
          layout_sidebar(
            sidebar = accordion(
              accordion_panel(
                "Select",
                icon = bsicons::bs_icon("menu-app"),
                selectizeInput(
                  inputId = 'selectize_pairLR_use',
                  label = 'pairLR_use',
                  choices = NULL,
                  multiple = T
                ),
                numericInput(
                  "nrows_feature_plot2",
                  label = "nrows",
                  min = 1,
                  step = 1,
                  value = 1,
                ),
                checkboxInput(
                  "do.binary_feature_plot",
                  label = "do.binary",
                  value = TRUE),
              ),
              accordion_panel(
                title = "Color",
                icon = tags$i(class="bi bi-palette-fill"),
                selectInput(
                  "direction_feature_plot2",
                  label = "direction",
                  choices = list("1"=1,"-1"=-1),
                  selected = 1,
                  multiple = F
                ),
                selectInput(
                  "palette_feature_plot2",
                  label = "palette",
                  choices = c(choices_palettes_diverging,choices_palettes_sequential),
                  selected = "Reds",
                  multiple = F
                ),
              ),

              accordion_panel(
                title = "Numerical",
                icon = bsicons::bs_icon("sliders"),
                numericInput(
                  "cut.off_feature_plot2",
                  label = "cut.off",
                  min = 0,
                  step = 0.1,
                  value = 0,
                ),
                sliderInput(
                  "point.size_feature_plot2",
                  label = "point.size",
                  min = 0,
                  max = 2,
                  step = 0.1,
                  value = 0.4
                )
              )
            ),
            # nav content
            div(class="d-flex justify-content-center",
                plotly::plotlyOutput(outputId = "gene_expression_distribution2",width = 664,height = 498)
            )
          ),
        )
      ),

      # ##########################################################################
      # 2.Examine signaling between cell groups
      # ##########################################################################
      h2(tags$i(class="bi bi-2-square-fill"),
         "Examine signaling between cell groups"),
      navset_card_tab(
        title = NULL,
        sidebar = NULL,
        nav_panel("Heatmap",
                  layout_sidebar(
                    sidebar = accordion(
                      h6("The number of interactions/interaction strength between any two cell groups",
                         class="h6"),
                      hr(),

                      accordion_panel(
                        "Select",
                        icon = bsicons::bs_icon("menu-app"),
                        selectInput(
                          "measure_heatmap",
                          label = "measurement",
                          choices = list("count" = "count", "weight" = "weight"),
                          selected = "count"
                        ),
                        selectInput(
                          "palette_heatmap",
                          label = "palette (sequential)",
                          choices = choices_palettes_sequential,
                          selected = "Blues"
                        ),
                        # Sets the order of colours in the scale. If 1, the default, colours are as output by RColorBrewer::brewer.pal(). If -1, the order of colours is reversed.
                        selectInput(
                          "direction_heatmap",
                          label = "direction",
                          choices = list(
                            "1"=1,
                            "-1"=-1
                          ),
                          selected = 1,
                        )

                        # refer to: https://ggplot2.tidyverse.org/reference/scale_brewer.html
                      ),
                    ),

                    # content
                    div(class="d-flex justify-content-center",
                        plotly::plotlyOutput(outputId = "netVisual_heatmap",width = 664,height = 498)
                    )
                  )
        ),

        # the enriched signaling among one selected pair of cell groups
        nav_panel("rankNet",
                  layout_sidebar(
                    sidebar = accordion(
                      h6("The enriched signaling",
                         class="h6"),
                      hr(),
                      accordion_panel(
                        "Select",
                        icon = bsicons::bs_icon("menu-app"),
                        selectInput(
                          "select1_cell_group",
                          label = "cell groups for sources.use",
                          choices = choices_cell_groups,
                          selected = choices_cell_groups[1],
                          multiple = TRUE
                        ),
                        selectInput(
                          "select2_cell_group",
                          label = "cell groups for targets.use",
                          choices = choices_cell_groups,
                          selected = choices_cell_groups[2],
                          multiple = TRUE
                        ),

                        # selectInput(
                        #   "measure_ranknet",
                        #   label = "measurement",
                        #   choices = list("count" = "count", "weight" = "weight"),
                        #   selected = "count"
                        # ),
                        selectInput(
                          "slot.name_ranknet",
                          label = "slot.name",
                          choices = list("net" = "net", "netP" = "netP"),
                          selected = "netP"
                        ),
                        # selectInput(
                        #   "palette_ranknet",
                        #   label = "palette (sequential)",
                        #   choices = choices_palettes_sequential,
                        #   selected = "Blues"
                        # ),
                      ),
                    ),

                    # content
                    plotly::plotlyOutput(outputId = "rankNet")
                  )
        ),
        nav_panel("Contribution Plot",
                  layout_sidebar(
                    sidebar = accordion(
                      h6("Contribution of each L-R pair to overall signaling",
                         class = "h6"),
                      hr(),
                      accordion_panel(
                        "Select",
                        icon = bsicons::bs_icon("menu-app"),
                        selectInput(
                          "pathway_contribution_plot",
                          label = "a pathway to show",
                          choices = choices_pathways,
                          selected = choices_pathways[1]
                        ),
                        selectInput(
                          "select3_cell_group",
                          label = "a cell group for sources.use",
                          choices = choices_cell_groups,
                          selected = choices_cell_groups[1]
                        ),
                        selectInput(
                          "select4_cell_group",
                          label = "a cell group for targets.use",
                          choices = choices_cell_groups,
                          selected = choices_cell_groups[2]
                        ),
                      ),

                      accordion_panel(
                        title = "Numerical",
                        icon = bsicons::bs_icon("sliders"),
                        sliderInput(
                          "font.size_contribution_plot",
                          label = "font.size",
                          min = 10,
                          max=30,
                          step = 5,
                          value = 20
                        )
                      )
                    ),

                    # content
                    plotOutput(outputId = "netAnalysis_contribution"),
                  )
        ),
      ),

      # Contribution of each L-R pair to overall signaling
      # width = 3.2inch, height = 1.5inch,
      # height might change dependent on dataset

      ## Examine individual signaling pathway
      ## (the following four plots will be appeared based on user's input)
      h2(tags$i(class="bi bi-3-square-fill"),
         "Examine individual signaling pathway"),
      navset_card_tab(
        title = h6("Plots",class="h6"),
        sidebar = accordion(
          selectizeInput(
            inputId = 'selectize_pathway',
            label = 'Select a pathway to show',
            choices = NULL,
            multiple = FALSE
          ),
          hr(),
          accordion_panel(
            title = "Circle plot",
            icon = tags$i(class="bi bi-circle-fill"),
            # edge.width.max = 5, vertex.size.max = 12, vertex.label.cex = 0.8
            sliderInput(
              "slider_Circle_plot_edge.width.max",
              label = "edge.width.max",
              min = 5,
              max = 15,
              value = 8,
              step = 1
            ),
            sliderInput(
              "slider_Circle_plot_vertex.size.max",
              label = "vertex.size.max",
              min = 8,
              max = 16,
              value = 12,
              step = 2),
            sliderInput(
              "slider_Circle_plot_vertex.label.cex",
              label = "vertex.label.cex",
              min = 1,
              max = 2,
              value = 1,
              step = 0.2
            ),
          ),
          accordion_panel(
            title = "Spatial plot",
            icon = tags$i(class="bi bi-layers-half"),
            # edge.width.max = 5, vertex.size.max = 1,
            # point.size = 2.5,
            # alpha.image = 0.2, vertex.label.cex = 5
            sliderInput(
              "slider_Spatial_plot_edge.width.max",
              label = "edge.width.max",
              min = 2,
              max = 8,
              value = 5,
              step = 1
            ),
            sliderInput(
              "slider_Spatial_plot_vertex.size.max",
              label = "vertex.size.max",
              min = 2,
              max = 8,
              value = 5,
              step = 1),
            sliderInput(
              "slider_Spatial_plot_vertex.label.cex",
              label = "vertex.label.cex",
              min = 5,
              max = 10,
              value = 8,
              step = 1
            ),

            sliderInput(
              "slider_Spatial_plot_point.size",
              label = "point.size",
              min = 1,
              max = 3,
              value = 2.4,
              step = 0.2
            ),
            sliderInput(
              "slider_Spatial_plot_alpha.image",
              label = "alpha.image",
              min = 0,
              max = 1,
              value = 0.2,
              step = 0.05
            ),
          ),
          accordion_panel(
            title = "Contribution of each L-R pair",
            icon = tags$i(class="bi bi-bar-chart-fill"),
          ),
        ),

        # nav tab
        nav_panel(
          title = "Circle plot",
          div(class="d-flex justify-content-center",
              plotOutput(outputId = "Circle_plot",
                         height = "780px",width = "580px")
          )
        ),
        nav_panel(
          title = "Spatial plot",
          div(class="d-flex justify-content-center",
              plotOutput(outputId = "Spatial_plot",
                         height = "780px",width = "580px")
          )
        ),
        nav_panel(
          title = "Contribution of each L-R pair",
          plotly::plotlyOutput(outputId = "LR_pair_contribution",
                       height = "900px")
        ),

      ),
      # body

    ),
    # page
  )
  # ##########################################################################
  # Shiny App's Server
  # ##########################################################################
  server <- function(input, output, session) {
    ############################################################################
    if (object@options$datatype == "RNA") {
      output$DimPlot <- plotly::renderPlotly({
        plotly_DimPlot(
          object,
          point.size = input$dimplot_point_size,
          alpha = input$dimplot_alpha,
        ) %>%
          plotly::config(toImageButtonOptions = list(
            format = "svg",
            filename = "DimPlot",
            width = 800,
            height = 600
          ))
      })
    } else {
      output$spatialDimPlot <- plotly::renderPlotly({
        plotly_spatialDimPlot(
          object,
          point.size = input$dimplot_point_size,
          alpha = input$dimplot_alpha,
        ) %>%
          plotly::config(toImageButtonOptions = list(
            format = "svg",
            filename = "spatialDimPlot",
            width = 800,
            height = 600
          ))
      })
    }

    observe({
      updateSelectizeInput(
        session,
        "selectize_gene_names",
        # selected = c("Wnt10a", "Fzd1", "Lrp6"),
        selected = choices_gene_names[1:2],
        # selected = c("Wnt10a", "Fzd1", "Lrp6","Ror2",
        #              "Nrp1","Nrp2","Bmpr2","Ret"),
        choices = choices_gene_names,
        server = TRUE
      )
    })
    # output$out6 <- renderPrint(input$selectize_gene_names)

    if (object@options$datatype == "RNA") {
      output$gene_expression_distribution <- plotly::renderPlotly(plotly_FeaturePlot(
        object,
        features = input$selectize_gene_names,
        plot_nrows = input$nrows_feature_plot1,
        point.size = input$point.size_feature_plot1,
        cutoff = input$cut.off_feature_plot1,
        color.heatmap = input$palette_feature_plot1,
        direction = input$direction_feature_plot1,
      ) %>%
        plotly::config(toImageButtonOptions = list(
          format = "svg",
          filename = "FeaturePlot (use gene names)",
          width = 600,
          height = 600
        ))
      )
    } else {
      output$gene_expression_distribution <- plotly::renderPlotly(plotly_spatialFeaturePlot(
        object,
        features = input$selectize_gene_names,
        plot_nrows = input$nrows_feature_plot1,
        point.size = input$point.size_feature_plot1,
        cutoff = input$cut.off_feature_plot1,
        color.heatmap = input$palette_feature_plot1,
        direction = input$direction_feature_plot1,
      ) %>%
        plotly::config(toImageButtonOptions = list(
          format = "svg",
          filename = "spatialFeaturePlot (use gene names)",
          width = 600,
          height = 600
        ))
      )
    }

    observe({
      updateSelectizeInput(
        session,
        "selectize_pairLR_use",
        selected = choices_pairLR_use[1],
        # selected = c("WNT10A_FZD1_LRP6","WNT10A_FZD10_LRP6","BMP2_BMPR1A_ACVR2A"),
        choices = choices_pairLR_use,
        server = TRUE
      )
    })
    # output$out7 <- renderPrint(input$selectize_pairLR_use)
    if (object@options$datatype == "RNA") {
      output$gene_expression_distribution2 <- plotly::renderPlotly({
        plotly_FeaturePlot(
          object,
          pairLR.use = input$selectize_pairLR_use,
          point.size = input$point.size_feature_plot2,
          do.binary = input$do.binary_feature_plot,
          cutoff = input$cut.off_feature_plot2,
          enriched.only = F,
          color.heatmap = input$palette_feature_plot2,
          direction = input$direction_feature_plot2,
          plot_nrows = as.numeric(input$nrows_feature_plot2)
        ) %>%
          plotly::config(toImageButtonOptions = list(
            format = "svg",
            filename = "FeaturePlot(use pairLRs)",
            width = 600,
            height = 600
          ))
      })
    } else {
      output$gene_expression_distribution2 <- plotly::renderPlotly({
        plotly_spatialFeaturePlot(
          object,
          pairLR.use = input$selectize_pairLR_use,
          point.size = input$point.size_feature_plot2,
          do.binary = input$do.binary_feature_plot,
          cutoff = input$cut.off_feature_plot2,
          enriched.only = F,
          color.heatmap = input$palette_feature_plot2,
          direction = input$direction_feature_plot2,
          plot_nrows = as.numeric(input$nrows_feature_plot2)
        ) %>%
          plotly::config(toImageButtonOptions = list(
            format = "svg",
            filename = "spatialFeaturePlot(use pairLRs)",
            width = 600,
            height = 600
          ))
      })
    }

    ############################################################################
    output$netVisual_heatmap <- plotly::renderPlotly({
      suppressWarnings({
        netVisual_heatmap(object,
                          measure = input$measure_heatmap,
        ) %>%
          plotly_netVisual_heatmap(
            palette.heatmap = input$palette_heatmap,
            direction.heatmap = input$direction_heatmap)
      })
    })

    output$rankNet <- plotly::renderPlotly({
      rankNet(
        object,
        mode = "single",
        measure = "weight",
        sources.use = input$select1_cell_group,
        targets.use = input$select2_cell_group,
        slot.name = input$slot.name_ranknet
      ) %>%
        plotly::ggplotly()
    })

    output$netAnalysis_contribution <- renderPlot({
      netAnalysis_contribution(
        object,
        signaling = input$pathway_contribution_plot,
        sources.use = input$select3_cell_group,
        targets.use = input$select4_cell_group,
        font.size = input$font.size_contribution_plot,
        font.size.title = input$font.size_contribution_plot,
      )
    },res = 96)
    ############################################################################
    observe({
      updateSelectizeInput(
        session,
        "selectize_pathway",
        selected = choices_pathways[1],
        choices = choices_pathways,
        server = TRUE
      )
    })
    output$Circle_plot <- renderPlot({
      netVisual_aggregate(
        object,
        signaling = input$selectize_pathway,
        layout = "circle",
        edge.width.max = input$slider_Circle_plot_edge.width.max,
        vertex.size.max = input$slider_Circle_plot_vertex.size.max,
        vertex.label.cex = input$slider_Circle_plot_vertex.label.cex
      )
    },res = 96)
    output$Spatial_plot <- renderPlot({
      netVisual_aggregate(
        object,
        signaling = input$selectize_pathway,
        layout = "spatial",
        edge.width.max = input$slider_Spatial_plot_edge.width.max,
        vertex.size.max = input$slider_Spatial_plot_vertex.size.max,
        vertex.label.cex = input$slider_Spatial_plot_vertex.label.cex,
        alpha.image = input$slider_Spatial_plot_alpha.image,
        point.size = input$slider_Spatial_plot_point.size,
      )
    })
    output$LR_pair_contribution <- plotly::renderPlotly({
      netAnalysis_contribution(
        object,
        signaling = input$selectize_pathway,
        font.size = 12,
        font.size.title = 14
      )
    })
    ############################################################################
  }

  # Running a Shiny app
  shinyApp(ui = ui, server = server,...)
}

function (object,
                                  features = NULL,
                                  signaling = NULL,
                                  pairLR.use = NULL,
                                  sample.use = NULL,
                                  reduction = NULL,
                                  enriched.only = TRUE,
                                  thresh = 0.05,
                                  do.group = TRUE,
                                  color.heatmap = "Reds",
                                  n.colors = 8,
                                  direction = -1,
                                  do.binary = FALSE,
                                  cutoff = NULL,
                                  color.use = NULL,
                                  alpha = 1,
                                  point.size = 0.8,
                                  legend.size = 3,
                                  legend.text.size = 8,
                                  shape.by = 16,
                                  plot_nrows = 1,
                                  show.legend = TRUE,
                                  show.legend.combined = FALSE){
    if (!is.null(reduction)) {
      coords <- object@dr[[reduction]]
    } else {
      if ("umap" %in% names(object@dr)) {
        coords <- object@dr$umap
      } else if ("tsne" %in% names(object@dr)){
        coords <- object@dr$tsne
      } else {
        stop("Please make sure `object@dr` contains a low-dimensional space of the data and specify the dimensionality reduction to use.")
      }
    }
    samples <- object@meta$samples
    cell_labels <- object@idents
    data <- as.matrix(object@data)
    meta <- object@meta
    coords <- as.data.frame(coords)
    if (ncol(coords) >= 2) {
      coords <- coords[, c(1,2)]
      colnames(coords) <- c("x_cent","y_cent")
      if (length(unique(samples)) > 1) {
        if (is.null(sample.use)) {
          stop("`sample.use` should be provided for visualizing signaling on each individual sample.")
        } else if (sample.use %in% unique(samples)) {
          coords = coords[samples == sample.use, ]
          meta = meta[samples == sample.use, ]
          data = data[, samples == sample.use]
        } else {
          stop("Please check the input `sample.use`, which should be the element in `meta$samples`.")
        }
      }
    } else {
      stop("Please check the input 'object@dr' and make sure it has at least two columns.")
    }
    if (length(color.heatmap) == 1) {
      colormap <- tryCatch({
        RColorBrewer::brewer.pal(n = n.colors, name = color.heatmap)
      }, error = function(e) {
        (scales::viridis_pal(option = color.heatmap, direction = -1))(n.colors)
      })
      if (direction == -1) {
        colormap <- rev(colormap)
      }
      colormap <- colorRampPalette(colormap)(99)
      colormap[1] <- "
    }
    else {
      colormap <- color.heatmap
    }
    if (is.null(features) &
        is.null(signaling) & is.null(pairLR.use)) {
      stop("Please input either features, signaling or pairLR.use.")
    }
    if (!is.null(features) & !is.null(signaling)) {
      stop("Please don't input features or signaling simultaneously.")
    }
    if (!is.null(features) & !is.null(pairLR.use)) {
      stop("Please don't input features or pairLR.use simultaneously.")
    }
    if (!is.null(signaling) & !is.null(pairLR.use)) {
      stop("Please don't input signaling or pairLR.use simultaneously.")
    }
    df <- data.frame(x = coords[, 1], y = coords[, 2],
                     cell_labels = cell_labels)
    if (!do.binary) {
      if (!is.null(signaling)) {
        res <- extractEnrichedLR(
          object,
          signaling = signaling,
          geneLR.return = TRUE,
          enriched.only = enriched.only,
          thresh = thresh
        )
        feature.use <- res$geneLR
      }
      else if (!is.null(pairLR.use)) {
        if (is.character(pairLR.use)) {
          pairLR.use <- data.frame(interaction_name = pairLR.use)
        }
        if (enriched.only) {
          if (do.group) {
            object@net$prob[object@net$pval > thresh] <- 0
            pairLR.use.name <-
              pairLR.use$interaction_name[pairLR.use$interaction_name %in%
                                            dimnames(object@net$prob)[[3]]]
            prob <- object@net$prob[, , pairLR.use.name,
                                    drop = FALSE]
            prob.sum <- apply(prob > 0, 3, sum)
            names(prob.sum) <- pairLR.use.name
            signaling.includes <- names(prob.sum)[prob.sum >
                                                    0]
            pairLR.use <- pairLR.use[pairLR.use$interaction_name %in%
                                       signaling.includes, , drop = FALSE]
          }
          else {
            pairLR.use.name <-
              pairLR.use$interaction_name[pairLR.use$interaction_name %in%
                                            dimnames(object@net$prob.cell)[[3]]]
            prob.cell <- object@net$prob.cell[, , pairLR.use.name,
                                              drop = FALSE]
            prob.sum <- apply(prob.cell > 0, 3, sum)
            names(prob.sum) <- pairLR.use.name
            signaling.includes <- names(prob.sum)[prob.sum >
                                                    0]
            pairLR.use <- pairLR.use[pairLR.use$interaction_name %in%
                                       signaling.includes, , drop = FALSE]
          }
          if (length(pairLR.use$interaction_name) == 0) {
            stop(
              paste0(
                "There is no significant communication related with the input `pairLR.use`. Set `enriched.only = FALSE` to show non-significant signaling."
              )
            )
          }
        }
        LR.pair <- object@LR$LRsig[pairLR.use$interaction_name,
                                   c("ligand", "receptor")]
        geneL <- unique(LR.pair$ligand)
        geneR <- unique(LR.pair$receptor)
        geneL <- extractGeneSubset(geneL, object@DB$complex,
                                   object@DB$geneInfo)
        geneR <- extractGeneSubset(geneR, object@DB$complex,
                                   object@DB$geneInfo)
        feature.use <- c(geneL, geneR)
      }
      else {
        feature.use <- features
      }
      if (length(intersect(feature.use, rownames(data))) >
          0) {
        feature.use <- feature.use[feature.use %in% rownames(data)]
        data.use <- data[feature.use, , drop = FALSE]
      }
      else if (length(intersect(feature.use, colnames(meta))) >
               0) {
        feature.use <- feature.use[feature.use %in% colnames(meta)]
        data.use <- t(meta[, feature.use, drop = FALSE])
      }
      else {
        stop("Please check your input! ")
      }
      if (!is.null(cutoff)) {
        cat("Applying a cutoff of ", cutoff, "to the values...",
            "\n")
        data.use[data.use <= cutoff] <- 0
      }
      numFeature = length(feature.use)
      gg <- vector("list", numFeature)
      plot_ncols <- ceiling(numFeature / plot_nrows)
      plot_width <- 1 / plot_ncols
      plot_height <- 1 / plot_nrows
      annotations_pos <- vector("list", 0)
      for (i in 1:plot_nrows) {
        for (j in 1:plot_ncols) {
          x <- (j - 0.5) * plot_width
          y <- 1-(i - 0.95) * plot_height
          annotations_pos[[length(annotations_pos)+1]] <- list(
            x=x,
            y=y
          )
        }
      }
      annotations <- vector("list", numFeature)
      for (i in seq_len(numFeature)) {
        feature.name <- feature.use[i]
        df$feature.data <- data.use[i,]
        g <-
          ggplot(data = df, aes(x, y)) + geom_point(
            aes(colour = feature.data,cell_labels=cell_labels),
            alpha = alpha,
            size = point.size,
            shape = shape.by
          ) +
          scale_colour_gradientn(
            colours = colormap,
            guide = guide_colorbar(
              title = NULL,
              ticks = T,
              label = T,
              barwidth = 0.5
            ),
            na.value = "grey90"
          ) +
          theme(legend.position = "right") + theme(
            legend.title = element_blank(),
            legend.text = element_text(size = legend.text.size),
            legend.key.size = unit(0.15, "inches")
          ) + ggtitle(feature.name) +
          theme(plot.title = element_text(
            hjust = 0.5,
            vjust = 0,
            size = 10
          )) + theme(
            panel.background = element_blank(),
            axis.ticks = element_blank(),
            axis.text = element_blank()
          ) +
          xlab(NULL) + ylab(NULL) + theme(legend.key = element_blank())
        gg[[i]] <- g %>% plotly::ggplotly(height = 400)
        annotations[[i]] <- list(
          x=annotations_pos[[i]]$x,
          y=annotations_pos[[i]]$y,
          text = feature.name,
          xref = "paper",
          yref = "paper",
          xanchor = "center",
          yanchor = "top",
          showarrow = FALSE,
          font = list(size = 16))
      }
      if (numFeature > 1) {
        gg <- plotly::subplot(gg, nrows = plot_nrows,margin = 0.02,shareX = FALSE,shareY = FALSE) %>%
          plotly::layout(title = '',annotations = annotations)
      }
      else {
        gg <- plotly::ggplotly(gg[[1]])
      }
    }
    else {
      set_individual_legend <- function(plt) {
        plt_build <- plotly::plotly_build(plt)
        len_legend <- length(plt_build$x$data)
        for (i in 1:len_legend) {
          plt_build$x$data[[i]]$legendgroup <- feature.name
          plt_build$x$data[[i]]$legendgrouptitle <- list(text=feature.name,font=list(size=12))
        }
        return(plt_build)
      }
      if (is.null(color.use)) {
        color.use <- ggPalette(4)
        color.use[4] <- "grey90"
      }
      color.use1 = color.use
      if (!is.null(signaling)) {
        res <- extractEnrichedLR(
          object,
          signaling = signaling,
          enriched.only = enriched.only,
          thresh = thresh
        )
        LR.pair <- object@LR$LRsig[res$interaction_name,
                                   c("ligand", "receptor")]
      }
      else if (!is.null(pairLR.use)) {
        if (is.character(pairLR.use)) {
          pairLR.use <- data.frame(interaction_name = pairLR.use)
        }
        if (enriched.only) {
          if (do.group) {
            object@net$prob[object@net$pval > thresh] <- 0
            pairLR.use.name <-
              pairLR.use$interaction_name[pairLR.use$interaction_name %in%
                                            dimnames(object@net$prob)[[3]]]
            prob <- object@net$prob[, , pairLR.use.name,
                                    drop = FALSE]
            prob.sum <- apply(prob > 0, 3, sum)
            names(prob.sum) <- pairLR.use.name
            signaling.includes <- names(prob.sum)[prob.sum >
                                                    0]
            pairLR.use <- pairLR.use[pairLR.use$interaction_name %in%
                                       signaling.includes, , drop = FALSE]
          }
          else {
            pairLR.use.name <-
              pairLR.use$interaction_name[pairLR.use$interaction_name %in%
                                            dimnames(object@net$prob.cell)[[3]]]
            prob.cell <- object@net$prob.cell[, , pairLR.use.name,
                                              drop = FALSE]
            prob.sum <- apply(prob.cell > 0, 3, sum)
            names(prob.sum) <- pairLR.use.name
            signaling.includes <- names(prob.sum)[prob.sum >
                                                    0]
            pairLR.use <- pairLR.use[pairLR.use$interaction_name %in%
                                       signaling.includes, , drop = FALSE]
          }
          if (length(pairLR.use$interaction_name) == 0) {
            stop(
              paste0(
                "There is no significant communication related with the input `pairLR.use`. Set `enriched.only = FALSE` to show non-significant signaling."
              )
            )
          }
        }
        LR.pair <- object@LR$LRsig[pairLR.use$interaction_name,
                                   c("ligand", "receptor")]
      }
      else {
        stop("Please input either `pairLR.use` or `signaling` for `binary` mode!")
      }
      geneL <- as.character(LR.pair$ligand)
      geneR <- as.character(LR.pair$receptor)
      complex_input <- object@DB$complex
      dataL <- computeExpr_LR(geneL, data, complex_input)
      dataR <- computeExpr_LR(geneR, data, complex_input)
      rownames(dataL) <- geneL
      rownames(dataR) <- geneR
      feature.use <- rownames(LR.pair)
      numFeature = nrow(LR.pair)
      if (is.null(cutoff)) {
        stop("A `cutoff` must be provided when plotting expression in binary mode! ")
      }
      gg <- vector("list", numFeature)
      plot_ncols <- ceiling(numFeature / plot_nrows)
      plot_width <- 1 / plot_ncols
      plot_height <- 1 / plot_nrows
      annotations_pos <- vector("list", 0)
      for (i in 1:plot_nrows) {
        for (j in 1:plot_ncols) {
          x <- (j - 0.5) * plot_width
          y <- 1-(i - 1) * plot_height
          annotations_pos[[length(annotations_pos)+1]] <- list(
            x=x,
            y=y
          )
        }
      }
      annotations <- vector("list", numFeature)
      for (i in seq_len(numFeature)) {
        feature.name <- feature.use[i]
        idx1 = dataL[i,] > cutoff
        idx2 = dataR[i,] > cutoff
        idx3 = idx1 & idx2
        group = rep("None", ncol(dataL))
        group[idx1] = geneL[i]
        group[idx2] = geneR[i]
        group[idx3] = "Both"
        group = factor(group, levels = c(geneL[i], geneR[i],
                                         "Both", "None"))
        color.use <- color.use1
        names(color.use) <- c(geneL[i], geneR[i], "Both",
                              "None")
        if (length(setdiff(levels(group), unique(group))) >
            0) {
          color.use <- color.use[names(color.use) %in% unique(group)]
          group = droplevels(group, exclude = setdiff(levels(group),
                                                      unique(group)))
        }
        df$feature.data <- group
        g <-
          ggplot(data = df, aes(x, y)) + geom_point(
            aes(colour = feature.data,cell_labels=cell_labels),
            alpha = alpha,
            size = point.size,
            shape = shape.by
          ) +
          scale_color_manual(values = color.use, na.value = "grey90") +
          theme(legend.position = "right") + theme(
            legend.title = element_blank(),
            legend.text = element_text(size = legend.text.size),
            legend.key.size = unit(0.15, "inches")
          ) + guides(color = guide_legend(override.aes = list(size = legend.size))) +
          ggtitle(feature.name) + theme(plot.title = element_text(
            hjust = 0.5,
            vjust = 0,
            size = 10
          )) + theme(
            panel.background = element_blank(),
            axis.ticks = element_blank(),
            axis.text = element_blank()
          ) +
          xlab(NULL) + ylab(NULL) + theme(legend.key = element_blank())
        gg[[i]] <- g %>% plotly::ggplotly(
          type = 'scatter',
          mode='markers+text',
        ) %>% set_individual_legend()
        annotations[[i]] <- list(
          x=annotations_pos[[i]]$x,
          y=annotations_pos[[i]]$y,
          text = feature.name,
          xref = "paper",
          yref = "paper",
          xanchor = "center",
          yanchor = "top",
          showarrow = FALSE,
          font = list(size = 16))
      }
      if (numFeature > 1) {
        gg <- plotly::subplot(gg, nrows = plot_nrows,margin = 0.02,shareX = FALSE,shareY = FALSE) %>%
          plotly::layout(title = '',
                         annotations = annotations,
                         legend = list(tracegroupgap = 10,title=list(text=''))
          )
      }
      else {
        gg <- plotly::ggplotly(gg[[1]],
                               type = 'scatter',
                               mode = 'markers') %>%
          plotly::layout(legend = list(title = list(text = '')))
      }
    }
    return(gg)
  }

#' The CellChat Class
#'
#' The CellChat object is created from a single-cell transcriptomic data matrix, Seurat V3 or SingleCellExperiment object.
#' When inputting an data matrix, it takes a digital data matrices as input. Genes should be in rows and cells in columns. rownames and colnames should be included.
#' The class provides functions for data preprocessing, intercellular communication network inference, communication network analysis, and visualization.
#'
#'
#'# Class definitions
#' @importFrom methods setClassUnion
#' @importClassesFrom Matrix dgCMatrix
setClassUnion(name = 'AnyMatrix', members = c("matrix", "dgCMatrix"))
setClassUnion(name = 'AnyFactor', members = c("factor", "list"))

#' The key slots used in the CellChat object are described below.
#'
#' @slot data.raw raw count data matrix
#' @slot data normalized data matrix for CellChat analysis (Genes should be in rows and cells in columns)
#' @slot data.signaling a subset of normalized matrix only containing signaling genes
#' @slot data.scale scaled data matrix
#' @slot data.smooth smoothed data
#' @slot images a list of information of spatial transcriptomics data
#' @slot net a three-dimensional array P (K×K×N), where K is the number of cell groups and N is the number of ligand-receptor pairs. Each row of P indicates the communication probability originating from the sender cell group to other cell groups.
#' @slot netP a three-dimensional array representing cel-cell communication networks on a signaling pathway level
#' @slot DB ligand-receptor interaction database used in the analysis (a subset of CellChatDB)
#' @slot LR a list of information related with ligand-receptor pairs
#' @slot meta data frame storing the information associated with each cell
#' @slot idents a factor defining the cell identity used for all analysis. It becomes a list for a merged CellChat object
#' @slot var.features A list: one element is a vector consisting of the identified over-expressed signaling genes; one element is a data frame returned from the differential expression analysis
#' @slot dr List of the reduced 2D coordinates, one per method, e.g., umap/tsne/dm
#' @slot options List of miscellaneous data, such as parameters used throughout analysis, and a indicator whether the CellChat object is a single or merged
#'
#' @exportClass CellChat
#' @importFrom Rcpp evalCpp
#' @importFrom methods setClass
# #' @useDynLib CellChat
CellChat <- methods::setClass("CellChat",
                                 slots = c(data.raw = 'AnyMatrix',
                                           data = 'AnyMatrix',
                                           data.signaling = "AnyMatrix",
                                           data.scale = "matrix",
                                           data.smooth = "AnyMatrix",
                                           images = "list",
                                           net = "list",
                                           netP = "list",
                                           meta = "data.frame",
                                           idents = "AnyFactor",
                                           DB = "list",
                                           LR = "list",
                                           var.features = "list",
                                           dr = "list",
                                           options = "list")
)
#' show method for CellChat
#'
#' @param CellChat object
#' @param show show the object
#' @param object object
#' @docType methods
#'
setMethod(f = "show", signature = "CellChat", definition = function(object) {
  if (object@options$mode == "single") {
    cat("An object of class", class(object), "created from a single dataset", "\n", nrow(object@data), "genes.\n",  ncol(object@data), "cells. \n")
  } else if (object@options$mode == "merged") {
    cat("An object of class", class(object), "created from a merged object with multiple datasets", "\n", nrow(object@data.signaling), "signaling genes.\n",  ncol(object@data.signaling), "cells. \n")
  }
  if (object@options$datatype == "RNA") {
    cat("CellChat analysis of single cell RNA-seq data! \n")
  } else {
    cat("CellChat analysis of", object@options$datatype, "data! The input spatial locations are \n")
    print(head(object@images$coordinates))
  }

  invisible(x = NULL)
})

#' Create a new CellChat object from a data matrix, Seurat or SingleCellExperiment object
#'
#' @param object a normalized (NOT count) data matrix (genes by cells), Seurat or SingleCellExperiment object
#' @param meta a data frame (rows are cells with rownames) consisting of cell information, which will be used for defining cell groups.
#' If input is a Seurat or SingleCellExperiment object, the meta data in the object will be used
#' @param group.by a char name of the variable in meta data, defining cell groups.
#' If input is a data matrix and group.by is NULL, the input `meta` should contain a column named 'labels',
#' If input is a Seurat or SingleCellExperiment object, USER must provide `group.by` to define the cell groups. e.g, group.by = "ident" for Seurat object
#' @param datatype By default datatype = "RNA"; when running CellChat on spatial imaging data, set datatype = "spatial" and input `spatial.factors`
#'
#' @param coordinates a data matrix in which each row gives the spatial locations/coordinates of each cell/spot
#' @param spatial.factors a data frame containing two distance factors `ratio` and `tol`, which is dependent on spatial transcriptomics technologies (and specific datasets).
#'
#' USER must input this data frame when datatype = "spatial". spatial.factors must contain an element named `ratio`, which is the conversion factor when converting spatial coordinates from Pixels or other units to Micrometers (i.e.,Microns). For example, setting `ratio = 0.18` indicates that 1 pixel equals 0.18um in the coordinates,
#'
#' and another element named `tol`, which is the tolerance factor to increase the robustness when comparing the center-to-center distance against the `interaction.range`. This can be the half value of cell/spot size in the unit of um. If the cell/spot size is not known, we provide a function `computeCellDistance` to compute the cell center-to-center distance. `tol` can be the the half value of the minimum center-to-center distance. Of note, CellChat does not need an accurate tolerance factor, which is used for determining whether considering the cell-pair as spatially proximal if their distance is greater than `interaction.range` but smaller than "`interaction.range` + `tol`".
#'
#'
#' @param assay Assay to use when the input is a Seurat or SingleCellExperiment object. NB: The data in the `integrated` assay in Seurat is not suitable for CellChat analysis because it contains negative values.
#' @param do.sparse whether use sparse format
#'
#' @return
#' @export
#' @importFrom methods as new
#' @examples
#' \dontrun{
#' Create a CellChat object from single-cell transcriptomics data
#' # Input is a data matrix
#' ## create a dataframe consisting of the cell labels
#' meta = data.frame(labels = cell.labels, row.names = names(cell.labels))
#' cellChat <- createCellChat(object = data.input, meta = meta, group.by = "labels")
#'
#' # input is a Seurat object
#' ## use the default cell identities of Seurat object
#' cellChat <- createCellChat(object = seurat.obj, group.by = "ident", assay = "RNA")
#' ## use other meta information as cell groups
#' cellChat <- createCellChat(object = seurat.obj, group.by = "seurat.clusters")
#'
#' # input is a SingleCellExperiment object
#' cellChat <- createCellChat(object = sce.obj, group.by = "sce.clusters")
#'
#' # input is a AnnData object
#' sce <- zellkonverter::readH5AD(file = "adata.h5ad")
#' assayNames(sce) # retrieve all the available assays within sce object
#' counts <- assay(sce, "X") # add a new assay entry "logcounts" if not available and make sure this is the original count data matrix
#' library.size <- Matrix::colSums(counts)
#' logcounts(sce) <- log1p(Matrix::t(Matrix::t(counts)/library.size) * 10000)
#' meta <- as.data.frame(SingleCellExperiment::colData(sce))
#' cellChat <- createCellChat(object = sce, group.by = "sce.clusters")
#'
#'
#' Create a CellChat object from spatial transcriptomics data
#' # Input is a data matrix
#' cellChat <- createCellChat(object = data.input, meta = meta, group.by = "labels",
#'                            datatype = "spatial", coordinates = coordinates, spatial.factors = spatial.factors)
#'
#' # input is a Seurat object
#' cellChat <- createCellChat(object = seurat.obj, group.by = "ident", assay = "SCT",
#'                            datatype = "spatial", spatial.factors = spatial.factors)
#'
#' }
createCellChat <- function(object, meta = NULL, group.by = NULL,
                           datatype = c("RNA", "spatial"), coordinates = NULL, spatial.factors = NULL,
                           assay = NULL, do.sparse = T) {
  datatype <- match.arg(datatype)
  # data matrix as input
  if (inherits(x = object, what = c("matrix", "Matrix", "dgCMatrix", "dgRMatrix","CsparseMatrix"))) {
    print("Create a CellChat object from a data matrix")
    data <- object
    if (is.null(group.by)) {
      group.by <- "labels"
    }
  }
  # Seurat object as input
  if (is(object,"Seurat")) {
    .error_if_no_Seurat()
    print("Create a CellChat object from a Seurat object")
    if (is.null(assay)) {
      assay = Seurat::DefaultAssay(object)
      if (assay == "integrated") {
        warning("The data in the `integrated` assay is not suitable for CellChat analysis! Please use the `RNA`, `SCT` or `Spatial` assay! ")
      }
      cat(paste0("The `data` slot in the default assay is used. The default assay is ", assay),'\n')
    }
    if (packageVersion("Seurat") < "5.0.0") {
      # data <- Seurat::GetAssayData(object, assay = assay, slot = "data") # normalized data matrix
      data <- object[[assay]]@data
    } else {
      data <- object[[assay]]$data
    }
    if (min(data) < 0) {
      stop("The data matrix contains negative values. Please ensure the normalized data matrix is used.")
    }
    if (is.null(meta)) {
      cat("The `meta.data` slot in the Seurat object is used as cell meta information",'\n')
      meta <- object@meta.data
      meta$ident <- Seurat::Idents(object)
    }
    if (is.null(group.by)) {
      group.by <- "ident"
    }
    if (datatype %in% c("spatial")) {
      if (is.null(coordinates)) {
        coordinates <- Seurat::GetTissueCoordinates(object, scale = NULL, cols = c("imagerow", "imagecol"))
      }
    }

  }
  # SingleCellExperiment object as input
  if (is(object,"SingleCellExperiment")) {
    print("Create a CellChat object from a SingleCellExperiment object")
    if (is.null(assay)) {
      assay = "logcounts"
    }
    if (assay %in% SummarizedExperiment::assayNames(object)) {
      cat(paste0("The data in the ", assay, " assay is used! "),'\n')
      data <- SummarizedExperiment::assay(object, assay)
    } else {
      stop("SingleCellExperiment object must contain an assay named `logcounts` or the input assay name! Please check the available assaynames via `assayNames(object)`. \n")
    }
    if (is.null(meta)) {
      cat("The `colData` assay in the SingleCellExperiment object is used as cell meta information",'\n')
      meta <- as.data.frame(SingleCellExperiment::colData(object))
    }
    if (is.null(group.by)) {
      stop("`group.by` should be defined!")
    }
  }

  if (!inherits(x = data, what = c("dgCMatrix")) & do.sparse) {
    if (inherits(x = data, what = c("dgRMatrix"))) {
      data <- as(data, "CsparseMatrix")
    }
    data <- as(data, "dgCMatrix")
  }

  if (!is.null(meta)) {
    if (inherits(x = meta, what = c("matrix", "Matrix","DataFrame"))) {
      meta <- as.data.frame(x = meta)
    }
    if (!is.data.frame(meta)) {
      stop("The input `meta` should be a data frame")
    }
    if (!identical(rownames(meta), colnames(data))) {
      cat("The cell barcodes in 'meta' is ", head(rownames(meta)),'\n')
      warning("The cell barcodes in 'meta' is different from those in the used data matrix.
              We now simply assign the colnames in the data matrix to the rownames of 'mata'!")
      rownames(meta) <- colnames(data)
    }
  } else {
    meta <- data.frame()
  }
  if (datatype %in% c("spatial")) {
    if (ncol(coordinates) == 2) {
      colnames(coordinates) <- c("x_cent","y_cent")
    } else {
      stop("Please check the input 'coordinates' and make sure it is a two column matrix.")
    }
    if (is.null(spatial.factors) | !("ratio" %in% names(spatial.factors)) | !("tol" %in% names(spatial.factors))) {
      stop("spatial.factors with colnames `ratio` and `tol` should be provided!")
    } else {
      images = list("coordinates" = coordinates,
                    "spatial.factors" = spatial.factors)
    }
    cat("Create a CellChat object from spatial transcriptomics data...",'\n')
  } else {
    images <- list()
  }

  object <- methods::new(Class = "CellChat",
                         data = data,
                         images = images,
                         meta = meta)

  if (!is.null(meta) & nrow(meta) > 0) {
    if (!("samples" %in% colnames(meta))) {
      warning("The 'meta' data does not have a column named `samples`. We now add this column and all cells are assumed to belong to `sample1`! \n")
      meta$samples <- "sample1"
      meta$samples <- factor(meta$samples)
      object@meta <- meta
    } else if (is.factor(meta$samples) == FALSE) {
      warning("The 'meta$samples' is not a factor. We now force it as a factor! \n")
      meta$samples <- factor(meta$samples)
      object@meta <- meta
    }

    cat("Set cell identities for the new CellChat object", '\n')
    if (!(group.by %in% colnames(meta))) {
      stop("The 'group.by' is not a column name in the `meta`, which will be used for cell grouping.")
    }
    object <- setIdent(object, ident.use = group.by) # set "labels" as default cell identity
    cat("The cell groups used for CellChat analysis are ", toString(levels(object@idents)), '\n')
  }

  object@options$mode <- "single"
  object@options$datatype <- datatype
  return(object)
}

#' Merge CellChat objects
#'
#' @param object.list  A list of multiple CellChat objects
#' @param add.names A vector containing the name of each dataset
#' @param merge.data whether merging the data for ALL genes. Default only merges the data of signaling genes
#' @param cell.prefix whether prefix cell names
#' @importFrom methods slot new
#'
#' @return
#' @export
#'
#' @examples
mergeCellChat <- function(object.list, add.names = NULL, merge.data = FALSE, cell.prefix = FALSE) {
  if (is.null(add.names)) {
    add.names <- paste("Dataset",1:length(object.list),sep = "_")
  }
  slot.name <- c("net", "netP", "idents" ,"LR", "var.features", "images")
  slot.combined <- vector("list", length(slot.name))
  names(slot.combined) <- slot.name
  for (i in 1:length(slot.name)) {
    object.slot <- vector("list", length(object.list))
    for (j in 1:length(object.list)) {
      object.slot[[j]] <- slot(object.list[[j]], slot.name[i])
    }
    slot.combined[[i]] <- object.slot
    names(slot.combined[[i]]) <- add.names
  }

  if (cell.prefix) {
    warning("Prefix cell names!")
    for (i in 1:length(object.list)) {colnames(object.list[[i]]@data) <- paste(colnames(object.list[[i]]@data), add.names[i], sep = "_")}
  } else {
    cell.names <- c()
    for (i in 1:length(object.list)) {
      cell.names <- c(cell.names, colnames(object.list[[i]]@data))
    }
    if (sum(duplicated(cell.names))) {
      stop("Duplicated cell names were detected across datasets!! Please set cell.prefix = TRUE")
    }
  }

  meta.use <- colnames(object.list[[1]]@meta)
  for (i in 2:length(object.list)) {
    meta.use <- meta.use[meta.use %in% colnames(object.list[[i]]@meta)]
  }

  dataset.name <- c()
  cell.names <- c()
  meta.joint <- data.frame()
  for (i in 1:length(object.list)) {
    dataset.name <- c(dataset.name, rep(add.names[i], length(colnames(object.list[[i]]@data))))
    cell.names <- c(cell.names, colnames(object.list[[i]]@data))
    meta.joint <- rbind(meta.joint, object.list[[i]]@meta[ , meta.use, drop = FALSE])
  }
  if (!identical(rownames(meta.joint), cell.names)) {
    cat("The cell barcodes in merged 'meta' is ", head(rownames(meta.joint)),'\n')
    warning("The cell barcodes in merged 'meta' is different from those in the used data matrix.
              We now simply assign the colnames in the data matrix to the rownames of merged 'mata'!")
    rownames(meta.joint) <- cell.names
  }

  #dataset.name <- data.frame(dataset.name = dataset.name, row.names = cell.names)
  meta.joint$datasets <- factor(dataset.name, levels = add.names)

  genes.use <- rownames(object.list[[1]]@data)
  for (i in 2:length(object.list)) {
    genes.use <- genes.use[genes.use %in% rownames(object.list[[i]]@data)]
  }
  data.joint <- c()
  for (i in 1:length(object.list)) {
    data.joint <- cbind(data.joint, object.list[[i]]@data[genes.use, ])
  }
  gene.signaling.joint = unique(unlist(lapply(object.list, function(x) rownames(x@data.signaling))))
  data.signaling.joint <- data.joint[rownames(data.joint) %in% gene.signaling.joint, ]

  idents.joint <- c()
  idents.levels <- c()
  for (i in 1:length(object.list)) {
    idents.joint <- c(idents.joint, as.character(object.list[[i]]@idents))
    idents.levels <- union(idents.levels, levels(object.list[[i]]@idents))
  }
  names(idents.joint) <- cell.names
  idents.joint <- factor(idents.joint, levels = idents.levels)
  slot.combined$idents$joint <- idents.joint

  if (merge.data) {
    message("Merge the following slots: 'data','data.signaling','images','net', 'netP','meta', 'idents', 'var.features', 'DB', and 'LR'.")
    merged.object <- methods::new(
      Class = "CellChat",
      data = data.joint,
      data.signaling = data.signaling.joint,
      images = slot.combined$images,
      net = slot.combined$net,
      netP = slot.combined$netP,
      meta = meta.joint,
      idents = slot.combined$idents,
      var.features = slot.combined$var.features,
      LR = slot.combined$LR,
      DB = object.list[[1]]@DB)
  } else {
    message("Merge the following slots: 'data.signaling','images','net', 'netP','meta', 'idents', 'var.features' , 'DB', and 'LR'.")
    merged.object <- methods::new(
      Class = "CellChat",
      data.signaling = data.signaling.joint,
      images = slot.combined$images,
      net = slot.combined$net,
      netP = slot.combined$netP,
      meta = meta.joint,
      idents = slot.combined$idents,
      var.features = slot.combined$var.features,
      LR = slot.combined$LR,
      DB = object.list[[1]]@DB)
  }
  merged.object@options$mode <- "merged"

  datatype.joint <- c()
  for (j in 1:length(object.list)) {
    datatype.joint <- union(datatype.joint, slot(object.list[[j]], "options")$datatype)
  }
  if (length(datatype.joint) == 1){
    merged.object@options$datatype <- datatype.joint
  } else {
    message("The data types in these objects are  ", datatype.joint,'\n')
    stop("Comparison analysis is not suggested for different types of data.")
  }
  return(merged.object)
}

#' Update a single CellChat object
#'
#' Update a single previously calculated CellChat object for spatial transcriptomics data analysis (version < 2.1.0)
#'
#' Update a single previously calculated CellChat object (version < 1.6.0)
#'
#' version < 0.5.0: `object@var.features` is now `object@var.features$features`; `object@net$sum` is now `object@net$weight` if `aggregateNet` has been run.
#'
#' version 1.6.0: a `object@images` slot is added and `datatype` is added in `object@options$datatype`
#'
#' version 2.1.0: a column named `slices` is added in `meta` data for spatial transcriptomics data analysis.
#'
#' version 2.1.1: `images$scale.factors` is changed to `images$spatial.factors` for spatial transcriptomics data analysis.
#'
#' version 2.1.2: the column `slices` in `object@meta` is renamed as `samples` in order to identify consistent signaling across samples for cell-cell communication analysis.
#'
#' version 2.1.3: the slot `object@data.project` is renamed as `object@data.smooth`.
#'
#' @param object CellChat object
#'
#' @return a updated CellChat object
#' @export
#'
updateCellChat <- function(object) {
  DB <- object@DB
  # interaction_input <- DB$interaction
  # if (("category" %in% colnames(interaction_input) == FALSE) & ("annotation" %in% colnames(interaction_input) == TRUE)) {
  #   message("Change the column name `annotation` in object@DB$interaction to `category` since CellChat v2")
  #   colnames(interaction_input) <- plyr::mapvalues(colnames(interaction_input),from = c("annotation"), to = c("category"), warn_missing = TRUE)
  #   DB$interaction <- interaction_input
  # }
  if (is.character(object@var.features)) {
    message("Update slot 'var.features' from a vector to a list")
    var.features.new <- list(features = object@var.features)
  } else {
    var.features.new <- object@var.features
  }
  if ("sum" %in% names(object@net)) {
    net <- object@net
    net$weight <- net$sum
  } else {
    net <- object@net
  }
  if (!("mode" %in% names(object@options))) {
    object@options$mode <- "single"
  }
  if (!("datatype" %in% names(object@options))) {
    object@options$datatype <- "RNA"
    images = list()
  } else {
    images = object@images
  }
  meta = object@meta
  if ("slices" %in% colnames(meta)) {
    meta$samples <-  meta$slices
    meta$slices = NULL
  }
  if (!("samples" %in% colnames(meta))) {
    warning("The 'meta' data does not have a column named `samples`. We now add this column and all cells are assumed to belong to `sample1`!")
    meta$samples <- "sample1"
    meta$samples <- factor(meta$samples)
  } else if (is.factor(meta$samples) == FALSE) {
    warning("The 'meta$samples' is not a factor. We now force it as a factor!")
    meta$samples <- factor(meta$samples)
  }
  if (object@options$datatype %in% c("spatial")) {
    if ("scale.factors" %in% names(object@images)) {
      images$spatial.factors <- as.data.frame(images$scale.factors)
      images$scale.factors <- NULL
    }
  }
  if ("data.smooth" %in% methods::slotNames(object) == FALSE) {
    data.smooth <- object@data.project
  } else {
    data.smooth <- object@data.smooth
  }
  object.new <- methods::new(
    Class = "CellChat",
    data.raw = object@data.raw,
    data = object@data,
    data.signaling = object@data.signaling,
    data.scale = object@data.scale,
    data.smooth = data.smooth,
    images = images,
    net = net,
    netP = object@netP,
    meta = meta,
    idents = object@idents,
    DB = DB,
    LR = object@LR,
    var.features = var.features.new,
    dr = object@dr,
    options = object@options
  )
  return(object.new)
}

#' Update a CellChat object by lifting up the cell groups to the same cell labels across all datasets
#'
#' This function is useful when comparing inferred communications across different datasets with different cellular compositions
#'
#' @param object A single or merged CellChat object
#' @param group.new A char vector giving the cell labels to lift up. The order of cell labels in the vector will be used for setting the new cell identity.
#'
#'  If the input is a merged CellChat object and group.new = NULL, it will use the cell labels from one dataset with the maximum number of cell groups
#'
#'  If the input is a single CellChat object, `group.new` must be defined.
#'
#' @return a updated CellChat object
#'
#' @export
#'
liftCellChat <- function(object, group.new = NULL) {
  if (object@options$mode == "merged") {
    idents <- object@idents[1:(length(object@idents)-1)]
    if (is.null(group.new)) {
      group.max.all <- unique(unlist(sapply(idents, levels)))
      group.num <- sapply(idents, nlevels)
      group.num.max <- max(group.num)
      group.max <- levels(idents[[which(group.num == group.num.max)]])
      if (length(group.max) != length(group.max.all)) {
        stop("CellChat object cannot lift up due to the missing cell groups in any dataset. Please define the parameter `group.new`!")
      }
    } else {
      group.max <- group.new
      group.num.max <- length(group.new)
    }
    message(paste0("The CellChat object will be lifted up using the cell labels ", paste(group.max, collapse=", ")))
    for (i in 1:length(idents)) {
      cat("Update slots object@net, object@netP, object@idents in dataset ", names(object@idents)[i],'\n')
      # cat("Update slot object@net...", '\n')
      net <- object@net[[i]]
      group.i <- levels(idents[[i]])
      # group.existing <- group.max[group.max %in% group.i]
      group.existing <- group.i[group.i %in% group.max]
      group.existing.index <- which(group.max %in% group.existing)
      for (net.j in names(net)) {
        values <- net[[net.j]]
        if (net.j %in% c("prob","pval")) {
          values.new <- array(data = 0, dim = c(group.num.max, group.num.max, dim(values)[3]),
                              dimnames = list(group.max, group.max, dimnames(values)[[3]]))
          values.new[group.existing.index, group.existing.index, ] <- values
          net[[net.j]] <- values.new
        }
        if (net.j %in% c("count","sum","weight")) {
          values.new <- array(data = 0, dim = c(group.num.max, group.num.max),
                              dimnames = list(group.max, group.max))
          values.new[group.existing.index, group.existing.index] <- values
          net[[net.j]] <- values.new
        }
        if (net.j %in% c("pairwiseRank")) {
          for (k in 1:length(values)) {
            values.new1 <- vector("list", group.num.max)
            values.new1[group.existing.index] <- values[[k]]
            temp <- values[[k]][[1]]
            temp$prob  <- 0; temp$pval <- 1
            for (kk in setdiff(1:group.num.max, group.existing.index)) {
              values.new1[[kk]] <- temp
            }
            names(values.new1) <- group.max
            values[[k]] <- values.new1
          }
          values.new <- vector("list", group.num.max)
          values.new[group.existing.index] <- values
          temp <- lapply(values.new1, function(x) {
            x$prob  <- 0; x$pval <- 1
            return(x)
          })
          for (kk in setdiff(1:group.num.max, group.existing.index)) {
            values.new[[kk]] <- temp
          }
          names(values.new) <- group.max
        }
        net[[net.j]] <- values.new
      }
      object@net[[i]] <- net

      # cat("Update slot object@netP...", '\n')
      netP <- object@netP[[i]]
      for (netP.j in names(netP)) {
        values <- netP[[netP.j]]
        if (netP.j %in% c("pathways")) {
          values.new <- values
          netP[[netP.j]] <- values.new
        }
        if (netP.j %in% c("prob")) {
          values.new <- array(data = 0, dim = c(group.num.max, group.num.max, dim(values)[3]),
                              dimnames = list(group.max, group.max, dimnames(values)[[3]]))
          values.new[group.existing.index, group.existing.index, ] <- values
          netP[[netP.j]] <- values.new
        }
        if (netP.j %in% c("centr")) {
          for (k in 1:length(values)) {
            values.new <- lapply(values, function(x) {
              values.new2 <- lapply(x, function(x) {
                values.new1 = as.vector(matrix(0, nrow = 1, ncol = group.num.max))
                values.new1[group.existing.index] <- x
                names(values.new1) <- group.max
                return(values.new1)
              })
              names(values.new2) <- names(x)
              return(values.new2)
            })
            names(values.new) <- names(values)
          }
          netP[[netP.j]] <- values.new
        }

      }
      object@netP[[i]] <- netP
      # cat("Update slot object@idents...", '\n')
      # idents[[i]] <- factor(group.max, levels = group.max)
      idents[[i]] <- factor(idents[[i]], levels = group.max)
    }
    object@idents[1:(length(object@idents)-1)] <- idents
  } else {
    if (is.null(group.new)) {
      stop("Please define the parameter `group.new`!")
    } else {
      group.max <- as.character(group.new)
      group.num.max <- length(group.new)
      message(paste0("The CellChat object will be lifted up using the cell labels ", paste(group.max, collapse=", ")))
    }
    cat("Update slots object@net, object@netP, object@idents in a single dataset...", '\n')
    # cat("Update slot object@net...", '\n')
    net <- object@net
    idents <- object@idents
    group.i <- levels(idents)
    # group.existing <- group.max[group.max %in% group.i]
    group.existing <- group.i[group.i %in% group.max]
    group.existing.index <- which(group.max %in% group.existing)
    for (net.j in names(net)) {
      values <- net[[net.j]]
      if (net.j %in% c("prob","pval")) {
        values.new <- array(data = 0, dim = c(group.num.max, group.num.max, dim(values)[3]),
                            dimnames = list(group.max, group.max, dimnames(values)[[3]]))
        values.new[group.existing.index, group.existing.index, ] <- values
        net[[net.j]] <- values.new
      }
      if (net.j %in% c("count","sum","weight")) {
        values.new <- array(data = 0, dim = c(group.num.max, group.num.max),
                            dimnames = list(group.max, group.max))
        values.new[group.existing.index, group.existing.index] <- values
        net[[net.j]] <- values.new
      }
      if (net.j %in% c("pairwiseRank")) {
        for (k in 1:length(values)) {
          values.new1 <- vector("list", group.num.max)
          values.new1[group.existing.index] <- values[[k]]
          temp <- values[[k]][[1]]
          temp$prob  <- 0; temp$pval <- 1
          for (kk in setdiff(1:group.num.max, group.existing.index)) {
            values.new1[[kk]] <- temp
          }
          names(values.new1) <- group.max
          values[[k]] <- values.new1
        }
        values.new <- vector("list", group.num.max)
        values.new[group.existing.index] <- values
        temp <- lapply(values.new1, function(x) {
          x$prob  <- 0; x$pval <- 1
          return(x)
        })
        for (kk in setdiff(1:group.num.max, group.existing.index)) {
          values.new[[kk]] <- temp
        }
        names(values.new) <- group.max
      }
      net[[net.j]] <- values.new
    }
    object@net <- net

    # cat("Update slot object@netP...", '\n')
    netP <- object@netP
    for (netP.j in names(netP)) {
      values <- netP[[netP.j]]
      if (netP.j %in% c("pathways")) {
        values.new <- values
        netP[[netP.j]] <- values.new
      }
      if (netP.j %in% c("prob")) {
        values.new <- array(data = 0, dim = c(group.num.max, group.num.max, dim(values)[3]),
                            dimnames = list(group.max, group.max, dimnames(values)[[3]]))
        values.new[group.existing.index, group.existing.index, ] <- values
        netP[[netP.j]] <- values.new
      }
      if (netP.j %in% c("centr")) {
        for (k in 1:length(values)) {
          values.new <- lapply(values, function(x) {
            values.new2 <- lapply(x, function(x) {
              values.new1 = as.vector(matrix(0, nrow = 1, ncol = group.num.max))
              values.new1[group.existing.index] <- x
              names(values.new1) <- group.max
              return(values.new1)
            })
            names(values.new2) <- names(x)
            return(values.new2)
          })
          names(values.new) <- names(values)
        }
      }
      netP[[netP.j]] <- values.new
    }
    object@netP <- netP

    # cat("Update slot object@idents...", '\n')
    idents <- factor(idents, levels = group.max)
    object@idents <- idents
  }

  return(object)
}

#' Subset CellChat object using a portion of cells
#'
#' @param object  A CellChat object (either an object from a single dataset or a merged objects from multiple datasets)
#' @param cells.use a char vector giving the cell barcodes to subset. If cells.use = NULL, USER must define `idents.use`
#' @param idents.use a subset of cell groups used for analysis
#' @param group.by cell group information; default is `object@idents`; otherwise it should be one of the column names of the meta slot
#' @param invert whether invert the idents.use
#' @param thresh threshold of the p-value for determining significant interaction. A parameter as an input of the function `computeCommunProbPathway`
#' @importFrom methods slot new
#'
#' @return
#' @export
#'
subsetCellChat <- function(object, cells.use = NULL, idents.use = NULL, group.by = NULL, invert = FALSE, thresh = 0.05) {
  if (!is.null(idents.use)) {
    if (is.null(group.by)) {
      labels <- object@idents
      if (object@options$mode == "merged") {
        message("Use the joint cell labels from the merged CellChat object")
        labels <- object@idents$joint
      }
    } else {
      labels <- object@meta[[group.by]]
    }
    if (!is.factor(labels)) {
      labels <- factor(labels)
    }
    level.use0 <- levels(labels)
    level.use <- levels(labels)[levels(labels) %in% unique(labels)]

    if (invert) {
      level.use <- level.use[!(level.use %in% idents.use)]
    } else {
      level.use <- level.use[level.use %in% idents.use]
    }
    cells.use.index <- which(as.character(labels) %in% level.use)
    cells.use <- names(labels)[cells.use.index]
  } else if (!is.null(cells.use)) {
    labels <- object@idents
    if (object@options$mode == "merged") {
      message("Use the joint cell labels from the merged CellChat object")
      labels <- object@idents$joint
    }
    level.use0 <- levels(labels)
    level.use <- levels(labels)[levels(labels) %in% unique(as.character(labels[cells.use]))]
    cells.use.index <- which(names(labels) %in% cells.use)
  } else {
    stop("USER should define either `cells.use` or `idents.use`!")
  }
  cat("The subset of cell groups used for CellChat analysis are ", level.use, '\n')

  if (nrow(object@data) > 0) {
    data.subset <- object@data[, cells.use.index]
  } else {
    data.subset <- matrix(0, nrow = 0, ncol = 0)
  }
  if (nrow(object@data.smooth) > 0) {
    data.smooth.subset <- object@data.smooth[, cells.use.index]
  } else {
    data.smooth.subset <- matrix(0, nrow = 0, ncol = 0)
  }
  data.signaling.subset <- object@data.signaling[, cells.use.index]

  meta.subset <- object@meta[cells.use.index, , drop = FALSE]

  if (object@options$mode == "merged") {
    idents <- object@idents[1:(length(object@idents)-1)]
    group.existing <- level.use0[level.use0 %in% level.use]
    group.existing.index <- which(level.use0 %in% level.use)
    net.subset <- vector("list", length = length(object@net))
    netP.subset <- vector("list", length = length(object@netP))
    idents.subset <- vector("list", length = length(idents))
    names(net.subset) <- names(object@net)
    names(netP.subset) <- names(object@netP)
    names(idents.subset) <- names(object@idents[1:(length(object@idents)-1)])
    images.subset <- vector("list", length = length(idents))
    names(images.subset) <- names(object@idents[1:(length(object@idents)-1)])

    for (i in 1:length(idents)) {
      cat("Update slots object@images, object@net, object@netP, object@idents in dataset ", names(object@idents)[i],'\n')
      images <- object@images[[i]]
      for (images.j in names(images)) {
        values <- images[[images.j]]
        if (images.j %in% c("coordinates")) {
          values.new <- values[cells.use.index, ]
          images[[images.j]] <- values.new
        }
        if (images.j %in% c("distance")) {
          values.new <- values[group.existing.index, group.existing.index, drop = FALSE]
          images[[images.j]] <- values.new
        }
      }
      images.subset[[i]] <- images

      # cat("Update slot object@net...", '\n')
      net <- object@net[[i]]
      for (net.j in names(net)) {
        values <- net[[net.j]]
        if (net.j %in% c("prob","pval")) {
          values.new <- values[group.existing.index, group.existing.index, , drop = FALSE]
          net[[net.j]] <- values.new
        }
        if (net.j %in% c("count","sum","weight")) {
          values.new <- values[group.existing.index, group.existing.index, drop = FALSE]
          net[[net.j]] <- values.new
        }
       # net[[net.j]] <- values.new
      }
      net.subset[[i]] <- net

      # cat("Update slot object@netP...", '\n')
      # netP <- object@netP[[i]]
      # for (netP.j in names(netP)) {
      #   values <- netP[[netP.j]]
      #   if (netP.j %in% c("pathways")) {
      #     values.new <- values
      #     netP[[netP.j]] <- values.new
      #   }
      #   if (netP.j %in% c("prob")) {
      #     values.new <- values[group.existing.index, group.existing.index, ]
      #     netP[[netP.j]] <- values.new
      #   }
      #   if (netP.j %in% c("centr")) {
      #     for (k in 1:length(values)) {
      #       values.new <- lapply(values, function(x) {
      #         values.new2 <- lapply(x, function(x) {
      #           values.new1 <- x[group.existing.index]
      #           names(values.new1) <- group.existing
      #           return(values.new1)
      #         })
      #         names(values.new2) <- names(x)
      #         return(values.new2)
      #       })
      #       names(values.new) <- names(values)
      #     }
      #   }
      #   netP[[netP.j]] <- values.new
      # }
      netP = computeCommunProbPathway(net = net.subset[[i]], pairLR.use = object@LR[[i]]$LRsig, thresh = thresh)
      netP$centr = netAnalysis_computeCentrality(net =  net.subset[[i]]$prob)
      netP.subset[[i]] <- netP
      idents.subset[[i]] <- idents[[i]][names(idents[[i]]) %in% cells.use]
      idents.subset[[i]] <- factor(idents.subset[[i]], levels = levels(idents[[i]])[levels(idents[[i]]) %in% level.use])
    }
    idents.subset$joint <- factor(object@idents$joint[cells.use.index], levels = level.use)

  } else {
    cat("Update slots object@images, object@net, object@netP in a single dataset...", '\n')

    group.existing <- level.use0[level.use0 %in% level.use]
    group.existing.index <- which(level.use0 %in% level.use)

    images <- object@images
    for (images.j in names(images)) {
      values <- images[[images.j]]
      if (images.j %in% c("coordinates")) {
        values.new <- values[cells.use.index, ]
        images[[images.j]] <- values.new
      }
      if (images.j %in% c("distance")) {
        values.new <- values[group.existing.index, group.existing.index, drop = FALSE]
        images[[images.j]] <- values.new
      }
    }
    images.subset <- images

    # cat("Update slot object@net...", '\n')
    net <- object@net
    for (net.j in names(net)) {
      values <- net[[net.j]]
      if (net.j %in% c("prob","pval")) {
        values.new <- values[group.existing.index, group.existing.index, , drop = FALSE]
        net[[net.j]] <- values.new
      }
      if (net.j %in% c("count","sum","weight")) {
        values.new <- values[group.existing.index, group.existing.index, drop = FALSE]
        net[[net.j]] <- values.new
      }
    }
    net.subset <- net

    # cat("Update slot object@netP...", '\n')
    # netP <- object@netP
    # for (netP.j in names(netP)) {
    #   values <- netP[[netP.j]]
    #   if (netP.j %in% c("pathways")) {
    #     values.new <- values
    #     netP[[netP.j]] <- values.new
    #   }
    #   if (netP.j %in% c("prob")) {
    #     values.new <- values[group.existing.index, group.existing.index, ]
    #     netP[[netP.j]] <- values.new
    #   }
    #   if (netP.j %in% c("centr")) {
    #     for (k in 1:length(values)) {
    #       values.new <- lapply(values, function(x) {
    #         values.new2 <- lapply(x, function(x) {
    #           values.new1 <- x[group.existing.index]
    #           names(values.new1) <- group.existing
    #           return(values.new1)
    #         })
    #         names(values.new2) <- names(x)
    #         return(values.new2)
    #       })
    #       names(values.new) <- names(values)
    #     }
    #   }
    #   netP[[netP.j]] <- values.new
    # }
    netP = computeCommunProbPathway(net = net.subset, pairLR.use = object@LR$LRsig, thresh = thresh)
    netP$centr = netAnalysis_computeCentrality(net = net.subset$prob)
    netP.subset <- netP
    idents.subset <- object@idents[cells.use.index]
    idents.subset <- factor(idents.subset, levels = level.use)
  }

  object.subset <- methods::new(
    Class = "CellChat",
    data = data.subset,
    data.signaling = data.signaling.subset,
    data.smooth = data.smooth.subset,
    images = images.subset,
    net = net.subset,
    netP = netP.subset,
    meta = meta.subset,
    idents = idents.subset,
    var.features = object@var.features,
    LR = object@LR,
    DB = object@DB,
    options = object@options
  )
  return(object.subset)
}

function (object,
                                  features = NULL,
                                  signaling = NULL,
                                  pairLR.use = NULL,
                                  sample.use = NULL,
                                  reduction = NULL,
                                  enriched.only = TRUE,
                                  thresh = 0.05,
                                  do.group = TRUE,
                                  color.heatmap = "Reds",
                                  n.colors = 8,
                                  direction = -1,
                                  do.binary = FALSE,
                                  cutoff = NULL,
                                  color.use = NULL,
                                  alpha = 1,
                                  point.size = 0.8,
                                  legend.size = 3,
                                  legend.text.size = 8,
                                  shape.by = 16,
                                  plot_nrows = 1,
                                  show.legend = TRUE,
                                  show.legend.combined = FALSE) {}

This code segment functions to: Generate interactive visualizations of gene expression or ligand-receptor pair activity across cell groups within a dimensional reduction space, supporting both continuous color gradients and categorical binary representations while enabling multi-panel layouts with configurable parameters for data thresholds and visual styling.

```r
[TASK_BEGIN]
plotly_FeaturePlot <- function (object,
                                  features = NULL,
                                  signaling = NULL,
                                  pairLR.use = NULL,
                                  sample.use = NULL,
                                  reduction = NULL,
                                  enriched.only = TRUE,
                                  thresh = 0.05,
                                  do.group = TRUE,
                                  color.heatmap = "Reds",
                                  n.colors = 8,
                                  direction = -1,
                                  do.binary = FALSE,
                                  cutoff = NULL,
                                  color.use = NULL,
                                  alpha = 1,
                                  point.size = 0.8,
                                  legend.size = 3,
                                  legend.text.size = 8,
                                  shape.by = 16,
                                  plot_nrows = 1,
                                  show.legend = TRUE,
                                  show.legend.combined = FALSE) {
    if (length(names(object@dr)) == 0) {
      stop("Please check `addReduction` to add a new reduced space into `object@dr`. \n")
    }
    if (!is.null(reduction)) {
      coords <- object@dr[[reduction]]
    } else {
      if ("umap" %in% names(object@dr)) {
        coords <- object@dr$umap
      } else if ("tsne" %in% names(object@dr)){
        coords <- object@dr$tsne
      } else {
        stop(paste0("The `object@dr` contains the following reduced space: ", toString(names(object@dr)), ". Please specify the dimensionality reduction to use. \n"))
      }
    }

    coordinates <- as.data.frame(coords)
    samples <- object@meta$samples
    if (ncol(coordinates) >= 2) {
      coordinates <- coordinates[, c(1,2)]
      colnames(coordinates) <- c("x_cent","y_cent")
      if (length(unique(samples)) > 1) {
        if (is.null(sample.use)) {
          stop("`sample.use` should be provided for visualizing signaling on each individual sample.")
        } else if (sample.use %in% unique(samples)) {
          coordinates = coordinates[samples == sample.use, ]
        } else {
          stop("Please check the input `sample.use`, which should be the element in `meta$samples`.")
        }
      }
    }

    data <- as.matrix(object@data)
    meta <- object@meta
    cell_labels <- object@idents

    if (length(color.heatmap) == 1) {
      colormap <- tryCatch({
        RColorBrewer::brewer.pal(n = n.colors, name = color.heatmap)
      }, error = function(e) {
        (scales::viridis_pal(option = color.heatmap, direction = direction))(n.colors)
      })
      colormap <- colorRampPalette(colormap)(99)
      colormap[1] <- "#E5E5E5"
    } else {
      colormap <- color.heatmap
    }

    if (!is.null(features) & !is.null(signaling)) stop("Please don't input features or signaling simultaneously.")
    if (!is.null(features) & !is.null(pairLR.use)) stop("Please don't input features or pairLR.use simultaneously.")
    if (!is.null(signaling) & !is.null(pairLR.use)) stop("Please don't input signaling or pairLR.use simultaneously.")

    df <- data.frame(x = coordinates[, 1], y = coordinates[, 2],
                     cell_labels = cell_labels[samples == sample.use])

    if (!do.binary) {
      if (!is.null(signaling)) {
        res <- CellChat::extractEnrichedLR(object, signaling = signaling, geneLR.return = TRUE,
                                          enriched.only = enriched.only, thresh = thresh)
        feature.use <- res$geneLR
      } else if (!is.null(pairLR.use)) {
        pairLR.use.name <- pairLR.use$interaction_name
        LR.pair <- object@LR$LRsig[pairLR.use.name, c("ligand", "receptor")]
        geneL <- unique(LR.pair$ligand)
        geneR <- unique(LR.pair$receptor)
        geneL <- CellChat:::extractGeneSubset(geneL, object@DB$complex, object@DB$geneInfo)
        geneR <- CellChat:::extractGeneSubset(geneR, object@DB$complex, object@DB$geneInfo)
        feature.use <- c(geneL, geneR)
      } else {
        feature.use <- features
      }

      data.use <- data[feature.use, , drop = FALSE]
      if (!is.null(cutoff)) data.use[data.use <= cutoff] <- 0

      numFeature = length(feature.use)
      gg <- vector("list", numFeature)
      annotations <- vector("list", numFeature)

      for (i in seq_len(numFeature)) {
        feature.name <- feature.use[i]
        df$feature.data <- data.use[i,]
        g <- ggplot(df, aes(x, y)) +
          geom_point(aes(color = feature.data), size = point.size, alpha = alpha) +
          scale_color_gradientn(colors = colormap, na.value = "grey90") +
          ggtitle(feature.name) +
          theme_classic() +
          theme(axis.line = element_blank(), axis.ticks = element_blank(),
                axis.text = element_blank(), plot.title = element_text(hjust = 0.5))

        gg[[i]] <- plotly::ggplotly(g, height = 400)
        annotations[[i]] <- list(x = 0.5, y = 1, text = feature.name,
                               xref = "paper", yref = "paper", showarrow = FALSE)
      }

      if (numFeature > 1) {
        plotly::subplot(gg, nrows = plot_nrows, margin = 0.02) %>%
          plotly::layout(annotations = annotations)
      } else {
        plotly::ggplotly(gg[[1]])
      }
    } else {
      if (is.null(color.use)) color.use <- ggPalette(4)
      if (!is.null(signaling)) {
        res <- CellChat::extractEnrichedLR(object, signaling = signaling)
        LR.pair <- object@LR$LRsig[res$interaction_name, c("ligand", "receptor")]
      } else {
        LR.pair <- object@LR$LRsig[pairLR.use$interaction_name, c("ligand", "receptor")]
      }

      dataL <- CellChat:::computeExpr_LR(LR.pair$ligand, data, object@DB$complex)
      dataR <- CellChat:::computeExpr_LR(LR.pair$receptor, data, object@DB$complex)

      numFeature = nrow(LR.pair)
      gg <- vector("list", numFeature)
      annotations <- vector("list", numFeature)

      for (i in seq_len(numFeature)) {
        idx1 <- dataL[i,] > cutoff
        idx2 <- dataR[i,] > cutoff
        group <- factor(dplyr::case_when(
          idx1 & idx2 ~ "Both",
          idx1 ~ LR.pair$ligand[i],
          idx2 ~ LR.pair$receptor[i],
          TRUE ~ "None"
        ), levels = c(LR.pair$ligand[i], LR.pair$receptor[i], "Both", "None"))

        df$feature.data <- group
        g <- ggplot(df, aes(x, y)) +
          geom_point(aes(color = feature.data), size = point.size, alpha = alpha) +
          scale_color_manual(values = color.use, na.value = "grey90") +
          ggtitle(paste(LR.pair$ligand[i], LR.pair$receptor[i], sep = "_")) +
          theme_classic() +
          theme(axis.line = element_blank(), axis.ticks = element_blank(),
                axis.text = element_blank(), plot.title = element_text(hjust = 0.5))

        gg[[i]] <- plotly::ggplotly(g, height = 400)
        annotations[[i]] <- list(x = 0.5, y = 1, text = paste(LR.pair$ligand[i], LR.pair$receptor[i], sep = "_"),
                               xref = "paper", yref = "paper", showarrow = FALSE)
      }

      if (numFeature > 1) {
        plotly::subplot(gg, nrows = plot_nrows, margin = 0.02) %>%
          plotly::layout(annotations = annotations)
      } else {
        plotly::ggplotly(gg[[1]])
      }
    }
  }
[TASK_END]
```

plotly_FeaturePlot <- function (object,
                                  features = NULL,
                                  signaling = NULL,
                                  pairLR.use = NULL,
                                  sample.use = NULL,
                                  reduction = NULL,
                                  enriched.only = TRUE,
                                  thresh = 0.05,
                                  do.group = TRUE,
                                  color.heatmap = "Reds",
                                  n.colors = 8,
                                  direction = -1,
                                  do.binary = FALSE,
                                  cutoff = NULL,
                                  color.use = NULL,
                                  alpha = 1,
                                  point.size = 0.8,
                                  legend.size = 3,
                                  legend.text.size = 8,
                                  shape.by = 16,
                                  plot_nrows = 1,
                                  show.legend = TRUE,
                                  show.legend.combined = FALSE) {
    if (length(names(object@dr)) == 0) {
      stop("Please check `addReduction` to add a new reduced space into `object@dr`. \n")
    }
    if (!is.null(reduction)) {
      coords <- object@dr[[reduction]]
    } else {
      if ("umap" %in% names(object@dr)) {
        coords <- object@dr$umap
      } else if ("tsne" %in% names(object@dr)){
        coords <- object@dr$tsne
      } else {
        stop(paste0("The `object@dr` contains the following reduced space: ", toString(names(object@dr)), ". Please specify the dimensionality reduction to use. \n"))
      }
    }
    coordinates <- as.data.frame(coords)
    samples <- object@meta$samples
    if (ncol(coordinates) >= 2) {
      coordinates <- coordinates[, c(1,2)]
      colnames(coordinates) <- c("x_cent","y_cent")
      if (length(unique(samples)) > 1) {
        if (is.null(sample.use)) {
          stop("`sample.use` should be provided for visualizing signaling on each individual sample.")
        } else if (sample.use %in% unique(samples)) {
          coordinates = coordinates[samples == sample.use, ]
        } else {
          stop("Please check the input `sample.use`, which should be the element in `meta$samples`.")
        }
      }
    }
    data <- as.matrix(object@data)
    meta <- object@meta
    cell_labels <- object@idents
    if (length(color.heatmap) == 1) {
      colormap <- tryCatch({
        RColorBrewer::brewer.pal(n = n.colors, name = color.heatmap)
      }, error = function(e) {
        (scales::viridis_pal(option = color.heatmap, direction = direction))(n.colors)
      })
      colormap <- colorRampPalette(colormap)(99)
      colormap[1] <- "
    } else {
      colormap <- color.heatmap
    }
    if (!is.null(features) & !is.null(signaling)) stop("Please don't input features or signaling simultaneously.")
    if (!is.null(features) & !is.null(pairLR.use)) stop("Please don't input features or pairLR.use simultaneously.")
    if (!is.null(signaling) & !is.null(pairLR.use)) stop("Please don't input signaling or pairLR.use simultaneously.")
    df <- data.frame(x = coordinates[, 1], y = coordinates[, 2],
                     cell_labels = cell_labels[samples == sample.use])
    if (!do.binary) {
      if (!is.null(signaling)) {
        res <- CellChat::extractEnrichedLR(object, signaling = signaling, geneLR.return = TRUE,
                                          enriched.only = enriched.only, thresh = thresh)
        feature.use <- res$geneLR
      } else if (!is.null(pairLR.use)) {
        pairLR.use.name <- pairLR.use$interaction_name
        LR.pair <- object@LR$LRsig[pairLR.use.name, c("ligand", "receptor")]
        geneL <- unique(LR.pair$ligand)
        geneR <- unique(LR.pair$receptor)
        geneL <- CellChat:::extractGeneSubset(geneL, object@DB$complex, object@DB$geneInfo)
        geneR <- CellChat:::extractGeneSubset(geneR, object@DB$complex, object@DB$geneInfo)
        feature.use <- c(geneL, geneR)
      } else {
        feature.use <- features
      }
      data.use <- data[feature.use, , drop = FALSE]
      if (!is.null(cutoff)) data.use[data.use <= cutoff] <- 0
      numFeature = length(feature.use)
      gg <- vector("list", numFeature)
      annotations <- vector("list", numFeature)
      for (i in seq_len(numFeature)) {
        feature.name <- feature.use[i]
        df$feature.data <- data.use[i,]
        g <- ggplot(df, aes(x, y)) +
          geom_point(aes(color = feature.data), size = point.size, alpha = alpha) +
          scale_color_gradientn(colors = colormap, na.value = "grey90") +
          ggtitle(feature.name) +
          theme_classic() +
          theme(axis.line = element_blank(), axis.ticks = element_blank(),
                axis.text = element_blank(), plot.title = element_text(hjust = 0.5))
        gg[[i]] <- plotly::ggplotly(g, height = 400)
        annotations[[i]] <- list(x = 0.5, y = 1, text = feature.name,
                               xref = "paper", yref = "paper", showarrow = FALSE)
      }
      if (numFeature > 1) {
        plotly::subplot(gg, nrows = plot_nrows, margin = 0.02) %>%
          plotly::layout(annotations = annotations)
      } else {
        plotly::ggplotly(gg[[1]])
      }
    } else {
      if (is.null(color.use)) color.use <- ggPalette(4)
      if (!is.null(signaling)) {
        res <- CellChat::extractEnrichedLR(object, signaling = signaling)
        LR.pair <- object@LR$LRsig[res$interaction_name, c("ligand", "receptor")]
      } else {
        LR.pair <- object@LR$LRsig[pairLR.use$interaction_name, c("ligand", "receptor")]
      }
      dataL <- CellChat:::computeExpr_LR(LR.pair$ligand, data, object@DB$complex)
      dataR <- CellChat:::computeExpr_LR(LR.pair$receptor, data, object@DB$complex)
      numFeature = nrow(LR.pair)
      gg <- vector("list", numFeature)
      annotations <- vector("list", numFeature)
      for (i in seq_len(numFeature)) {
        idx1 <- dataL[i,] > cutoff
        idx2 <- dataR[i,] > cutoff
        group <- factor(dplyr::case_when(
          idx1 & idx2 ~ "Both",
          idx1 ~ LR.pair$ligand[i],
          idx2 ~ LR.pair$receptor[i],
          TRUE ~ "None"
        ), levels = c(LR.pair$ligand[i], LR.pair$receptor[i], "Both", "None"))
        df$feature.data <- group
        g <- ggplot(df, aes(x, y)) +
          geom_point(aes(color = feature.data), size = point.size, alpha = alpha) +
          scale_color_manual(values = color.use, na.value = "grey90") +
          ggtitle(paste(LR.pair$ligand[i], LR.pair$receptor[i], sep = "_")) +
          theme_classic() +
          theme(axis.line = element_blank(), axis.ticks = element_blank(),
                axis.text = element_blank(), plot.title = element_text(hjust = 0.5))
        gg[[i]] <- plotly::ggplotly(g, height = 400)
        annotations[[i]] <- list(x = 0.5, y = 1, text = paste(LR.pair$ligand[i], LR.pair$receptor[i], sep = "_"),
                               xref = "paper", yref = "paper", showarrow = FALSE)
      }
      if (numFeature > 1) {
        plotly::subplot(gg, nrows = plot_nrows, margin = 0.02) %>%
          plotly::layout(annotations = annotations)
      } else {
        plotly::ggplotly(gg[[1]])
      }
    }
  }