cnmap: What the Package Does (One Line, Title Case)

Documented in cnmap

#' To Plot China Map
#'
#' @param data dataframe
#' @param shapename one string, name of shapes in data
#' @param choice (optional) choice for shape names
#' @param heat.variable string, variable name for heat map
#' @param heat.color colors for heat map
#' @param bubble.size.variable string, variable name for bubble size map
#' @param bubble.color.variable string, variable name for bubble color map
#' @param bubble.color colors for bubble map
#' @param bubble.size size for all bubbles in bubble map
#' @param lgd.bubble.color.title title for legend bubble color map
#' @param lgd.bubble.size.title title for legend bubble size map
#' @param lgd.heat.title title for legend heat map
#' @param lgd.title.size size for legend title
#' @param lgd.text.size size for legend text
#' @param text.show logical. Whether to show map text
#' @param text.alpha map text alpha, default is 1
#' @param text.size map text size, default is 5
#' @param text.color map text color, default is black
#' @param border.color map border color, default is grey
#' @param border.size map border size, default is 0.5
#' @param segment.min.length see \code{\link[ggrepel]{geom_label_repel}}
#' @param family see \code{\link[stats]{family}}
#' @param face plain, bold or italic
#' @param force see \code{\link[ggrepel]{geom_label_repel}}
#'
#' @return a ggplot2 object
#' @export
#'
#' @examples
#' library(tmcn)
#'
#' pose=toUTF8(c('\u6B66\u6C49\u5E02','\u5B5D\u611F\u5E02'))
#' gdp=c(500,100)
#' data=data.frame(pose,gdp)
#'
#' cnmap(data = data,shapename = 'pose')
#'
#' cnmap(data = data,shapename = 'pose',
#'        heat.variable = 'gdp')
#' cnmap(data = data,shapename = 'pose',
#'       bubble.color.variable = 'gdp')
cnmap <- function(data,shapename,choice=NULL,
                  heat.variable=NULL,
                  heat.color=c('gray','red'),
                  bubble.size.variable=NULL,
                  bubble.color.variable=NULL,
                  bubble.color=c('#8f62ff','#0000ff'),
                  bubble.size=4,
                  lgd.bubble.color.title=NULL,
                  lgd.bubble.size.title=NULL,
                  lgd.heat.title=NULL,
                  lgd.title.size=13,
                  lgd.text.size=10,
                  text.show=TRUE,
                  text.alpha=1,
                  text.size=5,
                  text.color='black',
                  border.color='gray',
                  border.size=0.5,
                  segment.min.length=0,
                  family='sans',
                  face='plain',
                  force=0.5){
    if (is.null(lgd.heat.title)) lgd.heat.title=heat.variable
    if (is.null(lgd.bubble.color.title)) lgd.bubble.color.title=bubble.color.variable
    if (is.null(lgd.bubble.size.title)) lgd.bubble.size.title=bubble.size.variable
    bubble.shape=20
    #library(ggplot2)
    #library(do)
    #library(ggrepel)
    if (any(duplicated(as.character(data[,shapename])))) stop(tmcn::toUTF8('\u5730\u5740\u540D\u6709\u91CD\u590D'))
    name=as.character(data[,shapename])
    check= name%==% map.data$Name
    CHECK=FALSE
    if (length(check)==0){
        model.check=1
        CHECK=TRUE
    }else{
        model.check=2
        if (any(check=='integer(0)')) CHECK=TRUE
    }
    if (CHECK) {
        #library(crayon)
        if (model.check==1){
            unpaired=name
        }else{
            unpaired = names(check)[check=='integer(0)']
        }
        cat(tmcn::toUTF8('\n\u5B58\u5728'),length(unpaired),tmcn::toUTF8('\u4E2A'),red$bold(tmcn::toUTF8('\u672A\u80FD\u5339\u914D')),tmcn::toUTF8('\u7684\u5730\u533A\u540D\u79F0\n'))
        cat(tmcn::toUTF8('\u4ED6\u4EEC\u662F\n'))
        cat(paste0(unpaired,collapse = ', '))
        cat(red(tmcn::toUTF8('\n\n\u8F93\u51651\u4E2A\u6570\u5B57\u9009\u62E9\u4ED6\u4EEC\u5BF9\u5E94\u7684\u5730\u5740\n')))
        for (i in 1:length(unpaired)) {
            cat(red$bold(unpaired[i]),'\n')
            unp.i=unlist(strsplit(unpaired[i],''))
            unp.i
            for (j in 1:length(unp.i)) {
                if (j==1) res.tump=NULL
                res.tump=c(res.tump,unique(map.data$Name[grepl(unp.i[j],map.data$Name)]))
            }
            res.table=table(res.tump)
            res.t2=res.table[order(res.table,decreasing = TRUE)]
            res.names=names(res.t2)[res.t2>=2]
            for (j in 1:length(res.names)) {
                if (j==1) res.similar=NULL
                rev.res=unlist(strsplit(res.names[j],''))
                res.similar=c(res.similar,sum(unlist(lapply(rev.res %==% unp.i,length)))/length(rev.res))
            }
            res.similar
            names(res.similar)=res.names
            names.choice=names(res.similar)[order(res.similar,decreasing = TRUE)]
            j=1
            for (j in 1:length(names.choice)) {
                cat(paste0(red(j),': ',names.choice[j],'\n'))
            }
            cat(paste0(red(j+1),': ',tmcn::toUTF8('\u4E0D\u7EE7\u7EED\u4E86'),'\n'))
            if (!is.null(choice)){
                n=choice[i]
                cat(n,'\n')
            }else{
                if (i==1) n.all=NULL
                n=readline()
                while(n > (j+1)){
                    cat(tmcn::toUTF8('\u8F93\u5165\u8303\u56F4\u5FC5\u987B\u662F1~'),j+1,tmcn::toUTF8(',\u4F60\u8F93\u51FA\u8D85\u51FA\u8303\u56F4,\u8BF7\u91CD\u65B0\u8F93\u5165'))
                    n=readline()
                }
                if (n==(j+1)) return()
                n.all=c(n.all,n)
            }
            name[unpaired[i] %==% name]=names.choice[as.numeric(n)]
            cat('\n\n')
        }
        data[,shapename]=name
        cat('\n')
        cat(tmcn::toUTF8('\u6700\u7EC8\u7684'),length(name),tmcn::toUTF8('\u4E2A\u5730\u533A\u540D\u79F0\u662F:\n'))
        cat(name)
        cat('\n\n')
        if (is.null(choice)){
            cat(tmcn::toUTF8('\u53EF\u4EE5\u5411\u547D\u4EE4\u4E2D\u6DFB\u52A0choice\u53C2\u6570,\u6765\u907F\u514D\u6BCF\u6B21\u9009\u62E9\n'))
            cat(paste0(', choice = c(',paste0(n.all,collapse = ','),')'))
        }
    }
    #check again and plot
    check=as.character(name) %==% map.data$Name
    CHECK=FALSE
    if (length(check)==0){
        model.check=1
        CHECK=TRUE
    }else{
        model.check=2
        if (any(check=='integer(0)')) CHECK=TRUE
    }
#######big judge
    if (CHECK) {
        #library(crayon)
        cat(tmcn::toUTF8('\n\u4ECD\u5B58\u5728'),
            red$bold(tmcn::toUTF8('\u672A\u80FD\u5339\u914D')),
            tmcn::toUTF8('\u7684\u5730\u533A\u540D\u79F0\n'))
        cat(tmcn::toUTF8('\u4ED6\u4EEC\u662F\n'))
        if (model.check==1){
            unpaired=name
        }else{
            unpaired = names(check)[check=='integer(0)']
        }
        cat(paste0(unpaired,collapse = ', '))
    }else{
        loc=unlist(name %==% map.data$Name)
        map.ready0=map.data[loc,]
        map.ready0=unique(map.ready0)
        ######################check dup in quxian
        if (any(table(map.ready0$Name)>1)){
            #whether in the same city
            left.5=left(map.ready0$Code,5)
            delet.5=names(table(left.5))[table(left.5) ==1]
            map.ready0=map.ready0[-unlist(delet.5 %==% left(map.ready0$Code,5)),]
        }
        map.ready0
        map.ready=NULL

######           plot start      ##########
################empty
        check.p=NULL
        if (is.null(heat.variable) &
            is.null(bubble.color.variable) &
            is.null(bubble.size.variable)){
            p<-ggplot(data = map.ready0) +
                geom_sf(color=border.color,size=border.size) +
                theme_bw()
        }
#######################heat
        if (!is.null(heat.variable)){
            check.p=1
            dd.value=data[,c(shapename,heat.variable)]
            map.ready=merge(x = map.ready0,y = dd.value,
                            by.x='Name',
                            by.y=shapename)
            display=data.frame(map.ready,check.names = FALSE)[,heat.variable]
            map.ready
            #plot with value
            p<-ggplot(data = map.ready, aes(fill=display)) +
                geom_sf(color=border.color,size=border.size) +
                theme_bw()
            if (is.factor(display)){
                p <- p + scale_fill_manual(name=lgd.heat.title,
                                           values = colorRampPalette(heat.color)(length(unique(dd.value[,heat.variable]))))
            }else{
                p <- p + scale_fill_gradientn(name=lgd.heat.title,
                                              colours=heat.color)
            }
        }
###################bubble
        if (!is.null(bubble.color.variable) |
            !is.null(bubble.size.variable) ){
            variable=shapename
            if (!is.null(bubble.color.variable)) variable=c(variable,bubble.color.variable)
            if (!is.null(bubble.size.variable)) variable=c(variable,bubble.size.variable)
            variable=unique(variable)
            dd.value=data[,variable]
            dd.value
            map.ready=merge(x = map.ready0,y = dd.value,by.x='Name',by.y=shapename)
            map.ready
            #if no p, we plot base
            if (is.null(check.p)){
                p<-ggplot(data = map.ready) +
                    geom_sf(color=border.color,size=border.size) +
                    theme_bw()
            }
            c.color=is.null(bubble.color.variable)
            c.size=is.null(bubble.size.variable)
            if (c.color & c.size){
###empyt
                p <- p+geom_sf_point(color=bubble.color[1],
                                     size=bubble.size,
                                     shape = bubble.shape)
            }else if(!c.color & c.size){
###only color
                display=data.frame(map.ready,check.names = FALSE)[,bubble.color.variable]
                p<-p+geom_sf_point(aes(color=display),
                                   size=bubble.size,
                                   fill=NA,
                                   shape = bubble.shape)
                if (is.numeric(display)){
                    p<-p+
                        #scale_fill_gradientn(name=lgd.bubble.color.title,colours = bubble.color)+
                        scale_color_gradientn(name=lgd.bubble.color.title,colours = bubble.color)
                }else{
                    p<-p +
                        #scale_fill_manual(name=lgd.bubble.color.title,values = bubble.color)+
                        scale_color_manual(name=lgd.bubble.color.title,values = bubble.color)
                }
            }else if(c.color & !c.size){
#####only size
                display=data.frame(map.ready,check.names = FALSE)[,bubble.size.variable]
                p<-p+geom_sf_point(aes(size=display),
                                   color=bubble.color[1],
                                   fill=NA,
                                   shape = bubble.shape)
                if (is.numeric(display)){
                    p<-p+ scale_size(name=lgd.bubble.size.title)
                }else{
                    p<-p+ scale_size_discrete(name=lgd.bubble.size.title)
                }
            }else if(!c.color & !c.size){
########color and size
                display1=data.frame(map.ready,check.names = FALSE)[,bubble.color.variable]
                display2=data.frame(map.ready,check.names = FALSE)[,bubble.size.variable]
                p<-p+geom_sf_point(aes(color=display1,
                                       size=display2),
                                   fill=NA,
                                   shape=bubble.shape)
                if (is.numeric(display1)){
                    p<-p+ scale_color_gradientn(name=lgd.bubble.color.title,colours = bubble.color)
                }else{
                    p<-p+ scale_color_manual(name=lgd.bubble.color.title,values = bubble.color)
                }
                if (is.numeric(display2)){
                    p<-p+ scale_size(name=lgd.bubble.size.title)
                }else{
                    p<-p+ scale_size_discrete(name=lgd.bubble.size.title)
                }
            }
        }
##################text
        if (text.show){
            if (is.null(map.ready)) text.data=map.ready0
            if (!is.null(map.ready)) text.data=map.ready
            p<-p+geom_text_repel(
                data = text.data,force = force,
                aes(label = Name, geometry = geometry),
                stat = "sf_coordinates",
                min.segment.length = segment.min.length,
                family=family,fontface=face,
                alpha=text.alpha,
                size=text.size,
                color=text.color
            )
        }
        p<-p +
            theme(axis.title  = element_blank())+
            theme(legend.title = element_text(size = lgd.title.size,family = family),
                  legend.text = element_text(size=lgd.text.size,family = family))
        return(p)
    }
}