# # Load necessary package library(readr) # Load the datasets library(readr) library(tidyr) #nodes <- read_csv("F:/RR/nodestemporate.csv", locale = locale(encoding = "UTF-8")) #nodes <- read_csv("F:/RR/nodestemporate.csv", locale = locale(encoding = "GB2312")) ##################################### shiefttarget<-1 # 0 <有向性(限二欄) directed arrow ;無向性1: indirected: larger in target and lower caption in source #################################### FLCAcluster<-1 # if #cluste=1 then 1 ncount<-20 itemlarger20<-ncount allelement<-FALSE addvalue<--1 # leaders are on publication otherwise on relationship Importance<-2 # 0 for edge influence; # 1 for publication #2: bubble by publication and cluster by edge Yessilhouette1<-"No" ###### "Yes" cat("Yessilhouette1==Yes or not \t") addvalue<-2 myfile<- "country.csv" ## 2 columns, 3 columns with WCD, or multipy columns with words parantheses<-1 ## if 1 for add parantheses and value to name when addvalue=1 mrtarrow<-0 ## arrow==1 cat("Cluster size at least number of member:",sep="\n") size_of_cluster<-4 if (!addvalue==2){ #InputData<- suppressMessages(read_csv("F:/RR/country.csv", locale = locale(encoding = "BIG5"))) is_numeric_col3<-FALSE #data <- InputData myfile <- suppressMessages(read_csv(paste0("F:/RR/", myfile), locale = locale(encoding = "BIG5"))) #myfile<- suppressMessages(read_csv("F:/RR/country.csv", locale = locale(encoding = "BIG5"))) #myfile<-"F:/RR/country.csv" } if (addvalue==2) { # Read stored node and relation data myfilevalue <- suppressMessages(read_csv("F:/RR/nodestemporate.csv", locale = locale(encoding = "BIG5"))) # nodes myfile <- suppressMessages(read_csv("F:/RR/datatemporate.csv", locale = locale(encoding = "BIG5"))) #myfile <- "F:/RR/datatemporate.csv" # data myfile <- myfile[complete.cases(myfile), ] } # 3<-based on publications by country.csv url <- "https://www.raschonline.com/raschonline/geoworldmap.txt" sourceCode <- readLines(url, warn = FALSE) eval(parse(text = sourceCode)) ########################################## if (ncol(InputData) == 2) { data3<-InputData # Filter rows where Source equals Target and count occurrences result <- data3 %>% filter(Source == Target) %>% count(Source, name = "Self_Loop_Count") result$name<-result$Source # View result print(result) # Join and compute new value nodesall <- nodesall %>% left_join(result, by = "name") %>% mutate(Self_Loop_Count = replace_na(Self_Loop_Count, 0), value = value - Self_Loop_Count) %>% select(name, value) # Assume nodes$value is to be updated from nodesall$value by 'name' nodes <- nodes %>% select(-value) %>% # Remove old value column if exists left_join(nodesall %>% select(name, value), by = "name") # Join new value } databk<-myfile nodesbk<-nodes ############################################################### nodes <- NULL nodes <- data.frame( name = ceb$name, value = ceb$value, carac = ceb$carac ) data <- NULL data <- data.frame( Leader = ceb$Leader, follower = ceb$follower, WCD = ceb$WCD ) if (allelement==TRUE){ data<-databk ###All element } ######Network chart################################ ######Network chart################################ ######################################### ########################################## if(1==3){ # betweenness algorithm data<-data63bk # Subset data63bk based on Leader or follower in subset_nodes$name subset_data63bk <- subset(data63bk, Leader %in% unique_elements & follower %in% unique_elements) subset_data63bk <- subset(data63bk, Leader %in% nodesbk2$name & follower %in% nodesbk2$name) network <- graph_from_data_frame(d=subset_data63bk, vertices=nodesbk2, directed=T) #network <- as.directed(network, mode = "arbitrary") ceb <- cluster_edge_betweenness(network) V(network)$name <- V(network)$name #as.character(1:vcount(network)) # Names: "1", "2", ..., "10" # Compute node betweenness centrality V(network)$betweenness <- betweenness(network) # Compute clustering membership cluster_membership <- as.numeric(membership(cluster_edge_betweenness(network))) my_color<-cluster_membership nodes$value2<-V(network)$betweenness maxbb=max(nodes$value2)/2 ################################# # Load required libraries library(igraph) # Subset nodes where value2 > 0 subset_nodes <- nodes[nodes$value2 > 0, ] # Subset data63bk based on Leader or follower in subset_nodes$name subset_data63bk <- subset(data63bk, Leader %in% subset_nodes$name | follower %in% subset_nodes$name) # Extract unique vertices from edge list unique_vertices <- unique(c(subset_data63bk$Leader, subset_data63bk$follower)) # Subset nodes to match unique vertices in edge list valid_nodes <- subset(nodes, name %in% unique_vertices) # Further filter valid_nodes where value2 > 0 valid_nodes <- valid_nodes[valid_nodes$value2 > 0, ] # Identify any missing vertices in valid_nodes remaining_vertices <- setdiff(unique_vertices, valid_nodes$name) # Add missing vertices with default values to valid_nodes if (length(remaining_vertices) > 0) { additional_nodes <- data.frame(name = remaining_vertices, value2 = 0) # Ensure column structure matches missing_columns <- setdiff(names(valid_nodes), names(additional_nodes)) for (col in missing_columns) { additional_nodes[[col]] <- NA # Add placeholder values } # Combine the valid_nodes and additional_nodes valid_nodes <- rbind(valid_nodes, additional_nodes) } # Create the network graph using the updated vertex data frame network <- graph_from_data_frame(d = subset_data63bk, vertices = valid_nodes, directed = TRUE) # Assign a color to nodes (optional) my_color <- ifelse(V(network)$name %in% subset_nodes$name, "blue", "gray") # Calculate betweenness centrality if not already present if (is.null(V(network)$betweenness)) { V(network)$betweenness <- betweenness(network, directed = TRUE) } # Plot the network plot(network, vertex.size = log(V(network)$betweenness + 1) * 29, vertex.color = my_color, vertex.label = V(network)$name, #vertex.label = NA, edge.arrow.size = 0.6, main = "Node Betweenness Centrality Visualization") ################################## ################################## }else{ unique_elements<-nodes$name # Subset data63bk based on Leader or follower in subset_nodes$name # Check column names and subset accordingly if ("Leader" %in% colnames(data)) { subset_data <- subset(data, Leader %in% unique_elements & follower %in% unique_elements) } else if ("Source" %in% colnames(data)) { subset_data <- subset(data, Source %in% unique_elements & Target %in% unique_elements) } #subset_data<-relation_set 多線.... aaak<-0 if (aaak==1) { # Correct column selection for the data frame # Assuming databk2 has at least 3 columns #data <- databk2[, 1:3] # all links #data <- datasankeymatics[, 1:3] # FLCA subset_data <- relation_set[, 1:3] # Rename columns in the data frame colnames(subset_data) <- c("Leader", "follower", "WCD") colnames(nodes) <- c("node", "group") # Subset the 'data' dataframe #nodes<- nodes[, 1:3] colnames(nodes) <- c("node", "group", "value","value2","cluster","color") nodes<-head(nodes,ncount) nrow(data) subset_data <- subset_data[ subset_data$Leader %in% nodes$node & subset_data$follower %in% nodes$node, ] } # otherwise FLCA 單線....below library(igraph) library(dplyr) # Reverse the edges by swapping columns only having two columns Explicitly swap 'Source' and 'Target' if (1==3){ subset_data_reversed <- subset_data %>% mutate(temp = Leader, Leader = follower, follower = temp) %>% select(-temp) # Remove temporary column } else { subset_data_reversed <- subset_data } #subset_data_reversed <- subset(relation_set, Leader %in% unique_elements & follower %in% unique_elements) # for all edges in top 20 network <- graph_from_data_frame(d = subset_data_reversed, vertices = nodes, directed = FALSE) nodes$value2<-nodes$value laydata <- layout_with_fr(network) textz <- paste0("Clustered DDI (Top 20 ", cbp3, ")") silihousettelaydata<-laydata silihousettenodes<-nodes silihousettenetwork<-network silihousettemy_color<-my_color # Plot with reversed arrows plot(network, layout = laydata, vertex.color = my_color, edge.width = E(network)$WCD * 1 / 4 / (maxaa / 10), vertex.label.dist = 1, vertex.shape = "circle", vertex.label = V(network)$name, vertex.label.font = 1, vertex.size = nodes$value2 * 1 / (maxbb / 24), #vertex.label.color = my_color, vertex.label.cex = 1.1, #edge.color = vertex_label_colors, edge.curved = 0.1, mark.groups = kknode, mark.col = kkcolor, mark.border = NA, main = textz, asp = 0, edge.arrow.size = 0.5 # Arrows are now reversed correctly ) #install.packages("gridGraphics") # Install if not already installed library(gridGraphics) # Load the package gridGraphics::grid.echo() plot2 <- grid.grab() } alledge<-1 # network for all edges if (alledge==0){ #nodes$carac<-ceb$carac # Minimal plot to isolate edge visibility network <- graph_from_data_frame(d = relation_set, vertices = nodes, directed = FALSE) plot(network, layout = laydata, vertex.color = my_color, edge.width = E(network)$WCD * 1 / 4 / (maxaa / 10), vertex.label.dist = 1, vertex.shape = "circle", vertex.label = V(network)$name, vertex.label.font = 1, vertex.size = nodes$value2 * 1 / (maxbb / 24), #vertex.label.color = my_color, vertex.label.cex = 1.1, #edge.color = vertex_label_colors, edge.curved = 0.1, asp = 0, edge.color = "gray50", # Visible color edge.arrow.size = 0.5 # Arrows are now reversed correctly ) } #nodes$carac<-ceb$carac #nodesall <- merge(nodesall, nodes[, c("name", "carac")], # by = "name", all.x = TRUE) nodesall$carac<-1 nodesall <- nodesall %>% arrange(desc(value), carac) nn<-max(as.numeric(as.character(nodes$carac)))+1 nodesall$carac[is.na(nodesall$carac)] <- nn ############Chord diagram primary links for each follower above########################## ############Chord diagram primary links for each follower above########################## ############Saneky Diagram see above url <- "https://www.raschonline.com/raschonline/FLCA.txt" sourceCode <- readLines(url, warn = FALSE) eval(parse(text = sourceCode)) ########################################## ceb <- FLCA(network) nodes<-NULL nodes <- data.frame( name = ceb$name, value = ceb$value, carac = ceb$carac ) library(tibble) # Ensure tibble is loaded # Create data frame properly data<-NULL data <- data.frame( Source = ceb$Leader, Target = ceb$follower, WCD = ceb$WCD ) ########################################## if (Importance==2) { nodes <- nodes %>% left_join(nodes_final %>% select(name, value), by = "name", suffix = c("", ".new")) %>% mutate(value2 = value) %>% mutate(value = value.new) %>% # Replace with matched value from nodes_final select(-value.new) # Remove the temporary column nodes <- nodes[!is.na(nodes$value), ] data <- data[data$Source %in% nodes$name & data$Target %in% nodes$name, ] } ########################################## url <- "https://www.raschonline.com/raschonline/sankeyplot.txt" sourceCode <- readLines(url, warn = FALSE) eval(parse(text = sourceCode)) if (Importance<2) { nodes <- nodes %>% left_join(nodes_final %>% select(name, value), by = "name", suffix = c("", ".new")) %>% mutate(value2 = value) %>% mutate(value = value.new) %>% # Replace with matched value from nodes_final select(-value.new) # Remove the temporary column nodes <- nodes[!is.na(nodes$value), ] data <- data[data$Source %in% nodes$name & data$Target %in% nodes$name, ] } if (Importance==2 || Importance==0){ nodes <- nodes[order(nodes$carac,-nodes$value2, nodes$name), ] } # cbp="FLCAalgorithmexampleB" # Step 1: Set column names nodes <- nodes[, c("name", "value", "value2", "carac")] # Step 1: Preprocess # Step 1: Set column names if (ncol(nodes) == 3) { colnames(nodes) <- c("name", "value", "value2") } else if (ncol(nodes) == 4) { colnames(nodes) <- c("name", "value", "value2", "carac") } else if (ncol(nodes) == 5) { colnames(nodes) <- c("name", "value", "value2", "carac", "value3") } # Step 2: Assign colors nodes$carac <- as.factor(nodes$carac) specified_colors <- c( "#FF0000", "#0000FF", "#998000", "#008000", "#800080", "#FFC0CB", "#000000", "#ADD8E6", "#FF4500", "#A52A2A", "#8B4513", "#FF8C00", "#32CD32", "#4682B4", "#9400D3", "#FFD700", "#C0C0C0", "#DC143C", "#1E90FF" ) regular_clusters <- levels(nodes$carac)[levels(nodes$carac) != "100"] color_mapping <- setNames(specified_colors[1:length(regular_clusters)], regular_clusters) nodes$fill_color <- ifelse(nodes$carac == "100", NA, color_mapping[as.character(nodes$carac)]) nodes$border_color <- "black" # Step 1: Preprocess mean_x <- mean(nodes$value2) mean_y <- mean(nodes$value) sd_x <- sd(nodes$value2) sd_y <- sd(nodes$value) # Step 2: Generate curves spread_x <- 4 * sd_x spread_y <- 5 * sd_y t <- seq(0, 1, length.out = 300) lower_curve <- data.frame( x = t * spread_x - spread_x / 2 + mean_x, y = mean_y - spread_y * (1 - t)^2 ) upper_curve <- data.frame( x = -t * spread_x + spread_x / 2 + mean_x, y = mean_y + spread_y * (1 - t)^2 ) # Step 3: Classification Functions ci_radius_x <- sd_x ci_radius_y <- sd_y ###############for column==3 if (ncol(nodes) == 3) { is_inside_ellipse <- function(x, y) { ((x - mean_x)^2 / ci_radius_x^2) + ((y - mean_y)^2 / ci_radius_y^2) <= 1 } is_outside_ellipse <- function(x, y) { ((x - mean_x)^2 / ci_radius_x^2) + ((y - mean_y)^2 / ci_radius_y^2) > 1 } is_above_upper <- function(x, y) { x_parabola <- -t * spread_x + spread_x / 2 + mean_x y_parabola <- mean_y + spread_y * (1 - t)^2 y_pred <- approx(x_parabola, y_parabola, xout = x, rule = 2)$y return(!is.na(y_pred) && y > y_pred) } is_below_lower <- function(x, y) { x_parabola <- t * spread_x - spread_x / 2 + mean_x y_parabola <- mean_y - spread_y * (1 - t)^2 y_pred <- approx(x_parabola, y_parabola, xout = x, rule = 2)$y return(!is.na(y_pred) && y < y_pred) } # Step 4: Classification Logic nodes$carac <- mapply(function(x, y) { above <- is_above_upper(x, y) below <- is_below_lower(x, y) inside <- is_inside_ellipse(x, y) outside <- is_outside_ellipse(x, y) if (x >= mean_x & y > mean_y & outside) return("1") else if (below) return("2") else if (inside) return("3") else if (x < mean_x & y > mean_y & above) return("4") else return("5") }, nodes$value2, nodes$value) # Step 5: Map labels and colors label_mapping <- c( "1" = "Leader", "2" = "Connector", "3" = "Normal", "4" = "Lone Wolves", "5" = "Follower" ) nodes$carac <- factor(nodes$carac, levels = names(label_mapping), labels = label_mapping) } ####column==3 specified_colors <- c( "Leader" = "#FF0000", "Connector" = "#0000FF", "Normal" = "#998000", "Lone Wolves" = "#008000", "Follower" = "#FFC0CB" ) nodes$color <- specified_colors[nodes$carac] # Step 6: Draw plot visual_ratio <- (max(nodes$value2) - min(nodes$value2)) / (max(nodes$value) - min(nodes$value)) theta <- seq(0, 2 * pi, length.out = 300) circle_data <- data.frame( x = mean_x + (spread_x * 0.19) * cos(theta), y = mean_y + (spread_y * 0.19) * sin(theta) ) ggplot(nodes, aes(x = value2, y = value)) + geom_point(aes(size = value, fill = color), color = "black", shape = 21, alpha = 0.9) + geom_text_repel(aes(label = name), size = 3.5) + scale_fill_identity() + scale_size(range = c(3, 12)) + geom_vline(xintercept = mean_x, linetype = "dashed", color = "red") + geom_hline(yintercept = mean_y, linetype = "dashed", color = "red") + geom_line(data = lower_curve, aes(x = x, y = y), color = "blue") + geom_line(data = upper_curve, aes(x = x, y = y), color = "blue") + geom_path(data = circle_data, aes(x = x, y = y), color = "purple", linewidth = 1.1) + coord_fixed(ratio = visual_ratio) + theme_minimal() + labs( title = "Kano Plot with Classification", x = "Collaboration (= Net Connection)", y = "Production (= Full Connection)", size = "Importance" ) kanowithoutedge<-1 if (kanowithoutedge==2){ # Step 4: Build the plot without edges ggplot(nodes, aes(x = value2, y = value)) + # Removed geom_segment (no edges) ✅ # Nodes geom_point(aes(size = value, fill = color), color = "black", shape = 21, alpha = 0.9) + geom_text_repel(aes(label = name), size = 3.5, max.overlaps = 100) + # Colors and sizes scale_fill_identity() + scale_size(range = c(3, 12)) + # Reference lines geom_vline(xintercept = mean_x, linetype = "dashed", color = "red") + geom_hline(yintercept = mean_y, linetype = "dashed", color = "red") + # Kano Curves geom_line(data = lower_curve, aes(x = x, y = y), color = "blue", linewidth = 2) + geom_line(data = upper_curve, aes(x = x, y = y), color = "blue", linewidth = 2) + # Optional diagonal reference geom_line(data = diag_line, aes(x = x, y = y), color = "gray70", linetype = "dotted") + # Quadrant labels annotate("text", x = mean_x + expand_x+mean_x/1.1, y = mean_y + expand_y* 8, label = "Leader", size = 5, fontface = "bold", color = "darkgreen") + annotate("text", x = mean_x - expand_x-mean_x/2, y = mean_y + expand_y*7, label = "Specialist", size = 5, fontface = "bold", color = "darkgreen") + annotate("text", x = mean_x - expand_x-mean_x/2, y = mean_y - expand_y*5, label = "Follower", size = 5, fontface = "bold", color = "darkgreen") + annotate("text", x = mean_x + expand_x+mean_x/2, y = mean_y - expand_y*5, label = "Connector", size = 5, fontface = "bold", color = "darkgreen") + annotate("text", x = mean_x + expand_x+mean_x/1.01, y = mean_y + expand_y* 8.5, label = "Consistent Contributor", size = 4, fontface = "italic", color = "blue") + annotate("text", x = mean_x-mean_x/1.4, y = mean_y + expand_y * 8.5, label = "Lone Wolves", size = 4, fontface = "italic", color = "blue") + annotate("text", x = mean_x*2.5, y = mean_y - expand_y * 3.5, label = "Team Player", size = 4, fontface = "italic", color = "blue") + xlim(min_x - 2 * expand_x, max_x + 2 * expand_x) + ylim(min_y - 2 * expand_y, max_y + 2 * expand_y) + theme_minimal(base_family = "Helvetica") + labs( title = "IPA-Kano Plot with Network and Curved Wings", x = "Collaboration (= Net Connection)", y = "Production (= Full Connection)", size = "Importance" ) + theme( plot.title = element_text(size = 16, face = "bold", hjust = 0.5), legend.position = "right" ) } if (Importance==2 || Importance==0){ nodes <- nodes[order(nodes$carac,-nodes$value2, nodes$name), ] } #Layout Name Description #"tree" Hierarchical tree (current) #"dendrogram" Similar to tree, better for hierarchical clustering #"circle" Circular layout, good for radial mind maps #"fr" Fruchterman-Reingold (force-directed) #"kk" Kamada-Kawai (force-directed) #"dh" Davidson-Harel layout #"graphopt" Spring-force layout #"nicely" Auto-chosen best force-directed layout #"star" Star-shaped layout (works best for central hub) #"manual" For customized XY layout ############Kano model library(dplyr) # Merge total values from databkk into nodes by name nodes <- nodes %>% select(-value) %>% left_join(nodesall[, c("name", "value")], by = "name") # Rename 'total' to 'value2' only if 'value2' does not exist or is all NA if (!"value2" %in% colnames(nodes) || all(is.na(nodes$value2))) { colnames(nodes)[colnames(nodes) == "value"] <- "value2" colnames(nodes)[colnames(nodes) == "total"] <- "value" } nodesbb<-nodes nodes$value2 <- 2 * ((nodes$value2 - min(nodes$value2, na.rm = TRUE)) / (max(nodes$value2, na.rm = TRUE) - min(nodes$value2, na.rm = TRUE))) - 1 nodes$value <- 2 * ((nodes$value - min(nodes$value, na.rm = TRUE)) / (max(nodes$value, na.rm = TRUE) - min(nodes$value, na.rm = TRUE))) - 1 # 載入必要套件 loading libraries library(scales) library(igraph) library(grid) library(ggplot2) library(dplyr) library(ggrepel) library(ggforce) # 假設你已經有 nodes 和 data（edges）資料框 # nodes 需有欄位：name, value, value2, carac # data 需為 edge list：Source, Target, WCD # 設定顏色 setting colors specified_colors <- c( "#FF0000", "#0000FF", "#998000", "#008000", "#800080", "#FFC0CB", "#000000", "#ADD8E6", "#FF4500", "#A52A2A", "#8B4513", "#FF8C00", "#32CD32", "#4682B4", "#9400D3", "#FFD700", "#C0C0C0", "#DC143C", "#1E90FF" ) nodes$carac <- as.factor(nodes$carac) unique_clusters <- unique(nodes$carac) num_clusters <- length(unique_clusters) if (num_clusters > length(specified_colors)) { extra_colors <- grDevices::hcl.colors(num_clusters - length(specified_colors), "Dark 3", rev = TRUE) full_color_set <- c(specified_colors, extra_colors) } else { full_color_set <- specified_colors } color_mapping <- setNames(full_color_set[1:num_clusters], levels(nodes$carac)) nodes$color <- color_mapping[as.character(nodes$carac)] nodes <- nodes[order(nodes$carac, -nodes$value, nodes$name), ] # 處理邊 for edge colnames(data) <- c("Source", "Target", "WCD") edges <- data %>% rename(from = Source, to = Target) edges$edge_color <- nodes$color[match(edges$to, nodes$name)] # Stretch X axis #nodes$value2 <- nodes$value2 * 5 # 加入邊的繪圖坐標 adding edge to coordination when ploting edges <- data %>% left_join(nodes, by = c("Source" = "name")) %>% rename(x = value2, y = value) %>% left_join(nodes, by = c("Target" = "name")) %>% rename(xend = value2, yend = value) # 中心與展開範圍 centrality to extend mean_x <- mean(nodes$value2) mean_y <- mean(nodes$value) sd_x <- sd(nodes$value2) sd_y <- sd(nodes$value) max_x <- max(c(nodes$value2, edges$x, edges$xend)) min_x <- min(c(nodes$value2, edges$x, edges$xend)) max_y <- max(c(nodes$value, edges$y, edges$yend)) min_y <- min(c(nodes$value, edges$y, edges$yend)) expand_x <- (max_x - min_x) * 0.1 expand_y <- (max_y - min_y) * 0.1 ######################################### # Step 1: Extract top 3 values in descending order top3_values <- sort(nodesbb$value, decreasing = TRUE)[1:3] top3_values if (min(top3_values)<=0){ top3_values<-top3_values+abs(min(top3_values))+.001 } top3_values top3<-top3_values # Assign for readability v1 <- top3_values[1] # top 1 v2 <- top3_values[2] # top 2 v3 <- top3_values[3] # top 3 # Step 2: Compute AAC as per your formula: # AAC = ((v1/v2)/(v2/v3)) / (1 + (v1/v2)/(v2/v3)) numerator <- (v1 / v2) / (v2 / v3) AAC <-round(numerator / (1 + numerator),2) top3_values <- sort(nodes$value, decreasing = TRUE)[1:3] top3_values if (min(top3_values)<=0){ top3_values<-top3_values+abs(min(top3_values))+.001 } top3_values top3<-top3_values # Assign for readability v1 <- top3_values[1] # top 1 v2 <- top3_values[2] # top 2 v3 <- top3_values[3] # top 3 top3_values <- sort(nodes$value2, decreasing = TRUE)[1:3] top3_values if (min(top3_values)<=0){ top3_values<-top3_values+abs(min(top3_values))+.001 } top3_values top3<-top3_values # Assign for readability v21 <- top3_values[1] # top 1 v22 <- top3_values[2] # top 2 v23 <- top3_values[3] # top 3 maxv2<-max(v2,v22) maxv3<-max(v3,v23) sd_x <- sd(nodes$value2)*0.0001 sd_y <- sd(nodes$value)*0.0001 radius_x<-sd_x if (AAC<0.7){ # Ensure fallback value reflects the spread, clamp if needed delta <- abs(maxv2 - maxv3)/2 fallback <- maxv2 - delta sd_x <- if (radius_x < maxv2) radius_x else fallback sd_y <- sd_x }else{ sd_x<-max(radius_x,maxv2) sd_y <- sd_x } radius <- sqrt((sd_x- mean_x)^2 + (sd_y - mean_y)^2) if (radius>.38){ if (AAC>=0.7){ radius<-.38 } } # Step 2: Generate curves # Step 2: Generate curves spread_x <- 5 * radius spread_y <- 5.7 * radius # 建立拋物線 set up parabolic curves t <- seq(0, 1, length.out = 300) lower_curve <- data.frame( x = t * spread_x - spread_x / 2 + mean_x, y = mean_y - spread_y * (1 - t)^2 ) upper_curve <- data.frame( x = -t * spread_x + spread_x / 2 + mean_x, y = mean_y + spread_y * (1 - t)^2 ) # 視覺比例修正 adjust the propotion for visuals visual_ratio <- (max_x - min_x) / (max_y - min_y) # 建立圓形貼近曲線 circle near to parabolic curves theta <- seq(0, 2 * pi, length.out = 300) ###############for column==3 # Step 3: Classification Functions ci_radius_x <- radius ci_radius_y <-radius #if (ncol(nodes) == 3) { is_inside_ellipse <- function(x, y) { ((x - mean_x)^2 / ci_radius_x^2) + ((y - mean_y)^2 / ci_radius_y^2) <= 1 } is_outside_ellipse <- function(x, y) { ((x - mean_x)^2 / ci_radius_x^2) + ((y - mean_y)^2 / ci_radius_y^2) > 1 } is_above_upper <- function(x, y) { x_parabola <- -t * spread_x + spread_x / 2 + mean_x y_parabola <- mean_y + spread_y * (1 - t)^2 y_pred <- approx(x_parabola, y_parabola, xout = x, rule = 2)$y return(!is.na(y_pred) && y > y_pred) } is_below_lower <- function(x, y) { x_parabola <- t * spread_x - spread_x / 2 + mean_x y_parabola <- mean_y - spread_y * (1 - t)^2 y_pred <- approx(x_parabola, y_parabola, xout = x, rule = 2)$y return(!is.na(y_pred) && y < y_pred) } # Step 4: Classification Logic nodes$carac2 <- mapply(function(x, y) { above <- is_above_upper(x, y) below <- is_below_lower(x, y) inside <- is_inside_ellipse(x, y) outside <- is_outside_ellipse(x, y) if (x >= mean_x & y > mean_y & outside) return("1") else if (below) return("4") else if (inside) return("5") else if (x < mean_x & y > mean_y & above) return("2") else return("3") }, nodes$value2, nodes$value) # Step 5: Map labels and colors label_mapping <- c( "1" = "Leader", "2" = "Lone Wolves", "3" = "Follower", "4" = "Connector", "5" = "Normal" ) nodes$color <- specified_colors[nodes$carac] # 輔助線 dianogal line diag_line <- data.frame( x = seq(mean_x - 3 * expand_x, mean_x + 3 * expand_x, length.out = 300), y = seq(mean_x - 3 * expand_x, mean_x + 3 * expand_x, length.out = 300) ) circle_data <- data.frame( x = mean_x + radius * cos(theta), y = mean_y + radius * sin(theta) ) nodessil<-nodes datasil<-data network <- graph_from_data_frame(d = data, vertices = nodes, directed = FALSE) networksil<-network # 畫圖 draw circle ggplot(nodes, aes(x = value2, y = value)) + geom_segment(data = edges, aes(x = x, y = y, xend = xend, yend = yend), color = "gray60", size = 0.8, alpha = 0.7) + geom_point(aes(size = value, fill = color), color = "black", shape = 21, alpha = 0.9) + geom_text_repel(aes(label = name), size = 3.5, max.overlaps = 100) + scale_fill_identity() + scale_size(range = c(3, 12)) + geom_vline(xintercept = mean_x, linetype = "dashed", color = "red") + geom_hline(yintercept = mean_y, linetype = "dashed", color = "red") + geom_line(data = lower_curve, aes(x = x, y = y), color = "blue", linewidth = 2) + geom_line(data = upper_curve, aes(x = x, y = y), color = "blue", linewidth = 2) + geom_line(data = diag_line, aes(x = x, y = y), color = "gray70", linetype = "dotted") + geom_path(data = circle_data, aes(x = x, y = y), color = "purple", linewidth = 1.1) + coord_fixed(ratio = visual_ratio) + xlim(min_x - 3 * expand_x, max_x + 3 * expand_x) + ylim(min_y - 3 * expand_y, max_y + 3 * expand_y) + labs( title = paste0("AAC=",AAC," n=",nodesbb$value[1]," for Top 1 in Top 20"), x = "Edge(Influence)", y = "Density(Dominance)", size = "Dominance" ) + theme_minimal(base_family = "Helvetica") + theme( plot.title = element_text(size = 16, face = "bold", hjust = 0.5), legend.position = "none" ) # Compute Pearson correlation cor_test <- cor.test(nodes$value, nodes$value2, method = "pearson") # Extract results r_val <- round(cor_test$estimate, 3) t_val <- round(cor_test$statistic, 3) p_val <- signif(cor_test$p.value, 3) # Create a correlation label cor_label <- paste0("r = ", r_val, ", t = ", t_val, ", p = ", round(p_val,4)) # Step 1: Extract top 3 values in descending order top3_values <- sort(nodesbb$value, decreasing = TRUE)[1:3] if (min(top3_values)<=0){ top3_values<-top3_values+abs(min(top3_values))+.001 } top3_values top3<-top3_values # Assign for readability v1 <- top3_values[1] # top 1 v2 <- top3_values[2] # top 2 v3 <- top3_values[3] # top 3 A01<-v1 A02<-v2 A03<-v3 # Step 2: Compute AAC as per your formula: # AAC = ((v1/v2)/(v2/v3)) / (1 + (v1/v2)/(v2/v3)) numerator <- (v1 / v2) / (v2 / v3) AAC <-round(numerator / (1 + numerator),2) # Step 1: Extract top 3 values in descending order top3_values <- sort(nodesbb$value2, decreasing = TRUE)[1:3] if (min(top3_values)<=0){ top3_values<-top3_values+abs(min(top3_values))+.001 } top3_values # Assign for readability v1 <- top3_values[1] # top 1 v2 <- top3_values[2] # top 2 v3 <- top3_values[3] # top 3 # Step 2: Compute AAC as per your formula: # AAC = ((v1/v2)/(v2/v3)) / (1 + (v1/v2)/(v2/v3)) numerator <- (v1 / v2) / (v2 / v3) AAC2 <- round(numerator / (1 + numerator),2) # Step 3: Output result cat("AAC2 =", round(AAC2, 4), "\n") # Step 3: Output result cat("AAC1 =", round(AAC, 4), "\n") # 與 Excel VLOOKUP(..., TRUE) 相同邏輯 if (AAC<1){ logit_value<-log(AAC/(1-AAC)) } else{ logit_value<-10 } lookup_table <- data.frame( Logit = c(-5, -4.6, -4, -3, -2.2, -2, -1.4, -1.1, -1, -0.8, -0.69, -0.5, -0.4, -0.2, -0.1, 0, 0.1, 0.2, 0.4, 0.5, 0.69, 0.8, 1, 1.1, 1.4, 2, 2.2, 3, 4, 4.6, 5), Probability = c(0.01, 0.01, 0.02, 0.05, 0.10, 0.12, 0.20, 0.25, 0.27, 0.30, 0.33, 0.38, 0.40, 0.45, 0.48, 0.5, 0.52, 0.55, 0.6, 0.62, 0.67, 0.7, 0.73, 0.75, 0.8, 0.88, 0.9, 0.95, 0.98, 0.99, 0.99) ) # 它會回傳小於等於指定值的最大 index。 # 使用 findInterval 模擬近似比對 (TRUE) idx <- findInterval(logit_value, lookup_table$Logit) if (idx == 0) { prob_result <- NA # 或可用最小值的 Probability } else { prob_result <- lookup_table$Probability[idx] } prob_result # 線性內插法 prob_result <- approx(x = lookup_table$Logit, y = lookup_table$Probability, xout = logit_value)$y round(prob_result,2) logit_values <- c(2.31 ,1.52 ,0.90 ,0.49 ,0.16 ,-0.28,-0.58,-0.99,-1.66,-2.31) prob_result <- approx(x = lookup_table$Logit, y = lookup_table$Probability, xout = logit_values)$y round(prob_result,2) #logits <- c(0.73, 1.3, 2.5) #idxs <- findInterval(logits, lookup_table$Logit) #probabilities <- lookup_table$Probability[idxs] #probabilities # HHI 計算# ✅ 範 # 確保 value 與 value2 被標準化為總和為1的比例 prop_value <- nodes$value / sum(nodes$value) prop_value2 <- nodes$value2 / sum(nodes$value2) if (min(nodes$value) < 0) { shifted_value <- nodes$value - min(nodes$value) + 1e-6 # 加小常數避免除零 } else { shifted_value <- nodes$value } shifted_value2<- nodes$value2 if (min(nodes$value2) < 0) { shifted_value2 <- nodes$value2 - min(nodes$value2) + 1e-6 # 加小常數避免除零 } else { shifted_value <- nodes$value } shifted_value <- sort(shifted_value, decreasing = TRUE)[1:3] shifted_value2 <- sort(shifted_value2, decreasing = TRUE)[1:3] # 標準化為比例 prop_value <- shifted_value / sum(shifted_value) # 標準化為比例 prop_value2 <- shifted_value2 / sum(shifted_value2) # 正確 HHI 計算 hhi_value <- sum(prop_value^2) hhi_value2 <- sum(prop_value2^2) cat("HHI (value) =", round(hhi_value, 4), "\n") cat("HHI (value2) =", round(hhi_value2, 4), "\n") cat(cor_label,sep="\n") final_data<-nodes$value round(summary(final_data),3) # 取得 top1 name in value and value2 top1_value_name <- nodes$name[which.max(nodes$value)] top1_value2_name <- nodes$name[which.max(nodes$value2)] # 判斷是否相同 top1name <- top1_value_name == top1_value2_name # 預設領導類型 leadertype <- "No" # 條件判斷 if (top1name) { if (AAC >= 0.8) { leadertype <- "Supper" } else if (AAC >= 0.7) { leadertype <- "Quasi-Supper" } else if (AAC >= 0.6) { leadertype <- "Strong" } else if (AAC >= 0.5) { leadertype <- "Moderate" } else { leadertype <- "Weak" } } else { leadertype <- "Not Leader" } cat("AAC1 =", round(AAC, 4), "\n") cat("A01 =", A01, "\n") cat("A02 =", A02, "\n") cat("A03 =", A03, "\n") cat("HHI (value) =", round(hhi_value, 4), "\n") round(top3,2) cat("Leader =", leadertype, "\n") table(nodes$carac2) # 找出 top 1 name top_1 <- nodes$name[1] # 篩選符合條件的 name filtered_names <- nodes$name[ nodes$name == top_1 | ((!nodes$name %in% data$Target & nodes$name %in% data$Source)) ] sumfiltered_names<- length(filtered_names ) Top1type<-nodes$name[1] if (length(unique(nodes$carac))==1 || AAC>0.7){ cat("Leadership =", Top1type," AA", "\n") }else if (sumfiltered_names>1){ cat("Leadership =", Top1type," NA", "\n") }else{ cat("Leadership =", Top1type," RA", "\n") } nodes$value2b<-nodesbb$value2 ########################################## #####Importance<-2 if (Importance==2) { nodes$value2<-NULL nodes <- nodes %>% left_join(nodesbb %>% select(name, value,value2), by = "name", suffix = c("", ".new")) %>% mutate(value2 = value2) %>% mutate(value = value.new) %>% # Replace with matched value from nodes_final select(-value.new) # Remove the temporary column nodes <- nodes[!is.na(nodes$value), ] data <- data[data$Source %in% nodes$name & data$Target %in% nodes$name, ] } ########################################## if ("value2b" %in% names(nodes)){ nodes$value2b<-nodes$value2 } url <- "https://www.raschonline.com/raschonline/sankeyplot.txt" sourceCode <- readLines(url, warn = FALSE) eval(parse(text = sourceCode)) nodesbb <- nodesbb[order(-nodesbb$value), c("name", "value", "value2", "carac")] nodesbb #write.csv(nodesbb, "F:/RR/nodesbb.csv", row.names = FALSE) if ("value2b" %in% names(nodes)){ nodes <- nodes[, c("name", "value","value2", "carac","value2b")] }else{ nodes <- nodes[, c("name", "value", "value2","carac")] } #write.csv(data, file = "F:/RR/datatemporate.csv", row.names = FALSE) #write.csv(nodes, file = "F:/RR/nodestemporate.csv", row.names = FALSE) ###R平台。由2集群用檔案製作11演算法分類結果。https://www.raschonline.com/raschonline/cbpsankey.asp?cbp=Force-DirectedGraph ################################################## ## Draw origal plot if (Yessilhouette1=="Yes"){ relation_subset <- relation_set[ relation_set$Leader %in% nodesbb$name & relation_set$follower %in% nodesbb$name, ] relation_subset<-relation_subset[,1:3] all_nodes <- union(relation_subset$Leader, relation_subset$follower) full_pairs <- expand.grid(Leader = all_nodes, follower = all_nodes, stringsAsFactors = FALSE) library(dplyr) full_matrix_data <- full_pairs %>% left_join(relation_subset, by = c("Leader", "follower")) %>% mutate(WCD = replace_na(WCD, 0)) library(tidyr) relation_matrix <- full_matrix_data %>% pivot_wider( names_from = follower, values_from = WCD ) %>% column_to_rownames(var = "Leader") %>% as.matrix() # Make symmetric: use maximum #relation_matrix <- pmax(relation_matrix, t(relation_matrix)) # Optional diag(relation_matrix) <- 0 relation_df <- as.data.frame(relation_matrix) relation_df$name <- rownames(relation_df) relation_df <- relation_df[, c("name", setdiff(names(relation_df), "name"))] relation_df <- relation_df %>% left_join(nodesbb[, c("name", "carac")], by = "name") write.csv(relation_df, "F:/RR/relation_matrix.csv", row.names = FALSE) } ###################################### ## Draw origal plot if (1==5){ data<-as.data.frame(silihousettelaydata) countries <-silihousettenodes$name plot( data, col = "black", pch = 16, main = "Example Data") text(data, labels = countries, pos = 3, cex = 0.7) dist_matrix <- as.matrix(dist(data)) connection_matrix <- max(dist_matrix) - dist_matrix rownames(connection_matrix) <- countries colnames(connection_matrix) <- countries hospital_names<- countries relation_matrix<-round(connection_matrix,3) relation_df <- as.data.frame(relation_matrix) relation_df$name <- rownames(relation_df) relation_df <- relation_df[, c("name", setdiff(names(relation_df), "name"))] relation_df <- relation_df %>% left_join(silihousettenodes[, c("name", "carac", "value")], by = "name") # Plot with reversed arrows textz<-paste0("Top ",nrow(silihousettenodes)," for ",length(unique(silihousettenodes))," Clusters") plot(network, layout = silihousettelaydata, vertex.color = silihousettemy_color, edge.width = E(silihousettenetwork)$WCD * 1 / 4 / (maxaa / 10), vertex.label.dist = 1, vertex.shape = "circle", vertex.label = V(silihousettenetwork)$name, vertex.label.font = 1, vertex.size = silihousettenodes$value2 * 1 / (maxbb / 24), #vertex.label.color = my_color, vertex.label.cex = 1.1, #edge.color = vertex_label_colors, edge.curved = 0.1, main = textz, asp = 0, edge.arrow.size = 0.5 # Arrows are now reversed correctly ) write.csv(relation_df, "F:/RR/relation_matrix.csv", row.names = FALSE) } cat("Silhouette score if relation_batrix generate above \t") ################### if (Yessilhouette1=="Yes"){ nodes<-nodessil data<-datasil network <- graph_from_data_frame(d=data, vertices=nodes, directed=F) laydata <- as.matrix(nodes[, c("value2", "value")]) V(network)$cluster<-nodes$carac ###next to https://raschonline.com/raschonline/cbp.asp?cbp=SilhouetteScores2 ##plot(network, layout = laydata, vertex.color = V(network)$cluster) # Reorder nodes to match network nodes_ordered <- nodes[match(V(network)$name, nodes$name), ] # Ensure layout matches vertices laydata <- as.matrix(nodes_ordered[, c("value2", "value")]) silihousettemy_color <- nodes_ordered$color vertex_sizes <- nodes_ordered$value # Safety checks stopifnot( vcount(network) == nrow(laydata), vcount(network) == length(silihousettemy_color), vcount(network) == length(vertex_sizes) ) nodesbb$valuedd<-rescale(nodesbb$value, to = c(5, 30)) nodes <- nodes %>% left_join(nodesbb %>% select(name, valuedd), by = "name") # Plot plot( network, layout = laydata, vertex.color = silihousettemy_color, edge.width = E(silihousettenetwork)$WCD * 1 / 4 / (maxaa / 10), vertex.label.dist = 1, vertex.shape = "circle", vertex.label = V(network)$name, vertex.label.font = 1, vertex.size = nodes$valuedd, vertex.label.cex = 1.1, edge.curved = 0.1, main = textz, asp = 0, edge.arrow.size = 0.5 ) library(igraph) library(cluster) # 1. Make sure graph has cluster assignment! clusters <- as.integer(as.character(V(network)$cluster)) # 2. Distance matrix (shortest paths) #dist_matrix <- distances(network) dist_matrix <- as.matrix(dist(laydata)) # Replace Inf with large number dist_matrix[is.infinite(dist_matrix)] <- max(dist_matrix[is.finite(dist_matrix)]) + 1 # 3. Compute silhouette # 3. Compute silhouette if (length(unique(clusters))==1){ nodesdata<- nodes[, c("value", "value2")] kmeans_result <- kmeans(nodesdata, centers = 2) final_clusters <- kmeans_result$cluster nodes$carac<- final_clusters clusters<-final_clusters } sil_obj <- silhouette(clusters, dist_matrix) # 4. Extract as data frame manually sil_df <- data.frame( cluster = as.integer(sil_obj[, "cluster"]), neighbor = as.integer(sil_obj[, "neighbor"]), sil_width = as.numeric(sil_obj[, "sil_width"]) ) # 5. Mean silhouette per cluster mean_sil_per_cluster <- tapply(sil_df$sil_width, sil_df$cluster, mean) # 6. Summary table silhouette_summary <- data.frame( cluster = as.integer(names(mean_sil_per_cluster)), mean_silhouette = as.numeric(mean_sil_per_cluster) ) #print(silhouette_summary) library(dplyr) # 1. Vertex-cluster mapping vertex_df <- data.frame( vertex = V(network)$name, cluster = V(network)$cluster ) # 2. Find first (leader) in each cluster leaders_df <- vertex_df %>% group_by(cluster) %>% summarise(leader = first(vertex)) leaders_df <- leaders_df %>% mutate(cluster = as.integer(as.character(cluster))) # 3. Join with mean silhouette summary cluster_summary <- left_join(silhouette_summary, leaders_df, by = "cluster") # 4. View result print(cluster_summary) }########## ###next to https://raschonline.com/raschonline/cbp.asp?cbp=SilhouetteScores2 if (Yessilhouette1=="Yes"){ url <- "https://www.raschonline.com/raschonline/silhouetteScore3.txt" sourceCode <- readLines(url, warn = FALSE, encoding = "UTF-8") eval(parse(text = sourceCode)) ggplot() + geom_point( data = laydata, aes(x = x, y = y, size = value, color = factor(carac)), alpha = 0.8 ) + ggrepel::geom_label_repel( data = laydata, aes(x = x, y = y, label = name, color = factor(carac)), size = 4, max.overlaps = 100 ) + scale_size_continuous(range = c(0.2, 5), name = "Node Size / Edge WCD") + scale_color_manual(values = carac_colors, name = "Carac Group") + # Add vertical and horizontal lines at mid x and y geom_vline(xintercept = mean(laydata$x), linetype = "dashed", color = "red") + geom_hline(yintercept = mean(laydata$y), linetype = "dashed", color = "red") + theme_minimal() + labs( title = paste0("Bubbles Sized by Count, Colored by Cluster, Less Distance by Strength\nAAC=", round(AAC, 2)), x = "Silhouette Width", y = "Publication Count" ) + theme(legend.position = "none") cat("AAC1 =", round(AAC, 4), "\n") } if (1==3){ ##for kano diagram coordinates network<-networksil nodes<-nodessil data<-datasil # 畫圖 draw circle if (!"sil_width" %in% colnames(nodes)){ nodes <- nodes %>% left_join( sil_df %>% select(country, sil_width), by = c("name" = "country") ) nodes$sil_width<- nodes$sil_width nodes$size_scaled <- rescale(nodes$sil_width, to = c(1, 10)) } ggplot(nodes, aes(x = value2, y = value)) + geom_segment(data = edges, aes(x = x, y = y, xend = xend, yend = yend), color = "gray60", size = 0.8, alpha = 0.7) + geom_point(aes(size = size_scaled, fill = color), color = "black", shape = 21, alpha = 0.9) + geom_text_repel(aes(label = name), size = 3.5, max.overlaps = 100) + ggrepel::geom_label_repel( data = laydata, aes(x = x, y = y, label = name, fill = factor(carac)), size = 4, max.overlaps = 100, color = "black", label.size = 0.2, label.padding = 0.25, box.padding = 0.4, segment.color = "gray60", segment.size = 0.4 ) + #scale_fill_manual(values = carac_colors, name = "Group") + scale_fill_identity() + scale_size(range = c(3, 12)) + geom_vline(xintercept = mean_x, linetype = "dashed", color = "red") + geom_hline(yintercept = mean_y, linetype = "dashed", color = "red") + geom_line(data = lower_curve, aes(x = x, y = y), color = "blue", linewidth = 2) + geom_line(data = upper_curve, aes(x = x, y = y), color = "blue", linewidth = 2) + geom_line(data = diag_line, aes(x = x, y = y), color = "gray70", linetype = "dotted") + geom_path(data = circle_data, aes(x = x, y = y), color = "purple", linewidth = 1.1) + coord_fixed(ratio = visual_ratio) + xlim(min_x - 3 * expand_x, max_x + 3 * expand_x) + ylim(min_y - 3 * expand_y, max_y + 3 * expand_y) + labs( title = paste0("AAC=",AAC," SS=",round(nodes$sil_width[1],2)," for Top 1"), x = "Edge(Influence)", y = "Density(Dominance)", size = "Dominance" ) + theme_minimal(base_family = "Helvetica") + theme( plot.title = element_text(size = 16, face = "bold", hjust = 0.5), legend.position = "none" ) } if (Yessilhouette1=="Yes"){ #####silhouette Score url <- "https://www.raschonline.com/raschonline/silhouetteScore3.txt" sourceCode <- readLines(url, warn = FALSE, encoding = "UTF-8") eval(parse(text = sourceCode)) xlabel<-"Silhouette Width" if (cohesion){ laydata$x<-round(1/(1+laydata$a_i),2) last_point <- tail(laydata, 1) xlabel<-"Cohesion Coefficient" } ggplot() + geom_point( data = laydata, aes(x = x, y = y, size = value, color = factor(carac)), alpha = 0.8 ) + ggrepel::geom_label_repel( data = laydata, aes(x = x, y = y, label = name, color = factor(carac)), size = 4, max.overlaps = 100 ) + scale_size_continuous(range = c(0.2, 5), name = "Node Size / Edge WCD") + scale_color_manual(values = carac_colors, name = "Carac Group") + # Add vertical and horizontal lines at mid x and y geom_vline(xintercept = mean(laydata$x), linetype = "dashed", color = "red") + geom_hline(yintercept = mean(laydata$y), linetype = "dashed", color = "red") + theme_minimal() + labs( title = paste0("Bubbles Sized by Count, Colored by Cluster, Less Distance by Strength\nAAC=", round(AAC, 2)), x = "Silhouette Width", y = "Publication Count" ) + theme(legend.position = "none") cat("AAC1 =", round(AAC, 4), "\n") # Spearman 等級相關（非線性但單調） cor(nodes$value, nodes$sil_width, method = "spearman") # Kendall τ（另一種非參數等級相關） cor(nodes$value, nodes$sil_width, method = "kendall") } if (1==2){ ### All edges shown url <- "https://www.raschonline.com/raschonline/silhouetteScore3.txt" sourceCode <- readLines(url, warn = FALSE, encoding = "UTF-8") eval(parse(text = sourceCode)) # ---------- clean NAs ---------- # ---------- clean NAs ---------- nodes$a_i[is.na(nodes$a_i)] <- 0 nodes$sil_width[is.na(nodes$sil_width)] <- 0 nodes$value2[is.na(nodes$value2)] <- 0 # ---------- preserve names + relabel ---------- if (!"name2" %in% names(nodes)) nodes$name2 <- nodes$name nodes$name <- sprintf("%s(%.2f)", nodes$name, nodes$sil_width) # lookup from original -> relabeled lkp <- setNames(nodes$name, nodes$name2) relation_set$Leader <- ifelse(relation_set$Leader %in% names(lkp), lkp[relation_set$Leader], relation_set$Leader) relation_set$follower <- ifelse(relation_set$follower %in% names(lkp), lkp[relation_set$follower], relation_set$follower) # ---------- build igraph ---------- network <- graph_from_data_frame(d = relation_set, vertices = nodes, directed = FALSE) laydata <- layout_with_fr(network) # ---------- assign cluster-based colors ---------- # ---------- assign colors BY VERTEX ORDER (cluster if present, else carac, else 1) ---------- base_colors <- c( "#FF0000", "#0000FF", "#998000", "#008000", "#800080", "#FFC0CB", "#000000", "#ADD8E6", "#FF4500", "#A52A2A", "#8B4513", "#FF8C00", "#32CD32", "#4682B4", "#9400D3", "#FFD700", "#C0C0C0", "#DC143C", "#1E90FF" ) # Get vertex attributes in the SAME order as V(network) vdf <- igraph::as_data_frame(network, what = "vertices") # choose grouping column: cluster -> carac -> single group group_col <- if ("cluster" %in% names(vdf)) "cluster" else if ("carac" %in% names(vdf)) "carac" else NULL grp <- if (is.null(group_col)) rep("1", nrow(vdf)) else vdf[[group_col]] grp <- as.character(grp) grp[is.na(grp)] <- "NA" # build a discrete palette for the unique groups (first-appearance order) lev <- unique(grp) pal <- if (length(lev) <= length(base_colors)) { base_colors[seq_along(lev)] } else { grDevices::colorRampPalette(base_colors)(length(lev)) } col_map <- setNames(pal, lev) # colors in vertex order vcols <- unname(col_map[grp]) # assign identical node & label colors V(network)$color <- vcols V(network)$label.color <- vcols # ---------- plot (unchanged aside from using vertex attrs) ---------- maxaa <- max(E(network)$WCD, na.rm = TRUE) maxbb <- max(nodes$value2, na.rm = TRUE) plot( network, layout = laydata, vertex.color = V(network)$color, vertex.label.color = V(network)$label.color, vertex.shape = "circle", vertex.label = V(network)$name, vertex.label.font = 1, vertex.label.cex = 1.1, vertex.label.dist = 1, vertex.size = nodes$value2 * 2 / (maxbb / 24), edge.width = (E(network)$WCD * 4 / 4) / (maxaa / 10), edge.color = "gray50", edge.curved = 0.1, edge.arrow.size = 0.5, asp = 0 ) # ---------- legend (only if multiple groups) ---------- if (length(lev) > 1) { legend( "topleft", legend = lev, col = col_map[lev], pch = 19, pt.cex = 1.5, bty = "n", title = if (is.null(group_col)) "Group" else group_col ) } } kanosilhouetteplot<-"FALSE" if (kanosilhouetteplot=="TRUE"){ ### Kano Silhouette plot url <- "https://www.raschonline.com/raschonline/silhouetteScore3.txt" sourceCode <- readLines(url, warn = FALSE, encoding = "UTF-8") eval(parse(text = sourceCode)) library(dplyr) radius<-.18 mean_y<-mean(nodes$sil_width) mean_x<-mean(nodes$a_i) max_y<-max(nodes$sil_width) min_y<-min(nodes$sil_width) max_x<-max(nodes$a_i) min_x<-min(nodes$a_i) # Step 2: Generate curves # Step 2: Generate curves spread_x <- 5 * radius spread_y <- 5.7 * radius # 建立拋物線 set up parabolic curves t <- seq(0, 1, length.out = 300) lower_curve <- data.frame( x = t * spread_x - spread_x / 2 + mean_x, y = mean_y - spread_y * (1 - t)^2 ) upper_curve <- data.frame( x = -t * spread_x + spread_x / 2 + mean_x, y = mean_y + spread_y * (1 - t)^2 ) # 視覺比例修正 adjust the propotion for visuals visual_ratio <- 3*(max_x - min_x) / (max_y - min_y) # 建立圓形貼近曲線 circle near to parabolic curves theta <- seq(0, 2 * pi, length.out = 300) ###############for column==3 # Step 3: Classification Functions ci_radius_x <- radius ci_radius_y <-radius #if (ncol(nodes) == 3) { is_inside_ellipse <- function(x, y) { ((x - mean_x)^2 / ci_radius_x^2) + ((y - mean_y)^2 / ci_radius_y^2) <= 1 } is_outside_ellipse <- function(x, y) { ((x - mean_x)^2 / ci_radius_x^2) + ((y - mean_y)^2 / ci_radius_y^2) > 1 } is_above_upper <- function(x, y) { x_parabola <- -t * spread_x + spread_x / 2 + mean_x y_parabola <- mean_y + spread_y * (1 - t)^2 y_pred <- approx(x_parabola, y_parabola, xout = x, rule = 2)$y return(!is.na(y_pred) && y > y_pred) } is_below_lower <- function(x, y) { x_parabola <- t * spread_x - spread_x / 2 + mean_x y_parabola <- mean_y - spread_y * (1 - t)^2 y_pred <- approx(x_parabola, y_parabola, xout = x, rule = 2)$y return(!is.na(y_pred) && y < y_pred) } nodes$color <- specified_colors[nodes$carac] # 輔助線 dianogal line diag_line <- data.frame( x = seq(mean_x - 3 * expand_x, mean_x + 3 * expand_x, length.out = 300), y = seq(mean_x - 3 * expand_x, mean_x + 3 * expand_x, length.out = 300) ) circle_data <- data.frame( x = mean_x + radius * cos(theta), y = mean_y + radius * sin(theta) ) nodessil<-nodes datasil<-data network <- graph_from_data_frame(d = data, vertices = nodes, directed = FALSE) # 畫圖 draw circle ggplot(nodes, aes(x = a_i, y = sil_width)) + geom_segment(data = edges, aes(x = x, y = y, xend = xend, yend = yend), color = "gray60", size = 0.8, alpha = 0.7) + geom_point(aes(size = value, fill = color), color = "black", shape = 21, alpha = 0.9) + geom_text_repel(aes(label = name), size = 3.5, max.overlaps = 100) + scale_fill_identity() + scale_size(range = c(3, 12)) + geom_vline(xintercept = mean_x, linetype = "dashed", color = "red") + geom_hline(yintercept = mean_y, linetype = "dashed", color = "red") + geom_line(data = lower_curve, aes(x = x, y = y), color = "blue", linewidth = 2) + geom_line(data = upper_curve, aes(x = x, y = y), color = "blue", linewidth = 2) + geom_line(data = diag_line, aes(x = x, y = y), color = "gray70", linetype = "dotted") + geom_path(data = circle_data, aes(x = x, y = y), color = "purple", linewidth = 1.1) + coord_fixed(ratio = visual_ratio) + xlim(min_x - 3 * expand_x, max_x + 3 * expand_x) + ylim(min_y - 3 * expand_y, max_y + 3 * expand_y) + labs( title = paste0("Silhouette-Kano Plot: DC=",round(AAC, 2)), x = paste0("Unweigtted-Cohension(a(i)):",nodes$a_i[1]), y = paste0("Weighted Cohension(SS(i)):",nodes$sil_width[1]), size = "Dominance" ) + theme_minimal(base_family = "Helvetica") + theme( plot.title = element_text(size = 16, face = "bold", hjust = 0.5), legend.position = "none" ) cat("AAC1 =", round(AAC, 4), "\n") nrow(relation_set) } relation_set<-relation_set[,1:3] data2<-relation_set #write.csv(data, file = "F:/RR/datatemporate.csv", row.names = FALSE) nodes <- nodesbb[, c("name", "value","value2", "carac")] #write.csv(nodes, file = "F:/RR/nodestemporate.csv", row.names = FALSE) #write.csv(data2, file = "F:/RR/datatemporate.csv", row.names = FALSE) nodes