diff --git a/.Rbuildignore b/.Rbuildignore index a22f894..725cd77 100644 --- a/.Rbuildignore +++ b/.Rbuildignore @@ -1,3 +1,5 @@ +^renv$ +^renv\.lock$ ^.*\.Rproj$ ^\.Rproj\.user$ build.R diff --git a/.Rprofile b/.Rprofile new file mode 100644 index 0000000..81b960f --- /dev/null +++ b/.Rprofile @@ -0,0 +1 @@ +source("renv/activate.R") diff --git a/DESCRIPTION b/DESCRIPTION index 74e8e3f..e7e5d83 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -4,9 +4,9 @@ Version: 1.1.0 Authors@R: person("Jason", "Bryer", email = "jason@bryer.org", role = c("aut", "cre")) Description: This package extends the DT::DataTable to allow users to create, edit, and delete rows from the data table. -Depends: R (>= 4.1.0), DT, shiny +Depends: R (>= 4.1.0), DT, shiny, shinyjs Suggests: RSQLite License: LGPL (>= 3) Encoding: UTF-8 LazyData: true -RoxygenNote: 7.2.1 +RoxygenNote: 7.3.1 diff --git a/R/DTedit-package.R b/R/DTedit-package.R index b47dc7b..834b789 100644 --- a/R/DTedit-package.R +++ b/R/DTedit-package.R @@ -1,7 +1,6 @@ #' Editable DataTables for shiny apps #' #' @name DTedit-package -#' @docType package #' @title Editable DataTables for shiny apps #' @author \email{jason@@bryer.org} #' @keywords package shiny DataTable @@ -9,4 +8,4 @@ #' textAreaInput passwordInput renderText modalDialog div textOutput modalButton #' actionButton showModal observeEvent p column br removeModal renderUI runApp #' @importFrom DT dataTableOutput renderDataTable dataTableProxy replaceData -NA +"_PACKAGE" diff --git a/R/dtedit.R b/R/dtedit.R index bd6e0bb..213567e 100644 --- a/R/dtedit.R +++ b/R/dtedit.R @@ -1,18 +1,20 @@ #' Function to create a DataTable with Add, Edit, and Delete buttons. #' -#' This object will maintain data state. However, in order of the data to persist -#' between Shiny instances, data needs to be saved to some external format (e.g. -#' database or R data file). The callback functions provide a mechanism for this -#' function to interact with a permanent data storage scheme. The callback -#' functions are called when the user adds, updates, or deletes a row from the -#' data table. The callback must accept two parameters: \code{data} and \code{row}. -#' For inserting and updating, the \code{data} object is the current state of -#' data table including any additions or updates. The \code{row} parameter indicates -#' which row from \code{data} was modified (or added). For deletions, however, -#' the \code{data} represents the data table just before deleting the specified -#' row. That is, if \code{callback.delete} returns a \code{data.frame}, that will -#' be the new data table; otherwise this function will remove row \code{row} from -#' \code{data} and that will become the current data table. +#' This object will maintain data state. However, in order of the data to +#' persist between Shiny instances, data needs to be saved to some external +#' format (e.g. database or R data file). The callback functions provide a +#' mechanism for this function to interact with a permanent data storage scheme. +#' +#' The callback functions are called when the user adds, updates, or deletes a +#' row from the data table. The callback must accept three parameters: +#' \code{data}, \code{row}, and \code{input} For inserting and updating, the +#' \code{data} object is the current state of data table including any additions +#' or updates. The \code{row} parameter indicates which row from \code{data} was +#' modified (or added). For deletions, however, the \code{data} represents the +#' data table just before deleting the specified row. That is, if +#' \code{callback.delete} returns a \code{data.frame}, that will be the new data +#' table; otherwise this function will remove row \code{row} from \code{data} +#' and that will become the current data table. #' #' The callback functions may throw errors (see e.g. \code{stop}) if there are #' problems with data. That is, if data validation checks indicate data problems @@ -22,35 +24,37 @@ #' modal dialog is not dismissed and the user can further edit the data and #' retry the insertion or update. #' -#' Callback functions may return a \code{data.frame}. When a \code{data.frame} is -#' returned that will become the current state of the data table. If anything +#' Callback functions may return a \code{data.frame}. When a \code{data.frame} +#' is returned that will become the current state of the data table. If anything #' else is returned then the internal \code{data.frame} will be used. #' #' @param input Shiny input object passed from the server. #' @param output Shiny output object passed from the server. -#' @param name the name of the UI output. That is, put \code{uiOutput(name)} where -#' you want the DataTable in \code{ui.R}. When using more that one \code{dtedit} -#' within a Shiny application the name must be unique. +#' @param name the name of the UI output. That is, put \code{uiOutput(name)} +#' where you want the DataTable in \code{ui.R}. When using more that one +#' \code{dtedit} within a Shiny application the name must be unique. #' @param thedata a data frame to view and edit. -#' @param view.cols character vector with the column names to show in the DataTable. -#' This can be a subset of the full \code{data.frame}. -#' @param edit.cols character vector with the column names the user can edit/add. -#' This can be a subset of the full \code{data.frame}. +#' @param view.cols character vector with the column names to show in the +#' DataTable. This can be a subset of the full \code{data.frame}. +#' @param edit.cols character vector with the column names the user can +#' edit/add. This can be a subset of the full \code{data.frame}. #' @param edit.label.cols character vector with the labels to use on the edit -#' and add dialogs. The length and order of \code{code.cols.labels} must -#' correspond to \code{edit.cols}. +#' and add dialogs. The length and order of \code{code.cols.labels} must +#' correspond to \code{edit.cols}. #' @param input.types a character vector where the name corresponds to a column -#' in \code{edit.cols} and the value is the input type. Possible values -#' are \code{dateInput}, \code{selectInput}, \code{numericInput}, -#' \code{textInput}, \code{textAreaInput}, or \code{passwordInput}. -#' The most common case where this parameter is desirable is when a text -#' area is required instead of a simple text input. -#' @param input.choices a list of character vectors. The names of each element in the list must -#' correspond to a column name in the data. The value, a character vector, are the options -#' presented to the user for data entry. -#' @param selectize Whether to use selectize.js or not. See \code{\link{selectInput}} for more info. +#' in \code{edit.cols} and the value is the input type. Possible values are +#' \code{dateInput}, \code{selectInput}, \code{numericInput}, +#' \code{textInput}, \code{textAreaInput}, or \code{passwordInput}. The most +#' common case where this parameter is desirable is when a text area is +#' required instead of a simple text input. +#' @param input.choices a list of character vectors. The names of each element +#' in the list must correspond to a column name in the data. The value, a +#' character vector, are the options presented to the user for data entry. +#' @param selectize Whether to use selectize.js or not. See +#' \code{\link{selectInput}} for more info. #' @param defaultPageLength number of rows to show in the data table by default. -#' @param modal.size the size of the modal dialog. See \code{\link{modalDialog}}. +#' @param modal.size the size of the modal dialog. See +#' \code{\link{modalDialog}}. #' @param text.width width of text inputs. #' @param textarea.width the width of text area inputs. #' @param textarea.height the height of text area inputs. @@ -60,419 +64,469 @@ #' @param title.delete the title of the dialog box for deleting a row. #' @param title.edit the title of the dialog box for editing a row. #' @param title.add the title of the dialog box for inserting a new row. +#' #' @param label.delete the label of the delete button. #' @param label.edit the label of the edit button. #' @param label.add the label of the add button. #' @param label.copy the label of the copy button. +#' #' @param show.delete whether to show/enable the delete button. #' @param show.update whether to show/enable the update button. #' @param show.insert whether to show/enable the insert button. #' @param show.copy whether to show/enablre the copy button. -#' @param callback.delete a function called when the user deletes a row. This function should -#' return an updated data.frame. -#' @param callback.update a function called when the user updates a row. This function should -#' return an updated data.frame. -#' @param callback.insert a function called when the user inserts a new row. This function should -#' return an updated data.frame. -#' @param click.time.threshold This is to prevent duplicate entries usually by double clicking the -#' save or update buttons. If the user clicks the save button again within this amount of -#' time (in seconds), the subsequent click will be ignored. Set to zero to disable this -#' feature. For developers, a message is printed using the warning function. +#' +#' @param callback.delete a function called when the user deletes a row. This +#' function should return an updated data.frame. +#' @param callback.update a function called when the user updates a row. This +#' function should return an updated data.frame. +#' @param callback.insert a function called when the user inserts a new row. +#' This function should return an updated data.frame. +#' @param click.time.threshold This is to prevent duplicate entries usually by +#' double clicking the save or update buttons. If the user clicks the save +#' button again within this amount of time (in seconds), the subsequent click +#' will be ignored. Set to zero to disable this feature. For developers, a +#' message is printed using the warning function. #' @param datatable.options options passed to \code{\link{DT::renderDataTable}}. -#' See \link{https://rstudio.github.io/DT/options.html} for more information. +#' See \link{https://rstudio.github.io/DT/options.html} for more information. +#' @inheritParams DT::renderDataTable +#' #' @export dtedit <- function(input, output, name, thedata, id, - view.cols = names(thedata), - edit.cols = names(thedata), - edit.label.cols = edit.cols, - input.types, - input.choices = NULL, - selectize = TRUE, - modal.size = 'm', - text.width = '100%', - textarea.width = '570px', - textarea.height = '200px', - date.width = '100px', - numeric.width = '100px', - select.width = '100%', - defaultPageLength = 10, - title.delete = 'Delete', - title.edit = 'Edit', - title.add = 'New', - label.delete = 'Delete', - label.edit = 'Edit', - label.add = 'New', - label.copy = 'Copy', - show.delete = TRUE, - show.update = TRUE, - show.insert = TRUE, - show.copy = TRUE, - callback.delete = function(data, row) { }, - callback.update = function(data, olddata, row) { }, - callback.insert = function(data, row) { }, - click.time.threshold = 2, # in seconds - datatable.options = list(pageLength=defaultPageLength) + view.cols = names(thedata), + edit.cols = names(thedata), + edit.label.cols = edit.cols, + input.types, + input.choices = NULL, + selectize = TRUE, + modal.size = 'm', + text.width = '100%', + textarea.width = '570px', + textarea.height = '200px', + date.width = '100px', + numeric.width = '100px', + select.width = '100%', + defaultPageLength = 10, + # + title.delete = 'Delete', + title.edit = 'Edit', + title.add = 'New', + # + label.delete = 'Delete', + label.edit = 'Edit', + label.add = 'New', + label.copy = 'Copy', + # + show.delete = TRUE, + show.update = TRUE, + show.insert = TRUE, + show.copy = TRUE, + # + enable.delete = TRUE, + enable.update = TRUE, + enable.insert = TRUE, + enable.copy = TRUE, + # + callback.delete = function(data, row, input) { }, + callback.update = function(data, olddata, row, input) { }, + callback.insert = function(data, row, input) { }, + callback.replace = function(data, input) {data}, + # + callback.filter = function(data, input) {data}, + click.time.threshold = 2, # in seconds + datatable.options = list(pageLength=defaultPageLength), + colnames ) { - # Some basic parameter checking - if(!is.data.frame(thedata) | ncol(thedata) < 1) { - stop('Must provide a data frame with at least one column.') - } else if(length(edit.cols) != length(edit.label.cols)) { - stop('edit.cols and edit.label.cols must be the same length.') - } else if(!all(view.cols %in% names(thedata))) { - stop('Not all view.cols are in the data.') - } else if(!all(edit.cols %in% names(thedata))) { - stop('Not all edit.cols are in the data.') - } - - if(missing(id)) { - id <- '' - } else { - id <- paste0(id, '-') - } - - DataTableName <- paste0(name, 'dt') - - result <- shiny::reactiveValues() - result$thedata <- thedata - result$view.cols <- view.cols - result$edit.cols <- edit.cols - - dt.proxy <- DT::dataTableProxy(DataTableName) - - selectInputMultiple <- function(...) { - shiny::selectInput(multiple = TRUE, selectize = selectize, ...) - } - - valid.input.types <- c('dateInput', 'selectInput', 'numericInput', - 'textInput', 'textAreaInput', 'passwordInput', - 'selectInputMultiple') - inputTypes <- sapply(thedata[,edit.cols], FUN=function(x) { - switch(class(x), - list = 'selectInputMultiple', - character = 'textInput', - Date = 'dateInput', - factor = 'selectInput', - integer = 'numericInput', - numeric = 'numericInput') - }) - if(!missing(input.types)) { - if(!all(names(input.types) %in% edit.cols)) { - stop('input.types column not a valid editting column: ', - paste0(names(input.types)[!names(input.types) %in% edit.cols])) - } - if(!all(input.types %in% valid.input.types)) { - stop(paste0('input.types must only contain values of: ', - paste0(valid.input.types, collapse = ', '))) - } - inputTypes[names(input.types)] <- input.types - } - - # Convert any list columns to characters before displaying - for(i in 1:ncol(thedata)) { - if(nrow(thedata) == 0) { - thedata[,i] <- character() - } else if(is.list(thedata[,i])) { - thedata[,i] <- sapply(thedata[,i], FUN = function(x) { paste0(x, collapse = ', ') }) - } - } - - output[[DataTableName]] <- DT::renderDataTable({ - thedata[,view.cols] - }, options = datatable.options, server=TRUE, selection='single', rownames=FALSE) - - getFields <- function(typeName, values) { - fields <- list() - for(i in seq_along(edit.cols)) { - if(inputTypes[i] == 'dateInput') { - value <- ifelse(missing(values), - as.character(Sys.Date()), - as.character(values[,edit.cols[i]])) - fields[[i]] <- dateInput( - inputId = paste0(id, name, typeName, edit.cols[i]), - label = edit.label.cols[i], - value = value, - width = date.width) - } else if(inputTypes[i] == 'selectInputMultiple') { - value <- ifelse(missing(values), '', values[,edit.cols[i]]) - if(is.list(value)) { - value <- value[[1]] - } - choices <- '' - if(!missing(values)) { - choices <- unique(unlist(values[,edit.cols[i]])) - } - if(!is.null(input.choices)) { - if(edit.cols[i] %in% names(input.choices)) { - choices <- input.choices[[edit.cols[i]]] - } - } - if(length(choices) == 1) { - if(choices == '') { - warning(paste0('No choices available for ', edit.cols[i], - '. Specify them using the input.choices parameter')) - } - } - fields[[i]] <- selectInputMultiple( - inputId = paste0(id, name, typeName, edit.cols[i]), - label = edit.label.cols[i], - choices = choices, - selected = value, - width = select.width) - } else if(inputTypes[i] == 'selectInput') { - value <- ifelse(missing(values), '', as.character(values[,edit.cols[i]])) - fields[[i]] <- shiny::selectInput( - inputId = paste0(id, name, typeName, edit.cols[i]), - label = edit.label.cols[i], - choices = levels(result$thedata[,edit.cols[i]]), - selected = value, - width = select.width) - } else if(inputTypes[i] == 'numericInput') { - value <- ifelse(missing(values), 0, values[,edit.cols[i]]) - fields[[i]] <- shiny::numericInput( - inputId = paste0(id, name, typeName, edit.cols[i]), - label = edit.label.cols[i], - value = value, - width = numeric.width) - } else if(inputTypes[i] == 'textAreaInput') { - value <- ifelse(missing(values), '', values[,edit.cols[i]]) - fields[[i]] <- shiny::textAreaInput( - inputId = paste0(id, name, typeName, edit.cols[i]), - label = edit.label.cols[i], - value = value, - width = textarea.width, height=textarea.height) - } else if(inputTypes[i] == 'textInput') { - value <- ifelse(missing(values), '', values[,edit.cols[i]]) - fields[[i]] <- shiny::textInput( - inputId = paste0(id, name, typeName, edit.cols[i]), - label = edit.label.cols[i], - value = value, - width = text.width) - } else if(inputTypes[i] == 'passwordInput') { - value <- ifelse(missing(values), '', values[,edit.cols[i]]) - fields[[i]] <- shiny::passwordInput( - inputId = paste0(id, name, typeName, edit.cols[i]), - label = edit.label.cols[i], - value = value, - width = text.width) - } else { - stop('Invalid input type!') - } - } - return(fields) - } - - output[[paste0(name, '_message')]] <- shiny::renderText('') - - updateData <- function(proxy, data, ...) { - # Convert any list columns to characters before displaying - for(i in 1:ncol(data)) { - if(is.list(data[,i])) { - data[,i] <- sapply(data[,i], FUN = function(x) { paste0(x, collapse = ', ') }) - } - } - DT::replaceData(proxy, data, ...) - } - - ##### Insert functions ##################################################### - - observeEvent(input[[paste0(name, '_add')]], { - if(!is.null(row)) { - shiny::showModal(addModal()) - } - }) - - insert.click <- NA - - observeEvent(input[[paste0(name, '_insert')]], { - if(!is.na(insert.click)) { - lastclick <- as.numeric(Sys.time() - insert.click, units = 'secs') - if(lastclick < click.time.threshold) { - warning(paste0('Double click detected. Ignoring insert call for ', name, '.')) - return() - } - } - insert.click <<- Sys.time() - - newdata <- result$thedata - row <- nrow(newdata) + 1 - newdata[row,] <- NA - - for(i in edit.cols) { - if(inputTypes[i] %in% c('selectInputMultiple')) { - newdata[[i]][row] <- list(input[[paste0(name, '_add_', i)]]) - } else { - newdata[row,i] <- input[[paste0(name, '_add_', i)]] - } - } - tryCatch({ - callback.data <- callback.insert(data = newdata, row = row) - if(!is.null(callback.data) & is.data.frame(callback.data)) { - result$thedata <- callback.data - } else { - result$thedata <- newdata - } - updateData(dt.proxy, - result$thedata[,view.cols], - rownames = FALSE) - shiny::removeModal() - return(TRUE) - }, error = function(e) { - output[[paste0(name, '_message')]] <<- shiny::renderText(geterrmessage()) - return(FALSE) - }) - }) - - addModal <- function(row, values) { - output[[paste0(name, '_message')]] <- shiny::renderText('') - fields <- getFields('_add_', values) - shiny::modalDialog(title = title.add, - shiny::div(shiny::textOutput(paste0(name, '_message')), style='color:red'), - fields, - footer = shiny::column(shiny::modalButton('Cancel'), - shiny::actionButton(paste0(id, name, '_insert'), 'Save'), - width=12), - size = modal.size - ) - } - - ##### Copy functions ####################################################### - - observeEvent(input[[paste0(name, '_copy')]], { - row <- input[[paste0(name, 'dt_rows_selected')]] - if(!is.null(row)) { - if(row > 0) { - shiny::showModal(addModal(values=result$thedata[row,])) - } - } - }) - - ##### Update functions ##################################################### - - observeEvent(input[[paste0(name, '_edit')]], { - row <- input[[paste0(name, 'dt_rows_selected')]] - if(!is.null(row)) { - if(row > 0) { - shiny::showModal(editModal(row)) - } - } - }) - - update.click <- NA - - observeEvent(input[[paste0(name, '_update')]], { - if(!is.na(update.click)) { - lastclick <- as.numeric(Sys.time() - update.click, units = 'secs') - if(lastclick < click.time.threshold) { - warning(paste0('Double click detected. Ignoring update call for ', name, '.')) - return() - } - } - update.click <- Sys.time() - - row <- input[[paste0(name, 'dt_rows_selected')]] - if(!is.null(row)) { - if(row > 0) { - newdata <- result$thedata - for(i in edit.cols) { - if(inputTypes[i] %in% c('selectInputMultiple')) { - newdata[[i]][row] <- list(input[[paste0(name, '_edit_', i)]]) - } else { - newdata[row,i] <- input[[paste0(name, '_edit_', i)]] - } - } - tryCatch({ - callback.data <- callback.update(data = newdata, - olddata = result$thedata, - row = row) - if(!is.null(callback.data) & is.data.frame(callback.data)) { - result$thedata <- callback.data - } else { - result$thedata <- newdata - } - updateData(dt.proxy, - result$thedata[,view.cols], - rownames = FALSE) - shiny::removeModal() - return(TRUE) - }, error = function(e) { - output[[paste0(name, '_message')]] <<- shiny::renderText(geterrmessage()) - return(FALSE) - }) - } - } - return(FALSE) - }) - - editModal <- function(row) { - output[[paste0(name, '_message')]] <- renderText('') - fields <- getFields('_edit_', values = result$thedata[row,]) - shiny::modalDialog(title = title.edit, - shiny::div(shiny::textOutput(paste0(name, '_message')), style='color:red'), - fields, - footer = column(shiny::modalButton('Cancel'), - shiny::actionButton(paste0(id, name, '_update'), 'Save'), - width=12), - size = modal.size - ) - } - - ##### Delete functions ##################################################### - - observeEvent(input[[paste0(name, '_remove')]], { - row <- input[[paste0(name, 'dt_rows_selected')]] - if(!is.null(row)) { - if(row > 0) { - shiny::showModal(deleteModal(row)) - } - } - }) - - observeEvent(input[[paste0(name, '_delete')]], { - row <- input[[paste0(name, 'dt_rows_selected')]] - if(!is.null(row)) { - if(row > 0) { - newdata <- callback.delete(data = result$thedata, row = row) - if(!is.null(newdata) & is.data.frame(newdata)) { - result$thedata <- newdata - } else { - result$thedata <- result$thedata[-row,] - } - updateData(dt.proxy, - result$thedata[,view.cols], - rownames = FALSE) - shiny::removeModal() - return(TRUE) - } - } - return(FALSE) - }) - - deleteModal <- function(row) { - fields <- list() - for(i in view.cols) { - fields[[i]] <- div(paste0(i, ' = ', result$thedata[row,i])) - } - shiny::modalDialog(title = title.delete, - shiny::p('Are you sure you want to delete this record?'), - fields, - footer = shiny::column(modalButton('Cancel'), - shiny::actionButton(paste0(id, name, '_delete'), 'Delete'), - width=12), - size = modal.size - ) - } - - ##### Build the UI for the DataTable and buttons ########################### - - output[[name]] <- shiny::renderUI({ - shiny::div( - if(show.insert) { shiny::actionButton(paste0(id, name, '_add'), label.add) }, - if(show.update) { shiny::actionButton(paste0(id, name, '_edit'), label.edit) }, - if(show.delete) { shiny::actionButton(paste0(id, name, '_remove'), label.delete) }, - if(show.copy) { shiny::actionButton(paste0(id, name, '_copy'), label.copy) }, - shiny::br(), shiny::br(), DT::dataTableOutput(paste0(id, DataTableName)) - ) - }) - - return(result) + # Some basic parameter checking + if(!is.data.frame(thedata) | ncol(thedata) < 1) { + stop('Must provide a data frame with at least one column.') + } else if(length(edit.cols) != length(edit.label.cols)) { + stop('edit.cols and edit.label.cols must be the same length.') + } else if(!all(view.cols %in% names(thedata))) { + stop('Not all view.cols are in the data.') + } else if(!all(edit.cols %in% names(thedata))) { + stop('Not all edit.cols are in the data.') + } + + if(missing(id)) { + id <- '' + } else { + id <- paste0(id, '-') + } + + DataTableName <- paste0(name, '_dt') + + result <- shiny::reactiveValues() + result$thedata <- thedata + result$view.cols <- view.cols + result$edit.cols <- edit.cols + result$dt.name <- DataTableName + result$dt.proxy <- dt.proxy <- DT::dataTableProxy(DataTableName) + + + + selectInputMultiple <- function(...) { + shiny::selectInput(multiple = TRUE, selectize = selectize, ...) + } + + valid.input.types <- c('dateInput', 'selectInput', 'numericInput', + 'textInput', 'textAreaInput', 'passwordInput', + 'selectInputMultiple') + inputTypes <- sapply(thedata[,edit.cols], FUN=function(x) { + switch(class(x), + list = 'selectInputMultiple', + character = 'textInput', + Date = 'dateInput', + factor = 'selectInput', + integer = 'numericInput', + numeric = 'numericInput') + }) + if(!missing(input.types)) { + if(!all(names(input.types) %in% edit.cols)) { + stop('input.types column not a valid editting column: ', + paste0(names(input.types)[!names(input.types) %in% edit.cols])) + } + if(!all(input.types %in% valid.input.types)) { + stop(paste0('input.types must only contain values of: ', + paste0(valid.input.types, collapse = ', '))) + } + inputTypes[names(input.types)] <- input.types + } + + + output[[DataTableName]] <- DT::renderDataTable({ + thedata <- result$thedata + + # Convert any list columns to characters before displaying + for(i in 1:ncol(thedata)) { + if(nrow(thedata) == 0) { + thedata[,i] <- character() + } else if(is.list(thedata[,i])) { + thedata[,i] <- sapply(thedata[,i], FUN = function(x) { paste0(x, collapse = ', ') }) + } + } + + thedata[,view.cols] + }, + options = datatable.options, + server=TRUE, + selection='single', + rownames=FALSE, + colnames=colnames + ) + + getFields <- function(typeName, values) { + fields <- list() + for(i in seq_along(edit.cols)) { + if(inputTypes[i] == 'dateInput') { + value <- ifelse(missing(values), + as.character(Sys.Date()), + as.character(values[,edit.cols[i]])) + fields[[i]] <- dateInput( + inputId = paste0(id, name, typeName, edit.cols[i]), + label = edit.label.cols[i], + value = value, + width = date.width) + } else if(inputTypes[i] == 'selectInputMultiple') { + value <- ifelse(missing(values), '', values[,edit.cols[i]]) + if(is.list(value)) { + value <- value[[1]] + } + choices <- '' + if(!missing(values)) { + choices <- unique(unlist(values[,edit.cols[i]])) + } + if(!is.null(input.choices)) { + if(edit.cols[i] %in% names(input.choices)) { + choices <- input.choices[[edit.cols[i]]] + } + } + if(length(choices) == 1) { + if(choices == '') { + warning(paste0('No choices available for ', edit.cols[i], + '. Specify them using the input.choices parameter')) + } + } + fields[[i]] <- selectInputMultiple( + inputId = paste0(id, name, typeName, edit.cols[i]), + label = edit.label.cols[i], + choices = choices, + selected = value, + width = select.width) + } else if(inputTypes[i] == 'selectInput') { + value <- ifelse(missing(values), '', as.character(values[,edit.cols[i]])) + fields[[i]] <- shiny::selectInput( + inputId = paste0(id, name, typeName, edit.cols[i]), + label = edit.label.cols[i], + choices = levels(result$thedata[,edit.cols[i]]), + selected = value, + width = select.width) + } else if(inputTypes[i] == 'numericInput') { + value <- ifelse(missing(values), 0, values[,edit.cols[i]]) + fields[[i]] <- shiny::numericInput( + inputId = paste0(id, name, typeName, edit.cols[i]), + label = edit.label.cols[i], + value = value, + width = numeric.width) + } else if(inputTypes[i] == 'textAreaInput') { + value <- ifelse(missing(values), '', values[,edit.cols[i]]) + fields[[i]] <- shiny::textAreaInput( + inputId = paste0(id, name, typeName, edit.cols[i]), + label = edit.label.cols[i], + value = value, + width = textarea.width, height=textarea.height) + } else if(inputTypes[i] == 'textInput') { + value <- ifelse(missing(values), '', values[,edit.cols[i]]) + fields[[i]] <- shiny::textInput( + inputId = paste0(id, name, typeName, edit.cols[i]), + label = edit.label.cols[i], + value = value, + width = text.width) + } else if(inputTypes[i] == 'passwordInput') { + value <- ifelse(missing(values), '', values[,edit.cols[i]]) + fields[[i]] <- shiny::passwordInput( + inputId = paste0(id, name, typeName, edit.cols[i]), + label = edit.label.cols[i], + value = value, + width = text.width) + } else { + stop('Invalid input type!') + } + } + return(fields) + } + + output[[paste0(name, '_message')]] <- shiny::renderText('') + + updateData <- function(proxy, data, ...) { + # Convert any list columns to characters before displaying + for(i in 1:ncol(data)) { + if(is.list(data[,i])) { + data[,i] <- sapply(data[,i], FUN = function(x) { paste0(x, collapse = ', ') }) + } + } + data <- callback.filter(data, input) + DT::replaceData(proxy, data, ...) + } + + ##### Insert functions ##################################################### + + observeEvent(input[[paste0(name, '_add')]], { + if(!is.null(row)) { + shiny::showModal(addModal()) + } + }) + + insert.click <- NA + + observeEvent(input[[paste0(name, '_insert')]], { + if(!is.na(insert.click)) { + lastclick <- as.numeric(Sys.time() - insert.click, units = 'secs') + if(lastclick < click.time.threshold) { + warning(paste0('Double click detected. Ignoring insert call for ', name, '.')) + return() + } + } + insert.click <<- Sys.time() + + newdata <- result$thedata + row <- nrow(newdata) + 1 + newdata[row,] <- NA + + for(i in edit.cols) { + if(inputTypes[i] %in% c('selectInputMultiple')) { + newdata[[i]][row] <- list(input[[paste0(name, '_add_', i)]]) + } else { + newdata[row,i] <- input[[paste0(name, '_add_', i)]] + } + } + tryCatch({ + callback.data <- callback.insert(data = newdata, row = row, input = input) + if(!is.null(callback.data) & is.data.frame(callback.data)) { + result$thedata <- callback.data + } else { + result$thedata <- newdata + } + updateData(dt.proxy, + result$thedata[,view.cols], + rownames = FALSE) + shiny::removeModal() + return(TRUE) + }, error = function(e) { + output[[paste0(name, '_message')]] <<- shiny::renderText(geterrmessage()) + return(FALSE) + }) + }) + + addModal <- function(row, values) { + output[[paste0(name, '_message')]] <- shiny::renderText('') + fields <- getFields('_add_', values) + shiny::modalDialog(title = title.add, + shiny::div(shiny::textOutput(paste0(name, '_message')), style='color:red'), + fields, + footer = shiny::column(shiny::modalButton('Cancel'), + shiny::actionButton(paste0(id, name, '_insert'), 'Save'), + width=12), + size = modal.size + ) + } + + ##### Copy functions ####################################################### + + observeEvent(input[[paste0(name, '_copy')]], { + row <- input[[paste0(name, '_dt_rows_selected')]] + if(!is.null(row) && row > 0) { + shiny::showModal(addModal(values=result$thedata[row,])) + } else { + shiny::showNotification('No row selected for copy.', type='error') + } + + }) + + ##### Update functions ##################################################### + + observeEvent(input[[paste0(name, '_edit')]], { + row <- input[[paste0(name, '_dt_rows_selected')]] + if(!is.null(row) && row > 0) { + shiny::showModal(editModal(row)) + } else { + browser() + shiny::showNotification('No row selected for update.', type='error') + } + }) + + update.click <- NA + + observeEvent(input[[paste0(name, '_update')]], { + if(!is.na(update.click)) { + lastclick <- as.numeric(Sys.time() - update.click, units = 'secs') + if(lastclick < click.time.threshold) { + warning(paste0('Double click detected. Ignoring update call for ', name, '.')) + return() + } + } + update.click <- Sys.time() + + row <- input[[paste0(name, '_dt_rows_selected')]] + if(!is.null(row) && row > 0) { + newdata <- result$thedata + for(i in edit.cols) { + if(inputTypes[i] %in% c('selectInputMultiple')) { + newdata[[i]][row] <- list(input[[paste0(name, '_edit_', i)]]) + } else { + newdata[row,i] <- input[[paste0(name, '_edit_', i)]] + } + } + tryCatch({ + callback.data <- callback.update(data = newdata, + olddata = result$thedata, + row = row, + input = input) + if(!is.null(callback.data) & is.data.frame(callback.data)) { + result$thedata <- callback.data + } else { + result$thedata <- newdata + } + updateData(dt.proxy, + result$thedata[,view.cols], + rownames = FALSE) + shiny::removeModal() + return(TRUE) + }, error = function(e) { + output[[paste0(name, '_message')]] <<- shiny::renderText(geterrmessage()) + return(FALSE) + }) + } else + { + shiny::showNotification('No row selected for delete.', type='error') + } + + return(FALSE) + }) + + editModal <- function(row) { + output[[paste0(name, '_message')]] <- renderText('') + fields <- getFields('_edit_', values = result$thedata[row,]) + shiny::modalDialog(title = title.edit, + shiny::div(shiny::textOutput(paste0(name, '_message')), style='color:red'), + fields, + footer = column(shiny::modalButton('Cancel'), + shiny::actionButton(paste0(id, name, '_update'), 'Save'), + width=12), + size = modal.size + ) + } + + ##### Delete functions ##################################################### + + observeEvent(input[[paste0(name, '_remove')]], { + row <- input[[paste0(name, '_dt_rows_selected')]] + if(!is.null(row) && row > 0) { + shiny::showModal(deleteModal(row)) + } else { + shiny::showNotification('No row selected for delete', type='error') + } + }) + + observeEvent(input[[paste0(name, '_delete')]], { + row <- input[[paste0(name, '_dt_rows_selected')]] + if(!is.null(row) && row > 0) { + newdata <- callback.delete(data = result$thedata, row = row, input=input) + if(!is.null(newdata) & is.data.frame(newdata)) { + result$thedata <- newdata + } else { + result$thedata <- result$thedata[-row,] + } + updateData(dt.proxy, + result$thedata[,view.cols], + rownames = FALSE) + shiny::removeModal() + return(TRUE) + + } else { + shiny::showNotification('No row selected for delete.', type='error') + } + return(FALSE) + }) + + deleteModal <- function(row) { + fields <- shinyjs::disabled(getFields('_add_', values = result$thedata[row,])) + shiny::modalDialog(title = title.delete, + shiny::p('Are you sure you want to delete this record?'), + fields, + footer = shiny::column( + modalButton('Cancel'), + shiny::actionButton(paste0(id, name, '_delete'), 'Delete'), + width=12), + size = modal.size + ) + } + + ##### Build the UI for the DataTable and buttons ########################### + + show_enable <- function(show=TRUE, enable=TRUE, ...) + { + tags <- list(...) + + if (!show) + return() + + if (isTruthy(enable)) + tags + else + shinyjs::disabled(tags) + } + + output[[name]] <- + shiny::renderUI({ + shiny::div( + shinyjs::useShinyjs(), + show_enable(show.insert, enable.insert, shiny::actionButton(paste0(id, name, '_add'), label.add) ), + show_enable(show.update, enable.update, shiny::actionButton(paste0(id, name, '_edit'), label.edit) ), + show_enable(show.delete, enable.delete, shiny::actionButton(paste0(id, name, '_remove'), label.delete) ), + show_enable(show.copy, enable.copy, shiny::actionButton(paste0(id, name, '_copy'), label.copy) ), + shiny::br(), shiny::br(), DT::dataTableOutput(paste0(id, DataTableName)) + ) + }) + + return(result) } diff --git a/man/DTedit-package.Rd b/man/DTedit-package.Rd index d9b2d9f..9b7f29e 100644 --- a/man/DTedit-package.Rd +++ b/man/DTedit-package.Rd @@ -2,6 +2,7 @@ % Please edit documentation in R/DTedit-package.R \docType{package} \name{DTedit-package} +\alias{DTedit} \alias{DTedit-package} \title{Editable DataTables for shiny apps} \description{ diff --git a/man/dtedit.Rd b/man/dtedit.Rd index c283ebb..5fef9a1 100644 --- a/man/dtedit.Rd +++ b/man/dtedit.Rd @@ -35,14 +35,22 @@ dtedit( show.update = TRUE, show.insert = TRUE, show.copy = TRUE, + enable.delete = TRUE, + enable.update = TRUE, + enable.insert = TRUE, + enable.copy = TRUE, callback.delete = function(data, row) { }, callback.update = function(data, olddata, row) { }, callback.insert = function(data, row) { + }, + callback.replace = function(data) { + data }, click.time.threshold = 2, - datatable.options = list(pageLength = defaultPageLength) + datatable.options = list(pageLength = defaultPageLength), + colnames ) } \arguments{ diff --git a/renv.lock b/renv.lock new file mode 100644 index 0000000..66409b3 --- /dev/null +++ b/renv.lock @@ -0,0 +1,551 @@ +{ + "R": { + "Version": "4.4.0", + "Repositories": [ + { + "Name": "CRAN", + "URL": "https://packagemanager.posit.co/cran/latest" + } + ] + }, + "Packages": { + "DT": { + "Package": "DT", + "Version": "0.33", + "Source": "Repository", + "Repository": "CRAN", + "Requirements": [ + "crosstalk", + "htmltools", + "htmlwidgets", + "httpuv", + "jquerylib", + "jsonlite", + "magrittr", + "promises" + ], + "Hash": "64ff3427f559ce3f2597a4fe13255cb6" + }, + "R6": { + "Package": "R6", + "Version": "2.5.1", + "Source": "Repository", + "Repository": "CRAN", + "Requirements": [ + "R" + ], + "Hash": "470851b6d5d0ac559e9d01bb352b4021" + }, + "Rcpp": { + "Package": "Rcpp", + "Version": "1.0.12", + "Source": "Repository", + "Repository": "CRAN", + "Requirements": [ + "methods", + "utils" + ], + "Hash": "5ea2700d21e038ace58269ecdbeb9ec0" + }, + "base64enc": { + "Package": "base64enc", + "Version": "0.1-3", + "Source": "Repository", + "Repository": "CRAN", + "Requirements": [ + "R" + ], + "Hash": "543776ae6848fde2f48ff3816d0628bc" + }, + "bslib": { + "Package": "bslib", + "Version": "0.7.0", + "Source": "Repository", + "Repository": "CRAN", + "Requirements": [ + "R", + "base64enc", + "cachem", + "fastmap", + "grDevices", + "htmltools", + "jquerylib", + "jsonlite", + "lifecycle", + "memoise", + "mime", + "rlang", + "sass" + ], + "Hash": "8644cc53f43828f19133548195d7e59e" + }, + "cachem": { + "Package": "cachem", + "Version": "1.1.0", + "Source": "Repository", + "Repository": "CRAN", + "Requirements": [ + "fastmap", + "rlang" + ], + "Hash": "cd9a672193789068eb5a2aad65a0dedf" + }, + "cli": { + "Package": "cli", + "Version": "3.6.2", + "Source": "Repository", + "Repository": "CRAN", + "Requirements": [ + "R", + "utils" + ], + "Hash": "1216ac65ac55ec0058a6f75d7ca0fd52" + }, + "commonmark": { + "Package": "commonmark", + "Version": "1.9.1", + "Source": "Repository", + "Repository": "CRAN", + "Hash": "5d8225445acb167abf7797de48b2ee3c" + }, + "crayon": { + "Package": "crayon", + "Version": "1.5.2", + "Source": "Repository", + "Repository": "CRAN", + "Requirements": [ + "grDevices", + "methods", + "utils" + ], + "Hash": "e8a1e41acf02548751f45c718d55aa6a" + }, + "crosstalk": { + "Package": "crosstalk", + "Version": "1.2.1", + "Source": "Repository", + "Repository": "CRAN", + "Requirements": [ + "R6", + "htmltools", + "jsonlite", + "lazyeval" + ], + "Hash": "ab12c7b080a57475248a30f4db6298c0" + }, + "digest": { + "Package": "digest", + "Version": "0.6.35", + "Source": "Repository", + "Repository": "CRAN", + "Requirements": [ + "R", + "utils" + ], + "Hash": "698ece7ba5a4fa4559e3d537e7ec3d31" + }, + "evaluate": { + "Package": "evaluate", + "Version": "0.24.0", + "Source": "Repository", + "Repository": "CRAN", + "Requirements": [ + "R", + "methods" + ], + "Hash": "a1066cbc05caee9a4bf6d90f194ff4da" + }, + "fastmap": { + "Package": "fastmap", + "Version": "1.2.0", + "Source": "Repository", + "Repository": "CRAN", + "Hash": "aa5e1cd11c2d15497494c5292d7ffcc8" + }, + "fontawesome": { + "Package": "fontawesome", + "Version": "0.5.2", + "Source": "Repository", + "Repository": "CRAN", + "Requirements": [ + "R", + "htmltools", + "rlang" + ], + "Hash": "c2efdd5f0bcd1ea861c2d4e2a883a67d" + }, + "fs": { + "Package": "fs", + "Version": "1.6.4", + "Source": "Repository", + "Repository": "CRAN", + "Requirements": [ + "R", + "methods" + ], + "Hash": "15aeb8c27f5ea5161f9f6a641fafd93a" + }, + "glue": { + "Package": "glue", + "Version": "1.7.0", + "Source": "Repository", + "Repository": "CRAN", + "Requirements": [ + "R", + "methods" + ], + "Hash": "e0b3a53876554bd45879e596cdb10a52" + }, + "highr": { + "Package": "highr", + "Version": "0.11", + "Source": "Repository", + "Repository": "CRAN", + "Requirements": [ + "R", + "xfun" + ], + "Hash": "d65ba49117ca223614f71b60d85b8ab7" + }, + "htmltools": { + "Package": "htmltools", + "Version": "0.5.8.1", + "Source": "Repository", + "Repository": "CRAN", + "Requirements": [ + "R", + "base64enc", + "digest", + "fastmap", + "grDevices", + "rlang", + "utils" + ], + "Hash": "81d371a9cc60640e74e4ab6ac46dcedc" + }, + "htmlwidgets": { + "Package": "htmlwidgets", + "Version": "1.6.4", + "Source": "Repository", + "Repository": "CRAN", + "Requirements": [ + "grDevices", + "htmltools", + "jsonlite", + "knitr", + "rmarkdown", + "yaml" + ], + "Hash": "04291cc45198225444a397606810ac37" + }, + "httpuv": { + "Package": "httpuv", + "Version": "1.6.15", + "Source": "Repository", + "Repository": "CRAN", + "Requirements": [ + "R", + "R6", + "Rcpp", + "later", + "promises", + "utils" + ], + "Hash": "d55aa087c47a63ead0f6fc10f8fa1ee0" + }, + "jquerylib": { + "Package": "jquerylib", + "Version": "0.1.4", + "Source": "Repository", + "Repository": "CRAN", + "Requirements": [ + "htmltools" + ], + "Hash": "5aab57a3bd297eee1c1d862735972182" + }, + "jsonlite": { + "Package": "jsonlite", + "Version": "1.8.8", + "Source": "Repository", + "Repository": "CRAN", + "Requirements": [ + "methods" + ], + "Hash": "e1b9c55281c5adc4dd113652d9e26768" + }, + "knitr": { + "Package": "knitr", + "Version": "1.47", + "Source": "Repository", + "Repository": "CRAN", + "Requirements": [ + "R", + "evaluate", + "highr", + "methods", + "tools", + "xfun", + "yaml" + ], + "Hash": "7c99b2d55584b982717fcc0950378612" + }, + "later": { + "Package": "later", + "Version": "1.3.2", + "Source": "Repository", + "Repository": "CRAN", + "Requirements": [ + "Rcpp", + "rlang" + ], + "Hash": "a3e051d405326b8b0012377434c62b37" + }, + "lazyeval": { + "Package": "lazyeval", + "Version": "0.2.2", + "Source": "Repository", + "Repository": "CRAN", + "Requirements": [ + "R" + ], + "Hash": "d908914ae53b04d4c0c0fd72ecc35370" + }, + "lifecycle": { + "Package": "lifecycle", + "Version": "1.0.4", + "Source": "Repository", + "Repository": "CRAN", + "Requirements": [ + "R", + "cli", + "glue", + "rlang" + ], + "Hash": "b8552d117e1b808b09a832f589b79035" + }, + "magrittr": { + "Package": "magrittr", + "Version": "2.0.3", + "Source": "Repository", + "Repository": "CRAN", + "Requirements": [ + "R" + ], + "Hash": "7ce2733a9826b3aeb1775d56fd305472" + }, + "memoise": { + "Package": "memoise", + "Version": "2.0.1", + "Source": "Repository", + "Repository": "CRAN", + "Requirements": [ + "cachem", + "rlang" + ], + "Hash": "e2817ccf4a065c5d9d7f2cfbe7c1d78c" + }, + "mime": { + "Package": "mime", + "Version": "0.12", + "Source": "Repository", + "Repository": "CRAN", + "Requirements": [ + "tools" + ], + "Hash": "18e9c28c1d3ca1560ce30658b22ce104" + }, + "promises": { + "Package": "promises", + "Version": "1.3.0", + "Source": "Repository", + "Repository": "CRAN", + "Requirements": [ + "R6", + "Rcpp", + "fastmap", + "later", + "magrittr", + "rlang", + "stats" + ], + "Hash": "434cd5388a3979e74be5c219bcd6e77d" + }, + "rappdirs": { + "Package": "rappdirs", + "Version": "0.3.3", + "Source": "Repository", + "Repository": "CRAN", + "Requirements": [ + "R" + ], + "Hash": "5e3c5dc0b071b21fa128676560dbe94d" + }, + "renv": { + "Package": "renv", + "Version": "1.0.7", + "Source": "Repository", + "Repository": "CRAN", + "Requirements": [ + "utils" + ], + "Hash": "397b7b2a265bc5a7a06852524dabae20" + }, + "rlang": { + "Package": "rlang", + "Version": "1.1.4", + "Source": "Repository", + "Repository": "CRAN", + "Requirements": [ + "R", + "utils" + ], + "Hash": "3eec01f8b1dee337674b2e34ab1f9bc1" + }, + "rmarkdown": { + "Package": "rmarkdown", + "Version": "2.27", + "Source": "Repository", + "Repository": "CRAN", + "Requirements": [ + "R", + "bslib", + "evaluate", + "fontawesome", + "htmltools", + "jquerylib", + "jsonlite", + "knitr", + "methods", + "tinytex", + "tools", + "utils", + "xfun", + "yaml" + ], + "Hash": "27f9502e1cdbfa195f94e03b0f517484" + }, + "sass": { + "Package": "sass", + "Version": "0.4.9", + "Source": "Repository", + "Repository": "CRAN", + "Requirements": [ + "R6", + "fs", + "htmltools", + "rappdirs", + "rlang" + ], + "Hash": "d53dbfddf695303ea4ad66f86e99b95d" + }, + "shiny": { + "Package": "shiny", + "Version": "1.8.1.1", + "Source": "Repository", + "Repository": "CRAN", + "Requirements": [ + "R", + "R6", + "bslib", + "cachem", + "commonmark", + "crayon", + "fastmap", + "fontawesome", + "glue", + "grDevices", + "htmltools", + "httpuv", + "jsonlite", + "later", + "lifecycle", + "methods", + "mime", + "promises", + "rlang", + "sourcetools", + "tools", + "utils", + "withr", + "xtable" + ], + "Hash": "54b26646816af9960a4c64d8ceec75d6" + }, + "shinyjs": { + "Package": "shinyjs", + "Version": "2.1.0", + "Source": "Repository", + "Repository": "CRAN", + "Requirements": [ + "R", + "digest", + "jsonlite", + "shiny" + ], + "Hash": "802e4786b353a4bb27116957558548d5" + }, + "sourcetools": { + "Package": "sourcetools", + "Version": "0.1.7-1", + "Source": "Repository", + "Repository": "CRAN", + "Requirements": [ + "R" + ], + "Hash": "5f5a7629f956619d519205ec475fe647" + }, + "tinytex": { + "Package": "tinytex", + "Version": "0.51", + "Source": "Repository", + "Repository": "CRAN", + "Requirements": [ + "xfun" + ], + "Hash": "d44e2fcd2e4e076f0aac540208559d1d" + }, + "withr": { + "Package": "withr", + "Version": "3.0.0", + "Source": "Repository", + "Repository": "CRAN", + "Requirements": [ + "R", + "grDevices", + "graphics" + ], + "Hash": "d31b6c62c10dcf11ec530ca6b0dd5d35" + }, + "xfun": { + "Package": "xfun", + "Version": "0.45", + "Source": "Repository", + "Repository": "CRAN", + "Requirements": [ + "grDevices", + "stats", + "tools" + ], + "Hash": "ca59c87fe305b16a9141a5874c3a7889" + }, + "xtable": { + "Package": "xtable", + "Version": "1.8-4", + "Source": "Repository", + "Repository": "CRAN", + "Requirements": [ + "R", + "stats", + "utils" + ], + "Hash": "b8acdf8af494d9ec19ccb2481a9b11c2" + }, + "yaml": { + "Package": "yaml", + "Version": "2.3.8", + "Source": "Repository", + "Repository": "CRAN", + "Hash": "29240487a071f535f5e5d5a323b7afbd" + } + } +} diff --git a/renv/.gitignore b/renv/.gitignore new file mode 100644 index 0000000..0ec0cbb --- /dev/null +++ b/renv/.gitignore @@ -0,0 +1,7 @@ +library/ +local/ +cellar/ +lock/ +python/ +sandbox/ +staging/ diff --git a/renv/activate.R b/renv/activate.R new file mode 100644 index 0000000..d13f993 --- /dev/null +++ b/renv/activate.R @@ -0,0 +1,1220 @@ + +local({ + + # the requested version of renv + version <- "1.0.7" + attr(version, "sha") <- NULL + + # the project directory + project <- Sys.getenv("RENV_PROJECT") + if (!nzchar(project)) + project <- getwd() + + # use start-up diagnostics if enabled + diagnostics <- Sys.getenv("RENV_STARTUP_DIAGNOSTICS", unset = "FALSE") + if (diagnostics) { + start <- Sys.time() + profile <- tempfile("renv-startup-", fileext = ".Rprof") + utils::Rprof(profile) + on.exit({ + utils::Rprof(NULL) + elapsed <- signif(difftime(Sys.time(), start, units = "auto"), digits = 2L) + writeLines(sprintf("- renv took %s to run the autoloader.", format(elapsed))) + writeLines(sprintf("- Profile: %s", profile)) + print(utils::summaryRprof(profile)) + }, add = TRUE) + } + + # figure out whether the autoloader is enabled + enabled <- local({ + + # first, check config option + override <- getOption("renv.config.autoloader.enabled") + if (!is.null(override)) + return(override) + + # if we're being run in a context where R_LIBS is already set, + # don't load -- presumably we're being run as a sub-process and + # the parent process has already set up library paths for us + rcmd <- Sys.getenv("R_CMD", unset = NA) + rlibs <- Sys.getenv("R_LIBS", unset = NA) + if (!is.na(rlibs) && !is.na(rcmd)) + return(FALSE) + + # next, check environment variables + # TODO: prefer using the configuration one in the future + envvars <- c( + "RENV_CONFIG_AUTOLOADER_ENABLED", + "RENV_AUTOLOADER_ENABLED", + "RENV_ACTIVATE_PROJECT" + ) + + for (envvar in envvars) { + envval <- Sys.getenv(envvar, unset = NA) + if (!is.na(envval)) + return(tolower(envval) %in% c("true", "t", "1")) + } + + # enable by default + TRUE + + }) + + # bail if we're not enabled + if (!enabled) { + + # if we're not enabled, we might still need to manually load + # the user profile here + profile <- Sys.getenv("R_PROFILE_USER", unset = "~/.Rprofile") + if (file.exists(profile)) { + cfg <- Sys.getenv("RENV_CONFIG_USER_PROFILE", unset = "TRUE") + if (tolower(cfg) %in% c("true", "t", "1")) + sys.source(profile, envir = globalenv()) + } + + return(FALSE) + + } + + # avoid recursion + if (identical(getOption("renv.autoloader.running"), TRUE)) { + warning("ignoring recursive attempt to run renv autoloader") + return(invisible(TRUE)) + } + + # signal that we're loading renv during R startup + options(renv.autoloader.running = TRUE) + on.exit(options(renv.autoloader.running = NULL), add = TRUE) + + # signal that we've consented to use renv + options(renv.consent = TRUE) + + # load the 'utils' package eagerly -- this ensures that renv shims, which + # mask 'utils' packages, will come first on the search path + library(utils, lib.loc = .Library) + + # unload renv if it's already been loaded + if ("renv" %in% loadedNamespaces()) + unloadNamespace("renv") + + # load bootstrap tools + `%||%` <- function(x, y) { + if (is.null(x)) y else x + } + + catf <- function(fmt, ..., appendLF = TRUE) { + + quiet <- getOption("renv.bootstrap.quiet", default = FALSE) + if (quiet) + return(invisible()) + + msg <- sprintf(fmt, ...) + cat(msg, file = stdout(), sep = if (appendLF) "\n" else "") + + invisible(msg) + + } + + header <- function(label, + ..., + prefix = "#", + suffix = "-", + n = min(getOption("width"), 78)) + { + label <- sprintf(label, ...) + n <- max(n - nchar(label) - nchar(prefix) - 2L, 8L) + if (n <= 0) + return(paste(prefix, label)) + + tail <- paste(rep.int(suffix, n), collapse = "") + paste0(prefix, " ", label, " ", tail) + + } + + heredoc <- function(text, leave = 0) { + + # remove leading, trailing whitespace + trimmed <- gsub("^\\s*\\n|\\n\\s*$", "", text) + + # split into lines + lines <- strsplit(trimmed, "\n", fixed = TRUE)[[1L]] + + # compute common indent + indent <- regexpr("[^[:space:]]", lines) + common <- min(setdiff(indent, -1L)) - leave + paste(substring(lines, common), collapse = "\n") + + } + + startswith <- function(string, prefix) { + substring(string, 1, nchar(prefix)) == prefix + } + + bootstrap <- function(version, library) { + + friendly <- renv_bootstrap_version_friendly(version) + section <- header(sprintf("Bootstrapping renv %s", friendly)) + catf(section) + + # attempt to download renv + catf("- Downloading renv ... ", appendLF = FALSE) + withCallingHandlers( + tarball <- renv_bootstrap_download(version), + error = function(err) { + catf("FAILED") + stop("failed to download:\n", conditionMessage(err)) + } + ) + catf("OK") + on.exit(unlink(tarball), add = TRUE) + + # now attempt to install + catf("- Installing renv ... ", appendLF = FALSE) + withCallingHandlers( + status <- renv_bootstrap_install(version, tarball, library), + error = function(err) { + catf("FAILED") + stop("failed to install:\n", conditionMessage(err)) + } + ) + catf("OK") + + # add empty line to break up bootstrapping from normal output + catf("") + + return(invisible()) + } + + renv_bootstrap_tests_running <- function() { + getOption("renv.tests.running", default = FALSE) + } + + renv_bootstrap_repos <- function() { + + # get CRAN repository + cran <- getOption("renv.repos.cran", "https://cloud.r-project.org") + + # check for repos override + repos <- Sys.getenv("RENV_CONFIG_REPOS_OVERRIDE", unset = NA) + if (!is.na(repos)) { + + # check for RSPM; if set, use a fallback repository for renv + rspm <- Sys.getenv("RSPM", unset = NA) + if (identical(rspm, repos)) + repos <- c(RSPM = rspm, CRAN = cran) + + return(repos) + + } + + # check for lockfile repositories + repos <- tryCatch(renv_bootstrap_repos_lockfile(), error = identity) + if (!inherits(repos, "error") && length(repos)) + return(repos) + + # retrieve current repos + repos <- getOption("repos") + + # ensure @CRAN@ entries are resolved + repos[repos == "@CRAN@"] <- cran + + # add in renv.bootstrap.repos if set + default <- c(FALLBACK = "https://cloud.r-project.org") + extra <- getOption("renv.bootstrap.repos", default = default) + repos <- c(repos, extra) + + # remove duplicates that might've snuck in + dupes <- duplicated(repos) | duplicated(names(repos)) + repos[!dupes] + + } + + renv_bootstrap_repos_lockfile <- function() { + + lockpath <- Sys.getenv("RENV_PATHS_LOCKFILE", unset = "renv.lock") + if (!file.exists(lockpath)) + return(NULL) + + lockfile <- tryCatch(renv_json_read(lockpath), error = identity) + if (inherits(lockfile, "error")) { + warning(lockfile) + return(NULL) + } + + repos <- lockfile$R$Repositories + if (length(repos) == 0) + return(NULL) + + keys <- vapply(repos, `[[`, "Name", FUN.VALUE = character(1)) + vals <- vapply(repos, `[[`, "URL", FUN.VALUE = character(1)) + names(vals) <- keys + + return(vals) + + } + + renv_bootstrap_download <- function(version) { + + sha <- attr(version, "sha", exact = TRUE) + + methods <- if (!is.null(sha)) { + + # attempting to bootstrap a development version of renv + c( + function() renv_bootstrap_download_tarball(sha), + function() renv_bootstrap_download_github(sha) + ) + + } else { + + # attempting to bootstrap a release version of renv + c( + function() renv_bootstrap_download_tarball(version), + function() renv_bootstrap_download_cran_latest(version), + function() renv_bootstrap_download_cran_archive(version) + ) + + } + + for (method in methods) { + path <- tryCatch(method(), error = identity) + if (is.character(path) && file.exists(path)) + return(path) + } + + stop("All download methods failed") + + } + + renv_bootstrap_download_impl <- function(url, destfile) { + + mode <- "wb" + + # https://bugs.r-project.org/bugzilla/show_bug.cgi?id=17715 + fixup <- + Sys.info()[["sysname"]] == "Windows" && + substring(url, 1L, 5L) == "file:" + + if (fixup) + mode <- "w+b" + + args <- list( + url = url, + destfile = destfile, + mode = mode, + quiet = TRUE + ) + + if ("headers" %in% names(formals(utils::download.file))) + args$headers <- renv_bootstrap_download_custom_headers(url) + + do.call(utils::download.file, args) + + } + + renv_bootstrap_download_custom_headers <- function(url) { + + headers <- getOption("renv.download.headers") + if (is.null(headers)) + return(character()) + + if (!is.function(headers)) + stopf("'renv.download.headers' is not a function") + + headers <- headers(url) + if (length(headers) == 0L) + return(character()) + + if (is.list(headers)) + headers <- unlist(headers, recursive = FALSE, use.names = TRUE) + + ok <- + is.character(headers) && + is.character(names(headers)) && + all(nzchar(names(headers))) + + if (!ok) + stop("invocation of 'renv.download.headers' did not return a named character vector") + + headers + + } + + renv_bootstrap_download_cran_latest <- function(version) { + + spec <- renv_bootstrap_download_cran_latest_find(version) + type <- spec$type + repos <- spec$repos + + baseurl <- utils::contrib.url(repos = repos, type = type) + ext <- if (identical(type, "source")) + ".tar.gz" + else if (Sys.info()[["sysname"]] == "Windows") + ".zip" + else + ".tgz" + name <- sprintf("renv_%s%s", version, ext) + url <- paste(baseurl, name, sep = "/") + + destfile <- file.path(tempdir(), name) + status <- tryCatch( + renv_bootstrap_download_impl(url, destfile), + condition = identity + ) + + if (inherits(status, "condition")) + return(FALSE) + + # report success and return + destfile + + } + + renv_bootstrap_download_cran_latest_find <- function(version) { + + # check whether binaries are supported on this system + binary <- + getOption("renv.bootstrap.binary", default = TRUE) && + !identical(.Platform$pkgType, "source") && + !identical(getOption("pkgType"), "source") && + Sys.info()[["sysname"]] %in% c("Darwin", "Windows") + + types <- c(if (binary) "binary", "source") + + # iterate over types + repositories + for (type in types) { + for (repos in renv_bootstrap_repos()) { + + # retrieve package database + db <- tryCatch( + as.data.frame( + utils::available.packages(type = type, repos = repos), + stringsAsFactors = FALSE + ), + error = identity + ) + + if (inherits(db, "error")) + next + + # check for compatible entry + entry <- db[db$Package %in% "renv" & db$Version %in% version, ] + if (nrow(entry) == 0) + next + + # found it; return spec to caller + spec <- list(entry = entry, type = type, repos = repos) + return(spec) + + } + } + + # if we got here, we failed to find renv + fmt <- "renv %s is not available from your declared package repositories" + stop(sprintf(fmt, version)) + + } + + renv_bootstrap_download_cran_archive <- function(version) { + + name <- sprintf("renv_%s.tar.gz", version) + repos <- renv_bootstrap_repos() + urls <- file.path(repos, "src/contrib/Archive/renv", name) + destfile <- file.path(tempdir(), name) + + for (url in urls) { + + status <- tryCatch( + renv_bootstrap_download_impl(url, destfile), + condition = identity + ) + + if (identical(status, 0L)) + return(destfile) + + } + + return(FALSE) + + } + + renv_bootstrap_download_tarball <- function(version) { + + # if the user has provided the path to a tarball via + # an environment variable, then use it + tarball <- Sys.getenv("RENV_BOOTSTRAP_TARBALL", unset = NA) + if (is.na(tarball)) + return() + + # allow directories + if (dir.exists(tarball)) { + name <- sprintf("renv_%s.tar.gz", version) + tarball <- file.path(tarball, name) + } + + # bail if it doesn't exist + if (!file.exists(tarball)) { + + # let the user know we weren't able to honour their request + fmt <- "- RENV_BOOTSTRAP_TARBALL is set (%s) but does not exist." + msg <- sprintf(fmt, tarball) + warning(msg) + + # bail + return() + + } + + catf("- Using local tarball '%s'.", tarball) + tarball + + } + + renv_bootstrap_download_github <- function(version) { + + enabled <- Sys.getenv("RENV_BOOTSTRAP_FROM_GITHUB", unset = "TRUE") + if (!identical(enabled, "TRUE")) + return(FALSE) + + # prepare download options + pat <- Sys.getenv("GITHUB_PAT") + if (nzchar(Sys.which("curl")) && nzchar(pat)) { + fmt <- "--location --fail --header \"Authorization: token %s\"" + extra <- sprintf(fmt, pat) + saved <- options("download.file.method", "download.file.extra") + options(download.file.method = "curl", download.file.extra = extra) + on.exit(do.call(base::options, saved), add = TRUE) + } else if (nzchar(Sys.which("wget")) && nzchar(pat)) { + fmt <- "--header=\"Authorization: token %s\"" + extra <- sprintf(fmt, pat) + saved <- options("download.file.method", "download.file.extra") + options(download.file.method = "wget", download.file.extra = extra) + on.exit(do.call(base::options, saved), add = TRUE) + } + + url <- file.path("https://api.github.com/repos/rstudio/renv/tarball", version) + name <- sprintf("renv_%s.tar.gz", version) + destfile <- file.path(tempdir(), name) + + status <- tryCatch( + renv_bootstrap_download_impl(url, destfile), + condition = identity + ) + + if (!identical(status, 0L)) + return(FALSE) + + renv_bootstrap_download_augment(destfile) + + return(destfile) + + } + + # Add Sha to DESCRIPTION. This is stop gap until #890, after which we + # can use renv::install() to fully capture metadata. + renv_bootstrap_download_augment <- function(destfile) { + sha <- renv_bootstrap_git_extract_sha1_tar(destfile) + if (is.null(sha)) { + return() + } + + # Untar + tempdir <- tempfile("renv-github-") + on.exit(unlink(tempdir, recursive = TRUE), add = TRUE) + untar(destfile, exdir = tempdir) + pkgdir <- dir(tempdir, full.names = TRUE)[[1]] + + # Modify description + desc_path <- file.path(pkgdir, "DESCRIPTION") + desc_lines <- readLines(desc_path) + remotes_fields <- c( + "RemoteType: github", + "RemoteHost: api.github.com", + "RemoteRepo: renv", + "RemoteUsername: rstudio", + "RemotePkgRef: rstudio/renv", + paste("RemoteRef: ", sha), + paste("RemoteSha: ", sha) + ) + writeLines(c(desc_lines[desc_lines != ""], remotes_fields), con = desc_path) + + # Re-tar + local({ + old <- setwd(tempdir) + on.exit(setwd(old), add = TRUE) + + tar(destfile, compression = "gzip") + }) + invisible() + } + + # Extract the commit hash from a git archive. Git archives include the SHA1 + # hash as the comment field of the tarball pax extended header + # (see https://www.kernel.org/pub/software/scm/git/docs/git-archive.html) + # For GitHub archives this should be the first header after the default one + # (512 byte) header. + renv_bootstrap_git_extract_sha1_tar <- function(bundle) { + + # open the bundle for reading + # We use gzcon for everything because (from ?gzcon) + # > Reading from a connection which does not supply a 'gzip' magic + # > header is equivalent to reading from the original connection + conn <- gzcon(file(bundle, open = "rb", raw = TRUE)) + on.exit(close(conn)) + + # The default pax header is 512 bytes long and the first pax extended header + # with the comment should be 51 bytes long + # `52 comment=` (11 chars) + 40 byte SHA1 hash + len <- 0x200 + 0x33 + res <- rawToChar(readBin(conn, "raw", n = len)[0x201:len]) + + if (grepl("^52 comment=", res)) { + sub("52 comment=", "", res) + } else { + NULL + } + } + + renv_bootstrap_install <- function(version, tarball, library) { + + # attempt to install it into project library + dir.create(library, showWarnings = FALSE, recursive = TRUE) + output <- renv_bootstrap_install_impl(library, tarball) + + # check for successful install + status <- attr(output, "status") + if (is.null(status) || identical(status, 0L)) + return(status) + + # an error occurred; report it + header <- "installation of renv failed" + lines <- paste(rep.int("=", nchar(header)), collapse = "") + text <- paste(c(header, lines, output), collapse = "\n") + stop(text) + + } + + renv_bootstrap_install_impl <- function(library, tarball) { + + # invoke using system2 so we can capture and report output + bin <- R.home("bin") + exe <- if (Sys.info()[["sysname"]] == "Windows") "R.exe" else "R" + R <- file.path(bin, exe) + + args <- c( + "--vanilla", "CMD", "INSTALL", "--no-multiarch", + "-l", shQuote(path.expand(library)), + shQuote(path.expand(tarball)) + ) + + system2(R, args, stdout = TRUE, stderr = TRUE) + + } + + renv_bootstrap_platform_prefix <- function() { + + # construct version prefix + version <- paste(R.version$major, R.version$minor, sep = ".") + prefix <- paste("R", numeric_version(version)[1, 1:2], sep = "-") + + # include SVN revision for development versions of R + # (to avoid sharing platform-specific artefacts with released versions of R) + devel <- + identical(R.version[["status"]], "Under development (unstable)") || + identical(R.version[["nickname"]], "Unsuffered Consequences") + + if (devel) + prefix <- paste(prefix, R.version[["svn rev"]], sep = "-r") + + # build list of path components + components <- c(prefix, R.version$platform) + + # include prefix if provided by user + prefix <- renv_bootstrap_platform_prefix_impl() + if (!is.na(prefix) && nzchar(prefix)) + components <- c(prefix, components) + + # build prefix + paste(components, collapse = "/") + + } + + renv_bootstrap_platform_prefix_impl <- function() { + + # if an explicit prefix has been supplied, use it + prefix <- Sys.getenv("RENV_PATHS_PREFIX", unset = NA) + if (!is.na(prefix)) + return(prefix) + + # if the user has requested an automatic prefix, generate it + auto <- Sys.getenv("RENV_PATHS_PREFIX_AUTO", unset = NA) + if (is.na(auto) && getRversion() >= "4.4.0") + auto <- "TRUE" + + if (auto %in% c("TRUE", "True", "true", "1")) + return(renv_bootstrap_platform_prefix_auto()) + + # empty string on failure + "" + + } + + renv_bootstrap_platform_prefix_auto <- function() { + + prefix <- tryCatch(renv_bootstrap_platform_os(), error = identity) + if (inherits(prefix, "error") || prefix %in% "unknown") { + + msg <- paste( + "failed to infer current operating system", + "please file a bug report at https://github.com/rstudio/renv/issues", + sep = "; " + ) + + warning(msg) + + } + + prefix + + } + + renv_bootstrap_platform_os <- function() { + + sysinfo <- Sys.info() + sysname <- sysinfo[["sysname"]] + + # handle Windows + macOS up front + if (sysname == "Windows") + return("windows") + else if (sysname == "Darwin") + return("macos") + + # check for os-release files + for (file in c("/etc/os-release", "/usr/lib/os-release")) + if (file.exists(file)) + return(renv_bootstrap_platform_os_via_os_release(file, sysinfo)) + + # check for redhat-release files + if (file.exists("/etc/redhat-release")) + return(renv_bootstrap_platform_os_via_redhat_release()) + + "unknown" + + } + + renv_bootstrap_platform_os_via_os_release <- function(file, sysinfo) { + + # read /etc/os-release + release <- utils::read.table( + file = file, + sep = "=", + quote = c("\"", "'"), + col.names = c("Key", "Value"), + comment.char = "#", + stringsAsFactors = FALSE + ) + + vars <- as.list(release$Value) + names(vars) <- release$Key + + # get os name + os <- tolower(sysinfo[["sysname"]]) + + # read id + id <- "unknown" + for (field in c("ID", "ID_LIKE")) { + if (field %in% names(vars) && nzchar(vars[[field]])) { + id <- vars[[field]] + break + } + } + + # read version + version <- "unknown" + for (field in c("UBUNTU_CODENAME", "VERSION_CODENAME", "VERSION_ID", "BUILD_ID")) { + if (field %in% names(vars) && nzchar(vars[[field]])) { + version <- vars[[field]] + break + } + } + + # join together + paste(c(os, id, version), collapse = "-") + + } + + renv_bootstrap_platform_os_via_redhat_release <- function() { + + # read /etc/redhat-release + contents <- readLines("/etc/redhat-release", warn = FALSE) + + # infer id + id <- if (grepl("centos", contents, ignore.case = TRUE)) + "centos" + else if (grepl("redhat", contents, ignore.case = TRUE)) + "redhat" + else + "unknown" + + # try to find a version component (very hacky) + version <- "unknown" + + parts <- strsplit(contents, "[[:space:]]")[[1L]] + for (part in parts) { + + nv <- tryCatch(numeric_version(part), error = identity) + if (inherits(nv, "error")) + next + + version <- nv[1, 1] + break + + } + + paste(c("linux", id, version), collapse = "-") + + } + + renv_bootstrap_library_root_name <- function(project) { + + # use project name as-is if requested + asis <- Sys.getenv("RENV_PATHS_LIBRARY_ROOT_ASIS", unset = "FALSE") + if (asis) + return(basename(project)) + + # otherwise, disambiguate based on project's path + id <- substring(renv_bootstrap_hash_text(project), 1L, 8L) + paste(basename(project), id, sep = "-") + + } + + renv_bootstrap_library_root <- function(project) { + + prefix <- renv_bootstrap_profile_prefix() + + path <- Sys.getenv("RENV_PATHS_LIBRARY", unset = NA) + if (!is.na(path)) + return(paste(c(path, prefix), collapse = "/")) + + path <- renv_bootstrap_library_root_impl(project) + if (!is.null(path)) { + name <- renv_bootstrap_library_root_name(project) + return(paste(c(path, prefix, name), collapse = "/")) + } + + renv_bootstrap_paths_renv("library", project = project) + + } + + renv_bootstrap_library_root_impl <- function(project) { + + root <- Sys.getenv("RENV_PATHS_LIBRARY_ROOT", unset = NA) + if (!is.na(root)) + return(root) + + type <- renv_bootstrap_project_type(project) + if (identical(type, "package")) { + userdir <- renv_bootstrap_user_dir() + return(file.path(userdir, "library")) + } + + } + + renv_bootstrap_validate_version <- function(version, description = NULL) { + + # resolve description file + # + # avoid passing lib.loc to `packageDescription()` below, since R will + # use the loaded version of the package by default anyhow. note that + # this function should only be called after 'renv' is loaded + # https://github.com/rstudio/renv/issues/1625 + description <- description %||% packageDescription("renv") + + # check whether requested version 'version' matches loaded version of renv + sha <- attr(version, "sha", exact = TRUE) + valid <- if (!is.null(sha)) + renv_bootstrap_validate_version_dev(sha, description) + else + renv_bootstrap_validate_version_release(version, description) + + if (valid) + return(TRUE) + + # the loaded version of renv doesn't match the requested version; + # give the user instructions on how to proceed + dev <- identical(description[["RemoteType"]], "github") + remote <- if (dev) + paste("rstudio/renv", description[["RemoteSha"]], sep = "@") + else + paste("renv", description[["Version"]], sep = "@") + + # display both loaded version + sha if available + friendly <- renv_bootstrap_version_friendly( + version = description[["Version"]], + sha = if (dev) description[["RemoteSha"]] + ) + + fmt <- heredoc(" + renv %1$s was loaded from project library, but this project is configured to use renv %2$s. + - Use `renv::record(\"%3$s\")` to record renv %1$s in the lockfile. + - Use `renv::restore(packages = \"renv\")` to install renv %2$s into the project library. + ") + catf(fmt, friendly, renv_bootstrap_version_friendly(version), remote) + + FALSE + + } + + renv_bootstrap_validate_version_dev <- function(version, description) { + expected <- description[["RemoteSha"]] + is.character(expected) && startswith(expected, version) + } + + renv_bootstrap_validate_version_release <- function(version, description) { + expected <- description[["Version"]] + is.character(expected) && identical(expected, version) + } + + renv_bootstrap_hash_text <- function(text) { + + hashfile <- tempfile("renv-hash-") + on.exit(unlink(hashfile), add = TRUE) + + writeLines(text, con = hashfile) + tools::md5sum(hashfile) + + } + + renv_bootstrap_load <- function(project, libpath, version) { + + # try to load renv from the project library + if (!requireNamespace("renv", lib.loc = libpath, quietly = TRUE)) + return(FALSE) + + # warn if the version of renv loaded does not match + renv_bootstrap_validate_version(version) + + # execute renv load hooks, if any + hooks <- getHook("renv::autoload") + for (hook in hooks) + if (is.function(hook)) + tryCatch(hook(), error = warnify) + + # load the project + renv::load(project) + + TRUE + + } + + renv_bootstrap_profile_load <- function(project) { + + # if RENV_PROFILE is already set, just use that + profile <- Sys.getenv("RENV_PROFILE", unset = NA) + if (!is.na(profile) && nzchar(profile)) + return(profile) + + # check for a profile file (nothing to do if it doesn't exist) + path <- renv_bootstrap_paths_renv("profile", profile = FALSE, project = project) + if (!file.exists(path)) + return(NULL) + + # read the profile, and set it if it exists + contents <- readLines(path, warn = FALSE) + if (length(contents) == 0L) + return(NULL) + + # set RENV_PROFILE + profile <- contents[[1L]] + if (!profile %in% c("", "default")) + Sys.setenv(RENV_PROFILE = profile) + + profile + + } + + renv_bootstrap_profile_prefix <- function() { + profile <- renv_bootstrap_profile_get() + if (!is.null(profile)) + return(file.path("profiles", profile, "renv")) + } + + renv_bootstrap_profile_get <- function() { + profile <- Sys.getenv("RENV_PROFILE", unset = "") + renv_bootstrap_profile_normalize(profile) + } + + renv_bootstrap_profile_set <- function(profile) { + profile <- renv_bootstrap_profile_normalize(profile) + if (is.null(profile)) + Sys.unsetenv("RENV_PROFILE") + else + Sys.setenv(RENV_PROFILE = profile) + } + + renv_bootstrap_profile_normalize <- function(profile) { + + if (is.null(profile) || profile %in% c("", "default")) + return(NULL) + + profile + + } + + renv_bootstrap_path_absolute <- function(path) { + + substr(path, 1L, 1L) %in% c("~", "/", "\\") || ( + substr(path, 1L, 1L) %in% c(letters, LETTERS) && + substr(path, 2L, 3L) %in% c(":/", ":\\") + ) + + } + + renv_bootstrap_paths_renv <- function(..., profile = TRUE, project = NULL) { + renv <- Sys.getenv("RENV_PATHS_RENV", unset = "renv") + root <- if (renv_bootstrap_path_absolute(renv)) NULL else project + prefix <- if (profile) renv_bootstrap_profile_prefix() + components <- c(root, renv, prefix, ...) + paste(components, collapse = "/") + } + + renv_bootstrap_project_type <- function(path) { + + descpath <- file.path(path, "DESCRIPTION") + if (!file.exists(descpath)) + return("unknown") + + desc <- tryCatch( + read.dcf(descpath, all = TRUE), + error = identity + ) + + if (inherits(desc, "error")) + return("unknown") + + type <- desc$Type + if (!is.null(type)) + return(tolower(type)) + + package <- desc$Package + if (!is.null(package)) + return("package") + + "unknown" + + } + + renv_bootstrap_user_dir <- function() { + dir <- renv_bootstrap_user_dir_impl() + path.expand(chartr("\\", "/", dir)) + } + + renv_bootstrap_user_dir_impl <- function() { + + # use local override if set + override <- getOption("renv.userdir.override") + if (!is.null(override)) + return(override) + + # use R_user_dir if available + tools <- asNamespace("tools") + if (is.function(tools$R_user_dir)) + return(tools$R_user_dir("renv", "cache")) + + # try using our own backfill for older versions of R + envvars <- c("R_USER_CACHE_DIR", "XDG_CACHE_HOME") + for (envvar in envvars) { + root <- Sys.getenv(envvar, unset = NA) + if (!is.na(root)) + return(file.path(root, "R/renv")) + } + + # use platform-specific default fallbacks + if (Sys.info()[["sysname"]] == "Windows") + file.path(Sys.getenv("LOCALAPPDATA"), "R/cache/R/renv") + else if (Sys.info()[["sysname"]] == "Darwin") + "~/Library/Caches/org.R-project.R/R/renv" + else + "~/.cache/R/renv" + + } + + renv_bootstrap_version_friendly <- function(version, shafmt = NULL, sha = NULL) { + sha <- sha %||% attr(version, "sha", exact = TRUE) + parts <- c(version, sprintf(shafmt %||% " [sha: %s]", substring(sha, 1L, 7L))) + paste(parts, collapse = "") + } + + renv_bootstrap_exec <- function(project, libpath, version) { + if (!renv_bootstrap_load(project, libpath, version)) + renv_bootstrap_run(version, libpath) + } + + renv_bootstrap_run <- function(version, libpath) { + + # perform bootstrap + bootstrap(version, libpath) + + # exit early if we're just testing bootstrap + if (!is.na(Sys.getenv("RENV_BOOTSTRAP_INSTALL_ONLY", unset = NA))) + return(TRUE) + + # try again to load + if (requireNamespace("renv", lib.loc = libpath, quietly = TRUE)) { + return(renv::load(project = getwd())) + } + + # failed to download or load renv; warn the user + msg <- c( + "Failed to find an renv installation: the project will not be loaded.", + "Use `renv::activate()` to re-initialize the project." + ) + + warning(paste(msg, collapse = "\n"), call. = FALSE) + + } + + renv_json_read <- function(file = NULL, text = NULL) { + + jlerr <- NULL + + # if jsonlite is loaded, use that instead + if ("jsonlite" %in% loadedNamespaces()) { + + json <- tryCatch(renv_json_read_jsonlite(file, text), error = identity) + if (!inherits(json, "error")) + return(json) + + jlerr <- json + + } + + # otherwise, fall back to the default JSON reader + json <- tryCatch(renv_json_read_default(file, text), error = identity) + if (!inherits(json, "error")) + return(json) + + # report an error + if (!is.null(jlerr)) + stop(jlerr) + else + stop(json) + + } + + renv_json_read_jsonlite <- function(file = NULL, text = NULL) { + text <- paste(text %||% readLines(file, warn = FALSE), collapse = "\n") + jsonlite::fromJSON(txt = text, simplifyVector = FALSE) + } + + renv_json_read_default <- function(file = NULL, text = NULL) { + + # find strings in the JSON + text <- paste(text %||% readLines(file, warn = FALSE), collapse = "\n") + pattern <- '["](?:(?:\\\\.)|(?:[^"\\\\]))*?["]' + locs <- gregexpr(pattern, text, perl = TRUE)[[1]] + + # if any are found, replace them with placeholders + replaced <- text + strings <- character() + replacements <- character() + + if (!identical(c(locs), -1L)) { + + # get the string values + starts <- locs + ends <- locs + attr(locs, "match.length") - 1L + strings <- substring(text, starts, ends) + + # only keep those requiring escaping + strings <- grep("[[\\]{}:]", strings, perl = TRUE, value = TRUE) + + # compute replacements + replacements <- sprintf('"\032%i\032"', seq_along(strings)) + + # replace the strings + mapply(function(string, replacement) { + replaced <<- sub(string, replacement, replaced, fixed = TRUE) + }, strings, replacements) + + } + + # transform the JSON into something the R parser understands + transformed <- replaced + transformed <- gsub("{}", "`names<-`(list(), character())", transformed, fixed = TRUE) + transformed <- gsub("[[{]", "list(", transformed, perl = TRUE) + transformed <- gsub("[]}]", ")", transformed, perl = TRUE) + transformed <- gsub(":", "=", transformed, fixed = TRUE) + text <- paste(transformed, collapse = "\n") + + # parse it + json <- parse(text = text, keep.source = FALSE, srcfile = NULL)[[1L]] + + # construct map between source strings, replaced strings + map <- as.character(parse(text = strings)) + names(map) <- as.character(parse(text = replacements)) + + # convert to list + map <- as.list(map) + + # remap strings in object + remapped <- renv_json_read_remap(json, map) + + # evaluate + eval(remapped, envir = baseenv()) + + } + + renv_json_read_remap <- function(json, map) { + + # fix names + if (!is.null(names(json))) { + lhs <- match(names(json), names(map), nomatch = 0L) + rhs <- match(names(map), names(json), nomatch = 0L) + names(json)[rhs] <- map[lhs] + } + + # fix values + if (is.character(json)) + return(map[[json]] %||% json) + + # handle true, false, null + if (is.name(json)) { + text <- as.character(json) + if (text == "true") + return(TRUE) + else if (text == "false") + return(FALSE) + else if (text == "null") + return(NULL) + } + + # recurse + if (is.recursive(json)) { + for (i in seq_along(json)) { + json[i] <- list(renv_json_read_remap(json[[i]], map)) + } + } + + json + + } + + # load the renv profile, if any + renv_bootstrap_profile_load(project) + + # construct path to library root + root <- renv_bootstrap_library_root(project) + + # construct library prefix for platform + prefix <- renv_bootstrap_platform_prefix() + + # construct full libpath + libpath <- file.path(root, prefix) + + # run bootstrap code + renv_bootstrap_exec(project, libpath, version) + + invisible() + +}) diff --git a/renv/settings.json b/renv/settings.json new file mode 100644 index 0000000..74c1d4b --- /dev/null +++ b/renv/settings.json @@ -0,0 +1,19 @@ +{ + "bioconductor.version": null, + "external.libraries": [], + "ignored.packages": [], + "package.dependency.fields": [ + "Imports", + "Depends", + "LinkingTo" + ], + "ppm.enabled": null, + "ppm.ignored.urls": [], + "r.version": null, + "snapshot.type": "explicit", + "use.cache": true, + "vcs.ignore.cellar": true, + "vcs.ignore.library": true, + "vcs.ignore.local": true, + "vcs.manage.ignores": true +}