#########################################################################
##   Use a bubble plot to visualize the number of penetrations
##   that occurred for each hole in an electrode grid.
##
##
##   (c) wolf zinke (Feb. 2014) - Electrode Grid Tools
##
##   TODO: - Add a representation for a subarea of
##           grid holes that are recorded from
##         - Add a color code in addition to the area to represent
##           the frequency of recordings
##
##########################################################################

GridMap = function(MLloc, APloc, grid_rad=7, hemi='R', grid_type='crist72', titl=NULL, filename=NULL)
{
    if(toupper(hemi) == 'L'){  MLloc = MLloc * -1  } # flip M/L direction

    min_rad = 0.1
    size.range = c(min_rad, 0.5)

    if(!is.null(filename)){
        postscript(file=filename , pointsize = 16, ,width = 0.39*30, height = 0.39*30,paper='special', horizontal=F)
#         postscript(file=filename ,paper='a4', horizontal=FALSE)
    }else{
        x11()
    }

    # define grid hole coordinates
    GridLayout(hole_rad=min_rad, grid_rad=grid_rad, hemi=hemi, titl=titl)  # needs to be sourced first

    # combine coordinates to unique identifiers
    got_coor = is.finite(APloc) & is.finite(MLloc)
    IDs = paste(MLloc[got_coor], APloc[got_coor], sep='/')

    # count occurrences of each grid location
    gridhole = table(IDs)
    grid_ids  = names(gridhole)
    coorlst   = strsplit(grid_ids,'/')

    xypos     = matrix(unlist(coorlst), ncol = 2, byrow = TRUE)
    APvals    = as.numeric(xypos[,2])
    MLvals    = as.numeric(xypos[,1])

    penecount = as.numeric(as.vector(gridhole))

    # Calculate the relative radius of each circle
    radarea = sqrt(penecount)
    radii   = (diff(size.range)*(radarea - min(radarea))) / diff(range(radarea)) + size.range[1] # normalize area

    # draw circles scaled according to the number of penetrations
    symbols (MLvals, APvals, circles=radii, add=TRUE, inches=FALSE , bg="black", fg='black',lwd=1.5)

    szpos = penecount >=  max(penecount)/5  # avoid writing numbers into small circles
    text(MLvals[szpos], APvals[szpos], labels=as.character(penecount[szpos]), col="white", cex=0.8)

    # create a legend for circle sizes
    # quick & dirty determination of legend sizes (should be improved some day)
    if(max(penecount) < 30){
        chose_steps = seq(from=2,by=2,to=10)
    }else{
        chose_steps = seq(from=5,by=5,to=100)
    }
    num_step = (max(penecount)/chose_steps)
    use_step = chose_steps[abs(num_step-6)==min(abs(num_step-6))]
    refsteps = seq(from=use_step,to=max(penecount),by=use_step)
    refsz = sqrt(refsteps)
    refsz = (diff(size.range)*(refsz - min(radarea))) / diff(range(radarea)) + size.range[1] # normalize area
    refsz = rev(refsz)

    symbols(rep(grid_rad+1,length(refsz)), -grid_rad-1+(1:length(refsz)-1), refsz, add=TRUE, inches=FALSE , bg="black", fg='black',lwd=1)

    text(grid_rad+1,   -grid_rad-2.2, "Number of\nPenetrations")
    text(grid_rad+2.2, -grid_rad-1+(1:length(refsz)-1), rev(refsteps))

    if(!is.null(filename)){ dev.off() }

}


#####################
# Parameters
#####################

# Country parameters
countryname = 'Kenya'
countryiso3 = 'KEN' # ISO3
national_official_population = 52000000 # number of people # REF:
national_official_elrate = 0.74 # national electricity access rate
national_official_population_without_access = national_official_population- (national_official_population*national_official_elrate) # number of people without access

# Planning horizon parameters
today = 2020
planning_year = 2030
planning_horizon = planning_year - today
discount_rate = 0.15

# Energy efficiency improvement factors
eff_impr_rur1= 0.05
eff_impr_rur2= 0.075
eff_impr_rur3= 0.1
eff_impr_rur4= 0.125
eff_impr_rur5= 0.15

eff_impr_urb1= 0.05
eff_impr_urb2= 0.075
eff_impr_urb3= 0.1
eff_impr_urb4= 0.125
eff_impr_urb5= 0.15

# Groundwater pump technical parameters
rho = 1000 # density of water (1000 kg / m3)
g = 9.81 # gravitational constant (m / s2)
c = 3.6 * (10^6) # differential pressure, (Pa)

# Surface water parameters
water_speed = 2 #m/s, https://www.engineeringtoolbox.com/flow-velocity-water-pipes-d_385.html
water_viscosity = 0.00089 #https://www.engineersedge.com/physics/water__density_viscosity_specific_weight_13146.htm
pipe_diameter = 0.8 # m

#Threshold parameters
threshold_surfacewater_distance = 5000 # (m): distance threshold which discriminates if groundwater pumping is necessary or a surface pump is enough # REF:
threshold_groundwater_pumping = 15 # (m): maximum depth at which the model allows for water pumping: beyond it, no chance to install the pump # REF:

#number of hours of pumping, 3 during the morning and 3 during the evening
nhours_irr = 6
eta_pump = 0.75

# Transportation costs
fuel_consumption = 15 # (l/h) # REF: OnSSET
fuel_cost = 1 # (USD/l) # baseline, then adapted based on distance to city
truck_bearing_t = 15 # (tons) # REF: https://en.wikipedia.org/wiki/Dump_truck

#Pumo economic parameters
LCOE_for_pumping = 0.08 # USD/kWh # REF:
lifetimepump = 30

# import local crop prices csv.  Structure: X, Y, City, cropname1, cropname 2, ...
prices = readxl::read_xls(paste0(input_folder , "prices.xls"))

# Appliances cost, household (check ./ramp/ramp/RAMP_households/Appliances cost.xlsx for inputs)
rur1_app_cost=154
rur2_app_cost=171
rur3_app_cost=278
rur4_app_cost=958
rur5_app_cost=1905

urb1_app_cost=113
urb2_app_cost=307
urb3_app_cost=902
urb4_app_cost=1464
urb5_app_cost=2994

# Appliances cost, schools (check ./ramp/ramp/RAMP_social/Appliances_schools.xlsx for inputs)
sch_1_app_cost = 60
sch_2_app_cost = 360
sch_3_app_cost = 1590
sch_4_app_cost = 2550
sch_5_app_cost = 3220

# Appliances cost, healtchare  (check ./ramp/ramp/RAMP_social/Appliances_healthcare.xlsx for inputs)
hc_1_app_cost = 110
hc_2_app_cost = 4710
hc_3_app_cost = 95060
hc_4_app_cost = 305660
hc_5_app_cost = 611450

#####################
# Input data
#####################

#
#clusters <- read_sf(paste0(home_repo_folder , 'clusters_final.gpkg'))

#
provinces <- read_sf(paste0(db_folder, '/input_folder/KEN_8_provinces.shp'))

# Country and provinces shapefiles
gadm0 = read_sf(paste0(input_folder , 'gadm36_' , countryiso3 , '_0.shp'))
gadm1 = read_sf(paste0(input_folder , 'gadm36_' , countryiso3 , '_1.shp'))
gadm2 = read_sf(paste0(input_folder , 'gadm36_' , countryiso3 , '_2.shp'))
gadm3 = read_sf(paste0(input_folder , 'gadm36_' , countryiso3 , '_3.shp'))

# Define extent of country analysed
ext = extent(gadm0)

# Import cropland extent (Default dataset used: GFSAD30CE)
cropland_extent = raster(paste0(input_folder , 'Croplands_GFSAD30AFCE.tif'))

# Import climatezones (Default datasets used: GAEZ soil classes)
climatezones = raster(paste0(input_folder , 'GAEZ_climatezones.tif'))

# Import surface water basins layer (Default datasets used: Global Surface Water Explorer)
categories_surface_water = raster(paste0(input_folder , 'transitions.tif'))

# Import diesel price layer (In each pixel: 2015 prices baseline , cost per transporting it from large cities)
diesel_price = raster(paste0(input_folder , 'diesel_price_baseline_countryspecific.tif'))

#
crops = readxl::read_xlsx(paste0(input_folder , 'crops_cfs_ndays_months.xlsx'))

# plot on a fishnet of 1x1 km
template <- raster(paste0(db_folder, '/input_folder/template_1km.tif'))

# Import csv of energy consumption by crop
energy_crops = read.csv(paste0(input_folder,'crop_processing.csv'))

crops = read_xlsx(paste0(input_folder ,'crops_cfs_ndays_months.xlsx'))

#
pet = stack(paste0(input_folder , "TerraClimate/TerraClimate_pet_2015.nc"))
ppt = stack(paste0(input_folder , "TerraClimate/TerraClimate_ppt_2015.tif"))
soil = stack(paste0(input_folder , "TerraClimate/TerraClimate_soil_2015.nc"))

#
roads<-read_sf(paste0(input_folder, 'RoadsKEN.shp'))

empl_wealth<-read_sf(paste0(input_folder, '/jrc/wealth_employment/shps/sdr_subnational_data_dhs_2014.shp'))

traveltime <- raster(paste0(input_folder, 'travel.tif'))

traveltime_market = raster(paste0(input_folder, 'traveltime_market.tif'))

#
DepthToGroundwater = read.delim(paste0(input_folder , 'DepthToGroundwater/xyzASCII_dtwmap_v1.txt'), sep='\t')
GroundwaterStorage = read.delim(paste0(input_folder , 'GroundwaterStorage/xyzASCII_gwstor_v1.txt'), sep='\t')
GroundwaterProductivity = read.delim(paste0(input_folder , 'GroundwaterProductivity/xyzASCII_gwprod_v1.txt'), sep='\t')

#
urbrur <- raster(paste0(input_folder , 'GHSL_settlement_type.tif'))

#
raster_tiers = raster(paste0(input_folder , 'tiersofaccess_SSA_2018.nc'))

#
population <- raster(paste0(input_folder, "GHS_POP_E2015_GLOBE_R2019A_4326_30ss_V1_0.tif"))

population <- rgis::mask_raster_to_polygon(population, gadm0)

#
dhs = read_sf(paste0(input_folder , 'statcompiler_subnational_data_2020-03-17/shps/sdr_subnational_data_dhs_2015.shp'))

# Classifying schools and healthcare facilities
health = read_xlsx(paste0(health_edu_folder , "GeoHealth Data.xlsx"))

# Extract coordinates from csv file of healthcare facilities
health$Y = as.numeric(gsub("[^0-9.-]", "", (sub("\\,.*", "", health$Geolocation))))
health$X = as.numeric(gsub("[^0-9.-]", "", (sub(".*,", "", health$Geolocation))))

# Keep only operational facilities
health = subset(health, (health$OperationalStatus == 'Operational') | (health$OperationalStatus == "Pending Opening"))

# Classify healthcare facilities into 5 tiers
health$heal_type1 = ifelse(health$Type == 'Dispensary', 1, 0)
health$heal_type2 = ifelse((health$Type=='Medical Clinic') | (health$Type == 'Dental Clinic') | (health$Type == 'Eye Centre') |  (health$Type == 'Laboratory (Stand-alone)') | (health$Type == 'Medical Centre') | (health$Type == 'Radiology Unit') |  (health$Type == 'Regional Blood Tranclustersusion Centre') | (health$Type=='Health Centre') | (health$Type=='Maternity Home') | (health$Type=='Nursing Home') | (health$Type=='VCT Centre') | (health$Type=='Health Programme') | (health$Type=='Health Project') |  (health$Type=='Rural Health Training Centre') | (health$Type=='Training Institution in Health (Stand-alone)'), 1, 0)
health$heal_type3 = ifelse((health$Type=='Other Hospital') | (health$Type=='Sub-District Hospital'), 1, 0)
health$heal_type4 = ifelse((health$Type=='District Hospital') |  (health$Type=='Provincial General Hospital') , 1, 0)
health$heal_type5 = ifelse((health$Type=='National Referral Hospital'), 1, 0)

# Calculate number of beds and cots of each tier in each cluster
health$beds_1 = ifelse(health$heal_type1== 1, health$Beds + health$Cots, 0)
health$beds_2 = ifelse(health$heal_type2== 1, health$Beds + health$Cots, 0)
health$beds_3 = ifelse(health$heal_type3== 1, health$Beds + health$Cots, 0)
health$beds_4 = ifelse(health$heal_type4== 1, health$Beds + health$Cots, 0)
health$beds_5 = ifelse(health$heal_type5== 1, health$Beds + health$Cots, 0)

# In any case the dispensary counts as one bed
health$beds_1 = ifelse((health$beds_1==0) & (health$heal_type1== 1), 1, health$beds_1)

#Fill empty fields with average number of beds of the category
health$beds_1 = ifelse(is.na(health$beds_1), 1, health$beds_1)
health$beds_2 = ifelse(is.na(health$beds_2), 45, health$beds_2)
health$beds_3 = ifelse(is.na(health$beds_3), 150, health$beds_3)
health$beds_4 = ifelse(is.na(health$beds_4), 450, health$beds_4)
health$beds_5 = ifelse(is.na(health$beds_5), 2000, health$beds_5)

# #Keep only hospitals with valid coordinates
health = filter(health, !is.na(health$X))

# #Convert to a spatial dataframe using coordinates
healthcarefacilities = st_as_sf(health, coords = c("X", "Y"), crs=4326)

#Import primaryschools
primaryschools = read_sf(paste0(health_edu_folder , 'Kenya_Open_Data_Initiative_KODI_Primary_Schools.shp'))

# Classify primaryschools using total enrollment as a proxy for their tier
primaryschools$sch_type1 = ifelse((primaryschools$TotalEnrol > 0) & (primaryschools$TotalEnrol <= 50), 1, 0)      #method to be confirmed
primaryschools$sch_type2 = ifelse((primaryschools$TotalEnrol > 50) & (primaryschools$TotalEnrol <= 150) , 1, 0)     #method to be confirmed
primaryschools$sch_type3 = ifelse((primaryschools$TotalEnrol > 150) & (primaryschools$TotalEnrol <= 300), 1, 0)     #method to be confirmed
primaryschools$sch_type4 = ifelse((primaryschools$TotalEnrol > 300) & (primaryschools$TotalEnrol <= 600) , 1, 0)    #method to be confirmed
primaryschools$sch_type5 = ifelse((primaryschools$TotalEnrol > 600)         , 1, 0)                             #method to be confirmed

primaryschools$pupils_1 = ifelse(primaryschools$sch_type1== 1, primaryschools$TotalEnrol, 0)
primaryschools$pupils_2 = ifelse(primaryschools$sch_type2== 1, primaryschools$TotalEnrol, 0)
primaryschools$pupils_3 = ifelse(primaryschools$sch_type3== 1, primaryschools$TotalEnrol, 0)
primaryschools$pupils_4 = ifelse(primaryschools$sch_type4== 1, primaryschools$TotalEnrol, 0)
primaryschools$pupils_5 = ifelse(primaryschools$sch_type5== 1, primaryschools$TotalEnrol, 0)

primaryschools$pupils_1 = ifelse(primaryschools$pupils_1== 0, 50, primaryschools$pupils_1)
primaryschools$pupils_2 = ifelse(primaryschools$pupils_2== 0, 100, primaryschools$pupils_2)
primaryschools$pupils_3 = ifelse(primaryschools$pupils_3== 0, 225, primaryschools$pupils_3)
primaryschools$pupils_4 = ifelse(primaryschools$pupils_4== 0, 450, primaryschools$pupils_4)
primaryschools$pupils_5 = ifelse(primaryschools$pupils_5== 0, 700, primaryschools$pupils_5)

#####################
# Assumed load curves
#####################

# crop processing
load_curve_cp = c(0, 0, 0, 0, 0, 0, 0.0833, 0.0833, 0.0833, 0.0833, 0.0833, 0.0833, 0.0833, 0.0833, 0.0833, 0.0833, 0.0833, 0.0833, 0, 0, 0, 0, 0, 0)

# irrigation
load_curve_irrig = c(0, 0, 0, 0, 0, 0.166, 0.166, 0.166, 0.166, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0.166, 0.166)
load_curve_irr = load_curve_irrig

# import load curve of productive activities
load_curve_prod_act <- read.csv(paste0(input_folder, 'productive profile.csv'))


#' Unit Testing script for NMF package: NMF models and utilities.
#'
#' @author Renaud Gaujoux
#' @creation 22 April 2009

# make the internal functions/objects visible
if( isNamespaceLoaded('NMF') ){
	.predict.nmf <- NMF:::.predict.nmf
	is.same <- NMF:::is.same
}

.TestSeed <- 123456

checkOnlyNAs <- function(x, msg){
	checkTrue( all(is.na(basis(x))) , paste(msg, ': Only NAs in W'))
	checkTrue( all(is.na(coef(x))), paste(msg, ': Only NAs in H'))
}

basicHM <- aheatmap

checkPlot <- function(...){
	if( isCHECK() ) return()
	pkgmaker::checkPlot(...)
}

#' checks the validity of a NMF object: dimensions
check.object <- function(obj, n, m, r, title='Check NMF object', class='NMFstd'){

	# convert dimensions to integers
	n <- as.integer(n)
	m <- as.integer(m)
	r <- as.integer(r)

	# check class
	checkTrue(is(obj, class), paste(title, ': object is of class "', class, "'"));
	# check virtual interface accessors
	checkTrue(is.same(obj@W, basis(obj)), msg('method `basis` returns slot W'))
	checkTrue(is.same(obj@H, coef(obj)), msg('method `coef` returns slot H'))

	checkIdentical(nrow(basis(obj)), n, paste(title, ': number of rows in basis matrix is correct'))
	checkIdentical(nrow(obj), n, paste(title, ': nrow returns correct value'))
	checkIdentical(ncol(basis(obj)), r, paste(title, ': number of columns in basis matrix is correct'))
	checkIdentical(nbasis(obj), r, paste(title, ': nbasis returns correct value'))
	checkIdentical(nrow(coef(obj)), r, paste(title, ': number of rows in coef matrix correct'))
	checkIdentical(ncol(coef(obj)), m, paste(title, ': number of columns in coef matrix is correct'))
	checkIdentical(ncol(obj), m, paste(title, ': ncol returns correct value'))
}

check.NMF.class <- function(class, ...){

	set.seed(.TestSeed)

	msg <- function(...) paste('New -', class,':', ...)

	# base constructor: should build an empty model
	a <- new(class, ...)

	# check if there is only NAs
	checkOnlyNAs(a, msg('with no parameters'))
	check.object(a, 0, 0, 0, msg('with no parameters'), class)

	# define some dimensions to use as template
	n <- 50; m <- 10; r <- 3;
	w <- rmatrix(n, r); h <- rmatrix(r, m)

	# base constructor with one of the two matrices: exceptions
	checkException(new(class, W=w, ...), msg('error if only basis matrix'))
	checkException(new(class, H=h, ...), msg('error if only coef matrix'))

	# base constructor with two matrices
	a <- new(class, W=w, H=h, ...)

	# check the dimensions of the internal matrices
	check.object(a, n, m, r, msg('with two matrices - '), class)
	checkIdentical(basis(a), w, msg('with two matrices - basis matrix is correctly set'));
	checkIdentical(coef(a), h, msg('with two matrices - coef matrix is correctly set'));

	# check error with wrong dimension
	checkException(a <- new(class, W=matrix(1,n,r+1), H=matrix(1,r,m), ...), msg('Error if incompatible dimensions (W)'))
	checkException(a <- new(class, W=matrix(1,n,r), H=matrix(1,r+1,m), ...), msg('Error if incompatible dimensions (H)'))
}

#' Tests the class 'NMF'
test.class.NMFstd <- function(){
	check.NMF.class('NMFstd')
}

#' Tests the class 'NMFns'
test.class.NMFns <- function(){
	# with no parameter
	check.NMF.class('NMFns')

	# with a parameter
	t <- 0.8
	check.NMF.class('NMFns', theta=t)

	# test specific stuff
	a <- new('NMFns', theta=t)
	checkIdentical(a@theta, t, 'Slot theta is correctly set')
	checkException(a <- new('NMFns', theta=-1), 'Negative value of theta throws an exception')
	checkException(a <- new('NMFns', theta=1.2), 'Value of theta > 1 throws an exception')

	# test equivalence with standard model when theta=0
	set.seed(.TestSeed)
	n <- 50; m <- 10; r <- 3
	W <- rmatrix(n, r)
	H <- rmatrix(r, m)
	a.ns <- new('NMFns', W=W, H=H, theta=0)
	a.std <- new('NMFstd', W=W, H=H)
	checkIdentical(fitted(a.ns), fitted(a.std), 'Values fitted correspond to standard model if theta=0')

	# check method smoothing
	a.ns <- new('NMFns', W=W, H=H, theta=0.4)
	s <- smoothing(a.ns)
	checkEquals(dim(s), c(r, r), 'Smoothing matrix: dimension are correct')
	checkTrue( all(s >= 0), 'Smoothing matrix: all entries are nonnegative')
	checkEquals( rowSums(s), rep(1, r), 'Smoothing matrix: sum of rows are ones')
	checkEquals( colSums(s), rep(1, r), 'Smoothing matrix: sum of columns are ones')
	checkEquals( fitted(a.ns), basis(a.ns) %*% s %*% coef(a.ns), 'Fitted values are correct (product of basis, smoothing and coef).')

	#TODO: put this in file test.algorithms.R
#	n <- 100; m <- 20; r <- 3
#	set.seed(.TestSeed)
#	V <- syntheticNMF(n, r, m, noise=TRUE) # add noise for stability
#	set.seed(.TestSeed)
#	res.std <- fit(nmf(V, r, 'brunet', seed='nndsvd'))
#	set.seed(.TestSeed)
#	res.ns <- fit(nmf(V, r, 'ns', seed='nndsvd', theta=0))

	#checkEqualsNumeric(basis(res.ns), basis(res.std), 'W from nsNMF(theta=0) are the same as the ones from the standard model')
	#checkEqualsNumeric(coef(res.ns), coef(res.std), 'H from nsNMF(theta=0) are the same as the ones from the standard model')
}

test.nmfModel <- function(){

	set.seed(.TestSeed)

	# define some dimensions to use as template
	n <- as.integer(25); m <- as.integer(10); r <- as.integer(3);

	check.empty.model <- function(x, n, m, r, msg, class='NMFstd'){
		check.object(x, n, m, r, msg, class)
		checkOnlyNAs(x, msg)
	}

	# check basic errors
	checkException(nmfModel(numeric()), 'Error if negative rank')
	checkException(nmfModel(c(1,2)), 'Error if rank of length != 1')
	checkException(nmfModel(r, -1), 'Error if negative target dimension')
	checkException(nmfModel(r, 1:3), 'Error if target dimension of length > 2')
	checkException(nmfModel(r, 1, -1), 'Error if target ncol negative')
	checkException(nmfModel(r, 1, 1:2), 'Error if target ncol of length > 1')
	checkException(nmfModel(r, 1, matrix(1,2,2)), 'Error if target ncol not vector')

	# constructor of empty model
		check.empty.model(nmfModel(), 0, 0, 0, 'Constructor with no arguments returns empty model')
	# constructor of empty model with ncol specified
		check.empty.model(nmfModel(ncol=5), 0, 5, 0, 'Constructor with only with ncol specified')
	# constructor with missing target
		check.empty.model(nmfModel(r), 0, 0, r, 'Constructor with missing target')
	# constructor using dimension vector
		check.empty.model(nmfModel(r, c(n,m)), n, m, r, 'Constructor with dimensions as a vector')
	# constructor using separate dimensions
		check.empty.model(nmfModel(r, n, m), n, m, r, 'Constructor with separate dimensions')
	# constructor with single dimension
		check.empty.model(nmfModel(r, n), n, n, r, 'Constructor with single dimension (nrow)')
	# constructor with single dimension (ncol)
		check.empty.model(nmfModel(r, ncol=m), 0, m, r, 'Constructor with single dimension (ncol)')
	#TODO: check exceptions if passing negative numbers

	# constructor using a target matrix
		msg <- function(...) paste('Constructor with target matrix -', ...)
		V <- rmatrix(n, m)
		check.empty.model(nmfModel(r, V), n, m, r, msg('second argument'))
		check.empty.model(nmfModel(V, r), n, m, r, msg('first argument'))
		check.empty.model(nmfModel(V), n, m, 0, msg('single argument'))
		dimnames(V) <- list(rows=letters[1:n], cols=letters[1:m])
		checkIdentical(dimnames(nmfModel(V)), c(dimnames(V), list(NULL)), msg('dimnames are correctly set'))
		checkIdentical(dimnames(nmfModel(V, use.names=FALSE)), NULL, msg('dimnames are not used if use.names=FALSE'))

	w <- rmatrix(n, r); h <- rmatrix(r, m)
	# constructor supplying matrices W and H
		msg <- function(...) paste('Constructor with target rank and both basis and coef matrices -', ...)
		a <- nmfModel(r, W=w, H=h)
		check.object(a, n, m, r, msg())
		checkIdentical(basis(a), w, msg('basis matrix is correctly set'))
		checkIdentical(coef(a), h, msg('coef matrix is correctly set'))
		checkException(nmfModel(r, c(n+1,m), W=w, H=h), msg('error if bad number of rows in basis matrix'))
		checkException(nmfModel(r, c(n,m), W=w[,-r], H=h), msg('error if bad number of columns in basis matrix'))
		checkException(nmfModel(r, c(n,m), W=w, H=h[-r,]), msg('error if bad number of rows in coef matrix'))
		checkException(nmfModel(r, c(n,m+1), W=w, H=h), msg('error if bad number of columns in coef matrix'))

		# reducing dimensions
		rmsg <- function(...) msg('reduce rank -', ...)
		a <- nmfModel(r-1, W=w, H=h)
		check.object(a, n, m, r-1, rmsg('dimensions are OK'))
		checkIdentical(basis(a), w[,-r], rmsg("entries for basis are OK"))
		checkIdentical(coef(a), h[-r,], rmsg("entries for coef are OK"))

		rmsg <- function(...) msg('reduce nrow -', ...)
		a <- nmfModel(r, n-1, W=w, H=h)
		check.object(a, n-1, m, r, rmsg('dimensions are OK'))
		checkIdentical(basis(a), w[-n,], rmsg("entries for basis are OK"))
		checkIdentical(coef(a), h, rmsg("entries for coef are OK"))

		rmsg <- function(...) msg('reduce ncol -', ...)
		a <- nmfModel(r, ncol=m-1, W=w, H=h)
		check.object(a, n, m-1, r, rmsg('dimensions are OK'))
		checkIdentical(basis(a), w, rmsg("entries for basis are OK"))
		checkIdentical(coef(a), h[,-m], rmsg("entries for coef are OK"))

	# constructor supplying only matrices W and H
		msg <- function(...) paste('Constructor with only basis and coef matrices (named arguments) -', ...)
		a <- nmfModel(W=w, H=h)
		check.object(a, n, m, r, msg())
		checkIdentical(basis(a), w, msg('basis matrix is correctly set'))
		checkIdentical(coef(a), h, msg('coef matrix is correctly set'))
		checkException(nmfModel(W=matrix(1, n, r+1), H=matrix(1, r, m)), msg('error if incompatible dimensions (1)'))
		checkException(nmfModel(W=matrix(1, n, r), H=matrix(1, r+1, m)), msg('error if incompatible dimensions (2)'))
	# constructor supplying only matrices W and H and not naming the arguments
		msg <- function(...) paste('Constructor with only basis and coef matrices (unamed argument) -', ...)
		a <- nmfModel(w, h)
		check.object(a, n, m, r, msg())
		checkIdentical(basis(a), w, msg('basis matrix is correctly set'))
		checkIdentical(coef(a), h, msg('coef matrix is correctly set'))
		checkException(nmfModel(matrix(1, n, r+1), matrix(1, r, m)), msg('error if incompatible dimensions (1)'))
		checkException(nmfModel(matrix(1, n, r), matrix(1, r+1, m)), msg('error if incompatible dimensions (2)'))

	# constructor supplying only W and target rank
		msg <- function(...) paste('Constructor with target rank and basis matrix only -', ...)
		a <- nmfModel(r, W=w)
		check.object(a, n, 0, r, msg())
		checkIdentical(basis(a), w, msg('basis matrix is correctly set'))
		checkTrue(all(is.na(coef(a))), msg('only NA in coef matrix'))
		checkException(nmfModel(r+1, W=w), msg('error if smaller number of columns in basis matrix'))

		# reducing dimensions
		rmsg <- function(...) msg('reduce rank -', ...)
		a <- nmfModel(r-1, W=w)
		check.object(a, n, 0, r-1, rmsg('dimensions are OK'))
		checkIdentical(basis(a), w[,-r], rmsg("entries for basis are OK"))
		checkTrue(all(is.na(coef(a))), rmsg('only NA in coef matrix'))
		checkException(nmfModel(r-1, W=w, force.dim=FALSE), msg('error if greater number of columns in basis matrix and force.dim=FALSE'))

	# constructor supplying only W
		msg <- function(...) paste('Constructor with basis matrix only -', ...)
		a <- nmfModel(W=w)
		check.object(a, n, 0, r, msg())
		checkIdentical(basis(a), w, msg('basis matrix is correctly set'))
		checkTrue(all(is.na(coef(a))), msg('only NA in coef matrix'))

	# constructor supplying only H and target rank
		msg <- function(...) paste('Constructor with target rank and coef matrix only -', ...)
		a <- nmfModel(r, H=h)
		check.object(a, 0, m, r, msg())
		checkIdentical(coef(a), h, msg('coef matrix is correctly set'))
		checkTrue(all(is.na(basis(a))), msg('only NA in basis matrix'))
		checkException(nmfModel(r+1, H=h), msg('error if smaller number of rows in coef matrix'))

		# reducing dimensions
		rmsg <- function(...) msg('reduce rank -', ...)
		a <- nmfModel(r-1, H=h)
		check.object(a, 0, m, r-1, rmsg('dimensions are OK'))
		checkIdentical(coef(a), h[-r,], rmsg('coef matrix is correctly set'))
		checkTrue(all(is.na(basis(a))), rmsg('only NA in basis matrix'))
		checkException(nmfModel(r-1, H=h, force.dim=FALSE), msg('error if greater number of rows in coef matrix and force.dim=FALSE'))

	# constructor supplying only H
		msg <- function(...) paste('Constructor with coef matrix only -', ...)
		a <- nmfModel(H=h)
		check.object(a, 0, m, r, msg())
		checkIdentical(coef(a), h, msg('coef matrix is correctly set'))
		checkTrue(all(is.na(basis(a))), msg('only NA in basis matrix'))

	# constructor supplying W and target dimensions
		msg <- function(...) paste('Constructor with basis matrix and both target dimensions -', ...)
		a <- nmfModel(r, n, m, W=w)
		check.object(a, n, m, r, msg())
		checkIdentical(basis(a), w, rmsg("entries for basis are OK"))
		checkTrue(all(is.na(coef(a))), rmsg('only NA in coef matrix'))

		rmsg <- function(...) msg('reduce nrow -', ...)
		a <- nmfModel(r, n-1, m, W=w)
		check.object(a, n-1, m, r, rmsg('dimensions are OK'))
		checkIdentical(basis(a), w[-n,], rmsg("entries for basis are OK"))
		checkTrue(all(is.na(coef(a))), rmsg('only NA in coef matrix'))

		checkException(nmfModel(r, n+1, m, W=w), msg('error if smaller number of rows in basis matrix'))
		checkException(nmfModel(r, n-1, W=w, force.dim=FALSE), msg('error if greater number of rows in basis matrix and force.dim=FALSE'))
		checkException(nmfModel(r+1, n, m, W=w), msg('error if smaller number of columns in basis matrix'))

	# constructor supplying H and target dimensions
		msg <- function(...) paste('Constructor with coef matrix and both target dimensions -', ...)
		a <- nmfModel(r, n, m, H=h)
		check.object(a, n, m, r, msg())
		checkTrue(all(is.na(basis(a))), msg('only NA in basis matrix'))
		checkIdentical(coef(a), h, msg('coef matrix is correctly set'))

		rmsg <- function(...) msg('reduce ncol -', ...)
		a <- nmfModel(r, n , m-1, H=h)
		check.object(a, n, m-1, r, rmsg('dimensions are OK'))
		checkIdentical(coef(a), h[,-m], rmsg('coef matrix is correctly set'))
		checkTrue(all(is.na(basis(a))), rmsg('only NA in basis matrix'))

		checkException(nmfModel(r+1, n, m, H=h), msg('error if smaller number of rows in coef matrix'))
		checkException(nmfModel(r, n, m-1, H=h, force.dim=FALSE), msg('error if greater number of columns in coef matrix and force.dim=FALSE'))
		checkException(nmfModel(r, n, m+1, H=h), msg('error if smaller number of columns in coef matrix'))

	# check basisnames passage

		check.model.dimnames <- function(x, dn, title){
			msg <- function(...) paste(title, '-', ...)
			checkIdentical(dimnames(x), dn, msg("dimnames are correct"))
			checkIdentical(colnames(basis(x)), dn[[3]], msg("colnames of basis matrix are correct"))
			checkIdentical(rownames(coef(x)), dn[[3]], msg("rownames of coef matrix are correct"))
		}

		dn <- letters[1:nrow(h)]
		h2 <- h; rownames(h2) <- dn;
		a <- nmfModel(r, H=h2)
		check.model.dimnames(a, list(NULL, NULL, dn), "Basis names are passed from input coef matrix")

		w2 <- w; colnames(w2) <- dn;
		a <- nmfModel(r, W=w2)
		check.model.dimnames(a, list(NULL, NULL, dn), "Basis names are passed from input basis matrix")

		w2 <- w; colnames(w2) <- dn;
		h2 <- h; rownames(h2) <- dn;
		a <- nmfModel(W=w2, H=h2)
		check.model.dimnames(a, list(NULL, NULL, dn), "Basis names are used unchanged if equal in input basis and coef matrices")

		msg <- function(...) paste("Basis names from input basis matrix are used to order the components - ", ...)
		w2 <- w; colnames(w2) <- dn;
		h2 <- h; rownames(h2) <- rev(dn);
		a <- nmfModel(W=w2, H=h2)
		check.model.dimnames(a, list(NULL, NULL, dn), msg("rownames of input basis are enforced"))
		checkIdentical(basis(a), w2, msg("basis unchanged"))
		checkIdentical(coef(a), h2[nrow(h):1,], msg("coef entries are reordered"))

		msg <- function(...) paste("Basis names from input basis matrix are NOT used to order the components if argument order.basis=FALSE - ", ...)
		w2 <- w; colnames(w2) <- dn;
		h2 <- h; rownames(h2) <- rev(dn);
		a <- nmfModel(W=w2, H=h2, order.basis=FALSE)
		check.model.dimnames(a, list(NULL, NULL, dn), msg("rownames of input basis are enforced"))
		checkIdentical(basis(a), w2, msg("basis unchanged"))
		checkEquals(coef(a), h2, msg("coef entries are not ordered"), check.attributes=FALSE)

		msg <- function(...) paste("Basis names from input basis matrix are forced onto to the coef matrix - ", ...)
		w2 <- w; colnames(w2) <- dn;
		h2 <- h; rownames(h2) <- paste(letters[1:nrow(h)], 2);
		a <- nmfModel(W=w2, H=h2)
		check.model.dimnames(a, list(NULL, NULL, dn), msg("rownames of input basis are enforced"))
		checkIdentical(basis(a), w2, msg("basis is unchanged"))
		checkEquals(coef(a), h2, msg("coef entries are correct"), check.attributes=FALSE)
}

test.dimensions <- function(){
	# define some dimensions to use as template
	n <- as.integer(50); m <- as.integer(10); r <- as.integer(3);

	# create an NMF object
	a <- nmfModel(r, n, m)

	# check the dimensions
	checkIdentical(dim(a), c(n, m, r), "Function 'dim' is OK")

	# check the row number
	checkIdentical(nrow(a), n, "Function 'nrow' is OK")

	# check the column number
	checkIdentical(ncol(a), m, "Function 'ncol' is OK")

	# check the number of basis
	checkIdentical(nbasis(a), r, "Function 'nbasis' is OK")

}

check.dimnames <- function(x, dn, msg){

	checkIdentical(dimnames(x), dn, paste(msg, '-',"dimnames returns correct value"))
	checkIdentical(dimnames(x)[c(1,3)], dimnames(basis(x)), paste(msg, '-', "dimnames returns value consistent with basis"))
	checkIdentical(dimnames(x)[c(3,2)], dimnames(coef(x)), paste(msg, '-', "dimnames returns value consistent with coef"))

	checkIdentical(rownames(x), dn[[1]], paste(msg, '-', "rownames returns correct value"))
	checkIdentical(rownames(basis(x)), rownames(x), paste(msg, '-', "rownames returns same value as rownames(basis)"))

	checkIdentical(colnames(x), dn[[2]], paste(msg, '-', "colnames returns correct value"))
	checkIdentical(colnames(coef(x)), colnames(x), paste(msg, '-', "colnames returns same value as colnames(basis)"))

	checkIdentical(basisnames(x), dn[[3]], paste(msg, '-', "basisnames returns correct value"))
	checkIdentical(colnames(basis(x)), basisnames(x), paste(msg, '-', "basisnames returns same value as colnames(basis)"))
	checkIdentical(rownames(coef(x)), basisnames(x), paste(msg, '-', "basisnames returns same value as rownames(coef)"))

}

test.dimnames <- function(){

	# set random seed
	set.seed(.TestSeed)
	# define some dimensions to use as template
	n <- 20; m <- 10; r <- 3;
	# generate matrices
	w <- rmatrix(n, r); h <- rmatrix(r, m)

	M <- nmfModel(r, n, m)

	# check errors
	a <- M
	checkException({dimnames(a) <- 1:n}, 'set to vector')
	checkException({dimnames(a) <- list(seq(n-1))}, 'Error of wrong dimension (nrow-1)')
	checkException({dimnames(a) <- list(seq(n+1))}, 'Error of wrong dimension (nrow+1)')

	# check with no elements
	msg <- function(...) paste('Dimnames with 2 elements -', ...)
	a <- M
	check.dimnames(a, NULL, 'No dimnames => NULL')
	check.dimnames({dimnames(a) <- NULL; a}, NULL, msg('set to NULL'))
	check.dimnames({dimnames(a) <- list(); a}, NULL, msg('set to list()'))

	# check with one elements
	msg <- function(...) paste('Dimnames with 1 element -', ...)
	a <- M
	dn <- list(letters[1:nrow(a)])
	dn.name <- setNames(dn, 'rows')
	check.dimnames({a <- M; dimnames(a) <- dn; a}, c(dn, list(NULL, NULL)), msg('Set dimnames'))
	check.dimnames({a <- M; dimnames(a) <- dn.name; a}, c(dn.name, list(NULL, NULL)), msg('Set with names'))

	check.dimnames({a <- M; rownames(a) <- dn[[1]]; a}, c(dn, list(NULL, NULL)), msg('Set rownames'))
	check.dimnames({a <- M; colnames(a) <- letters[1:ncol(a)]; a}, list(NULL, letters[1:ncol(a)], NULL), msg('Set colnames'))
	check.dimnames({a <- M; basisnames(a) <- letters[1:nbasis(a)]; a}, list(NULL, NULL, letters[1:nbasis(a)]), msg('Set basisnames'))
	check.dimnames({dimnames(a) <- NULL; a}, NULL, msg('Reset to NULL'))

	# check with two elements
	msg <- function(...) paste('Dimnames with 2 elements -', ...)
	a <- M
	dn <- list(letters[1:nrow(a)], letters[seq(nrow(a)+1, nrow(a)+ncol(a))])
	dn.name <- setNames(dn, c('rows', 'cols'))
	check.dimnames({dimnames(a) <- dn; a}, c(dn, list(NULL)), msg('Set dimnames'))
	check.dimnames({dimnames(a) <- NULL; a}, NULL, msg('Reset to NULL'))
	check.dimnames({dimnames(a) <- dn.name; a}, c(dn.name, list(NULL)), msg('Set with names'))
	check.dimnames({dimnames(a) <- NULL; a}, NULL, msg('Reset to NULL (2)'))

	# check with three elements
	msg <- function(...) paste('Dimnames with 3 elements -', ...)
	a <- M
	dn <- list(letters[1:nrow(a)], letters[seq(nrow(a)+1, nrow(a)+ncol(a))], letters[seq(nrow(a)+ncol(a)+1, nrow(a)+ncol(a)+nbasis(a))])
	dn.name <- setNames(dn, c('rows', 'cols', 'basis'))
	check.dimnames({dimnames(a) <- dn; a}, dn, msg('Set dimnames'))
	check.dimnames({dimnames(a) <- NULL; a}, NULL, msg('Reset to NULL'))
	check.dimnames({dimnames(a) <- dn.name; a}, dn.name, msg('Set with names'))
	check.dimnames({dimnames(a) <- NULL; a}, NULL, msg('Reset to NULL (2)'))
}

#' Unit test for accessor method: \code{basis}
test.basis <- function(){

	# define some dimensions to use as template
	n <- 50; m <- 10; r <- 3;

	# create an empty object
	a <- nmfModel(r);

	# get factor W
	checkTrue(is.same(basis(a), a@W), "Method 'basis' correctly returns slot W");

	# set factor W
	W.ext <- matrix(1, n, r)
	basis(a) <- W.ext
	checkIdentical(a@W, W.ext, "Method 'basis<-' correctly sets slot W");
	#checkException(basis(a) <- matrix(1, n, r+1), "Error if setting basis with a matrix of incompatible dimensions");
}

#' Unit test for accessor method: \code{coef}
test.coef <- function(){

	# define some dimensions to use as template
	n <- 50; m <- 10; r <- 3;

	# create an empty object
	a <- nmfModel(r);

	# get factor H
	checkTrue(is.same(coef(a), a@H), "Method 'coef' correctly returns slot H");

	# set factor H
	ext <- matrix(1, r, m)
	coef(a) <- ext
	checkIdentical(a@H, ext, "Method 'coef<-' correctly sets slot H");
	#checkException(coef(a) <- matrix(1, r+1, m), "Error if setting coef with a matrix of incompatible dimensions");
}

test.NMF.rnmf <- function(){

	# define some dimensions to use as template
	n <- 50; m <- 10; r <- 3;

	# create an empty NMF object
	a <- nmfModel(r)

	# check parameter validity checks
	set.seed(.TestSeed)
	checkException(rnmf(a, as.numeric(NA)), 'Error thrown if single NA value')
	checkException(rnmf(a, as.numeric(c(1,NA))), 'Error thrown if some NA value')
	checkException(rnmf(a, c(1,2,3)), 'Error thrown if some length greater than 2')
	checkException(rnmf(a, numeric()), 'Error thrown if some length is 0')

	# create a random NMF of given dimension
	set.seed(.TestSeed)
	a <- rnmf(r, n, m)
	checkPlot(basicHM(basis(a)), 'Random NMF basis (target dimension)')
	checkPlot(basicHM(coef(a)), 'Random NMF coef (target dimension)')
	# check the NMF dimensions
	checkEquals(nrow(a), n, 'number of rows matches target dimension')
	checkEquals(ncol(a), m, 'number of columns matches target dimension')
	checkEquals(nbasis(a), r, 'number of basis matches target dimension')
	# check equivalence of calls
	set.seed(.TestSeed)
	checkIdentical(a, rnmf(r, c(n, m)), "calling with numeric target of length 2 is equivalent to separate dimensions")
	set.seed(.TestSeed)
	checkIdentical(a, rnmf(r, n, m), "calling with numeric target of length 2 is equivalent to separate dimensions")

	# create a random NMF based on a template NMF
	a <- nmfModel(r, n, m)
	set.seed(.TestSeed)
	b <- rnmf(a)
	checkPlot(basicHM(basis(b)), 'Random NMF basis (target NMF)')
	checkPlot(basicHM(coef(b)), 'Random NMF coef (target NMF)')
	# check the NMF dimensions
	checkEquals(nrow(a), nrow(b), 'number of rows matches NMF target')
	checkEquals(ncol(a), ncol(b), 'number of columns matches NMF target')
	checkEquals(nbasis(a), nbasis(b), 'number of basis matches NMF model')

	# create a random NMF based on a target ExpressionSet
	set.seed(.TestSeed)
	max.entry <- 100
	V <- new('ExpressionSet', exprs=rmatrix(n, m, min=0, max=max.entry))
	a <- nmfModel(r, n, m)
	check.object(a <- rnmf(a, V), n, m, r, 'NMFobject + target ExpressionSet')
	check.dimnames(a, c(dimnames(exprs(V)), list(NULL)), 'NMFobject + target ExpressionSet')
	check.object(a <- rnmf(r, V), n, m, r, 'rank + target ExpressionSet')
	check.dimnames(a, c(dimnames(exprs(V)), list(NULL)), 'rank + target ExpressionSet')

	# create a random NMF based on a target matrix
	set.seed(.TestSeed)
	max.entry <- 100
	V <- rmatrix(n, m, min=0, max=max.entry)
	a <- nmfModel(r, n, m)
	a <- rnmf(a, V)
	checkPlot(basicHM(basis(a)), 'Random NMF basis (target matrix)')
	checkPlot(basicHM(coef(a)), 'Random NMF coef (target matrix)')
	# check the NMF dimensions
	checkEquals(nrow(a), n, 'number of rows matches matrix target')
	checkEquals(ncol(a), m, 'number of columns matches matrix target')
	checkEquals(nbasis(a), r, 'matrix target: number of basis matches NMF model')
	# check maximum value
	msg <- function(...) paste('Set max in target matrix -', ...)
	.check_max <- function(x, max.entry){
		checkTrue( max(basis(a)) <= max.entry, msg("Basis maximum entry is OK (<=)"))
		checkTrue( max(basis(a)) >= max.entry/2, msg("Basis maximum entry is OK (>=)"))
		checkTrue( max(coef(a)) <= max.entry, msg("Coef maximum entry is OK (<=)"))
		checkTrue( max(coef(a)) >= max.entry/2, msg("Coef maximum entry is OK (>=)"))
	}
	.check_max(a, max.entry)
	# check dimnames
	dn <- list(rows=letters[1:nrow(V)], cols=letters[seq(25-ncol(V)+1,25)])
	dimnames(V) <- dn
	check.dimnames(rnmf(a, V), c(dn, list(NULL)), "rnmf on target matrix with dimnames: dimnames are passed")
	check.dimnames(rnmf(a, V, use.dimnames=FALSE), NULL, "rnmf on target matrix with dimnames and use.dimnames=FALSE: dimnames are not passed")

	# setting maximum on NMFOffset model
	msg <- function(...) paste('Set max by argument -', ...)
	set.seed(.TestSeed)
	a <- rnmf(r, V, model='NMFOffset')
	.check_max(a, max.entry)

	# setting maximum entry by argument
	msg <- function(...) paste('Set max by argument -', ...)
	set.seed(.TestSeed)
	max.entry <- 5
	a <- rnmf(r, n, m, dist=list(max=max.entry))
	.check_max(a, max.entry)

}

#' Tests synthetic data generation
test.syntheticNMF <- function(){

	# define sizes
	n <- 100; m <- 20; r <- 3

	# standard
	set.seed(.TestSeed)
	d <- syntheticNMF(n, r, m)
	checkPlot(basicHM(d), 'Synthetic data plain')

	# with offset
	set.seed(.TestSeed)
	n.offset <- 15
	o <- c(rep(1, n.offset), rep(0, n-n.offset))
	d <- syntheticNMF(n, r, m, offset=o)
	# the function should throw an error when called with an offset of wrong length
	checkException(syntheticNMF(n, r, m, offset=o[-1]))
	checkPlot(basicHM(d), 'Synthetic data offset')

	# with noise
	set.seed(.TestSeed)
	d <- syntheticNMF(n, r, m, noise=TRUE)
	checkPlot(basicHM(d), 'Synthetic data with noise')

	# with offset and noise
	set.seed(.TestSeed)
	d <- syntheticNMF(n, r, m, offset=o, noise=TRUE)
	checkPlot(basicHM(d), 'Synthetic data with offset and noise')
}

# Sparseness
test.sparseness <- function(){

	# local function to check bounds of sparseness
	checkBounds <- function(s){
		checkTrue(s >= 0, 'greater than 0')
		checkTrue(s <= 1, 'lower than 1')
	}

	# test with a perfectly non-sparse vector (constant vector)
		x <- rep(1, 100)
		s <- sparseness(x)

		# check values
		checkBounds(s)
		checkEqualsNumeric(s, 0, 'should be 0')

	# test with a perfectly sparse vector
		x <- c(1, rep(0, 100))
		s <- sparseness(x)

		# check values
		checkBounds(s)
		checkEqualsNumeric(s, 1)

	# define sizes
	n <- 100; m <- 20; r <- 3

	# test with a random matrix (not necessarly positive)
		set.seed(.TestSeed)
		V <- matrix(rnorm(n*m), n, m)
		s <- sparseness(V)
		#check values
		checkBounds(s)

	# test with a random NMF object
		a <- nmfModel(r, V)
		set.seed(.TestSeed)
		a <- rnmf(a, V)
		s <- sparseness(a)
		# check return vector
		checkTrue( length(s) == 2, "Method 'sparseness' returns a 2-length vector" )
		#check values
		checkBounds(s[1])
		checkBounds(s[2])
}

# Clusters
test.predict <- function(){

	# define some dimensions
	n <- 100; m <- 20; r <- 3

	.msg <- NULL
	mess <- function(...) paste(.msg, ':', ...)

	# test on a known matrix
		.msg <- 'Artificial matrix'
		V <- matrix(c( c(1, rep(0,n-1)), c(0, 1, rep(0,n-2)), rep(c(0,0,1, rep(0, n-3)), m-2) ) , n, m)
		# compute clusters
		res <- .predict.nmf(t(V))
		# check the result
		checkEquals(res, as.factor(c(1, 2, rep(3, m-2))), mess('Return known clusters'))

	# test on a random matrix
		.msg <- 'Random matrix'
		set.seed(.TestSeed)
		V <- matrix(sapply(sample(n), function(i){x <- rep(0, n); x[i] <- 1; x}), n, m)

		# compute clusters
		res <- .predict.nmf(V)
		# check the result
		checkTrue( is.factor(res), mess('Result is a factor'))
		checkTrue( length(res) == nrow(V), mess('Result is the right size' ))
		checkTrue( nlevels(res) == ncol(V), mess('Result has the right number of levels' ))

	# test on a random NMF
		.msg <- 'NMF model'
		a <- nmfModel(r, V)
		set.seed(.TestSeed)
		a <- rnmf(a)

		res <- predict(a, 'samples')
		# check the result
		checkTrue( is.factor(res), mess('Result is a factor'))
		checkTrue( length(res) == ncol(a), mess('Result has right size' ))
		checkTrue( nlevels(res) == nbasis(a), mess('Result has right number of levels' ))

	# factor
	.msg <- 'Factor'
		res <- predict(a, 'features')
		# check the result
		checkTrue( is.factor(res), mess('Result is a factor'))
		checkTrue( length(res) == nrow(a), mess('Result has right size' ))
		checkTrue( nlevels(res) == nbasis(a), mess('Result has right number of levels' ))

}

# Purity
test.purity <- function(){

	# local function to check bounds of purity
	checkBounds <- function(x){
		checkTrue(x >= 0, 'greater than 0')
		checkTrue(x <= 1, 'lower than 1')
	}

	# generate factor
	x <- as.factor(c(rep(1,5), rep(2,10), rep(3,15)))

	# compute perfect clustering
	p <- purity(x, x)
	checkBounds(p)
	checkEqualsNumeric(p, 1)

	# compute random clustering
	set.seed(.TestSeed)
	p <- purity(as.factor(sample(x)), x)
	checkBounds(p)
}

# Entropy
test.entropy <- function(){

	# local function to check bounds of entropy
	checkBounds <- function(x){
		checkTrue(x >= 0, 'greater than 0')
		checkTrue(x <= 1, 'lower than 1')
	}

	# generate factor
	x <- as.factor(c(rep(1,5), rep(2,10), rep(3,15)))

	# comppute perfect entropy
	e <- entropy(x, x)
	checkBounds(e)
	checkEqualsNumeric(e, 0)

	# compute random clustering
	set.seed(.TestSeed)
	e <- entropy(as.factor(sample(x)), x)
	checkBounds(e)

}

#' Tests the distance method
test.deviance <- function(){

	# define some dimensions and matrices
	n <- 10; m <- 5;
	set.seed(.TestSeed)
	y <- rmatrix(n, m) # random matrix 1
	x <- rnmf(nmfModel(3, y))

	# check default is no computation
	checkEquals( deviance(x, y), as.numeric(NA), 'With no method: NA')
	# check error if undefined method
	checkException( deviance(x, y, 'toto'), 'Error if undefined method')

	# check if works when passing a function name
		norm1 <- function(x, y){ sum(abs(fitted(x)-y)) } # local function
		# generate a random function name
		funname <- paste('test', paste(sample(1:9, 20, replace=TRUE), collapse=''), sep='.')
		assign(funname, norm1, envir=.GlobalEnv)
		on.exit(rm(list=funname, envir=.GlobalEnv), add=TRUE)
		#TODO: make it work without assigning in .GloablEnv
		checkTrue( deviance(x, y, norm1) > 0, 'Works with a user-defined function in .GlobalEnv')
		checkTrue( deviance(x, y, funname) > 0, 'Works with name of a user-defined function .GlobalEnv')

	# check euclidean distance
		meth <- 'euclidean'
		#checkEqualsNumeric( deviance(x, x, meth), 0, 'Euclidean: separation')
		checkTrue( deviance(x, y, meth) > 0, 'Euclidean: positive')
		checkEqualsNumeric( deviance(x, y, meth), sum((fitted(x) - y)^2)/2, 'Euclidean: OK')

	# check Kullback-Leibler divergence
		meth <- 'KL'
		#checkEqualsNumeric( deviance(x, x, meth), 0, 'KL: separation')
		checkTrue( deviance(x, y, meth) > 0, 'KL: positive')
		#checkTrue( deviance(x, y, meth) != deviance(y, x, meth), 'KL: not symetric')
		# check if not infinite when there is some zero entries in the target matrix
		z <- y; z[1,] <- 0
		checkTrue( deviance(x, z, meth) != Inf, 'Ok if some zeros in the target' )
		# check if infinite when there is some zero entries in the second term
		z <- x; basis(z)[1,] <- 0
		checkIdentical( deviance(z, y, meth), Inf, 'Infinite if some zeros in the estimate' )
}

#' Tests the connectivity method
test.connectivity <- function(){
	# define some dimensions to use as template
	n <- 50; m <- 10; r <- 3;

	# build random NMF
	set.seed(.TestSeed)
	a <- nmfModel(r, c(n,m))
	a <- rnmf(a)
	con <- connectivity(a)

	# check properties of the connectivity matrix
	checkTrue( is.matrix(con), 'The result is a matrix')
	checkTrue( all(con %in% c(0,1)), 'All entries are 0 or 1')
	checkTrue( all(t(con) == con) , 'The connectivity matrix is symmetric')

}

#' test subsetting function
test.subset <- function(){

	# create a random NMF object
	n <- 30; r <- 5; p <- 20
	a <- nmfModel(r, n, p)
	a <- rnmf(a)

	# fake subset
	checkTrue(identical(a[], a), "subset [] is OK (identical)")
	checkTrue(identical(a[,], a), "subset [,] is OK (identical)")
	checkTrue(identical(a[TRUE,], a), "subset [TRUE,] is OK (identical)")
	checkTrue(identical(a[,TRUE], a), "subset [,TRUE] is OK (identical)")
	checkTrue(identical(a[TRUE,TRUE], a), "subset [TRUE,TRUE] is OK (identical)")
	checkTrue(identical(a[,,TRUE], a), "subset [,,TRUE] is OK (identical)")
	checkTrue(identical(a[TRUE,TRUE,TRUE], a), "subset [TRUE,TRUE,TRUE] is OK (identical)")
	# with NULL
	checkTrue(identical(a[NULL,], a[0,]), "subset [NULL,] is OK")
	checkTrue(identical(a[,NULL], a[,0]), "subset [,NULL] is OK")
	checkTrue(identical(a[NULL,NULL], a[0,0]), "subset [NULL,NULL] is OK")
	checkTrue(identical(a[NULL,NULL,NULL], a[0,0,0]), "subset [NULL,NULL,NULL] is OK")
	checkException(a[,,], "Error when called with [,,]")

	# subset on features
	checkEquals(dim(a[1,]), c(1, p, r), "subset 1 feature is OK (dim)")
	checkEquals(basis(a[5,]), basis(a)[5,, drop=FALSE], "subset 1 feature is OK (basis)")
	checkEquals(coef(a[5,]), coef(a), "subset 1 feature is OK (coef)")
	checkEquals(a[5,,drop=TRUE], basis(a)[5,, drop=TRUE], "subset 1 feature dropping is OK (return basis)")

	checkEquals(dim(a[1:10,]), c(10, p, r), "subset more than 1 feature is OK (dim)")
	checkEquals(basis(a[1:10,]), basis(a)[1:10,, drop=FALSE], "subset more than 1 feature is OK (basis)")
	checkEquals(coef(a[1:10,]), coef(a), "subset more than 1 feature is OK (coef)")
	checkEquals(a[1:10,,drop=TRUE], basis(a)[1:10,, drop=TRUE], "subset more than 1 feature dropping is OK (return basis)")

	# subset on samples
	checkEquals(dim(a[,1]), c(n, 1, r), "subset 1 sample is OK (dim)")
	checkEquals(coef(a[,5]), coef(a)[,5, drop=FALSE], "subset 1 sample is OK (coef)")
	checkEquals(basis(a[,1]), basis(a), "subset 1 sample is OK (basis)")
	checkEquals(a[,5,drop=TRUE], coef(a)[,5, drop=TRUE], "subset 1 sample dropping is OK (return coef)")

	checkEquals(dim(a[,1:10]), c(n, 10, r), "subset more then 1 sample is OK (dim)")
	checkEquals(coef(a[,1:10]), coef(a)[,1:10, drop=FALSE], "subset more than 1 sample is OK (coef)")
	checkEquals(basis(a[,1:10]), basis(a), "subset more than 1 sample is OK (basis)")
	checkEquals(a[,1:10,drop=TRUE], coef(a)[,1:10, drop=TRUE], "subset more than 1 sample dropping is OK (return coef)")

	# subset on basis
	checkEquals(dim(a[,,1]), c(n, p, 1), "subset 1 basis is OK (dim)")
	checkEquals(coef(a[,,3]), coef(a)[3,, drop=FALSE], "subset 1 basis is OK (coef)")
	checkEquals(basis(a[,,3]), basis(a)[,3, drop=FALSE], "subset 1 basis is OK (basis)")
	checkTrue(identical(a[,,3,drop=TRUE], a[,,3,drop=TRUE]), "subset 1 basis dropping is OK (do nothing)")

	checkEquals(dim(a[,,2:4]), c(n, p, 3), "subset more than 1 basis is OK (dim)")
	checkEquals(coef(a[,,2:4]), coef(a)[2:4, , drop=FALSE], "subset more than 1 basis is OK (coef)")
	checkEquals(basis(a[,,2:4]), basis(a)[, 2:4, drop=FALSE], "subset more than 1 basis is OK (basis)")
	checkTrue(identical(a[,,2:4,drop=TRUE], a[,,2:4,drop=FALSE]), "subset more than 1 basis dropping is OK (do nothing)")

	checkEquals(dim(a[NULL]), c(n, p, 0), "subset basis NULL is OK (dim)")
    checkIdentical(a[2], basis(a)[,2], "subset with single index + drop missing returns single basis as vector")
	checkIdentical(a[2, drop = FALSE], a[,,2], "subset with single index with drop=FALSE returns the complete NMF object")
	checkIdentical(a[2, drop=TRUE], basis(a)[,2, drop=TRUE], "subset with single index + drop=TRUE returns single basis as vector")

	checkTrue(is.nmf(a[2:3]), "subset with single vector index returns NMF object")
	checkEquals(basis(a[2:3]), basis(a)[,2:3], "subset with single vector index returns subset of NMF object")
	checkEquals(a[2:3, drop=TRUE], basis(a)[,2:3, drop=TRUE], "subset with single vector index + dropping returns correct matrix if length > 1")
	checkIdentical(a[2:3, drop=FALSE], a[,,2:3], "subset with single vector index + NOT dropping returns correct matrix if length > 1")

	# subset on both features and samples
	checkEquals(dim(a[1,1]), c(1, 1, r), "subset 1 feature x 1 sample is OK (dim)")
	checkEquals(coef(a[3,5]), coef(a)[,5, drop=FALSE], "subset 1 feature x 1 sample is OK (coef)")
	checkEquals(basis(a[3,5]), basis(a)[3,, drop=FALSE], "subset 1 feature x 1 sample is OK (basis)")

	checkEquals(dim(a[10:19,5:11]), c(10, 7, r), "subset more than 1 feature x sample is OK (dim)")
	checkEquals(coef(a[10:19,5:11]), coef(a)[,5:11], "subset more than 1 feature x sample is OK (coef)")
	checkEquals(basis(a[10:19,5:11]), basis(a)[10:19,], "subset more than 1 feature x sample is OK (basis)")
}

#' Tests for get/set misc elements in NMF models
test.misc <- function(){

	x <- nmfModel()
	m <- slot(x, 'misc')
	checkTrue(is.list(m) && length(m)==0L, 'On empty model misc is an empty list')
	checkEquals(misc(x), m, 'On empty model misc() returns an empty list')
	x$a <- 3
	checkEquals(slot(x, 'misc'), list(a=3), "Setting misc with $ works")
	checkEquals(misc(x), list(a=3), "Getting misc with misc() works")
	checkEquals(x$a, 3, "Getting misc with $ works")

	checkEquals(misc(list()), NULL, 'On empty list misc is NULL')
	checkEquals(misc(list(misc=4)), 4, 'On list with a `misc` element, misc() returns the element')
	checkEquals(misc(1), NULL, 'On non list object misc() is NULL')
	a <- 1
	attr(a, 'misc') <- 2
	checkEquals(misc(a), 2, 'On non list object with `misc` attribute, misc() returns the attribute')

}


# Packages
library(tidyverse)
library(magrittr)
library(ggplot2)
library(geomnet)
library(ggnetwork)
library(sf)
library(ggmap)
library(sp)
library(rgdal)
library(leaflet)
library(xlsx)
library(data.table)
library(mapview)
library(mapedit)
library(leaflet.extras)
library(here)
library(matlib)
library(nngeo)
library(writexl)

source(here("/R/functions.r"))

avala_points <- readxl::read_xlsx(path = here::here("Data/Input/With_observations/Avala/Avala_observations.xlsx"), sheet = "Points", col_types = c("numeric", "text", "numeric", "numeric", "logical", "logical", "logical"))
avala_obs <- readxl::read_xlsx(path = here::here("Data/Input/With_observations/Avala/Avala_observations.xlsx"), sheet = "Observations", col_types = c("text", "text", "numeric", "numeric", "numeric", "numeric", "numeric", "numeric", "numeric"))
avala <- surveynet2DAdjustment_Import_fun.xlsx(points = avala_points, observations = avala_obs, dest_crs = 3857)

# Creating Hz, Vz in decimal degrees and computing horizontal distances and filtering observations to "S" points.
avala[[2]] <- mutate(avala[[2]], Hz = HzD + HzM/60 + HzS/3600, Vz = VzD + VzM/60 + VzS/3600, HD = SD*sin(Vz*pi/180)) %>%
  dplyr::filter(To %in% c("S1","S2","S3","S4","S5","S6","S7"))

avala[[2]]

# Zadatak 1

ni <- function(pt1_coords, pt2_coords, type = list("dec", "dms", "rad"), axes = c("Easting", "Northing")){
  ## check if the axis were set:
  if(length(axes) < 2) stop("axes must be defined with Easting and Northing")
  if(!any(axes %in% list("Northing", "Easting"))){ stop(paste(type, "axes must be North and East.")) }

  north_ind <- which(axes == "Northing")
  east_ind <- which(axes == "Easting")

  ## check if the type exists:
  if(length(type) > 1){ type <- type[[1]] }
  if(!any(type %in% list("dms", "dec", "rad"))){ stop(paste(type, "method not available.")) }

  ## body
  east1 <- pt1_coords[east_ind]
  north1 <- pt1_coords[north_ind]
  east2 <- pt2_coords[east_ind]
  north2 <- pt2_coords[north_ind]
  deast <- as.numeric(east2 - east1)
  dnorth <- as.numeric(north2 - north1)
  atg <- ifelse(deast < 0, atan(dnorth/deast)*180/pi + 180, atan(dnorth/deast)*180/pi)
  ang <- ifelse(atg < 0, atg + 360, atg)

  deg <- floor(ang); minut <- floor((ang-deg)*60); sec <- ((ang-deg)*60-minut)*60

  if(type == "dms"){
    ang <- c(deg, minut, sec)
    names(ang) <- c("deg","min","sec")
  }
  if(type == "rad"){
    ang <- ang*pi/180
  }

  return(ang)
}

#points = avala_points; observations = avala_obs

import_surveynet2D <- function(points = points, observations = observations, dest_crs = NA){

  # Create geometry columns for points
  if (is.na(dest_crs)){
    dest_crs <- 3857
  }

  observations$x_station <- points$x[match(observations$from, points$Name)]
  observations$y_station <- points$y[match(observations$from, points$Name)]
  observations$x_obs.point <- points$x[match(observations$to, points$Name)]
  observations$y_obs.point <- points$y[match(observations$to, points$Name)]

  points <- points %>% as.data.frame() %>% sf::st_as_sf(coords = c("x","y")) %>% sf::st_set_crs(dest_crs)

  observations <- observations %>% dplyr::mutate(Hz = HzD + HzM/60 + HzS/3600,
                                                 Vz = VzD + VzM/60 + VzS/3600,
                                                 distance = (!is.na(.$HD) | !is.na(.$SD)),
                                                 direction = !is.na(Hz))

  observations <- as.data.table(observations) %>% dplyr::mutate(id = seq.int(nrow(.))) %>% split(., f = as.factor(.$id)) %>%
        lapply(., function(row) {lmat <- matrix(unlist(row[14:17]), ncol = 2, byrow = TRUE)
                                         st_linestring(lmat)}) %>%
        sf::st_sfc() %>%
        sf::st_sf('ID' = seq.int(nrow(observations)), observations, 'geometry' = .)

  # Creating list
  survey_net <- list(points, observations = observations)
  return(survey_net)
}

survey.net <- avala
st.survey.net <- survey.net[[2]] %>% dplyr::filter(direction) %>% sf::st_drop_geometry() %>% dplyr::filter(from == "S4")

fdir_st <- function(st.survey.net, units.dir = "sec", axes = c("Easting", "Northing")){
  units.table <- c("sec" = 3600, "min" = 60, "deg" = 1)
  st.survey.net <- st.survey.net %>% split(., f = as.factor(.$to)) %>%
    lapply(., function(x) {x$ni = ni(pt1_coords = as.numeric(x[, c("y_station", "x_station")]), pt2_coords = as.numeric(x[, c("y_obs.point", "x_obs.point")]), type = "dec", axes = c("Easting", "Northing")); return(x)}) %>%
    do.call(rbind,.) %>%
    dplyr::mutate(z = Hz-ni) %>%
    dplyr::arrange(ID)
  st.survey.net$z <- ifelse(st.survey.net$z < 0, st.survey.net$z + 360, st.survey.net$z)
  z0_mean <- mean(st.survey.net$z)
  st.survey.net$Hz0 <- z0_mean + st.survey.net$ni
  st.survey.net$Hz0 <- ifelse(st.survey.net$z > 360, st.survey.net$Hz0 - 360, st.survey.net$Hz0)
  f <- (st.survey.net$Hz0 - st.survey.net$Hz)
  f <- ifelse(f >= 360 | f >= 355, f - 360, f)*units.table[units.dir]
  return(f)
}

#fdir_st(st.survey.net = st.survey.net, units = "sec")

fmat <- function(survey.net, units.dir = "sec", units.dist = "mm", axes = c("Easting", "Northing")){
  f_dir <- survey.net[[2]] %>% dplyr::filter(direction) %>% st_drop_geometry() %>% split(.,.$from) %>%
           lapply(., function(x) fdir_st(x, units.dir = units.dir)) %>%
           do.call(c, .) %>% as.numeric()
  dist.units.table <- c("mm" = 1000, "cm" = 100, "m" = 1)
  survey.net[[2]] <- survey.net[[2]] %>% dplyr::filter(distance) %>% st_drop_geometry() %>%
    dplyr::mutate(dist0 = sqrt((x_station-x_obs.point)^2+(y_station-y_obs.point)^2))
  f_dist <- (survey.net[[2]]$dist0 - survey.net[[2]]$HD)*dist.units.table[units.dist]
  return(c(f_dir, f_dist))
}

# Wmat je ista, samo je promenjen naziv standarda. Stavljeni su "sd_Hz" i "sd_dist".
Wmat <- function(survey.net, apriori = 1){
  #TODO: Omoguciti zadavanje i drugih kovariacionih formi izmedju merenja.
  obs.data <- rbind(survey.net[[2]] %>% st_drop_geometry() %>%
                      dplyr::filter(direction) %>%
                      dplyr::select(from, to, standard = sd_Hz) %>%
                      dplyr::mutate(type = "direction"),
                    survey.net[[2]] %>% st_drop_geometry() %>%
                      dplyr::filter(distance) %>%
                      dplyr::select(from, to, standard = sd_dist) %>%
                      dplyr::mutate(type = "distance")
  )
  return(diag(apriori^2/obs.data$standard^2))
}

Amat <- function(survey.net, units, axes = c("Easting", "Northing")){

  A_dir <- survey.net[[2]] %>% dplyr::filter(direction) %>% st_coordinates() %>% as.data.frame() %>% mutate_at(vars(L1), as.factor) %>%
    split(., .$L1) %>%
    lapply(., function(x) coef_p(pt1 = x[1, 1:2], pt2 = x[2, 1:2], pts = st_coordinates(survey.net[[1]][, 1:2]), units = units, axes = axes)) %>%
    do.call(rbind, .)

  A_dist <- survey.net[[2]] %>% dplyr::filter(distance) %>% st_coordinates() %>% as.data.frame() %>% mutate_at(vars(L1), as.factor) %>%
    split(., .$L1) %>%
    lapply(., function(x) coef_d(pt1 = x[1, 1:2], pt2 = x[2, 1:2], pts = st_coordinates(survey.net[[1]][, 1:2]), units = units, axes = axes)) %>%
    do.call(rbind, .)

  Z_mat <- survey.net[[2]] %>% dplyr::filter(direction) %>%
    tidyr::spread(key = from, value = direction, fill = FALSE) %>%
    dplyr::select(survey.net[[1]]$Name[!survey.net[[1]]$Point_object]) %>%
    st_drop_geometry() %>%
    as.matrix()*1

  fix <- fix.params(net.points = survey.net[[1]], axes = axes)

  rest_mat <- matrix(0, nrow = dim(A_dist)[1], ncol = dim(Z_mat)[2])

  A <- cbind(rbind(A_dir, A_dist)[, !fix], rbind(Z_mat, rest_mat))

  if(("Easting" == axes)[1]) {sufix <- c("dE", "dN")} else {sufix <- c("dN", "dE")}
  colnames(A) <- c(paste(rep(survey.net[[1]]$Name, each = 2), rep(sufix, length(survey.net[[1]]$Name)), sep = "_")[!fix], paste(colnames(Z_mat), "z", sep = "_"))
  return(A)
}

################### ISPIT 14.6.2019. ########################################################

z_points <- readxl::read_xlsx(path = here::here("Data/Input/With_observations/Zadatak 3/Zadatak_1462019.xlsx"), sheet = "Points", col_types = c("numeric", "text", "numeric", "numeric", "logical", "logical", "logical"))
z_obs <- readxl::read_xlsx(path = here::here("Data/Input/With_observations/Zadatak 3/Zadatak_1462019.xlsx"), sheet = "Observations", col_types = c("text", "text", "numeric", "numeric", "numeric", "numeric","numeric","numeric", "numeric", "numeric","numeric", "numeric", "numeric"))
zadatak3 <- import_surveynet2D(points = z_points, observations = z_obs, dest_crs = NA)

A <- data.frame(Amat(survey.net = zadatak3, units = "mm"))
f <- data.frame(f = fmat(survey.net = zadatak3))
P <- data.frame(Wmat(survey.net = zadatak3, apriori = 5))

zadatak3.list <- list("A" = A, "f" = f, "P" = P)
write_xlsx(zadatak3.list, path = "zadatak3_design.xlsx")

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

z_points <- readxl::read_xlsx(path = here::here("Data/Input/With_observations/Zadatak 5/Zadatak_20012020.xlsx"), sheet = "Points", col_types = c("numeric", "text", "numeric", "numeric", "logical", "logical", "logical"))
z_obs <- readxl::read_xlsx(path = here::here("Data/Input/With_observations/Zadatak 5/Zadatak_20012020.xlsx"), sheet = "Observations", col_types = c("text", "text", "numeric", "numeric", "numeric", "numeric","numeric","numeric", "numeric", "numeric","numeric", "numeric", "numeric"))
zadatak5 <- import_surveynet2D(points = z_points, observations = z_obs, dest_crs = NA)

results <- adjust.snet(adjust = TRUE, survey.net = zadatak5, sd.apriori = 1, prob = 0.95, result.units = "mm", ellipse.scale = 1, teta.unit = "deg", units.dir = "sec", units.dist = "mm", use.sd.estimated = TRUE, all = TRUE)

# adjust = TRUE; survey.net = zadatak5; sd.apriori = 5; prob = 0.95; result.units = "mm"; ellipse.scale = 1; teta.unit = "deg"; units.dir = "sec"; units.dist = "mm"; use.sd.estimated = TRUE; all = TRUE

results$observations$

z_points <- readxl::read_xlsx(path = here::here("Data/Input/With_observations/Zadatak 2/Zadatak_22.xlsx"), sheet = "Points", col_types = c("numeric", "text", "numeric", "numeric", "logical", "logical", "logical"))
z_obs <- readxl::read_xlsx(path = here::here("Data/Input/With_observations/Zadatak 2/Zadatak_22.xlsx"), sheet = "Observations", col_types = c("text", "text", "numeric", "numeric", "numeric", "numeric","numeric","numeric", "numeric", "numeric","numeric", "numeric", "numeric"))
zadatak2 <- import_surveynet2D(points = z_points, observations = z_obs, dest_crs = NA)

A <- Amat(survey.net = zadatak5, units = "mm")
f <- data.frame(f = fmat(survey.net = zadatak5))
P <- data.frame(Wmat(survey.net = zadatak5, sd.apriori = 5))

zadatak1.list <- list("A" = A, "f" = f, "P" = P)

write_xlsx(zadatak1.list, path = "zadatak1_design.xlsx")

# Avala

avala_points <- readxl::read_xlsx(path = here::here("Data/Input/With_observations/Avala/Avala_observations.xlsx"), sheet = "Points", col_types = c("numeric", "text", "numeric", "numeric", "logical", "logical", "logical"))
avala_obs <- readxl::read_xlsx(path = here::here("Data/Input/With_observations/Avala/Avala_observations.xlsx"), sheet = "Observations", col_types = c("text", "text", "numeric", "numeric", "numeric", "numeric","numeric","numeric", "numeric", "numeric","numeric", "numeric", "numeric")) %>%
  dplyr::filter(., to %in% c("S1","S2","S3","S4","S5","S6","S7"))

avala <- import_surveynet2D(points = avala_points, observations = avala_obs, dest_crs = 3857)
A <- Amat(survey.net = avala, units = "mm")
f <- data.frame(f = fmat(survey.net = avala))
P <- data.frame(Wmat(survey.net = zadatak1, apriori = 5))

# Makis

Makis_points <- readxl::read_xlsx(path = here::here("Data/Input/With_observations/Makis/Makis_observations.xlsx"), sheet = "Points", col_types = c("numeric", "text", "numeric", "numeric", "logical", "logical", "logical"))
Makis_obs <- readxl::read_xlsx(path = here::here("Data/Input/With_observations/Makis/Makis_observations.xlsx"), sheet = "Observations", col_types = c("text", "text", "numeric", "numeric", "numeric", "numeric","numeric","numeric", "numeric", "numeric","numeric", "numeric", "numeric"))

Makis <- import_surveynet2D(points = Makis_points, observations = Makis_obs, dest_crs = 3857)
A <- Amat(survey.net = Makis, units = "mm")
f <- data.frame(f = fmat(survey.net = Makis))
P <- data.frame(Wmat(survey.net = Makis, apriori = 5))


\name{Coauthorship network of scientists in the field of complex networks}
\docType{data}
\alias{ComplexNetCoauthor}
\alias{coauthor.net}
\alias{coauthor.truetime}
\alias{coauthor.author_id}
\title{A collaboration network between authors of papers in the field of complex networks with article time-stamps}
\description{
The dataset is collaboration network of authors of network science articles with article time-stamps. An edge between two authors represents an article in common. Time stamps denote article publication dates. The network without time-stamps was compiled by Mark Newman in May 2006 from the bibliographies of two review articles on networks, M. E. J. Newman, SIAM Review 45, 167-256 (2003) and S. Boccaletti et al., Physics Reports 424, 175-308 (2006), with a few additional references added by hand. Paul Sheridan independently supplemented the network with time-stamps and some basic metadata in June 2015. The network is undirected with monthly resolution, and contains no duplicated edges. \code{coauthor.net} contains the network. \code{coauthor.truetime} contains the real times of processed time-stamps. Finally \code{coauthor.author_id} contains author names.

Reference: M. E. J. Newman, Finding community structure in networks using the eigenvectors of matrices, Preprint physics/0605087 (2006).

The dataset with article time-stamps is available for download at \url{https://www.paulsheridan.net/files/collabnet.zip}

}
\usage{data(ComplexNetCoauthor)}
\format{\code{coauthor.net} is a matrix with 2849 rows and 3 columns. Each row is an edge with the format (author id 1, author id 2, time_stamp). \code{coauthor.truetime} is a two-column matrix whose each row is (time_stamp, real time). \code{coauthor.author_id} is a two-column matrix whose each row is (author id, author name).}
\source{https://www.paulsheridan.net/files/collabnet.zip}


# Run posterior simulation to check model fit

# Set up
source('2019-06-19-jsa-type-ch2/init/init_a.r')

# Parameters
set.seed(420) # for reproducibility

# Script

print(paste0(Sys.time(), " --- Posterior simulation for model fit"))

# Load data
files <- dir(
    dir_model_folder,
    pattern = 'count_info.data.R',
    full.names = TRUE
)

data <- read_rdump(files)

# Load zero inflated fits
load(paste0(dir_model_folder, "fit.data"))

zips <- fit; rm(fit)

# Diagnostic plots

# launch_shinystan(zips)

# Save traceplot TODO: still does not work

png(
    paste0(dir_model_folder, 'traceplot.png'),
    width = 24, height = 16,
    units = "cm", res = 150
)

traceplot(zips, pars = names(zips))

dev.off()

# Save fit
write.csv(
    summary(zips)$summary,
    paste0(dir_model_folder, 'fit.csv'),
    fileEncoding = 'UTF-8'
)

# Posterior simulations
allsim <- mclapply(1:1000, function(ii) {
    posterior_sim(data = data, model = zips)
})

# Save posterior simulations
save(allsim, file = paste0(dir_model_folder, "post.data"))

# Clear memory
rm(allsim, zips, data)


#' Uses an ARTMAP network to classify the given input data.
#'
#' This function uses an ARTMAP network to classify the given input data with
#' the specified vigilance parameter. Each sample of the data is presented to
#' the network, which classifies each sample. The function returns the
#' classification of each sample. If the classification of the sample requires
#' that a new category be created, the class for that sample is set to -1.
#' @title ARTMAP_Classify
#' @param artmap_network The trained ARTMAP network. It should be created with ARTMAP_Create_Network() and trained with ARTMAP_Learn()
#' @param data Classification data to be presented to the network. It is a matrix of size NumFeatures-by-NumSamples.
#' @return Vector of size NumSamples that holds the class in which the ARTMAP network placed each sample.
#' @export
ARTMAP_Classify=function(artmap_network, data)
{
    # Make sure the user specifies the input parameters.
  if(nargs() != 2)
  {
    stop('You must specify both input parameters.');
  }

  # Make sure that the data is appropriate for the given network.
  numFeatures = ncol(data);
  numSamples = nrow(data);

  if(numFeatures != artmap_network$numFeatures)
  {
    stop('The data does not contain the same number of features as the network.');
  }

  # Make sure the vigilance is within the (0, 1] range.
  if((artmap_network$vigilance <= 0) | (artmap_network$vigilance > 1))
  {
    stop('The vigilance must be within the range (0, 1].');
  }

  # Set up the return variables.
  classification = matrix(0,numSamples,1);

  # Classify and learn on each sample.
  for (sampleNumber in 1:numSamples)
  {
    # Get the current data sample.
    currentData = data[sampleNumber,];

    # Activate the categories for this sample.
    bias = artmap_network$bias;
    categoryActivation = ART_Activate_Categories(currentData, artmap_network$weight, bias);

    # Rank the activations in order from highest to lowest.
    # This will allow us easier access to step through the categories.
    auxList = sort(-categoryActivation,index.return=TRUE);
    sortedActivations=auxList[[1]];
    sortedCategories=auxList[[2]];
    # Go through each category in the sorted list looking for the best match.
    resonance = 0;
    match = 0;
    numSortedCategories = length(sortedCategories);
    currentSortedIndex = 1;
    while(!resonance)
    {

      # If there are no categories, we return a -1.
      if(numSortedCategories == 0)
      {
        classification[sampleNumber,1] = -1;
        resonance = 1;
        break;
      }

      # Get the current category based on the sorted index.
      currentCategory = sortedCategories[currentSortedIndex];

      # Get the current weight vector from the sorted category list.
      currentWeightVector = artmap_network$weight[currentCategory,];

      # Calculate the match given the current data sample and weight vector.
      match = ART_Calculate_Match(currentData, currentWeightVector);

      # Check to see if the match is less than the vigilance.
      if(match < artmap_network$vigilance)
      {
        # If so, choose the next category in the sorted category list.
        # If the current category is the last in the list, set the
        # category for the return value as -1 and induce resonance.
        if(currentSortedIndex == numSortedCategories)
        {
          classification[sampleNumber,] = -1;
          resonance = 1;
        }
        else
        {
          currentSortedIndex = currentSortedIndex + 1;
        }
      }
      else
      {
        # Otherwise, the current category codes the input.
        # Therefore, we should induce resonance.
        classification[sampleNumber,] = artmap_network$mapField[currentCategory,];
        resonance = 1;
      }
    }
  }
  return (classification);
}


library(tidyverse)
library(scales)
library(ggthemes)
library(kableExtra)
library(plotly)
library(purrr)
library(readr)
library(scales)
library(clustertend)
library(stringr)
library("factoextra")
library("cluster")
library("NbClust")
library(flexclust)

# mozda fali koji library

options(scipen = 999)

setwd("C:\\Users\\Amir\\Desktop\\MU\\DZ3\\Code") # promijeniti path i izcitati podatke !!
fifa_data <- read.csv(file = 'data.csv', encoding = "UTF-8")

# trebamo definisati sve pozicije u igrici radi formiranja
# finalnih grupa koje ce biti ukljucene u clustering
positions <- unique(fifa_data$Position)

gk <- "GK"
defs <- positions[str_detect(positions, "B$")]
mids <- positions[str_detect(positions, "M$")]
f1 <- positions[str_detect(positions, "F$")]
f2 <- positions[str_detect(positions, "S$")]
f3 <- positions[str_detect(positions, "T$")]
f4 <- positions[str_detect(positions, "W$")]
fwds <- c(as.character(f1), as.character(f2), as.character(f3), as.character(f4))

# position grup ce predsavljati ili golman ili odbrana ili mid ili napad
fifa_data <- fifa_data %>%
  mutate(PositionGroup = ifelse(Position %in% gk, "GK", ifelse(Position %in% defs, "DEF", ifelse(Position %in% mids, "MID", ifelse(Position %in% fwds, "FWD", "Unknown")))))

# definisati cemo grupnu klasu po pitanju broja godina, koju mozemo iskoristiti
# za definisanje boljeg clustera tj. kao parametar za prikaz slicnih igraca

fifa_data <- fifa_data %>%
  mutate(AgeGroup = ifelse(Age <= 20, "20 and under", ifelse(Age > 20 & Age <=25, "21 to 25", ifelse(Age > 25 & Age <= 30, "25 to 30", ifelse(Age > 30 & Age <= 35, "31 to 35", "Over 35"))))) %>%
  mutate(AttackingRating = (Finishing + LongShots + Penalties + ShotPower + Positioning) /5)

fifa_data <- fifa_data %>%
  mutate(ValueMultiplier = ifelse(str_detect(Value, "K"), 1000, ifelse(str_detect(Value, "M"), 1000000, 1))) %>%
  mutate(ValueNumeric_pounds = as.numeric(str_extract(Value, "[[:digit:]]+\\.*[[:digit:]]*")) * ValueMultiplier)

fifa_data <- fifa_data %>%
  mutate(WageMultiplier = ifelse(str_detect(Wage, "K"), 1000, ifelse(str_detect(Wage, "M"), 1000000, 1))) %>%
  mutate(WageNumeric_pounds = as.numeric(str_extract(Wage, "[[:digit:]]+\\.*[[:digit:]]*")) * WageMultiplier)

# pregled uniformnosti rating playera iz igrice

fifa_data %>%
  ggplot(aes(x= Overall)) +
  geom_histogram(color = "white", fill = "blue") +
  ggtitle("Raspored uniformnosti overall rating-a za playere") +
  theme_fivethirtyeight()

# uniformna raspodjela rating-a za playere, shodno tome nije potrebno
# cilj tj. ideja trenutnog clusteringa jeste da na osnovu grupisanih podjela generise clustere koji daju slicne igrace u svakom clusteru
# po svojim karakteristikama
# tj. pocetni problem je da nekom manageru u igrici, omoguci da izabere igrace koje su mu potrebni sa strane pozicije ratinga, cijene etc

# ako pozicija je unkown ili ako je to golman
# uvest cemo RoomToGrow potencijal - overlal

data_cluster <- fifa_data %>%
  filter(PositionGroup != "Unknown") %>%
  filter(PositionGroup != "GK") %>%
  mutate(RoomToGrow = Potential - Overall) %>%
  select_if(is.numeric) %>%
  select(-ID, -Jersey.Number, -starts_with("Value"), - starts_with("Wage"), -starts_with("GK"), -Overall)

# hopkins, ocekivano <0.5
# hopkins(data_cluster, 50)

## ---------------------------- implementacija algoritama ----------------------------
## ---------------------------- K-means - Masovic Haris   ----------------------------

# prvo treba skalirati podatke
scaled_data <- scale(data_cluster)

set.seed(109)
# koristiti wss tj. total within sum of squares error
wss <- 0
# definisat cemo 30 clustera
for (j in 1:30) {
  km.out <- kmeans(scaled_data, centers = j, nstart = 20) # ovdje cemo koristiti custom kmeans funkciju
  wss[j] <- km.out$tot.withinss
}

wss_df <- data.frame(num_cluster = 1:30, wgss = wss)

# trebamo naci optimalno k
ggplot(data = wss_df, aes(x=num_cluster, y= wgss)) +
  geom_line(color = "lightgrey", size = 2) +
  geom_point(color = "blue", size = 4) +
  theme_fivethirtyeight() +
  labs(title = "Prikaz wss clustera za dataset, elbow metoda")

# definisemo k
k <- 8

# k-means model
wisc.km <- kmeans(scale(data_cluster), centers = k, nstart = 20)

# treba dodati za svakog igraca u kojem clusteru spada
cluster_data <- fifa_data %>%
  filter(PositionGroup != "Unknown") %>%
  filter(PositionGroup != "GK") %>%
  mutate(Cluster = wisc.km$cluster)

# izaberimo kljucne varijable
cluster_analysis <- cluster_data %>%
  select(ID, Name, Club, Age, PositionGroup, Overall, Cluster, ValueNumeric_pounds)

# prikaz clustera
table(cluster_analysis$Cluster, cluster_analysis$PositionGroup)

# novi cluster grupiran po clusteru i desc overall
cluster_arranged <- cluster_analysis %>%
  mutate(Cluster = as.character(Cluster)) %>%
  arrange(desc(Overall)) %>%
  group_by(Cluster)

# prikaz igraca, crtanje top 20 ljudi u svakom clusteru
# tj. vrstama po poziciji i dodatni filter da li odabrani player ima manje od 28g

p  <- cluster_analysis %>%
  mutate(Cluster = paste("Cluster: ", Cluster, sep = "")) %>%
  arrange(desc(Overall)) %>%
  group_by(Cluster) %>%
  slice(1:20) %>%
  mutate(Under28 = ifelse(Age < 28, "Yes", "No")) %>%
  ggplot(aes(x= Overall, y= ValueNumeric_pounds)) +
  geom_point(position = "jitter", shape = 21, color = "black", size = 2, aes(text = paste(Name, PositionGroup), fill = Under28)) +
  scale_fill_manual(values = c("blue", "red")) +
  scale_y_continuous(labels = dollar_format(prefix = "â¬")) +
  ggtitle("Najbolji playeri u svom clusteru") +
  facet_wrap(~ factor(Cluster), scales = "free", ncol = 2) +
  theme_fivethirtyeight() +
  theme(legend.position = "none", strip.text = element_text(face = "bold", size = 12))

# plot output
ggplotly(p, height = 700, width = 900)

# vraca slicne igrace u odnosu na onog koji se proslijedi
vratiSlicne <- function(playerId, kolikoIgracaSlicnih, eps) {

  cluster_filter <- cluster_analysis[cluster_analysis$ID == playerId,]$Cluster
  player_value <- cluster_analysis[cluster_analysis$ID == playerId,]$ValueNumeric_pounds
  player_group <- cluster_analysis[cluster_analysis$ID == playerId,]$PositionGroup

  cluster_analysis %>%
    filter(Cluster == cluster_filter, ValueNumeric_pounds >= (player_value * (1 - eps)) & ValueNumeric_pounds <= (player_value * (1 + eps)),
           PositionGroup == player_group, ID != playerId) %>%
    head(kolikoIgracaSlicnih)
}

# eksterni i interni kriteriji validacije

# interna validacija - sillhoute
dsModel = eclust(scaled_data, FUNcluster="kmeans", k=8, hc_metric="euclidean")
silhouette(dsModel$cluster, dist(scaled_data))
fviz_silhouette(dsModel)

# externa validacija - rand index
tabela <- table(cluster_analysis$Cluster, cluster_analysis$PositionGroup)

tabela2 <- matrix(1:16, nrow = 8, ncol = 2)
for (j in 1:8) {
  if(which.max(tabela[j,]) == 1) tabela2[j,] <- c('FWD', 'MID')
  if(which.min(tabela[j,]) == 2) tabela2[j,] <- c('DEF', 'MID')
  if(which.min(tabela[j,]) == 3) tabela2[j,] <- c('FWD', 'DEF')
}

cluster_analysis <- cluster_analysis %>%
  mutate(positionResult = ifelse(PositionGroup %in% tabela2[Cluster,], Cluster, 0))

randIndex(cluster_analysis$Cluster, cluster_analysis$positionResult)

## ---------------------------- DBSEARCH - Muminovic Amir   ----------------------------

nadjiSusjede <- function(D, P, eps) {
  # Pronadji sve tacke iz D koje su udaljeni do eps od tacke p
  susjedi = matrix(nrow = nrow(D), ncol = ncol(D));
  counter = 0
  for (i in c(1:nrow(D))) {
    currentPoint = D[i,]
    if (dist(rbind(currentPoint,P)) < eps){
      counter = counter + 1
      susjedi[counter,] = currentPoint
    }
  }

  return(susjedi[1:counter,])
}

povecajCluster <- function(D, labele, P, susjedi, C, eps, MinPts) {

  labele[P] = C

  i = 1
  while ( i <= nrow(susjedi)){
    sljedecaTacka = susjedi[i,]
    if (labele[i] == -1) {
      labele[i] = C
    }
    else if (labele[i] == 0) {
      labele[i] = C

      sljedeceSusjedstvo = nadjiSusjede(D, sljedecaTacka, eps)

      if (length(sljedeceSusjedstvo) >= MinPts) {
        susjedi = rbind(susjedi, sljedeceSusjedstvo)
      }
    }
    i = i + 1
  }
}

dbsearch <- function(D, eps, MinPts) {
  labele = replicate(nrow(D), 0)

  clusterID = 0

  for (i in c(1:nrow(D))){
    print(i)
    if (labele[i] == 0) {
      #Nadji susjede moje
      susjedi = nadjiSusjede(D, D[i,], eps)

      if (length(susjedi) < MinPts) {
        labele[i] = -1
      }
      else {
        clusterID = clusterID + 1
        povecajCluster(D, labele, i, susjedi, clusterID, eps, MinPts)
      }
    }
  }

  return(labele)
}

# Poziv fje
scaled_data <- scale(data_cluster)

library(dbscan)
kNNdistplot(scaled_data, k = length(scaled_data)+1)

res.Cluster <- dbsearch(section, 160, 150)

#Reuse

cluster_data <- fifa_data %>%
  filter(PositionGroup != "Unknown") %>%
  filter(PositionGroup != "GK") %>%
  mutate(Cluster = res$cluster)

# izaberimo kljucne varijable
cluster_analysis <- cluster_data %>%
  select(ID, Name, Club, Age, PositionGroup, Overall, Cluster, ValueNumeric_pounds)

# prikaz clustera
table(cluster_analysis$Cluster, cluster_analysis$PositionGroup)

# novi cluster grupiran po clusteru i desc overall
cluster_arranged <- cluster_analysis %>%
  mutate(Cluster = as.character(Cluster)) %>%
  arrange(desc(Overall)) %>%
  group_by(Cluster)

# prikaz igraca, crtanje top 20 ljudi u svakom clusteru
# tj. vrstama po poziciji i dodatni filter da li odabrani player ima manje od 28g

p  <- cluster_analysis %>%
  mutate(Cluster = paste("Cluster: ", Cluster, sep = "")) %>%
  arrange(desc(Overall)) %>%
  group_by(Cluster) %>%
  slice(1:20) %>%
  mutate(Under28 = ifelse(Age < 28, "Yes", "No")) %>%
  ggplot(aes(x= Overall, y= ValueNumeric_pounds)) +
  geom_point(position = "jitter", shape = 21, color = "black", size = 2, aes(text = paste(Name, PositionGroup), fill = Under28)) +
  scale_fill_manual(values = c("blue", "red")) +
  scale_y_continuous(labels = dollar_format(prefix = "â¬")) +
  ggtitle("Najbolji playeri u svom clusteru") +
  facet_wrap(~ factor(Cluster), scales = "free", ncol = 2) +
  theme_fivethirtyeight() +
  theme(legend.position = "none", strip.text = element_text(face = "bold", size = 12))

# plot output
ggplotly(p, height = 700, width = 900)

# vraca slicne igrace u odnosu na onog koji se proslijedi
vratiSlicne <- function(playerId, kolikoIgracaSlicnih, eps) {

  cluster_filter <- cluster_analysis[cluster_analysis$ID == playerId,]$Cluster
  player_value <- cluster_analysis[cluster_analysis$ID == playerId,]$ValueNumeric_pounds
  player_group <- cluster_analysis[cluster_analysis$ID == playerId,]$PositionGroup

  cluster_analysis %>%
    filter(Cluster == cluster_filter, ValueNumeric_pounds >= (player_value * (1 - eps)) & ValueNumeric_pounds <= (player_value * (1 + eps)),
           PositionGroup == player_group, ID != playerId) %>%
    head(kolikoIgracaSlicnih)
}

# eksterni i interni kriteriji validacije

# interna validacija - sillhoute
silhouette(res$cluster, dist(data_cluster))

# externa validacija - rand index
tabela <- table(cluster_analysis$Cluster, cluster_analysis$PositionGroup)

tabela2 <- matrix(1:16, nrow = 8, ncol = 2)
for (j in 1:8) {
  if(which.max(tabela[j,]) == 1) tabela2[j,] <- c('FWD', 'MID')
  if(which.min(tabela[j,]) == 2) tabela2[j,] <- c('DEF', 'MID')
  if(which.min(tabela[j,]) == 3) tabela2[j,] <- c('FWD', 'DEF')
}

cluster_analysis <- cluster_analysis %>%
  mutate(positionResult = ifelse(PositionGroup %in% tabela2[Cluster,], Cluster, 0))

randIndex(cluster_analysis$Cluster, cluster_analysis$positionResult)


require(rblm)

# ====== simulate some data ==========
model = m2.mini.new(10,serial = F)
NNs   = array(300000/model$nf,model$nf)
NNm   = array(30000/model$nf^2,c(model$nf,model$nf))
sdata = m2.mini.simulate.stayers(model,NNs)
jdata = m2.mini.simulate.movers(model,NNm)

# randomly assign firm IDs
sdata[,f1:=paste("F",j1 + model$nf*(sample.int(.N/50,.N,replace=T)-1),sep=""),j1]
sdata[,j1b:=j1]
jdata[,j1c:=j1]
jdata[,f1:=sample( unique(sdata[j1b==j1c,f1])    ,.N,replace=T),j1c]
jdata[,f2:=sample( unique(sdata[j1b==j2,f1])    ,.N,replace=T),j2]

# combine the movers and stayers, ad stands for all data:
ad = list(sdata=sdata,jdata=jdata)

# plot firm size distribution
ad$sdata[,.N,f1][,hist(N)]

# ========== clustering firms ================

# we start by extracting the measures that will be used to cluster
ms    = grouping.getMeasures(ad,"ecdf",Nw=20,y_var = "y1")
# in the previous command we tell rblm that we want to use the firm
# specific empirical measure "ecdf" with 20 points of supports and that
# the dependent variable is "y1". The firm identifier should be "f1"

# then we group we choose k=10
grps  = grouping.classify.once(ms,k = 10,nstart = 1000,iter.max = 200,step=100)

# finally we append the results to adata
ad   = grouping.append(ad,grps$best_cluster)

# ==== ESTIMATE THE MODEL (OLD CODE) ========
res = m2.mini.estimate(ad$jdata,ad$sdata,model0 = model,method = "prof")

# ==== Extract all necesserary moments for off-line estimation ===
mstats = ad$jdata[,list(m1=mean(y1),sd1=sd(y1),
                         m2=mean(y2),sd2=sd(y2),
                         v12 = cov(y1,y2),.N),list(j1,j2)]
cstats = ad$sdata[,list(m1=mean(y1),sd1=sd(y1),
                         m2=mean(y2),sd2=sd(y2),
                         v12 = cov(y1,y2),.N),list(j1)]

# save these for later estimation


library(lumi)
fileName <- 'GSE49454_non-normalized.txt'

x.lumi <- lumiR(fileName)
z= lumiN(x.lumi)
write.exprs(z, file="normalised.txt")

library("AnnotationDbi")
library("illuminaHumanv4.db")

x=read.table("normalised.txt", header=T, sep="\t")
y=as.character(x[,1])
annot=select(illuminaHumanv4.db, y, c("SYMBOL"), "PROBEID")
comb=merge(x,annot, by.y="PROBEID", by.x="X")
comb <- comb[,-1]
comb$SYMBOL <- as.factor(comb$SYMBOL)
y=aggregate(.~SYMBOL, data=comb, max)
rownames(y)=y[,1]
y=y[,-1]
write.table(y,file="annotated.txt", sep="\t")

#OR

library(GEOquery)
eset = getGEO('GSE49454')[[1]]
z= lumiN(eset)


#' Simple Imputation
#'
#' Generic simple imputation method
#' @param x Numeric, Factor, Logical or Charater vector, or a Data Frame
#' @param ... arugments to be passed to othermethods
#'
#' @return an imputed dataset of the  same class as x
#' @export
#'
#' @examples
impute <- function (x, ...) {
  UseMethod("impute", x)
}

#' @describeIn impute Median Imputation for a numeric Vector
#'
#' Median Imputation for a numeric Vector
#' @param x
#' @param .fun a fuction (default median) to use for imputation
#' @export
impute.numeric = function(x, .fun = median,...){
  na_mask = is.na(x)
  if(all(na_mask)) {
    warning('All data missing, returning original')
    return(x)
  }
  x[na_mask] = .fun(x, na.rm = TRUE,...)
  x
}

#' @describeIn impute Mode Imputation for a character vector
#' @export
impute.character = function(x){
  na_mask = is.na(x)
  if(all(na_mask)) {
    warning('All data missing, returning original')
    return(x)
  }
  tt = table(x)
  mode = names(sort(tt, decreasing = TRUE))[1]
  x[na_mask] = mode
  x
}

#' @describeIn impute Mode Imputation for a factor vector
#' @export
impute.factor = function(x){
  na_mask = is.na(x)
  if(all(na_mask)) {
    warning('All data missing, returning original')
    return(x)
  }
  impute.character(x)
}

#' @describeIn impute Mode Imputation for a logical vector
#' @export
impute.logical = function(x){
  na_mask = is.na(x)
  if(all(na_mask)) {
    warning('All data missing, returning original')
    return(x)
  }
  as.logical(impute.character(x))
}

#' @describeIn impute data frame imputation
#' @export
impute.data.frame = function(x, ...){
  purrr::map_df(x, impute, ...)
}

#' @describeIn impute data frame imputation
#' @export
impute.tbl_df = function(x, ...){
  purrr::map_df(x, impute, ...)
}


# library imports
library(tidyverse)
library(stringr)
library(limma)
library(psych)
library(Matrix)

# load the raw data: the table starts in Row 5
# there are extra lines at the bottom - need to stop before the end
data_import <- read_tsv("PAW_labeled_grouped_protein_summary_TMT_8.txt",
                        skip = 4, n_max = 4437, guess_max = 4437)

# the "Filter" column flags contams and decoys
data_all <- filter(data_import, is.na(Filter))

# check number of rows before and after filtering
print("Table lengths before and after filtering:")
cat(nrow(data_import), nrow(data_all))

# make a data frame for each TMT-plex (and drop zeros)
get_data <- function(df, substring) {
    # extracts PAW TMT columns containing a substring

    # df: data frame of PAW results
    # substring: a text substring that defines one TMT-plex

    # get the columns
    df <- df %>%
      select(starts_with("TotInt")) %>%
      select(contains(substring))

    # drop rows with zeros
    df[apply(df, 1, function(row) all(row !=0 )), ] # return filtered frame
}

# get each experiment and set column names to something easy to parse
A_raw <- get_data(data_all, "_A_")
B_raw <- get_data(data_all, "_B_")
C_raw <- get_data(data_all, "_C_")
D_raw <- get_data(data_all, "_D_")

# automatically find closest channel pairs

SL_norm <- function(df, suffix, print_factors = TRUE) {
    # Normalizes each channel's sum to the average grand total
        # df: data frame of TMT data (one column for each channel)
        # suffix: a text string to append to 1-to-n numbers for column names
        # print_factors: logical to control printing

    # compute norm factors and scale columns
    norm_facs <- mean(c(colSums(df))) / colSums(df)
    df_sl  <- sweep(df, 2, norm_facs, FUN = "*")

    # simplify column names
    colnames(df_sl) <- str_c(as.character(1:ncol(df)), suffix)

    # print the normalization factors for QC check
    if (print_factors == TRUE) {
        cat("\nNormalization Factors: ", suffix, "\n ")
        cat(sprintf("%s - %0.3f\n", colnames(df), norm_facs))
    }

    df_sl # return normalized data
}

diff <- function(df, x, y) {
    # computes a standardized difference between two vectors
        # df: data frame that contains x and y
        # x: index of first column
        # y: index of second column

    # compute the difference and set the column name
    diff <- 100 * abs(df[x] - df[y]) / rowMeans(df[c(x, y)])
    colnames(diff) <- sprintf("%d_%d", x, y)

    diff # return difference vector
}

iqr_grid <- function(df, print_grid = TRUE) {
    # computes an NxN grid of interquartile ranges of diffs
         # df: a data frame of TMT data
         # print_grid: logical to control printing

    # make an empty matrix ncol-by-ncol
    iqrs  <- matrix(0.0, ncol(df), ncol(df))

    # populate an upper diagonal "diff" matrix
    for (i in 1:ncol(df)) {
        for (j in (i+1):ncol(df)) {
            if (j > ncol(df)) {
                break
            }
            iqrs[i, j] <- IQR(diff(df, i, j)[[1]])
        }
    }

    # print the grid
    if( print_grid == TRUE) {
        cat("\nInterquartile range grid:\n")
        print(round(iqrs, 2))
    }

    iqrs # return the iqr grid
}

find_best_pair <- function(df, nmax, suffix, title) {
    # finds channel pairs having the smallest standardized differences
        # df: data frame with TMT channels
        # nmax: how many channels/pairs to check
        # suffix: suffix to add to channel labels
        # title: title string to use in plots

    # first do SL normalization
    df_sl <- SL_norm(df, suffix)

    # compute the ird grid
    iqrs <- iqr_grid(df_sl)

    # find the nmax number of smallest IQR values
    # from https://stackoverflow.com/questions/38664241/ranking-and-counting-matrix-elements-in-r
    iqrs_long <- summary(Matrix(iqrs, sparse = TRUE))
    iqrs_ordered <- iqrs_long[order(-iqrs_long[, 3], decreasing = TRUE),]
    candidates <- iqrs_ordered[1, 1] # starting vector of channels
    for (row in 1:nrow(iqrs_long)){
        candidates <- c(candidates, iqrs_ordered[row, 1])
        candidates <- c(candidates, iqrs_ordered[row, 2])
    }

    # get the set of indexes and print the best pairs
    for (pair in 1:nmax) {
        top_n <- sort(unique(candidates)[1:nmax])
        i <- iqrs_ordered[pair, 1]
        j <- iqrs_ordered[pair, 2]
        cat(sprintf("\nPair #%d: (%d, %d) => %0.2f", pair, i, j, iqrs[i, j]))
    }

    # make the box plots for the top-n pairs
    distributions <- list()
    for (row in 1:nmax){
        distributions[[row]] <- diff(df_sl, iqrs_ordered[row, 1], iqrs_ordered[row, 2])
    }
    boxplot(do.call(cbind, distributions), main = title)

    # multi-panel scatter plots for the top-n channels
    cat(pairs.panels(log10(df_sl[top_n]), lm = TRUE, main = title))
}

# nmax is how many top pairs to consider (3 or 4 are recommended values)
top_n <- 4

# find the standards in experiment A
# this is now a one-line function call
find_best_pair(A_raw, top_n, "_A", "Exp A")

# experiment B
find_best_pair(B_raw, top_n, "_B", "Exp B")

# experiment C
find_best_pair(C_raw, top_n, "_C", "Exp C")

# and experiment D
find_best_pair(D_raw, top_n, "_D", "Exp D")

# check the clustering
A_sl <- SL_norm(A_raw, "_A", print_factors = FALSE)
plotMDS(log10(A_sl), main = "Experiment A")

pairs.panels(log10(A_sl), main = "Exp. A - all 10")

# log the session
sessionInfo()


library(ggplot2)
library(data.table)
library(dplyr)

if(! exists("inputFile")){
  args <- commandArgs(TRUE)
  if(length(args) == 0){
    setwd("/scratch/weissvl/shengq2/20210624_human_wntpathway_rnaseq/genetable_tpm")
    inputFile<-"/scratch/weissvl/shengq2/20210624_human_wntpathway_rnaseq/genetable/result/weiss_human_wnt.proteincoding.count"
    outputPrefix<-'weiss_human_wnt.tpm.csv'
  }else{
    inputFile<-args[1]
    outputPrefix<-args[2]
  }
}

cat(inputFile, "\n")
counts<-read.table(file=inputFile, sep="\t", header=T, row.names=1)

name_index<-which("Feature_gene_name"==colnames(counts))
sample_index<-name_index+1
nsample=ncol(counts)
rawcounts<-counts[,c(sample_index:nsample)]
featureLength=counts$Feature_length
id_name_map=split(counts$Feature_gene_name, rownames(counts))
name_id_map=split(rownames(counts),counts$Feature_gene_name)

counts_to_tpm <- function(counts, featureLength) {
  stopifnot(length(featureLength) == nrow(counts))

  logFeatureLength<-log(featureLength)

  # Process one column at a time.
  tpm <- do.call(cbind, lapply(1:ncol(counts), function(i) {
    rate = log(counts[,i]) - logFeatureLength[i]
    denom = log(sum(exp(rate)))
    exp(rate - denom + log(1e6))
  }))

  # Copy the row and column names from the original matrix.
  colnames(tpm) <- colnames(counts)
  rownames(tpm) <- rownames(counts)
  return(tpm)
}

gene_to_symbol<-function(tpm, id_name_map, name_id_map){
  dup_symbols=namemap[lapply(name_id_map, length)>1]

  unique_ids=unlist(name_id_map[!(names(name_id_map) %in% names(dup_symbols))])
  unique_tpm=tpm[unique_ids,]
  rownames(unique_tpm)<-id_name_map[rownames(unique_tpm)]

  rm_dup_tpm=NULL
  symbol=names(dup_symbols)[1]
  for(symbol in names(dup_symbols)){
    dup_tpm=tpm[rownames(tpm) %in% unlist(dup_symbols[symbol]),]
    merged_tpm=colSums(dup_tpm)
    rm_dup_tpm<-rbind(rm_dup_tpm, merged_tpm)
  }

  rownames(rm_dup_tpm)<-names(dup_symbols)

  result<-rbind(unique_tpm, rm_dup_tpm)
  return(result)
}

tpm<-counts_to_tpm(rawcounts, featureLength)
symbol_tpm<-gene_to_symbol(tpm, id_name_map, name_id_map)
write.csv(symbol_tpm, file=outputPrefix)


run1 <- function() {
  data = "theo_sd"
  desc = "case example base run"
  ref  = ""
  imp  = 1
  est  = "saem"
  control = list()
  ini({
    tka <- .5
    tcl <- -3.2
    tv <- -1
    eta.ka ~ 1
    eta.cl ~ 2
    eta.v ~ 1
    add.err <- 0.1
  })
  model({
    ka <- exp(tka + eta.ka)
    cl <- exp(tcl + eta.cl)
    v <- exp(tv + eta.v)
    linCmt() ~ add(add.err)
  })
}


#name: RKNNApply
#meta.mlname: RKNN
#meta.mlrole: apply
#description: Custom R Apply func for KNN
#language: r
#input: blob model
#input: dataframe df
#input: string namesKeys [original features' names]
#input: string namesValues [new features' names]
#output: dataframe data_out

#>>> Load necessary packages
library(caret)
library(e1071)
renv::init()
if (!require(kknn)) install.packages("kknn")  #install package if not already there
install.packages('kknn')
library(kknn)
if (!require(MLmetrics)) install.packages("MLmetrics")  #install package if not already there
library(MLmetrics)

#>>> If original(namesKeys) and new(namesValues) passed, map original names to new
namesKeys = strsplit(namesKeys, ',')[[1]]
namesValues = strsplit(namesValues, ',')[[1]]
if (length(namesKeys) > 0) {
  featuresNames = names(df)
  for (n in 0:length(namesKeys))
    names(df)[featuresNames == namesValues[n]] = namesKeys[n]
}

#>>> Retrieve saved/trained model
trained_model = readRDS(model)

#>>> Predict using trained model
predY = predict(trained_model, df)
data_out = data.frame(predY)


pmv_iso_7730 <- function(ta, rh, vel, tr, met, wme, clo) {
    .Call('biometeoR_pmv_iso_7730', PACKAGE = 'biometeoR', ta, rh, vel, tr, met, wme, clo)
}


  LeT_peak_deg = function(tx,
                        tpeak,
                        prop_tr,
                        trials,
                        params,
                        wn_vector,
                        same_sd = F) {

  n = params[1]
  nvec = 1:n
  mu = params[2]
  sd = params[3]
  alpha = params[4]
  beta = params[5]
  W0 = params[6]
  p = params[8]

  tvector = replicate(trials, sample(c(1, 0), 1, prob = c(p, 1-p)))

  IRI1 = numeric(trials)
  IRI2 = numeric(trials)

  if (wn_vector[tx] == 0 ) {
    wn_vector[1:n] = W0

  }

  theta = params[7]

  t1 = floor(tx * (1 - prop_tr))
  tf = tx - t1

  t1vec = 1:t1

  R1 = matrix(0, nrow = trials, ncol = tpeak*3)
  R2 = matrix(0, nrow = trials, ncol = tpeak*3)

  R1p = matrix(0, nrow = trials, ncol = tpeak*3)
  R2p = matrix(0, nrow = trials, ncol = tpeak*3)

  if (same_sd) {
    l1 = rnorm(trials, mu, sd)
    l2 = rnorm(trials, mu, sd)

    while (any(l1 < 0) | any(l2 < 0)) {
      l1 = rnorm(trials, mu, sd)
      l2 = rnorm(trials, mu, sd)
    }

    nrf1vec = ceiling(l1 * t1) + tf
    nrf2vec = ceiling(l2 * nrf1vec)

  } else {
    l1 = rnorm(trials, mu, sd * 1.5)
    l2 = rnorm(trials, mu, sd)
    while (any(l1 < 0) | any(l2 < 0)) {
      l1 = rnorm(trials, mu, sd * 1.5)
      l2 = rnorm(trials, mu, sd)
    }

    nrf1vec = ceiling(l1 * (t1 + tf))
    nrf2vec = ceiling(l2 * nrf1vec)

  }

  nrf1pvec = ceiling(l1 * tpeak)
  nrf2pvec = ceiling(l2 * tpeak)

  IRI1 = nrf1vec
  IRI2 = nrf2vec

  for (j in 1:trials) {
    ttype = tvector[j]
    if (ttype){

      Nt = ceiling(l1[j] * t1vec)

      R1[j, 1:length(Nt)] = ifelse(wn_vector[Nt] > theta, 1, 0)

      t2vec = 1:nrf1vec[j]
      Nt2 = ceiling(t2vec * l2[j])
      R2[j, 1:length(Nt2)] = ifelse(wn_vector[Nt2] > theta, 1, 0)

      # Delayed component
      w1 = wn_vector[nrf1vec[j]] + beta * (1 - wn_vector[nrf1vec[j]])
      wn_vector[nrf1vec[j]] = w1
      w2 = wn_vector[nvec < nrf1vec[j]] - (alpha / nrf1vec[j]) * wn_vector[nvec < nrf1vec[j]]
      wn_vector[nvec < nrf1vec[j]] = w2

      # Immediate component

      w1 = wn_vector[nrf2vec[j]] + beta * (1 - wn_vector[nrf2vec[j]])
      wn_vector[nrf2vec[j]] = w1
      w2 = wn_vector[nvec < nrf2vec[j]] - (alpha / nrf2vec[j]) * wn_vector[nvec < nrf2vec[j]]
      wn_vector[nvec < nrf2vec[j]] = w2

    } else {

      Nt = ceiling(l1[j] * 1:tpeak)
      Nt2 = ceiling(l2[j] * 1:tpeak)

      R1p[j, 1:length(Nt)] = ifelse(wn_vector[Nt] > theta, 1, 0)
      R2p[j, 1:length(Nt2)] = ifelse(wn_vector[Nt2] > theta, 1, 0)

      nrf1p = nrf1pvec[j]
      nrf2p = nrf2pvec[j]

      wp1 = wn_vector[nvec < nrf1p] - (alpha / nrf1p) * wn_vector[nvec < nrf1p]
      wn_vector[nvec < nrf1p] = wp1
      wp2 = wn_vector[nvec < nrf2p] - (alpha / nrf2p) * wn_vector[nvec < nrf2p]

      wn_vector[nvec < nrf2p] = wp2
    }

  }

  list(R1 = R1, # 1
       R2 = R2, # 2
       R1p = R1p, # 3
       R2p = R2p, # 4
       Wn1 = wn_vector, # 5
       iri1 = IRI1,
       iri2 = IRI2)
}