# Latest release: 2024-07-11 steel_dwass_test_cld <- function(x,y, method = NA, n.mc = 10000, alphabets = letters, decreasing = TRUE, alpha = 0.05) { # パッケージをインストールし、読み込む suppressWarnings({ packages <- c("NSM3", "tidyverse") package.check <- lapply( packages, FUN = function(x) { if (!require(x, character.only = TRUE)) { install.packages(x, dependencies = TRUE) library(x, character.only = TRUE) } } ) }) # データをdataframeにまとめる data <- data.frame(value = x, group = y) # Steel-Dwass検定の実行 steel_dwass <- pSDCFlig(data$value, data$group, method = method, n.mc = n.mc) multcomp.df <- data.frame(labels = steel_dwass$labels, p.val = steel_dwass$p.val) if (decreasing == TRUE) { #平均値の計算と並べ替え summarise <- data[1] %>% group_by(data[2]) %>% summarise_all(list(mean = mean)) %>% arrange(-mean) } else { #平均値の計算と並べ替え summarise <- data[1] %>% group_by(data[2]) %>% summarise_all(list(mean = mean)) %>% arrange(mean) } # p値表 p.table <- matrix(nrow = length(attr(y, "levels")), ncol = length(attr(y, "levels"))) colnames(p.table) <- summarise[[1]] rownames(p.table) <- summarise[[1]] # 同じ列と行が一致する部分に空文字を入れる diag(p.table) <- "" # 右上半分を"-"に設定 for (i in 1:nrow(p.table)) { for (j in 1:ncol(p.table)) { if (i < j) { p.table[i, j] <- "-" } } } # 特定のグループペアに対してp値または"*"を取得する関数 get_p_val <- function(df, group1, group2) { # ラベルの組み合わせを作成 label1 <- group1 label2 <- group2 # データフレーム内でラベルを検索 p_val <- df$p.val[df$labels == label1 | df$labels == label2] # p値がalpha以下の場合は"*"を返し、それ以外は空文字を返す if (length(p_val) == 0) { return(NA) } else if (p_val <= alpha) { return("*") } else { return("") } } # NAのセルに記号を入れる for (i in 1:nrow(p.table)) { for (j in 1:ncol(p.table)) { if (p.table[i,j] %>% is.na() == TRUE) { p.table[i,j] <- get_p_val( multcomp.df, group1 = paste(rownames(p.table)[i],"-",colnames(p.table)[j]), group2 = paste(rownames(p.table)[j],"-",colnames(p.table)[i])) } } } # 各列に含まれる"*"の個数を数える star_counts <- apply(p.table, 2, function(x) sum(x == "*")) # アルファベットを追加する関数 add_alphabets <- function(column, current_alphabet) { for (i in seq_along(column)) { if (column[i] == "") { column[i] <- current_alphabet } } return(column) } # 各列にアルファベットを追加 new_matrix_data <- p.table previous_count <- NULL alphabet_index <- 1 for (j in seq_along(colnames(p.table))) { current_count <- star_counts[j] if (is.null(previous_count) || current_count != previous_count) { current_alphabet <- alphabets[alphabet_index] alphabet_index <- alphabet_index + 1 } new_matrix_data[, j] <- add_alphabets(p.table[, j], current_alphabet) previous_count <- current_count } # 行ごとに含まれる文字を集計 cld <- apply(new_matrix_data, 1, function(row) { # 行内の"-"と"*"を除いた文字をユニークに集めてソート unique_chars <- unique(row[row != "-" & row != "*"]) paste(sort(unique_chars), collapse = "") }) return(cld[attr(y, "levels")]) }