Merge pull request #2 from OHDSI/develop

Update to v0.0.2

DESCRIPTION

@@ -1,6 +1,6 @@
 Package: Ulysses
 Title: Automate OHDSI Study Setup
-Version: 0.0.1
+Version: 0.0.2
 Authors@R: 
     person("Martin", "Lavallee", , "[email protected]", role = c("aut", "cre"))
 Description: Automates setup of OHDSI study and provides functions to assist on improving organization
@@ -13,10 +13,14 @@ Imports:
     cli,
     crayon,
     fs,
+    gert,
+    gh,
     glue,
+    keyring,
     lifecycle,
     lubridate,
     magrittr,
+    purrr,
     rlang,
     rstudioapi,
     scales,

NAMESPACE

@@ -5,8 +5,11 @@ export(addCohortFolder)
 export(addConfig)
 export(addScratchFolder)
 export(checkConfig)
+export(checkDatabaseCredential)
+export(defaultCredentials)
 export(isOhdsiStudy)
 export(makeAnalysisScript)
+export(makeCaprScript)
 export(makeCohortDetails)
 export(makeConfig)
 export(makeContributionGuidelines)
@@ -21,9 +24,13 @@ export(makePassProtocol)
 export(makeReadMe)
 export(makeResultsReport)
 export(makeStudySAP)
+export(makeWebApiScript)
 export(newOhdsiStudy)
-export(requestStudyParticipation)
-export(requestStudyRepo)
+export(publishStudyToRepository)
+export(requestStudyRepository)
+export(setCredential)
+export(setMultipleCredentials)
+export(setStudyKeyring)
 import(fs)
 import(rlang)
 import(usethis)

NEWS.md

@@ -1,3 +1,10 @@
+# Ulysses 0.0.2
+
+* Add keyring functions and update SetupKeyring.R template
+* Update repository request email template
+* Add git function to publish repo to remote
+* Fix bugs in HowToRun and KeyringSetup template
+
 # Ulysses 0.0.1
 
 * Add initial functionality

R/git.R

@@ -0,0 +1,47 @@
+# Functions for git related tasks ------------
+
+has_git <- function(proj) {
+  repo <- tryCatch(gert::git_find(proj), error = function(e) NULL)
+  !is.null(repo)
+}
+
+#' Publish Study to Repo
+#' @param repoUrl an https url for the repo remote. Example: https://github.com/Org/repo.git
+#' @param message the commit message for your OHDSI study
+#' @export
+publishStudyToRepository <- function(repoUrl,
+                                     message = "Initial commit for OHDSI study") {
+
+  proj <- usethis::proj_get()
+  check <- !has_git(proj)
+  if (check) {
+    #Step1: initialize git
+    gert::git_init(proj)
+    # Step 2: add all files
+    stg <- gert::git_add(files = ".")
+    #step 3: commit all files
+    sha <- gert::git_commit_all(message = message)
+    #step 4: setup remote
+    gert::git_remote_add(url = repoUrl)
+    # Step 5: push
+    gert::git_push(remote = "origin")
+  } else {
+    remoteLs <- gert::git_remote_list()$url
+    has_remote <- remoteLs %in% repoUrl
+    if (!has_remote) {
+      #step 4: setup remote
+      gert::git_remote_add(url = repoUrl)
+      # Step 5: push
+      gert::git_push(remote = "origin")
+    }
+  }
+  if(check) {
+    #restart R session
+    cli::cat_bullet("Restarting RStudio to setup Git Pane in RStudio", bullet = "info", bullet_col = "blue")
+    rstudioapi::openProject(proj)
+  }
+  invisible(TRUE)
+}
+
+
+

R/helpers.R

@@ -50,3 +50,19 @@ findStepNumber <- function(dir = c("cohortsToCreate", "analysis/studyTasks"), pr
   return(step)
 
 }
+
+
+getGithubUser <- function() {
+  fn <- purrr::safely(gh::gh_whoami)
+  gitCreds <- fn()
+  if (length(gitCreds$error) > 0) {
+    cli::cat_bullet("Need to set up a Github PAT. Follow instructions from: ",
+                    crayon::italic("https://gh.r-lib.org/articles/managing-personal-access-tokens.html"),
+                    bullet = "warning",
+                    bullet_col = "yellow")
+    user <- "githubUser"
+  }
+  user <- gitCreds$result$login
+
+  return(user)
+}

R/keyring.R

@@ -0,0 +1,187 @@
+# Keyring Functions ----------------------
+
+## Helpers ------------
+set_cred <- function(cred, db, keyringName) {
+
+  key_name <- paste(db, cred, sep = "_")
+  prompt_txt <- glue::glue("Set {key_name}: ")
+
+  keyring::key_set(
+    service = key_name,
+    keyring = keyringName,
+    prompt = prompt_txt
+  )
+  invisible(key_name)
+}
+
+blurCreds <- function(item,  keyringName) {
+  cred <- keyring::key_get(service = item, keyring = keyringName)
+  txt <- glue::glue(item, ": ", crayon::blurred(cred))
+  cli::cat_bullet(txt, bullet = "info", bullet_col = "blue")
+  invisible(item)
+}
+
+
+checkKeyring <- function(keyringName, keyringPassword) {
+  allKeyrings <- keyring::keyring_list()
+  keyringName %in% allKeyrings$keyring
+}
+
+
+dropKeyring <- function(keyringName, keyringPassword) {
+
+  if (keyring::keyring_is_locked(keyring = keyringName)) {
+    keyring::keyring_unlock(keyring = keyringName, password = keyringPassword)
+  }
+  # Delete all keys from the keyring so we can delete it
+  cli::cat_bullet("Delete existing keyring: ", keyringName,
+                  bullet = "warning", bullet_col = "yellow")
+  keys <- keyring::key_list(keyring = keyringName)
+  if (nrow(keys) > 0) {
+    for (i in 1:nrow(keys)) {
+      # drop keys
+      keyring::key_delete(keys$service[i], keyring = keyringName)
+    }
+  }
+  # drop keyring
+  keyring::keyring_delete(keyring = keyringName)
+
+  invisible(keyringName)
+
+}
+
+
+setKeyring <- function(keyringName, keyringPassword) {
+
+  cli::cat_bullet(
+    "Creating a study keyring for: ", crayon::cyan(keyringName),
+    bullet = "info", bullet_col = "blue"
+  )
+  # create keyring
+  keyring::keyring_create(keyring = keyringName, password = keyringPassword)
+
+  invisible(keyringName)
+}
+
+## UI ------------
+
+#' Function to list default credentials
+#' @description
+#' This function builds the standard credential set needed for most connections. If
+#' another credential is needed use `c()` to bind the character vector.
+#' @export
+defaultCredentials <- function() {
+  creds <- c(
+    "dbms", # the database dialect
+    "user", # the user name for the db
+    "password", # the password for the db
+    "connectionString", # the connection string to access the db
+    "cdmDatabaseSchema", # the database + schema (or just schema) hosting the cdm
+    "vocabDatabaseSchema", # the database + schema (or just schema) hosting the vocabulary, usually same as cdm
+    "workDatabaseSchema" # the database + schema (or just schema) hosting the work or scratch
+  )
+  return(creds)
+}
+
+#' Function to check the database credential
+#' @param cred the credential to set (i.e dbms, user, connectionString)
+#' @param db the database prefix for the credential
+#' @param keyringName the name of the keyringName for the credential check, this will be the keyring namec
+#' @param verbose toggle option to print console message
+#' @export
+checkDatabaseCredential <- function(cred, db, keyringName, verbose = TRUE) {
+
+  #paste name to set full credential
+  key_name <- paste(db, cred, sep = "_")
+
+  if (verbose) {
+    cli::cat_bullet("Check that credential ", crayon::green(key_name), " is correct.",
+                    bullet = "warning", bullet_col = "yellow")
+  }
+
+  #print credential
+  blurCreds(item = key_name, keyringName = keyringName)
+
+  invisible(key_name)
+}
+
+#' Function to set single credential
+#' @param cred the credential to set (i.e dbms, user, connectionString)
+#' @param db the database prefix for the credential
+#' @param keyringName the name of the keyringName for the credential set, this will be the keyring namec
+#' @param keyringPassword the password for the keyring.
+#' @param forceCheck a toggle that will print blurred credentials to check credential
+#' @export
+setCredential <- function(cred, db, keyringName, keyringPassword, forceCheck = TRUE) {
+
+  if (keyring::keyring_is_locked(keyring = keyringName)) {
+    keyring::keyring_unlock(keyring = keyringName, password = keyringPassword)
+  }
+
+  cli::cat_bullet("Input your credentials in the dialog box",
+                  bullet = "warning", bullet_col = "yellow")
+
+  set_cred(cred = cred, db = db, keyringName = keyringName)
+
+  if (forceCheck) {
+    checkDatabaseCredential(cred = cred, db = db, keyringName = keyringName)
+  }
+  invisible(cred)
+}
+
+#' Function to set multi credentials
+#' @param creds a vector of credentials to set (i.e dbms, user, connectionString). See defaultCredentials on building set
+#' @param db the database prefix for the credential
+#' @param keyringName the name of the keyringName where the credential will be set
+#' @param keyringPassword the password for the keyring.
+#' @param forceCheck a toggle that will print blurred credentials to check credential
+#' @export
+setMultipleCredentials <- function(creds, db, keyringName, keyringPassword, forceCheck = TRUE) {
+
+  if (keyring::keyring_is_locked(keyring = keyringName)) {
+    keyring::keyring_unlock(keyring = keyringName, password = keyringPassword)
+  }
+
+  cli::cat_bullet("Input your credentials in the dialog box",
+                  bullet = "warning", bullet_col = "yellow")
+  purrr::walk(
+    creds,
+    ~set_cred(cred = .x, db = db, keyringName = keyringName)
+  )
+
+  if (forceCheck) {
+    purrr::walk(creds, ~checkDatabaseCredential(cred = .x,  db = db, keyringName = keyringName, verbose = FALSE))
+  }
+  invisible(creds)
+
+}
+
+
+
+#' Function to set study keyring
+#' @param keyringName the name of the keyring, this should be the reponame for the study
+#' @param keyringPassword a password to access the study keyring
+#' @export
+setStudyKeyring <- function(keyringName, keyringPassword) {
+
+  # check if keyring exists
+  check <- checkKeyring(keyringName = keyringName, keyringPassword = keyringPassword)
+
+  if (check) {
+    ask1 <- usethis::ui_yeah(
+      "This keyring already exists. Do you want to drop the keyring and its contents?"
+    )
+    if (ask1) {
+      dropKeyring(keyringName = keyringName, keyringPassword = keyringPassword)
+      #Set keyring
+      setKeyring(keyringName = keyringName, keyringPassword = keyringPassword)
+    } else{
+      cli::cat_bullet("Keeping keyring ", crayon::cyan(keyringName), ". ")
+    }
+  } else{
+    #Set keyring
+    setKeyring(keyringName = keyringName, keyringPassword = keyringPassword)
+  }
+  invisible(keyringName)
+}
+