R/locations.R
In c5sire/brapps: Functions for Demoing Breeding API
#' locations
#'
#' @param input shiny
#' @param output shiyn
#' @param session shiny
#' @param values shiny
#' @import shiny
#' @import leaflet
#' @importFrom magrittr '%>%'
#' @author Reinhard Simon
#' @export
locations <- function(input, output, session, values) {
#if(is.null(brapi)) return(NULL)
#crop = isolate(values$crop)
#is_server = isolate(values$is_server)
#mode = isolate(values$mode)
msg_no_loc = "No location selected."
#
# url = system.file("images", package = "brapps")
# greenLeafIcon <- leaflet::makeIcon(
# iconUrl = file.path(url, "leaf-green.png"),
# iconWidth = 38,
# iconHeight = 95,
# iconAnchorX = 22,
# iconAnchorY = 94,
# shadowUrl = file.path(url, "leaf-shadow.png"),
# shadowWidth = 50,
# shadowHeight = 64,
# shadowAnchorX = 4,
# shadowAnchorY = 62
# )
# get_base_data <- function(mode = "brapi",
# acrop = crop,
# atype = "fieldbooks") {
# bd = fbglobal::get_base_dir(amode = mode, is_server = is_server)
# fp = file.path(bd, acrop, atype)
# #print("get base data")
# #rint(fp)
# if (!dir.exists(fp))
# dir.create(fp, recursive = TRUE)
# fp
# }
#
# return_null_with_msg <- function(msg) {
# cat(msg)
# return(NULL)
# }
#
# fp = file.path(get_base_data(atype = "location", acrop = crop),
# "table_sites.rds")
#
# #print(fp)
# locationData <- reactiveFileReader(10000, session, fp, readRDS)
#
# dat <- reactive({
# dat = NULL
# if (file.exists(fp)) {
# #print(fp)
# dat = locationData()
#
# }
#
# if (is.null(dat)) {
# try({
# #if(is.null(brapi)) return_null_with_msg("Not connection to a BrAPI db set. Please connect.")
# dat <- brapi::locations_list()
# saveRDS(dat, file = fp)
# })
# if (is.null(dat)) {
# return_null_with_msg(
# "Could not retrieve data from database. Check your login details and internet connection."
# )
# }
# }
# dat = dat[dat$latitude != 0 & dat$longitude != 0,]
# out = dat[!is.na(dat$latitude),]
# #print(head(dat))
# #print(out)
# out
# })
#
#
output$ui_map_src_type <- shiny::renderUI({
bdb <- brapi::ba_db()
ndb <- names(bdb)
ndb <- ndb[!ndb %in% c("mockbase", "ricebase")]
ndb <- ndb[stringr::str_detect(ndb, "base")]
out <- shiny::selectInput("map_bdb", "BrAPI database", ndb,
selected = "sweetpotatobase")
return(out)
})
output$ui_map_src_filter <- shiny::renderUI({
out <- shiny::tagList(
shiny::checkboxInput("map_chk_prg", "Use Breeding Programs as filter", value = FALSE),
shiny::uiOutput("map_prgs")
)
#return(out)
})
# output$ui_map_src_fieldbook <- shiny::renderUI({
#
# out <- shiny::tagList(
# shiny::uiOutput("map_stds")
# )
#
# return(out)
# })
map_con <- reactive({
req(input$map_bdb)
con <- shiny::withProgress(message = "Connecting to database", {
brapi::ba_db()[[input$map_bdb]]
})
con
})
map_dat <- reactive({
#out <- NULL
#out <- tryCatch(
#print(map_con())
out <- shiny::withProgress(message = "Loading", detail = "locations", {
brapi::ba_locations(map_con(), pageSize = 1000)
})
#print(class(out))
validate(
need(is.data.frame(out), "Need a location table."),
need("latitude" %in% names(out), "Need a column named latitude."),
need("longitude" %in% names(out), "Need a column named longitude."),
need("name" %in% names(out), "Need a column named name."),
need("altitude" %in% names(out), "Need a column named altitude.")
)
#print(class(out))
# ,
# error = function(e) return(NULL)
# )
out$latitude <- as.numeric(out$latitude)
out$longitude <- as.numeric(out$longitude)
out <- shiny::withProgress(message = "Annotating", detail = "locations", {
out <- add_TmeanPTotal(out)
})
out
})
map_dat_sel <- reactive({
#req(input$tableLocs)
#req(input$tableLocs)
#req(input$ui_map_track)
# validate(need(
# (is.data.frame(map_dat())), "Location data not available."
# ))
out <- map_dat()
out = out[!is.na(out$latitude),]
stds <- NULL
#if (input$ui_map_track %in% c("studies", "seasons", "genotypes")) {
stds <- shiny::withProgress(message = "Loading", detail = "studies", {
brapi::ba_studies_search(map_con(), pageSize = 10000)
})
out <- merge(out, stds, by = "locationDbId")
#}
#print(head(out))
if (input$map_chk_prg) {
out <- out[out$programDbId == input$map_progrs, ]
}
#print(head(out))
if (input$ui_map_track == "studies") {
out <- cbind(out, popupDetail = out$studyName)
}
if (input$ui_map_track == "locations") {
out <- out[!duplicated(out$locationDbId), ]
out <- cbind(out, popupDetail = out$name)
}
if (input$ui_map_track == "seasons") {
# out <- merge(out, stds, by = "locationDbId")
out <- cbind(out, popupDetail = paste(out$name, out$seasons, sep = ": "))
out <- out[!duplicated(out$popupDetail), ]
}
out
})
data_prg <- shiny::reactive({
shiny::withProgress(message = "Connecting", detail = "Loading programs",{
brapi::ba_programs(map_con(), pageSize = 1000)
})
})
output$map_prgs <- shiny::renderUI({
shiny::req(input$map_chk_prg)
if (input$map_chk_prg) {
prg <- as.list(data_prg()$programDbId)
names(prg) <- data_prg()$name
shiny::selectInput("map_progrs", "Breeding programs", choices = prg,
selected = prg[1])
}
})
#
# output$tableLocs <- DT::renderDataTable(dat()
# , server = FALSE,
# options = list(scrollX = TRUE))
output$mapLocs <- leaflet::renderLeaflet({
shinytoastr::toastr_info("This may take a while to show..",
position = "top-center", progressBar = TRUE, timeOut = 10000)
#req(input$mapLocs_marker)
pts <- map_dat_sel()
validate(
need(is.data.frame(pts), "Need a location table."),
need(is.numeric(pts$longitude), "Need numeric longitude data."),
need(is.numeric(pts$latitude), "Need numeric latitude data."),
need(nrow(pts) > 0, "Need at least one location.")
)
# if (is.null(pts))
# pts <- dat()
# if (is.null(pts))
# return_null_with_msg(
# "Could not retrieve data from database. Check your login details and internet connection."
# )
#pts = pts[!is.na(pts$longitude),]
leaflet::leaflet(pts, height = "100%") %>%
leaflet::addTiles() %>%
leaflet::addAwesomeMarkers(~longitude, ~latitude,
popup = ~htmltools::htmlEscape(popupDetail),
clusterOptions = leaflet::markerClusterOptions(clickable = T)) %>%
leaflet::fitBounds(
~ min(pts$longitude),
~ min(pts$latitude),
~ max(pts$longitude),
~ max(pts$latitude)
) %>%
leaflet::addMiniMap()
})
# download the filtered data
# output$locsDL = downloadHandler(
# 'BRAPI-locs-filtered.csv',
# content = function(file) {
# utils::write.csv(dat_sel(), file)
# }
# )
#
#
mrks <- reactive({
x = input$mapLocs_marker_click
subset(
map_dat_sel(),
map_dat_sel()$latitude == as.numeric(x$lat) &
map_dat_sel()$longitude == as.numeric(x$lng)
)
})
#
output$hist_alt <- renderPlot({
if(input$ui_map_track != "locations") return(NULL)
graphics::hist(map_dat()$altitude,
main = "Frequency of altitude of breeding locations.",
xlab = "altitude [m]",
sub = "Selected location frequencies are in red.")
graphics::hist(map_dat_sel()$altitude, add = T, col = "red")
if (length(mrks()) > 0) {
graphics::abline(v = mrks()$altitude,
col = "blue",
lwd = 5)
}
})
#
# ##################################
#
rec2info <- function(rec) {
#rec %>% as.data.frame
nms = names(rec)
dat = t(rec)
dat = cbind(nms, dat)
# print(str(dat))
# print(nrow(dat))
row.names(dat) = 1:nrow(dat)
colnames(dat) = c("Attribute", "Value")
dat = dat[c(1, 5, 9, 4, 3, 2, 6, 7, 8, 10, 12, 13, 14, 11),]
x = htmlTable::htmlTable(dat)
paste0("<center>", x, "</center>") %>% HTML
}
#
output$siteInfo <- renderUI({
if(input$ui_map_track != "locations") return(NULL)
out = msg_no_loc
mrks <- mrks()
rec = mrks[1, ]
if (nrow(rec) == 1) {
out = rec2info(rec)
}
HTML(out)
})
get_geo_mark <- function() {
req(input$mapLocs_marker_click)
click <- input$mapLocs_marker_click
if (is.null(click))
return(NULL)
# leaflet::clearMarkers(input$mapLocs)
#
# leaflet::addMarkers(input$mapLocs,lat = click$lat, lng= click$lng, icon = greenLeafIcon)
locs = map_dat() # get_geo_locs()
locs[locs$latitude == click$lat & locs$longitude == click$lng,]
}
output$chart_env <- renderPlot({
if (input$ui_map_track != "locations") return(NULL)
chart_envelope(map_dat())
mrk <- get_geo_mark()
if (length(mrks()) > 0) {
graphics::points(x = mrk$annualMeanTemperature,
y = mrk$annualTotalRainfall,
col = "blue",
bg = "blue",
type = "p",
pch = 21)
}
})
# observeEvent(input$btn_demo_locs,
# rintrojs::introjs(session))
#
#
# observeEvent(input$setLocsToEnv, {
# brapi_locations <<- dat()
# brapi_locations_filtered <<- dat_sel()
# })
#
# ############### report #########
#
# output$rep_loc <- renderUI({
# withProgress(message = 'Updating report',
# value = 0,
# max = 10,
# {
# locs <- dat_sel()
# n = nrow(locs)
# if (n < 1)
# return("no locations in view!")
# rep_name = "report_location.Rmd"
# #tgt = file.path(getwd(), "reports", rep_name)
# report <- file.path(getwd(), "reports", rep_name)
# dn = dirname(report)
# if (!dir.exists(dn)) {
# dir.create(report)
# }
# if (!file.exists(report)) {
# org = system.file("/apps/hdtest/reports/report_location.Rmd",
# package = "brapps")
#
# file.copy(org, report)
# }
#
#
#
# setProgress(5)
# fn = "no report created."
# try({
# fn <- rmarkdown::render(
# report,
# output_dir = file.path("www", "reports"),
# #rep_dir,
# params = list(locs = locs)
# )
# })
# setProgress(8)
# }) # progress
#
# html <- includeHTML(fn)
# HTML(html)
# })
#
#
# get_all_studies <- function(){
# fp = file.path(get_base_data(atype = "fieldbook"), "fieldbooks.rda")
# stds = NULL
# try({
# if(file.exists(fp)) {
# stds = readRDS(file = fp)
# }
# })
# if(is.null(stds)){
# stds = brapi::studies()
# saveRDS(stds, fp)
# }
# stds
# }
# get_study_path <- function(year, id, mode = mode, crop = crop){
# # if(can_internet()){
# # mode = "brapi"
# # } else {
# # mode = "Demo"
# # }
# ##mode = "brapi"
# if(is.null(year)){
# fp = file.path(get_base_data(atype = "fieldbook", mode = mode, acrop = crop), paste0(id,".rda"))
# }
# if(!is.null(year)){
# fp = file.path(get_base_data(atype = "fieldbook", mode = mode, acrop = crop), year, paste0(id, ".rda"))
# }
# dn = dirname(fp)
# #print(dn)
# if(!dir.exists(dn)) dir.create(dn, recursive = TRUE)
# fp
# }
#
# get_study <- function(year, id){
#
# fp = get_study_path(year, id)
# stdy = NULL
# try({
# if(file.exists(fp)) {
# stdy = readRDS(file = fp)
# }
# })
# if(is.null(stdy)){
# if(can_internet() & !is.null(brapi)){
# stdy = brapi::study_table(id)
# saveRDS(stdy, fp)
# }
# }
# stdy
# }
# get_trials_for_location <- function(amode = "demo", crop) {
# locs = get_geo_mark()
# if (is.null(locs))
# return(NULL)
#
# stds = get_all_studies(amode = amode, crop = crop)
# stds <- stds[!is.na(stds$locationDbId),]
# sid = stds[stds$locationDbId %in% locs$locationDbId, "studyDbId"]
#
# # Download most recent trial for this location!
# # if(can_internet()){
# # ms = max(sid)
# # #xs = stds[stds$studyDbId == ms, ]
# # ss = get_study(year = stds$years[ms], id = ms, amode = amode, crop = crop)
# # }
# sid
# }
#
#
# output$site_fieldtrials <- renderUI({
# html = msg_no_loc
#
# #TODO get amode from user input
#
# amode = "Default"
#
# withProgress(message = 'Getting trial list ...',
# value = 0,
# max = 10,
# {
# #print(mode)
# #print(crop)
# sid = get_trials_for_location(amode = amode, crop = crop)
# #print(sid)
# if (is.null(sid)) {
# out = msg_no_loc
# } else {
# setProgress(5)
#
# if (length(sid) > 0) {
# stds = get_all_studies(amode = amode, crop = crop)
# stds = stds[stds$studyDbId %in% sid,]
#
# txt = paste0("No internet connected!<br/>")
# out = stds$name %>% paste(collapse = ", ")
#
# # if(can_internet() & !is.null(brapi)){
# # txt = ""
# #
# # path = "/breeders/trial/"
# # db = brapi$db
# # host = db
# # if(!stringr::str_detect(db, "@")){
# # if(!stringr::str_detect(db, "http")) {
# # host = paste0("http://", db)
# # }
# # }
# # if(rstudioapi::isAvailable()){
# # if(!stringr::str_detect(db, "http")) {
# # host = paste0("http://", db)
# # }
# # }
# # #print(sid)
# # out = paste0("<br><a href='",host, path, sid, "' target='_blank'>", stds$name, "</a>") %>%
# # paste(collapse = ", ")
# #
# # }
# html = paste0(txt, out)
# }
#
# setProgress(8)
#
# }
# })
# HTML(html)
#
# })
#
#
# output$site_genotypes <- renderUI({
# out = msg_no_loc
#
# #if(!can_internet()) return("No internet connected!")
# #if(!is.null(get_geo_mark())){
#
# # TODO get this from user input demo/brapi
# amode = "Default"
#
# withProgress(message = 'Getting trial list ...',
# value = 0,
# max = 10,
# {
# sid = get_trials_for_location(amode, crop)
# #print(paste("geno/site",sid))
# if (is.null(sid)) {
# out = msg_no_loc
# } else {
# #print(sid)
# year = NULL
# stds = get_all_studies(amode = amode, crop = crop)
#
# #ms = NULL
# if (length(sid) > 1) {
# sid = max(sid)
#
# }
# stds = stds[stds$studyDbId == sid,]
# year = stds$years
#
# #print(year)
# fb = NULL
# fb = get_study(year, sid)
# #print(sid)
#
#
# res = NULL
#
# if (is.null(fb))
# res = "The most recently added trial for this site seems to have no data!"
#
# if (is.null(res)) {
# topgp = brapi::get_top_germplasm(fb)
# #print(topgp)
# if (is.null(topgp))
# res = "Cannot find this trait in the most recently added trial."
#
# }
#
#
# if (is.null(res)) {
# gid = topgp$germplasmDbId
# gnm = topgp$germplasmName
# hid = topgp$`Harvest index computing percent`
# txt = ""
# # if(can_internet() ){
# # db = brapi$db
# # host = db
# # if(!stringr::str_detect(db, "@")){
# # if(!stringr::str_detect(db, "http")) {
# # host = paste0("http://", db)
# # }
# # }
# # if(rstudioapi::isAvailable()){
# # if(!stringr::str_detect(db, "http")) {
# # host = paste0("http://", db)
# # }
# # }
# #
# # path = "/stock/"
# # out = paste0("<a href='",host, path, gid,"/view' target='_blank'>", gnm, " (",hid, ")</a>")
# #
# # out = paste(out, collapse = ", ")
# # txt = ""
# # #print("here")
# # #print(out)
# #
# # }
# # if(!can_internet()){
# # out = paste0 (gnm, " (",hid, ")")
# # out = paste(out, collapse = ", ")
# # txt = paste("No internet connected!</br></br>")
# # }
#
# locs = dat()
# loc_name = locs[locs$locationDbId %in% sid, "name"]
# txt = paste0(
# txt,
# "Top genotypes for trait (",
# "Harvest index" ,
# ") from most recent (",
# year
# ,
# ") fieldbook: ",
# stds$name,
# " for location: ",
# loc_name,
# ":</br>"
# ) # TODO make trait choosable
# res = paste(txt, out)
# }
#
# out = res
# setProgress(8)
# }
#
# })
# #}
# HTML(out)
# })
#
#
# observeEvent(input$mapLocs_marker_click, {
# ## Get the click info like had been doing
# click <- input$mapLocs_marker_click
# clat <- click$lat
# clng <- click$lng
#
# output$siteInfo <- renderText({
# HTML(clat)
# HTML(clng)
# })
#
# # leaflet::leafletProxy('mapLocs') %>% # use the proxy to save computation
# # leaflet::addMarkers(
# # lng = clng,
# # lat = clat,
# # layerId = "marked",
# # icon = greenLeafIcon
# # )
#
# })
#
# observe({
# invalidateLater(millis = 30 * 1000, session)
# #unlink(fp)
# })
}
c5sire/brapps documentation built on May 13, 2019, 10:31 a.m.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
#' locations
#'
#' @param input shiny
#' @param output shiyn
#' @param session shiny
#' @param values shiny
#' @import shiny
#' @import leaflet
#' @importFrom magrittr '%>%'
#' @author Reinhard Simon
#' @export
locations <- function(input, output, session, values) {
#if(is.null(brapi)) return(NULL)
#crop = isolate(values$crop)
#is_server = isolate(values$is_server)
#mode = isolate(values$mode)
msg_no_loc = "No location selected."
#
# url = system.file("images", package = "brapps")
# greenLeafIcon <- leaflet::makeIcon(
# iconUrl = file.path(url, "leaf-green.png"),
# iconWidth = 38,
# iconHeight = 95,
# iconAnchorX = 22,
# iconAnchorY = 94,
# shadowUrl = file.path(url, "leaf-shadow.png"),
# shadowWidth = 50,
# shadowHeight = 64,
# shadowAnchorX = 4,
# shadowAnchorY = 62
# )
# get_base_data <- function(mode = "brapi",
# acrop = crop,
# atype = "fieldbooks") {
# bd = fbglobal::get_base_dir(amode = mode, is_server = is_server)
# fp = file.path(bd, acrop, atype)
# #print("get base data")
# #rint(fp)
# if (!dir.exists(fp))
# dir.create(fp, recursive = TRUE)
# fp
# }
#
# return_null_with_msg <- function(msg) {
# cat(msg)
# return(NULL)
# }
#
# fp = file.path(get_base_data(atype = "location", acrop = crop),
# "table_sites.rds")
#
# #print(fp)
# locationData <- reactiveFileReader(10000, session, fp, readRDS)
#
# dat <- reactive({
# dat = NULL
# if (file.exists(fp)) {
# #print(fp)
# dat = locationData()
#
# }
#
# if (is.null(dat)) {
# try({
# #if(is.null(brapi)) return_null_with_msg("Not connection to a BrAPI db set. Please connect.")
# dat <- brapi::locations_list()
# saveRDS(dat, file = fp)
# })
# if (is.null(dat)) {
# return_null_with_msg(
# "Could not retrieve data from database. Check your login details and internet connection."
# )
# }
# }
# dat = dat[dat$latitude != 0 & dat$longitude != 0,]
# out = dat[!is.na(dat$latitude),]
# #print(head(dat))
# #print(out)
# out
# })
#
#
output$ui_map_src_type <- shiny::renderUI({
bdb <- brapi::ba_db()
ndb <- names(bdb)
ndb <- ndb[!ndb %in% c("mockbase", "ricebase")]
ndb <- ndb[stringr::str_detect(ndb, "base")]
out <- shiny::selectInput("map_bdb", "BrAPI database", ndb,
selected = "sweetpotatobase")
return(out)
})
output$ui_map_src_filter <- shiny::renderUI({
out <- shiny::tagList(
shiny::checkboxInput("map_chk_prg", "Use Breeding Programs as filter", value = FALSE),
shiny::uiOutput("map_prgs")
)
#return(out)
})
# output$ui_map_src_fieldbook <- shiny::renderUI({
#
# out <- shiny::tagList(
# shiny::uiOutput("map_stds")
# )
#
# return(out)
# })
map_con <- reactive({
req(input$map_bdb)
con <- shiny::withProgress(message = "Connecting to database", {
brapi::ba_db()[[input$map_bdb]]
})
con
})
map_dat <- reactive({
#out <- NULL
#out <- tryCatch(
#print(map_con())
out <- shiny::withProgress(message = "Loading", detail = "locations", {
brapi::ba_locations(map_con(), pageSize = 1000)
})
#print(class(out))
validate(
need(is.data.frame(out), "Need a location table."),
need("latitude" %in% names(out), "Need a column named latitude."),
need("longitude" %in% names(out), "Need a column named longitude."),
need("name" %in% names(out), "Need a column named name."),
need("altitude" %in% names(out), "Need a column named altitude.")
)
#print(class(out))
# ,
# error = function(e) return(NULL)
# )
out$latitude <- as.numeric(out$latitude)
out$longitude <- as.numeric(out$longitude)
out <- shiny::withProgress(message = "Annotating", detail = "locations", {
out <- add_TmeanPTotal(out)
})
out
})
map_dat_sel <- reactive({
#req(input$tableLocs)
#req(input$tableLocs)
#req(input$ui_map_track)
# validate(need(
# (is.data.frame(map_dat())), "Location data not available."
# ))
out <- map_dat()
out = out[!is.na(out$latitude),]
stds <- NULL
#if (input$ui_map_track %in% c("studies", "seasons", "genotypes")) {
stds <- shiny::withProgress(message = "Loading", detail = "studies", {
brapi::ba_studies_search(map_con(), pageSize = 10000)
})
out <- merge(out, stds, by = "locationDbId")
#}
#print(head(out))
if (input$map_chk_prg) {
out <- out[out$programDbId == input$map_progrs, ]
}
#print(head(out))
if (input$ui_map_track == "studies") {
out <- cbind(out, popupDetail = out$studyName)
}
if (input$ui_map_track == "locations") {
out <- out[!duplicated(out$locationDbId), ]
out <- cbind(out, popupDetail = out$name)
}
if (input$ui_map_track == "seasons") {
# out <- merge(out, stds, by = "locationDbId")
out <- cbind(out, popupDetail = paste(out$name, out$seasons, sep = ": "))
out <- out[!duplicated(out$popupDetail), ]
}
out
})
data_prg <- shiny::reactive({
shiny::withProgress(message = "Connecting", detail = "Loading programs",{
brapi::ba_programs(map_con(), pageSize = 1000)
})
})
output$map_prgs <- shiny::renderUI({
shiny::req(input$map_chk_prg)
if (input$map_chk_prg) {
prg <- as.list(data_prg()$programDbId)
names(prg) <- data_prg()$name
shiny::selectInput("map_progrs", "Breeding programs", choices = prg,
selected = prg[1])
}
})
#
# output$tableLocs <- DT::renderDataTable(dat()
# , server = FALSE,
# options = list(scrollX = TRUE))
output$mapLocs <- leaflet::renderLeaflet({
shinytoastr::toastr_info("This may take a while to show..",
position = "top-center", progressBar = TRUE, timeOut = 10000)
#req(input$mapLocs_marker)
pts <- map_dat_sel()
validate(
need(is.data.frame(pts), "Need a location table."),
need(is.numeric(pts$longitude), "Need numeric longitude data."),
need(is.numeric(pts$latitude), "Need numeric latitude data."),
need(nrow(pts) > 0, "Need at least one location.")
)
# if (is.null(pts))
# pts <- dat()
# if (is.null(pts))
# return_null_with_msg(
# "Could not retrieve data from database. Check your login details and internet connection."
# )
#pts = pts[!is.na(pts$longitude),]
leaflet::leaflet(pts, height = "100%") %>%
leaflet::addTiles() %>%
leaflet::addAwesomeMarkers(~longitude, ~latitude,
popup = ~htmltools::htmlEscape(popupDetail),
clusterOptions = leaflet::markerClusterOptions(clickable = T)) %>%
leaflet::fitBounds(
~ min(pts$longitude),
~ min(pts$latitude),
~ max(pts$longitude),
~ max(pts$latitude)
) %>%
leaflet::addMiniMap()
})
# download the filtered data
# output$locsDL = downloadHandler(
# 'BRAPI-locs-filtered.csv',
# content = function(file) {
# utils::write.csv(dat_sel(), file)
# }
# )
#
#
mrks <- reactive({
x = input$mapLocs_marker_click
subset(
map_dat_sel(),
map_dat_sel()$latitude == as.numeric(x$lat) &
map_dat_sel()$longitude == as.numeric(x$lng)
)
})
#
output$hist_alt <- renderPlot({
if(input$ui_map_track != "locations") return(NULL)
graphics::hist(map_dat()$altitude,
main = "Frequency of altitude of breeding locations.",
xlab = "altitude [m]",
sub = "Selected location frequencies are in red.")
graphics::hist(map_dat_sel()$altitude, add = T, col = "red")
if (length(mrks()) > 0) {
graphics::abline(v = mrks()$altitude,
col = "blue",
lwd = 5)
}
})
#
# ##################################
#
rec2info <- function(rec) {
#rec %>% as.data.frame
nms = names(rec)
dat = t(rec)
dat = cbind(nms, dat)
# print(str(dat))
# print(nrow(dat))
row.names(dat) = 1:nrow(dat)
colnames(dat) = c("Attribute", "Value")
dat = dat[c(1, 5, 9, 4, 3, 2, 6, 7, 8, 10, 12, 13, 14, 11),]
x = htmlTable::htmlTable(dat)
paste0("<center>", x, "</center>") %>% HTML
}
#
output$siteInfo <- renderUI({
if(input$ui_map_track != "locations") return(NULL)
out = msg_no_loc
mrks <- mrks()
rec = mrks[1, ]
if (nrow(rec) == 1) {
out = rec2info(rec)
}
HTML(out)
})
get_geo_mark <- function() {
req(input$mapLocs_marker_click)
click <- input$mapLocs_marker_click
if (is.null(click))
return(NULL)
# leaflet::clearMarkers(input$mapLocs)
#
# leaflet::addMarkers(input$mapLocs,lat = click$lat, lng= click$lng, icon = greenLeafIcon)
locs = map_dat() # get_geo_locs()
locs[locs$latitude == click$lat & locs$longitude == click$lng,]
}
output$chart_env <- renderPlot({
if (input$ui_map_track != "locations") return(NULL)
chart_envelope(map_dat())
mrk <- get_geo_mark()
if (length(mrks()) > 0) {
graphics::points(x = mrk$annualMeanTemperature,
y = mrk$annualTotalRainfall,
col = "blue",
bg = "blue",
type = "p",
pch = 21)
}
})
# observeEvent(input$btn_demo_locs,
# rintrojs::introjs(session))
#
#
# observeEvent(input$setLocsToEnv, {
# brapi_locations <<- dat()
# brapi_locations_filtered <<- dat_sel()
# })
#
# ############### report #########
#
# output$rep_loc <- renderUI({
# withProgress(message = 'Updating report',
# value = 0,
# max = 10,
# {
# locs <- dat_sel()
# n = nrow(locs)
# if (n < 1)
# return("no locations in view!")
# rep_name = "report_location.Rmd"
# #tgt = file.path(getwd(), "reports", rep_name)
# report <- file.path(getwd(), "reports", rep_name)
# dn = dirname(report)
# if (!dir.exists(dn)) {
# dir.create(report)
# }
# if (!file.exists(report)) {
# org = system.file("/apps/hdtest/reports/report_location.Rmd",
# package = "brapps")
#
# file.copy(org, report)
# }
#
#
#
# setProgress(5)
# fn = "no report created."
# try({
# fn <- rmarkdown::render(
# report,
# output_dir = file.path("www", "reports"),
# #rep_dir,
# params = list(locs = locs)
# )
# })
# setProgress(8)
# }) # progress
#
# html <- includeHTML(fn)
# HTML(html)
# })
#
#
# get_all_studies <- function(){
# fp = file.path(get_base_data(atype = "fieldbook"), "fieldbooks.rda")
# stds = NULL
# try({
# if(file.exists(fp)) {
# stds = readRDS(file = fp)
# }
# })
# if(is.null(stds)){
# stds = brapi::studies()
# saveRDS(stds, fp)
# }
# stds
# }
# get_study_path <- function(year, id, mode = mode, crop = crop){
# # if(can_internet()){
# # mode = "brapi"
# # } else {
# # mode = "Demo"
# # }
# ##mode = "brapi"
# if(is.null(year)){
# fp = file.path(get_base_data(atype = "fieldbook", mode = mode, acrop = crop), paste0(id,".rda"))
# }
# if(!is.null(year)){
# fp = file.path(get_base_data(atype = "fieldbook", mode = mode, acrop = crop), year, paste0(id, ".rda"))
# }
# dn = dirname(fp)
# #print(dn)
# if(!dir.exists(dn)) dir.create(dn, recursive = TRUE)
# fp
# }
#
# get_study <- function(year, id){
#
# fp = get_study_path(year, id)
# stdy = NULL
# try({
# if(file.exists(fp)) {
# stdy = readRDS(file = fp)
# }
# })
# if(is.null(stdy)){
# if(can_internet() & !is.null(brapi)){
# stdy = brapi::study_table(id)
# saveRDS(stdy, fp)
# }
# }
# stdy
# }
# get_trials_for_location <- function(amode = "demo", crop) {
# locs = get_geo_mark()
# if (is.null(locs))
# return(NULL)
#
# stds = get_all_studies(amode = amode, crop = crop)
# stds <- stds[!is.na(stds$locationDbId),]
# sid = stds[stds$locationDbId %in% locs$locationDbId, "studyDbId"]
#
# # Download most recent trial for this location!
# # if(can_internet()){
# # ms = max(sid)
# # #xs = stds[stds$studyDbId == ms, ]
# # ss = get_study(year = stds$years[ms], id = ms, amode = amode, crop = crop)
# # }
# sid
# }
#
#
# output$site_fieldtrials <- renderUI({
# html = msg_no_loc
#
# #TODO get amode from user input
#
# amode = "Default"
#
# withProgress(message = 'Getting trial list ...',
# value = 0,
# max = 10,
# {
# #print(mode)
# #print(crop)
# sid = get_trials_for_location(amode = amode, crop = crop)
# #print(sid)
# if (is.null(sid)) {
# out = msg_no_loc
# } else {
# setProgress(5)
#
# if (length(sid) > 0) {
# stds = get_all_studies(amode = amode, crop = crop)
# stds = stds[stds$studyDbId %in% sid,]
#
# txt = paste0("No internet connected!<br/>")
# out = stds$name %>% paste(collapse = ", ")
#
# # if(can_internet() & !is.null(brapi)){
# # txt = ""
# #
# # path = "/breeders/trial/"
# # db = brapi$db
# # host = db
# # if(!stringr::str_detect(db, "@")){
# # if(!stringr::str_detect(db, "http")) {
# # host = paste0("http://", db)
# # }
# # }
# # if(rstudioapi::isAvailable()){
# # if(!stringr::str_detect(db, "http")) {
# # host = paste0("http://", db)
# # }
# # }
# # #print(sid)
# # out = paste0("<br><a href='",host, path, sid, "' target='_blank'>", stds$name, "</a>") %>%
# # paste(collapse = ", ")
# #
# # }
# html = paste0(txt, out)
# }
#
# setProgress(8)
#
# }
# })
# HTML(html)
#
# })
#
#
# output$site_genotypes <- renderUI({
# out = msg_no_loc
#
# #if(!can_internet()) return("No internet connected!")
# #if(!is.null(get_geo_mark())){
#
# # TODO get this from user input demo/brapi
# amode = "Default"
#
# withProgress(message = 'Getting trial list ...',
# value = 0,
# max = 10,
# {
# sid = get_trials_for_location(amode, crop)
# #print(paste("geno/site",sid))
# if (is.null(sid)) {
# out = msg_no_loc
# } else {
# #print(sid)
# year = NULL
# stds = get_all_studies(amode = amode, crop = crop)
#
# #ms = NULL
# if (length(sid) > 1) {
# sid = max(sid)
#
# }
# stds = stds[stds$studyDbId == sid,]
# year = stds$years
#
# #print(year)
# fb = NULL
# fb = get_study(year, sid)
# #print(sid)
#
#
# res = NULL
#
# if (is.null(fb))
# res = "The most recently added trial for this site seems to have no data!"
#
# if (is.null(res)) {
# topgp = brapi::get_top_germplasm(fb)
# #print(topgp)
# if (is.null(topgp))
# res = "Cannot find this trait in the most recently added trial."
#
# }
#
#
# if (is.null(res)) {
# gid = topgp$germplasmDbId
# gnm = topgp$germplasmName
# hid = topgp$`Harvest index computing percent`
# txt = ""
# # if(can_internet() ){
# # db = brapi$db
# # host = db
# # if(!stringr::str_detect(db, "@")){
# # if(!stringr::str_detect(db, "http")) {
# # host = paste0("http://", db)
# # }
# # }
# # if(rstudioapi::isAvailable()){
# # if(!stringr::str_detect(db, "http")) {
# # host = paste0("http://", db)
# # }
# # }
# #
# # path = "/stock/"
# # out = paste0("<a href='",host, path, gid,"/view' target='_blank'>", gnm, " (",hid, ")</a>")
# #
# # out = paste(out, collapse = ", ")
# # txt = ""
# # #print("here")
# # #print(out)
# #
# # }
# # if(!can_internet()){
# # out = paste0 (gnm, " (",hid, ")")
# # out = paste(out, collapse = ", ")
# # txt = paste("No internet connected!</br></br>")
# # }
#
# locs = dat()
# loc_name = locs[locs$locationDbId %in% sid, "name"]
# txt = paste0(
# txt,
# "Top genotypes for trait (",
# "Harvest index" ,
# ") from most recent (",
# year
# ,
# ") fieldbook: ",
# stds$name,
# " for location: ",
# loc_name,
# ":</br>"
# ) # TODO make trait choosable
# res = paste(txt, out)
# }
#
# out = res
# setProgress(8)
# }
#
# })
# #}
# HTML(out)
# })
#
#
# observeEvent(input$mapLocs_marker_click, {
# ## Get the click info like had been doing
# click <- input$mapLocs_marker_click
# clat <- click$lat
# clng <- click$lng
#
# output$siteInfo <- renderText({
# HTML(clat)
# HTML(clng)
# })
#
# # leaflet::leafletProxy('mapLocs') %>% # use the proxy to save computation
# # leaflet::addMarkers(
# # lng = clng,
# # lat = clat,
# # layerId = "marked",
# # icon = greenLeafIcon
# # )
#
# })
#
# observe({
# invalidateLater(millis = 30 * 1000, session)
# #unlink(fp)
# })
}
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Embedding an R snippet on your website
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.