##########################################################################################################

# THREADNET Misc functions

# 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!

##########################################################################################################

#' @title make_example_DF

#' @description Make an example data frame for display...

#' @name make_example_DF

#' @return DF with some data

#' @export

make_example_DF = function(){

correct_occ = read.table(text="tStamp actor action object location

'2017-4-7 17:52:04' jimmy tosses ball playground

'2017-4-7 17:52:12' rover fetches ball playground

'2017-5-18 9:05:52' jimmy tosses ball forest

'2017-5-18 9:06:24' rover fetches stick forest

'2017-5-18 9:10:48' jimmy searches ball forest ", header=TRUE)

}

#' @title numThreads counts how many threads in the data set

#' @description Threads must have unique thred numbers for this function to work

#' @name numThreads

#' @param o data frame with occurrences or events

#' @param TN column with thread number

#' @return number of threads

#' @export

numThreads = function(o,TN) {length(unique(o[[TN]]))}

# Time range for the data set (not really needed but nice)

timeRange= function(o){

# get the min/max time in the whole set of occurrences

start = min(as.POSIXlt.date(o$tStamp))

finish = max(as.POSIXlt.date(o$tStamp))

# take the difference

difftime(finish,start)}

# Put it into a nice phrase

timeRangePhrase = function(tr){

rangeunits = attr(tr,"units")

paste(floor(as.numeric(tr)),rangeunits,"from start to finish.")}

# this function is used to split up the threads into n ~equal buckets

#' @title make_subsets

#' @description this function is used to split up the threads into n ~equal buckets

#' @name make_subsets

#' @param d data frame with occurrences or events

#' @param n number of buckets

#' @return list of smaller data frames

#' @export

make_subsets <- function(d,n){

return(split(d, ceiling(seq_along(d)/(length(d)/n))))

}

#' @title zoomColumn

#' @description This function takes a slider value and returns a valid column name for zooming

#' if the argument is null, then use ZM_1

#' @name zoomColumn

#' @param z integer for the zoom level

#' @return column name for that zoom level ('ZM_n)

#' @export

zoomColumn <- function(z){

# print(paste("In zoomColumn z=",z))

if (is.null(z))

{r="ZM_1"}

else

{r=paste0("ZM_",z)}

# print(paste("In zoomColumn r=",r))

return(r)

}

######### Functions that return column names #######

#' @title cfnames provides names of all the contextual factors (except the time stamp)

#' @description grab all of the columns except the first, which has the time stamp

#' tStamp in the first colummn

#' @name cfnames

#' @param o data frame with threads

#' @return list of column names

#' @export

cfnames <- function(o){

colnames(o)[2:length(colnames(o))]}

#' @title get_CF_levels returns the levels of a contextual factor

#' @description this is used to populate the UI for comparison of categories within a CF

#' @name get_CF_levels

#' @param o data frame with threads

#' @param cf a contextual factors (column)

#' @return list of unique factor levels

#' @export

get_CF_levels <- function(o,cf){

return(levels(o[,cf]))

}

##########################################################################################################

#' @title combineContextFactors creates a new column that combines some set of other columns

#' @description this function adds a new column to the occurrenes table based on a combination of context factors CF). For example, actor+action

#' @name combineContextFactors

#' @param o data frame with threads

#' @param CF contextual factors to be combined.

#' @param newCol name of the new combined conextual factor

#' @return data frame with the new column

#' @export

combineContextFactors <- function(o,CF,newCol){

# Use the old column if there is one

if (!(newCol %in% names(o))) {

# Need to get the CF parameters into the right format for tidyr::unite function

cfn= sapply(CF, as.character)

newCol = as.character(newCol)

# unite the columns, but keep the old ones

o= unite_(o, newCol, cfn, sep="+", remove=FALSE)

}

# Coerce the new column into a factor

o[newCol] = as.factor(o[,newCol])

return(o)

}

#' @title newColName

#' @description returns new combined column name from a list of CFs

#' @name newColName

#' @param CF_list list of context factors to define events

#' @return column name

#' @export

newColName <- function(CF_list){

return(paste0(CF_list,collapse="_")) }

# These were used on the occ-to-event tab to configure the slider

#' @title threshold_slider_min

#' @description These were used on the occ-to-event tab to configure the slider

#' @name threshold_slider_min

#' @param o dataframe of occurrences

#' @return slider min

#' @export

threshold_slider_min <- function(o){

return(floor(min(o$timeGap)))

}

#' @title threshold_slider_max

#' @description These were used on the occ-to-event tab to configure the slider

#' @name threshold_slider_max

#' @param o dataframe of occurrences

#' @return slider max

#' @export

threshold_slider_max <- function(o){

return(ceiling(max(o$timeGap)))

}

#' @title threshold_slider_selected

#' @description These were used on the occ-to-event tab to configure the slider

#' @name threshold_slider_selected

#' @param o dataframe of occurrences

#' @return selected value = min

#' @export

threshold_slider_selected <- function(o){

return(min(o$timeGap))

}

#### count the handoffs, but reverse coded -- zero = all different

#' @title diff_handoffs

#' @description count the handoffs, but reverse coded -- zero = all different

#' @name diff_handoffs

#' @param o dataframe of occurrences

#' @return o dataframe of occurrences with handoff count filled in

#' @export

diff_handoffs <- function(o){

# initialize the previous row

previous_row <<- o[1,]

return(apply(o,1, row_diff_handoff))

}

row_diff_handoff <- function(this_row){

# just add up the differences.

d <-sum(this_row==previous_row)

# store the previous row

previous_row <<-this_row

# return the number ofdifferences

return(d)

}

#### Time gaps -- just pass in the column of time stamps

#' @title diff_tStamp

#' @description Time gaps -- just pass in the column of time stamps - uses auto units

#' @name diff_tStamp

#' @param ts column of time stamps

#' @return Column of differences between timestamps

#' @export

diff_tStamp <- function(ts){

# initialize the first row

previous_row <<- ts[1]

return(sapply(ts, row_diff_tStamp))

}

row_diff_tStamp <- function(this_row){

# print(paste("this_row",this_row))

# print(paste("previous_row",previous_row))

# just add up the differences.

d <-max(0,difftime(this_row, previous_row, units='auto'))

# store the previous row

previous_row <<-this_row

# return the time difference

return(d)

}

#' @title threadSizeTable provides a distribution of the length of threads

#' @description This function should work on either ocurrences or events.

#' it returns length and duration of each thread.It requires tStamp field to compute duration.

#' @name threadSizeTable

#' @param o data frame with threads

#' @param TN column comtaining the threadNumber

#' @return data frame with table of thread lengths

#' @export

threadSizeTable <- function(o,TN){

# get the number of threads

nThreads = nrow(unique(o[TN]))

id=integer(nThreads)

num=integer(nThreads)

dur=numeric(nThreads)

sizes = data.frame(id,

num,

dur)

for (i in 1:nThreads){

sizes$id = i

sizes$num[i] = sum(o[TN]==i)

}

s = as.data.frame(table(sizes$num))

return(s)

}

#########################################################

#' @title convert_TN_to_TramineR

#' @description converts the csv format used in ThreadNet to the format used by TraMiner. Should provide a way to save this, as well.

#' @name convert_TN_to_TramineR

#' @param df threads (occurrences or events)

#' @param CF Contextual factor that will be used to define the state sequences in TraMineR

#' @return Dataframe in TraMineR format (state sequeces in horizontal rows)

#' @export

convert_TN_to_TramineR <- function(df, CF){

# dataframe must be sorted by time or sequence within each threadNumber

# TN is the threadnumber

# CF is some attribute we will use in TramineR

# first find the threads

threads = unique(df$threadNum)

nThreads = length(threads)

# Initialize list of empty lists

s = rep( list(list()), nThreads )

for ( th in 1:nThreads){

#subset of df that contains the sequence

s[[th]] = as.character(df[df$threadNum==threads[th],CF])

}

# add NA to make all the lists the same length

s = lapply(s, `length<-`, max(lengths(s)))

# convert to data frame

df <- data.frame(matrix(unlist(s), nrow=nThreads, byrow=T))

return(df)

}

# these functions support the moving window

#' @title get_threadList

#' @description get_threadList returns a list of all thread numbers

#' @name get_threadList

#' @param e data frame with threaded events

#' @param TN Column with threadNumber

#' @param SN Column with sequence numbers

#' @return list of thread numbers

#' @export

get_threadList <- function(e,TN,SN){

# for the current data structure for events, you just pick all of the threads where seqNum == 1

return(e[e[[SN]]==1,TN])

}

#' @title get_moving_window

#' @description get_moving_window returns a set of threads for a moving window

#' @name get_moving_window

#' @param e data frame with threads (needs to have threadNum and seqNum)

#' @param s size of window

#' @param l location of window

#' @return data from with just the threads in the window

#' @export

get_moving_window <- function(e, s, l ){

# get the list of threads

w=get_threadList(e,"threadNum","seqNum")

# get get the appropriate subset of threads for the window

w=w[l:(l+s-1)]

# and now subset the rows for those threads

return(e[e$threadNum %in% w,])

}

#' @title window_correlation

#' @description Correlation between moving windows

#' @name window_correlation

#' @param e data fraom for POV

#' @param w width of moving window

#' @param s step - how far to move window in each increment (default is 1)

#' @param n number of windows (default is 2)

#' @export

window_correlation <- function(e,w,s=1,n=2){

# make data frame

vt=data.frame( ngrams=character(), freq=integer(), wid=integer() )

# use the finest granularity

zcf = zoom_upper_limit(e)

# now many threads?

nThreads = numThreads(e,'threadNum')

wcount=0

# scan through the data

for (wloc in seq( 1, nThreads, s)){

wcount= wcount +1

# print(paste('wloc =',wloc))

# get text vector for the whole data set - just keep the first two colomns

ngdf = count_ngrams(get_moving_window(e, w, wloc), 'threadNum', zcf, n)[1:2]

# print(paste('nrow ngdf =',nrow(ngdf)))

# add a the row number

ngdf$wid = wcount

# append the columns to the end

vt=rbind(vt,ngdf)

}

# convert to factor so that we can compute distances using the factor levels

vt$ngrams = factor(vt$ngrams)

nWindows = length(unique(vt$wid))

# get the set of unique ngrams for the whole data set

vt_unique = data.frame(ngrams=unique(vt$ngrams))

# put the results here

windowFreqMatrix = matrix(0,nrow=nWindows, ncol=nrow(vt_unique))

for (i in 1:nWindows){

# get the merged list

vtmerge = merge(x=vt_unique, y=vt[vt$wid==i,], by='ngrams', all.x = TRUE)

# use the wid.y to get the whole vector, but replace the NA with zeros

b=vtmerge[vtmerge$wid==i,'freq']

b[is.na(b)] <- 0

windowFreqMatrix[i,]=b

}

# old way: correlate one row with the next and stick it in a dataframe

df =data.frame(window=1:(nWindows-1),

thread = seq( 1, nThreads-s, s),

correlation= unlist(lapply(1:(nWindows-1),

function(i){abs( cor(windowFreqMatrix[i,],windowFreqMatrix[i+1,])) })))

# add the last row explicitly

df = rbind( df, data.frame(window=nWindows, thread=nThreads, correlation=0))

# return( df )

# get the ngram data and labels

b_df=as.data.frame(windowFreqMatrix)

colnames(b_df)=vt_unique$ngrams

# stick the ngram frequencies on the end for good measure

return(cbind(df,b_df))

}

#' @title dual_window_correlation

#' @description similar to moving window, except one window on each side of a focal thread.

#' @name dual_window_correlation

#' @param e data fraom for POV

#' @param w width of moving window

#' @param s step - how far to move window in each increment (default is 1)

#' @param n number of windows (default is 2)

#' @export

dual_window_correlation <- function(e,w,s=1,n=2){

# make data frame

vt=data.frame( ngrams=character(), freq=integer(), id=integer() )

# use the finest granularity

zcf = zoom_upper_limit(e)

# now many threads?

nThreads = numThreads(e,'threadNum')

# scan through the threads - treat each thread as a window of one

# can probably do with the split and apply much faster

for (t in 1:nThreads){

# print(paste('wloc =',wloc))

# get text vector for the whole data set - just keep the first two colomns

ngdf = count_ngrams(get_moving_window(e, 1, t), 'threadNum', zcf, n)[1:2]

# print(paste('nrow ngdf =',nrow(ngdf)))

# add a the row number

ngdf$id = t

# append the columns to the end

vt=rbind(vt,ngdf)

}

# convert to factor

vt$ngrams = factor(vt$ngrams)

# compute number of windows.

nWindows = floor(nThreads/w)

# get the set of unique ngrams for the whole data set

vt_unique = data.frame(ngrams=unique(vt$ngrams))

# put the results here

ngramFreqMatrix = matrix(0,nrow=nThreads, ncol=nrow(vt_unique))

for (i in 1:nThreads){

# get the merged list

vtmerge = merge(x=vt_unique, y=vt[vt$id==i,], by='ngrams', all.x = TRUE)

# use the wid.y to get the whole vector, but replace the NA with zeros

b=vtmerge[vtmerge$id==i,'freq']

b[is.na(b)] <- 0

ngramFreqMatrix[i,]=b

}

# return(ngramFreqMatrix)

# old way: correlate one row with the next and stick it in a dataframe

df =data.frame( thread = seq(w,nThreads-(w+1),s),

correlation= unlist(lapply(seq(w,nThreads-(w+1),s),

function(i){abs( cor(colSums( ngramFreqMatrix[(i-w):i, ] ),

colSums( ngramFreqMatrix[(i+1):(i+w+1), ] ))) })))

# # add the last row explicitly

# df = rbind( df, data.frame( thread=nThreads, correlation=0))

return( df )

# # get the ngram data and labels

# b_df=as.data.frame(ngramFreqMatrix)

# colnames(b_df)=vt_unique$ngrams

#

# # stick the ngram frequencies on the end for good measure

# return(cbind(df,b_df))

}

# Make a nice dataframe to display

#' @title make_nice_event_DT

#' @description Issue is that DT::renderdatatable cannot display lists correctly, so cut then out.

#' @name make_nice_event_DT

#' @description Removes columns that do not need to be displayed

#' @param e data frame with POV

#' @export

make_nice_event_DT <- function(e){

# Add new column for the occurrences as a character string for display

# tibble::add_column(e, paste(e$occurrences,sep=","), .after=1)

e$OccurrenceList = paste(e$occurrences,sep=",")

# move occurences directly after tstamp

col_occ = which(colnames(e)=="OccurrenceList")

e = e[, c(1, col_occ, (2:ncol(e))[-col_occ])]

# Now remove the columns that have lists

e$occurrences = NULL

e$OccurrenceList.1 = NULL

e[grep("V_",colnames(e))]=NULL

return(e)

}

#' @title zoom_upper_limit

#' @description find the biggest column with ZM_, and then get the number that goes with that.

#' @name zoom_upper_limit

#' @description Used to set upper limit on sliders for zooming

#' @param e data frame

#' @return biggest zoom level

#' @export

zoom_upper_limit <- function(e){

upper_limit = as.integer(str_replace(colnames(e[max(grep("ZM_",colnames(e)))]),"ZM_",""))

return(upper_limit)

}

# sliderInput("ThreadMapZoomID",

# "Zoom in and out by event similarity:",

# 1,100,5, step = 1, ticks=FALSE)

######################################################

# Just putting this code here to play with for now.

# this function finds the common events in two subsets of thread data

# common_events <- function(ss1, ss2, TN, CF, n){

#

# # get the list of ngrams for each subset of threads

# e1 = count_ngrams(ss1, TN, CF, n)[1]

# e2 = count_ngrams(ss2, TN, CF, n)[1]

#

# # return the intersection

# return(intersect(as.matrix(e1), as.matrix(e2)))

#

# }

#

# rr_grams <- function(o,TN, CF, N, R) {

# # N - max length of ngram

# # R = threshold for repetition

#

# }

# Ideas for regex work

# https://stackoverflow.com/questions/35704369/identify-repetitive-pattern-in-numeric-vector-in-r-with-fuzzy-search

# sapply(1:(length(x)/2), function(m) sum(rep(x[1:m], length = length(x)) != x))

# x <- rep(c(1, 4, 2), 10)

# for(k in seq_len(length(x)/2)) {

# pat <- x[1:k]

# if (identical(rep(pat, length = length(x)), x)) {

# print(pat)

# break

# }

# }

## [1] 1 4 2