diff --git a/R/ids.R b/R/ids.R index 7faff78..bcb09ee 100644 --- a/R/ids.R +++ b/R/ids.R @@ -106,6 +106,33 @@ is_key <- function(x, compound=FALSE) { is.character(x) & grepl("^[a-z0-9]+:[0-9]{5,20}$", x) } +id_spec_type <- function(x) { + if(is.numeric(x)) + return("id") + if(is.character(x)) { + if(length(x) == 1) { + if(grepl("^http[s]{0,1}://", x)) + return("url") + else if(isTRUE(substr(x,1,1)=="/")) + return("query") + else if(grepl("^\\s*([a-z:]{3}[0-9,\\s]+)+$", x, perl = T)) + return("key") + else if(grepl("^\\s*([0-9,\\s]+)+$", x, perl = T)) + return("id") + else + return("query") + } + if(all(grepl("^[a-z0-9]+:[0-9]{5,20}$", x))) + return("key") + if(all(grepl("^[0-9]{5,20}$", x))) + return("id") + } + if(inherits(x, "ngscene")) + return('ngscene') + return(NA_character_) +} + + #' Specify ids for fly connectome datasets #' #' @param query A query (e.g. cell type name or regular expression) diff --git a/R/normalisation.R b/R/normalisation.R new file mode 100644 index 0000000..ae4a578 --- /dev/null +++ b/R/normalisation.R @@ -0,0 +1,79 @@ +normalise_query <- function(x, dataset=NULL) { + if(!isTRUE(id_spec_type(x)=='query')) + return(x) + + if(!isTRUE(substr(x,1,1)=="/") || length(x)!=1) + return(x) + + # first add default query field if missing + query_field=stringr::str_match(x, '^/([A-z][A-z0-9]*):.+')[,2] + if(is.na(query_field)) { + query_field='type' + x=paste0('/type:', substr(x,2,nchar(x))) + } + query_field2=translate_fields(query_field, dataset = dataset, direction = 'out') + query_expr=stringr::str_match(x, '^[^:]+:(.+)')[,2] + if(is.na(query_expr)) { + warning('unable to parse query expression!') + return(x) + } + x=paste0("/", query_field2, ":", query_expr) + x +} + +# this private function; expects a character vector and returns one of same length +# out means from coconatfly to the external data source +# in means from the external data source to coconatfly +translate_fields <- function(x, dataset, direction=c("out", "in")) { + FUN=field_translater(dataset=dataset, direction = direction) + FUN(x) +} + +# this is a function generator, the resultant functions are what dplyr::rename +# would like +field_translater <- function(dataset, direction=c("out", "in")) { + dataset=match_datasets(dataset) + direction=match.arg(direction) + field_table <- switch(dataset, + flywire=c( + id='root_id', + type="cell_type", + class="super_class", + subclass="cell_class", + subsubclass="cell_sub_class"), + hemibrain=c( + id='bodyid', + lineage="cellBodyFiber" + ), + manc=c( + id='bodyid', + lineage="hemilineage" + ), + malecns=c( + id='bodyid', + class="superclass", + subclass="class", + subsubclass="subclass" + ), + opticlobe=c( + id='bodyid' + ), + character() + ) + + FUN=function(x) { + if(length(field_table)==0) return(x) + # out means that we are translating coconatfly -> external + # in means that we are translating external -> coconatfly + if(direction=='out') { + y=field_table[match(x, names(field_table))] + y[is.na(y)]=x[is.na(y)] + } else { + y=names(field_table)[match(x, field_table)] + y[is.na(y)]=x[is.na(y)] + } + unname(y) + } + FUN +} + diff --git a/tests/testthat/test-normalisation.R b/tests/testthat/test-normalisation.R new file mode 100644 index 0000000..76485e7 --- /dev/null +++ b/tests/testthat/test-normalisation.R @@ -0,0 +1,13 @@ +test_that("field translation works", { + cf=c("subclass", "class", "type", "rhubarb") + fw=c("cell_class", "super_class", "cell_type", "rhubarb") + expect_equal(translate_fields(fw, dataset = 'fly', direction = 'in'), cf) + expect_equal(translate_fields(cf, dataset = 'fly', direction = 'out'), fw) + + l=as.list(letters[seq_along(cf)]) + names(l)=cf + df=data.frame(l) + expect_type(tofw <- field_translater(dataset = "flywire", direction = "out"), 'closure') + df2=dplyr::rename_with(df, .fn=tofw) + expect_equal(colnames(df2), fw) +})