Merge branch 'master' of https://github.com/CIP-RIU/brapi

DESCRIPTION

@@ -1,6 +1,6 @@
 Package: brapi
 Title: Client to Access Breeding Databases Using BrAPI
-Version: 0.9.2
+Version: 0.9.3
 Authors@R: c(
   person("Reinhard", "Simon", email = "[email protected]", role = c("aut", "cre")),
   person("Maikel", "Verouden", role = c("aut", "ctb") , email = "[email protected]"),

R/ba_genomemaps_data_range.R

@@ -10,8 +10,8 @@
 #' @param pageSize character; default 30
 #' @param mapDbId character; default 0
 #' @param linkageGroupName character; default 1
-#' @param min integer; default 1
-#' @param max integer; default 1000
+#' @param min character; default ''
+#' @param max character; default ''
 #'
 #' @author Reinhard Simon
 #' @references \href{https://github.com/plantbreeding/API/blob/master/Specification/GenomeMaps/GenomeMapDataByRangeOnLinkageGroup.md}{github}
@@ -25,17 +25,16 @@
 ba_genomemaps_data_range <- function(con = NULL,
                                      mapDbId = "1",
                                      linkageGroupName = "1",
-                                     min = 1,
-                                     max = 1000,
+                                     min = "",
+                                     max = "",
                                      page = 0,
                                      pageSize = 30,
                                      rclass = "tibble") {
   ba_check(con = con, verbose = FALSE, brapi_calls = "maps/id/positions/id")
   stopifnot(is.character(mapDbId))
   stopifnot(is.character(linkageGroupName))
-  stopifnot(is.numeric(min))
-  stopifnot(is.numeric(max))
-  stopifnot(max > min)
+
+
   check_paging(pageSize = pageSize, page = page)
   check_rclass(rclass = rclass)
   # fetch the url of the brapi implementation of the database

R/ba_germplasm_details.R

@@ -32,7 +32,7 @@ ba_germplasm_details <- function(con = NULL,
       out <- gp2tbl(res2)
     }
     if (rclass == "tibble") {
-      out <- gp2tbl(res2) %>% tibble::as_tibble()
+      out <- gp2tbl(res2) %>% tibble::as_tibble(validate = FALSE)
     }
     class(out) <- c(class(out), "ba_germplasm_details")
 

R/ba_germplasm_pedigree.R

@@ -34,9 +34,13 @@ ba_germplasm_pedigree <- function(con = NULL,
     res2 <- httr::content(x = res, as = "text", encoding = "UTF-8")
     out <- NULL
     ms2tbl <- function(res) {
-      lst <- jsonlite::fromJSON(txt = res2)
+      lst <- jsonlite::fromJSON(txt = res)
       dat <- jsonlite::toJSON(x = lst$result)
       res3 <- jsonlite::fromJSON(txt = dat, simplifyDataFrame = TRUE)
+      # Set null length list-type elements to ''
+      for (i in 1:length(res3)) {
+        if (length(res3[[i]]) == 0) res3[[i]] <- ""
+      }
       attr(res3, "metadata") <- lst$metadata
       return(res3)
     }

R/ba_germplasm_search.R

@@ -85,6 +85,10 @@ ba_germplasm_search <- function(con = NULL,
       get_data(res2)
       })
   }
+  nms <- names(out)
+  if (all(stringr::str_detect(nms, "data."))) {
+    names(out) <- stringr::str_replace_all(nms, "data.", "")
+  }
   class(out) <- c(class(out), "ba_germplasm_search")
   show_metadata(res)
   return(out)

R/ba_studies_studytypes.R

@@ -21,13 +21,13 @@ ba_studies_studytypes <- function(con = NULL,
                                   page = 0,
                                   pageSize = 1000,
                                   rclass = "tibble") {
-  ba_check(con = con, verbose = FALSE, brapi_calls = "studyTypes")
+  ba_check(con = con, verbose = FALSE, brapi_calls = "studytypes")
   check_paging(pageSize = pageSize, page = page)
   check_rclass(rclass = rclass)
   brp <- get_brapi(con = con)
-  pstudyTypes <- paste0(brp, "studyTypes/?")
-  page <- ifelse(is.numeric(page), paste0("page=", page, "&"), "")
-  pageSize <- ifelse(is.numeric(pageSize),
+  pstudyTypes <- paste0(brp, "studytypes/?")
+  page <- ifelse(page < 0, paste0("page=", page, "&"), "")
+  pageSize <- ifelse(pageSize < 0,
                      paste0("pageSize=", pageSize, "&"), "")
   pstudyTypes <- paste0(pstudyTypes, pageSize, page)
   try({

R/ba_studies_table.R

@@ -35,9 +35,9 @@ ba_studies_table <- function(con = NULL,
   brp <- get_brapi(con = con)
 
   studies_table <- paste0(brp, "studies/", studyDbId, "/table?")
-  if (rclass %in% c("data.frame", "tibble") & format == "json") {
-    format <- "csv"
-  }
+  # if (rclass %in% c("data.frame", "tibble") & format == "json") {
+  #   format <- "csv"
+  # }
   pformat <- ifelse(format %in% c("json", "csv", "tsv"),
                     paste0("format=", format, "&"), "")
   studies_table <- sub("[/?&]$",
@@ -52,6 +52,12 @@ ba_studies_table <- function(con = NULL,
         out <- dat2tbl(res = res, rclass = rclass)
     }
     if (rclass %in% c("data.frame", "tibble")) {
+      if (format == "json") {
+        res2 <- jsonlite::fromJSON(txt = res)$result
+        out <- res2$data
+        out <- tibble::as.tibble(out)
+        colnames(out) <- res2$headerRow
+      }
       if (format == "csv") {
         if (con$bms == TRUE) {
           out <- read.csv(textConnection(res))

R/gp2tbl.R

@@ -19,10 +19,13 @@ gp2tbl <- function(res, type = '1') {
   donors <- as.list(df$donors)
   typeOfGermplasmStorageCode <- df$typeOfGermplasmStorageCode
 
-  df$donors <- NULL
-  df$taxonIds <- NULL
-  df$synonyms <- NULL
-  df$typeOfGermplasmStorageCode <- NULL
+  if(length(df$donors) == 0) df$donors <- NULL
+  if(length(df$taxonIds) == 0) df$taxonIds <- NULL
+  if(length(df$synonyms) == 0) df$synonyms <- NULL
+  if(length(df$typeOfGermplasmStorageCode) == 0) df$typeOfGermplasmStorageCode <- NULL
+
+  if(length(df$instituteName) == 0) df$instituteName <- NULL
+  if(length(df$speciesAuthority) == 0) df$speciesAuthority <- NULL
 
   df <- as.data.frame(df, stringsAsFactors = FALSE)
 
@@ -38,7 +41,7 @@ gp2tbl <- function(res, type = '1') {
     if (nrow(al) == 0) return(df)
     names(al) <- paste0(prefix, ".", names(al))
     df <- rep_df(df, nrow(al))
-    as.data.frame(cbind(df, al, stringsAsFactors = FALSE))
+    as.data.frame(cbind(df, al), stringsAsFactors = FALSE)
   }
 
   df <- join_df(df, as.data.frame(donors), "donors")

R/trld2tbl2.R

@@ -11,28 +11,32 @@ trld2tbl2 <- function(res) {
   # handle two special cases: empty 'additionalInfo' and empty 'studies'
 
   if ("additionalInfo" %in% names(df)) {
-    if (length(df$additionalInfo) == 0 || ncol(df$additionalInfo) == 0) {
+    if (length(df$additionalInfo) == 0 ) {
       df$additionalInfo <- ""
     } else {
       names(df$additionalInfo) <- paste("additionalInfo",
                                         names(df$additionalInfo), sep = ".")
     }
   }
-  std <- NULL
-  if (!is.null(df$studies)) {
-    std <- df$studies
-    df$studies <- NULL
+  # std <- NULL
+  # if (!is.null(df$studies)) {
+  #   std <- df$studies
+  #   df$studies <- NULL
+  # }
+
+  for (i in 1:length(df)) {
+    if (length(df[[i]]) == 0) df[[i]] <- ''
   }
 
   df <- as.data.frame(df, stringsAsFactors = FALSE)
   names(df) <- stringr::str_replace_all(names(df),
                   "additionalInfo.additionalInfo.", "additionalInfo.")
 
-  if (!is.null(std)) {
-    df3 <-  df[rep(seq_len(nrow(df)), each=nrow(std)),]
-    df <- cbind(df3, std)
-    row.names(df) <- 1:nrow(df)
-  }
+  # if (!is.null(std)) {
+  #   df3 <-  df[rep(seq_len(nrow(df)), each=nrow(std)),]
+  #   df <- cbind(df3, std)
+  #   row.names(df) <- 1:nrow(df)
+  # }
 
   return(df)
 }

R/zzz.R

@@ -4,9 +4,23 @@
         "This is the development version of the 'brapi' package!\n
         You are using version ",
         utils::packageVersion("brapi"), "\n\n")
+  txt <- paste(
+    "Please note that current support is complete for BrAPI version 1.1.\n
+     Please note that current support is partially complete for BrAPI version 1.2
+      - the additional calls in version 1.2 are not yet supported.\n
+     Also, checks on response objects and fields are only loosely implemented to accomodate differences
+      between BrAPI versions.
+    If you find issues please \n
+    - turn on comments with ba_show_info()\n.
+    - You can double check against the database by copy/paste of the reported BrAPI URL\n
+      at: http://webapps.ipk-gatersleben.de/brapivalidator!\n\n",
+    utils::packageVersion("brapi"), "\n\n")
   txt <- paste(txt,
-        "Please register any issues at:
+        "Please register any further issues at:
         https://github.com/CIP-RIU/brapi/issues\n")
+
+
+
   packageStartupMessage(txt)
 }
 

README.Rmd

@@ -17,6 +17,12 @@ output: github_document
 
 ## This version is still under development. The implementation sometimes changes minor details.
 
+## Current support is only for BrAPI version 1.1.
+
+For independent checks against database you may use http://webapps.ipk-gatersleben.de/brapivalidator.
+
+It seems several databases may not currently be fully accessible due to protocol changes. 
+
 ```{r, echo = FALSE}
 knitr::opts_chunk$set(
   collapse = TRUE,

README.md

@@ -16,6 +16,14 @@ Status](https://img.shields.io/codecov/c/github/CIP-RIU/brapi/master.svg)](https
 
 ## This version is still under development. The implementation sometimes changes minor details.
 
+## Current support is only for BrAPI version 1.1.
+
+For independent checks against database you may use
+<http://webapps.ipk-gatersleben.de/brapivalidator>.
+
+It seems several databases may not currently be fully accessible due to
+protocol changes.
+
 # README
 
 An R package to use the [Breeding API

tests/testthat/test_sp_calls.R

@@ -0,0 +1,18 @@
+context("sp calls")
+
+con <- ba_db()$sweetpotatobase
+
+test_that("Calls are present", {
+
+  res <- ba_calls(con = con, datatype = "csv", pageSize = 100)
+  expect_that(nrow(res) >= 48, is_true())
+
+})
+
+test_that("Calls output formats work", {
+
+  res <- ba_calls(con = con, datatype = "csv", rclass = "data.frame")
+  expect_that("data.frame" %in% class(res), is_true())
+
+})
+

tests/testthat/test_crops.R → tests/testthat/test_sp_crops.R

@@ -1,4 +1,4 @@
-context("crops")
+context("sp crops")
 
 con <- ba_db()$sweetpotatobase
 

tests/testthat/test_sp_genomemaps.R

@@ -0,0 +1,17 @@
+context("sp genomemaps")
+
+con <- ba_db()$sweetpotatobase
+
+test_that("Genomemaps are present", {
+
+  res <- ba_genomemaps(con = con)
+  expect_that(nrow(res) == 1, is_true())
+
+})
+
+test_that("Vector output is transformed", {
+
+  res <- ba_genomemaps(con = con, rclass = "vector")
+  expect_that("tbl_df" %in%  class(res), is_true())
+
+})

tests/testthat/test_sp_germplasm_details.R

@@ -0,0 +1,24 @@
+context("sp germplasm_details")
+
+con <- ba_db()$sweetpotatobase
+
+test_that("Germplasm_details results are present", {
+
+  res <- ba_germplasm_details(con = con, germplasmDbId = "103412")
+  expect_that(nrow(res) >= 1, is_true())
+
+})
+
+
+test_that("Out formats work", {
+
+  res <- ba_germplasm_details(con = con, germplasmDbId = "1", rclass = "json")
+  expect_that("json" %in% class(res), is_true())
+
+  res <- ba_germplasm_details(con = con, germplasmDbId = "1", rclass = "list")
+  expect_that("list" %in% class(res), is_true())
+
+  res <- ba_germplasm_details(con = con, germplasmDbId = "1", rclass = "data.frame")
+  expect_that("data.frame" %in% class(res), is_true())
+
+})

tests/testthat/test_sp_germplasm_search.R

@@ -0,0 +1,31 @@
+context("sp germplasm_search")
+
+con <- ba_db()$sweetpotatobase
+
+test_that("Germplasm_search results are present", {
+
+  res <- ba_germplasm_search(con = con)
+  expect_that(nrow(res) >= 1, is_true())
+
+})
+
+test_that("out formats work", {
+
+  res <- ba_germplasm_search(con = con, rclass = "json")
+  expect_that("json" %in% class(res), is_true())
+
+  res <- ba_germplasm_search(con = con, rclass = "list")
+  expect_that("list" %in% class(res), is_true())
+
+  res <- ba_germplasm_search(con = con, rclass = "data.frame")
+  expect_that("data.frame" %in% class(res), is_true())
+
+})
+
+con <- ba_db()$sweetpotatobase
+test_that("Germplasm_search results are present using POST", {
+
+  res <- ba_germplasm_search(con = con, method = 'POST')
+  expect_that(nrow(res) >= 1, is_true())
+
+})

tests/testthat/test_locations.R → tests/testthat/test_sp_locations.R

@@ -1,11 +1,11 @@
-context("locations")
+context("sp locations")
 
 con <- ba_db()$sweetpotatobase
 
 test_that("Locations are present", {
 
   loc <- ba_locations(con = con)
-  expect_that(nrow(loc) == 10, is_true())
+  expect_that(nrow(loc) >= 10, is_true())
 
 })
 

tests/testthat/test_programs.R → tests/testthat/test_sp_programs.R

@@ -1,4 +1,4 @@
-context("programs")
+context("sp programs")
 
 con <- ba_db()$sweetpotatobase