Merge pull request #61 from statnet/production

updates from Production

Author: ebey

inst/shiny/global.R

@@ -149,13 +149,20 @@ 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 = "-"))
+attr.info <- function(df, colname, numattrs, breaks) {
+  lvls <- length(unique(df[[colname]]))
+  if(colname %in% numattrs & lvls > 9){
+    tab <- hist(df[[colname]], breaks = breaks, plot = FALSE)
+    barname <- paste(tab$breaks[1:2], collapse = "-")
+    for(i in seq(length(tab$breaks) - 2)){
+      barname <- append(barname, paste(tab$breaks[i+1]+1,
+                                       tab$breaks[i+2], sep = "-"))
+    }
+    tab <- tab$counts
+    names(tab) <- barname
+  } else {
+    tab <- table(df[[colname]])
   }
-  out <- out$counts
-  names(out) <- barname
-  return(out)
+  return(tab)
 }
+

inst/shiny/server.R

@@ -1441,11 +1441,33 @@ output$attrcheck <- renderUI({
 })
 outputOptions(output, "attrcheck", suspendWhenHidden = FALSE)
 
-output$attrtbl <- renderDataTable({
+output$attrtbl_lg <- renderDataTable({
   dt <- nwdf()[, c("Names", input$attrcols)]
   dt
 }, options = list(pageLength = 10))
 
+output$attrtbl_sm <- renderPrint({
+  ntbl <- length(input$attrcols)
+  if(ntbl == 0){return()}
+  attrname <- input$attrcols
+  tbl_list <- list()
+  if(ntbl == 1){
+    tab <- attr.info(df = nwdf(), colname = attrname,
+                     numattrs = numattr(), breaks = 10)
+    tbl_list[[attrname]] <- tab
+  } else {
+    for(a in attrname){
+      tab <- attr.info(df = nwdf(), colname = a,
+                       numattrs = numattr(), breaks = 10)
+      tbl_list[[a]] <- tab
+    }
+  }
+  for(a in attrname){
+    print(a, quote = FALSE)
+    print(tbl_list[[a]])
+  }
+})
+
 output$attrhist <- renderPlot({
   nplots <- length(input$attrcols)
   if(nplots == 0){return()}
@@ -1457,15 +1479,12 @@ output$attrhist <- renderPlot({
       plot(density(nwdf()[[attrname]]), main = attrname,
            col = "#076EC3", lwd = 2)
     } else {
-      if(attrname %in% numattr() & lvls > 9){
-        tab <- hist.info(nwdf()[[attrname]], breaks = 10)
-      } else {
-        tab <- table(nwdf()[[attrname]])
-      }
+      tab <- attr.info(df = nwdf(), colname = attrname,
+                       numattrs = numattr(), breaks = 10)
       if(input$attrhistaxis == "percent"){
         tab <- tab/sum(tab)
       }
-      barplot(tab, xlab = attrname, col = histblue)
+      barplot(tab, main = attrname, col = histblue)
     }
   } else {
     r <- ceiling(nplots/2)
@@ -1475,15 +1494,12 @@ output$attrhist <- renderPlot({
       if(input$attrhistaxis == "density" & a %in% numattr() & lvls > 9){
         plot(density(nwdf()[[a]]), main = a, col = "#076EC3", lwd = 2)
       } else {
-        if(a %in% numattr() & lvls > 9){
-        tab <- hist.info(nwdf()[[a]], breaks = 10)
-      } else {
-        tab <- table(nwdf()[[a]])
-      }
-      if(input$attrhistaxis == "percent"){
-        tab <- tab/sum(tab)
-      }
-      barplot(tab, xlab = a, col = histblue)
+        tab <- attr.info(df = nwdf(), colname = a,
+                         numattrs = numattr(), breaks = 10)
+        if(input$attrhistaxis == "percent"){
+          tab <- tab/sum(tab)
+        }
+        barplot(tab, main = a, col = histblue)
       }
     }
   }
@@ -2934,15 +2950,19 @@ output$listofterms <- renderUI({
                  choices = c("Select a term" = "", current.terms))
 })
 
-output$termdoc <- renderPrint({
+output$termdoc <- renderUI({
   myterm <- input$chooseterm
   if(is.null(myterm)){
-    return(cat("Select or search for a term in the menu above."))
-  }
-  if(myterm == ""){
-    return(cat("Select or search for a term in the menu above."))
-  }
-  search.ergmTerms(name=myterm)
+    return(p("Select or search for a term in the menu above."))
+  } else if(myterm == ""){
+    return(p("Select or search for a term in the menu above."))
+  }
+  chrvec <- capture.output(search.ergmTerms(name = myterm))
+  desc <- strsplit(chrvec[3], split = "_")
+  p(chrvec[1], br(),br(),
+    strong(chrvec[2]), br(),br(),
+    em(desc[[1]][2]), desc[[1]][3], br(),
+    chrvec[4])
 })
 
 observe({

inst/shiny/ui.R

@@ -501,10 +501,13 @@ fluidRow(
                            )
         ),
       tabPanel('Attributes', br(),
-               conditionalPanel('input.attrview == "table"',
-                                dataTableOutput("attrtbl")
+               conditionalPanel('input.attrview == "Large table"',
+                                dataTableOutput("attrtbl_lg")
                                 ),
-               conditionalPanel('input.attrview == "histogram"',
+               conditionalPanel('input.attrview == "Small tables"',
+                                verbatimTextOutput("attrtbl_sm")
+                                ),
+               conditionalPanel('input.attrview == "Plot summaries"',
                                 tags$label("Type of plots"),
                                 helpText("Density plots will only be created for",
                                          "numeric attributes with more than nine",
@@ -760,7 +763,9 @@ fluidRow(
                                   label = "Download Plot", class = "btn-sm")),
                 conditionalPanel(condition='input.plottabs == "Attributes"',
                                  selectInput("attrview", label = "View attributes in:",
-                                             choices = c("table", "histogram")),
+                                             choices = c("Large table",
+                                                         "Small tables",
+                                                         "Plot summaries")),
                                  br(),
                                  uiOutput("attrcheck")
                 ),
@@ -899,7 +904,7 @@ actionLink('plotright', icon=icon('arrow-right', class='fa-2x'), label=NULL)
                       fluidRow(
                         column(12,
                                a("Commonly used ergm terms",
-                                 href = "http://statnet.csde.washington.edu/EpiModel/nme/d2-ergmterms.html",
+                                 href = "http://statnet.github.io/nme/ergmterms.html",
                                  target = "_blank"), br(),
                                a("Term cross-reference tables",
                                  href = "http://cran.r-project.org/web/packages/ergm/vignettes/ergm-term-crossRef.html",
@@ -916,7 +921,7 @@ actionLink('plotright', icon=icon('arrow-right', class='fa-2x'), label=NULL)
                       fluidRow(
                         column(12,
                                div(id="termdocbox",
-                                    verbatimTextOutput("termdoc")
+                                    uiOutput("termdoc")
                                 ),
                                 div(id = "termexpand",
                                     icon(name = "angle-double-up"))
@@ -931,12 +936,13 @@ actionLink('plotright', icon=icon('arrow-right', class='fa-2x'), label=NULL)
                     fluidRow(class = "shiftright",
                       column(3, style = "padding-left: 0;",
                         inlineSelectInput('controltype',label = NULL,
-                                          choices = c("MCMC","MCMLE"),
+                                          choices = c("MCMC"),
                                           style="margin:10px 0px;")),
                       column(5,
                         checkboxInput('controldefault', 'Use default options', value = TRUE))
                     ),
-                        conditionalPanel(condition = "input.controltype == 'MCMC'", class = "shiftright",
+                        conditionalPanel(condition = "input.controltype == 'MCMC'",
+                                         class = "shiftright gray", id = "mcmcopt1",
                           fluidRow(
                             column(4,
                                    span("Interval:"),
@@ -1179,7 +1185,8 @@ tabPanel(title='Simulations', value='tab7',
                              column(7,
                                     checkboxInput('simcontroldefault','Use default options', value=TRUE))
                            ),
-                           conditionalPanel(condition="input.simcontroltype == 'MCMC'", class="shiftright",
+                           conditionalPanel(condition="input.simcontroltype == 'MCMC'",
+                                            class="shiftright gray", id = "mcmcopt2",
                              fluidRow(
                                     column(5,
                                         span("Interval:"),

inst/shiny/www/alert.js

@@ -221,6 +221,13 @@ $(document).ready(function(){
     $("#mcmchelpbox").toggle(500);
   });
 
+  $("#controldefault").click(function(){
+    $("#mcmcopt1").toggleClass("gray");
+  })
+    $("#simcontroldefault").click(function(){
+    $("#mcmcopt2").toggleClass("gray");
+  })
+
 });
 
 

inst/shiny/www/style.css

@@ -309,8 +309,8 @@ div .mcmcopt {
 }
 
 .inlineselect {
-  width:100px; 
-  line-height:20px; 
+  width:100px;
+  line-height:20px;
   font-size:12px;
 }
 
@@ -341,6 +341,7 @@ div.placeholder {
 #termdoc {
   background:#FFFFFF;
   border:none;
+  padding:10px;
 }
 #termdocbox {
   position:absolute;
@@ -440,13 +441,16 @@ div.placeholder {
   background-color: #054D88;
   border-color: #02213A;
 }
+.gray {
+  opacity: .5;
+}
 .form-control[disabled],
 .form-control[readonly],
 fieldset[disabled] .form-control,
 input[disabled] {
   cursor: not-allowed;
   background-color: #e6e6e6;
-  opacity: 1;
+  opacity: .5;
 }
 .navbar-default {
   background-color: #3A3A3A;