u

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

# Conflicts:
#	docs/articles/tutorial.html

DESCRIPTION

@@ -1,6 +1,6 @@
 Package: brapi
 Title: Client to Access Breeding Databases Using BrAPI
-Version: 0.9.1
+Version: 0.9.2
 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_calls.R

@@ -1,9 +1,11 @@
 #' ba_calls
 #'
-#' lists calls available on a brapi server
+#' lists calls available on a brapi server.
+#'
+#' TODO v1.2: deprecate this and add ba_commonCropNames. The new function won't have datatype parameter.
 #'
 #' @param rclass string; default: tibble
-#' @param datatypes string, list of data types
+#' @param datatype string, list of data types
 #' @param con brapi connection object
 #' @param pageSize integer; default = 1000
 #' @param page integer; default = 0
@@ -16,32 +18,32 @@
 #' @family brapicore
 #' @export
 ba_calls <- function(con = NULL,
-                     datatypes = "csv",
-                     pageSize = 50,
+                     datatype = "csv",
+                     pageSize = 1000,
                      page = 0,
                      rclass = "tibble") {
   # argument checking
   ba_check(con = con, verbose = FALSE, brapi_calls = "calls")
   check_paging(pageSize = pageSize, page = page)
   check_rclass(rclass = rclass)
-  stopifnot(datatypes %in% c("all", "json", "csv", "tsv"))
+  stopifnot(datatype %in% c("all", "json", "csv", "tsv"))
   # obtain the brapi url
   brp <- get_brapi(con = con)
   # generate the call url
   brapi_calls <- paste0(brp, "calls/?")
-  pdatatypes <- ifelse(datatypes == "all", "",
-                       paste0("datatypes=", datatypes, "&"))
+  pdatatype <- ifelse(datatype == "", "",
+                       paste0("datatypes=", datatype, "&"))
   ppage <- ifelse(is.numeric(page), paste0("page=", page, ""), "")
   ppageSize <- ifelse(is.numeric(pageSize),
                       paste0("pageSize=", pageSize, "&"), "")
   if (pageSize >= 1000) {
     ppage <- ""
     ppageSize <- ""
-    datatypes <- ""
+    pdatatype <- ""
     brapi_calls <- paste0(brp, "calls/?")
   }
   # modify the call url with pagenation
-  brapi_calls <- paste0(brapi_calls, pdatatypes, ppageSize, ppage)
+  brapi_calls <- paste0(brapi_calls, pdatatype, ppageSize, ppage)
   try({
     # make the brapi GET call with the generated call url
     res <- brapiGET(url = brapi_calls, con = con)

R/ba_check.R

@@ -16,34 +16,11 @@ ba_check <- function(con = NULL, verbose = TRUE, brapi_calls = "any") {
   stopifnot(is.ba_con(con))
   stopifnot(is.logical(verbose))
   stopifnot(is.character(brapi_calls))
-  if (is.null(con)) {
-    stop("BrAPI connection object is NULL. Use brapi::ba_connect()")
-  }
-  url <- con$db
-  # if(brapi_calls != "calls") {
-  #   if(!(brapi_calls %in% ba_calls(con)$call)) {
-  #     message("Call not implemented according to calls result..")
-  #   }
-  # }
 
-  # check for localhost
-  if (stringr::str_detect(string = con$db, pattern = "127")) {
-    url <- paste0(con$db, ":", con$port, "/brapi/v1/")
-    status <- 600
-    status <- try({
-      httr::GET(url = url)$status_code
-    })
-    if (status == 404) {
-      stop("Call not implemented.")
-    }
+  url <- con$db
 
-    if (status == 600) {
-      stop("Cannot connect to server. Use other connection details.")
-    }
-  } else {
-    ba_can_internet()
-    ba_can_internet(url)
-  }
+  ba_can_internet()
+  ba_can_internet(url)
 
   if (verbose) {
     ba_message("BrAPI connection ok.")

R/ba_db.R

@@ -10,7 +10,7 @@
 ba_db <- function() {
   apiary <- as.ba_db(secure = TRUE,
                           protocol = "https://",
-                          db = "private-anon-f133f3ec50-brapi.apiary-mock.com",
+                          db = "private-anon-3d3307a632-brapi.apiary-mock.com",
                           port = 80,
                           multicrop = FALSE,
                           crop = "wheat",

R/ba_genomemaps_details.R

@@ -39,12 +39,10 @@ ba_genomemaps_details <- function(con = NULL,
       dat <- jsonlite::toJSON(x = lst$result$linkageGroups)
       if (rclass == "data.frame") {
         out <- jsonlite::fromJSON(txt = dat, simplifyDataFrame = TRUE)
-        out <- out[[1]]
+        out <- out[[1]] %>% tibble::as_tibble() %>% as.data.frame()
       } else {
         out <- jsonlite::fromJSON(txt = dat, simplifyDataFrame = TRUE)  #%>%
-        if (class(out) == "list") {
-          out <- out[[1]]
-        }
+
         out <- tibble::as_tibble(out)
       }
       if (!is.null(lst$result$linkageGroups)) {

R/ba_germplasm_markerprofiles.R

@@ -54,13 +54,13 @@ ba_germplasm_markerprofiles <- function(con = NULL,
     if (rclass %in% c("json", "list")) {
       out <- dat2tbl(res = res2, rclass = rclass)
     }
-    if (rclass == "vector") {
-      out <- jsonlite::fromJSON(txt = res2,
-                    simplifyVector = FALSE)$result$markerProfiles %>% unlist
-    }
+
     if (rclass == "data.frame") {
       out <- ms2tbl(res = res2)
     }
+    if (rclass == "vector") {
+      out <- ms2tbl(res = res2)[, 2]
+    }
     if (rclass == "tibble") {
       out <- ms2tbl(res = res2) %>% tibble::as_tibble()
     }

R/ba_locations.R

@@ -5,6 +5,8 @@
 #' All standard attributes are always listed. However, attributes in the additionalInfo
 #' only when at least one record has data.
 #'
+#' V1.2: same
+#'
 #' @note Tested against: sweetpotatobase, BMS
 #'
 #' @param con brapi connection object

R/ba_message.R

@@ -1,5 +1,5 @@
 ba_message <- function(msg = "Using local test server.") {
   if(is.null(msg)) return("")
-  if(getOption("brapi_info", default = FALSE) == FALSE) return("")
+  if(!getOption("brapi_info", default = FALSE)) return("")
   return(message(msg))
 }

R/ba_phenotypes_search.R

@@ -46,61 +46,27 @@ ba_phenotypes_search <- function(con = NULL,
   brp <- get_brapi(con = con)
   pvariables <- paste0(brp, "phenotypes-search/")
   try({
-    body <- list(germplasmDbIds = germplasmDbIds,
-                 observationVariableDbIds = observationVariableDbIds,
-                 studyDbIds = studyDbIds,
-                 locationDbIds = locationDbIds,
-                 programDbIds = programDbIds,
-                 seasonDbIds = seasonDbIds,
+    body <- list(germplasmDbId = germplasmDbIds,
+                 observationVariableDbId = observationVariableDbIds,
+                 studyDbId = studyDbIds,
+                 locationDbId = locationDbIds,
+                 programDbId = programDbIds,
+                 seasonDbId = seasonDbIds,
                  observationLevel = observationLevel,
                  pageSize = pageSize,
                  page = page)
     res <- brapiPOST(url = pvariables, body = body, con = con)
+    show_metadata(res)
+
     res2 <- httr::content(x = res, as = "text", encoding = "UTF-8")
-    out <- NULL
-    if (rclass %in% c("json", "list")) {
-      out <- dat2tbl(res = res2, rclass = rclass)
-    }
-    if (rclass %in% c("tibble", "data.frame")) {
-      out <- jsonlite::fromJSON(txt = res2, simplifyDataFrame = TRUE)
-      out1 <- out$result$data
-      n <- nrow(out1)
-      nr <- sapply(X = out1$observations, FUN = nrow)
-      nid <- rep.int(x = out1$observationUnitDbId, times = nr)
-      out2 <- out1$observations[[1]]
-      if (n > 1) {
-          for (i in 2:n) {
-            out2 <- rbind(out2, out1$observations[[i]])
-          }
-      }
-      out2 <- cbind(observationUnitDbId = nid, out2)
-      names(out2)[2:ncol(out2)] <- paste0("observations.",
-                                          names(out2)[2:ncol(out2)])
-      out3 <- merge(x = out1, y = out2, by = "observationUnitDbId")
-      out3$observations <- NULL
-      out <- out3
-      trt <- as.data.frame(x = cbind(treatments.factor = rep("",
-                              nrow(out)),
-                              treatments.modality = rep("", nrow(out))),
-                           stringsAsFactors = FALSE)
-      for (i in 1:nrow(out)) {
-          if (length(out$treatments[[i]]) == 2) {
-            trt[i, ] <- out$treatments[[i]]
-          }
-      }
-      trt[, 1] <- as.factor(trt[, 1])
-      trt[, 2] <- as.factor(trt[, 2])
-      out$treatments <- NULL
-      out <- cbind(out, trt)
-      out <- out[, c(1:19, 27, 28, 20:26)]
-      if (rclass == "data.frame") {
-        out <- tibble::as_data_frame(x = out)
-      } else {
-        out <- tibble::as_tibble(x = out)
-      }
+    if(rclass != "json") {
+      out <- baps2rclass(res2, rclass)
+    } else {
+      out <- res2
     }
+
     class(out) <- c(class(out), "ba_phenotypes_search")
-    show_metadata(res)
+
     return(out)
   })
 }

R/ba_programs.R

@@ -2,7 +2,7 @@
 #'
 #' lists the breeding programs
 #'
-#' BRAPI discussion: Should this return also the crop?
+#' V1.2: same
 #'
 #' @note Tested against: sweetpotatobase, BMS
 #'

R/ba_programs_search.R

@@ -2,6 +2,7 @@
 #'
 #' searches the breeding programs
 #'
+#' V1.2: same
 #'
 #' @param con list, brapi connection object
 #'

R/baps2rclass.R

@@ -0,0 +1,46 @@
+baps2rclass <- function(res2, rclass) {
+  out <- NULL
+  if (rclass %in% c("json", "list")) {
+    out <- dat2tbl(res = res2, rclass = rclass)
+  }
+  if (rclass %in% c("tibble", "data.frame")) {
+    out <- jsonlite::fromJSON(txt = res2, simplifyDataFrame = TRUE)
+    out1 <- out$result$data
+    n <- nrow(out1)
+    if(is.null(n)) return(NULL) # no data
+    nr <- sapply(X = out1$observations, FUN = nrow)
+    nid <- rep.int(x = out1$observationUnitDbId, times = nr)
+    out2 <- out1$observations[[1]]
+    if (n > 1) {
+      for (i in 2:n) {
+        out2 <- rbind(out2, out1$observations[[i]])
+      }
+    }
+    out2 <- cbind(observationUnitDbId = nid, out2)
+    names(out2)[2:ncol(out2)] <- paste0("observations.",
+                                        names(out2)[2:ncol(out2)])
+    out3 <- merge(x = out1, y = out2, by = "observationUnitDbId")
+    out3$observations <- NULL
+    out <- out3
+    trt <- as.data.frame(x = cbind(treatments.factor = rep("",
+                                                           nrow(out)),
+                                   treatments.modality = rep("", nrow(out))),
+                         stringsAsFactors = FALSE)
+    for (i in 1:nrow(out)) {
+      if (length(out$treatments[[i]]) == 2) {
+        trt[i, ] <- out$treatments[[i]]
+      }
+    }
+    trt[, 1] <- as.factor(trt[, 1])
+    trt[, 2] <- as.factor(trt[, 2])
+    out$treatments <- NULL
+    out <- cbind(out, trt)
+    out <- out[, c(1:19, 27, 28, 20:26)]
+    if (rclass == "data.frame") {
+      out <- tibble::as_data_frame(x = out)
+    } else {
+      out <- tibble::as_tibble(x = out)
+    }
+  }
+  return(out)
+}

R/brapiGET.R

@@ -1,9 +1,12 @@
 brapiGET <- function(url, format = "json", con = NULL) {
   ba_message(msg = paste0("URL call was: ", url, "\n"))
   ba_message(msg = paste0("Waiting for response from server: ...\n"))
+
   res <- httr::GET(url = url,
         httr::add_headers("Authorization" =
                             paste("Bearer", con$token)))
+
+
   txt <- ifelse(res$status == 200, " ok!", " problem!")
   ba_message(msg = paste0("Server status: ", txt, "\n"))
   out <- httr::content(res)

R/loc2tbl.R

@@ -1,4 +1,4 @@
-loc2tbl <- function(res, rclass, con) {
+loc2tbl <- function(res, rclass, con = NULL) {
   lst <- jsonlite::fromJSON(txt = res)
   dat <- jsonlite::toJSON(x = lst$result$data)
   dat <- jsonlite::fromJSON(txt = dat, simplifyDataFrame = TRUE)

R/show_server_status_messages.R

@@ -9,13 +9,14 @@ show_server_status_messages <- function(out) {
       ba_message()
   }
 
-  if(getOption("brapi_info", default = FALSE) == FALSE) {
-    out <- out$metadata$status %>% unlist %>% as.list()
-    ba_message(crayon::yellow("Status details from Server:"))
+  if(!getOption("brapi_info", default = FALSE)) return()
+
+  out <- out$metadata$status %>% unlist %>% as.list()
+  ba_message(crayon::yellow("Status details from Server:"))
+
+  show_message("info", "Infos", crayon::blue)
+  show_message("success", "Successes", crayon::green)
+  show_message("error", "Errors", crayon::red)
 
-    show_message("info", "Infos", crayon::blue)
-    show_message("success", "Successes", crayon::green)
-    show_message("error", "Errors", crayon::red)
-  }
 
 }