[13df9a]: / R / utils-pipe.R

Download this file

135 lines (119 with data), 3.3 kB

  1
  2
  3
  4
  5
  6
  7
  8
  9
 10
 11
 12
 13
 14
 15
 16
 17
 18
 19
 20
 21
 22
 23
 24
 25
 26
 27
 28
 29
 30
 31
 32
 33
 34
 35
 36
 37
 38
 39
 40
 41
 42
 43
 44
 45
 46
 47
 48
 49
 50
 51
 52
 53
 54
 55
 56
 57
 58
 59
 60
 61
 62
 63
 64
 65
 66
 67
 68
 69
 70
 71
 72
 73
 74
 75
 76
 77
 78
 79
 80
 81
 82
 83
 84
 85
 86
 87
 88
 89
 90
 91
 92
 93
 94
 95
 96
 97
 98
 99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
#' Pipe operator
#'
#' See \code{magrittr::\link[magrittr:pipe]{\%>\%}} for details.
#'
#' @name %>%
#' @rdname pipe
#' @keywords internal
#' @export
#' @importFrom magrittr %>%
#' @usage lhs \%>\% rhs
#' @param lhs A value or the magrittr placeholder.
#' @param rhs A function call using the magrittr semantics.
#' @return The result of calling `rhs(lhs)`.
NULL
#' Assignment pipe
#'
#' See \code{magrittr::\link[magrittr:pipe]{\%<>\%}} for details.
#'
#' @name %<>%
#' @keywords internal
#' @export
#' @importFrom magrittr %<>%
#' @usage lhs \%<>\% rhs
#' @param lhs A value or the magrittr placeholder.
#' @param rhs A function call using the magrittr semantics.
#' @return The result of calling `rhs(lhs)`.
NULL
# flag determined by the correlation table from one table or two tables
t_flag <- \(corr){
if (!nrow(corr) == ncol(corr)) {
return(FALSE)
}
if (!all(rownames(corr) == colnames(corr))) {
return(FALSE)
}
return(TRUE)
}
# 多列表是否一一对应
# test 对应的列需要跟剩下的列具有唯一映射
e_match <- function(df, test = NULL) {
dis_df <- dplyr::distinct_all(df) %>% as.data.frame()
if (is.null(test)) {
return(all_same(c(nrow(dis_df), apply(dis_df, 2, \(i)length(unique(i))))))
} else {
return(all_same(c(nrow(dis_df), nrow(dplyr::distinct_all(dis_df[, test, drop = FALSE])))))
}
}
all_same <- \(x){
return(all(x == x[1]))
}
# choose the last not na value
condance <- \(aa){
aa <- as.data.frame(aa)
if (any(is.na(aa[, length(aa)]))) {
res <- apply(aa, 1, \(x){
tmp <- x[!is.na(x)]
if (length(tmp) == 0) {
return(NA)
}
return(tmp[length(tmp)])
})
} else {
res <- aa[, length(aa), drop = TRUE]
}
res
}
# bind two df with same columns, the last df will replace first df
cbind_new <- \(df, df1){
if (ncol(df) < 1) {
return(df1)
}
if (ncol(df1) < 1) {
return(df)
}
inter <- intersect(colnames(df1), colnames(df))
la <- setdiff(colnames(df), inter)
cbind(df[, la, drop = FALSE], df1)
}
twocol2vector <- \(df){
if (ncol(df) < 2) {
return(NULL)
}
if (!e_match(df, test = 1)) {
stop("The columns are not one-to-one correspondence.")
}
df <- dplyr::distinct_all(df)
setNames(df[, 2], df[, 1])
}
custom_sort <- function(x) {
# 尝试将字符转换为数字并排序
converted <- suppressWarnings(as.numeric(x))
if (!any(is.na(converted))) {
# 如果转换成功,则返回按数字排序的结果
return(converted[order(converted)])
} else {
# 如果转换失败,则返回按字符排序的结果
return(stringr::str_sort(x, numeric = TRUE))
}
}
paste_df <- function(df, collapse = ",") {
apply(df, 1, paste, collapse = collapse)
}
paste_df2pielist <- function(df, collapse = ",") {
pcutils::strsplit2(df, split = collapse) %>%
pcutils::t2() %>%
as.list() %>%
lapply(function(x) as.numeric(x))
}
deprecated <- function(old, new) {
assign(old, new, envir = asNamespace(packageName()))
}
#' @export c_net_cal
deprecated("c_net_cal", c_net_calculate)
#' @export c_net_module
deprecated("c_net_module", module_detect)
#' @export c_net_lay
deprecated("c_net_lay", c_net_layout)
#' @export as.metanet
deprecated("as.metanet", c_net_update)