Merge pull request #53 from statnet/production

attribute histograms

Author: ebey

inst/shiny/global.R

@@ -27,10 +27,10 @@ inlineSelectInput <- function(inputId, label, choices, ...) {
   } else {
     labeldisp <- "display: inline;"
   }
-  
+
   tagList(tags$label(label, `for` = inputId, style = labeldisp),
-          tags$select(id = inputId, choices = choices, ..., 
-                      class = "shiny-bound-input inlineselect", 
+          tags$select(id = inputId, choices = choices, ...,
+                      class = "shiny-bound-input inlineselect",
                       lapply(choices, tags$option)))
 }
 
@@ -71,8 +71,8 @@ cugstats <- function(x, term, directed, loops) {
 }
 
 
-# Takes an ergm object and gathers some of the information from 
-# summary.ergm, in preparation to be passed to the function 
+# Takes an ergm object and gathers some of the information from
+# summary.ergm, in preparation to be passed to the function
 # coef.comparison.
 ergm.info <- function(object) {
   coefs <- object$coef
@@ -83,7 +83,7 @@ ergm.info <- function(object) {
                          cutpoints = c(0, 0.001, 0.01, 0.05, 0.1, 1),
                          symbols = c("***", "**", "*", ".", " "), legend = F)
   starredcoef <- paste0(format(coefs, digits = 3), signif.stars)
-  
+
   ans <- list()
   count <- 1
   for (i in terms) {
@@ -96,7 +96,7 @@ ergm.info <- function(object) {
 }
 
 
-# Takes in a list of multiple outputs from ergm.info, 
+# Takes in a list of multiple outputs from ergm.info,
 # formatting it all into a table comparing up to 5 models.
 coef.comparison <- function(coeflist) {
   nmod <- length(coeflist)
@@ -112,7 +112,7 @@ coef.comparison <- function(coeflist) {
   terms <- c(terms[-which(terms == "AIC")], "AIC")
   terms <- c(terms[-which(terms == "BIC")], "BIC")
   mat <- matrix(nrow = length(terms), ncol = nmod)
-  
+
   for (k in 1:nmod) {
     row <- 1
     for (l in terms) {
@@ -124,7 +124,7 @@ coef.comparison <- function(coeflist) {
       row <- row + 1
     }
   }
-  
+
   rownames(mat) <- terms
   colnames(mat) <- paste0("Model", 1:nmod)
   return(print(mat, quote = FALSE))
@@ -136,7 +136,7 @@ stat.comparison <- function(statlist) {
     stop("No model summaries were passed to stat.comparison")
   if (nmod > 5)
     stop("List of length greater than 5 passed to stat.comparison")
-  
+
   statvec <- c()
   for (j in 1:nmod) {
     for (k in 1:length(statlist[[j]])) {
@@ -145,6 +145,17 @@ stat.comparison <- function(statlist) {
       }
     }
   }
-  
+
   return(statvec)
 }
+
+hist.info <- function(x, breaks) {
+  out <- hist(x, breaks = breaks, plot = FALSE)
+  barname <- paste(out$breaks[1:2], collapse = "-")
+  for(i in seq(length(out$breaks) - 2)){
+    barname <- append(barname, paste(out$breaks[i+1]+1, out$breaks[i+2], sep = "-"))
+  }
+  out <- out$counts
+  names(out) <- barname
+  return(out)
+}

inst/shiny/server.R

@@ -512,7 +512,25 @@ numattr <- reactive({
           numattr <- append(numattr,attrib()[i])
         }
       }}
-    numattr})
+    numattr
+})
+
+#dataframe of nodes, their attributes, and their coordinates in nwplot
+nwdf <- reactive({
+  attrs <- menuattr()
+  if(is.na(as.numeric(network.vertex.names(nw()))[1])){
+    df <- data.frame(Names = network.vertex.names(nw()))
+  } else {
+    df <- data.frame(Names = as.numeric(network.vertex.names(nw())))
+  }
+  for(i in seq(length(attrs))){
+    df[[attrs[i]]] <- get.vertex.attribute(nw(), attrs[i])
+  }
+  df[["Missing"]] <- get.vertex.attribute(nw(), "na")
+  df[["cx"]] <- coords()[,1]
+  df[["cy"]] <- coords()[,2]
+  df
+})
 
 # betweenness centrality of all nodes (for sizing menu)
 nodebetw <- reactive({
@@ -1416,34 +1434,52 @@ output$nwplotdownload <- downloadHandler(
   }
   )
 
-#dataframe of nodes, their attributes, and their coordinates in nwplot
-nwdf <- reactive({
-  attrs <- menuattr()
-  if(is.na(as.numeric(network.vertex.names(nw()))[1])){
-    df <- data.frame(Names = network.vertex.names(nw()))
-  } else {
-    df <- data.frame(Names = as.numeric(network.vertex.names(nw())))
-  }
-  for(i in seq(length(attrs))){
-    df[[attrs[i]]] <- get.vertex.attribute(nw(), attrs[i])
-  }
-  df[["Missing"]] <- get.vertex.attribute(nw(), "na")
-  df[["cx"]] <- coords()[,1]
-  df[["cy"]] <- coords()[,2]
-  df
+output$attrcheck <- renderUI({
+  checkboxGroupInput("attrcols",
+                     label = "Include these attributes",
+                     choices = c(menuattr(), "Missing"),
+                     selected = c(menuattr(), "Missing"))
 })
+outputOptions(output, "attrcheck", suspendWhenHidden = FALSE)
 
 output$attrtbl <- renderDataTable({
-  df <- nwdf()
-  dt <- df[, c("Names", input$attribcols)]
+  dt <- nwdf()[, c("Names", input$attrcols)]
   dt
 }, options = list(pageLength = 10))
 
-output$attrcheck <- renderUI({
-  checkboxGroupInput("attribcols",
-                     label = "Include these attributes in the table",
-                     choices = c(menuattr(), "Missing"),
-                     selected = c(menuattr(), "Missing"))
+output$attrhist <- renderPlot({
+  nplots <- length(input$attrcols)
+  if(nplots == 0){return()}
+  attrname <- input$attrcols
+  if(nplots == 1){
+    par(mfrow = c(1, 1))
+    lvls <- length(unique(nwdf()[[attrname]]))
+    if(attrname %in% numattr() & lvls > 9){
+      tab <- hist.info(nwdf()[[attrname]], breaks = 10)
+    } else {
+      tab <- table(nwdf()[[attrname]])
+    }
+    barplot(tab, xlab = attrname, col = histblue)
+  } else {
+    r <- ceiling(nplots/2)
+    par(mfrow = c(r, 2))
+    for(a in attrname){
+      lvls <- length(unique(nwdf()[[a]]))
+      if(a %in% numattr() & lvls > 9){
+        tab <- hist.info(nwdf()[[a]], breaks = 10)
+      } else {
+        tab <- table(nwdf()[[a]])
+      }
+      barplot(tab, xlab = a, col = histblue)
+    }
+  }
+})
+
+output$attrhistplotspace <- renderUI({
+  nplots <- length(input$attrcols)
+  r <- ceiling(nplots/2)
+  h <- ifelse(r == 1, 400, r * 300)
+  plotOutput("attrhist", height = h)
 })
 
 #Data to use for null hypothesis overlays in network plots

inst/shiny/ui.R

@@ -501,7 +501,12 @@ fluidRow(
                            )
         ),
       tabPanel('Attributes', br(),
-              dataTableOutput("attrtbl")
+               conditionalPanel('input.attrview == "table"',
+                                dataTableOutput("attrtbl")
+                                ),
+               conditionalPanel('input.attrview == "histogram"',
+                                uiOutput("attrhistplotspace"))
+
                ),
       tabPanel('Degree Distribution',
                p(class='helper', id='ddhelper', icon('question-circle')),
@@ -745,6 +750,9 @@ fluidRow(
                    downloadButton('nwplotdownload',
                                   label = "Download Plot", class = "btn-sm")),
                 conditionalPanel(condition='input.plottabs == "Attributes"',
+                                 selectInput("attrview", label = "View attributes in:",
+                                             choices = c("table", "histogram")),
+                                 br(),
                                  uiOutput("attrcheck")
                 ),
                 conditionalPanel(condition='input.plottabs == "Degree Distribution"',

inst/shiny/www/alert.js

@@ -196,7 +196,7 @@ $(document).ready(function(){
     }
 
   });
-  
+
   $("#termdocbox").click(function(){
     $("#termexpand i").toggleClass("fa-angle-double-down fa-angle-double-up");
     if($("#termdocbox").height()<100){