#' @title Adds a feature.
#' @description Adds a feature created using \code{feat_fun} from \code{fg} OR
#'  \code{m} into a given flowGraph object. Only use this function if
#'  you cannot generate the desired features using the existing flowGraph
#'  functions starting with \code{fg_feat_<feature name>}.
#' @param fg flowGraph object.
#' @param type A string specifying the type of the feature being
#'  added i.e. 'node' or 'edge'.
#' @param feature A string indicating the unique name of the feature added.
#' @param m A numeric matrix with feature values; it should contain the
#'  same sample id's on row names as in \code{fg_get_meta(fg)$id}
#'  and node or edge names
#'  as column names (i.e. if \code{m} is a node feature, it would have the same
#'  column names as those in \code{fg_get_graph(fg)$v$phenotype};
#'  if it is an edge
#'  feature, its column names should be the same as
#'  \code{paste0(fg_get_graph(fg)$e$from, '_', fg_get_graph(fg)$e$to)}).
#' @param feat_fun A function that ouputs a feature matrix as in \code{m} given
#'  \code{fg} and other optional parameters.
#' @param overwrite A logical variable indicating whether or not the function
#'  should replace the existing feature with the same name if
#'  one is already in \code{fg}.
#' @param ... Other parameters that would be used as input into \code{feat_fun}.
#' @return flowGraph object.
#' @details \code{fg_add_feature} adds the given new feature matrix to the
#'  given flowGraph object \code{fg} updating slots
#'  \code{feat} and \code{feat_desc}.
#'  See \code{\link[flowGraph]{flowGraph-class}}
#'  slot \code{feat} and \code{feat_desc} for what should be in these slots.
#'  We do not recommend users to directly use this method unless there is
#'  a clear understanding on how the row and column names should be specified.
#'  Instead, we recommend users to use the functions listed in the "See also"
#'  sections prefixed with "fg_feat_".
#' @examples
#'
#'  no_cores <- 1
#'  data(fg_data_pos30)
#'  fg <- flowGraph(fg_data_pos30$count, class=fg_data_pos30$meta$class,
#'                  prop=FALSE, specenr=FALSE,
#'                  no_cores=no_cores)
#'  fg_get_feature_desc(fg)
#'
#'  fg <- fg_add_feature(fg, type="node", feature="count_copy",
#'                       m=fg_data_pos30$count)
#'  fg_get_feature_desc(fg)
#'
#' @seealso
#'  \code{\link[flowGraph]{flowGraph-class}}
#'  \code{\link[flowGraph]{fg_feat_node_prop}}
#'  \code{\link[flowGraph]{fg_feat_node_specenr}}
#'  \code{\link[flowGraph]{fg_get_feature}}
#'  \code{\link[flowGraph]{fg_rm_feature}}
#'  \code{\link[flowGraph]{fg_get_feature_desc}}
#' @rdname fg_add_feature
#' @export
fg_add_feature <- function(
    fg, type="node", feature, m=NULL, feat_fun=NULL, overwrite=FALSE, ...
) {
    type <- match.arg(type, c("node", "edge"))
    fg_feat <- fg_get_feature_all(fg)
    fg_feat_desc <- fg_get_feature_desc(fg)

    feat_names <- names(fg_feat[[type]])
    exists_ <- feature %in% feat_names
    if (exists_) {
        if (!overwrite) {
            message("skipped")
            return(fg)
        }
        f_ind <- feat_names != feature
        fg_feat_desc[[type]] <- fg_feat_desc[[type]][f_ind,,drop=FALSE]
        fg_feat[[type]] <- fg_feat[[type]][f_ind]
    }

    if (is.null(m)) {
        if (is.null(feat_fun))
            stop("please provide a feature matrix or a function to create one")
        m <- feat_fun(fg, ...)
    }

    fg@feat_desc[[type]] <-
        rbind(fg_feat_desc[[type]], summary_table(m, feature))
    fg@feat[[type]][[feature]] <- m

    return(fg)
}


#' @title Removes a feature.
#' @description Removes a feature from a given flowGraph object.
#' @param fg flowGraph object.
#' @param type A string specifying the type of the feature being
#'  removed i.e. 'node' or 'edge'.
#' @param feature A string indicating the unique name of the feature removed;
#'  note we cannot remove the 'node' 'count' feature type.
#' @return flowGraph object with specified feature removed.
#' @details \code{fg_rm_feature} removes a specified feature matrix from the
#'  given flowGraph object \code{fg} updating slots
#'  \code{feat} and \code{feat_desc}.
#'  See \code{\link[flowGraph]{flowGraph-class}}
#'  slot \code{feat} and \code{feat_desc} for what should be in these slots.
#' @examples
#'
#'  no_cores <- 1
#'  data(fg_data_pos30)
#'  fg <- flowGraph(fg_data_pos30$count, class=fg_data_pos30$meta$class,
#'                  no_cores=no_cores)
#'  fg_get_feature_desc(fg)
#'
#'  fg <- fg_rm_feature(fg, type="node", feature="prop")
#'  fg_get_feature_desc(fg)
#'
#' @seealso
#'  \code{\link[flowGraph]{flowGraph-class}}
#'  \code{\link[flowGraph]{fg_add_feature}}
#'  \code{\link[flowGraph]{fg_get_feature}}
#'  \code{\link[flowGraph]{fg_get_feature_desc}}
#'  \code{\link[flowGraph]{fg_rm_summary}}
#' @rdname fg_rm_feature
#' @export
fg_rm_feature <- function(fg, type="node", feature=NULL) {
    type <- match.arg(type, c("node", "edge"))
    if (feature=="count" & type=="node")
        stop("cannot remove the count node feature from a flowGraph object.")
    ft_ind <- which(names(fg_get_feature_all(fg)[[type]]) == feature)
    fg@feat[[type]][[feature]] <- NULL
    if (length(ft_ind)==1) {
        fg@feat_desc[[type]] <-
            fg_get_feature_desc(fg)[[type]][-ft_ind,, drop=FALSE]
    } else {
        warning("feature not found, nothing was dropped")
    }
    # don't need the drop part, but just in case.
    return(fg)
}


#' @title Adds a feature summary.
#' @description Adds a feature summary into a given flowGraph object.
#'  Only use this function if your summary statistic cannot be calcuated
#'  using the \code{\link[flowGraph]{fg_summary}} function.
#' @param fg flowGraph object.
#' @param type A string indicating feature type the summary was created for;
#'  'node' or 'edge'.
#' @param summary_meta The user must provide \code{type} and
#'  \code{summary_meta}.
#'
#'  \code{summary_meta} is a list containing
#'  \code{feature} (feature name), \code{test_name} (summary statistic name),
#'  \code{class} (class), \code{label1}, and \code{label2} (class labels compared).
#'  See \code{\link[flowGraph]{fg_get_summary_desc}} for details.
#' @param p A list containing summary values; this list contains elements:
#'  \code{values} (a vector containing summary statistics e.g. p-values;
#'   this vector should be named by their associated phenotype or edge name),
#'  \code{test_custom} (a function of the statistical test used), and
#'  \code{adjust_custom} (a function of the p-value correction method used).
#'  This list must contain the \code{values} element.
#' @param summ_fun  A function that ouputs a feature summary matrix
#'  as in \code{p} given \code{fg} and other optional parameters.
#' @param overwrite A logical variable indicating whether or not the function
#'  should replace the existing feature summary with the
#'  same name if one is already in \code{fg}.
#' @param ... Other parameters that would be used as input into \code{summ_fun}.
#' @return flowGraph object.
#' @details \code{fg_add_summary} adds the given feature summary list \code{p}
#'  or the output of the given function \code{summ_fun} to the
#'  given flowGraph object \code{fg} updating slots
#'  \code{summary} and \code{summary_desc}.
#'  See \code{\link[flowGraph]{flowGraph-class}}
#'  slot \code{summary} and \code{summary_desc}
#'  for what should be in these slots. We do not recommend users directly use
#'  this function unless what is required is duly in the above slots is
#'  well understood --- note these slots are used in plotting functions
#'  e.g. \code{\link[flowGraph]{fg_plot}}. We instead recommend users to use
#'  the \code{\link[flowGraph]{fg_summary}} function.
#' @examples
#'
#'  no_cores <- 1
#'  data(fg_data_pos30)
#'  fg <- flowGraph(fg_data_pos30$count, class=fg_data_pos30$meta$class,
#'                  no_cores=no_cores)
#'
#'  # get samples that we are going to compare
#'  m <- fg_get_feature(fg, type="node", feature="prop")
#'  m1_ <- m[fg_data_pos30$meta$class=="control",,drop=FALSE]
#'  m2_ <- m[fg_data_pos30$meta$class=="exp",,drop=FALSE]
#'
#'  # define test or summary function to conduct comparison
#'  test_custom <- function(x,y)
#'      tryCatch(stats::t.test(x,y)$p.value, error=function(e) 1)
#'  values_p <- sapply(seq_len(ncol(m)), function(j)
#'      test_custom(m1_[,j], m2_[,j]) )
#'  values_p <- p.adjust(values_p , method="BY")
#'
#'  # the user can choose to fill either parameter "p" or "summ_fun",
#'  # the latter of which must output a list with the same elements as "p".
#'  # see documentation for ?flowGraph-class, slot "summary" for
#'  # details on what should be in "p".
#'  p <- list(values=values_p, test_fun=test_custom, adjust_fun="BY")
#'  fg <- fg_add_summary(fg, type="node", summary_meta=list(
#'       feature="prop", test_name="wilcox_BY",
#'       class="class", label1="control", label2="exp"), p=p)
#'
#'  fg_get_summary_desc(fg)
#'
#'
#' @seealso
#'  \code{\link[flowGraph]{flowGraph-class}}
#'  \code{\link[flowGraph]{fg_summary}}
#'  \code{\link[flowGraph]{fg_get_summary}}
#'  \code{\link[flowGraph]{fg_rm_summary}}
#'  \code{\link[flowGraph]{fg_get_summary_desc}}
#'  \code{\link[flowGraph]{fg_add_feature}}
#' @rdname fg_add_summary
#' @export
#' @importFrom purrr map_lgl compact
fg_add_summary <- function(
    fg, type="node", summary_meta=NULL,
    p=NULL, summ_fun=NULL, overwrite=FALSE, ...
) {
    type <- match.arg(type, c("node", "edge"))
    options(stringsAsFactors=FALSE)
    try({
        index <- fg_get_summary_index(
            fg, type=type, summary_meta=summary_meta)
        if (!overwrite) {
            message("summary exists, skipped")
            return(fg)
        }
        fg <- fg_rm_summary(fg, type=type, index=index)
    }, silent=TRUE)

    if (is.null(p)) {
        if (is.null(summ_fun))
            stop("provide summary statistic values or a function to create one")
        p <- summ_fun(fg, type=type, ...)  # list(values, test, adjust)
    }

    # legacy, left here just in case
    if ("m1"%in%names(p)) p[["m1"]] <- NULL
    if ("m2"%in%names(p)) p[["m2"]] <- NULL
    p <- purrr::compact(p)

    sm <- data.frame(matrix(summary_meta, nrow=1))
    colnames(sm) <- c("feat", "test_name","class","label1", "label2")
    if (length(fg_get_summary_desc(fg)[[type]])==0) {
        fg@summary_desc[[type]] <- sm
    } else {
        fg@summary_desc[[type]] <- rbind(fg_get_summary_desc(fg)[[type]], sm)
        rownames(fg@summary_desc[[type]]) <- NULL
    }

    if (is.null(fg_get_summary_all(fg)[[type]])) fg@summary[[type]] <- list()
    fg@summary[[type]][[nrow(fg_get_summary_desc(fg)[[type]])]] <- p

    return(fg)
}


#' @title Removes a feature summary.
#' @description Removes a feature summary from a given flowGraph object;
#'  while \code{fg} is required, the user can choose to input parameters
#'  \code{summary_meta}, \code{index}, or all of \code{type},
#'  \code{feat}, \code{test_name}, \code{class}, \code{label1},
#'   and \code{label2}.
#'  See \code{\link[flowGraph]{fg_get_summary_desc}} for details.
#' @param fg flowGraph object.
#' @param type A string indicating feature type the summary was created for;
#'  'node' or 'edge'.
#' @param index The user must provide \code{type} and
#'  additionally, one of \code{summary_meta} or \code{index}.
#'
#'  \code{index} is an integer indicating the row in
#'  \code{fg_get_summary_desc(<flowGraph>)} of the corresponding type and
#'  summary the user would like to retrieve.
#' @param summary_meta The user must provide \code{type} and
#'  additionally, one of \code{summary_meta} or \code{index}.
#'
#'  \code{summary_meta} is a list containing

#'  \code{feat} (feature name), \code{test_name} (summary statistic name),
#'  \code{class} (class), \code{label1}, and \code{label2} (class labels compared).
#'  See \code{\link[flowGraph]{fg_get_summary_desc}} for details.
#' @return flowGraph object.
#' @examples
#'
#'  no_cores <- 1
#'  data(fg_data_pos30)
#'  fg <- flowGraph(fg_data_pos30$count, class=fg_data_pos30$meta$class,
#'                  prop=FALSE, specenr=FALSE,
#'                  no_cores=no_cores)
#'
#'  fg <- fg_summary(fg, no_cores=no_cores, class="class", label1="control",
#'                   overwrite=FALSE, test_name="wilcox_byLayer", diminish=FALSE,
#'                   node_features=NULL, edge_features=NULL)
#'  fg_get_summary_desc(fg)
#'
#'  fg <- fg_rm_summary(fg, summary_meta=c(
#'      feature="count",test_name="wilcox_byLayer",
#'      class="class", label1="control", label2="exp"))
#'  fg_get_summary_desc(fg)
#'
#' @seealso
#'  \code{\link[flowGraph]{flowGraph-class}}
#'  \code{\link[flowGraph]{fg_get_summary}}
#'  \code{\link[flowGraph]{fg_add_summary}}
#'  \code{\link[flowGraph]{fg_get_summary_desc}}
#'  \code{\link[flowGraph]{fg_rm_feature}}
#' @rdname fg_rm_summary
#' @export
#' @importFrom purrr map_lgl
fg_rm_summary <- function(fg, type="node", index=NULL, summary_meta=NULL) {
    type <- match.arg(type, c("node", "edge"))
    index <- fg_get_summary_index(fg,type=type, index,summary_meta)
    fg@summary[[type]][[index]] <- NULL
    # don't need the drop part, but just in case.
    fg@summary_desc[[type]] <-
        fg_get_summary_desc(fg)[[type]][-index,, drop=FALSE]
    return(fg)
}

#' @title Clears all featuresin a flowGraph object.
#' @description Returns a flowGraph object with only the \code{count} feature.
#' @param fg flowGraph object.
#' @return flowGraph object with only the \code{count} \code{node} feature.
#' @examples
#'
#'  no_cores <- 1
#'  data(fg_data_pos30)
#'  fg <- flowGraph(fg_data_pos30$count, class=fg_data_pos30$meta$class,
#'                  no_cores=no_cores)
#'
#'  fg <- fg_clear_features(fg)
#'  fg_get_summary_desc(fg)
#'
#' @seealso
#'  \code{\link[flowGraph]{flowGraph-class}}
#' @rdname fg_clear_features
#' @export
#' @importFrom purrr compact
fg_clear_features <- function(fg) {
    if (length(fg_get_feature_all(fg)$node)>1)
        fg@feat$node[!names(fg_get_feature_all(fg)$node)%in%"count"] <- NULL
    fg@feat$node <- purrr::compact(fg_get_feature_all(fg)$node)
    fg@feat$edge <- fg@feat_desc$edge <- list()
    fg@feat_desc$node <-
        fg_get_feature_desc(fg)$node[fg_get_feature_desc(fg)$node$feat=="count",]
    return(fg)
}


#' @title Removes all summary statistics.
#' @description Removes all summary statistics in a flowGraph object;
#'  we recommend doing this to save space.
#' @param fg flowGraph object.
#' @return flowGraph object with an empty \code{summary} slot.
#' @examples
#'
#'  no_cores <- 1
#'  data(fg_data_pos30)
#'  fg <- flowGraph(fg_data_pos30$count, class=fg_data_pos30$meta$class,
#'                  prop=FALSE, specenr=FALSE,
#'                  no_cores=no_cores, node_features="count")
#'  fg_get_summary_desc(fg)
#'
#'  fg <- fg_clear_summary(fg)
#'  fg_get_summary_desc(fg)
#'
#' @seealso
#'  \code{\link[flowGraph]{flowGraph-class}}
#'  \code{\link[flowGraph]{fg_summary}}
#' @rdname fg_clear_summary
#' @export
fg_clear_summary <- function(fg) {
    fg@summary <- fg@summary_desc <- list()
    fg@etc$actualVSexpect <- list()
    return(fg)
}


#' @title Clears all features and feature summaries in a flowGraph object.
#' @description Returns a flowGraph object with only the \code{count} feature
#'  and meta data. This function clears all other features and
#'  feature summaries to save space.
#' @param fg flowGraph object.
#' @return flowGraph object with all summary statistics and feature values
#'  removed except for the node count feature.
#' @examples
#'
#'  no_cores <- 1
#'  data(fg_data_pos30)
#'  fg <- flowGraph(fg_data_pos30$count, class=fg_data_pos30$meta$class,
#'                  no_cores=no_cores)
#'
#'  fg <- fg_extract_raw(fg)
#'  show(fg)
#'
#' @seealso
#'  \code{\link[flowGraph]{flowGraph-class}}
#' @rdname fg_extract_raw
#' @export
fg_extract_raw <- function(fg) {
    fg <- fg_clear_summary(fg)
    fg <- fg_clear_features(fg)
    return(fg)
}

#' @title Replace marker names.
#' @description Replace marker names in a flowGraph object.
#' @param fg flowGraph object.
#' @param markers_new A string vector of new marker names;
#'  if \code{markers_old} is set to \code{NULL},
#'  each marker in \code{markers_new} should correspond to
#'  each marker in the \code{markers} slot of the \code{flowGraph} object.
#' @param markers_old A string vector of old marker names user wants to replace;
#' these marker names corresponding to those
#' in \code{fg_get_markers(fg)} with the same length as \code{markers_new}.
#' If \code{markers_old=NULL}, \code{markers_new} should be the same length as
#' \code{fg_get_markers(fg)}.
#' @return flowGraph object with marker names replaced.
#' @examples
#'
#'  no_cores <- 1
#'  data(fg_data_pos30)
#'  fg <- flowGraph(fg_data_pos30$count, class=fg_data_pos30$meta$class,
#'                  prop=FALSE, specenr=FALSE,
#'                  no_cores=no_cores)
#'
#'  fg <- fg_gsub_markers(fg, c("Anew", "Bnew", "Cnew", "Dnew"))
#'  fg_get_feature_desc(fg)
#'
#' @rdname fg_gsub_markers
#' @export
#' @seealso
#'  \code{\link[flowGraph]{flowGraph-class}}
#'  \code{\link[flowGraph]{fg_gsub_ids}}
#' @importFrom purrr map
fg_gsub_markers <- function(fg, markers_new, markers_old=NULL) {

    if (is.null(markers_old)) {
        if (length(markers_new) != length(fg_get_markers(fg)))
            stop("incorrect number of markers\n")

        markers_old <- fg_get_markers(fg)
    } else {
        if (length(markers_old) != length(markers_new))
            stop("incorrect number of markers\n")
    }
    for (mi in seq_len(length(markers_old))) {
        fg_graph <- fg_get_graph(fg)
        fg@graph$v$phenotype <-
            gsub(markers_old[mi], markers_new[mi], fg_graph$v$phenotype)
        fg@graph$e$from <-
            gsub(markers_old[mi], markers_new[mi], fg_graph$e$from)
        fg@graph$e$to <-
            gsub(markers_old[mi], markers_new[mi], fg_graph$e$to)
        fg@graph$e$marker <-
            gsub(markers_old[mi], markers_new[mi], fg_graph$e$marker)

        fg@edge_list$parent <-
            purrr::map(fg@edge_list$parent, function(x)
                gsub(markers_old[mi], markers_new[mi], x))
        names(fg@edge_list$parent) <-
            gsub(markers_old[mi], markers_new[mi], names(fg@edge_list$parent))
        fg@edge_list$child <-
            purrr::map(fg@edge_list$child, function(x)
                purrr::map(x, function(y)
                    gsub(markers_old[mi], markers_new[mi], y) ))
        names(fg@edge_list$child) <-
            gsub(markers_old[mi], markers_new[mi], names(fg@edge_list$child))
    }
    fg_graph <- fg_get_graph(fg)
    fg@feat$node <- purrr::map(fg_get_feature_all(fg)$node, function(x) {
        colnames(x) <- fg_graph$v$phenotype
        x
    })
    if (length(fg_get_feature_all(fg)$edge) > 0) {
        ecn <- paste0(fg_graph$e$from, "__", fg_graph$e$to)
        fg@feat$edge <- purrr::map(fg_get_feature_all(fg)$edge, function(x) {
            colnames(x) <- ecn
            x
        })
    }

    fg@markers[match(markers_old, fg_get_markers(fg))] <- markers_new
    return(fg)
}

#' @title Replace sample id's.
#' @description Replace sample id's in a flowGraph object.
#' @param fg flowGraph object.
#' @param ids_new A string vector of new sample id's; if \code{ids_old} is
#' set to \code{NULL}, each id in \code{ids_new} should correspond to
#' each id in \code{fg_get_meta(fg)$id}.
#' @param ids_old A string vector of old sample id's the user wants to replace;
#' these marker names corresponding to those
#' in \code{fg_get_meta(fg)$id} with the same length as \code{ids_new}.
#' If \code{ids_old=NULL}, \code{ids_new} should be the same length as
#' \code{fg_get_meta(fg)$id}.
#' @return flowGraph object with sample id's replaced.
#' @examples
#'
#'  no_cores <- 1
#'  data(fg_data_pos30)
#'  fg <- flowGraph(fg_data_pos30$count, class=fg_data_pos30$meta$class,
#'                  prop=FALSE, specenr=FALSE,
#'                  no_cores=no_cores)
#'
#'  fg <- fg_gsub_ids(fg, ids_new=paste0(fg_get_meta(fg)$id, "_new"))
#'
#' @seealso
#'  \code{\link[flowGraph]{flowGraph-class}}
#'  \code{\link[flowGraph]{fg_get_feature_desc}}
#'  \code{\link[flowGraph]{fg_gsub_markers}}
#' @rdname fg_gsub_ids
#' @export
#' @importFrom purrr map
fg_gsub_ids <- function(fg, ids_new, ids_old=NULL) {

    fg_meta <- fg_get_meta(fg)
    fg_feat <- fg_get_feature_all(fg)
    if (is.null(ids_old)) {
        if (length(ids_new) != nrow(fg_meta))
            stop("incorrect number of ids\n")

        ids_old <- fg_meta$id
    } else if (length(ids_old) != length(ids_new)) {
        stop("incorrect number of ids\n")
    }

    ids_ind <- match(ids_old, fg_meta$id)
    fg@meta$id[ids_ind] <- ids_new
    fg@feat$node <- purrr::map(fg_feat$node, function(x) {
        rownames(x)[ids_ind] <- ids_new
        x
    })
    if (length(fg_feat$edge) > 0) {
        fg@feat$edge <- purrr::map(fg_feat$edge, function(x) {
            rownames(x)[ids_ind] <- ids_new
            x
        })
    }

    fg@feat_desc <- fg_get_feature_desc(fg, re_calc=TRUE)
    return(fg)
}


#' @title Merges the samples from two flowGraph objects.
#' @description Merges the samples from two flowGraph objects together;
#'  we recommend removing all summary statistics from the new flowGraph object
#'  as those won't be adjusted: \code{\link[flowGraph]{fg_clear_summary}}.
#' @param fg1 flowGraph object.
#' @param fg2 flowGraph object.
#' @return flowGraph object.
#' @details Appends the samples from \code{fg2} onto those in \code{fg1}.
#'  This function requires that the two flowGraph objects must have the
#'  same phenotypes. Therefore, we recommend users to use,
#'  instead, \code{\link[flowGraph]{fg_merge}}.
#' @examples
#'
#'  no_cores <- 1
#'  data(fg_data_pos30)
#'  fg0 <- flowGraph(fg_data_pos30$count, class=fg_data_pos30$meta$class,
#'                  prop=FALSE, specenr=FALSE,
#'                  no_cores=no_cores)
#'
#'  fg1 <- fg_extract_samples(fg0, fg_get_meta(fg0)$id[1:5])
#'  fg2 <- fg_extract_samples(fg0, fg_get_meta(fg0)$id[4:7])
#'  fg <- fg_merge_samples(fg1, fg2)
#'  fg_get_feature_desc(fg)
#'
#' @seealso
#'  \code{\link[flowGraph]{flowGraph-class}}
#'  \code{\link[flowGraph]{fg_get_feature_desc}}
#'  \code{\link[flowGraph]{fg_merge}}
#'  \code{\link[flowGraph]{fg_extract_samples}}
#' @rdname fg_merge_samples
#' @export
#' @importFrom purrr map
fg_merge_samples <- function(fg1, fg2) {
    fg <- fg1

    fg1_meta <- fg_get_meta(fg1)
    fg2_meta <- fg_get_meta(fg2)
    fg1_feat <- fg_get_feature_all(fg1)
    fg2_feat <- fg_get_feature_all(fg2)

    cnames = intersect(colnames(fg1_meta), colnames(fg2_meta))

    id2 <- setdiff(fg2_meta$id, fg1_meta$id)
    meta2 <- fg2_meta[fg2_meta$id%in%id2,cnames,drop=FALSE]
    meta1 <- fg1_meta[,cnames,drop=FALSE]

    fg@meta <- rbind(meta1, meta2)
    nfs <- intersect(names(fg1_feat$node),
                           names(fg2_feat$node))
    fg@feat$node=purrr::map(nfs, function(xi) {
        a <- fg1_feat$node[[xi]]
        b <- fg2_feat$node[[xi]][id2, , drop=FALSE]
        abcol <- intersect(colnames(a), colnames(b))
        ab <- rbind(a[,match(abcol, colnames(a)), drop=FALSE],
                          b[match(setdiff(rownames(b),
                                                      rownames(a)),
                                        rownames(b)),
                            match(abcol, colnames(b)), drop=FALSE])
    })
    names(fg@feat$node) <- nfs
    if (length(fg@feat$edge) > 0) {
        efs <- intersect(names(fg1_feat$edge),
                               names(fg2_feat$edge))
        fg@feat$edge <- purrr::map(efs, function(xi) {
            a <- fg1_feat$edge[[xi]]
            b <- fg2_feat$edge[[xi]][id2,, drop=FALSE]
            abcol <- intersect(colnames(a),
                                     colnames(b))
            ab <- rbind(
                a[, match(abcol, colnames(a)), drop=FALSE],
                b[match(setdiff(rownames(b),
                                            rownames(a)),
                              rownames(b)),
                  match(abcol, colnames(b)),drop=FALSE])
        })
        names(fg@feat$edge) <- efs
    }

    fg@feat_desc <- fg_get_feature_desc(fg, re_calc=TRUE)
    fg <- fg_clear_summary(fg)
    warning("merging two flowGraph objects will clear the summary statistics")
    return(fg)
}


#' @title Extracts a set of samples from a flowGraph object.
#' @description Extracts or removes a specified set of samples from
#'  a flowGraph object.
#' @param fg flowGraph object.
#' @param sample_ids A string vector of sample id's that the user wants to
#'  keep in \code{fg}.
#' @param rm_summary A logical indicating whether or not to clear summary.
#' @return flowGraph object.
#' @details The summaries in \code{fg} will not be modified;
#'  we recommend the user recalculates them.
#' @examples
#'
#'  no_cores <- 1
#'  data(fg_data_pos30)
#'  fg0 <- flowGraph(fg_data_pos30$count, class=fg_data_pos30$meta$class,
#'                  prop=FALSE, specenr=FALSE,
#'                  no_cores=no_cores)
#'  fg_get_feature_desc(fg0)
#'
#'  fg <- fg_extract_samples(fg0, fg_get_meta(fg0)$id[1:5])
#'  fg_get_feature_desc(fg)
#'
#' @seealso
#'  \code{\link[flowGraph]{flowGraph-class}}
#'  \code{\link[flowGraph]{fg_get_feature_desc}}
#'  \code{\link[flowGraph]{fg_merge}}
#'  \code{\link[flowGraph]{fg_extract_phenotypes}}
#' @rdname fg_extract_samples
#' @export
#' @importFrom purrr map
fg_extract_samples <- function(fg, sample_ids, rm_summary=TRUE) {
    fg_meta <- fg_get_meta(fg)
    if (!any(sample_ids %in% fg_meta$id))
        stop("please provide valid sample id's; see @meta$id\n")


    id_inds <- match(sample_ids, fg_meta$id)

    fg@meta <- fg_meta[id_inds, , drop=FALSE]

    fg_feat <- fg_get_feature_all(fg)
    fg@feat$node <- purrr::map(fg_feat$node, function(x)
        x[id_inds, , drop=FALSE])
    if (length(fg_feat$edge) > 0)
        fg@feat$edge <- purrr::map(fg_feat$edge, function(x)
            x[id_inds,, drop=FALSE])

    fg@feat_desc <- fg_get_feature_desc(fg, re_calc=TRUE)

    fg_summary <- fg_get_summary_all(fg)
    if (!is.null(fg_summary$node) | !is.null(fg_summary$edge))
        if (rm_summary) {
            warning("subsetting samples mean that summary statistics will no longer be valide, removing summary statistics.")
            fg <- fg_clear_summary(fg)
        }
    return(fg)
}


#' @title Extracts a set of phenotypes from a flowGraph object.
#' @description Extracts or removes a specified set of
#'  phenotypes from a flowGraph object.
#' @param fg flowGraph object.
#' @param phenotypes A string vector of phenotype or
#'  cell population name labels.
#' @return flowGraph object.
#' @details The \code{summary} in \code{fg} will not be modified;
#'  we recommend users recalculate them.
#' @examples
#'
#'  no_cores <- 1
#'  data(fg_data_pos30)
#'  fg0 <- flowGraph(fg_data_pos30$count, class=fg_data_pos30$meta$class,
#'                  prop=FALSE, specenr=FALSE,
#'                  no_cores=no_cores)
#'  fg_get_feature_desc(fg0)
#'
#'  fg <- fg_extract_phenotypes(fg0, fg_get_graph(fg0)$v$phenotype[1:10])
#'  fg_get_feature_desc(fg)
#'
#' @seealso
#'  \code{\link[flowGraph]{flowGraph-class}}
#'  \code{\link[flowGraph]{fg_get_feature_desc}}
#'  \code{\link[flowGraph]{fg_merge}}
#'  \code{\link[flowGraph]{fg_extract_samples}}
#'  \code{\link[flowGraph]{fg_merge_samples}}
#' @rdname fg_extract_phenotypes
#' @export
#' @importFrom purrr map compact
fg_extract_phenotypes <- function(fg, phenotypes) {
    if (!any(phenotypes %in% fg@graph$v$phenotype))
        stop("please provide valid phenotypes; see @graph$v\n")

    fg_graph <- fg_get_graph(fg)

    id_inds <- fg_graph$v$phenotype %in% phenotypes
    id_inds_ <- fg_graph$e$from %in% phenotypes &
        fg_graph$e$to %in% phenotypes

    fg@graph$v <- fg_graph$v[id_inds,, drop=FALSE]
    fg@graph$e <- fg_graph$e[id_inds_,, drop=FALSE]
    fg <- fg_set_layout(fg, fg_get_plot_layout(fg))

    fg_feat <- fg_get_feature_all(fg)
    fg@feat$node <- purrr::map(fg_feat$node, function(x)
        x[, id_inds, drop=FALSE])
    if (length(fg_feat$edge) > 0)
        fg@feat$edge <- purrr::map(fg_feat$edge, function(x)
            x[, id_inds_, drop=FALSE])

    fg@edge_list$child <-
        fg@edge_list$child[phenotypes[phenotypes %in%
                                          names(fg@edge_list$child)]]
    fg@edge_list$child <- purrr::map(fg@edge_list$child, function(x)
        purrr::map(x, function(y) {
            a <- y[y %in% phenotypes]
            if (length(a) == 0)
                return(NULL)
            a
        }))

    fg@edge_list$child <- purrr::compact(fg@edge_list$child)
    fg@edge_list$parent <-
        fg@edge_list$parent[phenotypes[phenotypes %in%
                                           names(fg@edge_list$parent)]]
    fg@edge_list$parent <- purrr::map(fg@edge_list$parent, function(x) {
        a <- x[x %in% phenotypes]
        if (length(a) == 0)
            return(NULL)
        a
    })
    fg@edge_list$parent <- purrr::compact(fg@edge_list$parent)

    if (length(fg@summary)>0) {
        if (length(fg@summary$node)>0)
            fg@summary$node <- purrr::map(fg@summary$node, function(x) {
                x$values <- x$values[id_inds]
                x
            })
        if (length(fg@summary$edge)>0)
            fg@summary$edge <- purrr::map(fg@summary$edge, function(x) {
                x$values <- x$values[id_inds_]
                x
            })
    }

    fg@feat_desc <- fg_get_feature_desc(fg, re_calc=TRUE)
    return(fg)
}


#' @title Merges two flowGraph objects together.
#' @description Merges two flowGraph objects together.
#' @param fg1 flowGraph object.
#' @param fg2 flowGraph object.
#' @param method_sample A string indicating how samples from flowGraph objects
#'  should be merged:
#'  \itemize{
#'    \item{\code{union}: keep all samples from both flowGraph objects;
#'     in this case \code{method_phenotype} must be \code{intersect}.}
#'    \item{\code{intersect}: keep only samples that exist
#'     in both \code{fg1} and \code{fg2}.}
#'    \item{\code{setdiff}: keep only samples that exist
#'     in \code{fg1} and not in \code{fg2}.}
#'    \item{\code{none}: keep all samples in \code{fg1}.}
#'  }
#' @param method_phenotype  A string indicating how phenotypes from
#' flowGraph objects should be merged:
#'  \itemize{
#'   \item{\code{intersect}: keep only phenotypes that exist in both
#'    \code{fg1} and \code{fg2}.}
#'   \item{\code{setdiff}: keep only phenotypes that exist in
#'    \code{fg1} and not in \code{fg2}.}
#'   \item{\code{none}: keep all phenotypes in \code{fg1}.}
#'  }
#' @return flowGraph object.
#' @details \code{fg_merge} is a generic function that merges the samples and
#'  phenotypes of two flowGraph objects.
#'  Note that if \code{method_sample="union"}
#'  then \code{method_phenotype} must be set to "intersect".
#' @examples
#'
#'  no_cores <- 1
#'  data(fg_data_pos30)
#'  fg0 <- flowGraph(fg_data_pos30$count, class=fg_data_pos30$meta$class,
#'                  prop=FALSE, specenr=FALSE,
#'                  no_cores=no_cores)
#'
#'  fg1 <- fg_extract_samples(fg0, fg_get_meta(fg0)$id[1:5])
#'  fg2 <- fg_extract_samples(fg0, fg_get_meta(fg0)$id[4:7])
#'  fg <- fg_merge(fg1, fg2, method_sample="intersect",
#'                           method_phenotype="intersect")
#'  fg_get_feature_desc(fg)
#'
#' @seealso
#'  \code{\link[flowGraph]{flowGraph-class}}
#'  \code{\link[flowGraph]{fg_extract_samples}}
#'  \code{\link[flowGraph]{fg_extract_phenotypes}}
#'  \code{\link[flowGraph]{fg_merge_samples}}
#' @rdname fg_merge
#' @export
fg_merge <- function(
    fg1, fg2, method_sample=c("union", "intersect", "setdiff", "none"),
    method_phenotype=c("intersect", "setdiff", "none")
) {
    method_sample <- match.arg(method_sample)
    method_phenotype <- match.arg(method_phenotype)

    if (method_sample == "union" & method_phenotype != "intersect")
        stop("if method_sample=union,
             then we must set method_phenotype=intersect;\n
             otherwise, features become difficult to compare.")
    if (method_sample == "union")
        return(fg_merge_samples(fg1, fg2))
    if (method_sample == "none" & method_phenotype == "none")
        return(fg1)

    sample_id1 <- fg_get_meta(fg1)$id
    sample_id2 <- fg_get_meta(fg2)$id
    sample_id1_int <- intersect(sample_id1, sample_id2)
    sample_id1_new <- setdiff(sample_id1, sample_id2)
    sample_id1_uni <- union(sample_id1, sample_id2)

    phen1 <- fg_get_graph(fg1)$v$phenotype
    phen2 <- fg_get_graph(fg2)$v$phenotype
    phen1_int <- intersect(phen1, phen2)
    phen1_new <- setdiff(phen1, phen2)
    phen1_uni <- union(phen1, phen2)

    if (method_sample == "none")
        sample1 <- fg1

    if (method_sample == "intersect") {
        if (length(sample_id1_int) == 0)
            stop("no intersecting samples")
        sample1 <- fg_extract_samples(fg1, sample_id1_int)
    }

    if (method_sample == "setdiff") {
        if (length(sample_id1_new) == 0)
            stop("no setdiff samples")
        sample1 <- fg_extract_samples(fg1, sample_id1_new)
    }

    if (method_phenotype == "none")
        return(sample1)

    if (method_phenotype == "intersect") {
        if (length(phen1_int) == 0)
            stop("no intersecting phenotypes")
        if (all(phen1_int %in% phen2))
            return(sample1)
        return(fg_extract_phenotypes(sample1, phen1_int))
    }

    if (method_phenotype == "setdiff") {
        if (length(phen1_new) == 0)
            stop("no setdiff phenotypes")
        if (all(phen1_new %in% phen1))
            return(sample1)
        return(fg_extract_phenotypes(sample1, phen1_new))
    }

}


#' @title Replaces sample meta.
#' @description Replaces sample meta in a given flowGraph object.
#' @param fg flowGraph object.
#' @param meta A data frame containing meta data; see details in
#'  \code{\link[flowGraph]{flowGraph-class}}.
#' @return A flowGraph object with an updated sample meta.
#' @seealso
#'  \code{\link[flowGraph]{flowGraph-class}}
#'  \code{\link[flowGraph]{fg_get_meta}}
#' @examples
#'
#'  no_cores <- 1
#'  data(fg_data_pos30)
#'  fg <- flowGraph(fg_data_pos30$count, class=fg_data_pos30$meta$class,
#'                  prop=FALSE, specenr=FALSE,
#'                  no_cores=no_cores)
#'  head(fg_get_meta(fg))
#'
#'  new_df <- fg_data_pos30$meta
#'  new_df$id[1] <- "newID"
#'
#'  fg <- fg_replace_meta(fg, new_df)
#'  head(fg_get_meta(fg))
#'
#' @rdname fg_replace_meta
#' @export
#' @importFrom purrr map
fg_replace_meta <- function(fg, meta) {
    if (nrow(meta)!=nrow(fg_get_meta(fg)))
        stop("meta must have same number of rows as the number of samples")
    if (!"id"%in%colnames(meta)) stop("meta must have id column")
    fg@meta <- meta

    fg_feat <- fg_get_feature_all(fg)
    fg@feat$node <- purrr::map(fg_feat$node, function(x) {
        rownames(x) <- meta$id
        x
    })
    if (length(fg_feat$edge) > 0)
        fg@feat$edge <- purrr::map(fg_feat$edge, function(x) {
            rownames(x) <- meta$id
            x
        })

    return(fg)
}



