开发基于GUI的R包（1）

点击蓝字关注这个神奇的公众号～

作者： 徐静 硕士研究生、算法工程师 兴趣方向：统计机器学习，深度学习，模型的线上化部署、网络爬虫，前端可视化。

个人博客：<https://dataxujing.github.io/>

前期基于shiny, R markdown等R生态系统写过一些动态或静态web端的应用并部署到服务器，感觉R很好玩。以前也基于Python的PyQt5开发过一些桌面GUI程序。除了基于web端的R语言的应用，是不是万能的R也可以写一些GUI程序呢？用过rattle包(一个基于GUI的数据挖掘图形化工具包)的小伙伴们都知道答案是肯定的。本文带各位看官梳理一下基于GUI的R包开发并把R包托管CRAN。

 1.GUI简介

图形用户界面（Graphical User Interface，简称 GUI，又称图形用户接口）是指采用图形方式显示的计算机操作用户界面。我们知道shiny是可以开发一些低并发量轻量级的Web应用,作为系统开发的原型Demo和动态交互数据分析报告的展示部署还是很不错的。相比Web开发，GUI可能在近几年要低调了一些。常见的GUI框架有：wxWidgets,WTL,DirectUI Duilib,QT,GTK(GIMP Toolkit),kGUI,MFC/ATL等等。R中我们主要尝试使用gWidgets和gWidgets两个集成R包完成R的GUI界面构建，其中gWidgets2是对gWidgets的重写（着重介绍gWidgets2)，该包本身建立了一个API来描述GUI接口，其附带的包将其自身集成到底层的工具包中，目前有：

1. gWidgets2RGtk2:通过RGTK2包与GTK的小部件集接口。

2. gWidgets2tcltk:通过TCLK包与TCL/TK小部件接口。

3. gWidgets2Qt:通过qtbase与控件的QT集接口。

4. 对于web编程，包gWidgetsWWW2 和 gWidgetsWWW2.rapache 基本上使用ExtJS JavaScript库实现相同的API。

废话少说，让各位看官看一看R实现一个简单的带有GUI界面的程序。

2.R语言写一个带GUI的程序

想要了解更多的关于R实现GUI应用可以参考gWidgets和gWidgets2的详细的说明文档，为了让大家看明白我会对下面的每一行代码进行注释。OK,各位看官请后退，我要贴代码了:

```R

#加载必要的R包

library(tidyverse)

library(stringr)

library(readr)

library(readxl)

library(writexl)

library(gWidgets)

library(gWidgets2)

library(gWidgetsRGtk2)

Ricetl <- function(){

  ##声明两个全局变量

  all_data = data_source_id = NULL

  ##忽略警告

  options(warn=-1)

  ##通过RGTK2包与GTK的小部件集接口

  options(guiToolkit="RGtk2")

  ##生成main window

  win <- gwindow('R for Data Extraction of Resident Identity Card (PRC)--[Ricetl]',visible=FALSE)

  ##生成toolbar

  ##生成Open这个toolbar

  my_Open <-  gaction(label="Open", icon="open",handler=function(h,...){  

    #下面的15行代码实现了handler函数用来打开需要导入GUI的数据（支持.csv和.xlsx后缀的文件)

    my_path = choose.files(caption = "Choose One File(.csv or xlsx) to -Ricetl-package")

    if(length(my_path)==0)

      galert('Please Select the Files to be Processed(A data file with a suffix of .csv or .xlsx)',title = "File Selection Problems",delay = 6)

    else{

      galert('The file you choose should be a data file with a suffix of .csv or .xlsx',title = "Tips",delay = 6)

      if(grepl("\\.csv$", my_path))

        data_source_id <- readr::read_csv(my_path)

      else{

        if(grepl("\\.xlsx$", my_path))

          data_source_id <- readxl::read_excel(my_path)

        else

          galert('Please Choose the Correct File Format (.csv or .xlsx)!',title = "File Selection Problems",delay = 6)

      }

    }

    data_source_id <<- data_source_id

  })

  ##生成Save这个Toolbar

  my_save <- gaction(label='Save',icon='save',handler=function(h,...){

    ##下面的12行代码实现了数据输出保存的handler函数，数可以保存成.csv格式

    my_path_save = choose.dir(caption = "Choose the Save Dir -Ricetl-package")

    if(!is.data.frame(all_data))

      galert('There is no output for the time, please execute the data you want to handle!',title = "File Save Failure",delay = 6)

    else{

      if(is.na(my_path_save))

        galert('Cancel the preservation!',title = "File Save Failure",delay = 6)

      else{

        readr::write_csv(all_data,path=paste0(my_path_save,'\\data_result.csv'))

        galert(paste0('The results are preserved in: ',my_path_save,'\\data_result.csv'),title = "File Save Success",delay = 6)

      }

    }

  })

  

  ##生成CloseToolbar

  my_close <- gaction(label='Close',icon='close',handler=function(h,...){

    ##执行关闭handler函数，离开主窗口

    dispose(win)

  })

  

  ##生成about Toolbar

  my_about_content <- "Ricetl package is a function set with Gui to extract data from the identity card number of People's Republic of China residents, looking forward to the experience."

  my_about <- gaction(label='About',icon='about',handler=function(h,...){

    ##执行该handler函数，弹出信息弹窗，内容就是my_about_content

    gmessage(my_about_content,title = "About Ricetl",parent=win)

  })

  ##在主窗口把上面定义好的事件画在主窗口上

  my_list <- list(

    open = my_Open,

    sep = list(separator = TRUE),

    save = my_save,

    sep = list(separator = TRUE),

    close = my_close,

    sep = list(separator = TRUE),

    about = my_about,

    sep = list(separator = TRUE))

  gtb <- gWidgets::gtoolbar(toolbarlist = my_list,container = win)

  ##gframe

  gf <- gframe(horizontal=FALSE, container=win)

  ## select contant 创建一个group

  bg_gl <- ggroup(container = gf)

  ### select year 一个输入框

  gl_year <- glabel("Year:", container=bg_gl)

  year_value <- gedit(text = "2018", width = 4,  container = bg_gl)

  gseparator(horizontal = FALSE,container = bg_gl)

  ### select mising type 一个筛选框

  gl_miss <- glabel("Missing:", container=bg_gl)

  miss_value <- gWidgets::gdroplist(items=c('NA','Mean'), selected = 1, editable = TRUE,container = bg_gl)

  gseparator(horizontal = FALSE,container = bg_gl)

  ### run my data 一个Button

  gbutton("execute", container=bg_gl, handler = function(h,...) {

    ##handler函数体

    #age

    if(svalue(miss_value)=='NA')

      my_age <- as.numeric(svalue(year_value)) - as.numeric(stringr::str_sub(as.vector(data.frame(data_source_id)[,1]),7L,10L))

    else{

      if(svalue(miss_value)=='Mean'){

        my_age_f <- as.numeric(svalue(year_value)) - as.numeric(stringr::str_sub(as.vector(data.frame(data_source_id)[,1]),7L,10L))

        my_age <- ifelse(!is.na(my_age_f),my_age_f,mean(my_age_f,na.rm = TRUE))

      }

      else{

        my_age_f <- as.numeric(svalue(year_value)) - as.numeric(stringr::str_sub(as.vector(data.frame(data_source_id)[,1]),7L,10L))

        my_age <- ifelse(!is.na(my_age_f),my_age_f,svalue(miss_value))

      }

    }

    #gender

    if(svalue(miss_value)=='NA')

      my_sex <- as.numeric(stringr::str_sub(as.vector(data.frame(data_source_id)[,1]),17L,17L)) %% 2

    else{

      my_sex <- as.numeric(stringr::str_sub(as.vector(data.frame(data_source_id)[,1]),17L,17L)) %% 2

      galert('This option is only meaningful for filling the missing values of the age!',title = "WARN-[Ricetl]",delay = 6)

    }

    #address

    my_addr <- as.numeric(stringr::str_sub(as.vector(data.frame(data_source_id)[,1]),1L,6L))

    my_addr_2 <- sapply(my_addr,address_code)

    #Verify Result

    vrs <- lapply(as.vector(data_source_id),str_ext)

    my_vrs <- unlist(plyr::llply(vrs[[1]],VeRe))

    all_data <<- data.frame('ID_no'=data_source_id,'Address'=my_addr_2,

                            'Age'=my_age,'Gender'=my_sex,'Checkout'=my_vrs)

    my_df <- gdf(all_data, container=gf, do.subset=TRUE)

  })

  ##创建几个分割线

  gseparator(horizontal = FALSE,container = bg_gl)

  gseparator(horizontal = TRUE,container = gf)

  gseparator(horizontal = TRUE,container = gf)

  ##创建几个分割线

  bg_note <- ggroup(container = gf)

  gseparator(horizontal = TRUE,container = gf)

  gseparator(horizontal = TRUE,container = gf)

  

  ##创建个label控件

  gl_note <- glabel("The output of the ID card number is listed as the identity card number corresponding

to the household registration address,the corresponding age of the residents,

the corresponding sex of the residents (1: male, 0: female) and the check code,

so we can choose the year to calculate the age of residents and the missing data,

which is worth filling. And the file you open should be a data file with a suffix

of .csv or .xlsx,and the data file contains only one column, which is the identity

card number of the People's Republic of China resident",container=bg_note)

  ##设定主窗口的大小

  size(win) <- c(600, 400)

  ##主窗口可见

  visible(win) <- TRUE

}

```

这里调用了一些我自己创建的其他方法，如果想正常运行可以再CRAN上下载安装R包Ricetl(上述代码是我写的Ricetl包的一部分)

```R

install.packages('Ricetl')

library(Ricetl)

devtools::vignette('Ricetl-doc')

Ricetl()

```

运行后效果如下：

注：后期持续更新如何把自己写的R代码封装成R包并托管到Github及CRAN。

大家都在看

2017年R语言发展报告（国内）

R语言中文社区历史文章整理（作者篇）

R语言中文社区历史文章整理（类型篇）

公众号后台回复关键字即可学习

回复 R                  R语言快速入门及数据挖掘 
回复 Kaggle案例  Kaggle十大案例精讲（连载中）
回复 文本挖掘      手把手教你做文本挖掘
回复 可视化          R语言可视化在商务场景中的应用 
回复 大数据         大数据系列免费视频教程 
回复 量化投资      张丹教你如何用R语言量化投资 
回复 用户画像      京东大数据，揭秘用户画像
回复 数据挖掘     常用数据挖掘算法原理解释与应用
回复 机器学习     人工智能系列之机器学习与实践
回复 爬虫            R语言爬虫实战案例分享