提交: 267fb20686e1ca7ef03a921dc35d2fbc9c8910fc - myprojects-hg-reborn (hg)

Commit MetaInfo

• 修订版: 267fb20686e1ca7ef03a921dc35d2fbc9c8910fc (tree)
• 时间: 2022-03-25 07:19:27
• 作者: Lorenzo Isella <lorenzo.isella@gmai...>
• Commiter: Lorenzo Isella

Log Message

I added multiple bond removal strategies.

更改概述

• modified: R-codes/read_plot_aggregate_shiny.R

差异

diff -r 0b42637ca63e -r 267fb20686e1 R-codes/read_plot_aggregate_shiny.R
--- a/R-codes/read_plot_aggregate_shiny.R	Thu Mar 24 12:05:24 2022 +0100
+++ b/R-codes/read_plot_aggregate_shiny.R	Thu Mar 24 23:19:27 2022 +0100
@@ -164,6 +164,94 @@
 }
 
 
+
+
+fragment_cluster_prob2 <- function(g, probs){
+
+    n_rep <- 4
+    set.seed(1234)
+
+    
+    n_links=E(g)
+    mysamp <- seq(n_links)
+
+    n_rem <- sum(probs>0)*n_rep
+    
+    myseq <- sample(mysamp, n_rem,replace=T, probs)
+    
+    frag_dist <- c()
+
+    
+    for (i in myseq){
+
+    
+        g_broken <- delete.edges(g,i)
+
+        fragments <- clusters(g_broken)$csize
+        if(length(fragments)==1){
+            fragments=c(0, fragments)
+
+            ## print("No frag!!!")
+        }
+        fragments_tibble <- tibble(n1=fragments[1], n2=fragments[2])
+        ## print(fragments_tibble)
+
+        frag_dist <- bind_rows(frag_dist, fragments_tibble)
+       
+    }
+
+    frag_dist <- frag_dist %>%
+        mutate(e1=if_else(n1<=n2, n1, n2),
+               e2=if_else(n1>=n2, n1, n2)) %>%
+        mutate(n1=e1,n2=e2) %>%
+        select(-c(e1,e2)) 
+    
+ return(frag_dist)
+}
+
+
+
+
+
+select_chunk <- function(x,  low, high){
+
+    if (low<0 | high<0 | low>1 | high>1 | low >=high){
+
+        print("error in the definition of high and low")
+        
+    } else  {
+
+        ss <- sort(x, index.return=T, decreasing=F)
+        n <- length(x)
+
+        low_cut <- round(n*low, 0)
+        high_cut <- round(n*high, 0)
+        res <- ss$ix[low_cut:high_cut]
+
+    }
+ 
+}
+
+
+
+select_chunk_reset <- function(x, low, high){
+
+
+    chunk <- select_chunk(x, low, high)
+
+    ## print("chunk is, ")
+    ## print(chunk)
+
+    x[-chunk] <- 0
+
+    return(x)
+
+    
+}
+
+
+
+
 #####################################################################
 #####################################################################
 #####################################################################
@@ -251,33 +339,12 @@
         condition = "input.vis_calc == 'Fragmentation Statistics' ",
          radioButtons("frag_calc", "Select Type of Bond Removal",
                       choices = c("Uniform Probability",
-                                  "Shell around CM (in units of Rg)",
-                                  "Bond betweenness"),
+                                  "Bond betweenness",
+                                  "Quantile Range for Bond Betweenness"),
                    selected = "Uniform Probability" )
 ),
 
 
-    # Main panel for displaying outputs ----
-    ## mainPanel(
-
-      # Output: Data file ----
-        ## tableOutput("contents2"),
-        
-        ## tableOutput("contents3"),
-
-    ##   conditionalPanel(
-    ##     condition = "input.data_choice == 'ingressi_terapia_intensiva' ",
-    ## plotlyOutput("myplot3"
-    ##            )
-    ## )
-
-
-
-    ##     ({
-    ##         rglwidgetOutput("myplot" , width = "auto" , height = "1280"
-    ##                  )
-    ## })
-
 
       conditionalPanel(
         condition = "input.vis_calc == 'Visualization'  ",
@@ -301,6 +368,21 @@
     DTOutput("frag2")
 ),
 
+
+      conditionalPanel(
+        condition = "input.vis_calc == 'Fragmentation Statistics' &&
+input.frag_calc ==  'Quantile Range for Bond Betweenness' ",
+    DTOutput("frag3")
+),
+
+      conditionalPanel(
+        condition = "input.vis_calc == 'Fragmentation Statistics' &&
+input.frag_calc ==  'Quantile Range for Bond Betweenness' ",
+
+sliderInput("betrange", "Quantile Range:",min = 0, max = 1, value = c(0,0.3),
+            step=1e-2)
+),
+
  conditionalPanel(
         condition = "input.vis_calc == 'Fragmentation Statistics' ",
 downloadButton("downloadData", HTML("Download Fragmentation Raw Data"))
@@ -416,7 +498,11 @@
     })
 
 
-    
+    fragments3 <- reactive({
+
+        fragment_cluster_prob2(g(), betweenness_list_quantiles())
+        
+    })
 
 
 
@@ -427,6 +513,9 @@
     output$frag2 <- renderDT({datatable(fragments2())
     })
 
+    output$frag3 <- renderDT({datatable(fragments3())
+    })
+
 
 
     df_frag <- reactive({
@@ -436,7 +525,10 @@
         } else if (input$frag_calc == "Bond betweenness"){
 
             fragments2()
-        } 
+        }  else if (input$frag_calc == "Quantile Range for Bond Betweenness"){
+
+            fragments3()
+        }
 
 
         
@@ -448,6 +540,17 @@
             mutate(n1_norm=n1/(n1+n2))
         
 })
+
+
+    betweenness_list_quantiles <- reactive({
+
+        eb <- edge_betweenness(g(), directed=F) %>%
+            select_chunk_reset(min(input$betrange), max(input$betrange)) 
+            
+        
+})
+
+
     
     bond_segments <- reactive({
         ## g <- get_network_from_table2(agg(), input$cutoff)
@@ -571,7 +674,7 @@
                             ## ## colors = scico(n_col, palette="hawai"),
                             ## mode = 'markers'
                             ) %>%
-                layout(  bargap=0.1)
+                layout(  bargap=0.1, xaxis = list(range=c(0,.5)))
             ## %>%
 ##                 layout(hovermode = "x unified",xaxis = list(title="",
 ##                                                    tickformat="%d %b"),