本シリーズでは、「心理学の尺度開発」に特化した、GUIベースの統計処理ソフトを作り上げることを目指しています。
今回はドラッグ＆ドロップ関連の作り込みが今後必要になることを踏まえて、一度小さなアプリを作っておきます。
DnDに利用するライブラリーは`draguraSelectR`を選びました。このあたりの理由以下のブログを参考にしてください。
プログラムの全体像
以下のプログラムを一度走らせてみてください。そうするとイメージがわくと思います。
library(dragulaSelectR)
library(dplyr)
library(shinyjs)
###############################
# operator opposite of %in%
###############################
'%!in%' = function(x,y)!('%in%'(x,y))
###############################
# create elements
###############################
createItem = function(ind, nums) {
tagList(
HTML("<style>
.draggray { color:#000; background: #f1f1f1; }
.draggray i { margin-left: 5px; width:100px; }
</style>"),
div(class = "draggray",
"Group # : ",
ind),
div("size :", nums)
)
}
dtGroupTablefunc = function(inFile, grpVar) {inFile %>% group_by_at(grpVar) %>% summarise_all(funs(n())) %>%
select(c(1:2)) %>% dplyr::arrange(.[[grpVar]]) %>% na.omit()
}
initCanList = function(inFile, grpVar) {
dtGroupTable = dtGroupTablefunc(inFile, grpVar)
unique_val = unique(dtGroupTable[[grpVar]])
x_tmp = list()
for (ii in 1:length(unique_val)) {
x_tmp[[ii]] = createItem(unique_val[ii], dtGroupTable[dtGroupTable[grpVar] == unique_val[ii],2])
names(x_tmp)[ii] = unique_val[ii]
}
return(x_tmp)
}
###############################
# ui
###############################
ui = fluidPage(
#####
# element size
#####
tags$head(
tags$style(HTML('
.ds-dragitem, .ds-dropoption {
position: relative;
border-style: solid;
border-color: lightgray;
border-width: thin;
margin: 4px;
padding: 2px 4px;
}
.ds-dropzone[data-direction="horizontal"] > .ds-dropoption, .ds-dropzone[data-direction="horizontal"] > .gu-transit {
vertical-align: middle;
display: inline-block;
text-align: !important left;
width: 100px !important;
height: 45px !important;
margin: 3px 0px 3px 4px;
padding: 0px;
border-color: lightgray;
border-width: thin;
}
'))
),
#####
# show display elements
#####
fluidRow(
uiOutput("initDrag"),
uiOutput("initDraw")
)
)
#####################
server = function(input, output, session) {
inFile = mtcars
#####
# Initialization of reactiveValues
#####
rvsTtl = reactiveValues()
rvsdropzone = reactiveValues()
counter = reactiveValues(countervalue = 0)
#####
# initialization of placeholder
#####
output$initDraw = renderUI({
column(10,
selectInput(inputId = "selGrp", "Select Group", choices = colnames(inFile)),
div(id="selectorPlaceholder")
)
})
output$initDrag = renderUI({
column(2,
actionButton("AddBtn", label = "ADD"),
actionButton("DelBtn", label = "DEL"),
h3("Dragzone"),
uiOutput("dragZoneUI")
)
})
#####
# select group
#####
observeEvent(input$selGrp, {
### initialization of parameters
if (counter$countervalue > 0) {
for (zz2 in 1:counter$countervalue) {
removeUI(selector = paste0('#dropzoneUI__',zz2))
rvsTtl$ttl[[zz2]] = 0
}
}
counter$countervalue = 0
delList = NULL
rvsdropzone$dropzone = NULL
x_tmp = as.list(NULL)
runjs('Shiny.onInputChange("dragZoneUI", null)')
})
#####
# add ui
#####
observeEvent(input$AddBtn, {
x_tmp = initCanList(inFile, input$selGrp)
counter$countervalue = counter$countervalue + 1
rvsdropzone$dropzone[[counter$countervalue]] = dropZoneInput(paste0("dropzone__",counter$countervalue),
choices = x_tmp, direction="horizontal", placeholder = "drop here")
rvsTtl$ttl[[counter$countervalue]] = 0
element =
div(id = paste0('dropzoneUI__',counter$countervalue),
tagList(h3(paste0("Dropzone", counter$countervalue)), textOutput(paste0("GroupTtl", counter$countervalue))),
rvsdropzone$dropzone[[counter$countervalue]]
)
insertUI(selector = "#selectorPlaceholder", ui = element, immediate = TRUE)
})
#####
# remove ui
#####
observeEvent(input$DelBtn, {
if(counter$countervalue > 0) {
removeUI(selector = paste0('#dropzoneUI__',counter$countervalue))
counter$countervalue <- counter$countervalue - 1
} else {
showModal(modalDialog(h4("You can not delete anymore."), size = "m", easyClose = TRUE))
}
})
#####
# update dragzone
#####
output$dragZoneUI = renderUI({
rvsdropzone$dropzone
x_tmp = as.list(NULL)
if (length(input$selGrp) == 0) {
x_tmp = initCanList(inFile, colnames(inFile[1]))
} else {
x_tmp = initCanList(inFile, input$selGrp)
}
delList = NULL
if (counter$countervalue > 0) {
for (zzz in 1:counter$countervalue) {
delList = c(delList, input[[paste0("dropzone__", zzz)]])
}
}
dragZone("dragzone_ind", choices = x_tmp[names(x_tmp) %!in% delList])
})
#####
# calc of group num
#####
observe( {
validate(need(counter$countervalue > 0, ""))
grpVar = input$selGrp
dtGroupTable = dtGroupTablefunc(inFile, grpVar)
for (zz2 in 1:counter$countervalue) {
rvsTtl$ttl[[zz2]] = colSums(dtGroupTable[dtGroupTable[[grpVar]] %in% c(input[[paste0("dropzone__",zz2)]]), 2])
output[[paste0("GroupTtl", counter$countervalue)]] = renderText({rvsTtl$ttl[[zz2]]})
}
})
}
shinyApp(ui = ui, server = server)
補足説明
少し長くなってますが概略を説明します。
dragulaSelectRではdragのdivとdropのdivをバインドする必要はなく、ドロップ側で受け入れることができる要素名をあらかじめ指定する形になります。なので、あらかじめドラッグ側とドロップ側に同じ要素を設定しておけば自由にやりとりが可能となります。
drag要素の設定
dragulaSelectRでは｀dragZone(“dragzone_id”, choices = colnames(mtcars))｀のようにドラッグの対象とする要素を設定するだけでmtcarsの列名がドラッグ要素として設定されます。詳細は以下を参照してください
drop側の設定
drop側は事前に受け取ることができる要素の候補を設定しておく必要があります。基本的な使い方はdrag側と同じでOKです。｀dropZoneInput(“dropzone_id”, choices = colnames(mtcars))｀と同じ要素を設定すればドラッグとドロップ側でmtcarsのカラム名をやりとりできます。
なお、dropZoneInputはいろいろなオプションがあります。
dropZoneInput(inputId, choices, presets = NULL, hidden = FALSE, placeholder = NULL, highlight = FALSE, multivalued = FALSE, selectable = FALSE, selectOnDrop = FALSE, togglevis = FALSE, togglelock = FALSE, removeOnSpill = TRUE, direction = "vertical", maxInput = Inf, replaceOnDrop = FALSE, flex = FALSE, server = NULL, ...)
drag側の要素をハンドリングする
ドラッグ側からドロップ側に要素を移したとき、ドラッグ側からその要素が消えてくれる挙動が望ましいかとおもいます。ところが、dragulaSelectRではドラッグ側とドロップ側をバインドしていないことからこれらの動きはせず、ドラッグしても要素が残り続けてしまいます。
そこで192行目以降でdragZoneの要素をリフレッシュする動きを取り込んでいます。具体的には194行目に｀rvsdropzone$dropzone｀のリアクティブ変数を置くことで、この値に変化があった時（すなわち、ドロップゾーンの変数に変化があった時）にドラッグゾーンの要素の中でドロップゾーンに移動した要素を除いてドラッグゾーンをリフレッシュする仕組みです。あたりは他にもっとエレガントなやり方があると思いますのでそれぞれのやり方で試してみてください。
グループを再編集する
このサンプルプログラムでは、一つのグループを複数のグループに分割するデモプログラムとなっています。変数を選択して、「ADD」ボタンを押すごとに箱が増えます。これらの箱に分類していくことで一つのグループを複数のグループに分割するイメージで作っています。
実際の場面を想定すると、年齢が記入されたカテゴリーを、7−12歳を「小学」、13−15歳を「中学」、16−18を「高校」、19歳以上を「大学」など複数のカテゴリーに分割してあらたなグループを作るような場面を想定しています。
156−195行目の処理がここに該当しており、「ADD」ボタンを押すとカテゴリーが一つ増えて、「DEL」ボタンを押すとカテゴリーが一つ減るギミックです。
また、217行目以降ではそれぞれのカテゴリーでのサンプル数の合計を計算して表示させるロジック部分となっています。
reactiveValues
このサンプルプログラムでは3つのリアクティブ変数を使っています。
rvsTtl = reactiveValues() rvsdropzone = reactiveValues() counter = reactiveValues(countervalue = 0)
リアクティブ変数の使い方がShinyで最ももずかしく、理解がしにくい部分かと感じています。想定していない動きをすることがよくあり、私は未だに十分に理解できているとはいえない状態ですが、とりあえず動いているといった形です。
リアクティブ変数については（もう少し理解を深めたら）また別の機会で取り上げたいと思います。
まとめ
シリーズで開発中の尺度開発ツールを作っている上で、グループを分割して新たなグループを作る仕組みをドラッグ＆ドロップで実現するための要素を作ってみました。ほかにもっと良いやり方や、場合によってはライブラリーがあるかもしれませんが、ご参考になれば幸いです。