From 3fe609e32dfb05c3ca0905d040591fe26249c4ff Mon Sep 17 00:00:00 2001 From: albamerdani Date: Thu, 3 Apr 2025 16:30:32 +0200 Subject: [PATCH 1/8] Add pipeline --- .github/workflows/deploy-activity-pattern-shiny.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.github/workflows/deploy-activity-pattern-shiny.yml b/.github/workflows/deploy-activity-pattern-shiny.yml index 8624216..c498166 100644 --- a/.github/workflows/deploy-activity-pattern-shiny.yml +++ b/.github/workflows/deploy-activity-pattern-shiny.yml @@ -29,5 +29,5 @@ jobs: - name: Sync files to the Shiny Server directory run: | mkdir -p ${{ env.shiny-path }} - rsync -av --delete ./repo/shiny-app/ ${{ env.shiny-path }} + rsync -av --delete ./repo/ ${{ env.shiny-path }} touch ${{ env.shiny-path }}/restart.txt From c94c3b6cf4586514851bf2404f7cf40fd590b309 Mon Sep 17 00:00:00 2001 From: hfri Date: Sat, 12 Apr 2025 11:51:19 +0200 Subject: [PATCH 2/8] Included layout changes --- server.R | 5 -- ui.R | 230 ++++++++++++++++++++++++++++++++++++------------------- 2 files changed, 153 insertions(+), 82 deletions(-) diff --git a/server.R b/server.R index 69eef9a..06a82ff 100644 --- a/server.R +++ b/server.R @@ -768,11 +768,6 @@ server <- function(input, output, session) { # Debugging messages message("Debug: Year filtered dataframe has ", nrow(df), " rows") - # Apply the year filter if selected_year is not "All" - if (input$selected_year != "All") { - df <- df %>% filter(format(when, "%Y") == input$selected_year) - } - return(df) # Return the filtered dataframe } }) diff --git a/ui.R b/ui.R index 94a3a62..91b0439 100644 --- a/ui.R +++ b/ui.R @@ -1,23 +1,29 @@ +# Author: Hanna Fricke +# Description: User interface for activity app. +# TO-DO : +# [] DONT HARDCODE METHOD FUTURE BUT BASE IT ON DATA + library(shiny) library(shiny.i18n) # for multilanguage library(shinyjs) library(shinyTree) library(shinybusy) +library(shinyBS) library(shinyWidgets) library(plotly) # multi language + tryCatch({ # try to get online version # i18n <- Translator$new(translation_json_path = "https://focus.sensingclues.org/api/labels/list") # Production Environment i18n <- Translator$new(translation_json_path = "https://focus.test.sensingclues.org/api/labels/list") # Test Environment -}, -error=function(e){ +}, error = function(e) { message("No labels available online, we will use the old ones from disk.") }) -if(!exists("i18n")) { +if (!exists("i18n")) { # use the stored version i18n <- Translator$new(translation_json_path = "translations.json") } @@ -30,110 +36,180 @@ js_lang <- "var language = window.navigator.userLanguage || window.navigator.la ui <- fluidPage( useShinyjs(), shiny.i18n::usei18n(i18n), - extendShinyjs(text=js_lang, functions=c()), + extendShinyjs(text = js_lang, functions = c()), # Get timezone from browser - tags$script("$(document).on('shiny:sessioninitialized', function(event) { + tags$script( + "$(document).on('shiny:sessioninitialized', function(event) { var n = Intl.DateTimeFormat().resolvedOptions().timeZone; - Shiny.onInputChange('user_timezone', n);});"), + Shiny.onInputChange('user_timezone', n);});" + ), # Load custom stylesheet includeCSS("www/style.css"), sidebarLayout( sidebarPanel( width = 3, - HTML(paste0( - "
", - "", - "
" - )), + HTML( + paste0( + "
", + "", + "
" + ) + ), # Custom button styles tags$head( - tags$style("#GetData{background-color:#FB8C00; color:white; font-size:100%}"), - tags$style("#login{background-color:#FB8C00; color:white; font-size:100%}"), - tags$style("#message_more_dates{color: red; font-size: 20px; font-style: italic}"), - tags$style("#downloadData{background-color:#FB8C00; color:white; font-size:100%}"), + tags$style( + "#GetData{background-color:#FB8C00; color:white; font-size:100%}" + ), + tags$style( + "#login{background-color:#FB8C00; color:white; font-size:100%}" + ), + tags$style( + "#message_more_dates{color: red; font-size: 20px; font-style: italic}" + ), + tags$style( + "#downloadData{background-color:#FB8C00; color:white; font-size:100%}" + ), ), h3(i18n$t("labels.obsReport")), uiOutput("userstatus"), - br(), br(), - disabled(dateRangeInput("DateRange", i18n$t("labels.selectPeriod"))), br(), - disabled(div(class = "choosechannel", - id = "GroupListDiv", - pickerInput( - inputId = "GroupList", - label = i18n$t("labels.selectGroup"), - choices = list(), - multiple = TRUE, - options = pickerOptions( - actionsBox = TRUE, noneSelectedText = '', - selectAllText = i18n$t("labels.selectAll"), - deselectAllText = i18n$t("labels.deselectAll")) - ) + br(), + disabled(dateRangeInput("DateRange", i18n$t("labels.selectPeriod"))), + br(), + disabled(div( + class = "choosechannel", + id = "GroupListDiv", + pickerInput( + inputId = "GroupList", + label = i18n$t("labels.selectGroup"), + choices = list(), + multiple = TRUE, + options = pickerOptions( + actionsBox = TRUE, + noneSelectedText = '', + selectAllText = i18n$t("labels.selectAll"), + deselectAllText = i18n$t("labels.deselectAll") + ) + ) )), br(), shinyTree("conceptTree", checkbox = TRUE, theme = "proton"), br(), - disabled(actionButton("GetData", i18n$t("commands.getdata"), icon=NULL)), + disabled(actionButton( + "GetData", i18n$t("commands.getdata"), icon = NULL + )), br() ), - mainPanel( - tags$head( - tags$style(HTML(" + mainPanel( + width = 9, + tags$head(tags$style( + HTML(" .sep { width: 20px; height: 1px; float: left; } - ")) - ), - tabsetPanel(type = "tabs", - tabPanel("Observation Analysis", - sidebarLayout( - sidebarPanel( - selectInput("selected_year", "Select Year:", choices = c("All")), # --> think I need to rewrite to ui output - radioButtons("time_input", "Select time period:", - choices = c("Hourly" = "hourly", "Monthly" = "monthly", "Seasonal" = "season"), - selected = "hourly"), # Set a default value - numericInput("topX", "Number of rows to display:", value = 10, min = 1, step = 1), - radioButtons("method", "Select method of observation:", choices = c("Cameratrap" = "cameratrap", "Animal sighting" = "animal sighting", "Sensor" = "sensor","Other" = "other")), - conditionalPanel( - condition = "input.time_input == 'season'", - numericInput("num_seasons", "Number of Seasons:", value = 1, min = 1), - uiOutput("season_inputs") - ) - ), - mainPanel( - plotlyOutput("combined_plot") - ) - ) - ), - tabPanel(i18n$t("labels.rawConceptsTab"), - fluidRow( - column(12, DT::dataTableOutput("tableRawConcepts")) - ), - div( - style = "position: fixed; top: 45%; left: 60%; transform: translate(-50%, -50%);", - add_busy_spinner(spin = "fading-circle", width = "100px", height = "100px") - ) - ), # endpanel - - tabPanel(i18n$t("labels.rawData"), - br(), - column(2, br(), br(), downloadButton("downloadData", i18n$t("commands.download"))), - fluidRow( - column(12, DT::dataTableOutput("tableRawObservations")) - ), - div( - style = "position: fixed; top: 45%; left: 60%; transform: translate(-50%, -50%);", - add_busy_spinner(spin = "fading-circle", width = "100px", height = "100px") - ) - ) + ") + )), + tabsetPanel( + type = "tabs", + tabPanel(i18n$t("Activity Pattern"), fluidPage(fluidRow(column( + 12, + div( + style = "display: flex; align-items: center; gap: 20px;", + selectInput( + inputId = "time_input", + label = i18n$t("Time interval"), + choices = list( + "Hourly" = "hourly", + "Monthly" = "monthly", + "Seasonal" = "season" + ), + selected = "hourly" # Default selection + ), + selectInput( + inputId = "method", + label = i18n$t("Observation method"), + choices = list( + "Cameratrap" = "cameratrap", + "Animal sighting" = "animal sighting", + "Sensor" = "sensor", + "Other" = "other" # DONT HARDCODE IN FUTURE BUT BASE IT ON DATA!!!!!!!!! + ), + selected = "Cameratrap" # Default selection + ), + numericInput( + "topX", + "Top rows:", + value = 10, + min = 1, + step = 1 + ), + div( + style = "display: flex; align-items: center; gap: 10px;", + conditionalPanel( + condition = "input.time_input == 'season'", + div( + numericInput( + "num_seasons", + "# Seasons:", + value = 1, + min = 1 + ), + bsTooltip( + "num_seasons", + "Select the number of seasons for analysis. Input the calendar month number to specify season. (1 = January, 2 = February, etc.)", + placement = "right", + options = list(container = "body") + ) + ), + uiOutput("season_inputs") # Now inside the conditionalPanel + ) + ) + ) + ) + ), + fluidRow( + column(12, plotlyOutput("combined_plot"))))), tabPanel(i18n$t("labels.rawConceptsTab"), fluidRow(column( + 12, DT::dataTableOutput("tableRawConcepts") + )), + div( + style = "position: fixed; top: 45%; left: 60%; transform: translate(-50%, -50%);", + add_busy_spinner( + spin = "fading-circle", + width = "100px", + height = "100px" + ) + ) + ), + + # endpanel + + tabPanel( + i18n$t("labels.rawData"), + br(), + column(2, br(), br(), downloadButton( + "downloadData", i18n$t("commands.download") + )), + fluidRow(column( + 12, DT::dataTableOutput("tableRawObservations") + )), + div( + style = "position: fixed; top: 45%; left: 60%; transform: translate(-50%, -50%);", + add_busy_spinner( + spin = "fading-circle", + width = "100px", + height = "100px" + ) + ) + ) ) ) ) ) + From 170e3117a0d2463dbf5d0a7744a11f84f26ff9e0 Mon Sep 17 00:00:00 2001 From: hfri Date: Sat, 19 Apr 2025 13:08:09 +0200 Subject: [PATCH 3/8] tree starts at fauna level; website still does not work --- functions.R | 5 +++-- server.R | 33 +++++++++++++++++++++++++++++++++ 2 files changed, 36 insertions(+), 2 deletions(-) diff --git a/functions.R b/functions.R index e346807..ef1704f 100644 --- a/functions.R +++ b/functions.R @@ -61,10 +61,11 @@ build_tree_from_concepts <- function(concepts, counts) { for (i in 1:length(concepts)) { dfn <- rbind(dfn, c(concepts[[i]]$id, concepts[[i]]$parent, concepts[[i]]$label)) } + names(dfn) <- c("from", "to", "label") # filter concepts to only the base ontology dfn <- dfn %>% filter(grepl("SCCSSOntology", from)) - + message(print(dfn)) tree <- FromDataFrameNetwork(dfn, check = "check") trav <- Traverse(tree) trav_name <- Get(trav, "name") @@ -80,7 +81,7 @@ build_tree_from_concepts <- function(concepts, counts) { df_counts <- bind_rows(dfs) # order df according to traverse sequence f <- df_counts[match(trav_name, df_counts$X_value), "frequency"] - + # set new attribute tree$Set(freq = f) diff --git a/server.R b/server.R index 06a82ff..88947b3 100644 --- a/server.R +++ b/server.R @@ -456,8 +456,41 @@ server <- function(input, output, session) { top_nodes <- sapply(session$userData$tree$children, function(x) x$name) cw_node <- "https://sensingclues.poolparty.biz/SCCSSOntology/6477" tr_node <- "https://sensingclues.poolparty.biz/SCCSSOntology/42" + rm11_node<- "https://sensingclues.poolparty.biz/SCCSSOntology/62" + rm12_node<- "https://sensingclues.poolparty.biz/SCCSSOntology/1911" + if (cw_node %in% top_nodes) {invisible(session$userData$tree$RemoveChild(cw_node))} if (tr_node %in% top_nodes) {invisible(session$userData$tree$RemoveChild(tr_node))} + if (rm11_node %in% top_nodes) {invisible(session$userData$tree$RemoveChild(rm11_node))} + if (rm12_node %in% top_nodes) {invisible(session$userData$tree$RemoveChild(rm12_node))} + + + # Access the top-level nodes + top_children <- session$userData$tree$children + + # Loop over top-level nodes to access their second-level children + for (parent in top_children) { + # Access second-level children of the current parent node + second_level_children <- parent$children + + # Check if the parent has any second-level children + if (!is.null(second_level_children)) { + # Extract the names of second-level children + obs_nodes <- sapply(second_level_children, function(x) x$name) + + # Define nodes to remove + rm13_node <- "https://sensingclues.poolparty.biz/SCCSSOntology/89" + rm14_node <- "https://sensingclues.poolparty.biz/SCCSSOntology/106" + rm15_node <- "https://sensingclues.poolparty.biz/SCCSSOntology/461" + + # Remove second-level children from the current parent node + if (rm13_node %in% obs_nodes) { invisible(parent$RemoveChild(rm13_node)) } + if (rm14_node %in% obs_nodes) { invisible(parent$RemoveChild(rm14_node)) } + if (rm15_node %in% obs_nodes) { invisible(parent$RemoveChild(rm15_node)) } + } + } + + if (length(session$userData$tree$children) == 0) {session$userData$tree <- list()} jsonTree <- shinyTree::treeToJSON(session$userData$tree, pretty = TRUE, createNewId = FALSE) enable_all(c("DateRange", "GroupListDiv", "GetData")) From 502130fc2e9f5717f6064d4ad8e0f471d178f1be Mon Sep 17 00:00:00 2001 From: hfri Date: Sat, 3 May 2025 19:26:32 +0200 Subject: [PATCH 4/8] added percentage --- functions.R | 2 +- server.R | 75 ++++++++++++++++++++++++++++++++++------------------- ui.R | 12 ++++----- 3 files changed, 54 insertions(+), 35 deletions(-) diff --git a/functions.R b/functions.R index ef1704f..c654407 100644 --- a/functions.R +++ b/functions.R @@ -65,7 +65,7 @@ build_tree_from_concepts <- function(concepts, counts) { names(dfn) <- c("from", "to", "label") # filter concepts to only the base ontology dfn <- dfn %>% filter(grepl("SCCSSOntology", from)) - message(print(dfn)) + tree <- FromDataFrameNetwork(dfn, check = "check") trav <- Traverse(tree) trav_name <- Get(trav, "name") diff --git a/server.R b/server.R index 88947b3..37571a2 100644 --- a/server.R +++ b/server.R @@ -793,7 +793,7 @@ server <- function(input, output, session) { # Prepare data - # Filter dataset based on year of observation + # Filter dataset based on year of observation --> remove later session$userData$filtered_data <- reactive({ session$userData$processed_obsdata() %...>% { df <- . @@ -888,6 +888,7 @@ server <- function(input, output, session) { # heatmap data transformation + # include proper if else session$userData$heatmap_data <- reactive({ session$userData$plot_data() %...>% { df <- . @@ -897,35 +898,37 @@ server <- function(input, output, session) { group_by(conceptLabel, Period) %>% summarise(Counts = n(), .groups = 'drop') - message( - "Debug - heatmap_data(): Grouped and summarized data. Rows after grouping: ", - nrow(df) - ) - # Ensure Period is an ordered factor AGAIN to avoid issues df$Period <- factor(df$Period, levels = levels(df$Period)) + # Create full grid of conceptLabel x Period full_periods <- expand.grid( conceptLabel = unique(df$conceptLabel), Period = levels(df$Period), - # Explicitly use levels stringsAsFactors = FALSE ) - message( - "Debug - heatmap_data(): Created full period grid with ", - nrow(full_periods), - " rows." - ) + message("Debug - heatmap_data(): Created full period grid with ", nrow(full_periods), " rows.") + # Fill missing combinations with 0 counts df_result <- full_periods %>% left_join(df, by = c("conceptLabel", "Period")) %>% - mutate(Counts = ifelse(is.na(Counts), 0, Counts)) # Ensure missing counts are filled with 0 + mutate(Counts = ifelse(is.na(Counts), 0, Counts)) - message( - "Debug - heatmap_data(): Applied full periods and resolved missing values. Rows after merging: ", - nrow(df_result) - ) + message("Debug - heatmap_data(): Applied full periods and resolved missing values. Rows after merging: ", + nrow(df_result)) + + # Now calculate percentages if needed + if (input$agg_method == "percentage") { + df_totals <- df_result %>% + group_by(conceptLabel) %>% + summarise(Total_Count = sum(Counts), .groups = 'drop') + + df_result <- df_result %>% + left_join(df_totals, by = "conceptLabel") %>% + mutate(Percentage = ifelse(Total_Count > 0, (Counts / Total_Count) * 100, 0)) + message("Percentage calculated") + } # Use bar data for ordering the heatmap data session$userData$bar_data() %...>% { @@ -939,18 +942,20 @@ server <- function(input, output, session) { filter(conceptLabel %in% bar_df$conceptLabel) } - # Ensure conceptLabel is ordered correctly --> needed to do that again otherwise it didnt take the factors correctly + # Ensure conceptLabel is ordered correctly df_result$conceptLabel <- factor(df_result$conceptLabel, levels = ordered_species) df_result$Period <- factor(df_result$Period, levels = levels(df$Period)) + message("Debug - heatmap_data(): Applied Top X filter. Rows remaining: ", nrow(df_result)) - return(df_result) + return(df_result) } } }) + ## --- MAIN OUTPUT ------ output$combined_plot <- renderPlotly({ @@ -962,11 +967,11 @@ server <- function(input, output, session) { session$userData$heatmap_data() %...>% { heatmap_data_df <- . - + #ifelse(input$method != "cameratrap", ~Counts,~Percentage) # Create bar chart bar_chart <- plot_ly( data = bar_data_df, - x = ~ Counts, + x = ~Counts , y = ~ conceptLabel, type = 'bar', orientation = 'h', @@ -983,27 +988,43 @@ server <- function(input, output, session) { yaxis = list(title = 'Species', categoryorder = "total ascending") ) + # Create heatmap + # Heatmap needs to be reactive + # Select z and text data for heatmap + if (input$agg_method == "percentage") { + z_data <- heatmap_data_df$Percentage + text_data <- heatmap_data_df$Percentage + colorbar_title <- "Percentage" + plot_title <- "Relative fractions (%) per species" + } else { + z_data <- heatmap_data_df$Counts + text_data <- heatmap_data_df$Counts + colorbar_title <- "Counts" + plot_title <- "Counts per Species" + } + # Create heatmap heatmap <- plot_ly( data = heatmap_data_df, - x = ~ Period, - y = ~ conceptLabel, - z = ~ Counts, - text = ~ Counts, + x = ~Period, + y = ~conceptLabel, + z = z_data, + text = text_data, texttemplate = "%{text}", hoverinfo = 'text', - colorbar = list(title = 'Counts'), + colorbar = list(title = colorbar_title), type = 'heatmap', colorscale = 'Greens', showscale = TRUE, reversescale = TRUE ) %>% layout( - title = 'Counts per Species', + title = plot_title, xaxis = list(title = 'Time Period'), yaxis = list(title = 'Species') ) + # Combine the plots subplot(bar_chart, heatmap, nrows = 1, margin = 0.05) %>% layout(title = 'Activity Pattern') diff --git a/ui.R b/ui.R index 91b0439..8508177 100644 --- a/ui.R +++ b/ui.R @@ -133,15 +133,13 @@ ui <- fluidPage( selected = "hourly" # Default selection ), selectInput( - inputId = "method", - label = i18n$t("Observation method"), + inputId = "agg_method", + label = i18n$t("Aggregation method"), choices = list( - "Cameratrap" = "cameratrap", - "Animal sighting" = "animal sighting", - "Sensor" = "sensor", - "Other" = "other" # DONT HARDCODE IN FUTURE BUT BASE IT ON DATA!!!!!!!!! + "Counts" = "counts", + "Percentage" = "percentage" ), - selected = "Cameratrap" # Default selection + selected = "Counts" # Default selection ), numericInput( "topX", From e2daec11ff908bff36406a63642e8fc0a8d83eb3 Mon Sep 17 00:00:00 2001 From: hfri Date: Sun, 11 May 2025 21:06:20 +0200 Subject: [PATCH 5/8] put parts of the menu to the right of the plot --- activity_heatmap.R | 1 + server.R | 2 +- ui.R | 69 ++++++++++++++++++++++++++++------------------ 3 files changed, 44 insertions(+), 28 deletions(-) diff --git a/activity_heatmap.R b/activity_heatmap.R index 2c36dd5..3b4ed61 100644 --- a/activity_heatmap.R +++ b/activity_heatmap.R @@ -68,6 +68,7 @@ write.csv(obs_df, file ="C:/Users/hanna/Documents/africa_demo.csv") ui <- fluidPage( sidebarLayout( sidebarPanel( + uiOutput("year_selector") selectInput("selected_year", "Select Year:", choices = c("All", unique(format(obs_df$when, "%Y")))), # choices from all years in data radioButtons("time_input", "Select time period:", # period one wants to look at choices = c("Hourly" = "hourly", "Monthly" = "monthly", "Seasonal" = "season")), diff --git a/server.R b/server.R index 37571a2..2271515 100644 --- a/server.R +++ b/server.R @@ -402,7 +402,7 @@ server <- function(input, output, session) { output$season_inputs <- renderUI({ req(input$num_seasons) # required input before going further lapply(1:input$num_seasons, function(i) { - textInput(inputId = paste0("season_", i), label = paste("Season", i, "(e.g., '12,1,2' for Dec-Jan-Feb):"), value = "") + textInput(inputId = paste0("season_", i), label = paste("Season", i), value = "") }) # loop through number of seasons and add suffix (e.g. 2 seasons = season_1, season_2) }) diff --git a/ui.R b/ui.R index 8508177..9fbc808 100644 --- a/ui.R +++ b/ui.R @@ -132,22 +132,6 @@ ui <- fluidPage( ), selected = "hourly" # Default selection ), - selectInput( - inputId = "agg_method", - label = i18n$t("Aggregation method"), - choices = list( - "Counts" = "counts", - "Percentage" = "percentage" - ), - selected = "Counts" # Default selection - ), - numericInput( - "topX", - "Top rows:", - value = 10, - min = 1, - step = 1 - ), div( style = "display: flex; align-items: center; gap: 10px;", conditionalPanel( @@ -173,18 +157,49 @@ ui <- fluidPage( ) ), fluidRow( - column(12, plotlyOutput("combined_plot"))))), tabPanel(i18n$t("labels.rawConceptsTab"), fluidRow(column( - 12, DT::dataTableOutput("tableRawConcepts") - )), - div( - style = "position: fixed; top: 45%; left: 60%; transform: translate(-50%, -50%);", - add_busy_spinner( - spin = "fading-circle", - width = "100px", - height = "100px" - ) - ) + column( + width = 9, # Plot takes 75% width + plotlyOutput("combined_plot") + ), + column( + width = 3, # Inputs take 25% width + div( + style = "display: flex; flex-direction: column; gap: 15px;", + radioButtons( + inputId = "agg_method", + label = i18n$t(""), + choices = list( + "Counts" = "counts", + "Percentage" = "percentage" + ), + selected = "Counts" ), + numericInput( + inputId = "topX", + label = "Top rows:", + value = 10, + min = 1, + step = 1 + ) + ) + ) + ) + ) +), +tabPanel( + i18n$t("labels.rawConceptsTab"), + fluidRow(column( + 12, DT::dataTableOutput("tableRawConcepts") + )), + div( + style = "position: fixed; top: 45%; left: 60%; transform: translate(-50%, -50%);", + add_busy_spinner( + spin = "fading-circle", + width = "100px", + height = "100px" + ) + ) +), # endpanel From 1d85f8b9bf77a59cde99e3ac23f6d1d226d36a8e Mon Sep 17 00:00:00 2001 From: hfri Date: Fri, 16 May 2025 10:20:19 +0200 Subject: [PATCH 6/8] bug fix, tried to include download button -- still need to make it functional --- server.R | 43 ++++++++++++-------- ui.R | 117 ++++++++++++++++++++++++++++++------------------------- 2 files changed, 89 insertions(+), 71 deletions(-) diff --git a/server.R b/server.R index 2271515..4bf2135 100644 --- a/server.R +++ b/server.R @@ -958,24 +958,21 @@ server <- function(input, output, session) { ## --- MAIN OUTPUT ------ - output$combined_plot <- renderPlotly({ - # Resolve bar_data and heatmap_data otherwise plotly doesnt work + # Shared function to generate combined plot + combined_plot_fn <- reactive({ session$userData$bar_data() %...>% { - bar_data_df <- . - bar_data_df <- bar_data_df$df # - + bar_data_df <- .; bar_data_df <- bar_data_df$df session$userData$heatmap_data() %...>% { heatmap_data_df <- . - #ifelse(input$method != "cameratrap", ~Counts,~Percentage) - # Create bar chart + # Bar chart bar_chart <- plot_ly( data = bar_data_df, - x = ~Counts , - y = ~ conceptLabel, + x = ~Counts, + y = ~conceptLabel, type = 'bar', orientation = 'h', - text = ~ Counts, + text = ~Counts, textposition = 'outside', marker = list( color = 'rgba(50, 171, 96, 0.6)', @@ -988,9 +985,7 @@ server <- function(input, output, session) { yaxis = list(title = 'Species', categoryorder = "total ascending") ) - # Create heatmap - # Heatmap needs to be reactive - # Select z and text data for heatmap + # Heatmap if (input$agg_method == "percentage") { z_data <- heatmap_data_df$Percentage text_data <- heatmap_data_df$Percentage @@ -1003,7 +998,6 @@ server <- function(input, output, session) { plot_title <- "Counts per Species" } - # Create heatmap heatmap <- plot_ly( data = heatmap_data_df, x = ~Period, @@ -1024,15 +1018,30 @@ server <- function(input, output, session) { yaxis = list(title = 'Species') ) - - # Combine the plots + # Combine subplot(bar_chart, heatmap, nrows = 1, margin = 0.05) %>% layout(title = 'Activity Pattern') } } }) - + # Render the plot + output$combined_plot <- renderPlotly({ + combined_plot_fn() + }) + # + # # Download handler + # output$download_plotly <- downloadHandler( + # filename = function() { + # paste("combined_plot", Sys.Date(), ".png", sep = "") + # }, + # content = function(file) { + # plot <- combined_plot_fn() + # + # # Save as PNG + # plotly::save_image(plot, file = file, format = "png", width = 1200, height = 600, scale = 1) + # } + # ) ### TAB RAW CONCEPTS observeEvent(input$GetData, { diff --git a/ui.R b/ui.R index 9fbc808..cafa8a3 100644 --- a/ui.R +++ b/ui.R @@ -137,69 +137,79 @@ ui <- fluidPage( conditionalPanel( condition = "input.time_input == 'season'", div( - numericInput( - "num_seasons", - "# Seasons:", - value = 1, - min = 1 + style = "display: flex; align-items: center; gap: 20px;", + + # First input: num_seasons + div( + numericInput( + "num_seasons", + "# Seasons:", + value = 1, + min = 1 + ), + bsTooltip( + "num_seasons", + "Select the number of seasons for analysis. Input the calendar month number to specify season. (1 = January, 2 = February, etc.)", + placement = "right", + options = list(container = "body") + ) ), - bsTooltip( - "num_seasons", - "Select the number of seasons for analysis. Input the calendar month number to specify season. (1 = January, 2 = February, etc.)", - placement = "right", - options = list(container = "body") + + # Second input: uiOutput for dynamic season inputs + div( + uiOutput("season_inputs") ) - ), - uiOutput("season_inputs") # Now inside the conditionalPanel + ) ) ) ) ) ), fluidRow( - column( - width = 9, # Plot takes 75% width - plotlyOutput("combined_plot") - ), - column( - width = 3, # Inputs take 25% width - div( - style = "display: flex; flex-direction: column; gap: 15px;", - radioButtons( - inputId = "agg_method", - label = i18n$t(""), - choices = list( - "Counts" = "counts", - "Percentage" = "percentage" - ), - selected = "Counts" + column( + width = 9, # Plot takes 75% width + plotlyOutput("combined_plot") ), - numericInput( - inputId = "topX", - label = "Top rows:", - value = 10, - min = 1, - step = 1 + column( + width = 3, # Inputs take 25% width + div( + style = "display: flex; flex-direction: column; gap: 15px;", + radioButtons( + inputId = "agg_method", + label = i18n$t(""), + choices = list( + "Counts" = "counts", + "Percentage" = "percentage" + ), + selected = "counts" + ), + numericInput( + inputId = "topX", + label = "Top rows:", + value = 10, + min = 1, + step = 1 + ), + downloadButton("download_plotly", "Download Combined Plot (PNG)") + ) ) ) - ) - ) - ) -), -tabPanel( - i18n$t("labels.rawConceptsTab"), - fluidRow(column( - 12, DT::dataTableOutput("tableRawConcepts") - )), - div( - style = "position: fixed; top: 45%; left: 60%; transform: translate(-50%, -50%);", - add_busy_spinner( - spin = "fading-circle", - width = "100px", - height = "100px" - ) - ) -), + ) + ), + tabPanel( + i18n$t("labels.rawConceptsTab"), + fluidRow(column( + 12, DT::dataTableOutput("tableRawConcepts") + )), + div( + style = "position: fixed; top: 45%; left: 60%; transform: translate(-50%, -50%);", + add_busy_spinner( + spin = "fading-circle", + width = "100px", + height = "100px" + ) + ) + ), # endpanel @@ -224,5 +234,4 @@ tabPanel( ) ) ) -) - +) \ No newline at end of file From 952c4eb6770d2820d5c2c3cc452ba67bc6af5688 Mon Sep 17 00:00:00 2001 From: hfri Date: Thu, 29 May 2025 12:25:00 +0200 Subject: [PATCH 7/8] Layout update and download option --- server.R | 51 +++++++---- ui.R | 268 ++++++++++++++++++++++++++++++++++--------------------- 2 files changed, 198 insertions(+), 121 deletions(-) diff --git a/server.R b/server.R index 4bf2135..83ad08c 100644 --- a/server.R +++ b/server.R @@ -398,11 +398,15 @@ server <- function(input, output, session) { # -- New inputs - Hanna + # Generate input fields per season dynamically based on number of seasons user desires # Generate input fields per season dynamically based on number of seasons user desires output$season_inputs <- renderUI({ req(input$num_seasons) # required input before going further lapply(1:input$num_seasons, function(i) { - textInput(inputId = paste0("season_", i), label = paste("Season", i), value = "") + # Wrap each textInput in a div with styling for horizontal layout and reduced width + div(style = "display: inline-block; width: 75px; margin-right: 10px;", # Adjust width and margin as needed + textInput(inputId = paste0("season_", i), label = paste("Season", i), value = "") + ) }) # loop through number of seasons and add suffix (e.g. 2 seasons = season_1, season_2) }) @@ -1015,12 +1019,11 @@ server <- function(input, output, session) { layout( title = plot_title, xaxis = list(title = 'Time Period'), - yaxis = list(title = 'Species') + yaxis = list(title = '', showticklabels = FALSE) ) # Combine - subplot(bar_chart, heatmap, nrows = 1, margin = 0.05) %>% - layout(title = 'Activity Pattern') + subplot(bar_chart, heatmap, nrows = 1, margin = 0.05) } } }) @@ -1029,20 +1032,34 @@ server <- function(input, output, session) { output$combined_plot <- renderPlotly({ combined_plot_fn() }) - # - # # Download handler - # output$download_plotly <- downloadHandler( - # filename = function() { - # paste("combined_plot", Sys.Date(), ".png", sep = "") - # }, - # content = function(file) { - # plot <- combined_plot_fn() - # - # # Save as PNG - # plotly::save_image(plot, file = file, format = "png", width = 1200, height = 600, scale = 1) - # } - # ) + # Use a reactiveVal to cache the final plot + plot_cache <- reactiveVal(NULL) + + # Save the completed plot to cache whenever it's re-rendered + observeEvent(combined_plot_fn(), { + combined_plot_fn() %...>% plot_cache() + }) + + # Render the plot from the reactive (unchanged) + output$combined_plot <- renderPlotly({ + combined_plot_fn() + }) + # Download handler + output$download_plotly <- downloadHandler( + filename = function() { + paste("combined_plot", ".html", sep = "") + }, + content = function(file) { + p <- plot_cache() + if (is.null(p)) { + stop("Plot is not yet ready for download.") + } + + saveWidget(as_widget(p), file) + } + ) + ### TAB RAW CONCEPTS observeEvent(input$GetData, { # make container for displaying hover text for column headings diff --git a/ui.R b/ui.R index cafa8a3..e626876 100644 --- a/ui.R +++ b/ui.R @@ -1,5 +1,5 @@ # Author: Hanna Fricke -# Description: User interface for activity app. +# Description: User interface for activity app. # TO-DO : # [] DONT HARDCODE METHOD FUTURE BUT BASE IT ON DATA @@ -29,6 +29,7 @@ if (!exists("i18n")) { } i18n$set_translation_language("en") +# js code to get the browser language - Corrected escaping js_lang <- "var language = window.navigator.userLanguage || window.navigator.language; Shiny.onInputChange('browser_language', language); console.log(language);" @@ -38,7 +39,7 @@ ui <- fluidPage( shiny.i18n::usei18n(i18n), extendShinyjs(text = js_lang, functions = c()), - # Get timezone from browser + # Get timezone from browser - Corrected escaping tags$script( "$(document).on('shiny:sessioninitialized', function(event) { var n = Intl.DateTimeFormat().resolvedOptions().timeZone; @@ -58,6 +59,14 @@ ui <- fluidPage( ) ), + # --- About Box --- + div(class = "about-box", + h4("About"), + p("Add a small descriptive text about the app here.") + ), + br(), + # --- End About Box --- + # Custom button styles tags$head( tags$style( @@ -74,31 +83,49 @@ ui <- fluidPage( ), ), - h3(i18n$t("labels.obsReport")), + # Remove old heading h3(i18n$t("labels.obsReport")) uiOutput("userstatus"), br(), - br(), - disabled(dateRangeInput("DateRange", i18n$t("labels.selectPeriod"))), - br(), - disabled(div( - class = "choosechannel", - id = "GroupListDiv", - pickerInput( - inputId = "GroupList", - label = i18n$t("labels.selectGroup"), - choices = list(), - multiple = TRUE, - options = pickerOptions( - actionsBox = TRUE, - noneSelectedText = '', - selectAllText = i18n$t("labels.selectAll"), - deselectAllText = i18n$t("labels.deselectAll") + + # --- Filter Sections --- + div(class = "filter-section time-period-box", + h4("Time Period"), + # Added a container div for easier styling of the date range input width + div(class = "date-range-input-container", + disabled(dateRangeInput("DateRange", i18n$t("labels.selectPeriod"))) ) - ) - )), + ), + br(), + + div(class = "filter-section data-sources-box", + h4("Data Sources"), + disabled(div( + class = "choosechannel", + id = "GroupListDiv", + pickerInput( + inputId = "GroupList", + label = i18n$t("labels.selectGroup"), # This label might be redundant with the H4 heading, consider removing if needed + choices = list(), + multiple = TRUE, + options = pickerOptions( + actionsBox = TRUE, + noneSelectedText = '', + selectAllText = i18n$t("labels.selectAll"), + deselectAllText = i18n$t("labels.deselectAll") + ) + ) + )) + ), br(), - shinyTree("conceptTree", checkbox = TRUE, theme = "proton"), + + div(class = "filter-section concepts-box", + h4("Concepts"), + p("Select concepts (one or more)"), + shinyTree("conceptTree", checkbox = TRUE, theme = "proton") + ), br(), + # --- End Filter Sections --- + disabled(actionButton( "GetData", i18n$t("commands.getdata"), icon = NULL )), @@ -108,93 +135,126 @@ ui <- fluidPage( mainPanel( width = 9, tags$head(tags$style( - HTML(" - .sep { + # Corrected escaping for the CSS content within HTML() + HTML(".sep { width: 20px; height: 1px; float: left; - } - ") + }") )), tabsetPanel( type = "tabs", - tabPanel(i18n$t("Activity Pattern"), fluidPage(fluidRow(column( - 12, - div( - style = "display: flex; align-items: center; gap: 20px;", - selectInput( - inputId = "time_input", - label = i18n$t("Time interval"), - choices = list( - "Hourly" = "hourly", - "Monthly" = "monthly", - "Seasonal" = "season" - ), - selected = "hourly" # Default selection - ), - div( - style = "display: flex; align-items: center; gap: 10px;", - conditionalPanel( - condition = "input.time_input == 'season'", - div( - style = "display: flex; align-items: center; gap: 20px;", - - # First input: num_seasons - div( - numericInput( - "num_seasons", - "# Seasons:", - value = 1, - min = 1 - ), - bsTooltip( - "num_seasons", - "Select the number of seasons for analysis. Input the calendar month number to specify season. (1 = January, 2 = February, etc.)", - placement = "right", - options = list(container = "body") - ) - ), - - # Second input: uiOutput for dynamic season inputs - div( - uiOutput("season_inputs") - ) - ) - ) - ) - ) - ) - ), - fluidRow( - column( - width = 9, # Plot takes 75% width - plotlyOutput("combined_plot") - ), - column( - width = 3, # Inputs take 25% width - div( - style = "display: flex; flex-direction: column; gap: 15px;", - radioButtons( - inputId = "agg_method", - label = i18n$t(""), - choices = list( - "Counts" = "counts", - "Percentage" = "percentage" - ), - selected = "counts" - ), - numericInput( - inputId = "topX", - label = "Top rows:", - value = 10, - min = 1, - step = 1 - ), - downloadButton("download_plotly", "Download Combined Plot (PNG)") - ) - ) - ) - ) + tabPanel(i18n$t("Activity Pattern"), + fluidPage( + + # === Time Interval Row === + fluidRow( + column( + 12, + div( + style = "display: flex; align-items: center; gap: 20px; margin-top: 10px;", + + # Time Interval Box + div( + style = "width: 100px;", + selectInput( + inputId = "time_input", + label = i18n$t("Time interval"), + choices = list( + "Hourly" = "hourly", + "Monthly" = "monthly", + "Seasonal" = "season" + ), + selected = "hourly", + width = "100%" + ) + ), + + # Conditional Season Controls + conditionalPanel( + condition = "input.time_input == 'season'", + div( + style = "display: flex; align-items: center; gap: 20px;", + div( + style = "width: 100px;", + numericInput( + "num_seasons", + "# Seasons:", + value = 1, + min = 1, + width = "100%" + ), + bsTooltip( + "num_seasons", + "Select the number of seasons for analysis. Input the calendar month number to specify season. (1 = January, 2 = February, etc.)", + placement = "right", + options = list(container = "body") + ) + ), + div( + style = "display: flex; flex-wrap: wrap; gap: 10px;", + uiOutput("season_inputs") + ) + ) + ) + ) + ) + ), + + # === TopX and Aggregation Method Row === + fluidRow( + column( + 12, + div( + style = "display: flex; align-items: center; gap: 20px; margin-top: 15px;", + + # Top X Filter Box (match width to Time Interval box) + div( + style = "width: 100px;", + numericInput( + inputId = "topX", + label = "Top rows:", + value = 10, + min = 1, + step = 1, + width = "100%" + ) + ), + + # Aligned Radio Buttons (inline, vertically centered) + div( + style = "display: flex; align-items: flex-end; height: 58px;", # Adjust height to match input height + radioButtons( + inputId = "agg_method", + label = NULL, + choices = list("Counts" = "counts", "Percentage" = "percentage"), + selected = "counts", + inline = TRUE + ) + ) + ) + ) + ), + + # === Plot Row === + fluidRow( + column( + 12, + plotlyOutput("combined_plot") + ) + ), + + # === Download Button Row === + fluidRow( + column( + 12, + div( + style = "margin-top: 20px;", + downloadButton("download_plotly", "Download plot (.html)") + ) + ) + ) + ) ), tabPanel( i18n$t("labels.rawConceptsTab"), @@ -209,7 +269,7 @@ ui <- fluidPage( height = "100px" ) ) - ), + ), # endpanel From 98b270f35f17d66a1958ea54eccc1151e58d59d0 Mon Sep 17 00:00:00 2001 From: hfri Date: Fri, 30 May 2025 11:23:06 +0200 Subject: [PATCH 8/8] small layout adaptions --- activity_heatmap.R | 248 --------------------------------------------- functions.R | 67 ------------ server.R | 27 ++++- 3 files changed, 23 insertions(+), 319 deletions(-) delete mode 100644 activity_heatmap.R diff --git a/activity_heatmap.R b/activity_heatmap.R deleted file mode 100644 index 3b4ed61..0000000 --- a/activity_heatmap.R +++ /dev/null @@ -1,248 +0,0 @@ -## Activity patterns -## Author: Hanna Fricke -## Date: 11-03-2025 -## Description: The goal is to create a heatmap that allows users to identify activity patterns of e.g. animal species over time (time of day, month, season) -## To-Dos -## [x] User time period - dynamic -## [x] User label for counts - dynamic -## [x] season based on user input - dynamic -## [x] name dataframes better -- obs_df is good for now but not really general (might be sounds)--> now data -## [] include some form of filter so that you really only get animals -## [x] time binning we need to improve and actually make 1 h bins. --> decide if you just want to make seperate new columns for that or -## [x] x-axis range heatmap needs to be different depending on selected period -## [] Include date range input for data -## [x] x-axis should display either 24h range or 12 months -## [x] make sure that user season cannot be paired with month or hour parameters -## [] See how you can adapt the season parameter that it can be an input that you provide as a user (e.g. a range slider) -## [x] make sure heatmap colour is also filled if factor levels are not in df -## [x] Include button that allows switching views from season to year to month -## [x] Include selection for time period of data -## [x] make sure that only one year is diplayed per view --> tested only on 2024 -## [] Include the option for different aggregates--> total observations of average observation time of the day depending on season and month -## [] Include button to switch between sensor and cameratrap data -## [] x- axis for hourly view is in steps of 2 atm --> make 1 -## [] include normalised view 0-1 -## [] use Shiny to read in data -## [] Include Ontology ID as ID not concept label -## [] Include box that allows to insert method of observation -## [] Visualise numbers in the bar graph and heatmap -## [] Include server side of methods -## [] Include relative counts -## [] add reverse ordering - -## Set up libraries -library(pacman) -p_load(ggplot2, plotly, dplyr, tidyr, quantmod, sensingcluesr) # makes loading and installing easier Lubridate needed? - -library(tidyr) -## import data from SC platform - chose Demo group africa -cookie <- login_cluey("XXX", "XXXX") # insert login - -groups <- get_groups(cookie, - from = "1900-01-01", # set so that dates include everything - to = "2999-12-31", - url = "https://focus.sensingclues.org/") # to get the names of the groups (REMOVE later) - -df <- get_observations( - cookie, - from = as.Date("2023-01-01"), # data was available from 2024 , adapt later to long e.g. from 1900-01-01 - to = Sys.Date(), - group = 'focus-project-1234' # demo group Africa -) - - -## Inspect demo data --> REMOVE later -df_copy<- df %>% mutate_if(is.character, as.factor) # check what values are in the dataframe -# Get the levels of each factor column -factor_levels <- lapply(df_copy[, sapply(df_copy, is.factor)], levels) -obs_df <- subset(df,description == "Observation animal") -dim(obs_df) == dim(subset(df, observationType == "animal")) # cross check if you really got all the animal data, seems like it -obs_df$when <- as.POSIXct(obs_df$when, format = "%Y-%m-%dT%H:%M:%S") # proper format for later - -## Note to myself: I need to filter out the properties from the observation from the animal names - -write.csv(obs_df, file ="C:/Users/hanna/Documents/africa_demo.csv") -## --------------------------------------------------------------------------------------------------------------------------------------- -## Make first Shiny version -# UI -ui <- fluidPage( - sidebarLayout( - sidebarPanel( - uiOutput("year_selector") - selectInput("selected_year", "Select Year:", choices = c("All", unique(format(obs_df$when, "%Y")))), # choices from all years in data - radioButtons("time_input", "Select time period:", # period one wants to look at - choices = c("Hourly" = "hourly", "Monthly" = "monthly", "Seasonal" = "season")), - numericInput("topX", "Number of rows to display:", value = 10, min = 1, step = 1), # User input for top X - radioButtons("method", "Select method of observation:", # period one wants to look at - choices = c("Cameratrap" = "cameratrap", "Animal sighting" = "animal sighting", "Sensor" = "sensor","Other" = "other")), - conditionalPanel( # only display if input is season - condition = "input.time_input == 'season'", - numericInput("num_seasons", "Number of Seasons:", value = 1, min = 1), # select how many seasons you expect - uiOutput("season_inputs"), # placeholder that reacts to server side - ) - ), - mainPanel( - plotlyOutput("combined_plot") - ) - ) -) - -server <- function(input, output, session) { - - # Generate input fields per season dynamically based on number of seasons user desires - output$season_inputs <- renderUI({ - req(input$num_seasons) # required input before going further - lapply(1:input$num_seasons, function(i) { - textInput(inputId = paste0("season_", i), label = paste("Season", i, "(e.g., '12,1,2' for Dec-Jan-Feb):"), value = "") - }) # loop through number of seasons and add suffix (e.g. 2 seasons = season_1, season_2) - }) - message(print(class(output))) - # Reactive expression to parse user-defined seasons - user_defined_seasons <- reactive({ - req(input$num_seasons) - seasons <- list() - for (i in 1:input$num_seasons) { - season_input <- input[[paste0("season_", i)]] - if (!is.null(season_input) && season_input != "") { - months <- unlist(strsplit(season_input, ",")) - seasons[[paste0("Season_", i)]] <- sprintf("%02d", as.numeric(trimws(months))) - } - } - seasons - }) - - - # Filter data based on year - filtered_data <- reactive({ - if (input$selected_year == "All") { - obs_df - } else { - obs_df %>% filter(format(when, "%Y") == input$selected_year) - } - }) - - # Prepare data for plotting --> in reactive format - plot_data <- reactive({ - data <- filtered_data() - time_input <- input$time_input - seasons <- user_defined_seasons() - - data <- data %>% - mutate(Period = case_when( - time_input == "hourly" ~ format(when, "%H"), - time_input == "monthly" ~ format(when, "%m"), - time_input == "season" ~ purrr::map_chr(format(when, "%m"), function(month) { - season <- names(seasons)[sapply(seasons, function(s) month %in% s)] - if (length(season) > 0) season else NA - }), - TRUE ~ NA_character_ - )) - - if (time_input == "hourly") { - data$Period <- factor(data$Period, levels = sprintf("%02d", 0:23), labels = paste0(sprintf("%02d", 0:23), "h")) - } else if (time_input == "monthly") { - data$Period <- factor(data$Period, levels = sprintf("%02d", 1:12), labels = month.abb) - } else if (time_input == "season") { - data$Period <- factor(data$Period, levels = names(seasons)) - } - - data - }) - - # Render combined plot - output$combined_plot <- renderPlotly({ - data <- plot_data() - - # Group data by Period and Label - bar_data <- data %>% - group_by(conceptLabel) %>% - summarise(Counts = n(), .groups = 'drop') - - - # Apply top X filter - topX <- input$topX - if (topX > 0) { - bar_data <- bar_data %>% - top_n(topX, Counts) %>% - arrange(desc(Counts)) - } - - # Order species according to frequency of detection for the bar chart - ordered_species <- bar_data %>% - arrange(Counts) %>% - pull(conceptLabel) - - # Heatmap Data Preparation - heatmap_data <- data %>% - group_by(conceptLabel, Period) %>% - summarise(Counts = n(), .groups = 'drop') - - # Create a full set of all combinations of conceptLabel and Period - full_periods <- expand.grid( - conceptLabel = unique(heatmap_data$conceptLabel), - Period = levels(data$Period) - ) - - # Left join the full combination set with the observed data to ensure all combinations - heatmap_data_complete <- full_periods %>% - left_join(heatmap_data, by = c("conceptLabel", "Period")) %>% - mutate(Counts = ifelse(is.na(Counts), 0, Counts)) - - # Apply top X filter to heatmap data - if (topX > 0) { - heatmap_data_complete <- heatmap_data_complete %>% - filter(conceptLabel %in% bar_data$conceptLabel) - } - ## ORDERED SPECIES NEEDS TO BE INCLUDED HERE! FILTERED - - heatmap_data_complete$conceptLabel <- factor(heatmap_data_complete$conceptLabel, levels = unique(c( - ordered_species, heatmap_data_complete$conceptLabel - ))) - - bar_chart <- plot_ly( - bar_data, - x = ~ Counts, - y = ~ conceptLabel, - type = 'bar', - orientation = 'h', - text = ~ Counts, # Add text for counts on bars - textposition = 'outside', # Position the text outside the bars - marker = list( - color = 'rgba(50, 171, 96, 0.6)', - line = list(color = 'rgba(50, 171, 96, 1.0)', width = 1) - ) -) %>% - layout( - title = 'Total Counts per Species and Time Period', - xaxis = list(title = 'Counts'), - yaxis = list(title = 'Species', categoryorder = "total ascending") - ) - - # Now use heatmap_data_complete for your heatmap plot - heatmap <- plot_ly( - data = heatmap_data_complete, - x = ~ Period, - y = ~ conceptLabel, - z = ~ Counts, - text = ~ Counts, - texttemplate = "%{text}", # Display the text values within the cells - hoverinfo = 'text', # Show text when hovering over a cell - colorbar = list(title = 'Counts'), # Optional: label for color scale - type = 'heatmap', - colorscale = 'Greens', - showscale = TRUE, - reversescale = TRUE - ) %>% - layout( - title = 'Counts per Species', - xaxis = list(title = 'Time Period'), - yaxis = list(title = 'Species') - ) - - subplot(bar_chart, heatmap, nrows = 1, margin = 0.05) %>% - layout(title = 'Activity Pattern') - }) -} - -# Run the application -shinyApp(ui = ui, server = server) \ No newline at end of file diff --git a/functions.R b/functions.R index c654407..0ea9920 100644 --- a/functions.R +++ b/functions.R @@ -96,77 +96,10 @@ build_tree_from_concepts <- function(concepts, counts) { stateLeafs <- list(opened = TRUE, selected = TRUE) nLeafs <- tree$leafCount tree$Set(state = rep(list(stateLeafs), nLeafs), filterFun = isLeaf) - # seems impossible to have tree opened and selected from tree.data object - #stateNotLeafs <- list(opened = TRUE) - #tree$Set(state = rep(list(stateNotLeafs),length(tree)-nLeafs), filterFun = isNotLeaf) - # "state": { - # "opened": true, - # "disabled": false, - # "selected": false, - # "loaded": false - # } - #tree$Do(function(node) node$state = list(opened = TRUE, disabled = FALSE, selected = TRUE, loaded = FALSE)) - - #tree = lapply(tree, function(x) structure(x, stopened = T)) - return(tree) } -# ----------------------------------------------------------------------------- -# OBSERVATIONS -# ----------------------------------------------------------------------------- - -## EVENTUALLY CONVERT PLOT INTO A FUNCTION - - -# ----------------------------------------------------------------------------- -# INTERSECTION -# ----------------------------------------------------------------------------- - -# # check which observations are in which layers -# intersect_observations_to_layers <- function(layer, obs) { -# # per feature -# for (i in 1:nrow(layer)){ -# # json -# # name is in properties -# #j <- unlist(f[[i]]) -# f01 <- layer[i,] -# -# label <- f01$NAME -# -# # make sure coordinate systems are the same -# # we actually overwrite the features crs so this could be wrong... -# f01 <- st_set_crs(f01, st_crs(obs)) -# # drop z dimension -# f01 <- st_zm(f01) -# # seems most MULTIPOLYGONS are POLYGONS at the lower level -# f01 <- st_make_valid(f01) -# -# # f01$geometry <- f01$geometry %>% -# # s2::s2_rebuild() %>% -# # sf::st_as_sfc() -# -# # check which points intersect with polygon -# tryCatch({ -# # do not use s2 -# sf::sf_use_s2(FALSE) -# lst <- st_intersects(obs, f01, sparse = FALSE) -# message(paste("LAYER ", label, " is OK")) -# sf::sf_use_s2(TRUE) -# # fill in the name for these points -# if (sum(lst) > 0) { -# obs[lst,]$area <- label -# } -# }, -# #error -# error = function(cond) message(paste("LAYER ", label, " has issues")) -# ) #tryCatch -# } -# return(obs) -# } - - # ----------------------------------------------------------------------------- # VISUALIZATIONS # ----------------------------------------------------------------------------- diff --git a/server.R b/server.R index 83ad08c..a8c0885 100644 --- a/server.R +++ b/server.R @@ -398,7 +398,6 @@ server <- function(input, output, session) { # -- New inputs - Hanna - # Generate input fields per season dynamically based on number of seasons user desires # Generate input fields per season dynamically based on number of seasons user desires output$season_inputs <- renderUI({ req(input$num_seasons) # required input before going further @@ -969,6 +968,12 @@ server <- function(input, output, session) { session$userData$heatmap_data() %...>% { heatmap_data_df <- . + # Calculate max count for dynamic axis range + max_count <- max(bar_data_df$Counts, na.rm = TRUE) + + # Use 10% buffer or just add 20 units if scale is small + xaxis_range <- c(0, max_count + max_count * 1.1) # or max_count * 1.1 for percentage padding + # Bar chart bar_chart <- plot_ly( data = bar_data_df, @@ -985,21 +990,33 @@ server <- function(input, output, session) { ) %>% layout( title = 'Total Counts per Species and Time Period', - xaxis = list(title = 'Counts'), - yaxis = list(title = 'Species', categoryorder = "total ascending") + xaxis = list( + title = 'Counts', + range = xaxis_range + ), + yaxis = list( + title = 'Species', + categoryorder = "total ascending" + ), + margin = list(r = 5), + cliponaxis = FALSE ) # Heatmap if (input$agg_method == "percentage") { z_data <- heatmap_data_df$Percentage - text_data <- heatmap_data_df$Percentage + text_data <- round(heatmap_data_df$Percentage) colorbar_title <- "Percentage" plot_title <- "Relative fractions (%) per species" + zmin <- 0 + zmax <- 100 } else { z_data <- heatmap_data_df$Counts text_data <- heatmap_data_df$Counts colorbar_title <- "Counts" plot_title <- "Counts per Species" + zmin <- min(bar_data_df$Counts, na.rm = TRUE) + zmax <- ceiling(max_count/ 10) * 10 } heatmap <- plot_ly( @@ -1007,6 +1024,8 @@ server <- function(input, output, session) { x = ~Period, y = ~conceptLabel, z = z_data, + zmin = zmin, + zmax= zmax, text = text_data, texttemplate = "%{text}", hoverinfo = 'text',