#' @importFrom methods setClass

#' @importClassesFrom Signac Motif

#' @importClassesFrom SeuratObject Seurat

#' @importClassesFrom TFBSTools PWMatrixList

NULL

#' @title Motifs database class

#'

#' @description MotifsDatabase object stores motifs(PFM matrices)

#' and tf2motifs (TF to motifs names mapping) data.

#'

#' @slot motifs (TFBSTools::PWMatrixList) - PFM matrices.

#' @slot tf2motifs (data.frame) - TF to motif names mapping. Columns: motif, tf.

#'

#' @name  motifs_db-class

#' @rdname motifs_db-class

#' @exportClass motifs_db

motifs_db <- setClass("motifs_db",

                           representation(

                             motifs = "PWMatrixList",

                             tf2motifs = "data.frame",

                             tfs = "character"

                           ))

setMethod("show", "motifs_db",

  function(object) {

    cat(

      paste("Motifs database object with :\n- ",

          length(object@motifs), "motifs\n- ",

          length(unique(object@tf2motifs$tf)), " TFs\n- ",

          nrow(object@tf2motifs), "TF to motif names mapping"

          )

      )

  })

#' @title Multiplex class

#' @description Multiplex object stores a list of networks, a list of features and

#' a list of logicals indicating if the network is directed or weighted.

#' @slot networks (list) - List of networks.

#' @slot features (vector) - Vector of features.

#' @slot directed (list) - List of logical indicating if networks are directed.

#' @slot weighted (list) - List of logical indicating if networks are weighted.

#' 

#' @name multiplex-class

#' @rdname multiplex-class

#' @exportClass multiplex

multiplex <- setClass(Class = "multiplex",

                       slots = c(

                         "networks" = "list", # List of networks

                         "features" = "vector", # Vector of features

                         "directed" = "list", # Logical indicating

                                      # if the network is directed

                         "weighted" = "list" # Logical indicating

                                      # if the network is weighted

                         # "network_names" = "vector" # Vector of network names

                        )

                      )

setMethod("show", "multiplex",

  function(object) {

    cat(

      # Reprensentation of the multiplex object

      # with the number of networks and features, and the list of network names

      paste("Multiplex of ", length(object@networks),

      " networks with", length(object@features), "features.\n",

      "Networks names: ", paste(names(object@networks), collapse = ", "))

      )

  })

#' @title Bipartite class

#'

#' @description Bipartite object stores a bipartite network (edge list) and the names of the

#'  left and right features' multiplexes.

#' @slot network (data.frame) - Bipartite network (edge list)

#' @slot multiplex_left (character) - Left features' multiplex

#' @slot multiplex_right (character) - Right features' multiplex

#'

#' @name bipartite-class

#' @rdname bipartite-class

#' @exportClass bipartite

#'

#' @examples bipartite <- bipartite(

#'                           network = bipartite_network,

#'                          multiplex_left = "RNA",

#'                         multiplex_right = "peaks")

#'

bipartite <- setClass(Class = "bipartite",

                       slots = c(

                      "network" = "data.frame", # Bipartite network (edge list)

                      "multiplex_left" = "character", # left features' multiplex

                      "multiplex_right" = "character" # right features multiplex

                        )

                      )

setMethod("show", "bipartite",

  function(object) {

    cat(

      paste("Bipartite network of ", nrow(object@network), " edges.\n",

      "Multiplexes names: ", object@multiplex_left,

      " and ", object@multiplex_right, "\n")

      )

  })

#' @title Multilayer class

#'

#' @description Multilayer object stores a list of bipartite networks and a

#'  list of multiplex networks. It can also stores a config list to create a

#'  yaml file, which is used to parametrize the random walk with restart to

#' explore the multilayer.

#'

#' @slot bipartites (list) - List of bipartite networks

#' @slot multiplex (list) - List of multiplex networks

#' @slot config (list) - List of parameters to parametrize the random walk with

#' restart to explore the multilayer

#'

#' @name multilayer-class

#' @rdname multilayer-class

#' @exportClass multilayer

#'

multilayer <- setClass(Class = "multilayer",

                       slots = c(

                        "bipartites" = "list", # Bipartite networks

                        "multiplex" = "list", # Multiplex networks

                        "config" = "list" # Parameters to create the hmln

                        )                 # representation of a yaml file

                      )

setMethod("show", "multilayer",

  # Representation of the multilayer object with the number of bipartite and

  # multiplex networks, and the list of bipartite names and multiplex names

  function(object) {

    cat(

      paste("Multilayer network containing ",

      length(object@bipartites), " bipartite networks and ",

      length(object@multiplex), " multiplex networks.\n",

      "\n- Multiplex names: ", paste(names(object@multiplex),

                                          collapse = ", "),

      "\n- Bipartite names: ", paste(names(object@bipartites),

                                          collapse = ", "), "\n"

      )

    )

  })

#' The Hummus_Object class

#'

#' The Hummus_Object object is an extended \code{Seurat} object

#' for the storage and analysis of a heterogeneous multilayer network

#'

#' @slot multilayer (multilayer) - Multilayer object

#' @slot motifs_db (motifs_db) - Motifs database

#' @slot assay (list) - List of assays

#'

#' @name Hummus_Object-class

#' @rdname Hummus_Object-class

#' @exportClass Hummus_Object

#' @export

#'

Hummus_Object <- setClass(

    Class = "Hummus_Object",

    slots = list(

        "assays" = "list",

        "active.assay" = "character",

        "multilayer" = "multilayer",

        "motifs_db" = "motifs_db"

    )

)

#' @title Initiate a hummus object

#' 

#' @description Initiate a hummus object

#' 

#' @param seurat_assays A Seurat object or a list of Seurat assays

#' @param active.assay The name of the active assay. Default: NULL

#' @param multilayer A multilayer object. Default: NULL

#' @param motifs_db A motifs_db object. Default: NULL

#' @return A hummus object

#' @export

#' 

#' @examples seurat_object <- Seurat::CreateSeuratObject(counts = matrix(rnorm(1000), nrow = 100, ncol = 10))

#'          hummus <- InitiateHummus_Object(seurat_object)

#'          hummus

Initiate_Hummus_Object <- function(

  seurat_assays,

  active.assay = NULL,

  multilayer = NULL,

  motifs_db = NULL) {

  # Check if seurat_assays is a Seurat object or a list of Seurat assays

  if (inherits(seurat_assays, "Seurat")) {

    assays <- seurat_assays@assays

    # setup active assay name

    active.assay <- seurat_assays@active.assay

  } else if (inherits(seurat_assays, "list")) {

    assays <- seurat_assays

    # setup active assay name

    if (is.null(active.assay)) {

      active.assay <- names(x = assays)[1]

    } else if (!(active.assay %in% names(x = assays))) {

      stop("active.assay must be a valid assay name.")

    } else {

      active.assay <- active.assay

    }

  } else {

    stop("seurat_assays must be a Seurat object or a list of Seurat assays.")

  }

  # Check if multilayer is a multilayer object or NULL

  if (!inherits(multilayer, "multilayer")) {

    if (!is.null(multilayer)) {

      stop("multilayer must be a multilayer object or NULL.")

    } else {

      multilayer <- new("multilayer")

    }

  }

  # Check if motifs_db is a motifs_db object or NULL

  if (!inherits(motifs_db, "motifs_db")) {

    if (!is.null(motifs_db)) {

      stop("motifs_db must be a motifs_db object or NULL.")

    } else {

      motifs_db <- new("motifs_db")

    }

  }

  object <- new(

    Class = "Hummus_Object",

    assays = assays,

    active.assay = active.assay,

    multilayer = multilayer,

    motifs_db = motifs_db

  )

  return(object)

}

#' @title Get Default assays of Hummus_Object (based on Seurat)

#' @name DefaultAssay

#' @export

#'

#' @examples

#' # Get current default assay

#' DefaultAssay(object = pbmc_small)

#'

DefaultAssay.Hummus_Object <- function(object, ...) {

  SeuratObject::CheckDots(...)

  default <- slot(object = object, name = 'active.assay')

  if (!length(x = default)) {

    default <- NULL

  }

  return(default)

}

#' Default Assay

#'

#' Get and set the default assay

#'

#' @param object An object

#'

#' @return \code{DefaultAssay}: The name of the default assay

#'

#' @rdname DefaultAssay

#' @export DefaultAssay

#'

#' @concept data-access

#'

DefaultAssay <- function(object, ...) {

  UseMethod(generic = 'DefaultAssay', object = object)

}

#' @param value Name of assay to set as default

#'

#' @return \code{DefaultAssay<-}: An object with the default assay updated

#'

#' @rdname DefaultAssay

#' @export DefaultAssay<-

#'

"DefaultAssay<-" <- function(object, ..., value) {

  UseMethod(generic = 'DefaultAssay<-', object = object)

}

#' @title Variable features of assays in Hummus_Object (based on Seurat)

#' @name VariableFeatures

#' @export

#'

VariableFeatures.Hummus_Object <- function(

  object,

  method = NULL,

  assay = NULL,

  nfeatures = NULL,

  layer = NA,

  simplify = TRUE,

  selection.method = lifecycle::deprecated(),

  ...

) {

  SeuratObject::CheckDots(...)

  if (lifecycle::is_present(arg = selection.method)) {

    SeuratObject.Deprecate(

      when = '5.0.0',

      what = 'VariableFeatures(selection.method = )',

      with = 'VariableFeatures(method = )'

    )

    method <- selection.method

  }

  assay <- assay %||% SeuratObject::DefaultAssay(object = object)

  return(SeuratObject::VariableFeatures(

    object = object[[assay]],

    method = method,

    nfeatures = nfeatures,

    layer = layer,

    simplify = simplify,

    ...

  ))

}

#' @return \code{VariableFeatures}: a vector of the variable features

#'

#' @rdname VariableFeatures

#' @export VariableFeatures

#'

#'

VariableFeatures <- function(object, method = NULL, ...) {

  UseMethod(generic = 'VariableFeatures', object = object)

}

#' @param value A character vector of variable features

#'

#' @rdname VariableFeatures

#' @export VariableFeatures<-

#'

"VariableFeatures<-" <- function(object, ..., value) {

  UseMethod(generic = 'VariableFeatures<-', object = object)

}

#' @title Access assays in Hummus_Object (based on Seurat)

#' @method [[ Hummus_Object

#' @name [[<-,Hummus_Object

#' @export

#' @aliases [[<-.Hummus_Object \S4method{[[<-}{Hummus_Object,character,missing,Assay}

#' 

"[[.Hummus_Object" <- function(x, i = missing_arg(), ..., drop = FALSE, na.rm = FALSE) {

  md <- slot(object = x, name = 'assays')

  if (rlang::is_missing(x = i)) {

    return(md)

  } else if (is.null(x = i)) {

    return(NULL)

  } else if (!length(x = i)) {

    return(data.frame(row.names = row.names(x = md)))

  }

  # Correct invalid `i`

  meta.cols <- names(x = md)

  if (rlang::is_bare_integerish(x = i)) {

    if (all(i > length(x = meta.cols))) {

      abort(message = paste(

        "Invalid integer indexing:",

        "all integers greater than the number of meta columns"

      ))

    }

    i <- meta.cols[as.integer(x = i[i <= length(x = meta.cols)])]

  }

  if (!is.character(x = i)) {

    abort(message = "'i' must be a character vector")

  }

  # Determine if we're pulling cell-level meta data

  # or a sub-object

  slot.use <- if (length(x = i) == 1L) {

    SeuratObject::.FindObject(object = x, name = i)

  } else {

    NULL

  }

  # Pull cell-level meta data

  if (is.null(x = slot.use)) {

    i <- tryCatch(

      expr = arg_match(arg = i, values = meta.cols, multiple = TRUE),

      error = function(e) {

        #error message that indicates which colnames not found

        abort(

          message = paste(

            paste(sQuote(x = setdiff(x = i, y = meta.cols)), collapse = ', '),

            "not found in this HuMMuS object\n",

            e$body

          ),

          call = rlang::caller_env(n = 4L)

        )

      }

    )

    # Pull the cell-level meta data

    data.return <- md[, i, drop = FALSE, ...]

    # If requested, remove NAs

    if (isTRUE(x = na.rm)) {

      idx.na <- apply(X = is.na(x = data.return), MARGIN = 1L, FUN = all)

      data.return <- data.return[!idx.na, , drop = FALSE]

    } else {

      idx.na <- rep_len(x = FALSE, length.out = ncol(x = x))

    }

    # If requested, coerce to a vector

    if (isTRUE(x = drop)) {

      data.return <- unlist(x = data.return, use.names = FALSE)

      names(x = data.return) <- rep.int(

        x = colnames(x = x)[!idx.na],

        times = length(x = i)

      )

    }

    return(data.return)

  }

  # Pull a sub-object

  return(slot(object = x, name = slot.use)[[i]])

}

setMethod("show", "Hummus_Object",

  function(object) {

    #object <- SeuratObject::UpdateSlots(object = object)

    assays <- SeuratObject::.FilterObjects(object = object,

                                          classes.keep = "Assay")

    nfeatures <- sum(vapply(

      X = assays,

      FUN = function(x) {

        return(nrow(x = object[[x]]))

      },

      FUN.VALUE = integer(length = 1L)

    ))

    num.assays <- length(x = assays)

    cat("Hummus object containing a multilayer object :\n")

    show(object@multilayer)

    cat('\n\nAnd a Seurat object :\n\n')

    cat(

      nfeatures,

      "features across",

      ncol(x = object),

      "samples within",

      num.assays,

      ifelse(test = num.assays == 1, yes = "assay", no = "assays"),

      "\n"

    )

    cat(

      "Active assay:",

      SeuratObject::DefaultAssay(object = object),

      paste0('(', nrow(x = object), " features, ",

      length(x = SeuratObject::VariableFeatures(object = object))," variable features)")

    )

    other.assays <- assays[assays != SeuratObject::DefaultAssay(object = object)]

    if (length(x = other.assays) > 0) {

      cat(

        '\n',

        length(x = other.assays),

        'other',

        ifelse(test = length(x = other.assays) == 1, yes = 'assay', no = 'assays'),

        'present:',

        strwrap(x = paste(other.assays, collapse = ', '))

      )

    }

    reductions <- SeuratObject::.FilterObjects(object = object, classes.keep = 'DimReduc')

    if (length(x = reductions) > 0) {

      cat(

        '\n',

        length(x = reductions),

        'dimensional',

        ifelse(test = length(x = reductions) == 1, yes = 'reduction', no = 'reductions'),

        'calculated:',

        strwrap(x = paste(reductions, collapse = ', '))

      )

    }

    fovs <- SeuratObject::.FilterObjects(object = object, classes.keep = 'FOV')

    if (length(x = fovs)) {

      cat(

        '\n',

        length(x = fovs),

        'spatial',

        ifelse(test = length(x = fovs) == 1L, yes = 'field', no = 'fields'),

        'of view present:',

        strwrap(x = paste(fovs, sep = ', '))

      )

    }

    images <- SeuratObject::.FilterObjects(object = object, classes.keep = 'SpatialImage')

    images <- setdiff(x = images, y = fovs)

    if (length(x = images)) {

      cat(

        '\n',

        length(x = images),

        ifelse(test = length(x = images) == 1L, yes = 'image', no = 'images'),

        'present:',

        strwrap(x = paste(images, collapse = ', '))

      )

    }

    cat('\n')

  }

)

#' @title Save multilayer object files in a hierarchical structure on disk

#'

#' @description Save multilayer files from a Hummus_Object

#' in a hierarchical structure on disk, inside a folder specified through

#'  folder_name

#'

#' @param hummus A hummus object

#' @param folder_name The name of the folder to save the multilayer

#' @param verbose (integer) - Display function messages. Set to 0 for no

#'  message displayed, >= 1 for more details.

#' @param suffix The suffix of the files to save. Default: ".tsv"

#'

#' @return Nothing, but create a folder containing the multilayer object files

#' @export

#'

#' @examples folder_name = "multilayer"

#' save_multilayer(hummus = hummus, folder_name = "multilayer")

#'

save_multilayer <- function(

    hummus,

    folder_name,

    verbose = TRUE,

    suffix = ".tsv"

    ) {

  multiplex_folder <- "multiplex"

  bipartite_folder <- "bipartite"

  seed_folder      <- "seed"

  config_folder    <- "config"

  dir.create(folder_name)

  dir.create(paste0(folder_name, "/", multiplex_folder))

  dir.create(paste0(folder_name, "/", bipartite_folder))

  dir.create(paste0(folder_name, "/", seed_folder))

  dir.create(paste0(folder_name, "/", config_folder))

  # For each multiplex, create a subfolder of multiplex, 

  # and save its networks inside

  for (multiplex_name in names(hummus@multilayer@multiplex)){

    dir.create(paste0(folder_name, "/", multiplex_folder, "/", multiplex_name))

    print(hummus@multilayer@multiplex[[multiplex_name]])

    for (network_name in names(hummus@multilayer@multiplex[[multiplex_name]]@networks)){

      print(paste(multiplex_name, network_name))

      write.table(hummus@multilayer@multiplex[[multiplex_name]]@networks[[network_name]],

            col.names = FALSE, row.names = FALSE, quote = FALSE, sep = "\t",

             file = paste0(folder_name, "/",

                           multiplex_folder, "/",

                           multiplex_name, "/", network_name, suffix))

    }

  }

  # save bipartite networks

  for (bipartite in names(hummus@multilayer@bipartites)){

      write.table(hummus@multilayer@bipartites[[bipartite]]@network, sep = "\t",

                  col.names = FALSE, row.names = FALSE, quote = FALSE,

                  file = paste0(folder_name, "/",

                               bipartite_folder, "/",

                               bipartite, ".tsv"))

  }

}

#' @title Add a network to a multiplex, a multilayer or an hummus object

#'

#' @description Add a network to a multiplex, a multilayer or an hummus object

#'

#' @param object A multiplex, a multilayer or an hummus object

#' @param network A network (edge list)

#' @param network_name The name of the network

#' @param multiplex_name The name of the multiplex. Default: NULL if object is a

#' multiplex already only

#' @param directed Logical indicating if the network is directed. Default: FALSE

#' @param weighted Logical indicating if the network is weighted. Default: FALSE

#' @param verbose (integer) - Display function messages. Set to 0 for no

#' message displayed, >= 1 for more details.

#'

#' @return A multiplex, a multilayer or an hummus object with the added network

#' @export

#'

#' @examples hummus <- add_network(

#'                            object = hummus,

#'                            network = atac_peak_network,

#'                            network_name = network_name,

#'                            multiplex_name = multiplex_name,

#'                            weighted = TRUE,

#'                            directed = FALSE)

#' 

add_network <- function(

  object,

  network,

  network_name,

  multiplex_name = NULL,

  directed = FALSE,

  weighted = FALSE,

  verbose = 1) {

  # Check if object is a multiplex, a multilayer or an hummus object

  if (inherits(object, "multiplex")) {

    multiplex <- object

  } else if (inherits(object, "multilayer") ) {

    # Check if multiplex_name is NULL

    if (is.null(multiplex_name)) {

      stop("You need to specify the multiplex name.")

    }

    # Check if multiplex_name already exists

    if (!(multiplex_name %in% names(object@multiplex))) {

      if (verbose > 0) {

        cat("\tCreating new multiplex : ", multiplex_name, "\n")

      }

      # Create new multiplex if not

      object@multiplex[[multiplex_name]] <- new("multiplex")

    }

    # Get working multiplex

    multiplex <- object@multiplex[[multiplex_name]]

  } else if (inherits(object, "Hummus_Object")) {

    # Check if multiplex_name is NULL

    if (is.null(multiplex_name)) {

      stop("You need to specify the multiplex name.")

    }

    # Check if multiplex_name already exists

    if (!(multiplex_name %in% names(object@multilayer@multiplex))) {

      if (verbose > 0) {

        cat("\tCreating new multiplex : ", multiplex_name, "\n")

      }

      # Create new multiplex if not

      object@multilayer@multiplex[[multiplex_name]] <- new("multiplex")

    }

    # Get working multiplex

    multiplex <- object@multilayer@multiplex[[multiplex_name]]

  } else {

    stop("Object is not a multiplex, a multilayer nor an hummus object.: ", class(object))

  }

  # Check if network name already exists in the multiplex

  if (network_name %in% names(multiplex@networks)) {

    stop("Network name already exists in the multiplex.")

  }

  # Check if there is features in common

  features <- unique(c(unique(network[, 1]), unique(network[, 2])))

  if (length(intersect(features, multiplex@features)) == 0

      && length(multiplex@features) != 0) {

    stop(cat("There is no features in common.",

      "Check if there is a mistake in the features names",

      " or if you want to create a new multiplex instead."))

  }

  # Add network

  multiplex@networks[[network_name]] <- network

  multiplex@features <- unique(c(multiplex@features, features))

  multiplex@directed[[network_name]] <- directed

  multiplex@weighted[[network_name]] <- weighted

  # Return object

  if (inherits(object, "multiplex")) {

    return(multiplex)

  } else if (inherits(object, "multilayer")) {

    object@multiplex[[multiplex_name]] <- multiplex

    return(object)

  } else if (inherits(object, "Hummus_Object")) {

    object@multilayer@multiplex[[multiplex_name]] <- multiplex

    return(object)

  }

}

#' @title Wrapper function to save a network or not

#'

#' @description Wrapper function to save a network or not in a file according

#' to the store_network parameter. If store_network is TRUE, the network is

#' saved in the output_file.

#'

#' @param network A network (edge list)

#' @param store_network Logical indicating if the network should be saved

#' @param output_file The name of the file to save the network

#' @param verbose (integer) - Display function messages. Set to 0 for no

#' message displayed, >= 1 for more details.

#'

#' @return Nothing, but save the network in a file if store_network is TRUE

#' @export

#'

#' @examples network <- read.table("network.tsv", header = TRUE, sep = "\t")

#'           store_network(network = network,

#'               store_network = TRUE,

#'               output_file = "network.tsv",

#'               verbose = 1)

#'

store_network <- function(

    network,

    store_network,

    output_file,

    verbose = 1) {

  if (store_network) {

    if (is.null(output_file)) {

      stop("Please provide an output file name",

           " if you want to store the network.")

    }

    if (verbose > 0) {

      cat("\tStoring network in file : ", output_file, "\n")

    }

    write.table(network,

                output_file,

                col.names = TRUE,

                row.names = FALSE,

                quote = FALSE,

                sep = "\t")

  }

}