In dylanirion/finmatchr: Interactive Image-Image browser for shark fins

Browse

# for some reason, not including the below results in Error in (function (name, val, shinysession) : No handler registered for type date_tree:jsTreeR.list
library(jsTreeR)

# increase max upload to 10mb
options( shiny.maxRequestSize = 10*1024^2 )

if( Sys.which("convert") == "" ) { stop( "`convert` not found, please make sure ImageMagick is installed." ) }

#for some reason I can't see params in s3_to_tmp
pars <- params

#some styling maps
color.map <- c( IS_SAME = '#5CB85CFF', UNSURE = '#F0AD4EFF', NOT_SAME = '#D9534F50', HAS_ENCOUNTER = '#21908CFF', HAS_IMAGE = '#FFC107FF', VIRTUAL = '#F2F2F2FF', Event = '#440154FF', Encounter = '#21908CFF', Image = '#FFC107FF' )
color.map.80 <- c( Event = '#693376FF', Encounter = '#4DA6A3FF', Image = '#FDEB50FF' )
color.map.50 <- c( Event = '#A180A9FF', Encounter = '#90C7C5FF', Image = '#FEF392FF' )
font.color.map <- c( Event = '#FFFFFFFF', Encounter = '#FFFFFFFF', Image = '#343434FF' )
font.color.map.50 <- c(Image = '#999999FF')
font.size.map <- c( IS_SAME = 0, UNSURE = 0, NOT_SAME = 0, HAS_ENCOUNTER = 10, HAS_IMAGE = 10, VIRTUAL = 0 )
font.align.map <- c( IS_SAME = NULL, UNSURE = NULL, NOT_SAME = NULL, HAS_ENCOUNTER = "top", HAS_IMAGE = "top", VIRTUAL = NULL )
physics.map <- c( IS_SAME = T, UNSURE = F, NOT_SAME = T, HAS_ENCOUNTER = F, HAS_IMAGE = F, VIRTUAL = F )
spring.map <- c( IS_SAME = 200, UNSURE = 300, NOT_SAME = 300, HAS_ENCOUNTER = 95, HAS_IMAGE = 95, VIRTUAL = 300 )
chosen.map <- c( IS_SAME = T, UNSURE = T, NOT_SAME = T, HAS_ENCOUNTER = F, HAS_IMAGE = F, VIRTUAL = T, Image = T, Encounter = F, Event = F )
smooth.map <- c( IS_SAME = F, UNSURE = F, NOT_SAME = F, HAS_ENCOUNTER = F, HAS_IMAGE = F, VIRTUAL = F )
dashes.map <- c( IS_SAME = F, UNSURE = F, NOT_SAME = F, HAS_ENCOUNTER = F, HAS_IMAGE = F, VIRTUAL = F )

tags$style( HTML( "
    #manual_query {
      background-color: white;
      border:  1px solid #cccccc;
      border-radius: 4px;
    }
    #manual_query:focus {
      border-color: #66afe9;
      outline: 0;
      box-shadow: inset 0 1px 1px rgb(0 0 0 / 8%), 0 0 8px rgb(102 175 233 / 60%);
    }
    #upload_status {
      overflow-y:scroll;
      max-height: 50px;
      display: flex;
      flex-direction: column-reverse;
    }
    .fin_icon_path {
      cursor: pointer;
      pointer-events: bounding-box;
    }
    .invert_icon {
      fill: red;
      stroke: none;
    }
    " ) )

#script to forward keydown to shiny input
#custom handler for simulating on click graph event
# (visSetSelection doesn't seem to trigger the on click defined in the visNetwork)
#custom handlers for updating to and from img indexes
tags$script(src='js/script.js')

# create connection to local neo4j database
#TODO: store connection as react and catch errors?
con <- neo4j_api$new( url = pars$neo4j_url, user = pars$neo4j_user, password = pars$neo4j_pass )

#expose tempdir to shiny server
addResourcePath( prefix = "img", directoryPath = tempdir() )
addResourcePath( prefix = "svg", directoryPath = system.file("svg", package = "finmatchr" ) )
addResourcePath( prefix = "js", directoryPath = system.file("js", package = "finmatchr" ) )


#addResourcePath( prefix = "data", directoryPath = system.file("data", package = "finmatchr" ) )
task_file <- '/Users/dylanirion/Documents/GWS Abundance/data/task.json'
#task_results_file <- '/Users/dylanirion/Documents/GWS Abundance/data/task_results.json'
#task_results_file <- '/Users/dylanirion/Documents/GWS Abundance/data/2010_results.json'
task_results_file <- '/Users/dylanirion/Documents/GWS Abundance/data/2007-2010_encounters_results.json'
#task_results_file <- '/Users/dylanirion/Documents/GWS Abundance/data/2007-2010_encounters_results2.json'
#task_results_file <- '/Users/dylanirion/Documents/GWS Abundance/data/2007-2010_individuals_results.json'
unconnected_folders_file <- '/Users/dylanirion/Documents/GWS Abundance/data/unconnected_folders.json'
all_folders_file <- '/Users/dylanirion/Documents/GWS Abundance/data/all_folders.json'

#setup reactive values
react <- reactiveValues( run = NULL, style = NULL, draw = NULL, update = NULL, copy = NULL, valid_img_count = NULL, unreviewed_img_count = NULL, date_list = NULL, upload_status = NULL, temp_count = 0, temp_folders = NULL, run_match = NULL, active_tab = "Browse", task_result = NULL, match_from_throb = NULL, match_to_throb = NULL, continue_query = NULL, continue_update = NULL)
# TODO: read options from json to persist?
# TODO: change style maps to options?
settings <- reactiveValues( aggregate_by = "Duplicate/Cropped", update_single_all = "All",
                            show_nodes = c( "unusable" = T, "Encounter" = F, "Event" = F ),
                            show_edges = c( "IS_SAME" = T, "UNSURE" = T, "NOT_SAME" = F ),
                            zoom_to_fin = T )
payload <- reactiveValues( query = NULL, graph = NULL, original_graph = NULL, from = NULL, to = NULL, from_meta = NULL, to_meta = NULL, edge_meta = NULL, old_from = NULL, old_to = NULL, match_from = NULL, match_to = NULL, match_edge_meta = NULL )

#function to embed image as svg and return svgPanZoom
#TODO: add an svg icon when annotation is present
draw_img <- function( node ) {
  path <- paste0( "img/", node %>% pull(uuid), ".jpg" )
  if( ifelse( !"has_annot" %in% colnames(node) | is.na(node$has_annot) , F, node$has_annot ) & settings$zoom_to_fin ) {
    size <- node %>% pull(image_size) %>% pluck(1)
    x <- node %>% pull(x) %>% pluck(1)
    y <- node %>% pull(y) %>% pluck(1)
    svgPanZoom( paste0( "<svg xmlns='http://www.w3.org/2000/svg' xmlns:xlink='http://www.w3.org/1999/xlink'>",
                        "<image width = '", size[2], "' height = '", size[1], "' xlink:href='", path, "' />",
                        "<polyline id = 'fin' points= '", paste( x, y, sep = ", ", collapse = " "), "' data-min = '", paste(min(x), min(y), sep=",") , "' data-max = '", paste(max(x), max(y), sep=",") , "' fill='none' stroke = 'red' display = 'none' />",
                        "</svg>" ),
                controlIconsEnabled = TRUE ) %>%
      #TODO: calculate which is larger, dy, dx, and scale accordingly
      #TODO: stroke outside of icon
      onRender( "function(el, x) {
      var svg = el.getElementsByTagName('svg')[0];
      svg.append(Object.assign(document.createElementNS('http://www.w3.org/2000/svg','g'), {innerHTML:\"<path class='fin_icon_path' d='m50,5a45,45 0 0 0 -45,45a45,45 0 0 0 45,45a45,45 0 0 0 45,-45a45,45 0 0 0 -45,-45zm6.37305,14.29297l0.86718,1.54101c4.59453,8.17276 6.60367,20.51569 9.65625,30.69141c1.5263,5.08786 3.30745,9.607 5.58985,12.6875c2.2824,3.0805 4.86276,4.73363 8.58984,4.625l0.08789,2.99805c-4.72367,0.13767 -8.42592,-2.24315 -11.08789,-5.83594c-2.66197,-3.59279 -4.48496,-8.38717 -6.05273,-13.61328c-2.91342,-9.71178 -5.02557,-20.84588 -8.61328,-28.28906c-10.83666,9.18762 -15.49541,18.30032 -19.2168,26.60937c-3.905,8.719 -7.01568,16.74422 -15.78516,22.13867l-1.57226,-2.55468c7.91381,-4.86811 10.67857,-12.01017 14.61914,-20.8086c3.94057,-8.79842 9.02872,-19.06452 21.53906,-29.08398l1.37891,-1.10547z' stroke-width='3.5' stroke='red' fill='none'/>\"}));
      var image = svg.getElementsByTagName('image')[0];
      var fin = svg.getElementById('fin');
      var icon = svg.getElementsByClassName('fin_icon_path')[0];
      icon.parentNode.setAttribute('transform', 'translate(247 0) scale(0.25)');
      icon.addEventListener('click', function(e) {
        e.preventDefault();
        e.currentTarget.classList.toggle('invert_icon');
        fin.setAttribute('display', fin.getAttribute('display') === 'none' ? '' : 'none');
      });
      var mat = svg.getElementsByClassName('svg-pan-zoom_viewport')[0].transform.baseVal.consolidate().matrix;
      var height = parseInt(image.getAttribute('height') );
      this.zoomWidget.zoomAtPointBy( height / ( 50 + parseInt(fin.dataset.max.split(',')[1] ) - parseInt( fin.dataset.min.split(',')[1] ) ), {x: mat.a * ( parseInt( fin.dataset.min.split(',')[0] ) + 75 + (parseInt( fin.dataset.max.split(',')[0] ) - parseInt( fin.dataset.min.split(',')[0] ) ) / 2 ) + mat.e, y: mat.d * ( parseInt( fin.dataset.min.split(',')[1] ) - 75 + ( parseInt( fin.dataset.max.split(',')[1] ) - parseInt( fin.dataset.min.split(',')[1] ) ) / 2 ) + mat.f});
                }")
  } else {
    svgPanZoom( paste0( "<svg xmlns='http://www.w3.org/2000/svg' xmlns:xlink='http://www.w3.org/1999/xlink'><image width = '750' height = '500' xlink:href='", path, "'/></svg>" ),
                controlIconsEnabled = TRUE )
  }
}

#LISTENERS
#"active_tab" listener
# pases on value to react
active_tab <- observeEvent( input$active_tab, {
  react$active_tab = input$active_tab
}, ignoreNULL = F, ignoreInit = T )

##TEMP!!! (SEE ALSO REACT$TEMP_COUNT CUSTOM KEYDOWN JS AND BUTTON FOR THIS ACTION)
query_fix_edges_action <- observeEvent(input$query_fix_edges, {
  #if not first click, update json file
  if(react$temp_count != 0) {
    #write_json(react$temp_folders[-1], all_folders_file)
    write_json(react$temp_folders[-1], unconnected_folders_file)
  }

  #react$temp_folders<-read_json(all_folders_file, simplifyVector=T)
  react$temp_folders<-read_json(unconnected_folders_file, simplifyVector=T)
  updateActionButton(session, "query_fix_edges", label = paste0("Query Next Folder [",length(react$temp_folders),"]") )
  react$draw <- payload$graph <- payload$from <- payload$to <- payload$old_from <- payload$old_to <- payload$edge_id <- NULL
  payload$query <-paste0("MATCH (img1:Image)<-[:HAS_IMAGE]-(:Folder {path: \"",str_replace_all(react$temp_folders[1],"(\\')", "\\\\\\1"),"\"}) ",
                         "WITH img1 ",
                         "OPTIONAL MATCH (img1)<-[rel:IS_SAME]->(img2:Image) ",
                         #"WHERE rel.basis IN ['duplicate', 'cropped'] ",
                         "WITH COLLECT(id(img1)) + COLLECT(id(img2)) AS ids, COLLECT(img1) + COLLECT(img2) AS imgs, COLLECT(rel) AS r ",
                         "UNWIND imgs AS img ",
                         "WITH img, ids, r ",
                         "OPTIONAL MATCH (img)<-[rel1:HAS_IMAGE]-(enc:Encounter) ",
                         "WITH img, ids, enc, COLLECT(img) + COLLECT(enc) AS n, r + COLLECT(rel1) AS r ",
                         "OPTIONAL MATCH (enc)<-[rel:HAS_ENCOUNTER]-(evt:Event) ",
                         "WITH img, ids, n + COLLECT(evt) AS nodes, r + COLLECT(rel) AS relationships ",
                         "OPTIONAL MATCH (img)-[r]->(b) ",
                         "WHERE id(b) IN ids ",
                         "WITH img, nodes, relationships + COLLECT(r) as relationships ", 
                         "OPTIONAL MATCH (img)-[rel: HAS_ANNOTATION]-(a: Annotation) ",
                         "WITH nodes + COLLECT(a) AS nodes, relationships + COLLECT(rel) AS relationships ",
                         "RETURN nodes, relationships" )
  react$temp_count <- react$temp_count + 1
  react$run <- ifelse( is.null( react$run ), 0, react$run + 1 )

},ignoreInit=T)

###

#"run_manual_query" button click
# sets "query" payload from text input
# triggers "run" with increment
manual_query_action <- observeEvent( input$run_manual_query, {
  react$draw <- payload$graph <- payload$from <- payload$to <- payload$old_from <- payload$old_to <- payload$edge_id <- NULL
  payload$query <- input$manual_query
  react$run <- ifelse( is.null( react$run ), 0, react$run + 1 )
}, ignoreInit = T )

#"date_tree" click
# sets "query" payload
# triggers "run" with increment
query_date_action <- observeEvent( input$date_tree_selected, {
  react$draw <- payload$graph <- payload$from <- payload$to <- payload$old_from <- payload$old_to <- payload$edge_id <- NULL
  if( req(length(input$date_tree_selected) > 0 ) ) {
    payload$query <- paste0( "MATCH (img:Image) WHERE ", paste0("(", paste0( lapply( input$date_tree_selected, function(d) d$data$query ), collapse = ") OR (" ), ")"), " ",
                             "WITH img ",
                             "WITH COLLECT(id(img)) AS ids, COLLECT(img) AS imgs ",
                             "UNWIND imgs AS img ",
                             "WITH img, ids ",
                             "OPTIONAL MATCH (img)<-[rel:HAS_IMAGE]-(enc:Encounter) ",
                             "WITH img, ids, enc, COLLECT(img) + COLLECT(enc) AS n, COLLECT(rel) AS rels ",
                             "OPTIONAL MATCH (enc)<-[rel:HAS_ENCOUNTER]-(evt:Event) ",
                             "WITH img, ids, n + COLLECT(evt) AS nodes, rels + COLLECT(rel) AS rels ",
                             "OPTIONAL MATCH (img)-[rel]->(b) ",
                             "WHERE id(b) IN ids ",
                             "WITH img, nodes, rels + COLLECT(rel) as rels ", 
                             "OPTIONAL MATCH (img: Image)-[rel: HAS_ANNOTATION]-(a: Annotation) ",
                             "WITH nodes + COLLECT(a) AS nodes, rels + COLLECT(rel) AS relationships ",
                             "RETURN nodes, relationships" )
  }
  react$run <- ifelse( is.null( react$run ), 0, react$run + 1 )
}, ignoreInit = T )

#"run" reactive
# executes "query" payload
# processes response as "graph" payload
# triggers "style" with increment
run_query <- observeEvent( react$run, {
  payload$from_meta <- NULL
  payload$to_meta <- NULL
  payload$edge_meta <- NULL
  # query db with progress bar         
  withProgress(message = 'Querying Database...', value = 0, {

    # increment progress bar
    incProgress(0.5)

    # query data from neo4j
    if( payload$query != '' ) {
      graph <- payload$query %>% cypher( con, "graph" )
    } else {
      graph <- list()
    }

    #@todo: move all this into a function
    if( length(graph) ) {
      # add potentially empty property columns
      node_cols <- tibble( unusable = NA_real_, reviewed = NA_real_, date = NA_character_, camera_date = NA_character_, region = NA_character_, trailing = NA_character_, leading = NA_character_, image_size = NA_character_, x = NA_character_, y = NA_character_, tip = NA_character_  )
      edge_cols <- tibble( id = NA_character_ , from = NA_character_, to = NA_character_, basis = NA_character_, reviewed = NA_real_, label = NA_character_, score = NA_real_, chosen = NA_real_, hidden = NA_real_ )
      # unnest nodes
      graph$nodes <- graph %>%
        pluck("nodes") %>%
        unnest_wider( col = "properties" ) %>%
        add_column( !!!node_cols[!names( node_cols ) %in% names(.)] ) %>%
        mutate( label = unlist(label) %>% .[ . != "DUMMY" ],
          trailing = map( trailing, ~c( unlist(.) ) ),
          leading = map( leading, ~c( unlist(.) ) ),
          image_size = map( image_size, ~c( unlist(.) ) ),
          x = map( x, ~c( unlist(.) ) ),
          y = map( y, ~c( unlist(.) ) ),
          tip = map( tip, ~c( unlist(.) ) ) )

      if(!is.null(graph$relationships)) {
        graph$nodes <- graph$nodes %>%
          left_join( { graph$relationships %>%
            filter( type == "HAS_ANNOTATION" ) %>%
            select(startNode, endNode) %>%
            mutate( has_annot = T ) }, by = c( "id" = "startNode" ) ) %>%
        left_join( {select(., id, image_size, trailing, tip, leading, x, y, )}, by = c( "endNode" = "id" ) ) %>%
        select( -trailing.x, -image_size.x, -leading.x, -x.x, -y.x, -tip.x, -endNode ) %>%
        rename( image_size = image_size.y, trailing = trailing.y, tip = tip.y, leading = leading.y, x = x.y, y = y.y ) %>%
        filter( label != "Annotation" )
      } else {
        graph$nodes <- graph$nodes %>%
          mutate( has_annot = F )
      }

      graph$nodes <- graph$nodes %>%
        distinct( id, .keep_all = T )


      # unnest relationships
      if( !is.null( graph$relationships ) ) {
        graph$relationships <- graph$relationships %>%
          unnest_relationships() %>%
          filter( type != "HAS_ANNOTATION" ) %>%
          #adds "value" column??
          select_if(!names(.) %in% c('value')) %>%
          rename( from = startNode, to = endNode, label = type ) %>%
          add_column( !!!edge_cols[!names( edge_cols ) %in% names(.)] )

        #pseudonodes from relationships (nested tibble)
        if( settings$aggregate_by == "Duplicate/Cropped" ) {
          agg_filter = parse_expr("label == 'IS_SAME' & basis %in% c( 'duplicate', 'cropped' ) & reviewed == T")
        } else if( settings$aggregate_by == "Encounter" ) {
          agg_filter = parse_expr("label == 'IS_SAME' & reviewed == T & from_date == to_date")
        } else if( settings$aggregate_by == "Individual" ) {
          agg_filter = parse_expr("label == 'IS_SAME' & reviewed == T")
        } else {
          agg_filter = parse_expr("FALSE")
        }

        igraph_object<- graph_from_data_frame( d = graph$relationships %>%
                                                 left_join( graph$nodes %>%
                                                              select( id, date ),
                                                            by=c( "from" = "id" ) ) %>%
                                                 rename( from_date = date ) %>%
                                                 left_join( graph$nodes %>%
                                                              select( id, date ),
                                                            by=c( "to" = "id" ) ) %>%
                                                 rename( to_date = date ) %>%
                                                 filter( !!agg_filter ) %>%
                                                 select( from, to, everything() ), directed = F, vertices = graph$nodes )

        comp <- groups( components( igraph_object ) ) %>% map_df( ~ tibble( id = as.character(md5(paste0( sort( . ), collapse = ", ") ) ), members = list(.) ) )

        graph$nodes <- graph$nodes %>%
          mutate( group = comp[components( igraph_object )$membership, "id"] %>% pull(id) ) %>%
          nest( data = !group ) %>%
          select( id = group, data ) %>%
          mutate( label = map_chr( data, ~unique( .$label ) ) )

        #drop the relationships we grouped (if there are any)
        #TODO: group these instead so we know which two nodes exactly have the linking relationship
        #TODO: drop UNSURE when cgrouped with IS_SAME or NOT_SAME
        if( nrow(graph$relationships) ) {
          graph$relationships <- graph$relationships %>%
            rowwise() %>%
            mutate( keep = map2_lgl( from, to, ~ !any( sapply( comp$members, function(e) is.element( .x, e ) & is.element( .y, e ) ) ) ),
                    from = comp[which( sapply( comp$members, function(e) is.element( from, e ) ) ), "id"] %>% pull(id),
                    to = comp[which( sapply( comp$members, function(e) is.element( to, e ) ) ), "id"] %>% pull(id) ) %>%
            ungroup() %>%
            filter( keep ) %>%
            #something like this to identify groups with multiple labels in remove UNSURE?
            group_by(from, to) %>%
            mutate(keep = all(label[1]==label)) %>%
            ungroup() %>%
            filter( keep | label != "UNSURE" ) %>%
            select( -keep )
        }
      } else {
        graph$nodes <- graph$nodes %>%
          mutate( group = uuid ) %>%
          nest( data = !group ) %>%
          select( id = group, data ) %>%
          mutate( label = map_chr( data, ~unique( .$label ) ) )
        graph$relationships <- tibble() %>%
          add_column( !!!edge_cols[!names( edge_cols ) %in% names(.)] )
      }

      #remove 'unusable' nodes (but re-add later)
      unusable <- graph$nodes %>% mutate( unusable = map_lgl( data, ~all( .$unusable == T ) ) ) %>% filter( unusable == T ) %>% select( -unusable ) 
      graph$nodes <- graph$nodes %>% mutate( unusable = map_lgl( data, ~all( .$unusable == T ) ) ) %>% filter( unusable != T | is.na(unusable) ) %>% select( -unusable )

      if( graph$nodes %>% filter( label == "Image" ) %>% nrow() > 1 ) {
        #create virtual relationships for any that aren't present
        #TODO: don't create virtual if path is already present between two nodes
        virtual_rels <- t( combn( graph$nodes %>% filter( label == "Image" ) %>% pull(id), 2 ) ) %>%
        `colnames<-`( c( "from", "to" ) ) %>% as_tibble() %>%
          mutate( label = "VIRTUAL", basis = NA_character_, reviewed = F )

        #if no real relationships, just add them all
        if( is.null( graph$relationships ) ) {
          graph$relationships <- virtual_rels
        } else { #otherwise we need to join only those that don't exist
          graph$relationships <- bind_rows( graph$relationships,
                                            anti_join( virtual_rels, bind_rows( graph$relationships %>% filter( label %in% c( "IS_SAME", "UNSURE", "NOT_SAME" ) ),
                                                                                graph$relationships %>% filter( label %in% c( "IS_SAME", "UNSURE", "NOT_SAME" ) ) %>%
                                                                                  rename( "from" = "to", "to" = "from" ) ),
                                                       by = c( "from", "to" ) ) )
        }
      }
      #rewrite edge ids
      graph$relationships <- graph$relationships %>%
        rowwise() %>%
        mutate( id = as.character( md5(paste0( label, basis, sort( c( from, to ) ), collapse = ", ") ) ) ) %>%
        ungroup() %>%
        distinct(id, .keep_all = T)

      #re-add unusable nodes
      graph$nodes <- bind_rows( graph$nodes, unusable )

      #sort edges
      if( nrow( graph$relationships ) > 0 ) {
        graph$relationships <- graph$relationships %>% rowwise %>% mutate( sort = paste0( sort( c( from, to ) ), collapse = ", ") ) %>% ungroup() %>% arrange(sort) %>% select( -sort )
      }
    }  
    payload$graph <- graph

    #trigger styling
    react$style <- ifelse( is.null( react$style ), 0, react$style + 1 )
  })
})

#"style" reactive
# styles and update "graph" payload
# triggers "draw" on first drawing, or "update" with increment
style_results <- observeEvent( react$style, {
  graph <- payload$graph
  if( length(graph) ) {
    graph$nodes <- graph$nodes %>%
    mutate( shape = "circle",
            color.background = recode( label, !!!color.map.80 ),
            color.border = recode( label, !!!color.map ),
            font.color = recode( label, !!!font.color.map ),
            chosen = recode( label, !!!chosen.map ),
            hidden = F,
            #title = case_when( label == 'Event' ~ paste0( '<p><b>', uuid, '</b><br>', date, '</p>' ), label == 'Encounter' ~ paste0( '<p><b>', uuid, '</b><br>', date, '</p>' ), label == 'Image' ~ paste0( '<p><b>', uuid, '</b><br>', source_file, '<br>', camera_date, '<br>', date, '</p>' ) )
            ) %>%
      # override colors for unusable
      rowwise() %>%
      mutate(color.background = case_when( label == "Image" & all(data %>% pull(unusable) == TRUE) ~ color.map.50["Image"],
                                          TRUE ~ color.background ),
             color.border = case_when( label == "Image" & all(data %>% pull(unusable) == TRUE) ~ color.map.80["Image"],
                                          TRUE ~ color.border ),
             font.color = case_when( label == "Image" & all(data %>% pull(unusable) == TRUE) ~ font.color.map.50["Image"],
                                          TRUE ~ font.color )) %>%
      ungroup()

    if( !settings$show_nodes["unusable"] ) {
      graph$nodes <- graph$nodes %>%
        rowwise() %>%
        mutate( hidden = case_when( label == "Image" & all(data %>% pull(unusable) == TRUE) ~ T,
                                    TRUE ~ hidden ) ) %>%
        ungroup()
    }

    if( !any(settings$show_nodes[c("Encounter", "Event")]) ) {
      graph$nodes <- graph$nodes %>%
        mutate( hidden = case_when( label %in% c("Encounter", "Event")[!settings$show_nodes[c("Encounter", "Event")]] ~ T,
                                    TRUE ~ hidden ) )
    }

    if( nrow(graph$relationships) > 0 ) {
      graph$relationships <- graph$relationships %>%
      #filter( label != "NOT_SAME" ) %>%
      mutate( color.color = recode( label, !!!color.map ),
              dashes = recode( label, !!!dashes.map ),
              font.size = recode( label, !!!font.size.map ),
              font.align = recode( label, !!!font.align.map ),
              physics = recode( label, !!!physics.map ),
              length = recode( label, !!!spring.map ),
              chosen = recode( label, !!!chosen.map ),
              smooth.enabled = recode( label, !!!smooth.map ),
              hidden = recode( label, !!!!settings$show_edges, .default = F ),
              hidden = case_when( label == 'VIRTUAL' ~ ifelse( is.null(settings$show_edges['UNSURE']), T, !settings$show_edges['UNSURE']),
                                  T ~ hidden ) ) %>%

      # override dashes for unreviewed
      rowwise() %>%
      mutate(dashes = case_when( reviewed != TRUE | is.na(reviewed) & !label %in% c("HAS_IMAGE", "HAS_ENCOUNTER", "HAS_FOLDER")  ~ TRUE,
                                 TRUE ~ dashes )) %>%
      ungroup()

      # if we hid any nodes, hide the edges too
      if( !settings$show_nodes["unusable"] | !any(settings$show_nodes[c("Encounter", "Event")]) ) {
        graph$relationships <- graph$relationships %>%
          left_join(graph$nodes %>% select(id, hidden ), by = c( "from" = "id" ) ) %>%
          left_join(graph$nodes %>% select(id, hidden ), by = c( "to" = "id" ) ) %>%
          rowwise() %>%
          mutate( hidden = any( hidden.x, hidden.y, hidden ) ) %>%
          ungroup %>%
          select( -hidden.x, -hidden.y )
      }
    }
  }

  payload$graph <- graph
  #if we haven't drawn the graph yet, do so, otherwise update it
  if( is.null( react$draw ) ) {
    react$draw <- T
  } else {
    react$update <- ifelse( is.null( react$update ), 0, react$update + 1 )
  }
})

#"draw" reactive
# displays "graph" payload
# adds click actions to trigger inputs
# triggers finishedDrawing reactive
# returns visNetwork
draw_results <- eventReactive( react$draw, {
  graph <- payload$graph
  if( length(graph) ) {
    react$copy <- ifelse( is.null( react$copy ), 0, react$copy + 1 )
    visNetwork( graph$nodes, graph$relationships, height = '100%',
                submain = paste0( "Aggregating by ", settings$aggregate_by, ", Updating ", ifelse( settings$update_single_all == "All" & ( settings$aggregate_by == "Duplicate/Cropped" | settings$aggregate_by == "Encounter" ), "All", "Single" ),
                                  "<br>", nrow( graph$relationships %>% filter( reviewed == T ) ), "/", nrow( graph$relationships %>% filter( chosen == T ) ), " Edges Reviewed, ", nrow( graph$nodes$data %>% bind_rows() %>% filter( label == "Image" & ( unusable == T | reviewed == T ) ) ), "/", nrow( graph$nodes$data %>% bind_rows() %>% filter( label == "Image" ) ), " images reviewed" ) ) %>%
      visEvents( type = "on",
               click = paste0( "function(p) { ",
                               "  keysEnabled = true;",
                               "  graphSelected = true;",
                               # is it possible to check node label here?
                               "  if( typeof p.edges[0] === 'undefined' && typeof p.nodes[0] !== 'undefined' ) { ",
                               "    if( this.body.data.nodes.get(p.nodes[0]).label == \"Image\" ) { ",
                               "      selectEdge(this.body.data.nodes.get(p.nodes[0]).id, ",
                               "        null, ",
                               "        null, ",
                               "        'EDIT SINGLE' ",
                               "      );",
                               "    }",
                               "  } else if( typeof p.nodes[0] === 'undefined' && typeof p.edges[0] !== 'undefined' ) { ",
                               "    if( [\"IS_SAME\", \"UNSURE\", \"NOT_SAME\", \"VIRTUAL\" ].includes(this.body.data.edges.get(p.edges[0]).label) ) { ",
                               "      selectEdge(this.body.data.edges.get(p.edges[0]).from, ",
                               "        this.body.data.edges.get(p.edges[0]).to, ",
                               "        this.body.data.edges.get(p.edges[0]).label, ",
                               "        this.body.data.edges.get(p.edges[0]).id ",
                               "      );",
                               "    }",
                               "  }",
                               "}" ),
               selectEdge = paste0( "function() { keysEnabled = true; graphSelected = true; }" ),
               deselectEdge = paste0( "function() { keysEnabled = false; graphSelected = false; }" ) ) %>%
      visInteraction( dragNodes = F,
                      navigationButtons = T,
                      selectConnectedEdges = F )
  }
}, ignoreInit = T )

#"update" reactive
# displays "graph" payload
# updates VisNetworkProxy
update_results <- observeEvent( react$update, {
  graph <- payload$graph
  if( length(graph) ) {
    n <- NULL
    e <- NULL
    #update the graph
    visNetworkProxy( "graph" ) %>%
      visUpdateNodes(graph$nodes) %>%
      visUpdateEdges( graph$relationships ) %>%
      visRemoveEdges( payload$original_graph$relationships$id[which( !payload$original_graph$relationships$id %in% graph$relationships$id )] ) %>%
      visRemoveNodes( payload$original_graph$nodes$id[which( !payload$original_graph$nodes$id %in% graph$nodes$id )] ) %>%
      visSetTitle( submain = paste0( "Aggregating by ", settings$aggregate_by, ", Updating ", ifelse( settings$update_single_all == "All" & ( settings$aggregate_by == "Duplicate/Cropped" | settings$aggregate_by == "Encounter" ), "All", "Single" ),
                                     "<br>", nrow( graph$relationships %>% filter( reviewed == T ) ), "/", nrow( graph$relationships %>% filter( chosen == T ) ), " Edges Reviewed, ", nrow( graph$nodes$data %>% bind_rows() %>% filter( label == "Image" & ( unusable == T | reviewed == T ) ) ), "/", nrow( graph$nodes$data %>% bind_rows() %>% filter( label == "Image" ) ), " images reviewed" ) )

    #then decide if we are selecting a node or edge
    if( is.null(payload$old_to) & !is.null(payload$old_from) ) {
      #selecting just a node, find the old one (if it exists)
      n <- graph$nodes %>%
        mutate( keep = map_lgl( data, ~ payload$old_from %in% .$id )  ) %>%
        filter( keep ) %>% select( id ) %>% pull(id)
      if( length(n) ) {
        n <- which( graph$nodes$id == n )
      } else {
        n <- NULL
        e <- min( which( graph$relationships$chosen == T ) )
      }
    } else if( !is.null(payload$old_from) & !is.null(payload$old_to) ) {
      #selecting an edge, if there is only 1 left, select it
      if( nrow( graph$relationships %>% filter( chosen == T ) ) == 1 ) {
        e <- min( which( graph$relationships$chosen == T ) )
      } else if( nrow( graph$relationships %>% filter( chosen == T ) ) == 0 ) {
        n <- min( which( graph$nodes$chosen == T ) )
        e <- NULL
      } else {
        # otherwise try to find the original
        if( length( which( graph$relationships$id == input$edge_id ) ) ) {
          e <- which( graph$relationships$id == input$edge_id )
        } else if( !is.null(payload$old_from) & !is.null(payload$old_to) ) {
          # or try to find the new edge
          a <- graph$nodes %>%
            mutate( keep = map_lgl( data, ~ payload$old_from %in% .$id )  ) %>%
            filter( keep ) %>% select( id ) %>% pull(id)
          b <- graph$nodes %>%
            mutate( keep = map_lgl( data, ~ payload$old_to %in% .$id )  ) %>%
            filter( keep ) %>% select( id ) %>% pull(id)
          if( length(a) & length(b) ) {
            # edge was consolidated into a node
            if( a == b ) {
              n <- which( graph$nodes$id == a )
            } else {
              e <- which( graph$relationships$id == graph$relationships %>%
                          filter( ( from == a | to == a ) & ( from == b | to == b ) ) %>% slice(1) %>% pull(id) )
              # edge no longer exists, but one of the nodes is still active
              if( !length(e) ) {
                n <- which( ( graph$nodes$id == a | graph$nodes$id == b ) & sapply( graph$nodes$data, function(l) any( ifelse( is.na(l$unusable), F, l$unusable ) == F) ) )
              }
            }
            # don't think I actually want this case
          #} else if( !length(a) & !length(b) ) {
          #  #if somehow we can't find anything, just select the first edge
          #  e <- min( which( graph$relationships$chosen == T ) )
          } else {
            #otherwise just select the remaining original node
            n <- ifelse( length(a), which( graph$nodes$id == a ), which( graph$nodes$id == b ) )
          }
        } else {
          e <- min( which( graph$relationships$chosen == T ) )
        }
      }
    }
    if( !is.null(n) ) {
      visNetworkProxy( "graph" ) %>%
        visSetSelection( nodesId = graph$nodes$id[n], highlightEdges = F )
      session$sendCustomMessage( "simSelect", list( from = graph$nodes$id[n],
                                                    to = NULL,
                                                    label = NULL,
                                                    id = "EDIT SINGLE" ) )
    } else if( !is.null(e) ) {
      visNetworkProxy( "graph" ) %>%
        visSetSelection( edgesId = graph$relationships$id[e] )
      session$sendCustomMessage( "simSelect", list( from = graph$relationships$from[e],
                                                    to = graph$relationships$to[e],
                                                    label = graph$relationships$label[e],
                                                    id = graph$relationships$id[e] ) )
    }
    session$sendCustomMessage( "setFromImgIDX", ifelse( is.null(payload$old_from), 1, input$from_img_idx ) )
    session$sendCustomMessage( "setToImgIDX", ifelse( is.null(payload$old_to), 1, input$to_img_idx ) )
  } else {
    visNetworkProxy( "graph" ) %>%
      visRemoveEdges( payload$original_graph$relationships$id ) %>%
      visRemoveNodes( payload$original_graph$nodes$id ) %>%
      visSetTitle( submain = "No remaining nodes" )
  }
})

#"copy" reactive
# copies/converts images to tempdir on new graph draw
start_copy <- observeEvent( react$copy, {
  nodes <- payload$graph$nodes %>%
    filter( label == "Image" ) %>%
    select( -id, -label ) %>%
    unnest( cols = c(data) )
  withProgress( message = paste0( 'Copying Images...[1/', nrow(nodes), ']' ), value = 0, {
    for( i in 1:nrow( nodes ) ) {
      # increment progress bar
      setProgress( i / nrow(nodes), message = paste0( 'Copying Images...[', i, '/', nrow(nodes), ']' ) )
      s3_to_tmp( nodes$source_file[i], nodes$uuid[i], pars )
    }
  })
}, ignoreInit = T)

#"edge_id" (input) reactive
# sets from/to/edge _meta payloads
watch_graph_click <- observeEvent( input$edge_id, {
  if( input$edge_id != 'EDIT SINGLE' ) {
      if( !input$edge_label %in% c( 'HAS_ENCOUNTER', 'HAS_IMAGE' ) ) {
      payload$from <- payload$graph$nodes %>% filter( id == input$edge_from_id ) %>% select( -id, -label ) %>% unnest( cols = c(data) )
      payload$to <- payload$graph$nodes %>% filter( id == input$edge_to_id )  %>% select( -id, -label ) %>% unnest( cols = c(data) )
      payload$edge_meta <- payload$graph$relationships %>% filter( id == input$edge_id )
    }
  } else {
      payload$from <- payload$graph$nodes %>% filter( id == input$edge_from_id ) %>% select( -id, -label ) %>% unnest( cols = c(data) )
      payload$to <- NULL
      payload$edge_meta <- NULL
  }
})

#"from" reactive
# sets from viewer img index
from <- observeEvent( payload$from, {
  if( !is.null(payload$from) & !is.null(payload$old_from) ) {
    if( payload$old_from %in% payload$from$id ) {
      session$sendCustomMessage( "setFromImgIDX", input$from_img_idx )
    } else {
      session$sendCustomMessage( "setFromImgIDX", 1 )
    }
  } else {
    session$sendCustomMessage( "setFromImgIDX", 1 )
  }  
}, ignoreNULL = F )

# "from_img_idx" (input) reactive
# populates from viewer
# updates input field values from meta
# return svgPanZoom 
draw_from <- eventReactive( input$from_img_idx, {
  if( !is.null(payload$from ) ) {
    payload$from_meta <- payload$from %>% slice( input$from_img_idx )
    payload$old_from <- payload$from_meta$id
    img <- payload$from_meta
    output$from_id <- renderText({ paste0( img %>% pull(uuid), " [", input$from_img_idx, "/", nrow(payload$from), "]" ) })
    output$from_path <- renderText({ img %>% pull(source_file) })
    output$from_exif_date <- renderText({ img %>% pull(camera_date) })
    updateDateInput( session, "from_date", label = NULL, value = img %>% pull(date) )
    updateCheckboxInput( session, "from_unusable", label = NULL, value = ifelse( is.na( img %>% .$unusable ), F, img %>% pull(unusable) ) )
    updateCheckboxInput( session, "from_reviewed", label = NULL, value = ifelse( is.na( img %>% .$reviewed ), F, img %>% pull(reviewed) ) )
    updateTextInput( session, "from_region", label = NULL, value = img %>% pull(region) )
    return( draw_img( img ) )
  } else {
    payload$old_from <- NULL
    output$from_id <- renderText({ "" })
    output$from_path <- renderText({ "" })
    output$from_exif_date <- renderText({ "" })
    updateDateInput( session, "from_date", label = NULL, value = NA )
    updateCheckboxInput( session, "from_unusable", label = NULL, value = F )
    updateCheckboxInput( session, "from_reviewed", label = NULL, value = F )
    updateTextInput( session, "from_region", label = NULL, value = "" )
    return(NULL)
  }
})

#"to" reactive
# sets to viewer img index
to <- observeEvent( payload$to, {
  if( !is.null(payload$to) & !is.null(payload$old_to) ) {
    if( payload$old_to %in% payload$to$id ) {
      session$sendCustomMessage( "setToImgIDX", input$to_img_idx )
    } else {
      session$sendCustomMessage( "setToImgIDX", 1 )
    }
  } else {
    session$sendCustomMessage( "setToImgIDX", 1 )
  }
}, ignoreNULL = F )

# "to_img_idx" (input) reactive
# populates to viewer
# updates input field values from meta
# return svgPanZoom 
draw_to <- eventReactive( input$to_img_idx, {
  if( !is.null(payload$to ) ) {
    payload$to_meta <- payload$to %>% slice( input$to_img_idx )
    payload$old_to <- payload$to_meta$id
    img <- payload$to_meta
    output$to_id <- renderText({ paste0( img %>% pull(uuid), " [", input$to_img_idx, "/", nrow(payload$to), "]" ) })
    output$to_path <- renderText({ img %>% pull(source_file) })
    output$to_exif_date <- renderText({ img %>% pull(camera_date) })
    updateDateInput( session, "to_date", label = NULL, value = img %>% pull(date) )
    updateCheckboxInput( session, "to_unusable", label = NULL, value = ifelse( is.na( img %>% .$unusable ), F, img %>% pull(unusable) ) )
    updateCheckboxInput( session, "to_reviewed", label = NULL, value = ifelse( is.na( img %>% .$reviewed ), F, img %>% pull(reviewed) ) )
    updateTextInput( session, "to_region", label = NULL, value = img %>% pull(region) )
    return( draw_img( img ) )
  } else {
    output$to_id <- renderText({ "" })
    payload$old_to <- NULL
    output$to_path <- renderText({ "" })
    output$to_exif_date <- renderText({ "" })
    updateDateInput( session, "to_date", label = NULL, value = NA )
    updateCheckboxInput( session, "to_unusable", label = NULL, value = F )
    updateCheckboxInput( session, "to_reviewed", label = NULL, value = F )
    updateTextInput( session, "to_region", label = NULL, value = "" )
    return(NULL)
  }
})

#"edge_meta" reactive
# populates edge viewer
# updates input values from meta
draw_classification <- observeEvent( payload$edge_meta, {
  if( !is.null(payload$edge_meta ) ) {
    updateRadioButtons( session, "label", label = NULL, choices = NULL, selected = ifelse( payload$edge_meta$label == "VIRTUAL", "UNSURE", payload$edge_meta$label ) )
    updateSelectInput( session, "basis", label = NULL, choices = NULL, selected = ifelse( is.na( payload$edge_meta$basis ), "", payload$edge_meta$basis ) )
    updateCheckboxInput( session, "reviewed", label = NULL, value = ifelse( is.na( payload$edge_meta$reviewed ), F, payload$edge_meta$reviewed ) )
    output$score <- renderText({ ifelse( is.na( payload$edge_meta$score ), "", paste0("Score: ", round(as.numeric(payload$edge_meta$score), 2)) ) })
  } else {
    updateRadioButtons( session, "label", label = NULL, choices = NULL, selected = "UNSURE" )
    updateSelectInput( session, "basis", label = NULL, choices = NULL, selected = "" )
    updateCheckboxInput( session, "reviewed", label = NULL, value = F )
  }
}, ignoreNULL = F )

#"save_from" (input) reactive
# updates node in database if any property values have changed
# triggers re-execution of "query" payload
# and update of graph
update_from <- observeEvent( input$save_from, {
  if( !is.null(payload$from_meta) ) {
    if( input$from_region != ifelse( is.na( payload$from_meta$region ), F, payload$from_meta$region ) | ifelse( length(input$from_date) == 0, F, as.character(input$from_date) ) != ifelse( is.na( payload$from_meta$date ), F, as.character(payload$from_meta$date) ) | input$from_unusable != ifelse( is.na( payload$from_meta$unusable ), F, payload$from_meta$unusable ) | input$from_reviewed != ifelse( is.na( payload$from_meta$reviewed ), F, payload$from_meta$reviewed ) ) {
      withProgress( message = "Updating Database...", value = 0, {
        payload$original_graph <- payload$graph
        #Condition update on setting
        if( settings$update_single_all == "All" & ( settings$aggregate_by == "Duplicate/Cropped" | settings$aggregate_by == "Encounter" ) ) {
          update_node( payload$from$uuid, input$from_region, ifelse( length(input$from_date) != 0, as.character(input$from_date), "null" ), ifelse( input$from_unusable == F, "null", input$from_unusable ), ifelse( input$from_reviewed == F, "null", input$from_reviewed ), con )
        } else{
          update_node( payload$from_meta$uuid, input$from_region, ifelse( length(input$from_date) != 0, as.character(input$from_date), "null" ), ifelse( input$from_unusable == F, "null", input$from_unusable ), ifelse( input$from_reviewed == F, "null", input$from_reviewed ), con )
        }
        react$run <- ifelse( is.null( react$run ), 0, react$run + 1 )
      })
    }
  }
})

#"save_to" (input) reactive
# updates node in database if any properties have changed
# triggers re-execution of "query" payload
# and update of graph
update_to <- observeEvent( input$save_to, {
  if( !is.null(payload$to_meta) ) {
    if( input$to_region != ifelse( is.na( payload$to_meta$region ), F, payload$to_meta$region ) | ifelse( length(input$to_date) == 0, F, as.character(input$to_date) ) != ifelse( is.na( payload$to_meta$date ), F, as.character(payload$to_meta$date) ) | input$to_unusable != ifelse( is.na( payload$to_meta$unusable ), F, payload$to_meta$unusable ) | input$to_reviewed != ifelse( is.na( payload$to_meta$reviewed ), F, payload$to_meta$reviewed ) ) {
      withProgress( message = "Updating Database...", value = 0.5, {
        payload$original_graph <- payload$graph
        #Condition update on setting
        if( settings$update_single_all == "All" & ( settings$aggregate_by == "Duplicate/Cropped" | settings$aggregate_by == "Encounter" ) ) {
          update_node( payload$to$uuid, input$to_region, ifelse( length(input$to_date) != 0, as.character(input$to_date), "null" ), ifelse( input$to_unusable == F, "null", input$to_unusable ), ifelse( input$to_reviewed == F, "null", input$to_reviewed ), con )
        } else{
          update_node( payload$to_meta$uuid, input$to_region, ifelse( length(input$to_date) != 0, as.character(input$to_date), "null" ), ifelse( input$to_unusable == F, "null", input$to_unusable ), ifelse( input$to_reviewed == F, "null", input$to_reviewed ), con )
        }
        react$run <- ifelse( is.null( react$run ), 0, react$run + 1 )
      })
    }
  }
})

#"classify_label" (input) reactive
# updates edge in database
# triggers re-execution of "query" payload
# and update of graph
update_classification <- observeEvent( input$classify_label, {
  withProgress( message = "Updating Database...", value = 0.5, {
    payload$original_graph <- payload$graph
    update_edge( payload$from$uuid[input$from_img_idx], payload$to$uuid[input$to_img_idx], input$label, input$basis, input$reviewed, con, payload )
    react$run <- ifelse( is.null( react$run ), 0, react$run + 1 )
  })
})

#"keydown" (input) reactive
# space bar triggers
# L/R arrows navigate edges (skipping to next unreviewed if present)
# simulates graph select on prev/next arrow keydown (this then populates edge viewer)
# 'x','c' navigate 'from' images for grouped sets
# ',','.' navigate 'to' images for grouped sets
keydown <- observeEvent( input$keys, {
  if( ifelse( is.null( input$keys$`32` ), F, input$keys$`32` ) ) { # spacebar
    #TODO: DISABLE SPACE BAR UNTIL BUTTON IS PRESSED?
    if(react$active_tab == "Browse" ) {
      session$sendCustomMessage( "nextFolder", list( val = 'bar' ) )
      session$sendCustomMessage( "simSelect", list( from = NULL, to = NULL, label = NULL, id = NULL ) )
    } else if (react$active_tab == "Process Task Results") {
      session$sendCustomMessage( "nextTaskResult", list( val = 'bar' ) )
    }
  } else if( ( ifelse( is.null( input$keys$`37` ), F, input$keys$`37` ) | ifelse( is.null( input$keys$`39` ), F, input$keys$`39` ) ) & !is.null(payload$graph$relationships) & ifelse( is.null(payload$graph$relationships), F, length( payload$graph$relationships %>% filter( chosen == T & hidden != T ) ) ) ) { #L/R arrows
    #TODO: make this cycle through nodes if they are selected instead
    relationships <- payload$graph$relationships %>% filter( chosen == T & hidden != T )
    i <- ifelse( !length(input$edge_id) | ifelse( is.null(input$edge_id), F, input$edge_id ) == "EDIT SINGLE", 1, which( relationships$id == input$edge_id ) )
    unreviewed_i <- which( relationships$reviewed != T | is.na( relationships$reviewed )  )
    if( ifelse( is.null( input$keys$`37` ), F, input$keys$`37` ) ) {  # left arrow
      if( length(unreviewed_i) > 0 ) {
        i <- ifelse(  i >= max(unreviewed_i), min(unreviewed_i), unreviewed_i[which( unreviewed_i >= i + 1 )][1] )
      } else {
        i <- ifelse(  i == 1, length( relationships$id ), i - 1 )
      }
    } else if( ifelse( is.null( input$keys$`39` ), F, input$keys$`39` ) ) {  # right arrow
      if( length(unreviewed_i) > 0 ) {
        i <- ifelse(  i <= min(unreviewed_i), max(unreviewed_i), rev(unreviewed_i[which( unreviewed_i <= i - 1 )])[1] )
      } else {
        i <- ifelse( i == length( relationships$id ), 1, i + 1 )
      }
    }
    if(react$active_tab == "Browse" ) {
      visNetworkProxy( "graph" ) %>% visSetSelection( edgesId = relationships$id[i] )
      #can't get on click to fire through visSetSelection, so doing manually
      session$sendCustomMessage( "simSelect", list( from = relationships$from[i], to = relationships$to[i], label = relationships$label[i], id = relationships$id[i] ) )
    }
  } else if( ( ifelse( is.null( input$keys$`88` ), F, input$keys$`88` ) | ifelse( is.null( input$keys$`67` ), F, input$keys$`67` ) ) & !is.null(payload$graph) & !is.null(payload$from) & react$active_tab == "Browse" ) {
    nodes <- payload$from
    j <- input$from_img_idx
    if( ifelse( is.null( input$keys$`88` ), F, input$keys$`88` ) ) {  # x
      j <- ifelse(  j == 1, length( nodes$id ), j - 1 )
    } else if( ifelse( is.null( input$keys$`67` ), F, input$keys$`67` ) ) {  # c
      j <- ifelse( j == length( nodes$id ), 1, j + 1 )
    }
      session$sendCustomMessage( "setFromImgIDX", j )
  } else if( ( ifelse( is.null( input$keys$`88` ), F, input$keys$`88` ) | ifelse( is.null( input$keys$`67` ), F, input$keys$`67` ) ) & !is.null(payload$graph) & !is.null(payload$match_from) & react$active_tab == "Process Task Results" ) {
    nodes <- payload$match_from
    j <- input$match_from_img_idx
    if( ifelse( is.null( input$keys$`88` ), F, input$keys$`88` ) ) {  # x
      j <- ifelse(  j == 1, length( nodes$id ), j - 1 )
    } else if( ifelse( is.null( input$keys$`67` ), F, input$keys$`67` ) ) {  # c
      j <- ifelse( j == length( nodes$id ), 1, j + 1 )
    }
    session$sendCustomMessage( "setMatchFromImgIDX", j )
  } else if( ( ifelse( is.null( input$keys$`188` ), F, input$keys$`188` ) | ifelse( is.null( input$keys$`190` ), F, input$keys$`190` ) ) & !is.null(payload$graph) & !is.null(payload$to) & react$active_tab == "Browse" ) {
    nodes <- payload$to
    j <- input$to_img_idx
    if( ifelse( is.null( input$keys$`188` ), F, input$keys$`188` ) ) {  # <
      j <- ifelse(  j == 1, length( nodes$id ), j - 1 )
    } else if( ifelse( is.null( input$keys$`190` ), F, input$keys$`190` ) ) {  # >
      j <- ifelse( j == length( nodes$id ), 1, j + 1 )
    }
    session$sendCustomMessage( "setToImgIDX", j )
  } else if( ( ifelse( is.null( input$keys$`188` ), F, input$keys$`188` ) | ifelse( is.null( input$keys$`190` ), F, input$keys$`190` ) ) & !is.null(payload$graph) & !is.null(payload$match_to) & react$active_tab == "Process Task Results" ) {
    nodes <- payload$match_to
    j <- input$match_to_img_idx
    if( ifelse( is.null( input$keys$`188` ), F, input$keys$`188` ) ) {  # <
      j <- ifelse( j == 1, length( nodes$id ), j - 1 )
    } else if( ifelse( is.null( input$keys$`190` ), F, input$keys$`190` ) ) {  # >
      j <- ifelse( j == length( nodes$id ), 1, j + 1 )
    }
    session$sendCustomMessage( "setMatchToImgIDX", j )
  } else if( ifelse( is.null( input$keys$`83` ), F, input$keys$`83` ) ) { #s
    if(react$active_tab == "Browse" ) {
      updateSelectInput( session, "label", label = NULL, choices = NULL, selected = "IS_SAME" )
    } else if (react$active_tab == "Process Task Results") {
      updateSelectInput( session, "match_label", label = NULL, choices = NULL, selected = "IS_SAME" )
    }
  } else if( ifelse( is.null( input$keys$`85` ), F, input$keys$`85` ) ) { #u
    if(react$active_tab == "Browse" ) {
      updateSelectInput( session, "label", label = NULL, choices = NULL, selected = "UNSURE" )
    } else if (react$active_tab == "Process Task Results") {
      updateSelectInput( session, "match_label", label = NULL, choices = NULL, selected = "UNSURE" )
    }
  } else if( ifelse( is.null( input$keys$`78` ), F, input$keys$`78` ) ) { #n
    if(react$active_tab == "Browse" ) {
      updateSelectInput( session, "label", label = NULL, choices = NULL, selected = "NOT_SAME" )
    } else if (react$active_tab == "Process Task Results") {
      updateSelectInput( session, "match_label", label = NULL, choices = NULL, selected = "NOT_SAME" )
    }
  }
})

#"refresh" (input) reactives
# updates "Database Statistics" section
# populates and triggers folder_list
db_stats <- observeEvent( input$refresh, {
  withProgress( message = "Calculating Statistics...", value = 0, {
    "CALL gds.graph.create.cypher('valid-images', 'MATCH (n:Image) WHERE COALESCE(n.unusable, false) <> true AND COALESCE(n.reviewed, false) = true RETURN id(n) AS id', 'MATCH (n:Image) WHERE COALESCE(n.unusable, false) <> true AND COALESCE(n.reviewed, false) = true WITH n MATCH (n:Image)-[r:IS_SAME]-(m:Image) WHERE (r.basis = \\'duplicate\\' OR r.basis = \\'cropped\\') AND COALESCE(r.reviewed, false) = true RETURN id(n) AS source, id(m) AS target',{validateRelationships: false})" %>% cypher( con, "row" )
    img_count_query <- paste0( "CALL gds.wcc.stream('valid-images') ",
                               "YIELD nodeId, componentId ",
                               "WITH componentId, count(*) AS size ",
                               "RETURN count(componentId) AS c" )
    react$valid_img_count <- img_count_query %>% cypher( con, "row" ) %>% pluck("c") %>% pull(value)
    "CALL gds.graph.drop('valid-images') YIELD graphName" %>% cypher( con, "row" )
    setProgress( value = 1/3 )

    unreviewed_img_count_query <- paste0( "MATCH (img:Image) ",
                                          "WHERE COALESCE(img.unusable, false) <> true AND COALESCE(img.reviewed, false) <> true ",
                                          "WITH COUNT(img) AS c ",
                                          "RETURN c" )
    react$unreviewed_img_count <- unreviewed_img_count_query %>% cypher( con, "row" ) %>% pluck("c") %>% pull(value)
    setProgress( value = 2/3 )

    date_query <- paste0( "MATCH (i:Image) WHERE COALESCE(i.date, false) <> false WITH DISTINCT i.date AS dates RETURN dates ORDER BY dates")
    dates <-  date_query %>% cypher( con, "row" ) %>%
      pluck("dates") %>%
      mutate( year = year( value ),
              month = month( value, label = T ),
              n_month = month( value ),
              day = day( value ) )
    date_list <- list()
    for( i in 1:length(unique(dates$year)) ) {
      date_list[[i]]<-list()
      date_list[[i]]$text <- unique(dates$year)[i]
      date_list[[i]]$data <- list( query = paste0("img.date.year = ", unique(dates$year)[i] ) )
      date_list[[i]]$children <- list()
      tmp1 <- dates %>% filter( year == unique(dates$year)[i] )
      for( j in 1:length(unique(tmp1$month)) ) {
        date_list[[i]]$children[[j]] <- list()
        date_list[[i]]$children[[j]]$text <- as.character(unique(tmp1$month)[j])
        date_list[[i]]$children[[j]]$data <- list( query = paste0( "img.date.year = ", unique(dates$year)[i], " AND img.date.month = ", unique(tmp1$n_month)[j] ) )
        date_list[[i]]$children[[j]]$children <- list()
        tmp2 <- tmp1 %>% filter( month == unique(tmp1$month)[j] )
        for( k in 1:nrow(tmp2) ) {
          date_list[[i]]$children[[j]]$children[[k]] <- list()
          date_list[[i]]$children[[j]]$children[[k]]$text <- tmp2 %>% pull(day) %>% .[k]
          date_list[[i]]$children[[j]]$children[[k]]$data <- list( query = paste0( "img.date = date('", tmp2 %>% pull( value ) %>% .[k], "')" ) )
        }
      }
    }
    react$date_list <- date_list
  })
}, ignoreNULL = F, ignoreInit = T )

#"date_list" reactive
# populates date jstree
draw_date_tree <- eventReactive( react$date_list, {
  jstree( react$date_list, checkboxes = T )
})

#"options" (input) reactive
# shows modal
draw_options_modal <- observeEvent( input$options, {
  showModal( modalDialog( title = "Options", 
                          radioButtons( "aggregate_by",
                                        "Aggregate By",
                                        choices = c("None","Duplicate/Cropped","Encounter","Individual"),
                                        selected = settings$aggregate_by,
                                        inline = T ),
                          radioButtons( "update_single_all",
                                        "Update [Single/All] Aggregated Nodes (Duplicate/Cropped/Encounter only)",
                                        choices = c("Single","All"),
                                        selected = settings$update_single_all,
                                        inline = T ),
                          checkboxGroupInput( "show_nodes",
                                              "Show Nodes",
                                              choices = list( "Unusable" = "unusable",
                                                              "Encounter" = "Encounter",
                                                              "Event" = "Event"),
                                              selected = names(settings$show_nodes)[which(settings$show_nodes)],
                                              inline = TRUE ),
                          checkboxGroupInput( "show_edges",
                                              "Show Edges",
                                              choices = list( "IS SAME" = "IS_SAME",
                                                              "UNSURE" = "UNSURE",
                                                              "NOT SAME" = "NOT_SAME" ),
                                              selected = names(settings$show_edges)[which(settings$show_edges)],
                                              inline = TRUE ),
                          checkboxInput( "zoom_to_fin",
                                         "Zoom to fin",
                                         value = settings$zoom_to_fin ),
                          actionButton( "refresh_graph", label = "Refresh Graph" ),
                          easyClose = TRUE,
                          footer = NULL ) )
})

#"aggregate_by" (input) reactive
# updates setting
# triggers run if a query is present
#TODO: WARN IF CHANGE WILL CREATE BIG GRAPH!
update_aggregate_by <- observeEvent( input$aggregate_by, {
  if( !is.null(payload$query) & !settings$aggregate_by == input$aggregate_by ) {
    settings$aggregate_by <- input$aggregate_by
    react$draw <- NULL
    react$run <- ifelse( is.null( react$run ), 0, react$run + 1 )
  } else {
    settings$aggregate_by <- input$aggregate_by
  }
}, ignoreNULL = T, ignoreInit = T )

#"update_single_all" (input) reactive
# updates setting
# triggers draw
update_update_single_all <- observeEvent( input$update_single_all, {
  if( !is.null(payload$query) & !settings$update_single_all == input$update_single_all) {
    settings$update_single_all <- input$update_single_all
    react$draw <- ifelse( is.null( react$draw ), NULL, react$draw + 1 )
  } else {
    settings$update_single_all <- input$update_single_all
  }
}, ignoreNULL = T, ignoreInit = T )

#"show_nodes" (input) reactive
# updates setting
# triggers style
update_show_nodes <- observeEvent( input$show_nodes, {
  if( !is.null(payload$query) & !setequal( input$show_nodes, names(settings$show_nodes)[which(settings$show_nodes)] ) ) {
    settings$show_nodes[input$show_nodes] <- T
    settings$show_nodes[!names(settings$show_nodes) %in% input$show_nodes] <- F
    react$style <- ifelse( is.null( react$style ), NULL, react$style + 1 )
  } else {
    settings$show_nodes[input$show_nodes] <- T
    settings$show_nodes[!names(settings$show_nodes) %in% input$show_nodes] <- F
  }
}, ignoreNULL = F, ignoreInit = T )

#"show_edges" (input) reactive
# updates setting
# triggers style
update_show_edges <- observeEvent( input$show_edges, {
  if( !is.null(payload$query) & !setequal( input$show_edges, names(settings$show_edges)[which(settings$show_edges)] ) ) {
    settings$show_edges[input$show_edges] <- T
    settings$show_edges[!names(settings$show_edges) %in% input$show_edges] <- F
    react$style <- ifelse( is.null( react$style ), NULL, react$style + 1 )
  } else {
    settings$show_edges[input$show_edges] <- T
    settings$show_edges[!names(settings$show_edges) %in% input$show_edges] <- F
  }
}, ignoreNULL = F, ignoreInit = T )

#"zoom_to_fin" (input) reactive
# updates setting
# triggers draw
update_zoom_to_fin <- observeEvent( input$zoom_to_fin, {
  if( !is.null(payload$query) & !settings$zoom_to_fin == input$zoom_to_fin ) {
    settings$zoom_to_fin <- input$zoom_to_fin
    react$draw <- ifelse( is.null( react$draw ), NULL, react$draw + 1 )
  } else {
    settings$zoom_to_fin <- input$zoom_to_fin
  }
}, ignoreNULL = T, ignoreInit = T )

#"refresh_graph" (input) reactive
# triggers draw
refresh_graph <- observeEvent( input$refresh_graph, {
  if( !is.null(payload$query) ) {
      react$draw <- NULL
      react$run <- ifelse( is.null( react$run ), NULL, react$run + 1 )
  }
}, ignoreNULL = T, ignoreInit = T )

# OUTPUTS
output$valid_images <- renderText({ react$valid_img_count })
output$unreviewed_images <- renderText({ react$unreviewed_img_count })
output$date_tree <- renderJstree({ draw_date_tree() })
output$graph <- renderVisNetwork({ draw_results() })
output$from_image <- renderSvgPanZoom({ draw_from() })
output$to_image <- renderSvgPanZoom({ draw_to() })

Inputs 1{.sidebar}

Database Statistics:

#Statistics
div( "Valid Images: ", textOutput( "valid_images", inline = T ) )
div( "Unreviewed Images: ", textOutput( "unreviewed_images", inline = T ) )
actionLink( "refresh", label = "Refresh" )

Select an action:

#Sidebar Inputs
textAreaInput( "manual_query", "Query")
br()
actionButton( "run_manual_query", label = "Run Query" )
hr()
actionButton( "query_fix_edges", label = "Query Next Folder [????]" )
hr()
wellPanel( jstreeOutput( "date_tree" ),
           style = "
           overflow-y:scroll;
           height: 15vh;
           padding: 0px 19px;
           background-color: white;
           border:  1px solid #cccccc;
           border-radius: 4px
           " )
actionButton( "options", label = "Options" )

Row {data-height=350}

Graph Explorer

#withSpinner()?
visNetworkOutput( "graph" )

Row {data-height=650}

Data View

fillRow( height = 650, flex = c( 2, 1, 2 ),
         fillCol( flex = c( 1, 1, 1, 1, 1, 7, 1 ),
                  fillRow( flex = c( 1, 3 ),
                           "Image UUID: ", textOutput( "from_id", inline = T ) ),
                  fillRow( flex = c( 1, 3 ),
                           "Image path: ", textOutput( "from_path", inline = T ) ),
                  fillRow( flex = c( 1, 3 ),
                           "EXIF date: ", textOutput( "from_exif_date", inline = T ) ),
                  fillRow( flex = c( 1, 3 ),
                           "Date: ", dateInput( "from_date", label = NULL, value = NA ) ),
                  fillRow( flex = c( 1, 3 ),
                           "Region: ", textInput( "from_region", label = NULL, value = NULL ) ),
                  svgPanZoomOutput( "from_image" ),
                  fillRow( flex = c( 2, 2, 2 ), checkboxInput( "from_unusable", "Unusable" ), checkboxInput( "from_reviewed", "Reviewed" ), actionButton( "save_from", "Update" ) ) ),
         fillCol( flex = c(0.5,2,1,0.25,0.5,1,1),
                  fillRow( flex = c( 1, 3, 1 ), "", "Classification", "" ),
                  fillRow( flex = c( 1, 3, 1 ), "", radioButtons( "label", label = NULL, choices = c( "IS SAME" = "IS_SAME", "UNSURE" = "UNSURE", "NOT SAME" = "NOT_SAME" ), selected = "UNSURE" ), "" ),
                  fillRow( flex = c( 1, 5, 1 ), "", selectInput( "basis", "Basis",
                                                                 choices = c( "", "notch match" = "notch match", "pigment match" = "pigment match", "burst image" = "burst image", "tag presence" = "tag presence", "duplicate" = "duplicate", "cropped" = "cropped", "service" = "service" ) ), "" ),
                  fillRow(),
                  fillRow( flex = c( 1, 3, 1), "", textOutput( "score", inline = T ), ""),
                  fillRow( flex = c( 1, 3, 1 ), "", checkboxInput( "reviewed", "Reviewed" ), "" ),
                  fillRow( flex = c( 1, 3, 1 ), "", actionButton( "classify_label", "Submit" ), "" ) ),
         fillCol( flex = c( 1, 1, 1, 1, 1, 7, 1 ),
                  fillRow( flex = c( 1, 3 ),
                           "Image UUID: ", textOutput( "to_id", inline = T ) ),
                  fillRow( flex = c( 1, 3 ),
                           "Image path: ", textOutput( "to_path", inline = T ) ),
                  fillRow( flex = c( 1, 3 ),
                           "EXIF date: ", textOutput( "to_exif_date", inline = T ) ),
                  fillRow( flex = c( 1, 3 ),
                           "Date: ", dateInput( "to_date", label = NULL, value = NA ) ),
                  fillRow( flex = c( 1, 3 ),
                           "Region: ", textInput( "to_region", label = NULL, value = NULL ) ),
                  svgPanZoomOutput( "to_image" ),
                  fillRow( flex = c( 2, 2, 2 ), checkboxInput( "to_unusable", "Unusable" ), checkboxInput( "to_reviewed", "Reviewed" ), actionButton( "save_to", "Update" ) ) )
         )

Process Task Results

#LISTENERS

#"active_tab" react
# sets "query" payload
# triggers "query_match_result"
read_match_result <- observeEvent( react$active_tab, {
  if( react$active_tab == "Process Task Results" ) {
    # re-trigger to refresh
    react$task_result <- NULL
    react$task_result <- read_json(task_results_file)[[1]]
  }
}, ignoreNULL = F, ignoreInit = T )

throb_from_query <- observeEvent( react$task_result, {
  payload$match_edge_meta <- payload$match_from <- payload$match_to <- NULL
  react$match_from_throb = T
  react$match_to_throb = T
  react$continue_query <- ifelse( is.null( react$continue_query ), 0, react$continue_query + 1 )
}, ignoreNULL = T, ignoreInit = T)


#"continue_match" reactive
# executes query
# triggers "review_match" with increment
run_match_query <- observeEvent( react$continue_query, {

  # query db with progress bar         
  withProgress(message = 'Querying Database...', value = 0, {
    match <- react$task_result

    #this check is relatively time consuming
    is_connected <- paste0("MATCH (img1:Image {d_uuid: '", match$from, "'}), (img2:Image {d_uuid: '", match$to, "'}) WHERE COALESCE(img1.unusable, false) = false AND COALESCE(img2.unusable, false) = false RETURN COUNT(img1) = 0 OR COUNT(img2) = 0 AS valid") %>%
      cypher(con, type="row") %>%
      pluck("valid") %>%
      pull(value) | paste0( "MATCH p=allShortestPaths((img1:Image {d_uuid: '", match$from, "'})-[:IS_SAME|NOT_SAME*]-(img2:Image{d_uuid: '", match$to, "'})) RETURN count(nodes(p)) AS c") %>%
      cypher(con, type="row") %>%
      pluck("c") %>%
      pull(value) > 0 | paste0( "MATCH (img1:Image {d_uuid: '", match$from, "'}) ",
                       "WHERE COALESCE(img1.unusable, false) <> true ",
                       "OPTIONAL MATCH (img1)-[r:IS_SAME]-(j:Image) WHERE r.basis IN ['duplicate', 'cropped'] ",
                       "WITH COLLECT(img1) + COLLECT(j) AS imgs1 ",
                       "MATCH (img2:Image {d_uuid: '", match$to,"'}) ",
                       "WHERE COALESCE(img2.unusable, false) <> true ",
                       "OPTIONAL MATCH (img2)-[r:IS_SAME]-(j:Image) WHERE r.basis IN ['duplicate', 'cropped'] ",
                       "WITH imgs1, COLLECT(img2) + COLLECT(j) AS imgs2 ",
                       "UNWIND imgs1 AS img1 UNWIND imgs2 AS img2 ",
                       "MATCH (img1)-[r:UNSURE]-(img2) ",
                       "RETURN COUNT(DISTINCT r) AS c") %>%
      cypher(con, type="row") %>%
      pluck("c") %>%
      pull(value) > 0

    incProgress(0.25)

    #TODO: adjustable LIMIT 5?
    if(!is_connected) {
      query <- paste0( "MATCH (img1:Image {d_uuid: '", match$from, "'}) ",
                       "WHERE COALESCE(img1.unusable, false) <> true ",
                       "OPTIONAL MATCH (img1)-[rel1:IS_SAME*1..5]-(same1: Image) ",
                       "WHERE ALL(rel in rel1 WHERE NOT rel.basis IN ['duplicate', 'cropped']) ",
                       "AND COALESCE(same1.unusable, false) <> true ",
                       "WITH img1, rel1, same1 LIMIT 5 ",
                       "WITH COLLECT(img1) + COLLECT(same1) AS imgs, COLLECT(rel1) AS rels ",
                       "WITH imgs, rels ",
                       "MATCH (img2:Image {d_uuid:'", match$to,"'}) ",
                       "WHERE COALESCE(img2.unusable, false) <> true ",
                       "OPTIONAL MATCH (img2)-[rel2:IS_SAME*1..5]-(same2: Image) ",
                       "WHERE ALL( rel IN rel2 WHERE NOT rel.basis IN ['duplicate', 'cropped']) ",
                       "AND COALESCE(same2.unusable, false) <> true ",
                       "WITH imgs, rels, img2, rel2, same2 LIMIT 5 ",
                       "WITH imgs + COLLECT(img2) + COLLECT(same2) AS imgs, rels + COLLECT(rel2) AS rels ",
                       # had something like this to get most connected nodes
                       #"WITH img1, img2, rels1, same1, SIZE((same1)-[:IS_SAME]-(:Image)) as cnt ",
                       #"WITH img1, img2, rels1, same1 ORDER BY cnt DESC LIMIT 5 ",
                       "UNWIND imgs AS img ",
                       "OPTIONAL MATCH (img)-[rel: HAS_ANNOTATION]-(a: Annotation) ",
                       "WITH COLLECT(id(img)) AS ids, imgs + COLLECT(a) AS nodes, rels + COLLECT(rel) AS rels ",
                       "OPTIONAL MATCH (img)-[r]-(j:Image) ",
                       "WHERE id(img) IN ids AND id(j) IN ids WITH nodes, rels + COLLECT(r) AS rels ",
                       "RETURN nodes, rels" )

      # query data from neo4j
      graph <- query %>% cypher( con, "graph" )

      #@todo: move all this into a function
      if( length(graph) ) {
        incProgress(0.5)

        # add potentially empty property columns
        node_cols <- tibble( trailing = NA_character_, leading = NA_character_, image_size = NA_character_, x = NA_character_, y = NA_character_, tip = NA_character_  )
        edge_cols <- tibble( id = NA_character_ , from = NA_character_, to = NA_character_, label = NA_character_, chosen = NA_character_, hidden = NA_character_ )
        # unnest nodes
        graph$nodes <- graph %>%
          pluck("nodes") %>%
          unnest_wider( col = "properties" ) %>%
          add_column( !!!node_cols[!names( node_cols ) %in% names(.)] ) %>%
          mutate( label = unlist(label) %>% .[ . != "DUMMY" ],
                  trailing = map( trailing, ~c( unlist(.) ) ),
                  leading = map( leading, ~c( unlist(.) ) ),
                  image_size = map( image_size, ~c( unlist(.) ) ),
                  x = map( x, ~c( unlist(.) ) ),
                  y = map( y, ~c( unlist(.) ) ),
                  tip = map( tip, ~c( unlist(.) ) ) )

        if(!is.null(graph$relationships)) {
          graph$nodes <- graph$nodes %>%
            left_join( { graph$relationships %>%
                filter( type == "HAS_ANNOTATION" ) %>%
                select(startNode, endNode) %>%
                mutate( has_annot = T ) }, by = c( "id" = "startNode" ) ) %>%
            left_join( {select(., id, image_size, trailing, tip, leading, x, y, )}, by = c( "endNode" = "id" ) ) %>%
            select( -trailing.x, -image_size.x, -leading.x, -x.x, -y.x, -tip.x, -endNode ) %>%
            rename( image_size = image_size.y, trailing = trailing.y, tip = tip.y, leading = leading.y, x = x.y, y = y.y ) %>%
            filter( label != "Annotation" )
        } else {
          graph$nodes <- graph$nodes %>%
            mutate( has_annot = F )
        }

        graph$nodes <- graph$nodes %>%
          distinct( id, .keep_all = T )

        # unnest relationships
        if( !is.null( graph$relationships ) ) {
          graph$relationships <- graph$relationships %>%
            unnest_relationships() %>%
            filter( type != "HAS_ANNOTATION" ) %>%
            #adds "value" column??
            select_if(!names(.) %in% c('value')) %>%
            rename( from = startNode, to = endNode, label = type ) %>%
            add_column( !!!edge_cols[!names( edge_cols ) %in% names(.)] )

          #pseudonodes from relationships (nested tibble)
          igraph_object<- graph_from_data_frame( d = graph$relationships %>%
                                                   left_join( graph$nodes %>%
                                                                select( id, date ),
                                                              by=c( "from" = "id" ) ) %>%
                                                   rename( from_date = date ) %>%
                                                   left_join( graph$nodes %>%
                                                                select( id, date ),
                                                              by=c( "to" = "id" ) ) %>%
                                                   rename( to_date = date ) %>%
                                                   filter( label == 'IS_SAME' ) %>%
                                                   select( from, to, everything() ), directed = F, vertices = graph$nodes )

          comp <- groups( components( igraph_object ) ) %>% map_df( ~ tibble( id = as.character(md5(paste0( sort( . ), collapse = ", ") ) ), members = list(.) ) )

          graph$nodes <- graph$nodes %>%
            mutate( group = comp[components( igraph_object )$membership, "id"] %>% pull(id) ) %>%
            nest( data = !group ) %>%
            select( id = group, data ) %>%
            mutate( label = map_chr( data, ~unique( .$label ) ) )

          #drop the relationships we grouped (if there are any)
          if( nrow(graph$relationships) ) {
            graph$relationships <- graph$relationships %>%
              rowwise() %>%
              mutate( keep = map2_lgl( from, to, ~ !any( sapply( comp$members, function(e) is.element( .x, e ) & is.element( .y, e ) ) ) ),
                      from = comp[which( sapply( comp$members, function(e) is.element( from, e ) ) ), "id"] %>% pull(id),
                      to = comp[which( sapply( comp$members, function(e) is.element( to, e ) ) ), "id"] %>% pull(id) ) %>%
              ungroup() %>%
              filter( keep ) %>% select( -keep )
          }
        } else {
          graph$nodes <- graph$nodes %>%
            mutate( group = uuid ) %>%
            nest( data = !group ) %>%
            select( id = group, data ) %>%
            mutate( label = map_chr( data, ~unique( .$label ) ) )
          graph$relationships <- tibble() %>%
            add_column( !!!edge_cols[!names( edge_cols ) %in% names(.)] )
        }
      }

      if( length(graph$nodes) ) {
        incProgress(1)
        payload$graph <- graph
        react$copy <- ifelse( is.null( react$copy ), 0, react$copy + 1 )
        payload$match_from <- graph$nodes %>% slice(1) %>% select( -id, -label ) %>% unnest( cols = c(data) )
        payload$match_to <- graph$nodes %>% slice(2)  %>% select( -id, -label ) %>% unnest( cols = c(data) )
        payload$match_edge_meta <- list(score = react$task_result$score)
      } else {
        result_list <- read_json(task_results_file)[-1]
        write_json( do.call(bind_rows, result_list), task_results_file)
        react$task_result <- result_list[[1]]
      }
    } else {
      result_list <- read_json(task_results_file)[-1]
      write_json( do.call(bind_rows, result_list), task_results_file)
      react$task_result <- result_list[[1]]
    }
  })
})

#"match_from" reactive
# sets from viewer img index
match_from <- observeEvent( payload$match_from, {
  if( !is.null(payload$match_from) ) {
    session$sendCustomMessage( "setMatchFromImgIDX", 1 )
  }
}, ignoreNULL = F, ignoreInit = T )

# "match_from_img_idx" (input) reactive
# populates from viewer
# updates input field values
# return svgPanZoom 
draw_match_from <- eventReactive( input$match_from_img_idx, {
  if( !is.null(payload$match_from ) & !is.null(input$match_from_img_idx) ) {
    img <- payload$match_from %>% slice( input$match_from_img_idx )
    output$match_from_id <- renderText({ paste0( img %>% pull(uuid), " [", input$match_from_img_idx, "/", nrow(payload$match_from), "]" ) })
    react$match_from_throb = F
    return( draw_img( img ) )
  } else {
    output$match_from_id <- renderText({ "" })
    return(NULL)
  }
}, ignoreNULL = F)

#"to" reactive
# sets to viewer img index
match_to <- observeEvent( payload$match_to, {
  if( !is.null(payload$match_to) ) {
    session$sendCustomMessage( "setMatchToImgIDX", 1 )
  }
}, ignoreNULL = F, ignoreInit = T )

# "match_to_img_idx" (input) reactive
# populates to viewer
# updates input field values
# return svgPanZoom 
draw_match_to <- eventReactive( input$match_to_img_idx, {
  if( !is.null(payload$match_to ) & !is.null(input$match_to_img_idx) ) {
    img <- payload$match_to %>% slice( input$match_to_img_idx )
    output$match_to_id <- renderText({ paste0( img %>% pull(uuid), " [", input$match_to_img_idx, "/", nrow(payload$match_to), "]" ) })
    react$match_to_throb = F
    return( draw_img( img ) )
  } else {
    output$match_to_id <- renderText({ "" })
    return(NULL)
  }
}, ignoreNULL = F)

#"match_edge_meta" reactive
# populates edge viewer
# updates input values from meta
draw_match_classification <- observeEvent( payload$match_edge_meta, {
  if( !is.null(payload$match_edge_meta ) ) {
    updateRadioButtons( session, "match_label", label = NULL, choices = NULL, selected = "UNSURE" )
    output$match_score <- renderText({ ifelse( is.na( payload$match_edge_meta$score ), "", paste0("Score: ", round(as.numeric(payload$match_edge_meta$score), 2)) ) })
  } else {
    updateRadioButtons( session, "match_label", label = NULL, choices = NULL, selected = "UNSURE" )
  }
}, ignoreNULL = F )

throb_from_update <- observeEvent( input$match_classify_label, {
  react$match_from_throb = T
  react$match_to_throb = T
  react$continue_update <- ifelse( is.null( react$continue_update ), 0, react$continue_update + 1 )
}, ignoreInit = T)

#"match_classify_label" (input) reactive
# updates edge in database
# triggers next task result
update_match_classification <- observeEvent( react$continue_update, {
  withProgress( message = "Updating Database...", value = 0.5, {
    update_edge( payload$match_from$uuid[1], payload$match_to$uuid[1], input$match_label, 'service', T, con, payload )
    payload$match_edge_meta <- payload$match_from <- payload$match_to <- NULL
    result_list <- read_json(task_results_file)[-1]
    write_json( do.call(bind_rows, result_list), task_results_file)
    if(length(result_list)) {
      react$task_result <- result_list[[1]]
    } else {
      showNotification( "No more tasks!", duration = NULL, type = "warning")
    }
  })
})

throb_from <- observeEvent( react$match_from_throb, {
  if(react$match_from_throb) {
    session$sendCustomMessage( "throbMatchFrom", T )
  }
}, ignoreInit = T )

throb_to <- observeEvent( react$match_to_throb, {
  if(react$match_to_throb) {
    session$sendCustomMessage( "throbMatchTo", T )
  }
}, ignoreInit = T )

output$match_from_image <- renderSvgPanZoom({ draw_match_from() })
output$match_to_image <- renderSvgPanZoom({ draw_match_to() })

Review Match

fillRow( height = 650, flex = c( 2, 1, 2 ),
         fillCol( flex = c( 1, 7 ),
                  fillRow( flex = c( 1, 3 ),
                           "Image UUID: ", textOutput( "match_from_id", inline = T ) ),
                  svgPanZoomOutput( "match_from_image" ) ),
         fillCol( flex = c(0.5,2,0.25,0.5,1),
                  fillRow( flex = c( 1, 3, 1 ), "", "Classification", "" ),
                  fillRow( flex = c( 1, 3, 1 ), "", radioButtons( "match_label", label = NULL, choices = c( "IS SAME" = "IS_SAME", "UNSURE" = "UNSURE", "NOT SAME" = "NOT_SAME" ), selected = "UNSURE" ), "" ),
                  fillRow(),
                  fillRow( flex = c( 1, 3, 1), "", textOutput( "match_score", inline = T ), ""),
                  fillRow( flex = c( 1, 3, 1 ), "", actionButton( "match_classify_label", "Submit" ), "" ) ),
         fillCol( flex = c( 1, 7 ),
                  fillRow( flex = c( 1, 3 ),
                           "Image UUID: ", textOutput( "match_to_id", inline = T ) ),
                  svgPanZoomOutput( "match_to_image" ) )
         )

Create Task

Add Photos

#"upload_photos" (input) reactive
upload <- observeEvent( input$upload_photos, {
  req(input$upload_photos)
  ## change all these to progress bar?
  react$upload_status <- paste( "Found", nrow(input$upload_photos), "valid photos...\n" )
  if( !is.null( pars$api_url ) ) {
    exists <- exists_in_database( pars$api_url, uuid_from_file( input$upload_photos$datapath ) )
    react$upload_status <- paste0( react$upload_status, paste( sum( !exists ), "image(s) not in database...\n" ) )
    for( i in 1:nrow( input$upload_photos[!exists,] ) ) {
      react$upload_status <- paste0( react$upload_status, paste0( "Uploading ", input$upload_photos[!exists, "name"][i], "...\n" ) )
      ## GET PRESIGNED URLS
      ## ACTUALLY DO UPLOAD
      ## ACTUALLY DO REGISTRATION OF IMAGES
      ## STORE NODE IN NEO
    }
  } else {
    react$upload_status <- "Error: api_url not specified."
  }

}, ignoreNULL = T, ignoreInit = T )

# OUTPUTS
output$upload_status <- renderText({ react$upload_status })

Inputs 3{.sidebar}

fileInput( "upload_photos", "Choose Photos",
           multiple = TRUE,
           accept = c( "image/jpeg",
                       "image/png" ) )

Row {data-height=350}

Info

verbatimTextOutput( "upload_status" )

dylanirion/finmatchr documentation built on Nov. 23, 2021, 4:53 a.m.