From f307a067d2138f9dfeb92133d87ddc88f610de47 Mon Sep 17 00:00:00 2001 From: MGousseff Date: Sun, 9 Jul 2023 23:21:19 +0200 Subject: [PATCH] levCol2 migrated to levcol Check showLCZ with tryGroup=TRUE and write test files --- R/levCol.R | 449 +++++++++++++++-------------------- R/levCol2.R | 264 -------------------- R/showLCZ.R | 7 +- inst/tinytest/test_levCol.R | 46 +++- inst/tinytest/test_levCol2.R | 248 ------------------- inst/tinytest/test_showLCZ.R | 37 +-- 6 files changed, 255 insertions(+), 796 deletions(-) delete mode 100644 R/levCol2.R delete mode 100644 inst/tinytest/test_levCol2.R diff --git a/R/levCol.R b/R/levCol.R index 103c35c..1540b5f 100644 --- a/R/levCol.R +++ b/R/levCol.R @@ -3,6 +3,7 @@ #' @param sf is the input sf file #' @param column is the column that contains the data #' @param drop is set to TRUE if one wants to drop unused levels, in case column is a factor with unused levels +#' @param useStandCol is set to TRUE if one wants recognized standard levels to be associated with standard colors. Default is FALSE #' @param ... other parameters specified, expected a vector of levels and a vector of colors #' whose name must begin with colors. Other cases are handled to enhance usability. #' @import dplyr sf @@ -14,24 +15,35 @@ #' @export #' #' @examples -#' #levCol is not to be used directly by user. It deals with levels and colors provided by the user -levCol<-function(sf,column,drop=FALSE,...){ +#' #levCol2 is not to be used directly by user. It deals with levels and colors provided by the user +levCol<-function(sf,column,drop=FALSE,useStandCol=FALSE,...){ +# Getting ALL the arguments in (...) and computing the values needed for conditions statements args<-list(...) - # Note : case_match will be use in future version to ease readability of this function - + +# Stop if there are more than 37 arguments. if (length(args)>=37){ stop("This function can not deal with more than 36 arguments. You can use the function groupLCZ to group some levels.")} - # - - uniqueData<-sf[column] %>% sf::st_drop_geometry() %>% unique() # Attention unique outputs a list of length 1 +# get the natural levels from the data : uniqueData + uniqueData<-sf[column] %>% sf::st_drop_geometry() %>% unique() + # Attention, unique outputs a list of length 1 + + # Sometimes, the input data can be a factor, with levels not present in the actual data. + # One may want to drop these levels + if(drop==TRUE){uniqueData<-droplevels(uniqueData)} + uniqueData<-levels(uniqueData[,1]) %>% as.character() %>% as.vector() + # Stop if there are more than 36 levels : really impossible to read such a map + # or confusion matrix + if(length(uniqueData)>36){ stop( - "This package is not suited for classification with more than 36 levels or types. + "This package is not suited for qualitative variables/classifications with more than 36 levels/types. You can use the function groupLCZ to group some levels.") } +# Getting the levels and separating level vector(s) and colors vector if present. + argNames<-names(args) indCol<-grep(x=argNames, pattern="colors") if (length(indCol) != 0) { @@ -39,291 +51,214 @@ levCol<-function(sf,column,drop=FALSE,...){ stop( "Only one argument can start with colors, and it must contain the colors, please rename your arguments and retry.")} else { - argCol <- args[indCol][[1]] - argLev<-args[-indCol] - if (prod(argCol=="")==1){ + argCol <- args[indCol][[1]] + argLev<-args[-indCol] + # In case the color vector is made of empty strings + if (prod(argCol=="")==1){ args<-args[-indCol] argCol<-NULL + # In case the vector of levels is simultaneously made of empty strings if(prod(unlist(argLev)=="")==1){args<-NULL} - } + } }} else - { - argCol<-NULL - argLev<-args + { + argCol<-NULL + argLev<-args } - + if(length(argLev)>36){ stop("This package is not suited for classification with more than 36 levels or types. You can use the function groupLCZ to group some levels.") } - - - -# argLev has to be treatd differently if input is one vector with the levels or -# if each level has an argument. - - # Define cases - # Case : no arguments at all in (...), or colors and other arguments are NULL - if (length(args) == 0 || - (is.null(args)) || - (prod(unlist(args)=="")==1)) - { - if (length(uniqueData) > 36) - { - case<-"Too many levels" - stop("0: The number of levels must be less than 37 for the map to be readable, - you may want to group some of the levels using groupLCZ function ") - } else { - case<-"1: No level vector and no color vector, less than 36 levels, + +############################################################################################# +## Simplest Case no arguments passed : levels and colors deduced from the Data +############################################################################################# + +if (length(args) == 0 || + (is.null(args)) || + (prod(unlist(args)=="")==1)) { + case<-"1: No level vector and no color vector, less than 36 levels, levels will be deduced from the data and colors will be chosen from a standard palette." - typeLevels<-standLevCol( levels=uniqueData, - colors=palette.colors(n=length(uniqueData), palette="Polychrome 36"), - useStandCol=TRUE) - - } - } + typeLevels<-standLevCol( levels=uniqueData, + colors=palette.colors(n=length(uniqueData), palette="Polychrome 36"), + useStandCol=useStandCol) +} - # Case (...) contains only one argument (color OR levels) - if(length(args) == 1) - { - if (length(indCol) == 1 && prod(argCol!="")==1 && !is.null(argCol)) + ############################################################################################# + ## Case when only colors are passed + ############################################################################################# + if(length(args) == 1 && length(indCol) == 1 && prod(argCol!="")==1) { if (length(argCol) == length(uniqueData)){ - if ( prod(areColors(argCol)==1)){ - case<-"2: No level vector, but a color vector - which size covers the number of levels in the data." - typeLevels<-argCol - names(typeLevels)<-uniqueData - } else { - case<-"2.1 : No level vector, but a color vector which size covers the number of levels in the data. - Some or all of the specified colors are not recognized as colors and will be replaced by colors from a standard palette." - colFalse<-!areColors(argCol) - typeLevels<-argCol - typeLevels[colFalse]<-palette.colors( - n=sum(as.numeric(colFalse)), palette="Polychrome 36") - names(typeLevels)<-uniqueData - } + + case<-"2: No level vector, but a color vector which size covers the number of levels in the data." + typeLevels<-argCol + names(typeLevels)<-uniqueData + } + else if (length(argCol) < length(uniqueData)) { + case<-"3: No levels but a color vector which size does not cover the number of levels in the data, missing colors will be picked from a standard palette. " + lengthDiff<-length(uniqueData)-length(argCol) + typeLevels<-c(argCol,palette.colors(n=lengthDiff, palette="Polychrome 36")) + names(typeLevels)<-uniqueData } - else - { - case<-"3: No levels but a color vector which size does not cover the number of levels in the data, - colors will be picked from a standard palette. " - typeLevels<-palette.colors(n=length(uniqueData), palette="Polychrome 36") - names(typeLevels)<-uniqueData + else if (length(argCol) > length(uniqueData)) { + case<-"3.1 : No levels but a color vector which size is greater than the number of levels in the data, some colors were dropped. " + typeLevels<-argCol[1:length(uniqueData)] + names(typeLevels)<-uniqueData } } - if (is.null(argCol)) - { - if (prod(areColors(argLev[[1]]))==1) { - if(prod(uniqueData%in%names(argLev[[1]]))==1 & length(uniqueData)==length(argLev[[1]])) { - case<-"4: A single vector was provided, whose names cover the levels in the data - and whose values are colors." - typeLevels<-argLev[[1]] - names(typeLevels)<-names(argLev[[1]]) - } else - { - if(length(uniqueData)<=length(argLev[[1]])) - { - case<-case<-"5: A single vector was provided, whose values are colors - but who includes names of levels not present in the data. - Specified colors will be associated to levels deduced from the data, - in order of appearence. " - typeLevels<-argLev[[1]][seq_along(uniqueData)] - names(typeLevels)<-uniqueData - } else - { - case<-"6: A single vector was provided, whose values are colors - but whose names don't cover the levels in the data. - Colors will be associated to unique values of the data - and missing colors will be added from a standard palette. " - typeLevels<-c(argLev[[1]], - palette.colors(n=length(uniqueData)-length(argLev[[1]]), palette="Polychrome 36")) - names(typeLevels)<-uniqueData - } - } - } - else { - if (prod(uniqueData%in%argLev[[1]])==1) { - case<-"7: No color vector but a level vector whose names cover the levels in the data" - typeLevels<-palette.colors(n=length(argLev[[1]]), palette="Polychrome 36") - names(typeLevels)<-argLev[[1]] - } else - { - case<-"8: No color vector but a level vector whose names don't cover the levels in the data - Levels will be deduced from data and colors will be chosen from a standard palette." - typeLevels<-palette.colors(n=length(uniqueData),palette="Polychrome 36") - names(typeLevels)<-uniqueData - } - - - } + ############################################################################################# + ## Case when only levels are passed in a single vector (elements of the vector are not named) + ############################################################################################# + if (is.null(argCol) && length(args)==1 && is.null(names(argLev[[1]]))) { + + ########### Case where the levels cover the levels of unique Data + if (prod(uniqueData%in%argLev[[1]])==1) { + + case<-"7: No color vector but a level vector whose names cover the levels in the data (even if some levels may not be present in the data)" + typeLevels<-palette.colors(n=length(argLev[[1]]), palette="Polychrome 36") + names(typeLevels)<-argLev[[1]] + } else if ( prod(uniqueData%in%argLev[[1]])==0 ){ + ########### Case where the levels do not cover the levels of unique Data + case<-"8: No color vector but a level vector whose names don't cover the levels in the data + Levels will be deduced from data and colors will be chosen from a standard palette." + temp<-unique(c(uniqueData,argLev[[1]])) + typeLevels<-palette.colors(n=length(temp),palette="Polychrome 36") + names(typeLevels)<-temp + } } - } - -# Case (...) contains 2 argument, hopefully a vector of levels and a vector of colors - if ( length(args)==2 && - !(prod(unlist(args)=="")==1)) { + ############################################################################################# + ## Case when only one vector is passed, but the elements of the vector are named. + ## Name is expected to be a level, value is expected to be a color. + ############################################################################################# + if (is.null(argCol) && length(args)==1 && !is.null(names(argLev[[1]]))) { + ########### Case where the level names do not cover the levels of unique Data + if(prod(uniqueData%in%names(argLev[[1]]))==1) { + case<-"4: & 5: A single vector was provided, whose names cover the levels in the data (values are expected to be colors)." + typeLevels<-argLev[[1]] + } else if (prod(uniqueData%in%names(argLev[[1]]))==0) { + case<-"6: A single vector was provided, whose names don't cover the levels in the data, + missing levels were assigned random colors." + + indMiss<-!uniqueData%in%names(argLev[[1]]) + nMiss<-sum(indMiss) + miss<-palette.colors(n=nMiss, palette="Polychrome 36") + names(miss)<-uniqueData[indMiss] + typeLevels<-c(argLev[[1]],miss) + - typeLevels<-argLev - if(length(indCol==1)) - { if ( length(argLev)length(argCol)){ - case<-"11: One vector seems to be a vector of levels, - which covers the values of the data, the other a vector of colors, - who is empty or whose length is shorter than the specified levels. - Missing colors will be picked from a standard palette. Association between levels and colors is unreliable. - For a better rendition specify as many colors as levels." + case<-"13: No color vector is specified, there seems to be two ambiguous level vectors, + they will pasted and fed to the function again, and reduced to the following case. " + recall<-levCol(sf=sf,column=column,drop=drop,levels=c(argLev[[1]],argLev[[2]])) + typeLevels<-recall$levelsColors + case<-c(case,recall$case) + } + ########### Case where one vector of color is passed, one vector of levels - LCZlevels<-argLev[[1]] - # typeLevels<-palette.colors(n=length(LCZlevels), palette="Polychrome 36") - lengthDiff<-length(LCZlevels)-length(argCol) - argCol<-c(argCol,palette.colors(n=lengthDiff, palette="Polychrome 36")) - typeLevels<-argCol - names(typeLevels)<-LCZlevels - } else if (length(uniqueData)<=length(argCol)){ - case<-"12: One vector seems to be a vector of levels, - which covers the values of the data, - the other a vector of colors, whose length is longer than the specified levels. - The supplemental colors will be dropped." - typeLevels<-argCol[1:length(uniqueData)] - names(typeLevels)<-argLev[[1]] - } - } - } - } - else { - case<-"13: No color vector is specified, there seems to be two ambiguous level vectors, - levels will be deduced from the data and colors chosen from a standard palette." - typeLevels<-palette.colors(n=length(uniqueData), palette="Polychrome 36") - names(typeLevels)<-uniqueData + if ( length(args) == 2 && !(prod(unlist(args) == "") == 1) && length(indCol == 1)) { + + ########### Case where the vectors are of the same size or if the levels vector + # is shorter than the color vector + if (length(argLev[[1]]) <= length(argCol)){ + + typeLevels<-argCol + names(typeLevels)<-argLev[[1]] + recall<-levCol(sf=sf, column=column, drop=drop, levels=typeLevels) + typeLevels<-recall$levelsColors + typeLevels<-typeLevels[!is.na(names(typeLevels))] + case<-paste( + "Case one vector of levels, one vector of colors, either the same length (case 9: and 10:), or colors longer (case 12:, unused colors were dropped), + reduced to ", + recall$case) + } else if (length(argLev[[1]]) > length(argCol)) { - } + ######## case when vectors not of the same size and more levels than colors + complement<-length(argLev[[1]])-length(argCol) + typeLevels<-c(argCol,palette.colors(n=complement, palette="Polychrome 36")) + names(typeLevels)<-argLev[[1]] + recall<-levCol(sf=sf, column=column, drop=drop, levels=typeLevels) + typeLevels<-recall$levelsColors + case<-paste("Case one vector of levels, one of colors, the vector of colors being shorter, some colors were picked, case 11:, reduced to ", + recall$case, "your may want to check your vector of colors") + } + + + + } -# Case (...) contain more than 2 arguments, - # hopefully an argument for each level and zero or one vector of colors + ############################################################################################# + ## Case when more than two vectors are passed. + ## Hopefully an argument for each level and zero or one vector of colors + ############################################################################################# - if ( length(args) > 2 ) - { + if ( length(args) > 2 && length(indCol)==1){ + ######## Case when several vectors of levels and a vector of colors + LCZlevels<-unique(c(names(argLev),uniqueData)) + recall<-levCol(sf=sf, column=column, drop=drop, levels=LCZlevels, colors=argCol) + + + case<-paste("Case 14: with at least a color or 15:, or 17: or 18:, then reduced to ", + recall$case) + typeLevels<-recall$levelsColors + } + + if ( length(args) > 2 && length(indCol)==0){ + ######## Case when several vectors of levels and a level of colors LCZlevels<-names(argLev) - ### GERER L'APPEL À groupLCZ DANS CE CAS - if(prod(uniqueData%in%LCZlevels)==0 && length(argCol)<=length(uniqueData)){ - case<-"14: The specified levels don't cover the levels in the data - and the number of specified colors is zero or less than the number of levels present, - levels will be deduced from the data and colors will be chosen from a standard palette." - typeLevels<-c(palette.colors(n=length(uniqueData), palette="Polychrome 36")) - indOK<-match(uniqueData,LCZlevels)[!is.na(match(uniqueData,LCZlevels))] - typeLevels[indOK]<-argCol[indOK] - names(typeLevels)<-uniqueData - } else if (prod(uniqueData%in%LCZlevels)==0 && length(argCol)>=length(uniqueData)){ - case<-"15: The specified levels don't cover the levels in the data - but the number of specified colors is greater or equal - to the number of levels present in the data, - they are matched in the order of appearence." - colTemp<-argCol - names(colTemp)[1:length(LCZlevels)]<-LCZlevels - allLev<-unique(c(LCZlevels,uniqueData)) - colN<-palette.colors(n=length(allLev),palette = "Polychrome 36") - names(colN)<-allLev - indOK<-match(names(colN),LCZlevels)[!is.na(match(names(colN),LCZlevels))] - colN[indOK]<-colTemp[indOK] - typeLevels<-colN - } - else if (prod(uniqueData%in%LCZlevels)==1 && length(argCol)>length(uniqueData)){ - case<-"15.1: The specified levels cover the levels in the data - but the number of specified colors is greater or equal - to the number of levels present in the data, - they are matched in the order of appearence and - levels non specified will be matched with color from a standard palette. - Maybe recheck your levels and colors. " - typeLevels<-argCol[seq_along(LCZlevels)] - names(typeLevels)<-LCZlevels - } - else if (prod(uniqueData%in%LCZlevels)==1 && length(argCol)==0 ){ - case<-"16: The specified levels cover the levels in the data - and no colors were specified, colors will be chosen from a standard palette." - typeLevels<-palette.colors(n=length(LCZlevels), palette="Polychrome 36") - names(typeLevels)<-LCZlevels - } - else if (prod(uniqueData%in%LCZlevels)==1 && length(argCol)==length(argLev)){ - if(prod(areColors(argCol))==1){ - case<-"17: Several arguments are specified, whose names cover - the levels in the data and are associated with a vector of colors of the same size. - Evrything seems OK and these levels and colors will be used." - typeLevels<-argCol - names(typeLevels)<-LCZlevels - } else { - - case<-"18: Several arguments are specified, whose names cover - the levels in the data but the associated vector of colors - contains names which are not colors. - These will be replaced by colors from a standard palette." - colFalse<-!areColors(argCol) - typeLevels<-argCol - typeLevels[colFalse]<-palette.colors( - n=sum(as.numeric(colFalse)), palette="Polychrome 36") - names(typeLevels)<-LCZlevels - } - } + recall<-levCol(sf=sf, column=column, drop=drop, levels=LCZlevels) + case<-paste("Case 16: then reduced to ", + recall$case) + typeLevels<-recall$levelsColors } -output<-list(levelsColors=typeLevels,case=case) - message(case) -return(output) -} + + ############################################################################################# + ## Check if colors value are recognized, if not, assign a color + ############################################################################################# + if(prod(areColors(typeLevels))!=1){ + case<-paste( + case, + " Some of the specified colors are unknown to R and were replaced by colors picked from a Polychrome Palette") + colFalse<-!areColors(typeLevels) + typeLevels[colFalse]<-palette.colors( + n=sum(as.numeric(colFalse)), palette="Polychrome 36") + } -#library(lczexplore) -#library(tinytest) - # redonBDTgrouped<-groupLCZ(redonBDT,column="LCZ_PRIMARY",outCol = "grouped",urban=c("1","2","3","4","5","6","7","8","9"), - # industry="10", - # vegetation=c("101","102","103","104"), - # impervious="105",pervious="106",water="107", - # colors=c("red","black","green","grey","burlywood","blue")) + ############################################################################################# + ## If drop=TRUE check if some levels were specified and not present in the data, then drop them + ############################################################################################# -#summary(redonBDTgrouped$grouped) \ No newline at end of file + + if(drop==TRUE ){ + indKeep<-names(typeLevels)%in%uniqueData + if(prod(names(typeLevels)%in%uniqueData)==0) { + case<-paste( + case, + "Drop=TRUE, some of the specified levels were not found in the data and were dropped") + typeLevels<-typeLevels[indKeep] + } + } + output<-list(levelsColors=typeLevels,case=case) + +} \ No newline at end of file diff --git a/R/levCol2.R b/R/levCol2.R deleted file mode 100644 index 1540b5f..0000000 --- a/R/levCol2.R +++ /dev/null @@ -1,264 +0,0 @@ -#' Manages the levels and the colors of the LCZ columns -#' -#' @param sf is the input sf file -#' @param column is the column that contains the data -#' @param drop is set to TRUE if one wants to drop unused levels, in case column is a factor with unused levels -#' @param useStandCol is set to TRUE if one wants recognized standard levels to be associated with standard colors. Default is FALSE -#' @param ... other parameters specified, expected a vector of levels and a vector of colors -#' whose name must begin with colors. Other cases are handled to enhance usability. -#' @import dplyr sf -#' @importFrom grDevices palette.colors -#' -#' @return output is a list containing levelColors, a named vector, which names are the levels -#' present in the data and which values are the associated colors, -#' and case, a string spcifying what case was encountered when producing the levels and colors. -#' @export -#' -#' @examples -#' #levCol2 is not to be used directly by user. It deals with levels and colors provided by the user -levCol<-function(sf,column,drop=FALSE,useStandCol=FALSE,...){ -# Getting ALL the arguments in (...) and computing the values needed for conditions statements - args<-list(...) - -# Stop if there are more than 37 arguments. - if (length(args)>=37){ stop("This function can not deal with more than 36 arguments. - You can use the function groupLCZ to group some levels.")} - -# get the natural levels from the data : uniqueData - uniqueData<-sf[column] %>% sf::st_drop_geometry() %>% unique() - # Attention, unique outputs a list of length 1 - - # Sometimes, the input data can be a factor, with levels not present in the actual data. - # One may want to drop these levels - - if(drop==TRUE){uniqueData<-droplevels(uniqueData)} - - uniqueData<-levels(uniqueData[,1]) %>% as.character() %>% as.vector() - - # Stop if there are more than 36 levels : really impossible to read such a map - # or confusion matrix - - if(length(uniqueData)>36){ stop( - "This package is not suited for qualitative variables/classifications with more than 36 levels/types. - You can use the function groupLCZ to group some levels.") } - -# Getting the levels and separating level vector(s) and colors vector if present. - - argNames<-names(args) - indCol<-grep(x=argNames, pattern="colors") - if (length(indCol) != 0) { - if (length(indCol)>1 ) { - stop( - "Only one argument can start with colors, and it must contain the colors, - please rename your arguments and retry.")} else { - argCol <- args[indCol][[1]] - argLev<-args[-indCol] - # In case the color vector is made of empty strings - if (prod(argCol=="")==1){ - args<-args[-indCol] - argCol<-NULL - # In case the vector of levels is simultaneously made of empty strings - if(prod(unlist(argLev)=="")==1){args<-NULL} - } - }} else - { - argCol<-NULL - argLev<-args - } - - if(length(argLev)>36){ stop("This package is not suited for classification with more than 36 levels or types. - You can use the function groupLCZ to group some levels.") } - -############################################################################################# -## Simplest Case no arguments passed : levels and colors deduced from the Data -############################################################################################# - -if (length(args) == 0 || - (is.null(args)) || - (prod(unlist(args)=="")==1)) { - case<-"1: No level vector and no color vector, less than 36 levels, - levels will be deduced from the data - and colors will be chosen from a standard palette." - - typeLevels<-standLevCol( levels=uniqueData, - colors=palette.colors(n=length(uniqueData), palette="Polychrome 36"), - useStandCol=useStandCol) -} - - ############################################################################################# - ## Case when only colors are passed - ############################################################################################# - if(length(args) == 1 && length(indCol) == 1 && prod(argCol!="")==1) - { - if (length(argCol) == length(uniqueData)){ - - case<-"2: No level vector, but a color vector which size covers the number of levels in the data." - typeLevels<-argCol - names(typeLevels)<-uniqueData - } - else if (length(argCol) < length(uniqueData)) { - case<-"3: No levels but a color vector which size does not cover the number of levels in the data, missing colors will be picked from a standard palette. " - lengthDiff<-length(uniqueData)-length(argCol) - typeLevels<-c(argCol,palette.colors(n=lengthDiff, palette="Polychrome 36")) - names(typeLevels)<-uniqueData - } - else if (length(argCol) > length(uniqueData)) { - case<-"3.1 : No levels but a color vector which size is greater than the number of levels in the data, some colors were dropped. " - typeLevels<-argCol[1:length(uniqueData)] - names(typeLevels)<-uniqueData - } - } - - ############################################################################################# - ## Case when only levels are passed in a single vector (elements of the vector are not named) - ############################################################################################# - if (is.null(argCol) && length(args)==1 && is.null(names(argLev[[1]]))) { - - ########### Case where the levels cover the levels of unique Data - if (prod(uniqueData%in%argLev[[1]])==1) { - - case<-"7: No color vector but a level vector whose names cover the levels in the data (even if some levels may not be present in the data)" - typeLevels<-palette.colors(n=length(argLev[[1]]), palette="Polychrome 36") - names(typeLevels)<-argLev[[1]] - } else if ( prod(uniqueData%in%argLev[[1]])==0 ){ - ########### Case where the levels do not cover the levels of unique Data - case<-"8: No color vector but a level vector whose names don't cover the levels in the data - Levels will be deduced from data and colors will be chosen from a standard palette." - temp<-unique(c(uniqueData,argLev[[1]])) - typeLevels<-palette.colors(n=length(temp),palette="Polychrome 36") - names(typeLevels)<-temp - } - } - - ############################################################################################# - ## Case when only one vector is passed, but the elements of the vector are named. - ## Name is expected to be a level, value is expected to be a color. - ############################################################################################# - if (is.null(argCol) && length(args)==1 && !is.null(names(argLev[[1]]))) { - ########### Case where the level names do not cover the levels of unique Data - if(prod(uniqueData%in%names(argLev[[1]]))==1) { - case<-"4: & 5: A single vector was provided, whose names cover the levels in the data (values are expected to be colors)." - typeLevels<-argLev[[1]] - } else if (prod(uniqueData%in%names(argLev[[1]]))==0) { - case<-"6: A single vector was provided, whose names don't cover the levels in the data, - missing levels were assigned random colors." - - indMiss<-!uniqueData%in%names(argLev[[1]]) - nMiss<-sum(indMiss) - miss<-palette.colors(n=nMiss, palette="Polychrome 36") - names(miss)<-uniqueData[indMiss] - typeLevels<-c(argLev[[1]],miss) - - - - } - } - - ############################################################################################# - ## Case when two vectors are passed. One is expected to be levels, the other to be colors - ############################################################################################# - - ########### Case where no vector of color is passed, two vectors of levels - - if ( length(args)==2 && prod(unlist(args)=="")==0 && length(indCol)==0) { - - case<-"13: No color vector is specified, there seems to be two ambiguous level vectors, - they will pasted and fed to the function again, and reduced to the following case. " - recall<-levCol(sf=sf,column=column,drop=drop,levels=c(argLev[[1]],argLev[[2]])) - typeLevels<-recall$levelsColors - case<-c(case,recall$case) - } - - ########### Case where one vector of color is passed, one vector of levels - - if ( length(args) == 2 && !(prod(unlist(args) == "") == 1) && length(indCol == 1)) { - - ########### Case where the vectors are of the same size or if the levels vector - # is shorter than the color vector - if (length(argLev[[1]]) <= length(argCol)){ - - typeLevels<-argCol - names(typeLevels)<-argLev[[1]] - recall<-levCol(sf=sf, column=column, drop=drop, levels=typeLevels) - typeLevels<-recall$levelsColors - typeLevels<-typeLevels[!is.na(names(typeLevels))] - case<-paste( - "Case one vector of levels, one vector of colors, either the same length (case 9: and 10:), or colors longer (case 12:, unused colors were dropped), - reduced to ", - recall$case) - } else if (length(argLev[[1]]) > length(argCol)) { - - ######## case when vectors not of the same size and more levels than colors - complement<-length(argLev[[1]])-length(argCol) - typeLevels<-c(argCol,palette.colors(n=complement, palette="Polychrome 36")) - names(typeLevels)<-argLev[[1]] - recall<-levCol(sf=sf, column=column, drop=drop, levels=typeLevels) - typeLevels<-recall$levelsColors - case<-paste("Case one vector of levels, one of colors, the vector of colors being shorter, some colors were picked, case 11:, reduced to ", - recall$case, "your may want to check your vector of colors") - - } - - - - } - - ############################################################################################# - ## Case when more than two vectors are passed. - ## Hopefully an argument for each level and zero or one vector of colors - ############################################################################################# - - if ( length(args) > 2 && length(indCol)==1){ - ######## Case when several vectors of levels and a vector of colors - LCZlevels<-unique(c(names(argLev),uniqueData)) - - recall<-levCol(sf=sf, column=column, drop=drop, levels=LCZlevels, colors=argCol) - - - case<-paste("Case 14: with at least a color or 15:, or 17: or 18:, then reduced to ", - recall$case) - typeLevels<-recall$levelsColors - } - - if ( length(args) > 2 && length(indCol)==0){ - ######## Case when several vectors of levels and a level of colors - LCZlevels<-names(argLev) - - recall<-levCol(sf=sf, column=column, drop=drop, levels=LCZlevels) - case<-paste("Case 16: then reduced to ", - recall$case) - typeLevels<-recall$levelsColors - - } - - - - ############################################################################################# - ## Check if colors value are recognized, if not, assign a color - ############################################################################################# - if(prod(areColors(typeLevels))!=1){ - case<-paste( - case, - " Some of the specified colors are unknown to R and were replaced by colors picked from a Polychrome Palette") - colFalse<-!areColors(typeLevels) - typeLevels[colFalse]<-palette.colors( - n=sum(as.numeric(colFalse)), palette="Polychrome 36") - } - - ############################################################################################# - ## If drop=TRUE check if some levels were specified and not present in the data, then drop them - ############################################################################################# - - - if(drop==TRUE ){ - indKeep<-names(typeLevels)%in%uniqueData - if(prod(names(typeLevels)%in%uniqueData)==0) { - case<-paste( - case, - "Drop=TRUE, some of the specified levels were not found in the data and were dropped") - typeLevels<-typeLevels[indKeep] - } - } - output<-list(levelsColors=typeLevels,case=case) - -} \ No newline at end of file diff --git a/R/showLCZ.R b/R/showLCZ.R index 6a325f8..b9cb7df 100644 --- a/R/showLCZ.R +++ b/R/showLCZ.R @@ -10,6 +10,7 @@ #' @param title allows the user to set the title of the plot #' @param drop indicates if you want to show the levels present in no geometry. #' @param useStandCol is set to TRUE implies that any levels detected as a standard LCZ level will receive the standard associated color +#' @param tryGroup is set to TRUE when one wants to group and plot on the fly #' @param ... these dynamic dots allow you to pass arguments to specify levels expected #' in your dataset and colors associated to these levels when not in the standard representation. You can pas your levels through a vector and you colors through another vector called colors. #' For more details about this, read the "lcz_explore_alter" vignette. @@ -29,7 +30,7 @@ #' colors=c("red","black","green","grey","burlywood","blue"),wf="BD TOPO") #' showLCZ<-function(sf, title="", wf="",column="LCZ_PRIMARY", - repr="standard", drop=FALSE, useStandCol=FALSE,...){ + repr="standard", drop=FALSE, useStandCol=FALSE, tryGroup=TRUE,...){ datasetName<-deparse(substitute(sf)) @@ -125,10 +126,10 @@ showLCZ<-function(sf, title="", wf="",column="LCZ_PRIMARY", levColShow<-levCol(sf,column,...) typeLevels<-levColShow$levelsColors - rm(sfNew1) + rm(sfNew) } - + message(levColCase) # IN CASE SOME STANDARD LEVELS ARE DETECTED, ONE MAY WANT STANDARD COLORS TO BE APPLIED diff --git a/inst/tinytest/test_levCol.R b/inst/tinytest/test_levCol.R index 06acee2..5ff4096 100644 --- a/inst/tinytest/test_levCol.R +++ b/inst/tinytest/test_levCol.R @@ -1,9 +1,11 @@ # This tests the function levCol.R # library(tinytest) # library(lczexplore) -# +# library(dplyr) # library(sf) +dealtWithCases<-c("1","2","3","3.1","4","5","6","7","8","13") + redonBDTgrouped<-groupLCZ(redonBDT,column="LCZ_PRIMARY",urban=c("1","2","3","4","5","6","7","8","9"), industry="10", vegetation=c("101","102","103","104"), @@ -42,6 +44,14 @@ test<-levCol(sf=redonBDTgrouped,column="grouped", colors=c("red","black","green","grey","burlywood")) expect_equal(grep("3:",test$case),1) +test<-test<-levCol(sf=redonBDTgrouped,column="grouped", + colors=c("red","black","green","grey","burlywood","blue","purple")) + + + + + + # case 4: A single vector was provided, whose names cover the levels in the data # and whose values are colors. test<-levCol(redonBDTgrouped, column="grouped", levels=c("urban"="red","industry"="black", @@ -54,10 +64,10 @@ expect_equal(grep("4:",test$case),1) # but whose names don't cover the levels in the data. # Specified colors will be associated to levels deduced from the data, # in order of appearence. -test<-levCol(redonBDTgrouped, column="grouped", levels=c("urban"="red","industry"="black", +test<-levCol(redonBDTgrouped, column="grouped", drop=TRUE, levels=c("urban"="red","industry"="black", "vegetation"="green", "impervious"="grey", - "not present in the data"="white", + "not in data"="white", "pervious"="burlywood","water"="blue")) expect_equal(grep("5:",test$case),1) @@ -81,6 +91,15 @@ test<-levCol(redonBDTgrouped, column="grouped", levels=c("urban","industry","John Scofield","impervious","pervious","water")) expect_equal(grep("8:",test$case),1) +test<-levCol(redonBDTgrouped, column="grouped", + levels=c("industry","John Scofield","impervious","pervious","water")) +expect_equal(grep("8:",test$case),1) + +test<-levCol(redonBDTgrouped, column="grouped", drop=TRUE, + levels=c("industry","John Scofield","impervious","pervious","water")) +expect_equal(grep("8:",test$case),1) + + # case 9: Levels specified in one vector, whose values cover the levels in the data, # colors in another vector, these vectors having the same length test<-levCol(redonBDTgrouped, column="grouped", @@ -105,12 +124,12 @@ expect_equal(grep("10:",test$case),1) # the other a vector of colors, whose length is shorter than the specified levels. # Missing colors will be picked from a standard palette. -# test<-levCol(redonBDTgrouped, column="grouped", -# levels=c("urban","industry","vegetation","impervious","pervious","water"), -# colors=c("red","black","green","grey","blue")) +test<-levCol(redonBDTgrouped, column="grouped", + levels=c("urban","industry","vegetation","impervious","pervious","water"), + colors=c("red", "black", "green", "grey", "blue")) -# expect_equal(grep("11:",test$case),1) +expect_equal(grep("11:",test$case),1) # case 12: One vector seems to be a vector of levels, # which covers the values of the data, @@ -143,11 +162,13 @@ expect_equal(grep("14.0:",test$case),1) # and the number of specified colors is zero or less than the number of levels present, # levels will be deduced from the data and colors will be chosen from a standard palette. -test<-levCol(sf=redonBDTgrouped,column="grouped", +test<-levCol(sf=redonBDTgrouped, column="grouped", industry="10", vegetation=c("101","102","103","104"), impervious="105",pervious="106",water="107", - colors=c("red","black","green","grey","burlywood","blue")) + colors=c("red","black","green","grey","burlywood")) + + expect_equal(grep("14:",test$case),1) # case 15: The specified levels don't cover the levels in the data @@ -155,7 +176,7 @@ expect_equal(grep("14:",test$case),1) # to the number of levels present in the data, # they are matched in the order of appearence. -test<-levCol(sf=redonBDTgrouped,column="grouped",urban=c("1","2","3","4","5","6","7","8","9"), +test<-levCol(sf=redonBDTgrouped,column="grouped",urban=c("1","2","3","4","5","6","7","8","9"), vegetation=c("101","102","103","104"), impervious="105",pervious="106",water="107", colors=c("red","black","green","grey","burlywood","blue","orange")) @@ -188,6 +209,8 @@ test<-levCol(sf=redonBDTgrouped,column="grouped",urban=c("1","2","3","4","5","6" vegetation=c("101","102","103","104"), impervious="105",pervious="106",water="107", colors=c("red","black","green","grey","burlywood","blue")) + + expect_equal(grep("17:",test$case),1) # case 18 : Several arguments are specified, whose names cover @@ -200,6 +223,9 @@ test<-levCol(sf=redonBDTgrouped,column="grouped",urban=c("1","2","3","4","5","6" vegetation=c("101","102","103","104"), impervious="105",pervious="106",water="107", colors=c("red","black","green","grey","DJ Shadow","blue")) + + + expect_equal(grep("18:",test$case),1) redonBDTgrouped<-groupLCZ(redonBDT,column="LCZ_PRIMARY",urban=c("1","2","3","4","5","6","7","8","9"), diff --git a/inst/tinytest/test_levCol2.R b/inst/tinytest/test_levCol2.R deleted file mode 100644 index 5ff4096..0000000 --- a/inst/tinytest/test_levCol2.R +++ /dev/null @@ -1,248 +0,0 @@ -# This tests the function levCol.R -# library(tinytest) -# library(lczexplore) -# library(dplyr) -# library(sf) - -dealtWithCases<-c("1","2","3","3.1","4","5","6","7","8","13") - -redonBDTgrouped<-groupLCZ(redonBDT,column="LCZ_PRIMARY",urban=c("1","2","3","4","5","6","7","8","9"), - industry="10", - vegetation=c("101","102","103","104"), - impervious="105",pervious="106",water="107",colors=c("red","black","green","grey","burlywood","blue")) - -# several vector covering the levels in the data, with colors of the proper size - -# case 0: The number of levels must be less than 37 for the map to be readable, -# you may want to group some of the levels using groupLCZ function -expect_error( - levCol(sf=redonBDT, column="LCZ_PRIMARY",1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, - 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, 36, 37, 38,colors="black"), - "more than 36 arguments") - -# case 1: No level vector and no color vector, less than 36 levels, -# levels will be deduced from the data -# and colors will be chosen from a standard palette. Or there are a level vector and a color vector, but they are empty. - -test<-levCol(redonBDTgrouped,column="grouped",levels="",colors="") -expect_equal(grep("1:",test$case),1) - - -test<-levCol(sf=redonBDT, column="LCZ_PRIMARY") -expect_equal(grep("1:",test$case),1) - -# case 2: No levels but a color vector which size covers the number of levels in the data - -test<-levCol(sf=redonBDTgrouped,column="grouped", - colors=c("red","black","green","grey","burlywood","blue")) -expect_equal(grep("2:",test$case),1) - -# case 3: No levels but a color vector which size does not cover the number of levels in the data, -# colors will be picked from a standard palette.. - -test<-levCol(sf=redonBDTgrouped,column="grouped", - colors=c("red","black","green","grey","burlywood")) -expect_equal(grep("3:",test$case),1) - -test<-test<-levCol(sf=redonBDTgrouped,column="grouped", - colors=c("red","black","green","grey","burlywood","blue","purple")) - - - - - - -# case 4: A single vector was provided, whose names cover the levels in the data -# and whose values are colors. -test<-levCol(redonBDTgrouped, column="grouped", levels=c("urban"="red","industry"="black", - "vegetation"="green", - "impervious"="grey", - "pervious"="burlywood","water"="blue")) -expect_equal(grep("4:",test$case),1) - -# case 5: A single vector was provided, whose values are colors -# but whose names don't cover the levels in the data. -# Specified colors will be associated to levels deduced from the data, -# in order of appearence. -test<-levCol(redonBDTgrouped, column="grouped", drop=TRUE, levels=c("urban"="red","industry"="black", - "vegetation"="green", - "impervious"="grey", - "not in data"="white", - "pervious"="burlywood","water"="blue")) -expect_equal(grep("5:",test$case),1) - -# case 6: A single vector was provided, whose values are colors -# but whose names don't cover the levels in the data. -# Colors will be associated to unique values of the data -# and missing colors will be added from a standard palette. -test<-levCol(redonBDTgrouped, column="grouped", levels=c("urban"="red","industry"="black", - "vegetation"="green", - "pervious"="burlywood","water"="blue")) -expect_equal(grep("6:",test$case),1) - -# case 7: No color vector but a level vector whose names cover the levels in the data -test<-levCol(redonBDTgrouped, column="grouped", - levels=c("urban","industry","vegetation","impervious","pervious","water")) -expect_equal(grep("7:",test$case),1) - -# case 8: No color vector but a level vector whose names don't cover the levels in the data -# Levels will be deduced from data and colors will be chosen from a standard palette. -test<-levCol(redonBDTgrouped, column="grouped", - levels=c("urban","industry","John Scofield","impervious","pervious","water")) -expect_equal(grep("8:",test$case),1) - -test<-levCol(redonBDTgrouped, column="grouped", - levels=c("industry","John Scofield","impervious","pervious","water")) -expect_equal(grep("8:",test$case),1) - -test<-levCol(redonBDTgrouped, column="grouped", drop=TRUE, - levels=c("industry","John Scofield","impervious","pervious","water")) -expect_equal(grep("8:",test$case),1) - - -# case 9: Levels specified in one vector, whose values cover the levels in the data, -# colors in another vector, these vectors having the same length -test<-levCol(redonBDTgrouped, column="grouped", - levels=c("urban","industry","vegetation","impervious","pervious","water"), - colors=c("red","black","green","grey","burlywood","blue")) - -expect_equal(grep("9:",test$case),1) - -# case 10: Levels specified in one vector, whose values cover the levels in the data, -# colors in another vector, these vectors having the same length -# BUT some of the color names are not recognized as a color -# and will be replaced from a standard palette - -test<-levCol(redonBDTgrouped, column="grouped", - levels=c("urban","industry","vegetation","impervious","pervious","water"), - colors=c("red","black","green","grey","chaussures","blue")) - -expect_equal(grep("10:",test$case),1) - -# case 11: One vector seems to be a vector of levels, -# which covers the values of the data, -# the other a vector of colors, whose length is shorter than the specified levels. -# Missing colors will be picked from a standard palette. - -test<-levCol(redonBDTgrouped, column="grouped", - levels=c("urban","industry","vegetation","impervious","pervious","water"), - colors=c("red", "black", "green", "grey", "blue")) - - -expect_equal(grep("11:",test$case),1) - -# case 12: One vector seems to be a vector of levels, -# which covers the values of the data, -# the other a vector of colors, whose length is longer than the specified levels. -# The supplemental colors will be dropped. - -test<-levCol(redonBDTgrouped, column="grouped", - levels=c("urban","industry","vegetation","impervious","pervious","water"), - colors=c("red","black","green","grey","burlywood","blue","purple")) - -expect_equal(grep("12:",test$case),1) - -# case 13: No color vector is specified, there seems to be two ambiguous level vectors, -# levels will be deduced from the data and colors chosen from a standard palette. -test<-levCol(redonBDTgrouped, column="grouped", - level1=c("urban","industry","vegetation"), - level2=c("impervious","pervious","water")) -expect_equal(grep("13:",test$case),1) - -# case 14.0:The level vector doesn't cover the levels in the data -# and the number of specified colors is zero or less than the number of levels present, -# levels will be deduced from the data and colors will be chosen from a standard palette. - -test<-levCol(redonBDTgrouped, column="grouped", - levels=c("urban","industry","vegetation","pervious","water"), - colors=c("red","black","green","grey","blue")) -expect_equal(grep("14.0:",test$case),1) - -# case 14: The specified levels don't cover the levels in the data -# and the number of specified colors is zero or less than the number of levels present, -# levels will be deduced from the data and colors will be chosen from a standard palette. - -test<-levCol(sf=redonBDTgrouped, column="grouped", - industry="10", - vegetation=c("101","102","103","104"), - impervious="105",pervious="106",water="107", - colors=c("red","black","green","grey","burlywood")) - - -expect_equal(grep("14:",test$case),1) - -# case 15: The specified levels don't cover the levels in the data -# but the number of the specified colors is greater or equal -# to the number of levels present in the data, -# they are matched in the order of appearence. - -test<-levCol(sf=redonBDTgrouped,column="grouped",urban=c("1","2","3","4","5","6","7","8","9"), - vegetation=c("101","102","103","104"), - impervious="105",pervious="106",water="107", - colors=c("red","black","green","grey","burlywood","blue","orange")) -expect_equal(grep("15:",test$case),1) - -# case 15.1 : The specified levels cover the levels in the data -# # but the number of the specified colors is greater than the number of levels present in the data, -# # they are matched in the order of appearence. - -test<-levCol(sf=redonBDTgrouped,column="grouped",urban=c("1","2","3","4","5","6","7","8","9"), - industry="10", - vegetation=c("101","102","103","104"), - impervious="105",pervious="106",water="107", - colors=c("red","black","green","grey","burlywood","blue","orange")) -expect_equal(grep("15.1:",test$case),1) - -# case 16: The specified levels cover the levels in the data -# and no colors were specified, colors will be chosen from a standard palette. -test<-levCol(sf=redonBDTgrouped,column="grouped",urban=c("1","2","3","4","5","6","7","8","9"), - industry="10", - vegetation=c("101","102","103","104"), - impervious="105",pervious="106",water="107", - ) -expect_equal(grep("16:",test$case),1) - -# case 17: Several arguments are specified, whose names cover -# the levels in the data and are associated with a vector of colors of the same size. -test<-levCol(sf=redonBDTgrouped,column="grouped",urban=c("1","2","3","4","5","6","7","8","9"), - industry="10", - vegetation=c("101","102","103","104"), - impervious="105",pervious="106",water="107", - colors=c("red","black","green","grey","burlywood","blue")) - - -expect_equal(grep("17:",test$case),1) - -# case 18 : Several arguments are specified, whose names cover -# the levels in the data but the associated vector of colors -# contains names which are not colors. -# These will be replaced by colors from a standard palette. - -test<-levCol(sf=redonBDTgrouped,column="grouped",urban=c("1","2","3","4","5","6","7","8","9"), - industry="10", - vegetation=c("101","102","103","104"), - impervious="105",pervious="106",water="107", - colors=c("red","black","green","grey","DJ Shadow","blue")) - - - -expect_equal(grep("18:",test$case),1) - -redonBDTgrouped<-groupLCZ(redonBDT,column="LCZ_PRIMARY",urban=c("1","2","3","4","5","6","7","8","9"), - industry="10", - vegetation=c("101","102","103","104"), - impervious="105",pervious="106",water="107",colors=c("red","black","green","grey","burlywood","blue")) - -# levCol(sf=redonBDTgrouped, -# column="grouped", -# LCZlevels=c("urban","industry","vegetation","impervious","pervious","water"),colors="") - - -rm(test) -rm(redonBDTgrouped) - -# levCol(sf=redonBDTgrouped,column="LCZ_PRIMARY",urban=c("1","2","3","4","5","6","7","8","9"), -# industry="10", -# vegetation=c("101","102","103","104"), -# impervious="105",pervious="106",water="107", -# colors=c("red","black","green","grey","chaussure","blue")) diff --git a/inst/tinytest/test_showLCZ.R b/inst/tinytest/test_showLCZ.R index 0a26767..0a6f4b2 100644 --- a/inst/tinytest/test_showLCZ.R +++ b/inst/tinytest/test_showLCZ.R @@ -15,13 +15,13 @@ testCol <- palette.colors(n=17, palette="Polychrome 36") # showLCZ(redonBDT, title="Zones climatiques locales à Redon",repr="alter", # useStandCol=FALSE, # colors = testCol ) -# -# showLCZ(sf=redonOSM, wf="OSM", column="LCZ_PRIMARY", title="test", repr="alter", colors=testCol, useStandCol=FALSE) -# -# -# showLCZ(redonBDT, title="Zones climatiques locales à Redon",repr="alter", -# useStandCol=TRUE, -# colors = testCol ) + +# showLCZ(sf=redonOSM, wf="OSM", column="LCZ_PRIMARY", title="test", repr="alter", colors=testCol, useStandCol=FALSE) +# # +# # +# showLCZ(redonBDT, title="Zones climatiques locales à Redon",repr="alter", +# useStandCol=TRUE, +# colors = testCol ) #levCol(sf=redonBDT, column="LCZ_PRIMARY",colors = testCol) redonBDTgrouped<-groupLCZ(redonBDT,column="LCZ_PRIMARY", urban=c("1","2","3","4","5","6","7","8","9"), @@ -45,9 +45,8 @@ expect_message( expect_message( showLCZ(redonBDTgrouped,column="grouped",repr="alter", LCZlevels=c("urban","industry","vegetation","impervious","pervious","water"), - colors=c("red","black","green","grey","blue"), - title="LCZ regroupées à Redon"), - "For a better rendition specify as many colors as levels." + colors=c("red","black","green","grey"), + title="LCZ regroupées à Redon"),"case 11:" ) @@ -67,9 +66,8 @@ expect_message( "6:" ) -expect_message( -showLCZ(redonBDTgrouped,column="grouped",repr="alter"), - "No level vector and no color vector" +expect_silent( +showLCZ(redonBDTgrouped,column="grouped",repr="alter") ) #levCol(redonBDTgrouped,column="grouped",levels=NULL,colors=NULL) @@ -78,4 +76,15 @@ expect_message( showLCZ(redonBDTgrouped,column="grouped",repr="alter", LCZlevels=c("urban","industry","vegetation","impervious","pervious","water")), "7: No color vector but a level vector whose names cover the levels in the data" -) \ No newline at end of file +) + + + +expect_message( +showLCZ(sf=redonBDTgrouped, column="LCZ_PRIMARY",repr="alter", + urban=c("1","2","3","4","5","6","7","8","9"), +industry="10", +vegetation=c("101","102","103","104"), +impervious="105",pervious="106",water="107", + colors=c("red","black","green","grey","burlywood","blue"),tryGroup = TRUE), +"the function groupLCZ will try to create ")