-
Notifications
You must be signed in to change notification settings - Fork 5
Expand file tree
/
Copy pathserver.R
More file actions
268 lines (218 loc) · 9.9 KB
/
Copy pathserver.R
File metadata and controls
268 lines (218 loc) · 9.9 KB
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
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
##########################################################################################################
# THREADNET:SHINY SERVER
# This software may be used according to the terms provided in the
# GNU General Public License (GPL-3.0) https://opensource.org/licenses/GPL-3.0?
# Absolutely no warranty!
##########################################################################################################
server <- shinyServer(function(input, output, session) {
options(warn=-1)
options(shiny.maxRequestSize=30*1024^2)
# create reactive value to force execution of function that gets map names for menus
rv <-reactiveValues(newmap=0)
# get_CF returns the choice of contextual factors from the Data tab.
get_CF <<- reactive({ return( input$CFcolumnsID ) })
# get_POV returns the choice of POV from the POV tab
get_THREAD_CF <<- reactive({ return(input$THREAD_CF_ID) })
get_EVENT_CF <<- reactive({ return(input$EVENT_CF_ID) })
get_COMPARISON_CF <<- reactive({ return(setdiff(get_CF(), union(get_THREAD_CF(),get_EVENT_CF() ))) })
# time scale for use throughout the app
get_timeScale <<- reactive({ return(input$timeScaleID) })
# These sliders controls the zoom level for zooming in-out
# they are grouoped here because hopefully they can be replaced by a single function... except that reactive functions don't take parameters
get_Zoom_VIZ <<- reactive({ return( ifelse (zoom_upper_limit(get_event_mapping_threads(input$VisualizeEventMapInputID))==1 ,
"ZM_1", paste0("ZM_",input$VisualizeTabZoomID))) })
get_Zoom_COMP_A <<- reactive({ return( ifelse (zoom_upper_limit(get_event_mapping_threads(input$CompareMapInputID_A))==1 ,
"ZM_1", paste0("ZM_",input$CompareZoomID_A))) })
get_Zoom_COMP_B <<- reactive({ return( ifelse (zoom_upper_limit(get_event_mapping_threads(input$CompareMapInputID_B))==1 ,
"ZM_1", paste0("ZM_",input$CompareZoomID_B))) })
get_Zoom_DIA_COMP <<- reactive({ return( ifelse (zoom_upper_limit(get_event_mapping_threads(input$DiaCompareMapInputID))==1 ,
"ZM_1", paste0("ZM_",input$DiaCompareZoomID))) })
get_Zoom_MOVE <<- reactive({ return( ifelse (zoom_upper_limit(get_event_mapping_threads(input$MovingWindowMapInputID))==1 ,
"ZM_1", paste0("ZM_",input$MovingWindowZoomID))) })
get_Zoom_REGEX <<- reactive({ return( ifelse (zoom_upper_limit(get_event_mapping_threads(input$RegExInputMapID))==1 ,
"ZM_1", paste0("ZM_",input$regexZoomID))) })
get_Zoom_freqNgram <<- reactive({ return( ifelse (zoom_upper_limit(get_event_mapping_threads(input$freqNgramInputMapID))==1 ,
"ZM_1", paste0("ZM_",input$freqNgramZoomID))) })
get_Zoom_CHUNK <<- reactive({ return( ifelse (zoom_upper_limit(get_event_mapping_threads(input$ChunkInputMapID))==1 ,
"ZM_1", paste0("ZM_",input$chunkZoomID))) })
# add reactive value to force update
get_event_mapping_names <- reactive({
rv$newmap
get_event_mapping_name_list()
})
#dataframe for occurrences that are read in from file1
occ <- eventReactive(input$file1,read_occurrences(input$file1))
# selected columns from the raw data
selectOcc <- reactive(occ()[c("tStamp", input$CFcolumnsID)] )
# select rows using the nice DT input
selectOccFilter <- reactive(selectOcc()[input$Data_Tab_Output_2_rows_all,])
# The POV tabs reconstruct the data into threads by sorting by tStamp and
# adding columns for threadNum and seqNum for the selected POV in ThreadOccByPOV
threadedOcc <- reactive({ ThreadOccByPOV( selectOccFilter(), input$THREAD_CF_ID, input$EVENT_CF_ID ) })
# get the data that will be the input for this tab
chunkInputEvents <- reactive({
rv$newmap
get_event_mapping_threads(input$ChunkInputMapID)
})
# this function runs when you push the button to create a new mapping based on chunks
observeEvent( input$EventButton2,{
rv$newmap <- rv$newmap+1 # trigger reactive value
isolate(
OccToEvents_By_Chunk(
chunkInputEvents(),
input$Chunks_method_Button, # which method?
input$EventMapName2,
input$fixed_chunk_size,
input$chunk_time_gap_threshold,
'mins',
input$chunk_CFs,
get_EVENT_CF(),
get_COMPARISON_CF()
)
)
}, ignoreInit = TRUE )
# get the data that will be the input for this tab
regexInputEvents <- reactive(get_event_mapping_threads(input$RegExInputMapID))
# get the input values and return data frame with regex & label
regexInput <- reactive({
data.frame(
pattern <- unlist(lapply(1:input$numRegexInputRows,function(i){input[[paste0('regex', i)]]})),
label <- unlist(lapply(1:input$numRegexInputRows,function(i){input[[paste0('regexLabel', i)]]})),
stringsAsFactors = FALSE
)
})
# this function runs when you push the button to create a new mapping
observeEvent(input$EventButton3,{
rv$newmap <- rv$newmap+1 # trigger reactive value
isolate(
OccToEvents3(
regexInputEvents(),
input$EventMapName3,
get_EVENT_CF(),
get_COMPARISON_CF(),
'threadNum',
get_Zoom_REGEX(),
regexInput(),
input$KeepIrregularEvents
)
)
}, ignoreInit = TRUE )
# get the data that will be the input for this tab
freqNgramInputEvents <- reactive(get_event_mapping_threads( input$freqNgramInputMapID))
fng_select <- reactive(
support_level(
thread_text_vector(
freqNgramInputEvents(),
'threadNum',
get_Zoom_freqNgram(),
' '
),
frequent_ngrams(
freqNgramInputEvents() ,
'threadNum',
get_Zoom_freqNgram(),
input$freqNgramRange[1],
input$freqNgramRange[2],
TRUE
)
)
)
# The bottom example shows a server-side table. Make sure you have included row names in the table (as the first column of the table).
# In the case of server-side processing, the row names of the selected rows are available in input$x3_rows_selected as a character vector.
selected_ngrams <- reactive({
s <- as.integer(input$freqnGramTable_rows_selected)
data.frame(
pattern <- unlist(lapply(1:length(s),function(i){ str_replace_all(fng_select()[i,'ngrams'],' ',',') })),
label <- unlist(lapply(1:length(s),function(i){paste0("<",str_replace_all(fng_select()[i,'ngrams'],' ','_'),">")})),
stringsAsFactors=FALSE
)
})
# this function runs when you push the button to create a new mapping
observeEvent(input$EventButton4,{
rv$newmap <- rv$newmap+1 # trigger reactive value
isolate(
OccToEvents3(
freqNgramInputEvents(),
input$EventMapName4,
get_EVENT_CF(),
get_COMPARISON_CF(),
'threadNum',
get_Zoom_freqNgram(),
selected_ngrams(),
input$KeepIrregularEvents_2
)
)
}, ignoreInit = TRUE)
# separate the cluster calculation from the dendrogram display
cluster_result <- eventReactive(input$EventButton6,{
rv$newmap <- rv$newmap+1 # trigger reactive value
isolate(
clusterEvents(
get_event_mapping_threads(input$ClusterEventsInputID),
input$EventMapName6,
input$ClusterMethodID,
get_EVENT_CF(),
'cluster'
)
)
}, ignoreInit = TRUE )
# Get data for the Visualize tab.Need parallel functions for the other tabs.
subsetEventsViz <- reactive({get_event_mapping_threads( input$SelectSubsetMapInputID ) })
# reactive functions for the export and delete buttons
observeEvent(input$DeleteMappingButton,{
rv$newmap <- rv$newmap+1 # trigger reactive value
delete_event_mapping(input$ManageEventMapInputID)
output$delete_confirm <- renderText(paste(input$ManageEventMapInputID, " deleted."))
}, ignoreInit = TRUE)
observeEvent(input$ExportMappingRData,{
export_event_mapping(input$ManageEventMapInputID )
output$action_confirm <- renderText(paste(input$ManageEventMapInputID, " exported as .RData file"))
})
observeEvent(input$ExportMappingCsv,{
export_event_mapping_csv( input$ManageEventMapInputID )
output$action_confirm <- renderText(paste(input$ManageEventMapInputID, " exported as .csv file"))
})
observeEvent(input$SelectSubsetButton,{
rv$newmap <- rv$newmap+1 # trigger reactive value
store_event_mapping( input$SelectSubsetMapName, subsetEventsViz()[input$SelectSubsetDataTable_rows_all,] )
}, ignoreInit = TRUE)
# Get data for the Visualize tab.Need parallel functions for the other tabs.
# threadedEventsViz <- reactive({get_event_mapping_threads( input$VisualizeEventMapInputID ) })
# Get data for the Visualize tab. Need parallel functions for the other tabs.
threadedEventsViz_ALL <- reactive({ get_event_mapping_threads( input$VisualizeEventMapInputID ) })
threadedEventsViz <- reactive({
loc = input$VisualizeRangeID[1]
width=input$VisualizeRangeID[2] - input$VisualizeRangeID[1]
get_moving_window(threadedEventsViz_ALL(),width,loc) })
# Get data for the COMPARE tab mapping A
threadedEventsComp_A <- reactive({get_event_mapping_threads(input$CompareMapInputID_A ) })
# Get data for the COMPARE tab mapping B.
threadedEventsComp_B <- reactive({get_event_mapping_threads( input$CompareMapInputID_B ) })
# Get data for the Diachronic COMPARE tab.
threadedEventsDiaComp <- reactive({get_event_mapping_threads(input$DiaCompareMapInputID ) })
CF_levels <- reactive( get_CF_levels( threadedEventsDiaComp(),input$selectComparisonID) )
# Get data for the Moving Window tab.
threadedEventsMove <- reactive({get_event_mapping_threads(input$MovingWindowMapInputID )})
threadedEventsMove_A <- reactive({
get_moving_window(
threadedEventsMove() ,
input$MovingWindowSizeID,
input$WindowLocation_A_ID
)
})
threadedEventsMove_B <- reactive({
get_moving_window(
threadedEventsMove(),
input$MovingWindowSizeID,
input$WindowLocation_B_ID
)
})
# Source tab-specific Server output functions
source(file.path("server", "readData.R"), local = TRUE)$value
source(file.path("server", "choosePOV.R"), local = TRUE)$value
source(file.path("server", "comparisons.R"), local = TRUE)$value
source(file.path("server", "visualize.R"), local = TRUE)$value
source(file.path("server", "subsets.R"), local = TRUE)$value
source(file.path("server", "movingWindow.R"), local = TRUE)$value
source(file.path("server", "parameterSettings.R"), local = TRUE)$value
})