Commit 3823e25d authored by houyun's avatar houyun
Browse files

re-write reorder function

parent 1da3d061

NAMESPACE

+4 −3
Original line number Diff line number Diff line
@@ -32,6 +32,9 @@ S3method(print,hyplot) 
S3method(print,marker)

S3method(print,matrix_data)

S3method(print,random_forest)

S3method(reorder_by,data.frame)

S3method(reorder_by,matrix)

S3method(reorder_by,matrix_data)

S3method(rep_len,marker)

export("%>%")

export("col_names<-")
@@ -87,7 +90,6 @@ export(is_md_tbl) 
export(latex_richtext)

export(layout_tbl_graph_circular)

export(layout_with_circular)

export(make_cluster)

export(mantel_test)

export(marker)

export(matrix_data)
@@ -103,8 +105,7 @@ export(rand_dataset) 
export(random_forest)

export(regex_select)

export(register_pairs_plot)

export(reorder_cols)

export(reorder_rows)

export(reorder_by)

export(row_names)

export(scale_marker_binned)

export(scale_marker_continuous)

R/matrix-data.R

+2 −2
Original line number Diff line number Diff line
@@ -6,7 +6,7 @@ 
#' @param diag logical, if TRUE (default) will keep the diagonal of matrix data.

#' @param row_names,col_names the name of rows and columns.

#' @param group NULL or a character vector.

#' @param ... passing to \code{\link{make_cluster}}.

#' @param ... not used.

#' @return a object of matrix_data

#' @rdname matrix_data

#' @author Hou Yun
@@ -54,7 +54,7 @@ matrix_data <- function(x, 
                  col_names = col_names)

    class(x) <- "grouped_matrix_data"

  }

  make_cluster(x, ...)

  x

}



#' @method print matrix_data

R/reorder_by.R

0 → 100755
+163 −0
Original line number Diff line number Diff line 
#' @title Re-sorting Matrix Data

#' @description Resort matrix data by "hclust", "dendrogram", and so on.

#' @param x matrix data.

#' @param by_rows,by_cols method of reorder, default is "hclust".

#' @param dist_fun a function to calculute distance matrix.

#' @param ... other parameters.

#' @return same object with `x`.

#' @author Hou Yun

#' @rdname reorder_by

#' @export

reorder_by <- function(x, ...) {

  UseMethod("reorder_by")

}



#' @rdname reorder_by

#' @export

reorder_by.matrix <- function(x,

                              by_rows = "hclust",

                              by_cols = by_rows,

                              dist_fun = dist_func(),

                              ...) {

  if (identical(by_rows, "none") && identical(by_cols, "none")) {

    return(x)

  }



  if (identical(by_rows, "none")) {

    by_rows <- seq_len(nrow(x))

  }

  if (identical(by_cols, "none")) {

    by_cols <- seq_len(ncol(x))

  }



  ## get row order

  if (identical(by_rows, "hclust")) {

    by_rows <- stats::hclust(dist_fun(x))

  }

  if (inherits(by_rows, "dist")) {

    by_rows <- hclust(by_rows, ...)

  }

  if (inherits(by_rows, "dendrogram")) {

    by_rows <- stats::as.hclust(by_rows)

  }



  if (inherits(by_rows, "hclust") || inherits(by_rows, "ggtree")) {

    attr(x, "row_tree") <- by_rows

  }



  if (inherits(by_rows, "numeric") || inherits(by_rows, "character")) {

    row_ord <- by_rows

  } else {

    row_ord <- get_order(by_rows)

  }



  ## get col order

  if (identical(by_cols, "hclust")) {

    by_cols <- stats::hclust(dist_fun(t(x)))

  }

  if (inherits(by_cols, "dist")) {

    by_cols <- hclust(by_cols, ...)

  }

  if (inherits(by_cols, "dendrogram")) {

    by_cols <- stats::as.hclust(by_cols)

  }



  if (inherits(by_cols, "hclust") || inherits(by_cols, "ggtree")) {

    attr(x, "col_tree") <- by_cols

  }



  if (inherits(by_cols, "numeric") || inherits(by_cols, "character")) {

    col_ord <- by_cols

  } else {

    col_ord <- get_order(by_cols)

  }

  x[row_ord, col_ord, drop = FALSE]

}



#' @rdname reorder_by

#' @export

reorder_by.data.frame <- function(x,

                                  by_rows = "hclust",

                                  by_cols = by_rows,

                                  dist_fun = dist_func(),

                                  ...) {

  x <- reorder_by(x = as.matrix(x),

                  by_rows = by_rows,

                  by_cols = by_cols,

                  dist_fun = dist_fun,

                  ...)

  as.data.frame(x)

}



reorder_by.correlate <- function(x,

                                 by_rows = "hclust",

                                 by_cols = by_rows,

                                 dist_fun = NULL,

                                 ...) {

  r <- x$r

  is_symmet <- identical(rownames(r), colnames(r))



  if (identical(by_rows, "hclust")) {

    if (is_symmet && is.null(dist_fun)) {

      by_rows <- stats::as.dist(1 - r)

    } else {

      by_rows <- dist_fun(r, ...)

    }

  }



  if (identical(by_cols, "hclust")) {

    if (is_symmet && is.null(dist_fun)) {

      by_cols <- stats::as.dist(1 - t(r))

    } else {

      by_cols <- dist_fun(t(r), ...)

    }

  }



  r <- reorder_by(x = r,

                  by_rows = by_rows,

                  by_cols = by_cols,

                  dist_fun = dist_fun,

                  ...)

  rnm <- rownames(r)

  cnm <- colnames(r)

  for (ii in names(x)) {

    if (ii == "r") {

      x[[ii]] <- r

    } else {

      if (is.null(x[[ii]])) next

      x[[ii]] <- x[[ii]][rnm, cnm, drop = FALSE]

    }

  }

  attr(x, "row_tree") <- attr(r, "row_tree")

  attr(x, "col_tree") <- attr(r, "col_tree")

  x

}



#' @rdname reorder_by

#' @export

reorder_by.matrix_data <- function(x,

                                   by_rows = "hclust",

                                   by_cols = by_rows,

                                   dist_fun = dist_func(),

                                   ...) {

  first <- reorder_by(x = x[[1]],

                      by_rows = by_rows,

                      by_cols = by_cols,

                      dist_fun = dist_fun,

                      ...)

  rnm <- rownames(first)

  cnm <- colnames(first)

  for (ii in seq_along(x)) {

    if (ii == 1L) {

      x[[ii]] <- first

    } else {

      if (is.null(x[[ii]])) next

      x[[ii]] <- x[[ii]][rnm, cnm, drop = FALSE]

    }

  }

  attr(x, "row_tree") <- attr(first, "row_tree")

  attr(x, "col_tree") <- attr(first, "col_tree")

  attr(x, "row_names") <- rnm

  attr(x, "col_names") <- cnm

  x

}

man/matrix_data.Rd

+1 −1
Original line number Diff line number Diff line
@@ -26,7 +26,7 @@ matrix, lower triangular or upper triangular matrix.} 


\item{group}{NULL or a character vector.}



\item{...}{passing to \code{\link{make_cluster}}.}

\item{...}{not used.}

}

\value{

a object of matrix_data

man/reorder_by.Rd

0 → 100644
+53 −0
Original line number Diff line number Diff line 
% Generated by roxygen2: do not edit by hand

% Please edit documentation in R/reorder_by.R

\name{reorder_by}

\alias{reorder_by}

\alias{reorder_by.matrix}

\alias{reorder_by.data.frame}

\alias{reorder_by.matrix_data}

\title{Re-sorting Matrix Data}

\usage{

reorder_by(x, ...)



\method{reorder_by}{matrix}(

  x,

  by_rows = "hclust",

  by_cols = by_rows,

  dist_fun = dist_func(),

  ...

)



\method{reorder_by}{data.frame}(

  x,

  by_rows = "hclust",

  by_cols = by_rows,

  dist_fun = dist_func(),

  ...

)



\method{reorder_by}{matrix_data}(

  x,

  by_rows = "hclust",

  by_cols = by_rows,

  dist_fun = dist_func(),

  ...

)

}

\arguments{

\item{x}{matrix data.}



\item{...}{other parameters.}



\item{by_rows, by_cols}{method of reorder, default is "hclust".}



\item{dist_fun}{a function to calculute distance matrix.}

}

\value{

same object with `x`.

}

\description{

Resort matrix data by "hclust", "dendrogram", and so on.

}

\author{

Hou Yun

}

CRA Git | Maintained and supported by SUSTech CRA and CCSE