Add load latest data button, quiet mode default, and fetch citation from GitHub

R/data_management.R

@@ -85,10 +85,10 @@ bind_rows_with_characters <- function(..., .id = NULL) {
 #'
 #' @param data Path to the FReD dataset (defaults to current FReD data on OSF), unless the package is in offline mode (`use_FReD_offline()`)
 #' @param retain_es_as_character Should effect sizes be retained as character? Defaults to TRUE, so that coded test statistics with df can be converted to common metric.
-#' @param verbose Should detailed messages be printed that highlight data conversion issues? Defaults to TRUE. FALSE is quiet mode, and NULL prints a summary of problems.
+#' @param verbose Should detailed messages be printed that highlight data conversion issues? Defaults to FALSE (quiet mode). TRUE prints detailed warnings, and NULL prints a summary of problems.
 #' @return A data frame with the FReD dataset
 
-read_fred <- function(data = get_param("FRED_DATA_FILE"), retain_es_as_character = TRUE, verbose = TRUE) {
+read_fred <- function(data = get_param("FRED_DATA_FILE"), retain_es_as_character = TRUE, verbose = FALSE) {
 
   if (get_param("FRED_OFFLINE")) return(return_inbuilt("data"))
 
@@ -288,7 +288,7 @@ update_offline_data <- function(data_file = get_param("FRED_DATA_FILE"), items =
       } else if (item == "data_changelog") {
         data <- get_dataset_changelog()
       } else if (item == "citation") {
-        data <- create_citation(data_file)
+        data <- create_citation()
       }
       attr(data, "last_updated") <- Sys.time()
       file_path <- system.file("extdata", "snapshot", paste0(item, ".RDS"), package = "FReD")

R/fred.R

@@ -59,15 +59,15 @@ dummy_function_calls <- function() {
   }
 }
 
-#' Create FReD dataset citation
+#' Get FReD dataset citation
 #'
-#' Pulls current contributor list and dynamicalky creates a *markdown-formatted* citation for the FReD dataset.
+#' Retrieves the current citation for the FReD dataset from GitHub.
 #'
-#' @param data_file Path to the FReD dataset, defaults to the current FReD dataset on OSF
+#' @param citation_url URL to the citation file on GitHub
 #' @param cache Should the citation be returned from cache, if already requested during this session? Defaults to TRUE.
-#' @return A markdown-formatted citation for the FReD dataset, including the current dataset version.
+#' @return A markdown-formatted citation for the FReD dataset.
 
-create_citation <- function(data_file = get_param("FRED_DATA_FILE"), cache = TRUE) {
+create_citation <- function(citation_url = "https://raw.githubusercontent.com/forrtproject/FReD-data/main/output/citation.txt", cache = TRUE) {
   if (get_param("FRED_OFFLINE")) {
     return(return_inbuilt("citation"))
   }
@@ -77,19 +77,21 @@ create_citation <- function(data_file = get_param("FRED_DATA_FILE"), cache = TRU
       if (cache && exists("citation", .cache, inherits = FALSE)) {
         return(.cache$citation)
       }
-      contributors <- safe_read_xl(data_file, url = get_param("FRED_DATA_URL"), sheet = "Contributors FReD")
-      contributors <- contributors[contributors$Added.to.FReD.website.as.contributor, ]
-      contributors$first <- substr(contributors$First.name, 1, 1)
-      contributors$middle <- ifelse(!is.na(contributors$Middle.name), paste(" ", substr(contributors$Middle.name, 1, 1), ".", sep = ""), "")
-      contributors$apa <- paste0(
-        contributors$Surname, ", ",
-        contributors$first, ".",
-        contributors$middle
-      )
-      c_names <- paste(contributors$apa, collapse = ", ")
 
-      version <- get_dataset_changelog() %>% stringr::str_extract("(?<=\\*\\*Version:\\*\\* )\\d+\\.\\d+\\.\\d+")
-      cit <- glue::glue("{c_names} (2024). _FReD: FORRT Replication Database, version {version}._ [https://dx.doi.org/10.17605/OSF.IO/9r62x] _*shared first authorship_")
+      temp <- tempfile(fileext = ".txt")
+      download.file(citation_url, temp, quiet = TRUE)
+
+      # Validate download succeeded
+      if (!file.exists(temp) || file.size(temp) == 0) {
+        stop("Failed to download citation file")
+      }
+
+      cit <- readLines(temp, warn = FALSE) %>% paste(collapse = "\n")
+
+      # Validate citation content is not empty
+      if (nchar(trimws(cit)) == 0) {
+        stop("Citation file is empty")
+      }
 
       .cache$citation <- cit
 
@@ -138,7 +140,7 @@ get_dataset_changelog <- function(changelog_file = "https://osf.io/fj3xc/downloa
 #' @return A data frame with the processed FReD dataset
 #' @export
 
-load_fred_data <- function(data = get_param("FRED_DATA_FILE"), verbose = TRUE) {
+load_fred_data <- function(data = get_param("FRED_DATA_FILE"), verbose = FALSE) {
 
   read_fred(data, verbose = verbose) %>%
     clean_variables() %>%

inst/fred_explorer/global.R

@@ -12,12 +12,19 @@ if (!exists("create_citation")) {
 
 if (!exists("create_citation")) stop("Failed to attach FReD namespace.")
 
-df <- load_fred_data()
-
-df_display <- df[, c("description", "es_o", "es_r", "n_o", "n_r", "osf_link", "contributors", "result", "result2", "ref_o", "ref_r")]
-df_display$es_o <- round(df_display$es_o, 3)
-df_display$es_r <- round(df_display$es_r, 3)
+# Function to load and prepare data - can be called again to refresh
+load_app_data <- function() {
+  df <- load_fred_data()
+  df_display <- df[, c("description", "es_o", "es_r", "n_o", "n_r", "osf_link", "contributors", "result", "result2", "ref_o", "ref_r")]
+  df_display$es_o <- round(df_display$es_o, 3)
+  df_display$es_r <- round(df_display$es_r, 3)
+  list(df = df, df_display = df_display)
+}
 
+# Initial data load
+app_data <- load_app_data()
+df <- app_data$df
+df_display <- app_data$df_display
 
 dataset_variables <- load_variable_descriptions()
 

inst/fred_explorer/server.R

@@ -9,7 +9,39 @@ server <- function(input, output, session) {
     }
   })
 
+  # Reactive data source - allows refreshing
+  data_source <- reactiveValues(
+    df = df,
+    df_display = df_display
+  )
+
+  # Refresh data when button is clicked
+
+  observeEvent(input$refresh_data, {
+    showNotification("Refreshing data from source...", type = "message", duration = 2)
+    tryCatch({
+      # Force fresh download by temporarily disabling offline mode
+      was_offline <- get_param("FRED_OFFLINE")
+      if (was_offline) use_FReD_offline(FALSE)
+
+      # Delete cached data file to force fresh download from OSF
+      cached_file <- get_param("FRED_DATA_FILE")
+      if (file.exists(cached_file)) {
+        file.remove(cached_file)
+      }
+
+      new_data <- load_app_data()
+      data_source$df <- new_data$df
+      data_source$df_display <- new_data$df_display
 
+      if (was_offline) use_FReD_offline(TRUE)
+
+      showNotification(paste("Data refreshed successfully!", nrow(new_data$df), "findings loaded."),
+                       type = "message", duration = 5)
+    }, error = function(e) {
+      showNotification(paste("Error refreshing data:", e$message), type = "error", duration = 5)
+    })
+  })
 
   # Disclaimer --------------------------------------------------------------
 
@@ -29,7 +61,7 @@ server <- function(input, output, session) {
 
   # Update df_temp based on filters
   observe({
-    df_temp <- df[rev(row.names(df)), ]
+    df_temp <- data_source$df[rev(row.names(data_source$df)), ]
 
     # source
     if (input$source == "All studies") {
@@ -410,7 +442,7 @@ server <- function(input, output, session) {
 
 
   output$dataset <- DT::renderDT(server = FALSE,
-                                 DT::datatable(df_display,
+                                 DT::datatable(data_source$df_display,
     rownames = FALSE,
     # extensions = 'Buttons',
     options = list(scrollX=TRUE, lengthMenu = c(5, 10, 15),
@@ -660,14 +692,17 @@ server <- function(input, output, session) {
     entries <- unlist(base::strsplit(entries, split = "\n")) # |-
     dois <- tolower(stringr::str_extract(entries, "10.\\d{4,9}/[-._;()/:a-z0-9A-Z]+"))
 
+    # Use local copy to avoid modifying reactive data
+    df_local <- data_source$df
+
     # combine coded and uncoded studies
-    df[is.na(df$result), "result"] <- "Not coded yet"
+    df_local[is.na(df_local$result), "result"] <- "Not coded yet"
 
     # Check which entries  exist in the df
-    intersection <- dois[dois %in% df$doi_o]
+    intersection <- dois[dois %in% df_local$doi_o]
 
     # df subset
-    df_temp <- df[(tolower(df$doi_o) %in% dois), ]
+    df_temp <- df_local[(tolower(df_local$doi_o) %in% dois), ]
     df_temp <- df_temp[!is.na(df_temp$doi_o), ]
 
     bardata <- as.data.frame(base::table(df_temp$result, useNA = "always") / nrow(df_temp))
@@ -698,14 +733,17 @@ server <- function(input, output, session) {
     entries <- unlist(base::strsplit(entries, split = "\n")) # |-
     dois <- tolower(stringr::str_extract(entries, "10.\\d{4,9}/[-._;()/:a-z0-9A-Z]+"))
 
+    # Use local copy to avoid modifying reactive data
+    df_local <- data_source$df
+
     # combine coded and uncoded studies
-    df[is.na(df$result), "result"] <- "Not coded yet"
+    df_local[is.na(df_local$result), "result"] <- "Not coded yet"
 
     # Check which entries  exist in the df
-    intersection <- dois[dois %in% df$doi_o]
+    intersection <- dois[dois %in% df_local$doi_o]
 
     # df subset
-    df_temp <- df[(tolower(df$doi_o) %in% dois), ]
+    df_temp <- df_local[(tolower(df_local$doi_o) %in% dois), ]
     df_temp <- df_temp[!is.na(df_temp$doi_o), ]
 
     df_temp$original <- df_temp$ref_o # paste(df_temp$ref_o, df_temp$doi_o, sep = " ") # ADD DOIs if they are not already part of the reference
@@ -884,7 +922,7 @@ server <- function(input, output, session) {
 
   output$checker_bar <- plotly::renderPlotly({
     # this plot is based on the filtered entries from the checkertable
-    df_temp <- df
+    df_temp <- data_source$df
     df_temp <- df_temp[rev(row.names(df_temp)), ]
 
     # exclude non-validated entries
@@ -929,7 +967,7 @@ server <- function(input, output, session) {
 
   output$flexiblecheckertable <- DT::renderDT({
     # this plot is based on the filtered entries from the checkertable
-    df_temp <- df
+    df_temp <- data_source$df
     df_temp <- df_temp[rev(row.names(df_temp)), ]
 
     # exclude non-validated entries

inst/fred_explorer/ui.R

@@ -84,7 +84,10 @@ sidebar_contents <- sidebar(
                selected = "significance_r"),
   div(
     HTML("<strong>NB:</strong> The success criteria (e.g., <em>p</em>-values, CIs) are calculated from raw effect and sample sizes. These may differ from original reports that used adjusted models.")
-  )
+  ),
+  hr(),
+  actionButton("refresh_data", "Load latest data", icon = icon("refresh"),
+               style = "width: 100%;")
 )
 
 # Define content for each panel