Untitled2.R
In knrg07/NobleNetworks:
# if(!require(shiny)) install.packages("shiny", repos = "http://cran.us.r-project.org")
# if(!require(shinythemes)) install.packages("shinythemes", repos = "http://cran.us.r-project.org")
# if(!require(dplyr)) install.packages("dplyr", repos = "http://cran.us.r-project.org")
# if(!require(sna)) install.packages("sna", repos = "http://cran.us.r-project.org")
# if(!require(igraph)) install.packages("igraph", repos = "http://cran.us.r-project.org")
# if(!require(visNetwork)) install.packages("visNetwork", repos = "http://cran.us.r-project.org")
# if(!require(shinyWidgets)) install.packages("shinyWidgets", repos = "http://cran.us.r-project.org")
# if(!require(devtools)) install.packages("devtools", repos = "http://cran.us.r-project.org")
# if(!require(NobleDynamic)) devtools::install_github('knrg07/NobleDynamic')
# if(!require(networkDynamic)) install.packages("networkDynamic", repos = "http://cran.us.r-project.org")
# if(!require(ggplot2)) install.packages("ggplot2", repos = "http://cran.us.r-project.org")
# if(!require(ggiraph)) install.packages("ggiraph", repos = "http://cran.us.r-project.org")
# if(!require(leaflet)) install.packages("leaflet", repos = "http://cran.us.r-project.org")
library(shiny)
library(shinythemes)
library(dplyr)
library(sna)
library(igraph)
library(visNetwork)
library(shinyWidgets)
library(networkDynamic)
library(ggplot2)
library(ggiraph)
library(leaflet)
library(packcircles)
library(viridis)
library(scales)
library(dygraphs)
library(xts)
load('/Users/karlanohemi/Desktop/PROJECTS/R PACKAGES/NobleDynamic/data/rawData.rda')
load('/Users/karlanohemi/Desktop/PROJECTS/R PACKAGES/NobleDynamic/data/gantt.rda')
gantt <- gantt_data
don=xts( x=gantt[,-1], order.by=gantt$wk_date)
#don <- don
### IMPORT DATA ONLY ONE TIME
# data(rawData)
x <- as.data.frame(rawContacts)
vhf <- as.data.frame(vhf)
ok_base <- leaflet() %>% addProviderTiles(providers$Stamen.Toner) %>% setView(-97.14, 33.93, zoom = 10)
gantt <- gantt
## RUN 3 UNIQUE FUNCTIONS BEFOREHAND FOR QUICKER HANDLING
# FUNCTION 1 FOR SUBSETTING BASED ON DATES & SPATIAL-TEMPORAL DEFINITION INPUTS
subset_view <- function(data, start, end, distance, time){
df <- data %>% filter(week_date >= start & week_date <= end & TIME_min <= time & distEuclid <= distance )
return(df)}
# FUNCTION 2: SUBSEQUENT NODE DERIVATION
create_nodes <- function(data){
no1b <- as.data.frame(table(data$KID_ref))
no2b <- as.data.frame(table(data$KID_par))
nodes <- full_join(no1b, no2b, by = "Var1")
nodes <- as.data.frame(nodes[,1])
colnames(nodes) <- 'KID'
nodes$group <- gsub('[0-9]', '', nodes$KID)
nodes$group[(nodes$group == "c")] <- "Cattle"
nodes$group[(nodes$group == "p")] <- "Pigs"
nodes$group[(nodes$group == "d")] <- "Deer"
nodes <- merge(nodes, vhf, by = 'KID', all.x = T)
nodes <- subset(nodes, select = c(KID, group, vertex.id))
colnames(nodes) <- c('id', 'group', 'vertex.id')
nodes$vertex.id <- as.integer(nodes$vertex.id)
nodes$color <- ifelse(nodes$group == 'Cattle', '#458B00', ifelse(nodes$group == 'Pigs', '#FF6347', '#996633'))
nodes <- as.data.frame(nodes)
return(nodes)}
# FUNCTION 3: SUBSEQUENT EDGE DERIVATION
create_edges <- function(data){
edges <- subset(data, select = c(KID_ref, KID_par, value))
edges <- aggregate(edges$value, by = list(edges$KID_ref, edges$KID_par), FUN = sum)
colnames(edges) <- c('from', 'to', 'value')
edges <- as.data.frame(edges)
edges$value <- as.integer(edges$value)
edges$color <- '#CCCCCC'
return(edges)}
# customization for descriptive plots
tooltip_css <- "background-opacity:0;font-size: 150%;font-style:strong;padding:10px;border-radius:10px 20px 10px 20px;"
# TESTING FUNCTIONS BELOW
# test <- subset_view(x, '2018-04-01', '2018-04-14', 10, 10)
# nodes <- create_nodes(test)
# edges<- create_edges(test)
ui <- bootstrapPage(
navbarPage(theme = shinytheme('darkly'),
collapsible = T, title = 'Noble Networks', id = 'nav',
navbarMenu(title = 'Static Networks',
tabPanel('Static Graph', style = 'background-color:#005493',
div(class='outer', align = 'right',
tags$head(includeCSS('style/main.css')),
visNetworkOutput("networkPlot",height = "100%", width = '100%'),
absolutePanel(id = 'controls', class = 'panel panel-default',
top = 75, left = 10, width = 250, fixed = T,
draggable = T, height = '100%', style = 'color:black',
span(tags$i(h6('Short date intervals are recommended for static descriptives. See the Dynamic Network tab for time-series networks.'), align = 'left'), style = 'color:#941100'),
span(tags$strong(h4('Current Static View:'), align = 'left')),
h3(textOutput('tot_anim'), align = 'left'),
span(h4(textOutput('tot_cow'), align = 'right'), style = 'color:#458B00'),
span(h4(textOutput('tot_pig'), align = 'right'), style = 'color:#FF6347'),
span(h4(textOutput('tot_deer'), align = 'right'), style = 'color:#996633'),
tags$hr(),
span(tags$strong(h4('Modify Definitions:'), align = 'left')),
setSliderColor(c('#8A2252', '#00B3A3'), c(1,2)),
sliderInput('time_window', label = "Temporal Window (MINUTES):", value = 10, min = 1, max = 30),
sliderInput('distance_window', label = "Spatial Window (METERS):", value = 10, min = 1, max = 30),
tags$hr(),
tags$hr(),
dateRangeInput('date_range', label = 'Modify Date Range View:', start = '2018-04-01', end = '2018-04-14', min = '2017-08-20', max = '2020-05-03', format = 'yyyy-mm-dd', separator = '-', weekstart = 7, startview = 'month'),
actionButton('Update_Click', label = 'Update Network'))),
absolutePanel(id = 'controls', class = 'panel panel-default',
bottom = 5, right = 10, width = 225, fixed = F,
draggable = T, height = '25%', style = 'color:black',
h4('Graph Averages:', align = 'left'),
span(tags$strong(h5(textOutput('avg_deg'), align = 'left'), style = 'color:#00B3A3')),
span(tags$strong(h5(textOutput('avg_diam'), align = 'left'), style = 'color:#00B3A3')),
span(tags$strong(h5(textOutput('avg_assort'), align = 'left'), style = 'color:#6B8D23')),
span(tags$strong(h5(textOutput('avg_bet'), align = 'left'), style = 'color:#1A80B3')),
span(tags$strong(h5(textOutput('avg_clos'), align = 'left'), style = 'color:#777788')))
# girafeOutput('Prop_bubbles'))
),
tabPanel(title = 'Centrality Measures', style = 'background-color:#005493',
div(class='outer', align = 'right', tags$head(includeCSS('style/main.css')),
sidebarLayout(
sidebarPanel(
htmlOutput('in_view')
),
mainPanel(
tabsetPanel(
tabPanel('Degree', girafeOutput('deg_Plt')),
tabPanel('Assortivity', girafeOutput('assort_Plt')),
tabPanel('Betweenness', girafeOutput('bet_Plt')),
tabPanel('Closeness', girafeOutput('clos_Plt'))
))))),
tabPanel(title = 'Communities', style = 'background-color:#005493',
div(class='outer', align = 'right',
tags$head(includeCSS('style/main.css')),
sidebarLayout(
sidebarPanel(h3('TBD', align = 'left'),
radioButtons(inputId="PlotLayout", label="Plot Layout", choices=c("Auto","Random","Fruchterman Reingold","Kamada Kawai"), selected="Fruchterman Reingold")),
mainPanel(
tabsetPanel(
tabPanel('TBD', plotOutput("graphPlot")),
tabPanel('TBD'))))))),
navbarMenu(title = 'Dynamic Networks',
tabPanel('TBD', style = 'background-color:#005493',
div(class = 'outer', align = 'right',
tags$head(includeCSS('style/main.css')),
sidebarPanel(
h4('Something on the Left Panel'),
h5('MORE on the Left Panel')
),
mainPanel(
tabsetPanel(
tabPanel('TBD'),
tabPanel('TBD'))))),
tabPanel('TBD', style = 'background-color:#005493',
div(class = 'outer', align = 'right',
tags$head(includeCSS('style/main.css')),
sidebarPanel(
h4('More on the Left Panel'),
h4('AND MORE on the Left Panel')),
mainPanel(
tabsetPanel(
tabPanel('TBD'),
tabPanel('TBD')))))),
tabPanel('Study Area Map', style = 'background-color:#005493',
div(class='outer', align = 'right',
tags$head(includeCSS('style/main.css')),
leafletOutput("ok_map", height = "100%", width = '100%'),
absolutePanel(id = 'controls', class = 'panel panel-default',
top = 75, left = 10, width = 250, fixed = T,
draggable = T, height = '100%', style = 'color:black',
),
absolutePanel(id = 'controls', class = 'panel panel-default',
top = 75, right = 10, width = 250, fixed = T,
draggable = T, height = '32%', style = 'color:black',
span(tags$strong(h4(textOutput('tot_inter'),align = 'left'))),
tags$hr(),
span(h5(textOutput('cow_cow'),align = 'right'), style = 'color:#458B00'),
span(h5(textOutput('pig_pig'),align = 'right'), style = 'color:#FF6347'),
span(h5(textOutput('deer_deer'),align = 'right'), style = 'color:#996633'),
span(h5(textOutput('cow_pig'),align = 'right'), style = 'color:#333333'),
span(h5(textOutput('cow_deer'),align = 'right'), style = 'color:#333333'),
span(h5(textOutput('pig_deer'),align = 'right'), style = 'color:#333333'))
)),
tabPanel('Data Overview',
fluidRow(
box(
dygraphOutput('gantt', width = "100%", height = "400px"), width = 9 ),
box(textOutput('legendDivID'), title = 'Active:', collapsible = F, width = 3)
)
)
))
server <- function(input, output) {
makeReactiveBinding('newData')
makeReactiveBinding('nodes')
makeReactiveBinding('edges')
makeReactiveBinding('deg')
makeReactiveBinding('props')
newData <- reactive({
input$Update_Click
isolate({subset_view(x, input$date_range[1], input$date_range[2], input$distance_window, input$time_window)})
})
edges <- reactive({
input$Update_Click
isolate({
data <- newData()
edges <- create_edges(data)})})
nodes <- reactive({
input$Update_Click
isolate({
data <- newData()
nodes <- create_nodes(data)})})
realTimeGraph <- reactive({
nodes <- nodes()
edges <- edges()
g <- graph_from_data_frame(d = edges, vertices = nodes, directed = F)
})
plotGraph <- function(){
g <- realTimeGraph()
plotlayout <- switch(input$PlotLayout,
"Auto"=layout.auto(g),
"Random"=layout.random(g),
"Fruchterman Reingold"=layout.fruchterman.reingold(g),
"Kamada Kawai"=layout.kamada.kawai(g))
V(g)$size = deg()*1.3
V(g)$label <- ''
clp <- cluster_optimal(g)
par(bg = '#333333')
plot(clp, g)
}
output$graphPlot <- renderPlot({suppressWarnings(plotGraph())})
deg <- reactive({
input$Update_Click
isolate({
edges <- edges()
nodes <- nodes()
net <- graph_from_data_frame(d = edges, vertices = nodes, directed = F)
deg <- degree(net, mode = 'all')})
return(deg*1.3)})
#graph_stats <- reactive({
# input$Update_Click
# isolate({
# edges <- edges()
# nodes <- nodes()
# net <- graph_from_data_frame(d = edges, vertices = nodes, directed = F)
# diam_all <- diameter(net)
# dens_all <- igraph::graph.density(net)
# cent_all <- centr_degree(net, mode = 'all', loops = F)
# degr_all <- cent_all$centralization
# mean_dist_all <- mean_distance(net)
# assort_all <- assortativity_degree(net, directed = F)
# sub_cow <- subgraph(net, v = V(net)[group == 'Cattle'])
# sub_pig <- subgraph(net, v = V(net)[group == 'Pigs'])
# sub_deer <- subgraph(net, v = V(net)[group == 'Deer'])
# diam_cow <- diameter(sub_cow)
# dens_cow <- igraph::graph.density(sub_cow)
# cent_cow <- centr_degree(sub_cow, mode = 'all', loops = F)
# degr_cow <- cent_cow$centralization
# mean_dist_cow <- mean_distance(sub_cow)
# assort_cow <- assortativity_degree(sub_cow, directed = F)
# diam_pig <- diameter(sub_pig)
# dens_pig <- igraph::graph.density(sub_pig)
# cent_pig <- centr_degree(sub_pig, mode = 'all', loops = F)
# degr_pig <- cent_pig$centralization
# mean_dist_pig <- mean_distance(sub_pig)
# assort_pig <- assortativity_degree(sub_pig, directed = F)
# diam_deer <- diameter(sub_deer)
# dens_deer <- igraph::graph.density(sub_deer)
# cent_deer <- centr_degree(sub_deer, mode = 'all', loops = F)
# degr_deer <- cent_deer$centralization
# mean_dist_deer <- mean_distance(sub_deer)
# assort_deer <- assortativity_degree(sub_deer, directed = F)
# diam <- rbind(10, -1, diam_all, diam_cow, diam_deer, diam_pig)
# dens <- rbind(10, -1, dens_all, dens_cow, dens_deer, dens_pig)
# degr <- rbind(10, -1, degr_all, degr_cow, degr_deer, degr_pig)
# assort <- rbind(10, -1, assort_all, assort_cow, assort_deer, assort_pig)
# mean_dist <- rbind(10, -1, mean_dist_all, mean_dist_cow, mean_dist_deer, mean_dist_pig)
# graph_lev <- data.frame(Diameter = diam, Density = dens, Degree = degr, Mean_Distance = mean_dist, Asssortivity = assort)
# as.data.frame(graph_lev)
# })
# return(graph_lev)})
vertex_stats <- reactive({
input$Update_Click
isolate({
edges <- edges()
nodes <- nodes()
net <- graph_from_data_frame(d = edges, vertices = nodes, directed = F)
nodes$degree <- degree(net, mode = 'all')
nodes$assort <- assortativity(net, directed = F)
nodes$between <- betweenness(net, v = V(net), directed = F)
nodes$closeness <- closeness(net, v = V(net), mode = 'all')
eigen <- eigen_centrality(net, directed = F)
nodes$eigen <- eigen$vector
nodes$count <- 1
as.data.frame(nodes)})
return(nodes)})
output$deg_Plt <- renderGirafe({
input$Update_Click
isolate({
df <- vertex_stats()
gg_point <- ggplot(df, aes(x = as.factor(group), y = degree, tooltip = group, data_id = group, colour = group)) + geom_boxplot_interactive(fill = c('#458B00','#996633', '#FF6347')) + theme_dark() + ylab("Vertex Degree Scores")+ xlab("Species") + scale_color_manual(values= c('#458B00','#996633', '#FF6347')) + theme(panel.background = element_blank(), panel.border = element_blank(), legend.position = "none", plot.background = element_rect(fill = "#333333"),axis.title.x = element_text(colour = "white"), axis.title.y = element_text(colour = "white") ,axis.text.x = element_text(colour = "white"), axis.text.y = element_text(colour = "#00B3A3")) + ylim(0, max(df$degree))
girafe(ggobj = gg_point, options = list(opts_selection(type = 'single', only_shiny = F)))
})})
output$bet_Plt <- renderGirafe({
input$Update_Click
isolate({
df <- vertex_stats()
gg_point <- ggplot(df, aes(x = as.factor(group), y = between, tooltip = group, data_id = group, colour = group)) + geom_boxplot_interactive(fill = c('#458B00','#996633', '#FF6347')) + theme_dark() + ylab("Vertex Betweenness Scores")+ xlab("Species") + scale_color_manual(values= c('#458B00','#996633', '#FF6347')) + theme(panel.background = element_blank(), panel.border = element_blank(), legend.position = "none", plot.background = element_rect(fill = "#333333"),axis.title.x = element_text(colour = "white"), axis.title.y = element_text(colour = "white"),axis.text.x = element_text(colour = "white"), axis.text.y = element_text(colour = "#1A80B3")) + ylim(0, max(df$between))
girafe(ggobj = gg_point, options = list(opts_selection(type = 'single', only_shiny = F)))})})
output$assort_Plt <- renderGirafe({
input$Update_Click
isolate({
df <- vertex_stats()
gg_point <- ggplot(df, aes(x = as.factor(group), y = assort, tooltip = group, data_id = group, colour = group)) + geom_boxplot_interactive(fill = c('#458B00','#996633', '#FF6347')) + theme_dark() + ylab("Vertex Assortivity Degree")+ xlab("Species") + scale_color_manual(values= c('#458B00','#996633', '#FF6347')) + theme(panel.background = element_blank(), panel.border = element_blank(), legend.position = "none", plot.background = element_rect(fill = "#333333"),axis.title.x = element_text(colour = "white"), axis.title.y = element_text(colour = "white"),axis.text.x = element_text(colour = "white"), axis.text.y = element_text(colour = "#6B8D23")) + ylim(0, max(df$assort))
girafe(ggobj = gg_point, options = list(opts_selection(type = 'single', only_shiny = F)))})})
output$clos_Plt <- renderGirafe({
input$Update_Click
isolate({
df <- vertex_stats()
gg_point <- ggplot(df, aes(x = as.factor(group), y = closeness, tooltip = group, data_id = group, colour = group)) + geom_boxplot_interactive(fill = c('#458B00','#996633', '#FF6347')) + theme_dark() + ylab("Vertex Closeness Values")+ xlab("Species") + scale_colour_manual(values= c('#458B00','#996633', '#FF6347')) + theme(panel.background = element_blank(), panel.border = element_blank(), legend.position = "none", plot.background = element_rect(fill = "#333333"), axis.title.x = element_text(colour = "white"), axis.title.y = element_text(colour = "white"),axis.text.x = element_text(colour = "white"), axis.text.y = element_text(colour = "#777788")) + ylim(0, max(df$closeness))
girafe(ggobj = gg_point, options = list(opts_selection(type = 'single', only_shiny = T)), opts_tooltip(use_fill = F))})})
# output$Prop_bubbles <- renderGirafe({
# input$Update_Click
# isolate({
# sub <- newData()
# sub <- aggregate(sub$value, by = list(sub$SPECIES_PAIRS), FUN = sum)
# colnames(sub) <- c('group', 'value')
# pack <- circleProgressiveLayout(sub$value, sizetype = 'area')
# sub <- cbind(sub, pack)
# sub$prop <- c(sub$value)/sum(sub$value)
# sub$prop <- label_percent()(sub$prop)
# sub$text <- paste("Interaction Type: ",sub$group, "\n", "Percentage:", sub$prop)
# dat.gg <- circleLayoutVertices(pack, npoints=50)
# p <-ggplot() + geom_polygon_interactive(data = dat.gg, aes(x, y, group = id, fill=id, tooltip = sub$text[id], data_id = id), colour = "black", alpha = 0.6) + scale_fill_viridis() + geom_text(data = sub, aes(x, y, label = group), size=2, color="black") + theme_void() + theme(legend.position="none", plot.margin=unit(c(0,0,0,0),"cm") ) + coord_equal()
# girafe(ggobj = p, options = list(opts_selection(type = 'single', only_shiny = T)), opts_tooltip(use_fill = F))
# })
# })
props <- reactive({
input$Update_Click
isolate({
ss <- newData()
ss <- aggregate(ss$value, by = list(ss$SPECIES_PAIRS), FUN = sum)
colnames(ss) <- c('Type', 'value')
ss$Proportion <- c(ss$value)/sum(ss$value)
ss$Proportion <- label_percent()(ss$Proportion)
as.data.frame(ss)})
return(ss)})
output$cow_cow <- renderText({
ss <- props()
ss <- ss[which(ss$Type == 'Cattle-Cattle'),]
if(nrow(ss) == 0){
return(print('Cattle-Cattle: 0.0%'))
}else{
paste('Cattle-Cattle:', prettyNum(props()$Proportion[(props()$Type == 'Cattle-Cattle')]))}})
output$pig_pig <- renderText({
ss <- props()
ss <- ss[which(ss$Type == 'Pig-Pig'),]
if(nrow(ss) == 0){
return(print('Pig-Pig: 0.0%'))
}else{
paste('Pig-Pig:', prettyNum(props()$Proportion[(props()$Type == 'Pig-Pig')]))}})
output$deer_deer <- renderText({
ss <- props()
ss <- ss[which(ss$Type == 'Deer-Deer'),]
if(nrow(ss) == 0){
return(print('Deer-Deer: 0.0%'))
}else{
paste('Deer-Deer:', prettyNum(props()$Proportion[(props()$Type == 'Deer-Deer')]))}})
output$cow_pig <- renderText({
ss <- props()
ss <- ss[which(ss$Type == 'Cattle-Pig'),]
if(nrow(ss) == 0){
return(print('Cattle-Pig: 0.0%'))
}else{
paste('Cattle-Pig:', prettyNum(props()$Proportion[(props()$Type == 'Cattle-Pig')]))}})
output$cow_deer <- renderText({
ss <- props()
ss <- ss[which(ss$Type == 'Cattle-Deer'),]
if(nrow(ss) == 0){
return(print('Cattle-Deer: 0.0%'))
}else{
paste('Cattle-Deer:', prettyNum(props()$Proportion[(props()$Type == 'Cattle-Deer')]))}})
output$pig_deer <- renderText({
ss <- props()
ss <- ss[which(ss$Type == 'Pig-Deer'),]
if(nrow(ss) == 0){
return(print('Pig-Deer: 0.0%'))
}else{
paste('Pig-Deer:', prettyNum(props()$Proportion[(props()$Type == 'Pig-Deer')]))}})
output$tot_anim <- renderText({
paste0(prettyNum(nrow(vertex_stats()), big.mark = ','), ' Total Animals')})
output$tot_cow <- renderText({
paste0(prettyNum(sum(vertex_stats()$count[(vertex_stats()$group == 'Cattle')]), big.mark = ','), ' Cattle')})
output$tot_pig <- renderText({
paste0(prettyNum(sum(vertex_stats()$count[(vertex_stats()$group == 'Pigs')]), big.mark = ','), ' Pigs')})
output$tot_deer <- renderText({
paste0(prettyNum(sum(vertex_stats()$count[(vertex_stats()$group == 'Deer')]), big.mark = ','), ' Deer')})
output$tot_inter <- renderText({
paste0(prettyNum(nrow(newData()), big.mark = ','), ' Total Interactions')})
output$avg_deg <- renderText({
paste0('Degree: ', prettyNum(mean(vertex_stats()$degree), digits = 3))})
output$avg_assort <- renderText({
paste0('Assortitive Value: ', prettyNum(mean(vertex_stats()$assort), digits = 3))})
output$avg_bet <- renderText({
paste0('Betweenness: ', prettyNum(mean(vertex_stats()$between), digits = 3))})
output$avg_clos <- renderText({
paste0('Closeness: ', prettyNum(mean(vertex_stats()$closeness), digits = 3))})
output$ok_map <- renderLeaflet({ok_base})
output$networkPlot <- renderVisNetwork({
edges <- edges()
nodes <- nodes()
nodes$size <- deg()
#output$in_view <- renderText({
# paste0("Plots in view are for current static definition of a ", input$distance_window, " meter Spatial Window and a ", input$time_window, ' minute Temporal Window. More specifically, for date views between ', input$date_range[1], ' and ', input$date_range[2], '.')})
output$in_view <- renderUI({
line1 <- paste0("Plots in view are for a <b style = color:#CCCC33;>", input$distance_window, " meter </b> Spatial Window and <b style = color:#CCCC33;>", input$time_window, " minute</b> Temporal Window definition.")
line2 <- paste0("<br/> More specifically, for date between <b style = color:#CCCC33;>", input$date_range[1], "</b> and <b style = color:#CCCC33;>", input$date_range[2], "</b>.")
HTML(paste(line1, line2, sep = '<br/>'))
})
output$gantt <- renderDygraph({withProgress(message = "Loading...", {
dygraph(don, main = 'Animal Observations by Week') %>% dyLegend(show = 'onmouseover', hideOnMouseOut = T, labelsDiv = "legendDivID") %>% dyGroup(c('c01', 'c02', 'c03', 'c04', 'c05', 'c06', 'c07', 'c08', 'c09', 'c10', 'c11', 'c12', 'c13', 'c14', 'c15', 'c16', 'c17', 'c18', 'c19', 'c20', 'c21', 'c22', 'c23', 'c24', 'c25', 'c28', 'c29', 'c30', 'c32', 'c33', 'c34', 'c35', 'c36', 'c37', 'c38', 'c39', 'c40', 'c41', 'c42'), color = c('#458B00','#458B00','#458B00','#458B00','#458B00','#458B00','#458B00','#458B00','#458B00','#458B00', '#458B00','#458B00','#458B00','#458B00','#458B00','#458B00','#458B00','#458B00','#458B00','#458B00', '#458B00','#458B00','#458B00','#458B00','#458B00','#458B00','#458B00','#458B00','#458B00','#458B00', '#458B00','#458B00','#458B00','#458B00','#458B00','#458B00','#458B00','#458B00','#458B00')) %>% dyGroup(c('p02', 'p04', 'p07', 'p08', 'p10', 'p11', 'p12', 'p14', 'p15', 'p16', 'p18', 'p20', 'p21', 'p22', 'p24', 'p25', 'p27', 'p28', 'p30', 'p32', 'p33', 'p35', 'p36', 'p38', 'p40', 'p41', 'p44', 'p45', 'p46', 'p47', 'p48', 'p49', 'p50', 'p51', 'p52', 'p53', 'p55', 'p56', 'p57', 'p58', 'p59', 'p60', 'p61', 'p62', 'p64', 'p65', 'p67', 'p68'), color = c('#FF6347','#FF6347','#FF6347','#FF6347','#FF6347','#FF6347','#FF6347','#FF6347','#FF6347','#FF6347', '#FF6347','#FF6347','#FF6347','#FF6347','#FF6347','#FF6347','#FF6347','#FF6347','#FF6347','#FF6347', '#FF6347','#FF6347','#FF6347','#FF6347','#FF6347','#FF6347','#FF6347','#FF6347','#FF6347','#FF6347', '#FF6347','#FF6347','#FF6347','#FF6347','#FF6347','#FF6347','#FF6347','#FF6347','#FF6347','#FF6347', '#FF6347','#FF6347','#FF6347','#FF6347','#FF6347','#FF6347','#FF6347','#FF6347')) %>% dyGroup(c('d01', 'd02', 'd03', 'd04', 'd05', 'd06', 'd07', 'd09', 'd10', 'd11', 'd12', 'd13', 'd14', 'd15', 'd16', 'd17', 'd18', 'd19', 'd20', 'd21', 'd22', 'd23', 'd24', 'd25', 'd26', 'd27', 'd28', 'd29', 'd30'), color = c('#996633','#996633','#996633','#996633','#996633','#996633','#996633','#996633','#996633','#996633','#996633','#996633','#996633','#996633','#996633','#996633','#996633','#996633','#996633','#996633','#996633','#996633','#996633','#996633','#996633','#996633','#996633','#996633','#996633')) %>% dyAxis('x', axisLabelColor = 'white')%>% dyAxis('y', axisLabelColor = 'white', valueFormatter = paste0('function(y){return "";}') )%>% dyCSS("style/legend.css") %>% dyAxis('y2', valueFormatter = paste0('function(x){ var KIDS = [',paste(paste0("'", names(don),"'"),collapse=','),']; return KIDS[x - 1]; }') ) %>% dyRangeSelector(fillColor = " #8A2252", strokeColor = "#8A2252", retainDateWindow = T)
})
})
# expr, env = parent.frame(), quoted = FALSE)
visNetwork(nodes, edges, width = '750px', height = "100%", background = '#222222') %>% visGroups(groupname = 'Pigs', color = '#FF6347', shadow = list(enabled = T)) %>% visGroups(groupname = 'Cattle', color = '#458B00', shadow = list(enabled = T)) %>% visGroups(groupname = 'Deer', color = '#CD9B1D', shadow = list(enabled = T)) %>% visInteraction(hover = T) %>% visOptions(selectedBy = list(variable = "group", style = 'width: 150px; height: 22px; background: white; color: #999933; border:none; outline:none;'), highlightNearest = T, collapse = F) %>% visInteraction(keyboard = TRUE, dragNodes = T, dragView = T, zoomView = T) # %>% visIgraphLayout()
})}
shinyApp(ui = ui, server = server)
knrg07/NobleNetworks documentation built on July 23, 2020, 12:35 a.m.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
# if(!require(shiny)) install.packages("shiny", repos = "http://cran.us.r-project.org")
# if(!require(shinythemes)) install.packages("shinythemes", repos = "http://cran.us.r-project.org")
# if(!require(dplyr)) install.packages("dplyr", repos = "http://cran.us.r-project.org")
# if(!require(sna)) install.packages("sna", repos = "http://cran.us.r-project.org")
# if(!require(igraph)) install.packages("igraph", repos = "http://cran.us.r-project.org")
# if(!require(visNetwork)) install.packages("visNetwork", repos = "http://cran.us.r-project.org")
# if(!require(shinyWidgets)) install.packages("shinyWidgets", repos = "http://cran.us.r-project.org")
# if(!require(devtools)) install.packages("devtools", repos = "http://cran.us.r-project.org")
# if(!require(NobleDynamic)) devtools::install_github('knrg07/NobleDynamic')
# if(!require(networkDynamic)) install.packages("networkDynamic", repos = "http://cran.us.r-project.org")
# if(!require(ggplot2)) install.packages("ggplot2", repos = "http://cran.us.r-project.org")
# if(!require(ggiraph)) install.packages("ggiraph", repos = "http://cran.us.r-project.org")
# if(!require(leaflet)) install.packages("leaflet", repos = "http://cran.us.r-project.org")
library(shiny)
library(shinythemes)
library(dplyr)
library(sna)
library(igraph)
library(visNetwork)
library(shinyWidgets)
library(networkDynamic)
library(ggplot2)
library(ggiraph)
library(leaflet)
library(packcircles)
library(viridis)
library(scales)
library(dygraphs)
library(xts)
load('/Users/karlanohemi/Desktop/PROJECTS/R PACKAGES/NobleDynamic/data/rawData.rda')
load('/Users/karlanohemi/Desktop/PROJECTS/R PACKAGES/NobleDynamic/data/gantt.rda')
gantt <- gantt_data
don=xts( x=gantt[,-1], order.by=gantt$wk_date)
#don <- don
### IMPORT DATA ONLY ONE TIME
# data(rawData)
x <- as.data.frame(rawContacts)
vhf <- as.data.frame(vhf)
ok_base <- leaflet() %>% addProviderTiles(providers$Stamen.Toner) %>% setView(-97.14, 33.93, zoom = 10)
gantt <- gantt
## RUN 3 UNIQUE FUNCTIONS BEFOREHAND FOR QUICKER HANDLING
# FUNCTION 1 FOR SUBSETTING BASED ON DATES & SPATIAL-TEMPORAL DEFINITION INPUTS
subset_view <- function(data, start, end, distance, time){
df <- data %>% filter(week_date >= start & week_date <= end & TIME_min <= time & distEuclid <= distance )
return(df)}
# FUNCTION 2: SUBSEQUENT NODE DERIVATION
create_nodes <- function(data){
no1b <- as.data.frame(table(data$KID_ref))
no2b <- as.data.frame(table(data$KID_par))
nodes <- full_join(no1b, no2b, by = "Var1")
nodes <- as.data.frame(nodes[,1])
colnames(nodes) <- 'KID'
nodes$group <- gsub('[0-9]', '', nodes$KID)
nodes$group[(nodes$group == "c")] <- "Cattle"
nodes$group[(nodes$group == "p")] <- "Pigs"
nodes$group[(nodes$group == "d")] <- "Deer"
nodes <- merge(nodes, vhf, by = 'KID', all.x = T)
nodes <- subset(nodes, select = c(KID, group, vertex.id))
colnames(nodes) <- c('id', 'group', 'vertex.id')
nodes$vertex.id <- as.integer(nodes$vertex.id)
nodes$color <- ifelse(nodes$group == 'Cattle', '#458B00', ifelse(nodes$group == 'Pigs', '#FF6347', '#996633'))
nodes <- as.data.frame(nodes)
return(nodes)}
# FUNCTION 3: SUBSEQUENT EDGE DERIVATION
create_edges <- function(data){
edges <- subset(data, select = c(KID_ref, KID_par, value))
edges <- aggregate(edges$value, by = list(edges$KID_ref, edges$KID_par), FUN = sum)
colnames(edges) <- c('from', 'to', 'value')
edges <- as.data.frame(edges)
edges$value <- as.integer(edges$value)
edges$color <- '#CCCCCC'
return(edges)}
# customization for descriptive plots
tooltip_css <- "background-opacity:0;font-size: 150%;font-style:strong;padding:10px;border-radius:10px 20px 10px 20px;"
# TESTING FUNCTIONS BELOW
# test <- subset_view(x, '2018-04-01', '2018-04-14', 10, 10)
# nodes <- create_nodes(test)
# edges<- create_edges(test)
ui <- bootstrapPage(
navbarPage(theme = shinytheme('darkly'),
collapsible = T, title = 'Noble Networks', id = 'nav',
navbarMenu(title = 'Static Networks',
tabPanel('Static Graph', style = 'background-color:#005493',
div(class='outer', align = 'right',
tags$head(includeCSS('style/main.css')),
visNetworkOutput("networkPlot",height = "100%", width = '100%'),
absolutePanel(id = 'controls', class = 'panel panel-default',
top = 75, left = 10, width = 250, fixed = T,
draggable = T, height = '100%', style = 'color:black',
span(tags$i(h6('Short date intervals are recommended for static descriptives. See the Dynamic Network tab for time-series networks.'), align = 'left'), style = 'color:#941100'),
span(tags$strong(h4('Current Static View:'), align = 'left')),
h3(textOutput('tot_anim'), align = 'left'),
span(h4(textOutput('tot_cow'), align = 'right'), style = 'color:#458B00'),
span(h4(textOutput('tot_pig'), align = 'right'), style = 'color:#FF6347'),
span(h4(textOutput('tot_deer'), align = 'right'), style = 'color:#996633'),
tags$hr(),
span(tags$strong(h4('Modify Definitions:'), align = 'left')),
setSliderColor(c('#8A2252', '#00B3A3'), c(1,2)),
sliderInput('time_window', label = "Temporal Window (MINUTES):", value = 10, min = 1, max = 30),
sliderInput('distance_window', label = "Spatial Window (METERS):", value = 10, min = 1, max = 30),
tags$hr(),
tags$hr(),
dateRangeInput('date_range', label = 'Modify Date Range View:', start = '2018-04-01', end = '2018-04-14', min = '2017-08-20', max = '2020-05-03', format = 'yyyy-mm-dd', separator = '-', weekstart = 7, startview = 'month'),
actionButton('Update_Click', label = 'Update Network'))),
absolutePanel(id = 'controls', class = 'panel panel-default',
bottom = 5, right = 10, width = 225, fixed = F,
draggable = T, height = '25%', style = 'color:black',
h4('Graph Averages:', align = 'left'),
span(tags$strong(h5(textOutput('avg_deg'), align = 'left'), style = 'color:#00B3A3')),
span(tags$strong(h5(textOutput('avg_diam'), align = 'left'), style = 'color:#00B3A3')),
span(tags$strong(h5(textOutput('avg_assort'), align = 'left'), style = 'color:#6B8D23')),
span(tags$strong(h5(textOutput('avg_bet'), align = 'left'), style = 'color:#1A80B3')),
span(tags$strong(h5(textOutput('avg_clos'), align = 'left'), style = 'color:#777788')))
# girafeOutput('Prop_bubbles'))
),
tabPanel(title = 'Centrality Measures', style = 'background-color:#005493',
div(class='outer', align = 'right', tags$head(includeCSS('style/main.css')),
sidebarLayout(
sidebarPanel(
htmlOutput('in_view')
),
mainPanel(
tabsetPanel(
tabPanel('Degree', girafeOutput('deg_Plt')),
tabPanel('Assortivity', girafeOutput('assort_Plt')),
tabPanel('Betweenness', girafeOutput('bet_Plt')),
tabPanel('Closeness', girafeOutput('clos_Plt'))
))))),
tabPanel(title = 'Communities', style = 'background-color:#005493',
div(class='outer', align = 'right',
tags$head(includeCSS('style/main.css')),
sidebarLayout(
sidebarPanel(h3('TBD', align = 'left'),
radioButtons(inputId="PlotLayout", label="Plot Layout", choices=c("Auto","Random","Fruchterman Reingold","Kamada Kawai"), selected="Fruchterman Reingold")),
mainPanel(
tabsetPanel(
tabPanel('TBD', plotOutput("graphPlot")),
tabPanel('TBD'))))))),
navbarMenu(title = 'Dynamic Networks',
tabPanel('TBD', style = 'background-color:#005493',
div(class = 'outer', align = 'right',
tags$head(includeCSS('style/main.css')),
sidebarPanel(
h4('Something on the Left Panel'),
h5('MORE on the Left Panel')
),
mainPanel(
tabsetPanel(
tabPanel('TBD'),
tabPanel('TBD'))))),
tabPanel('TBD', style = 'background-color:#005493',
div(class = 'outer', align = 'right',
tags$head(includeCSS('style/main.css')),
sidebarPanel(
h4('More on the Left Panel'),
h4('AND MORE on the Left Panel')),
mainPanel(
tabsetPanel(
tabPanel('TBD'),
tabPanel('TBD')))))),
tabPanel('Study Area Map', style = 'background-color:#005493',
div(class='outer', align = 'right',
tags$head(includeCSS('style/main.css')),
leafletOutput("ok_map", height = "100%", width = '100%'),
absolutePanel(id = 'controls', class = 'panel panel-default',
top = 75, left = 10, width = 250, fixed = T,
draggable = T, height = '100%', style = 'color:black',
),
absolutePanel(id = 'controls', class = 'panel panel-default',
top = 75, right = 10, width = 250, fixed = T,
draggable = T, height = '32%', style = 'color:black',
span(tags$strong(h4(textOutput('tot_inter'),align = 'left'))),
tags$hr(),
span(h5(textOutput('cow_cow'),align = 'right'), style = 'color:#458B00'),
span(h5(textOutput('pig_pig'),align = 'right'), style = 'color:#FF6347'),
span(h5(textOutput('deer_deer'),align = 'right'), style = 'color:#996633'),
span(h5(textOutput('cow_pig'),align = 'right'), style = 'color:#333333'),
span(h5(textOutput('cow_deer'),align = 'right'), style = 'color:#333333'),
span(h5(textOutput('pig_deer'),align = 'right'), style = 'color:#333333'))
)),
tabPanel('Data Overview',
fluidRow(
box(
dygraphOutput('gantt', width = "100%", height = "400px"), width = 9 ),
box(textOutput('legendDivID'), title = 'Active:', collapsible = F, width = 3)
)
)
))
server <- function(input, output) {
makeReactiveBinding('newData')
makeReactiveBinding('nodes')
makeReactiveBinding('edges')
makeReactiveBinding('deg')
makeReactiveBinding('props')
newData <- reactive({
input$Update_Click
isolate({subset_view(x, input$date_range[1], input$date_range[2], input$distance_window, input$time_window)})
})
edges <- reactive({
input$Update_Click
isolate({
data <- newData()
edges <- create_edges(data)})})
nodes <- reactive({
input$Update_Click
isolate({
data <- newData()
nodes <- create_nodes(data)})})
realTimeGraph <- reactive({
nodes <- nodes()
edges <- edges()
g <- graph_from_data_frame(d = edges, vertices = nodes, directed = F)
})
plotGraph <- function(){
g <- realTimeGraph()
plotlayout <- switch(input$PlotLayout,
"Auto"=layout.auto(g),
"Random"=layout.random(g),
"Fruchterman Reingold"=layout.fruchterman.reingold(g),
"Kamada Kawai"=layout.kamada.kawai(g))
V(g)$size = deg()*1.3
V(g)$label <- ''
clp <- cluster_optimal(g)
par(bg = '#333333')
plot(clp, g)
}
output$graphPlot <- renderPlot({suppressWarnings(plotGraph())})
deg <- reactive({
input$Update_Click
isolate({
edges <- edges()
nodes <- nodes()
net <- graph_from_data_frame(d = edges, vertices = nodes, directed = F)
deg <- degree(net, mode = 'all')})
return(deg*1.3)})
#graph_stats <- reactive({
# input$Update_Click
# isolate({
# edges <- edges()
# nodes <- nodes()
# net <- graph_from_data_frame(d = edges, vertices = nodes, directed = F)
# diam_all <- diameter(net)
# dens_all <- igraph::graph.density(net)
# cent_all <- centr_degree(net, mode = 'all', loops = F)
# degr_all <- cent_all$centralization
# mean_dist_all <- mean_distance(net)
# assort_all <- assortativity_degree(net, directed = F)
# sub_cow <- subgraph(net, v = V(net)[group == 'Cattle'])
# sub_pig <- subgraph(net, v = V(net)[group == 'Pigs'])
# sub_deer <- subgraph(net, v = V(net)[group == 'Deer'])
# diam_cow <- diameter(sub_cow)
# dens_cow <- igraph::graph.density(sub_cow)
# cent_cow <- centr_degree(sub_cow, mode = 'all', loops = F)
# degr_cow <- cent_cow$centralization
# mean_dist_cow <- mean_distance(sub_cow)
# assort_cow <- assortativity_degree(sub_cow, directed = F)
# diam_pig <- diameter(sub_pig)
# dens_pig <- igraph::graph.density(sub_pig)
# cent_pig <- centr_degree(sub_pig, mode = 'all', loops = F)
# degr_pig <- cent_pig$centralization
# mean_dist_pig <- mean_distance(sub_pig)
# assort_pig <- assortativity_degree(sub_pig, directed = F)
# diam_deer <- diameter(sub_deer)
# dens_deer <- igraph::graph.density(sub_deer)
# cent_deer <- centr_degree(sub_deer, mode = 'all', loops = F)
# degr_deer <- cent_deer$centralization
# mean_dist_deer <- mean_distance(sub_deer)
# assort_deer <- assortativity_degree(sub_deer, directed = F)
# diam <- rbind(10, -1, diam_all, diam_cow, diam_deer, diam_pig)
# dens <- rbind(10, -1, dens_all, dens_cow, dens_deer, dens_pig)
# degr <- rbind(10, -1, degr_all, degr_cow, degr_deer, degr_pig)
# assort <- rbind(10, -1, assort_all, assort_cow, assort_deer, assort_pig)
# mean_dist <- rbind(10, -1, mean_dist_all, mean_dist_cow, mean_dist_deer, mean_dist_pig)
# graph_lev <- data.frame(Diameter = diam, Density = dens, Degree = degr, Mean_Distance = mean_dist, Asssortivity = assort)
# as.data.frame(graph_lev)
# })
# return(graph_lev)})
vertex_stats <- reactive({
input$Update_Click
isolate({
edges <- edges()
nodes <- nodes()
net <- graph_from_data_frame(d = edges, vertices = nodes, directed = F)
nodes$degree <- degree(net, mode = 'all')
nodes$assort <- assortativity(net, directed = F)
nodes$between <- betweenness(net, v = V(net), directed = F)
nodes$closeness <- closeness(net, v = V(net), mode = 'all')
eigen <- eigen_centrality(net, directed = F)
nodes$eigen <- eigen$vector
nodes$count <- 1
as.data.frame(nodes)})
return(nodes)})
output$deg_Plt <- renderGirafe({
input$Update_Click
isolate({
df <- vertex_stats()
gg_point <- ggplot(df, aes(x = as.factor(group), y = degree, tooltip = group, data_id = group, colour = group)) + geom_boxplot_interactive(fill = c('#458B00','#996633', '#FF6347')) + theme_dark() + ylab("Vertex Degree Scores")+ xlab("Species") + scale_color_manual(values= c('#458B00','#996633', '#FF6347')) + theme(panel.background = element_blank(), panel.border = element_blank(), legend.position = "none", plot.background = element_rect(fill = "#333333"),axis.title.x = element_text(colour = "white"), axis.title.y = element_text(colour = "white") ,axis.text.x = element_text(colour = "white"), axis.text.y = element_text(colour = "#00B3A3")) + ylim(0, max(df$degree))
girafe(ggobj = gg_point, options = list(opts_selection(type = 'single', only_shiny = F)))
})})
output$bet_Plt <- renderGirafe({
input$Update_Click
isolate({
df <- vertex_stats()
gg_point <- ggplot(df, aes(x = as.factor(group), y = between, tooltip = group, data_id = group, colour = group)) + geom_boxplot_interactive(fill = c('#458B00','#996633', '#FF6347')) + theme_dark() + ylab("Vertex Betweenness Scores")+ xlab("Species") + scale_color_manual(values= c('#458B00','#996633', '#FF6347')) + theme(panel.background = element_blank(), panel.border = element_blank(), legend.position = "none", plot.background = element_rect(fill = "#333333"),axis.title.x = element_text(colour = "white"), axis.title.y = element_text(colour = "white"),axis.text.x = element_text(colour = "white"), axis.text.y = element_text(colour = "#1A80B3")) + ylim(0, max(df$between))
girafe(ggobj = gg_point, options = list(opts_selection(type = 'single', only_shiny = F)))})})
output$assort_Plt <- renderGirafe({
input$Update_Click
isolate({
df <- vertex_stats()
gg_point <- ggplot(df, aes(x = as.factor(group), y = assort, tooltip = group, data_id = group, colour = group)) + geom_boxplot_interactive(fill = c('#458B00','#996633', '#FF6347')) + theme_dark() + ylab("Vertex Assortivity Degree")+ xlab("Species") + scale_color_manual(values= c('#458B00','#996633', '#FF6347')) + theme(panel.background = element_blank(), panel.border = element_blank(), legend.position = "none", plot.background = element_rect(fill = "#333333"),axis.title.x = element_text(colour = "white"), axis.title.y = element_text(colour = "white"),axis.text.x = element_text(colour = "white"), axis.text.y = element_text(colour = "#6B8D23")) + ylim(0, max(df$assort))
girafe(ggobj = gg_point, options = list(opts_selection(type = 'single', only_shiny = F)))})})
output$clos_Plt <- renderGirafe({
input$Update_Click
isolate({
df <- vertex_stats()
gg_point <- ggplot(df, aes(x = as.factor(group), y = closeness, tooltip = group, data_id = group, colour = group)) + geom_boxplot_interactive(fill = c('#458B00','#996633', '#FF6347')) + theme_dark() + ylab("Vertex Closeness Values")+ xlab("Species") + scale_colour_manual(values= c('#458B00','#996633', '#FF6347')) + theme(panel.background = element_blank(), panel.border = element_blank(), legend.position = "none", plot.background = element_rect(fill = "#333333"), axis.title.x = element_text(colour = "white"), axis.title.y = element_text(colour = "white"),axis.text.x = element_text(colour = "white"), axis.text.y = element_text(colour = "#777788")) + ylim(0, max(df$closeness))
girafe(ggobj = gg_point, options = list(opts_selection(type = 'single', only_shiny = T)), opts_tooltip(use_fill = F))})})
# output$Prop_bubbles <- renderGirafe({
# input$Update_Click
# isolate({
# sub <- newData()
# sub <- aggregate(sub$value, by = list(sub$SPECIES_PAIRS), FUN = sum)
# colnames(sub) <- c('group', 'value')
# pack <- circleProgressiveLayout(sub$value, sizetype = 'area')
# sub <- cbind(sub, pack)
# sub$prop <- c(sub$value)/sum(sub$value)
# sub$prop <- label_percent()(sub$prop)
# sub$text <- paste("Interaction Type: ",sub$group, "\n", "Percentage:", sub$prop)
# dat.gg <- circleLayoutVertices(pack, npoints=50)
# p <-ggplot() + geom_polygon_interactive(data = dat.gg, aes(x, y, group = id, fill=id, tooltip = sub$text[id], data_id = id), colour = "black", alpha = 0.6) + scale_fill_viridis() + geom_text(data = sub, aes(x, y, label = group), size=2, color="black") + theme_void() + theme(legend.position="none", plot.margin=unit(c(0,0,0,0),"cm") ) + coord_equal()
# girafe(ggobj = p, options = list(opts_selection(type = 'single', only_shiny = T)), opts_tooltip(use_fill = F))
# })
# })
props <- reactive({
input$Update_Click
isolate({
ss <- newData()
ss <- aggregate(ss$value, by = list(ss$SPECIES_PAIRS), FUN = sum)
colnames(ss) <- c('Type', 'value')
ss$Proportion <- c(ss$value)/sum(ss$value)
ss$Proportion <- label_percent()(ss$Proportion)
as.data.frame(ss)})
return(ss)})
output$cow_cow <- renderText({
ss <- props()
ss <- ss[which(ss$Type == 'Cattle-Cattle'),]
if(nrow(ss) == 0){
return(print('Cattle-Cattle: 0.0%'))
}else{
paste('Cattle-Cattle:', prettyNum(props()$Proportion[(props()$Type == 'Cattle-Cattle')]))}})
output$pig_pig <- renderText({
ss <- props()
ss <- ss[which(ss$Type == 'Pig-Pig'),]
if(nrow(ss) == 0){
return(print('Pig-Pig: 0.0%'))
}else{
paste('Pig-Pig:', prettyNum(props()$Proportion[(props()$Type == 'Pig-Pig')]))}})
output$deer_deer <- renderText({
ss <- props()
ss <- ss[which(ss$Type == 'Deer-Deer'),]
if(nrow(ss) == 0){
return(print('Deer-Deer: 0.0%'))
}else{
paste('Deer-Deer:', prettyNum(props()$Proportion[(props()$Type == 'Deer-Deer')]))}})
output$cow_pig <- renderText({
ss <- props()
ss <- ss[which(ss$Type == 'Cattle-Pig'),]
if(nrow(ss) == 0){
return(print('Cattle-Pig: 0.0%'))
}else{
paste('Cattle-Pig:', prettyNum(props()$Proportion[(props()$Type == 'Cattle-Pig')]))}})
output$cow_deer <- renderText({
ss <- props()
ss <- ss[which(ss$Type == 'Cattle-Deer'),]
if(nrow(ss) == 0){
return(print('Cattle-Deer: 0.0%'))
}else{
paste('Cattle-Deer:', prettyNum(props()$Proportion[(props()$Type == 'Cattle-Deer')]))}})
output$pig_deer <- renderText({
ss <- props()
ss <- ss[which(ss$Type == 'Pig-Deer'),]
if(nrow(ss) == 0){
return(print('Pig-Deer: 0.0%'))
}else{
paste('Pig-Deer:', prettyNum(props()$Proportion[(props()$Type == 'Pig-Deer')]))}})
output$tot_anim <- renderText({
paste0(prettyNum(nrow(vertex_stats()), big.mark = ','), ' Total Animals')})
output$tot_cow <- renderText({
paste0(prettyNum(sum(vertex_stats()$count[(vertex_stats()$group == 'Cattle')]), big.mark = ','), ' Cattle')})
output$tot_pig <- renderText({
paste0(prettyNum(sum(vertex_stats()$count[(vertex_stats()$group == 'Pigs')]), big.mark = ','), ' Pigs')})
output$tot_deer <- renderText({
paste0(prettyNum(sum(vertex_stats()$count[(vertex_stats()$group == 'Deer')]), big.mark = ','), ' Deer')})
output$tot_inter <- renderText({
paste0(prettyNum(nrow(newData()), big.mark = ','), ' Total Interactions')})
output$avg_deg <- renderText({
paste0('Degree: ', prettyNum(mean(vertex_stats()$degree), digits = 3))})
output$avg_assort <- renderText({
paste0('Assortitive Value: ', prettyNum(mean(vertex_stats()$assort), digits = 3))})
output$avg_bet <- renderText({
paste0('Betweenness: ', prettyNum(mean(vertex_stats()$between), digits = 3))})
output$avg_clos <- renderText({
paste0('Closeness: ', prettyNum(mean(vertex_stats()$closeness), digits = 3))})
output$ok_map <- renderLeaflet({ok_base})
output$networkPlot <- renderVisNetwork({
edges <- edges()
nodes <- nodes()
nodes$size <- deg()
#output$in_view <- renderText({
# paste0("Plots in view are for current static definition of a ", input$distance_window, " meter Spatial Window and a ", input$time_window, ' minute Temporal Window. More specifically, for date views between ', input$date_range[1], ' and ', input$date_range[2], '.')})
output$in_view <- renderUI({
line1 <- paste0("Plots in view are for a <b style = color:#CCCC33;>", input$distance_window, " meter </b> Spatial Window and <b style = color:#CCCC33;>", input$time_window, " minute</b> Temporal Window definition.")
line2 <- paste0("<br/> More specifically, for date between <b style = color:#CCCC33;>", input$date_range[1], "</b> and <b style = color:#CCCC33;>", input$date_range[2], "</b>.")
HTML(paste(line1, line2, sep = '<br/>'))
})
output$gantt <- renderDygraph({withProgress(message = "Loading...", {
dygraph(don, main = 'Animal Observations by Week') %>% dyLegend(show = 'onmouseover', hideOnMouseOut = T, labelsDiv = "legendDivID") %>% dyGroup(c('c01', 'c02', 'c03', 'c04', 'c05', 'c06', 'c07', 'c08', 'c09', 'c10', 'c11', 'c12', 'c13', 'c14', 'c15', 'c16', 'c17', 'c18', 'c19', 'c20', 'c21', 'c22', 'c23', 'c24', 'c25', 'c28', 'c29', 'c30', 'c32', 'c33', 'c34', 'c35', 'c36', 'c37', 'c38', 'c39', 'c40', 'c41', 'c42'), color = c('#458B00','#458B00','#458B00','#458B00','#458B00','#458B00','#458B00','#458B00','#458B00','#458B00', '#458B00','#458B00','#458B00','#458B00','#458B00','#458B00','#458B00','#458B00','#458B00','#458B00', '#458B00','#458B00','#458B00','#458B00','#458B00','#458B00','#458B00','#458B00','#458B00','#458B00', '#458B00','#458B00','#458B00','#458B00','#458B00','#458B00','#458B00','#458B00','#458B00')) %>% dyGroup(c('p02', 'p04', 'p07', 'p08', 'p10', 'p11', 'p12', 'p14', 'p15', 'p16', 'p18', 'p20', 'p21', 'p22', 'p24', 'p25', 'p27', 'p28', 'p30', 'p32', 'p33', 'p35', 'p36', 'p38', 'p40', 'p41', 'p44', 'p45', 'p46', 'p47', 'p48', 'p49', 'p50', 'p51', 'p52', 'p53', 'p55', 'p56', 'p57', 'p58', 'p59', 'p60', 'p61', 'p62', 'p64', 'p65', 'p67', 'p68'), color = c('#FF6347','#FF6347','#FF6347','#FF6347','#FF6347','#FF6347','#FF6347','#FF6347','#FF6347','#FF6347', '#FF6347','#FF6347','#FF6347','#FF6347','#FF6347','#FF6347','#FF6347','#FF6347','#FF6347','#FF6347', '#FF6347','#FF6347','#FF6347','#FF6347','#FF6347','#FF6347','#FF6347','#FF6347','#FF6347','#FF6347', '#FF6347','#FF6347','#FF6347','#FF6347','#FF6347','#FF6347','#FF6347','#FF6347','#FF6347','#FF6347', '#FF6347','#FF6347','#FF6347','#FF6347','#FF6347','#FF6347','#FF6347','#FF6347')) %>% dyGroup(c('d01', 'd02', 'd03', 'd04', 'd05', 'd06', 'd07', 'd09', 'd10', 'd11', 'd12', 'd13', 'd14', 'd15', 'd16', 'd17', 'd18', 'd19', 'd20', 'd21', 'd22', 'd23', 'd24', 'd25', 'd26', 'd27', 'd28', 'd29', 'd30'), color = c('#996633','#996633','#996633','#996633','#996633','#996633','#996633','#996633','#996633','#996633','#996633','#996633','#996633','#996633','#996633','#996633','#996633','#996633','#996633','#996633','#996633','#996633','#996633','#996633','#996633','#996633','#996633','#996633','#996633')) %>% dyAxis('x', axisLabelColor = 'white')%>% dyAxis('y', axisLabelColor = 'white', valueFormatter = paste0('function(y){return "";}') )%>% dyCSS("style/legend.css") %>% dyAxis('y2', valueFormatter = paste0('function(x){ var KIDS = [',paste(paste0("'", names(don),"'"),collapse=','),']; return KIDS[x - 1]; }') ) %>% dyRangeSelector(fillColor = " #8A2252", strokeColor = "#8A2252", retainDateWindow = T)
})
})
# expr, env = parent.frame(), quoted = FALSE)
visNetwork(nodes, edges, width = '750px', height = "100%", background = '#222222') %>% visGroups(groupname = 'Pigs', color = '#FF6347', shadow = list(enabled = T)) %>% visGroups(groupname = 'Cattle', color = '#458B00', shadow = list(enabled = T)) %>% visGroups(groupname = 'Deer', color = '#CD9B1D', shadow = list(enabled = T)) %>% visInteraction(hover = T) %>% visOptions(selectedBy = list(variable = "group", style = 'width: 150px; height: 22px; background: white; color: #999933; border:none; outline:none;'), highlightNearest = T, collapse = F) %>% visInteraction(keyboard = TRUE, dragNodes = T, dragView = T, zoomView = T) # %>% visIgraphLayout()
})}
shinyApp(ui = ui, server = server)
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Embedding an R snippet on your website
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.