Re-adding tests for sweetpotatobase

DESCRIPTION

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

NAMESPACE

@@ -13,6 +13,7 @@ export(ba_genomemaps)
 export(ba_genomemaps_data)
 export(ba_genomemaps_data_range)
 export(ba_genomemaps_details)
+export(ba_germplasm_attributes)
 export(ba_germplasm_details)
 export(ba_germplasm_details_study)
 export(ba_germplasm_markerprofiles)

R/ba_germplasm_attributes.R

@@ -0,0 +1,80 @@
+#' ba_germplasm_attributes
+#'
+#' germplasm_attibutes call.
+#'
+#' @param con brapi connection object
+#' @param rclass character; default: tibble; or else: json, list, data.frame.
+#' @param germplasmDbId character; default: ''.
+#' @param attributeList character vector; default: ''.
+#' @param page integer; default: 0.
+#' @param pageSize integer; default: 10.
+#'
+#' @return rclass as set by parameter.
+#' @example inst/examples/ex-ba_germplasmattributes_details.R
+#' @import httr
+#' @author Reinhard Simon
+#' @references \href{https://github.com/plantbreeding/API/blob/master/Specification/GermplasmAttributes/GermplasmAttributeValuesByGermplasmDbId.md}{github}
+#' @family germplasmattributes
+#' @family genotyping
+#' @export
+ba_germplasm_attributes <- function(con = NULL,
+                                           germplasmDbId = "",
+                                           attributeList = "",
+                                           page = 0,
+                                           pageSize = 10,
+                                           rclass = "tibble") {
+  ba_check(con = con, verbose = FALSE)
+  stopifnot(is.character(germplasmDbId))
+  stopifnot(germplasmDbId != "")
+  stopifnot(is.character(attributeList))
+  check_paging(pageSize = pageSize, page = page)
+  check_rclass(rclass = rclass)
+  # fetch the url of the brapi implementation of the database
+  brp <- get_brapi(con = con)
+  # generate the specific brapi call url
+  pattributeList <- ifelse(attributeList != "", paste("attributeList=", attributeList, collapse = ",", sep=""), "")
+  germplasm_attributes_list <- paste0(brp,
+                                      "germplasm/",
+                                      germplasmDbId,
+                                      "/attributes/?",
+                                      pattributeList,
+
+                                      "&page=",
+                                      page,
+                                      "&pageSize=",
+                                      pageSize)
+  try({
+    res <- brapiGET(url = germplasm_attributes_list, con = con)
+    res2 <- httr::content(x = res, as = "text", encoding = "UTF-8")
+    ms2tbl <- function(res) {
+      lst <- tryCatch(
+        jsonlite::fromJSON(txt = res)
+      )
+
+      assertthat::assert_that("data" %in% names(lst$result),
+                              msg = "The json return object lacks a data element.")
+      dat <- jsonlite::toJSON(x = lst$result$data)
+      germplasmDbId <- lst$result$germplasmDbId
+
+      df <- jsonlite::fromJSON(txt = dat, simplifyDataFrame = TRUE,
+                               flatten = TRUE)
+      df <- cbind(germplasmDbId, df)
+      # assertthat::validate_that(nrow(df) > 0,
+      #             msg = "The json return object lacks a data element.")
+
+      return(df)
+    }
+    if (rclass %in% c("json", "list")) {
+      out <- dat2tbl(res = res2, rclass = rclass)
+    }
+    if (rclass == "data.frame") {
+      out <- ms2tbl(res = res2)%>% tibble::as_tibble() %>% as.data.frame()
+    }
+    if (rclass == "tibble") {
+      out <- ms2tbl(res = res2) %>% tibble::as_tibble()
+    }
+    class(out) <- c(class(out), "ba_germplasmattributes_details")
+    show_metadata(res)
+    return(out)
+  })
+}

R/ba_germplasm_markerprofiles.R

@@ -29,26 +29,30 @@ ba_germplasm_markerprofiles <- function(con = NULL,
     out <- NULL
     ms2tbl <- function(res) {
       lst <- tryCatch(
-        jsonlite::fromJSON(txt = res2)
+        jsonlite::fromJSON(txt = res)
       )
 
       assertthat::assert_that("result" %in% names(lst),
                     msg = "The json return object lacks a result element.")
       dat <- jsonlite::toJSON(x = lst$result)
       df <- jsonlite::fromJSON(txt = dat, simplifyDataFrame = TRUE,
                                flatten = TRUE)
+      if(length(df$markerprofileDbIds) == 0) {
+        df$markerprofileDbIds <- ''
+      }
 
-      assertthat::assert_that(all(c("germplasmDbId",
-                                    "markerprofileDbIds") %in%
-                                    names(df)),
-            msg = "The json return object lacks germplasmDbId and
-            markerprofileDbIds.")
-      assertthat::assert_that((length(df$markerprofileDbIds) >= 1),
-          msg = "No markerprofileDbIdas")
-      res3 <-  as.data.frame(cbind(germplasmDbId = rep(df$germplasmDbId,
-                                              length(df$markerprofileDbIds)),
-                            markerProfiles = df$markerprofileDbIds),
-                            stringsAsFactors = FALSE)
+      res3 <- tibble::as.tibble(df)
+      # assertthat::assert_that(all(c("germplasmDbId",
+      #                               "markerprofileDbIds") %in%
+      #                               names(df)),
+      #       msg = "The json return object lacks germplasmDbId and
+      #       markerprofileDbIds.")
+      # # assertthat::assert_that((length(df$markerprofileDbIds) >= 1),
+      # #     msg = "No markerprofileDbIdas")
+      # res3 <-  as.data.frame(cbind(germplasmDbId = rep(df$germplasmDbId,
+      #                                         length(df$markerprofileDbIds)),
+      #                       markerProfiles = df$markerprofileDbIds),
+      #                       stringsAsFactors = FALSE)
       return(res3)
     }
     if (rclass %in% c("json", "list")) {

R/ba_germplasm_pedigree.R

@@ -37,10 +37,21 @@ ba_germplasm_pedigree <- function(con = NULL,
       lst <- jsonlite::fromJSON(txt = res)
       dat <- jsonlite::toJSON(x = lst$result)
       res3 <- jsonlite::fromJSON(txt = dat, simplifyDataFrame = TRUE)
+      for (i in 1:length(res3)) {
+        if (length(res3[[i]]) == 0) res[[i]] <- ''
+      }
       # Set null length list-type elements to ''
       for (i in 1:length(res3)) {
         if (length(res3[[i]]) == 0) res3[[i]] <- ""
       }
+      if (length(res3$siblings) > 1) {
+        siblings <- res3$siblings
+        names(siblings) <- paste0('siblings.', names(siblings))
+        res3$siblings <- NULL
+        res3 <- tibble::as.tibble(res3)
+        res3 <- cbind(res3, siblings)
+        siblings <- NULL
+      }
       attr(res3, "metadata") <- lst$metadata
       return(res3)
     }

R/ba_germplasmattributes.R

@@ -17,6 +17,7 @@
 ba_germplasmattributes <- function(con = NULL,
                                    attributeCategoryDbId = "0",
                                    rclass = "tibble") {
+
   ba_check(con = con, verbose = FALSE)
   stopifnot(is.character(attributeCategoryDbId))
   check_rclass(rclass = rclass)

R/ba_germplasmattributes_details.R

@@ -23,6 +23,7 @@ ba_germplasmattributes_details <- function(con = NULL,
                                            page = 0,
                                            pageSize = 10,
                                            rclass = "tibble") {
+  .Deprecated('ba_germplasm_attributes')
   ba_check(con = con, verbose = FALSE)
   stopifnot(is.character(germplasmDbId))
   stopifnot(germplasmDbId != "")

R/ba_studies_table.R

@@ -11,7 +11,7 @@
 #' @param rclass character; default: "tibble" possible other values: "json"/"list"/"data.frame"
 #' @param studyDbId character; default: ''
 #' @param con list; brapi connection object
-#' @param format character; one of: json, csv, tsv. Default: json
+#' @param format character; one of: json, csv, tsv. Default: csv
 #'
 #' @author Reinhard Simon, Maikel Verouden
 #' @references \href{https://github.com/plantbreeding/API/blob/master/Specification/Studies/StudyObservationUnitsAsTable.md}{github}
@@ -25,7 +25,7 @@
 #' @export
 ba_studies_table <- function(con = NULL,
                              studyDbId = "",
-                             format = "json",
+                             format = "csv",
                              rclass = "tibble") {
   ba_check(con = con, verbose = FALSE, brapi_calls = "studies/id/table")
   stopifnot(is.character(studyDbId))
@@ -46,6 +46,7 @@ ba_studies_table <- function(con = NULL,
                               pformat))
   try({
     res <- brapiGET(url = studies_table, con = con)
+  })
     res <- httr::content(x = res, as = "text", encoding = "UTF-8")
     out <- NULL
     if (rclass %in% c("json", "list")) {
@@ -56,6 +57,8 @@ ba_studies_table <- function(con = NULL,
         res2 <- jsonlite::fromJSON(txt = res)$result
         out <- res2$data
         out <- tibble::as.tibble(out)
+        if(length(res2$headerRow) != length(colnames(out)))
+          stop('Header row length does not coincide with column count. Contact database provider.')
         colnames(out) <- res2$headerRow
       }
       if (format == "csv") {
@@ -82,5 +85,5 @@ ba_studies_table <- function(con = NULL,
     }
     class(out) <- c(class(out), "ba_studies_table")
     return(out)
-  })
+
 }

R/mpa2tbl.R

@@ -4,8 +4,11 @@ mpa2tbl <- function(res, rclass = "tibble") {
   dba <- jsonlite::fromJSON(txt = dat)
   udb <- unlist(dba)
   udb <- udb[!is.na(udb)] %>% as.data.frame(stringsAsFactors = FALSE)
-  udb <- as.data.frame(x = cbind(marker = rownames(udb), alleles = udb[, 1]),
-                       stringsAsFactors = FALSE)
+  if (nrow(udb) > 0) {
+    udb <- as.data.frame(x = cbind(marker = rownames(udb), alleles = udb[, 1]),
+                         stringsAsFactors = FALSE)
+
+  }
   if (rclass == "tibble") {
     udb <- tibble::as_tibble(udb)
   }

R/zzz.R

@@ -5,7 +5,7 @@
         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 supports 44/44 BrAPI calls of 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

README.Rmd

@@ -15,9 +15,11 @@ output: github_document
 [![CRAN_Status_Badge](http://www.r-pkg.org/badges/version/brapi)](https://cran.r-project.org/package=brapi)
 [![lifecycle](https://img.shields.io/badge/lifecycle-maturing-blue.svg)](https://www.tidyverse.org/lifecycle/#maturing)
 
-## This version is still under development. The implementation sometimes changes minor details.
+This version is still under development. The implementation sometimes changes minor details.
 
-## Current support is only for BrAPI version 1.1.
+Current support is mainly for BrAPI version 1.1.
+
+Support for version 1.2 is underway.
 
 For independent checks against database you may use http://webapps.ipk-gatersleben.de/brapivalidator.
 
@@ -34,6 +36,7 @@ knitr::opts_chunk$set(
 # README
 
 An R package to use the [Breeding API (BrAPI)](http://docs.brapi.apiary.io) for accessing plant breeding data.
+See the [documentation](https://cip-riu.github.io/brapi/) for details.
 
 It can be installed using:
 

README.md

@@ -14,9 +14,12 @@ Status](https://img.shields.io/codecov/c/github/CIP-RIU/brapi/master.svg)](https
 [![CRAN\_Status\_Badge](http://www.r-pkg.org/badges/version/brapi)](https://cran.r-project.org/package=brapi)
 [![lifecycle](https://img.shields.io/badge/lifecycle-maturing-blue.svg)](https://www.tidyverse.org/lifecycle/#maturing)
 
-## This version is still under development. The implementation sometimes changes minor details.
+This version is still under development. The implementation sometimes
+changes minor details.
 
-## Current support is only for BrAPI version 1.1.
+Current support is mainly for BrAPI version 1.1.
+
+Support for version 1.2 is underway.
 
 For independent checks against database you may use
 <http://webapps.ipk-gatersleben.de/brapivalidator>.
@@ -28,6 +31,7 @@ protocol changes.
 
 An R package to use the [Breeding API
 (BrAPI)](http://docs.brapi.apiary.io) for accessing plant breeding data.
+See the [documentation](https://cip-riu.github.io/brapi/) for details.
 
 It can be installed using: