.II "bc^tutorial"
.ds TL "bc Desk Calculator"
.NH "bc Desk Calculator Language" 1
.PP
This tutorial introduces
.BR bc ,
the calculator language for \*(OS.
If you have not used
.B bc
before, this tutorial will introduce you to its
features and functions.
If you are familiar with
.BR bc ,
you can use it as a reference.
.PP
\fBbc\fR is a language that can calculate
to high precision.
It automatically adjusts
the number of digits in a number to represent it correctly.
It is like having a powerful calculator at your fingertips.
.Sh "Entry and Exit"
.PP
The \fBbc\fR calculator for \*(OS is easy to use.
Whenever you wish to invoke
.B bc ,
all you do is type its name (\fBbc\fR), followed by
a stroke of the carriage return key.
When you are finished using the calculator and wish to exit,
just type the word \*(Qlquit\*(Qr or
.if \nX=0 \fB<ctrl-D>\fR.
.if \nX=1 \fB<ctrl-Z>\fR.
.B bc
exits and returns control to \*(OS.
.Sh "Example of Simple Use"
.PP
\fBbc\fR performs calculations on formulas that you type into it.
The formulas are laid out as you would naturally write them.
For example, to invoke \fBbc\fR, have it add
2+2, and then exit, type:
.DM
	bc
	2 + 2
.DE
.B bc
replies:
.DM
	4
.DE
Then, leave \fBbc\fR by typing:
.DM
	quit
.DE
.B bc
is an arbitrary precision calculator:
the number of digits carried by \fBbc\fR depends upon
the requirements of the calculation,
and is automatically expanded by \fBbc\fR.
Thus, \fBbc\fR will never overflow.
The number of digits it carries is
limited only by the amount of available computer memory.
For example, invoke
.B bc
and then try this calculation:
.DM
	2^500
.DE
The circumflex \*(Ql^\*(Qr character signifies a superscript; thus,
we are asking \fBbc\fR to raise 2 to the 500th power.
After a moment, \fBbc\fR will reply:
.DM
	327339060789614187001318969682759915221664\e
	204604306478948329136809613379640467455488\e
	327009232590415715088668412756007100921725\e
	6545885393053328527589376
.DE
.II "bc^exponentiation operator"
You have probably already noticed one nice thing about this calculator:
you don't have to include a print statement as part of your command, because
.B bc
automatically prints the results onto your terminal screen.
When \fBbc\fR sees any expression, like \*(QL2+2\*(QR or \*(QL37\-7\*(QR,
it prints the result.
.PP
.B bc
provides the
common arithmetic operators
for add, subtract, multiply, and divide, as
illustrated by the following commands:
.DM
	7 + 5
	7 - 5
	7 * 5
	7 / 5
.DE
.PP
\fBbc\fR also provides the
remainder operator
\*(Ql\fB%\fR\*(Qr.
To get a sense of how it works, type:
.DM
	7 % 5
	5 % 7
.DE
Here, \fBbc\fR prints the \fIremainder\fR of the first number
divided by the second; in the case of the first example,
\fBbc\fR prints 2, and in the second prints 5.
As you saw above, \fBbc\fR also includes
the exponentiation operator \*(Ql\fB^\fR\*(Qr.
.PP
With \fBbc\fR, you can also enter numbers with fractional parts.
Type the following to illustrate:
.DM
	9.999 * 9.999
.DE
\fBbc\fR replies:
.DM
	99.980
.DE
You can save temporary calculations or repeated constants in
\fIvariables\fR.
The following example shows you first how to define variables,
and second how to use them:
.DM
	a = 1.1
	b = 2.2
	a
	b
	a * b
.DE
Variable names can be longer than one letter.
.PP
The basic calculations in the above examples show only part of what
.B bc
can do.
The following section describes simple statements \(em the assignment of
variables and abbreviations \(em that allow you to perform
complex calculations easily.
.SH "Simple Statements"
.PP
Although you can use \fBbc\fR as a simple calculator
for manipulating numbers, you
can take advantage of its greater power by using \fIvariables\fR.
Variables, as noted above, store parts of calculations or constants that
you will use repeatedly in calculations.
Variable names are simply \*(QLwords\*(QR that you make up.
Here are some examples of possible variable names:
.DM
	a
	b
	totaltaxesdue
	ratio
.DE
To use variables, simply give them a value, use
them in a calculation in place of a number, or print them out.
.PP
To see how a variable can save you repetitive typing, and protect
you from possible errors, invoke \fBbc\fR and type the following:
.DM
	x = 9.999
	x
	x * x
	x = x * x
	x
.DE
The following gives the example with \fBbc\fR's replies \fIin italics\^\fR:
.DM
	x = 9.999
	x
	\fI9.999\fP
	x * x
	\fI99.980\fP
	x = x * x
	x
	\fI99.980\fP
.DE
.II bc^assignment
.B bc
did not reply to the
assignment statements \fBx=9.999\fR and \fBx=x*x\fR.
However, it did print the value of \fBx\fR when requested,
and the results of arithmetic using \fBx\fR.
.PP
Calculations executed with hand-held calculators,
with programming languages like C, or with \fBbc\fR
often use the following formula:
.DM
	x = x + 1
.DE
To decrease the likelihood of error,
\fBbc\fR offers you a shorthand expression for this common phrase:
.DM
	x += 1
.DE
What it means is, \*(QLadd one to \fBx\fR\*(QR.
Type the following example into \fBbc\fR to see how this expression works:
.DM
	x = 1
	x * x
	x += 1
	x * x
	x += 1
.DE
Likewise, \fBbc\fR provides an abbreviation for:
.DM
	x = x - 2
.DE
The form should now be familiar:
.DM
	x \(mi= 2
.DE
The number to the right of the \fB-=\fR or \fB+=\fR operator can be replaced
with a variable or even another calculation.
When you type:
.DM
	i = 4
	x = 48
	x \(mi= i
	x
.DE
\fBbc\fR replies:
.DM
	44
.DE
Alternatively, if you type:
.DM
	i = 4
	x = 48
	x \(mi= i * i
	x
.DE
then \fBbc\fR replies:
.DM
	32
.DE
Similar abbreviations are provided for multiplication,
division, remainder, and exponentiation.
Here is a summary of this class of operation.
.DS
.ta 0.5i 1.5i
	\fIa \fB+=\fR 2	Replace \fIa\fR with a plus 2
	\fIb \fB+= \fIa\fR	Replace \fIb\fR with \fIb\fR plus \fIa\fR
	\fIb \fB\(mi=\fR \fIa\fR	Replace \fIb\fR with \fIb\fR minus \fIa\fR
	\fIc \fB*= \fIb\fR	Replace \fIc\fR with \fIc\fR multiplied by \fIb\fR
	\fIc \fB/= \fIa\fR	Replace \fIc\fR with \fIc\fR divided by \fIa\fR
	\fIc \fB%= \fIb\fR	Replace \fIc\fR with remainder of \fIc\fR divided by \fIb\fR
	\fId \fB^= \fI3\fR	Replace \fId\fR with \fId\fR raised to the third power
.DE
.B bc
also has an operator that increases a variable by one:
\*(Ql\fB++\fR\*(Qr.
When you type:
.DM
	a = 1
	++a
.DE
then \fBbc\fR replies:
.DM
	2
.DE
To use this operator in an expression, combine it
with a variable anywhere that a variable would normally be used.
For example, entering
.DM
	b = 1
	a = 3
	b = ++a
	a
	b
.DE
yields:
.DM
	4
	4
.DE
The \*(Ql\fB++\fR\*(Qr operator can also be put after a name.
The resulting value in the expression is the value of the
name \fIbefore\fR it is incremented.
However, after the expression is evaluated,
the name will have an incremented value.
The following example shows the use of \*(Ql\fB++\fR\*(Qr
both before and after a name:
.DM
	a = 1
	b = 1
	a++
	++b
	a
	b
.DE
\fBbc\fR replies:
.DM
	1
	2
	2
	2
.DE
Operators are used in this manner:
.DM
	a = 1
	b = 2
	c = a++ + ++b
.DE
Similar to \*(Ql\fB++\fR\*(Qr is \*(Ql\fB\(mi\(mi\fR\*(Qr.
It behaves the same way, except that rather than adding one,
it subtracts one.
.SH "Numbers with Fractions"
.PP
Most of the examples presented earlier use whole numbers (integers).
However, \fBbc\fR can use numbers with fractional parts.
This section discusses the use of fractional numbers in \fBbc\fR and their
precision
under different operations.
.Sh "The Scale of Numbers"
.PP
The number of digits to the left of the decimal point carried by
.B bc
depends upon the requirements of the calculation.
If you calculate a large number, as in:
.DM
	2^500
.DE
the result will contain as many digits as needed to express the product.
.PP
The number of digits to the right of a decimal point is
called the
.I scale
of the number.
Scale depends upon the operation that produces the
number of digits, and a variable called
.B scale
that will be described shortly.
.PP
To illustrate simple uses of numbers with fractions, invoke
.B bc
and then type:
.DM
	a = .01
	b = 0.99
	a + b
.DE
\fBbc\fR replies:
.DM
	1.00
.DE
.Sh "Addition and Subtraction"
.PP
\fBbc\fR will dynamically adjust the number of digits in the calculation.
It deals similarly with fractional numbers.
To the following example
.DM
	a = 0.01
	b = 0.001
	a + b
.DE
\fBbc\fR reply:
.DM
	.011
.DE
In addition and subtraction, the scale of the result
is the \fIlarger\fR of the scales of the two numbers involved.
Results are not truncated in addition or subtraction operations.
.Sh "Scale During Multiplication"
.PP
Other arithmetic operations act differently with numbers
that contain fractions.
In the multiplication of two numbers, the scale of
the product will at least equal the larger of the scales of the two numbers.
For example, the input:
.DM
	1.1 * 1.11
.DE
results in:
.DM
	1.22
.DE
.Sh "Setting the Scale of Results"
.PP
To increase the number of fractional digits for higher accuracy,
.B bc
provides the built-in variable \fBscale\fR.
The following example illustrates the \fBscale\fR variable:
.DM
	scale = 3
	1.1 * 1.11
.DE
The result from this example is:
.DM
	1.221
.DE
Note, however, the scale of the product of a multiplication procedure
never exceeds the sum of the scales of the two numbers being multiplied.
For example,
.DM
	scale = 10
	1.1 * 1.11
.DE
yields the result:
.DM
	1.221
.DE
If the variable \fBscale\fR is less than the
sum of the scales of the numbers being multiplied, then the product
will have a scale equal to that of the variable \fBscale\fR.
For example,
.DM
	scale = 4
	1.11 * 2.222
.DE
yields:
.DM
	2.4664
.DE
The scales of the operands are 2 and 3.
The larger scale is 3, so the result of a multiplication
will have a scale of at least 3, no matter what \fBscale\fR is set to.
Also, the sum of the scales is 5, so the result will never
have more than 5 digits to the right of the decimal point.
In this example, \fBscale\fR has been set to a scale of 4.
Therefore, the result has four digits to the right of the decimal point.
.Sh "Scale for Divisions"
.PP
For division and remainder, the scale of the result is determined
only by the value of the variable \fBscale\fR.
For example,
.DM
	scale = 13
	14 / 13
	14 % 13
.DE
yields:
.DM
	1.0769230769230
	.0000000000010
.DE
For non-whole numbers, as well as for integers,
the definition of remainder is chosen so that the relationship
.DM
	dividend = (divisor * quotient) + remainder
.DE
is true.
.Sh "Scale From Exponentiation"
.PP
.B bc
sets the \fBscale\fR of a result of exponentiation as
if repeated multiplications had been performed.
Thus, for
.DM
	5.992 ^ 5
.DE
the scale is chosen as if you typed:
.DM
	n = 5.992
	n * n * n * n * n
.DE
That is, the default is the scale of the largest (or, in this case,
the only) number being multiplied; and scale cannot exceed the
sum of the scales of the numbers being multiplied.
Thus, the scale of the product in this example
has a default setting of 3, and can be reset up to 15.
.Sh "What Is the Current Scale?"
.PP
The variable \fBscale\fR is just like other variables:
you can assign values to it, as above.
Because it is like regular variables, you can also use it
in operations, as in this example:
.DM
	scale += 1
.DE
You can also print its value:
.DM
	scale
.DE
The value of the \fBscale\fR variable is zero until you explicitly change it.
.SH "The if Statement"
.PP
The statements shown so far have been either assignment statements,
giving a new value to a variable; or an expression, which prints
the resulting value.
Several other kinds of statements are available.
These give you power to write programs that make
decisions and perform iterative computations.
.Sh "Using the if Statement"
.PP
To see the
.B if
statement in action, type the following example into \fBbc\fR:

.DM
	x = 3
	if (x < 5) x
	if (x > 5) -x
.DE
.B bc
replies:
.DM
	3
.DE
If the input is:
.DM
	x = 6
	if (x < 5) x
	if (x > 5) -x
	<return>
.DE
\fBbc\fR replies:
.DM
	-6
.DE
The part of the
.B if
statement in parentheses, such as \fB(x > 5)\fR, determines whether
.B bc
executes the statement that follows it, such as
.BR -x .
If the expression is false, the following statement is not executed.
If the expression is true, the following statement is executed.
.Sh "Comparisons"
.PP
The decision expression in an \fBif\fR statement is enclosed in parentheses.
The decision can be based upon a comparison of two operands, or numbers.
The kinds of comparisons that can be done are:
.DS
	\fB==\fR	First operand equal to second
	\fB!=\fR	First operand not equal to second
	\fB<=\fR	First operand less than or equal to second
	\fB<\fR	First operand less than second
	\fB>=\fR	First operand greater than or equal to second
	\fB>\fR	First operand greater than second
.DE
The \fBif\fR statement can include the sorts of
the simple statements already shown.
You can also include an \fBif\fR statement, as well as the \fBwhile\fR,
\fBdo\fR, and \fBfor\fR statements,
which will be discussed below.
The following example illustrates the use of an \fBif\fR
statement within an \fBif\fR statement:
.DM
	a = 2
	b = 6
	if (a >= 2) if (b > a) a + b
	<return>
.DE
\fBbc\fR replies, simply:
.DM
	8
.DE
Because both of the \fBif\fR conditions were true,
\fBbc\fR proceeded to add \fBa\fR and \fBb\fR.
Note that nested
.B if
statements must appear on the same line.
Therefore,
.DM
	if (a == 3) if (b > a) a + b
.DE
does not print the result of
.B "a + b"
because not both conditions were true.
However
.DM
	if (a == 3)
	if (b > a) a + b
.DE
prints the result of
.B "a + b"
because
.B bc
treats
.B if
statements one by one, and the second
.B if
statement's condition is true.
.Sh "Grouped Statements"
.PP
You can place more than one statement after the expression part of the
\fBif\fR statement by using grouping braces \*(Ql\fB{\fR\*(Qr
and \*(Ql\fB}\fR\*(Qr.
This can be useful if you want to perform several calculations
based on the result of an \fBif\fR statement comparison.
The following example prints the value of \fBa\fR and
\fBb\fR if the value of \fBb\fR is less than the value of \fBa\fR:
.DM
	a = 1
	b = .99
	if (a > b) {
	    a
	    b
	}
.DE
\fBbc\fR replies:
.DM
	1
	.99
.DE
Any statement may be enclosed within the group braces, as
the following example shows:
.DM
	a = 1
	b = .99
	if (a > b) {
	    a
	    b
	    if ((a + b) >= 2) a + b
	}
.DE
.Sh "Many Statements Per Line"
.PP
To this point, all of our examples typed each statement on its own line.
This includes the group braces \*(Ql\fB{\fR\*(Qr and \*(Ql\fB}\fR\*(Qr,
the latter of which must appear on a line by itself.
You can, however, place several statements on one line if you separate them
with semicolons.
If you do this, remember that the semicolon rather than the
carriage return separates the statements.
For example, if you type:
.DM
	a = 1;b = 2;c = 3
	a;b;c
.DE
\fBbc\fR replies:
.DM
	1
	2
	3
.DE
You can use this in combination with the group braces:
.DM
	a = 1;b = 2;c = 3
	if ((a + b) >= c) {
	    a; b; c; a + b; }
.DE
The reply from \fBbc\fR is:
.DM
	1
	2
	3
	3
.DE
This example can be compressed even further by putting all of the \fBif\fR
statement on one line:
.DM
	a = 1;b = 2;c = 3
	if ((a + b) >= c) { a; b; c; a + b; }
.DE
You do not need to follow the \*(Ql\fB}\fR\*(Qr with a semicolon.
.SH "The while Statement"
.PP
The \fBwhile\fR statement repeats calculations.
This is useful in successive approximation calculations.
The following example of the \fBwhile\fR loop
prints the numbers one through ten:
.DM
.ta 1.0i 1.5i
	i = 1
	while (i <= 10) {
		i
		i = i + 1
	}
.DE
.B bc
replies:
.DM
	1
	2
	3
	4
	5
	6
	7
	8
	9
	10
.DE
The statement
.DM
	i = i + 1
.DE
adds 1 to the variable \fBi\fR.
The expression
.DM
	(i <= 10)
.DE
compares \fBi\fR with ten.
While \fBi\fR is less than or equal to ten, the \fBwhile\fR
loop executes.
When \fBi\fR is increased to greater than ten, the loop stops executing.
.PP
.B bc
checks the comparison expression for the \fBwhile\fR loop
before the loop is entered for the first time.
If the comparison fails, the loop is not executed at all;
otherwise the processing repeats as long as the comparison is true.
For example, the following statements do not print anything:
.DM
	i = 0
	while (i > 1) i
	quit
.DE
.Sh "Abbreviations in the while Statement"
.PP
If we recall the assignment statements from the previous section,
we can shorten
the \fBwhile\fR counting-to-ten example to:
.DM
	i = 1
	while (i <= 10) {
		i
		i += 1
	}
.DE
The result remains the same \(em a list of numbers from one to ten.
.PP
Another abbreviation of the example uses the \*(Ql\fB++\fR\*(Qr operator.
The variable \fBi\fR is incremented, then tested in the \fBwhile\fR
expression, which simplifies the entire example to:
.DM
	i = 0
	while (++i <= 10) i
.DE
Before the \fBwhile\fR is executed, \fBi\fR is set to zero.
Then, the \fBwhile\fR expression increments the
value of \fBi\fR before it is used or compared,
Thus, the first value compared, then printed, is one.
.PP
Finally, the example calculation can be shortened to one line.
If a variable in \fBbc\fR is used before it is initialized, it will
have the value of zero.
For example:
.DM
	zip
.DE
prints:
.DM
	0
.DE
Using this in our counting-to-ten example yields:
.DM
	while (++n <= 10) n
.DE
.SH "The for Statement"
.PP
.B for
is a statement that controls the execution of other
.B bc
statements.
You should use
\fBfor\fR to write a formula
to control the number of times a value is computed.
.PP
The previous section demonstrated how to print the numbers one to
ten using a \fBwhile\fR statement.
The following does the same task with a \fBfor\fR statement:
.DM
	for (i=1; i <= 10; ++i) i
.DE
.Sh "Three Parts of the for Statement"
.PP
The \fBfor\fR statement is more complex than the \fBwhile\fR statement;
its controlling expressions have three parts.
.PP
The first part, shown here in italics
.DM
	for (\fIi=1\^\fP; i <= 10; ++i) i
.DE
sets up the initial condition.
The second part
.DM
	for (i=1; \fIi <= 10\^\fP; ++i) i
.DE
tests whether more iterations should be performed.
.B bc
performs this test
.I before
it executes the statements that are subordinate to the
.B for
statement.
If the test fails, no more iterations are performed.
.PP
The third part
.DM
	for (i=1; i <= 10; \fI++i\^\fP) i
.DE
is performed at the end of each iteration.
In practically every instance, this part of the
.B for
statement modifies the value of the variable that the second part tests.
.PP
Taken together, these statements (1) set \fBi\fR to zero; (2) check whether
\fBi\fR is less than or equal to ten; (3) if \fBi\fR proves to be so,
prints \fBi\fR, and then increases it by one.
.PP
The following example of the \fBfor\fR statement adds
the squares of the numbers one through ten, prints each square,
and then prints the sum of the squares at the end.
.DM
	sum = 0
	for (n=1; n <= 10; ++n) {
	    sq = n * n
	    sq
	    sum += sq
	}
	sum
.DE
The result is:
.DM
	1
	4
	9
	16
	25
	36
	49
	64
	81
	100
	385
.DE
.Sh "Similarities Between the for and while Statements"
.PP
To illustrate the similarity between the \fBfor\fR statement and
the simpler \fBwhile\fR statement, the following rewrites the
above example, substituting the \fBwhile\fR for the \fBfor\fR:
.DM
	sum = 0
	n = 0
	while (++n <= 10) {
		sq = n * n
		sq
		sum += sq
	}
	sum
.DE
.SH "Functions in bc"
.PP
.B bc
allows you to name routines that you use repeatedly.
You can then call them by name without having to retype them;
obviously, this can be a great time-saver.
These named routines are called
.IR functions .
This section shows you how to define and use functions
for your \fBbc\fR calculations.
.Sh "Example of Function Use"
.PP
The following example defines a function that calculates the area of
a circle from its radius.
.DM
	scale = 5
	pi = 3.14159
	define area (radius) {
		r2 = radius * radius
		return (pi * r2);
	}
	area (1.00)
	area (2.00)
	area (56)
.DE
The results will be:
.DM
	3.14159
	12.56636
	9852.02624
.DE
The \fBdefine\fR keyword tells \fBbc\fR that you are defining a function.
The name of the function follows.
Then, in parentheses, come the \fIparameters\fR of the function.
In this example, the only parameter, or \fIargument\fR,
of the function is \fBradius\fR.
Most functions have arguments, but they are not mandatory.
.PP
The \fBreturn\fR statement defines the value of the function.
In the
.B area
example, the expression
.DM
	area (1.00)
.DE
references the function \fBarea\fR.
\fBbc\fR then performs the calculation described by your definition
of the function
.BR area .
The number
.DM
	1.00
.DE
is substituted wherever the parameter \fBradius\fR is shown.
.PP
The statement
.DM
	r2 = radius * radius
.DE
is then executed, yielding this result:
.DM
	1.00
.DE
Then, the statement
.DM
	return (pi * r2)
.DE
calculates the area and returns its value.
The statement
.DM
	area (1.00)
.DE
then has the value calculated in the return statement.
.Sh "Functions Using Other Functions"
.PP
Functions in \fBbc\fR perform calculations using the
same expressions as the rest of the \fBbc\fR program.
This includes the use of functions.
The \fBarea\fR program can be written using another function,
\fBsq\fR, to calculate the square of a number:
.DM
	scale = 5
	pi = 3.14159
	define sq (number) {
		return (number * number)
		}
	define area (radius) {
		return (sq (radius) * pi)
		}
	area (1.00)
	area (2.00)
	area (56)
.DE
Again, the results will be identical:
.DM
	3.14159
	12.56636
	9852.02624
.DE
.Sh "Functions That Call Themselves"
.PP
Not only can functions call other functions and perform
regular calculations; a function can use itself in calculations.
An example of this is the Fibonacci calculation:
.DM
	define fib (f) {
		if (f == 0) return (0)
		if (f == 1) return (1)
		if (f > 1) return (fib (f - 1) + fib (f - 2))
	}
	fib (5)
	fib (20)
.DE
Fibonacci numbers are defined in the following way:
Fibonacci number zero is zero; similarly, Fibonacci number one is one.
Any other Fibonacci number is defined as the sum of the two previous
Fibonacci numbers.
Fibonacci numbers are defined only for non-negative integers.
.PP
The defined function \fBfib\fR follows this definition by
returning zero if the number requested is zero and one if the argument is one.
If the number is neither of these, then the function calls itself to
calculate the previous two numbers of the series and adds them together.
.Sh "The auto Statement"
.PP
Many functions that call other functions, including themselves, may require
variables that are not changeable by the rest of the program.
This is signalled to \fBbc\fR by the \fBauto\fR statement:
.DM
	auto var1, var2
.DE
This declares \fBvar1\fR and \fBvar2\fR as local to
the function that contains them.
.PP
To illustrate the use of \fBauto\fR, the following \fBbc\fR
program calculates the factorial of a number:
.DM
	define factorial (number) {
		auto value, i
		value = 1
		for (i = 1; i <= number; ++i) value *= i
		return (value)
	}
	value = 3
	factorial (value)
	i = 99
	factorial (20)
	value
	i
.DE
The result is:
.DM
	6
	2432902008176640000
	3
	99
.DE
The first number, 6, results from:
.DM
	factorial (value)
.DE
The second number is from:
.DM
	factorial (20)
.DE
The last two numbers are from \fBvalue\fR and \fBi\fR,
and are included to demonstrate that the variables in the function
\fBfactorial\fR appearing in this statement:
.DM
	 auto value, i
.DE
are separate from the variables of the same name in the rest of the program.
.PP
If the function calls itself, as the \fBfib\fR example does
above, any variable names noted in the \fBauto\fR statement are
handled separately for each call of the function.
.SH "Programs in a File"
.PP
Because its programs can be quite complex,
\fBbc\fR lets you keep them in files.
This lets you build a library of \fBbc\fR programs and
functions that can be called up easily.
.Sh "Using a Program From a File"
.PP
To illustrate the use of programs stored in a file,
type the following example into file \fBfib.bc\fR using the
editor of your choice.
The program defines the function \fBfib\fR:
.DM
	define fib (f) {
		if (f == 0) return (0)
		if (f == 1) return (1)
		if (f > 1) return (fib (f - 1) + fib (f - 2))
	}
.DE
To use a \fBbc\fR program that has been stored in a file, enter
the file name on the \fBbc\fR command line, like this:
.DM
	bc fib.bc
.DE
The function definition will be read in by \fBbc\fR and ready for your use.
To use the function, simply type the function name with parameters.
.PP
So, if you type:
.DM
	bc fib.bc
	fib (6)
.DE
\fBbc\fR will reply:
.DM
	8
.DE
.Sh "Using Libraries"
.PP
You can enter several useful programs in their own files and call them
into \fBbc\fR at the same time.
The following example creates another function
that calculates the sum of the squares of integers up to a given number.
Use an editor to type the following into a file named \fBsumsq.bc\fR:
.DM
	define sumsq (number) {
		auto i, sum
		sum = 0
		for (i = number; i > 0; --i) sum += i ^ 2
		return (sum)
	}
.DE
Now, you can use the \fBsumsq\fR function to print the sum of
the squares for each number from one to ten:
.DM
	bc sumsq.bc
	for (i = 1; i <= 10; ++i) sumsq (i)
.DE
The result is:
.DM
	1
	5
	14
	30
	55
	91
	140
	204
	285
	385
	quit
.DE
You can use the two functions stored in a file to print the difference
between the sum of the squares of numbers, and the
Fibonacci number:
.DM
	bc fib.bc sumsq.bc
	for (i = 1; i <= 10; ++i) sumsq (i) - fib (i)
	quit
.DE
The result of this questionable computation is:
.DM
	0
	4
	12
	27
	50
	83
	127
	183
	251
	330
.DE
.Sh "The bc Library"
.II bc^library
.PP
\*(OS provides
an extended library to go with \fBbc\fR.
It includes the following functions:
.DS
	\fBatan\fP(\fIz\fP)	arctangent of \fIz\fP
	\fBcos\fP(\fIz\fP)	cosine of \fIz\fP
	\fBexp\fP(\fIz\fP)	exponential function of \fIz\fP
	\fBj\fP(\fIn,z\fP)	\fIn\fPth order Bessel function of \fIz\fP
	\fBln\fP(\fIz\fP)	natural logarithm of \fIz\fP
	\fBpi\fP	the value of pi to 100 digits
	\fBsin\fP(\fIz\fP)	sine of \fIz\fP
.DE
The library is stored in file
.if \nX=0 \fB/usr/lib/lib.b\fR.
.if \nX=1 \fB\eBIN\eLIB.B\fR.
To use the library, invoke the \fBbc\fR
command with the \fB-l\fR option.
.PP
To show how the library can be used in your work
the following example computes the sine of an angle of
one-third radian with scale set to 20:
.DM
	bc -l
	scale = 20
	sin (1/3)
	quit
.DE
The result is:
.DM
	.32719469679615224418
.DE
.SH Summary
.PP
The Lexicon entry for
.B bc
summarizes its commands, features, and libraries.
It will also refer you to related commands and functions.


# auprc.r
# usage: Rscript auprc.r
# calculate the Area under Precision Recall curve

library(zoo)

# order x in increasing fashion
x <- c(0.755239138372, 0.761591821833, 0.766995253742, 0.772033588901, 0.778386272362, 0.783935742972, 0.789558232932, 0.795618838992, 0.801533406353)
y <- c(1, 1, 1, 1, 1, 0.999255398362, 0.995305596465, 0.987493202828, 0.9801768015)
id <- order(x)

auc <- sum(diff(x[id]) * rollmean(y[id], 2))
print(paste0("auPRC = ", auc))


conv_datetime <- function(data, f="%Y-%m-%d_%H-%M-%S"){
	as.POSIXct(substr(data,1,19), format=f)
}

s_swim_pace <- function(data){
	ggplot(data, aes(x=as.POSIXct(time,format="%H:%M:%S")))+
		geom_line(aes(y=as.POSIXct(speed,format="%M:%S")))+
		geom_point(aes(y=as.POSIXct(speed,format="%M:%S")))+
		scale_y_datetime(labels = date_format("%M:%S"))+
		xlab("Time [min:sec]")+ylab("Pace [min:sec]")
}
s_swim_ca_sw <- function(data){
	mult <- 3
	ggplot(data, aes(x=as.POSIXct(time,format="%H:%M:%S")))+
		geom_line(aes(y=swolf/mult), color='blue')+
		geom_point(aes(y=swolf/mult), color='blue')+
		geom_line(aes(y=cadence), color='red')+
		geom_point(aes(y=cadence), color='red')+
		scale_y_continuous(name = "Cadence (red)",
						   sec.axis = sec_axis(~.*mult, name="Swolf (blue)"))+
		xlab("Time [min:sec]")
}
s_run_pace <- function(data){
	ggplot(data, aes(x=as.POSIXct(time, format="%H:%M:%S")))+
		geom_line(aes(y=as.POSIXct(pace, format="%M:%S")), color='red')+
		geom_point(aes(y=as.POSIXct(pace, format="%M:%S")), color='red')+
		scale_y_datetime(labels = date_format("%M:%S"))+
		ylab("Pace [min/1km]")+
		xlab("Time [min:sec]")
}
s_run_hr <- function(data){
	ggplot(data, aes(x=as.POSIXct(time, format="%H:%M:%S")))+
		geom_line(aes(y=hr), color='red')+
		ylab("Heartrate [bpm]")+
		xlab("Distance")
}
s_r_dist <- function(data){
	mult <- 4
	ggplot(data, aes(x=distance))+
		geom_line(aes(y=hr/mult), color='red')+
		geom_line(aes(y=speed), color='blue')+
		scale_y_continuous(name = "Speed [km/h] (blue)",
						   sec.axis = sec_axis(~.*mult, name="Heart Rate [bpm] (red)"))+
		xlab("Distance [km]")
}
s_r_altitude <- function(data){
	ggplot(data, aes(x=distance))+
		geom_line(aes(y=altitude), color='blue')+
		ylab("Altitude [m]")+
		xlab("Distance [km]")
}

c_swim_dist <- function(data){
	ggplot(data, aes(x=conv_datetime(filename),y=total_distance))+
		geom_line(color='red')+geom_point(color='red')+facet_wrap(~pool_length)+
		labs(x="Time",y="Distance")
}
c_swim_swolf <- function(data){
	mult <- 1/4
	ggplot(data, aes(x=conv_datetime(filename)))+
		geom_line(aes(y=avg_swolf), color='blue')+
		geom_point(aes(y=avg_swolf), color='blue')+
		geom_line(aes(y=avg_cadence/mult), color='red')+
		geom_point(aes(y=avg_cadence/mult), color='red')+
		scale_y_continuous(
						   name = "Swolf (blue)",
						   sec.axis = sec_axis(~.*mult, name="Cadence (red)"))+
facet_wrap(~pool_length)+
ylab("Swolf")+
xlab("Time")
}
c_swim_pace <- function(data){
	ggplot(data, aes(x=conv_datetime(filename)))+
		geom_line(aes(y=as.POSIXct(avg_speed, format="%M:%S")), color='blue')+
		geom_point(aes(y=as.POSIXct(avg_speed, format="%M:%S")), color='blue')+
		geom_line(aes(y=as.POSIXct(max_speed, format="%M:%S")), color='red')+
		geom_point(aes(y=as.POSIXct(max_speed, format="%M:%S")), color='red')+
		scale_y_datetime(labels = date_format("%M:%S"))+
		ylab("Max. Pace (red)         Avg. Pace (blue)")+
		xlab("Time")
}
c_run_hr <- function(data){
	ggplot(data,aes(x=conv_datetime(filename)))+
		geom_line(aes(y=max_hr), color='red')+
		geom_point(aes(y=max_hr), color='red')+
		geom_line(aes(y=avg_hr), color='blue')+
		geom_point(aes(y=avg_hr), color='blue')+
		scale_y_continuous(name = "Avg. Heart Rate [bpm] (blue)",
						   sec.axis = sec_axis(~., name="Max. Heart Rate [bpm] (red)"))+
xlab("Time [hour:min:sec]")
}
c_run_te <- function(data){
	ggplot(data, aes(x=conv_datetime(filename),y=training_effect))+
		geom_line(color='red')+geom_point(color='red')+labs(x="Time",y="Training effect")
}
c_run_dist <- function(data){
	ggplot(data, aes(x=conv_datetime(filename),y=total_distance))+
		geom_line(color='blue')+geom_point(color='blue')+labs(x="Date",y="Distance [km]")
}
c_run_pace <- function(data){
	ggplot(data, aes(x=conv_datetime(filename)))+
		geom_line(aes(y=as.POSIXct(avg_pace, format="%M:%S")), color='blue')+
		geom_point(aes(y=as.POSIXct(avg_pace, format="%M:%S")), color='blue')+
		geom_line(aes(y=as.POSIXct(max_pace, format="%M:%S")), color='red')+
		geom_point(aes(y=as.POSIXct(max_pace, format="%M:%S")), color='red')+
		scale_y_datetime(labels = date_format("%M:%S"))+
		ylab("Max. Pace (red)         Avg. Pace (blue)")+
		xlab("Time")
}

c_r_hr <- function(data){
	ggplot(data,aes(x=conv_datetime(filename)))+
		geom_line(aes(y=max_hr), color='red')+geom_point(aes(y=max_hr), color='red')+
		geom_line(aes(y=avg_hr), color='blue')+geom_point(aes(y=avg_hr), color='blue')+
		scale_y_continuous(name = "Avg. Heart Rate [bpm] (blue)",
						   sec.axis = sec_axis(~., name="Max. Heart Rate [bpm] (red)"))+
xlab("Time [hour:min:sec]")
}
c_r_dist <- function(data){
	ggplot(data, aes(x=conv_datetime(filename),y=total_distance))+
		geom_line(color='blue')+geom_point(color='blue')+labs(x="Date",y="Distance [km]")
}
c_r_te <- function(data){
	ggplot(data, aes(x=conv_datetime(filename),y=training_effect))+
		geom_line(color='red')+geom_point(color='red')+labs(x="Time",y="Training effect")
}
c_r_speed <- function(data){
	ggplot(data, aes(x=conv_datetime(filename)))+
		geom_line(aes(y=as.numeric(as.character(max_speed))), color='red')+
		geom_point(aes(y=as.numeric(as.character(max_speed))), color='red')+
		geom_line(aes(y=as.numeric(as.character(avg_speed))), color='blue')+
		geom_point(aes(y=as.numeric(as.character(avg_speed))), color='blue')+
		scale_y_continuous(
						   name = "Avg. Speed [km/h] (blue)",
						   sec.axis = sec_axis(~., name="Max. Speed [km/h] (red)"))+
xlab("Time")
}
c_r_dur <- function(data){
	ggplot(data, aes(x=conv_datetime(filename)))+
		geom_line(aes(y=as.POSIXct(total_time, format="%H:%M:%S")), color='blue')+
		geom_point(aes(y=as.POSIXct(total_time, format="%H:%M:%S")), color='blue')+
		geom_line(aes(y=as.POSIXct(total_time_moving, format="%H:%M:%S")), color='red')+
		geom_point(aes(y=as.POSIXct(total_time_moving, format="%H:%M:%S")), color='red')+
		#scale_y_datetime(labels = date_format("%H:%M"))+
		ylab("Time moving (red)         Total time (blue) [h:m]")+
		xlab("Time")
}


get.top.N.salaries2 <- function(N)
{
   #Sort data frame by Department, then by Salary
   sorted <- dfr[with(dfr, order(Department, Salary, decreasing=TRUE)),]
   #Split the dataframe up, by Department
   bydept <- split(sorted, sorted$Department)
   #Return the first N values (or all of them
   lapply(bydept,
      function(x)
      {
         n <- min(N, nrow(x))
         x[1:n,]
      })
}
get.top.N.salaries2(3)


# Computes the frecuency of events, binned at bin_res resolution,
# from x.min to x.max.

f_table = function(x, x.min, x.max, bin_res){

  bin = seq(x.min, x.max, bin_res) # vector of bins
  nas = rep(NA,length(bin)) # vector of NAs of length bin
  m   = matrix(c(bin,nas),ncol = 2) # matrix to store results

  for (k in 1:length(bin)) {

    f = sum(m[k, 1] == x)
    m[k, 2] = f

  }
  m[ ,2]
}


 DGBSVX Example Program Results

 Solution(s)
             1          2
 1     -2.0000     1.0000
 2      3.0000    -4.0000
 3      1.0000     7.0000
 4     -4.0000    -2.0000

 Backward errors (machine-dependent)
       1.1E-16    9.9E-17

 Estimated forward error bounds (machine-dependent)
       1.6E-14    1.9E-14

 Estimate of reciprocal condition number
       1.8E-02

 A has not been equilibrated

 Estimate of reciprocal pivot growth factor
       1.0E+00


source("ac_powerflow_lib.r")

animation_steps = 120

steps = seq(0, 2*pi, length.out=animation_steps)

for (i in 1:length(steps)) {
    ac_powerflow(sprintf("admittance_angle_flow/%03d.pdf",i), y_a = -1.45 + steps[i])
    ac_powerloss(sprintf("admittance_angle_loss/%03d.pdf",i), y_a = -1.45 + steps[i])
}

# steps = seq(0, 99, length.out=animation_steps)

# for (i in 1:length(steps)) {
#     ac_powerflow(sprintf("admittance_magnitude_flow/%03d.pdf",i), y_m = 1.0 + steps[i])
#     ac_powerloss(sprintf("admittance_magnitude_loss/%03d.pdf",i), y_m = 1.0 + steps[i])
# }


#' A LASSO model selection function
#'
#' This function allows to select by crossvalidation one or a serie of different models allowing for best performance. The function is a wrapper for glmnet package.
#'
#' @param datax A data.frame of explicative variables to be studied of length equal to explicative variable vector
#' @param dependent A dependent variable vector
#' @param laglim The model allows to automatically convert the dataset in order to study lagged dependecies
#' @param study.t0 A logical value indicating whether the t0 period should be taken into account
#' @param folds Number of folds for crossvalidation
#' @param modlim A maximum number of additional models to be presented in output
#' @param varlim A maximal number of variables to figure in supplementary models
#'
#' @return A list of selected models estimated with OLS
#' \describe{
#'  \item{optimal}{The model for best lambda value, selected by cross validation}
#'  \item{other}{A list of other models in order of goodness of fit with limited regressors}
#' }
#' @keywords LASSOanalyse
#' @export
#' @examples
#' LASSOanalyse(data, dependent,
#'      laglim = 5, study.t0 = TRUE, folds = 10,
#'      modlim = 1, varlim = 10)
#' @import tidyverse
#' @import glmnet
#'
LASSOanalyse = function(datax, # Explanatory variables dataframe
    dependent, # Dependent variable
    laglim = 5, # Limit of the lag to explore to
    study.t0 = TRUE,
    folds = 10,
    modlim = 1,
    varlim = 10 # Limit of the variables to inlude into final model
    ) {
    ###############
    # Load packages
    cat("Stage 1 \n")
    #####################
    # Database recreation
    # Taking lags into account
    cat("Stage 2 \n")
    # Taking into accoun t0
    if (study.t0 == TRUE) {
        # For defined lag order
        if (laglim != 0) {
            database = datax
            for (i in 1:laglim) {
                cat(i, "\n")
                databaseX = datax %>%
                    mutate_all(function(x) lag(x, i))
                names(databaseX) =
                    paste0("l", i, "_", names(datax))
                database = cbind(database, databaseX)
                rm(databaseX)
            }
            rm(datax) ; gc()
        # Only t0 data study
        } else {
            database = datax
            rm(datax) ; gc()
        }
    # No taking into account t0
    } else {
        # Defined lag order
        if (laglim != 0) {
            # First lag base creation
            cat(1, "\n")
            database = datax %>%
                    mutate_all(function(x) lag(x, n = 1))
            names(database) =
                    paste0("l", 1, "_", names(datax))
            # More than 1 lag account
            if (laglim > 1) {
                for (i in 2:laglim) {
                    cat(i, "\n")
                    databaseX = datax %>%
                        mutate_all(function(x) lag(x, n = i))
                    names(databaseX) =
                        paste0("l", i, "_", names(datax))
                    database = cbind(database, databaseX)
                    rm(databaseX)
                }
            }
            rm(datax) ; gc()
        # Extra case for conflicts
        } else {
            cat("No laglim defined,
                proceeding with t0 period study \n")
            database = datax
            rm(datax) ; gc()
        }
    }
    ################
    # GLM LASSO part
    cat("Stage 3 \n")
    # Data
    # NA treatment
    nas = which(is.na(database), arr.ind = TRUE)
    nas = unique(nas[,1])
    # Subsetting rows without NAs
    databaseX = as.matrix(database[-nas,])
    dependent = as.matrix(dependent[-nas])
    # LASSO Cross validation
    res_lasso = cv.glmnet(databaseX, dependent,
        nfolds = folds)
    # Optimal lambda by variables limit
    ## Get validation information
    ns = data.frame(
        n = 1:length(res_lasso$lambda),
        lambda = res_lasso$lambda,
        cvm = res_lasso$cvm,
        cvsd = res_lasso$cvsd,
        df = head(res_lasso$glmnet.fit$df,
            length(res_lasso$lambda))) %>%
        filter(df <= varlim) %>%
        arrange(cvm) %>%
        head(modlim) %>%
        select(n) %>%
        as.integer()
    # Select lambda proposed by selection
    lambda_opt = res_lasso$lambda.min
    ##########
    # MCO part
    cat("Stage 4.1 \n")
    # Evaluate OLS for every model
    if (length(ns) != 0) {
        models = list()
        for (i in 1:length(ns)) {
            # Get variables positions
            ox_vars = which(res_lasso$glmnet.fit$beta[,ns[i]] != 0)
            # Results OLS
            models[[i]] = lm(dependent ~ databaseX[,ox_vars])
        }
    } else {
        models = "No models satisfying the indicated criteria"
    }
    # LASSO for optimal lambda
    cat("Stage 4.2 \n")
    opt_vars = which(glmnet(databaseX, dependent,
        lambda = lambda_opt)$beta != 0)
    # Run MCO
    ols_opt = lm(dependent ~ databaseX[,opt_vars])
    ################
    # Return results
    results = list(optimal = ols_opt,
        other = models)
    # Output
    return(results)
}


# 3. faza: Vizualizacija podatkov
source("lib/libraries.r", encoding="UTF-8")

Place_ <- gather(Tabela_place,key='Leto',value='Place',2:12)  #vse damo v tri stolpce; Drzava,leto,plače (zapis za risanje grafov)
BDP_ <- gather(Tabela_BDP,key='Leto',value='BDP',2:12)
Davki_ <- gather(Tabela_davki,key='Leto',value='Davki',2:12)

graf_place <- ggplot(Place_, aes(x=Leto, y= Place, colour=Drzava, group=Drzava)) +
  geom_line() +  #povežemo podatke iz istih držav
  geom_point() +
  ggtitle("Gibanje neto plač v posameznih državah 2008-2018") +
  ylab("Višina Plače")

graf_BDP <- ggplot(BDP_, aes(x=Leto, y= BDP, colour=Drzava, group=Drzava)) +  #'group Drzava' pove funkciji, da poveže podatke za isto državo z eno črto
  geom_line() +
  geom_point() +
  ggtitle("Gibanje vrednosti BDP v posameznih državah 2008-2018") +
  ylab("Vrednost BDP")

graf_davki <- ggplot(Davki_, aes(x=Leto, y= Davki, colour=Drzava, group=Drzava)) +
  geom_line() +
  geom_point() +
  ggtitle("Gibanje višine davkov v posameznih državah 2008-2018") +
  ylab("Višina davkov")
#tukaj vidimo da višina davkov močno niha, zato grafa ne bom vključil v samo poročilo

#podrobneje si poglejmo podatke za državo, ki ima najvišjo povprečno plačo (Islandija), najnižjo plačo (Bolgarija) in Slovenijo.

#Islandija
Place_Isl <- Place_[Place_$Drzava == 'Iceland', ]
BDP_Isl <- BDP_[BDP_$Drzava == 'Iceland', ]

graf_Islandija <- ggplot() +
  #plače
  geom_point(data=Place_Isl, aes(x=Leto, y=Place),colour='red') +
  #BDP
  geom_point(data=BDP_Isl, aes(x=Leto, y=BDP),colour='blue') +
  ggtitle("Islandija") +
  xlab("Leto") + ylab("Plače/BDP")

#Bolgarija
Place_Bul <- Place_[Place_$Drzava == 'Bulgaria', ]
BDP_Bul <- BDP_[BDP_$Drzava == 'Bulgaria', ]

graf_Bolgarija <- ggplot() +
  #plače
  geom_point(data=Place_Bul, aes(x=Leto, y=Place),colour='red') +
  #BDP
  geom_point(data=BDP_Bul, aes(x=Leto, y=BDP),colour='blue') +
  ggtitle("Bolgarija") +
  xlab("Leto") + ylab("Plače/BDP")

#Slovenija
Place_Slo <- Place_[Place_$Drzava == 'Slovenia', ]
BDP_Slo <- BDP_[BDP_$Drzava == 'Slovenia', ]

graf_Slovenija <- ggplot() +
  #plače
  geom_point(data=Place_Slo, aes(x=Leto, y=Place),colour='red') +
  #BDP
  geom_point(data=BDP_Slo, aes(x=Leto, y=BDP),colour='blue') +
  ggtitle("Slovenija") +
  xlab("Leto") + ylab("Plače/BDP")

data("World")  #iz tmap dobimo zemljevid sveta

zemljevid_plac <- function(){
  Evropa <- World
  place <- Tabela_place %>% select('Drzava', '2018')  #vzamemo samo leto 2018
  stevila <- merge(y = place,x = Evropa, by.x= 'sovereignt', by.y = 'Drzava')  #vzamemo stolpec sovereignt, da se imena ujemajo
  Evropa <- tm_shape(stevila) + tm_polygons('2018')
  tmap_mode('view')
  return(Evropa)
}
zemljevid_plac()

zemljevid_davkov <- function(){
  Evropa <- World
  davki <- Tabela_davki %>% select('Drzava', '2018')
  stevila <- merge(y = davki,x = Evropa, by.x= 'sovereignt', by.y = 'Drzava')
  Evropa <- tm_shape(stevila) + tm_polygons('2018')
  tmap_mode('view')
  return(Evropa)
}
zemljevid_davkov()

zemljevid_BDP <- function(){
  Evropa <- World
  BDP <- Tabela_BDP %>% select('Drzava', '2018')
  stevila <- merge(y = BDP,x = Evropa, by.x= 'sovereignt', by.y = 'Drzava')
  Evropa <- tm_shape(stevila) + tm_polygons('2018')
  tmap_mode('view')
  return(Evropa)
}
zemljevid_BDP()


rand.parens <- function(n) paste(permute(c(rep('[',n),rep(']',n))),collapse="")

as.data.frame(within(list(), {
  parens <- replicate(10, rand.parens(sample.int(10,size=1)))
  balanced <- sapply(parens, balanced)
}))


# Script to fit an SEIRS-SEI dengue transmission model to weekly trap counts
# and reports of "dengue-like illness" using Stan.

library(rstan)
library(plyr)
library(magrittr)
library(lubridate)

# Setting Stan options
rstan_options(auto_write = TRUE)
options(mc.cores = parallel::detectCores())

#===============================================================================
# Loading data and setting up model

tseries <- read.csv("Data/Vitoria.data.csv")

data <- ddply(tseries, .(tot.week), summarise,
              obs = sum(Cases, na.rm = T),
              q = sum(Mosquitoes, na.rm = T),
              tau = sum(Trap, na.rm = T),
              year = unique(Year),
              week = unique(Week)
              )

# Population size
pop <- 327801

# Wrangling weather data and computing EIP
weather <- read.csv("Data/Vitoria.weather.csv") %>%
  mutate(date = ymd(BRST), year = year(date), week = week(date))

weather <- subset(weather, date < date[1] + weeks(243))
weather$tot.week <- rep(c(1:243), each = 7)

# Weekly mean temperature
covars <- ddply(weather, .(tot.week), summarise,
                temp = mean(Mean.TemperatureC, na.rm = T),
                humid = mean(Mean.Humidity, na.rm = T))

# Computing inverse of extrinsic incubation period
rov <- 7 * exp(0.21 * covars$temp - 7.9)

#===============================================================================
# Running stan

# Setting imports (if any)
firsts <- daply(data, .(year), function(df) min(df$tot.week))[2:5]
import <- rep(0, 243)
# import[firsts - 8] <- 10 / pop

# Wrapping up all the data
dat.stan <- list(T = 243,
                 steps = 7,
                 y =data$obs,
                 q = data$q,
                 tau = data$tau,
                 rov = rov,
                 control = matrix(1.0, nrow = 243, ncol = 3),
                 import = import,
                 pop = pop)

# Specifying initial conditions for 3 chains
inits = list(list(S0 = 0.4,
                  E0 = 80,
                  I0 = 40,
                  log_phi_q = -13,
                  phi_y = 1/12,
                  eta_inv_y = 0.1,
                  eta_inv_q = 0.1,
                  ro_c = 0.8,
                  gamma_c = 1,
                  delta_c = 0.8,
                  dvmu_c = 1,
                  logNv = 1.5,
                  dv0 = 0,
                  rv0 = 0,
                  sigmadv = 0.2,
                  sigmarv = 0.2,
                  eps_dv = rep(0, 243),
                  eps_rv = rep(0, 243)),
             list(S0 = 0.3,
                  E0 = 100,
                  I0 = 80,
                  log_phi_q = -13.5,
                  phi_y = 1/6,
                  eta_inv_y = 1,
                  eta_inv_q = 1,
                  ro_c = 1,
                  gamma_c = 1.2,
                  delta_c = 1,
                  dvmu_c = 0.6,
                  logNv = 0.7,
                  dv0 = 0,
                  rv0 = 0,
                  sigmadv = 0.5,
                  sigmarv = 0.5,
                  eps_dv = rep(0, 243),
                  eps_rv = rep(0, 243)),
             list(S0 = 0.5,
                  E0 = 40,
                  I0 = 20,
                  log_phi_q = -12.5,
                  phi_y = 1/24,
                  eta_inv_y = 5,
                  eta_inv_q = 5,
                  ro_c = 0.9,
                  gamma_c = 0.5,
                  delta_c = 0.6,
                  dvmu_c = 1,
                  logNv = 1,
                  dv0 = 0,
                  rv0 = 0,
                  sigmadv = 0.01,
                  sigmarv = 0.01,
                  eps_dv = rep(0, 243),
                  eps_rv = rep(0, 243)))

# Running HMC
# Note non-default options for adapt_delta and max_treedepth, which
# help ensure good mixing and avoid divergent transitions
# Also note that this will take on the order of 1 week to run

fit <- stan(file = "Code/gammaeip.stan",
            data = dat.stan,
            init = inits,
            iter = 2000,
            chains = 3,
            control = list(adapt_delta = 0.99,
                           max_treedepth = 15))

saveRDS(fit, "Results/chain.rds")


# Calculate lat gradients of mean and max habitat temperatures from observations

# load data
load('temp/tosmax.rdata') # tosmax 0.25x0.25 from OISST daily + HadDTR
load('temp/hadex2_txx.rdata') # hadex2txx

# lat averages for max habitat temperature
sstmaxhrlat <- data.frame(lat = as.numeric(rownames(tosmax)))
sstmaxhrlat$mean <- apply(tosmax, MARGIN=1, FUN=mean, na.rm=TRUE)
sstmaxhrlat$sd <- apply(tosmax, MARGIN=1, FUN=sd, na.rm=TRUE)
sstmaxhrlat$n <- apply(tosmax, MARGIN=1, FUN=function(x) sum(!is.na(x)))

hadex2txxlat <- data.frame(lat = as.numeric(rownames(hadex2txx)))
hadex2txxlat$mean <- apply(hadex2txx, MARGIN=1, FUN=mean, na.rm=TRUE)
hadex2txxlat$sd <- apply(hadex2txx, MARGIN=1, FUN=sd, na.rm=TRUE)
hadex2txxlat$n <- apply(hadex2txx, MARGIN=1, FUN=function(x) sum(!is.na(x)))

# plots
par(mfrow=c(1,2))
	# land
with(hadex2txxlat, lines(lat, mean, col='orange'))
with(hadex2txxlat, lines(lat, mean-sd, col='orange', lty=2))
with(hadex2txxlat, lines(lat, mean+sd, col='orange', lty=2))

	# ocean
with(sstmaxhrlat, lines(lat, mean, col='red'))
with(sstmaxhrlat, lines(lat, mean-sd, col='red', lty=2))
with(sstmaxhrlat, lines(lat, mean+sd, col='red', lty=2))

# write out
write.csv(hadex2txxlat, file='temp/hadex2txxlat.csv')
write.csv(sstmaxhrlat, file='temp/sstmaxhrlat.csv')


#===================================
#
# Detection probability - survival analysis
# -----
library(tidyverse)
library(lubridate)
library(sf)
library(purrr)
library(nimble)
library(posterior)
source("R/judas functions.r")

goat_dyads<- read_csv("data/Santiago_judas_dyads.csv")
goat_dyads<- goat_dyads %>% mutate(id1 = factor(as.character(id1)), id2 = factor(as.character(id2)))
goat_ids<- goat_dyads %>% select(ID=id1,Sex=Sex1,Trans=Trans1) %>% distinct() %>% arrange(ID)

id1<- as.vector(unclass(goat_dyads$id1))
id2<- as.vector(unclass(goat_dyads$id2))

dyad<- as.vector(unclass(factor(goat_dyads$Dyad)))
ndyads<- max(dyad)
N<- nrow(goat_dyads)
M<- nrow(goat_ids)
X<- model.matrix(~ distance + Sex1 + Trans1, data=goat_dyads)[,-1]
K<- ncol(X)
sex<- model.matrix(~Sex + Trans, goat_ids)[,-1]

# Calculate home range scale (sigma) from Judas locations

goat_locs<- read_csv("data/santiago_judas_locs.csv")
goat_locs<- goat_locs %>% mutate(ID = factor(as.character(ID)))
goat_locs<- goat_locs %>% group_by(ID) %>% nest() %>% arrange(ID)

goat_chr<- goat_locs %>% mutate(CNorm=map(data, calc_hr))
goat_chr<- goat_chr %>% unnest(CNorm) %>% select(-data)

maxD<- goat_chr$sigma * 2.45

#------------------------------------------------------
# Discrete survival analysis

# Nimble function to undertake estimation of Marginal detection probability (Eqn. 2)

integrateP<- function(b0, b1, beta, XX, maxD) {
  integrand<- function(x, b0, b1, beta, XX, maxD) {
    e<- 2*x/maxD^2
    sex.effects<- as.vector(beta %*% XX)
    int<- e * (1-exp(-exp(b0 + b1*x + sex.effects)))
    return(int)
  }
  return(integrate(integrand,lower=0,upper=maxD, b0=b0, b1=b1, beta=beta, XX=XX, maxD=maxD,
                   rel.tol = .Machine$double.eps^0.5)[[1]])
}

RintegrateP <- nimbleRcall(function(b0=double(0), b1=double(0), beta=double(1),
                                    XX=double(1), maxD=double(0)){}, Rfun='integrateP',
                           returnType = double(0))

# Nimble code -  Note: since no time varying parameters/covariates we can group intervals
# and use a binomial distribution rather than bernoulli.

code<- nimbleCode({

  for (i in 1:N) {
    ev[i] ~ dbin(q[i], time[i])
    cloglog(q[i])<- b1 + inprod(X[i,1:K],beta[1:K]) + eps_id1[id1[i]] + eps_id2[id2[i]]
  }

  for(k in 1:M) {
    eps_id1[k] ~ dnorm(0, sd=sigma_id1)
    eps_id2[k] ~ dnorm(0, sd=sigma_id2)
    beta0[k] <- b1 + eps_id1[k]
    Pave[k]<- RintegrateP(beta0[k], beta[1], beta[2:K], sex[k,1:(K-1)], maxD[k])
  }

  for(j in 1:K) {
    beta[j] ~ dnorm(0, sd=5)
  }
  b1 ~ dnorm(0, sd=5)

  sigma_id1 ~ T(dt(0, 1, 4),0,)
  sigma_id2 ~ T(dt(0, 1, 4),0,)

})
#----------------------

constants<- list(N=N, M=M, K=K, id1=id1, id2=id2)
data<- list(time=goat_dyads$time,ev=goat_dyads$event, X=X, sex=sex, maxD=maxD)

inits1<- list(b1=-4, beta= c(-1,1,1,1), sigma_id1=runif(1),sigma_id2=runif(1),
              q=rep(0.01,N),eps_id1=runif(M,-2,0),eps_id2=runif(M, -2,0))

## create the model object
Rmodel <- nimbleModel(code=code, constants=constants, data=data, inits=inits1)
Rmcmc<- compileNimble(Rmodel)

ModSpec <- configureMCMC(Rmodel)
#ModSpec$removeSamplers(c("eps_id1"), print = FALSE)
#ModSpec$removeSamplers(c("eps_id2"), print = FALSE)
#ModSpec$addSampler(target =c("eps_id1"), type = 'AF_slice', print=FALSE)
#ModSpec$addSampler(target =c("eps_id2"), type = 'AF_slice', print=FALSE)
ModSpec$resetMonitors()
ModSpec$addMonitors(c("b1","beta","sigma_id1","sigma_id2","beta0","Pave"))

Cmcmc <- buildMCMC(ModSpec)
Cmodel <- compileNimble(Cmcmc, project = Rmodel, resetFunctions = T)

n.iter<- 2000
n.burnin<- 1000
n.thin<- 1
n.chains<- 3

inits<- function(){inits1}

samp<- runMCMC(Cmodel, niter=n.iter, nburnin=n.burnin, thin=n.thin, nchains=n.chains,inits=inits,
               samplesAsCodaMCMC = TRUE)

tmp<- subset_draws(as_draws(samp), variable=c("b1","beta","sigma_id1","sigma_id2"))
summarise_draws(tmp)

tmp<- subset_draws(as_draws(samp), variable=c("Pave"))
summarise_draws(tmp)
#--------------------------------------------------------------------
# Plots
#--------------------------------------------------------------------

# Predicted probability of detection at activity centres (i.e. distance = 0)

fit<- as_draws_rvars(samp)

beta0<- draws_of(fit$beta0)
beta<- draws_of(fit$beta)
beta1<- beta[,1]
beta2<- beta[,-1]

n<- nrow(goat_ids)
XX<- model.matrix(~Sex + Trans, goat_ids)[,-1]

plam<- matrix(NA,nrow=dim(beta)[1],ncol=n)
for(i in 1:n){
  plam[,i]<- 1-exp(-exp(beta0[,i] + beta2 %*% XX[i,]))
}

plam<- as.data.frame(plam)
names(plam)<- goat_ids$ID
plam$samp<- 1:nrow(plam)

plam<- plam %>% pivot_longer(-samp, names_to = "ID", values_to = "p")
plam<- left_join(plam, goat_ids)
plam<- plam %>% mutate(Sex = factor(Sex, levels=c("Female","Super","Male")),
                       Trans = factor(Trans, labels = c("Not Translocated","Translocated")))

win.graph(10,5)
plam %>% ggplot(aes(ID, p, color=interaction(Sex,Trans))) +
  geom_boxplot(fill="grey90",outlier.color = NA) +
  labs(x="Judas ID", y="Detection probability at HR centre") +
  theme_bw() +
  theme(axis.text.x = element_blank(),
        legend.position = "bottom",
        legend.title = element_blank())

#--------------------------------------------------------
# Predicted detection curves with distance from HR centre
#--------------------------------------------------------
fit<- as_draws_rvars(samp)

beta0<- E(fit$beta0)
beta<- E(fit$beta)
beta1<- beta[1]
beta2<- beta[-1]

n<- nrow(goat_ids)
distance<- seq(0,20,0.1)
XX<- model.matrix(~Sex + Trans, goat_ids)[,-1]

plam<- matrix(NA,nrow=length(distance), ncol=n)

for(i in 1:n){
  plam[,i]<- 1-exp(-exp(beta0[i] + beta1*distance + as.vector(XX[i,] %*% beta2)))
}
plam<- as.data.frame(plam)
names(plam)<- goat_ids$ID
plam<- plam %>% mutate(Distance=distance)

plam<- plam %>% pivot_longer(-Distance, names_to = "ID", values_to = "p")
plam<- left_join(plam, goat_ids)
plam<- plam %>% mutate(Sex = factor(Sex, levels=c("Female","Super","Male")),
                       Trans = factor(Trans, labels = c("Not Translocated","Translocated")))

win.graph(8,7)
plam %>% ggplot(aes(Distance, p, group=ID)) +
  geom_line(color="grey50") +
  facet_grid(rows=vars(Sex), cols=vars(Trans)) +
  labs(x="Distance (km)",y="Probability of association") +
  theme_bw() +
  theme(legend.position = "none",
        strip.text = element_text(face="bold"))

#--------------------------------------------------------------------
# Unconditional detection probability (Eqn. 2)
#--------------------------------------------------------------------

fit<- subset_draws(as_draws_rvars(samp), variable="Pave")

plam<- goat_ids %>% mutate(pave= E(fit$Pave), lcl = quantile2(fit$Pave)[1,], ucl=quantile2(fit$Pave)[2,])
plam<- plam %>% mutate(Sex = factor(Sex, levels=c("Female","Super","Male")),
                       Trans = factor(Trans, labels = c("Not Translocated","Translocated")))

win.graph(10,5)
plam<- plam %>% arrange(pave)
plam %>%  mutate(ID = fct_reorder(ID, pave), Sex) %>%
  ggplot(aes(x=Trans, y=pave, color=Sex)) +
  geom_pointrange(aes(ymin=lcl,ymax=ucl), position=position_dodge2(width=0.5)) +
  facet_wrap(~Sex) +
  labs(x="",y="Probability of association",color="Status") +
  theme_bw() +
  theme(legend.position = "none",
        strip.text = element_text(face="bold"),
        axis.title = element_text(face="bold", size=12),
        axis.text.x = element_text(size=11))


# requirement: R >= 3.4
# Install Rstan first
Sys.setenv(MAKEFLAGS = "-j4")
install.packages("rstan", repos = "https://cloud.r-project.org/", dependencies=TRUE)
# Restart R and test with:
fx <- inline::cxxfunction( signature(x = "integer", y = "numeric" ) , '
     return ScalarReal( INTEGER(x)[0] * REAL(y)[0] ) ;
' )
fx( 2L, 5 ) # should be 10
# Install VAMF
install.packages("devtools")
devtools::install_github("willtownes/vamf")
# Load vamf
library(vamf)
# Install useful
install.packages(useful)
library(useful)

# Read in Group1 matrix
G1 <- read.table("Group1.matrix",header=FALSE,sep="\t")

# Check the matrix
corner(G1)
# Set Emsembl gene ID column as row names of the matrix
rownames(G1) <- G1$V1
# Remove Ensembl ID and gene name columns
G1 <- G1[,3:ncol(G1)]
# Check the right hand corner
corner(right(G1))
# Remove rows (genes) with no expression
G1 <- G1[rowSums(G1) != 0, ]

# More stringent filtering (at least one transcript in more than 10 cells):
 G1test <- G1[rowSums(G1 > 0) > 10, ]

# Convert array to matrix
typeof(G1test) # it should be "list"
G1testmtx <- as.matrix(G1test)
typeof(G1testmtx) # now it will be "integer"

# Do Principal Component Analysis
pca_factor <- prcomp(t(G1testmtx), center=TRUE, scale=TRUE)$x

# Save pca_factor to file
write.table(pca_factor, file = "Group1_pca_factor.txt", quote=FALSE, sep="\t") # if quote = TRUE, the name labels will have quote marks.

# Run VAMF
vamf_factor <- vamf(G1testmtx,10,nrestarts=2,log2trans=TRUE)$factors

# Save vamf_factor to file
write.table(vamf_factor, file="Group1_vamf_factor.txt", quote=FALSE, sep="\t")

# Plot separately.
plot(pca_factors[,1:2])
with(vamf_factors,plot(dim1,dim2))


require(plyr)
require(dplyr)
den <- data.frame(
  Rep = rep(1:3,each=100),
  val = runif(300)
  )
d2 <-den %>%  group_by(Rep) %>% mutate(nt=ntile(Rep,10)) %>%
  group_by(Rep,nt) %>% summarize(meanV=mean(val)) %>%
  mutate(nt=nt*100)


library("drat")
library("dde")
library("odin")

drat::add("mrc-ide")

## function to make colors transparent, stolen from adegenet::transp
transp <- function (col, alpha = 0.5) {
    res <- apply(col2rgb(col), 2,
                 function(c) rgb(c[1]/255, c[2]/255,
                                 c[3]/255, alpha))
    return(res)
}

## x: instance of odin model
## t: time steps
## n: number of replicates
run_model <- function(x, t = 0:100, n = 1, ...) {
    res <- x$run(t, replicate = n, ...)
    res <- x$transform_variables(res)
    res <- cbind.data.frame(t = res[[1]], res[-1])
    attr(res, "n_compartments") <- length(x$names) - 1
    attr(res, "n_replicates") <- n
    attr(res, "compartments") <- x$names[-1]
    class(res) <- c("pretty_odin", class(res))
    res
}

## plot function
plot.pretty_odin <- function(x, pal = seird_pal, transparency=FALSE,...) {
    ## handle colors
    n_compartments <- attr(x, "n_compartments")
    n_replicates <- attr(x, "n_replicates")
    col_leg <- pal(n_compartments)
    alpha <- max(10 / n_replicates, 0.05)
    if(transparency){
        col <- rep(transp(col_leg, alpha), each = n_replicates)
    }else{
        col <- rep(col_leg, each = n_replicates)
    }
    ## make plot
    par(mar = c(4.1, 5.1, 0.5, 0.5), las = 3)
    matplot(x[, 1], x[, -1], xlab = "Time", ylab = "Number of individuals",
            type = "l", col = col, lty = 1, ...)
    legend("topright", lwd = 1, col = col_leg, bty = "n",
           legend = attr(x, "compartments"))
}

## colors
seird_col <- c("#8c8cd9", "#e67300", "#d279a6", "#ff4d4d", "#999966", "#660000")
seird_pal <- colorRampPalette(seird_col)

seird_generator <- odin::odin({
  ## Core equations for transitions between compartments:
  update(S) <- S - n_SE + n_RS
  update(E) <- E + n_SE - n_EI + n_import_E
  update(Ir) <- Ir + n_EIr - n_IrR
  update(Id) <- Id + n_EId - n_IdD
  update(R) <- R + n_IrR - n_RS
  update(D) <- D + n_IdD

  ## Individual probabilities of transition:
  p_SE <- 1 - exp(-beta * I / N)
  p_EI <-  1 - exp(-delta)
  p_IrR <- 1 - exp(-gamma_R) # Ir to R
  p_IdD <- 1 - exp(-gamma_D) # Id to d
  p_RS <- 1 - exp(-omega) # R to S

  ## Draws from binomial distributions for numbers changing between
  ## compartments:
  n_SE <- rbinom(S, p_SE)
  n_EI <- rbinom(E, p_EI)

  n_EIrId[] <- rmultinom(n_EI, p)
  p[1] <- 1 - mu
  p[2] <- mu
  dim(p) <- 2
  dim(n_EIrId) <- 2
  n_EIr <- n_EIrId[1]
  n_EId <- n_EIrId[2]
  n_IrR <- rbinom(Ir, p_IrR)
  n_IdD <- rbinom(Id, p_IdD)

  n_RS <- rbinom(R, p_RS)

  n_import_E <- rpois(epsilon)

  ## Total population size, and number of infecteds
  I <- Ir + Id
  N <- S + E + I + R + D

  ## Initial states
  initial(S) <- S_ini
  initial(E) <- E_ini
  initial(Id) <- 0
  initial(Ir) <- 0
  initial(R) <- 0
  initial(D) <- 0

  ## User defined parameters - default in parentheses:
  S_ini <- user(1000) # susceptibles
  E_ini <- user(1) # infected
  beta <- user(0.3) # infection rate
  delta <- user(0.2) # inverse incubation period
  gamma_R <- user(0.2) # recovery rate
  gamma_D <- user(0.4) # death rate
  mu <- user(0.05) # CFR
  omega <- user(0.1) # rate of waning immunity
  epsilon <- user(0.05) # import case rate

  }, verbose = FALSE)

set.seed(1)
seird <- seird_generator(S_ini = 1e6, E_ini = 1, epsilon = 0.01, omega = 1)
x <- run_model(seird, t = 0:2000, n = 100)
plot(x)


#' Designs, simulates, and analyses a cluster randomised trial (CRT) with geographical contamination
#'
#' \code{CRTspillover} estimates the required number of clusters and the extent of contamination between arms for a CRT based on an input set of locations.
#' The trial is simulated and the simulated data are analysed.
#'
#' @param alpha confidence level
#' @param power power
#' @param effect required effect size
#' @param ICC Intra-Cluster Correlation obtained from other studies
#' @param pC baseline prevalence
#' @param cont contamination range in km, obtained from other studies
#' @param coordinates dataframe containing coordinates of households. Columns 'x' and 'y' should contain Cartesian (x,y) coordinates. Units are expected to be km.
#' @param h  proposal for the number of coordinates in each cluster
#' @param algo algorithm for cluster boundaries, choose between
#' "TSP": travelling salesman problem heuristic;
#' "NN": nearest neighbor;
#' "kmeans": kmeans algorithm
#' @param reuseTSP indicator of whether a pre-existing path should be used by the TSP algorithm
#' @param sd standard deviation measuring spatial smoothing of proportion
#' @param method statistical method used to analyse trial.
#' Options are 'piecewise_linear','logit','sigmoid','empirical','GEE','MCMC01','MCMC02','MCMC03'
#' @param excludeBuffer exclude any buffer zone (records with buffer=TRUE) from the analysis
#' @param requireBootstrap logical indicator of whether bootstrap confidence intervals are required
#' @param resamples number of bootstrap samples if bootstrap confidence intervals are required
#' @param burnin number of burnin interations of MCMC algorithm (for MCMC methods)
#' @param iter total number of interations of MCMC algorithm (for MCMC methods)
#' @return list object with the following attributes:
#' \itemize{
#' \item \code{design}: list of vector-specific entomological parameters (see
#' description of output from function \code{Design_CRT})
#' \item \code{simulation}: vector of intervention-specific entomological
#' parameters and impact (vectorial capacity) values
#' \item \code{analysis}: list of results of statistical analysis of the simulated trial (see
#' description of output from function \code{Analyse_CRT})
#' }
#' @export
#'
#' @examples
#'
CRTspillover = function(alpha = 0.05, power = 0.8, effect = 0.4, ICC = 0.175,
  pC = 0.4, cont = 0.25, coordinates=AvecNet_coordinates, h = 80, algo = "kmeans",
  reuseTSP=FALSE, sd = 0.4, method='MCMC03', excludeBuffer=FALSE, requireBootstrap=FALSE,
  resamples=1000, iter=10000, burnin=5000){

  design =Design_CRT(alpha = alpha, power = power, effect = effect, ICC = ICC,
              pC = pC, cont = cont, coordinates=coordinates, h = h, algo = algo, reuseTSP=reuseTSP)

  simulation = Simulate_CRT(trial=design$assignments, efficacy=effect, initialPrevalence=pC, sd=sd)

  analysis = Analyse_CRT(trial=simulation, method=method, excludeBuffer=excludeBuffer, requireBootstrap=requireBootstrap,
              alpha=alpha, resamples=resamples, burnin=burnin)

  CRT=list(design=design,simulation=simulation,analysis=analysis)
return(CRT)}


library(assertthat)

evaluate <- function(Y, F){
  assert_loss(Y,F)
  (Y-F)^2
}

neg_grad <- function(Y, F){
  assert_loss(Y,F)
  (Y-F)
}

effect <- function(Ft, Ff){
  assert_loss(Ft,Ff)
  mean(Ft-Ff)
}

assert_loss <- function(Y, F){
  assert_that(is.numeric(Y))
  assert_that(is.numeric(F))
  assert_that(length(Y)==length(F))
}


#' Conversion between adjacency matrix and edgelist
#'
#' Generates adjacency matrix from an edgelist and vice versa.
#'
#' @param edgelist Two column matrix/data.frame in the form of ego -source- and
#' alter -target- (see details).
#' @templateVar undirected TRUE
#' @templateVar self TRUE
#' @templateVar multiple TRUE
#' @template graph_template
#' @param w Numeric vector. Strength of ties (optional).
#' @param t0 Integer vector. Starting time of the ties (optional).
#' @param t1 Integer vector. Finishing time of the ties (optional).
#' @param t Integer scalar. Repeat the network \code{t} times (if no \code{t0,t1} are provided).
#' @param simplify Logical scalar. When TRUE and \code{times=NULL} it will return an adjacency
#' matrix, otherwise an array of adjacency matrices.
#' (see details).
#' @param keep.isolates Logical scalar. When FALSE, rows with \code{NA/NULL} values
#' (isolated vertices unless have autolink) will be droped (see details).
#' @param recode.ids Logical scalar. When TRUE ids are recoded using \code{\link{as.factor}}
#' (see details).
#' @details
#'
#' When converting from edglist to adjmat the function will \code{\link{recode}} the
#' edgelist before starting. The user can keep track after the recording by checking
#' the resulting adjacency matrices' \code{\link{row.names}}. In the case that the
#' user decides skipping the recoding (because wants to keep vertices index numbers,
#' implying that the resulting graph will have isolated vertices), he can override
#' this by setting \code{recode.ids=FALSE} (see example).
#'
#' When multiple edges are included, \code{multiple=TRUE},each vertex between \eqn{\{i,j\}}{{i,j}} will be counted
#' as many times it appears in the edgelist. So if a vertex \eqn{\{i,j\}}{{i,j}} appears 2
#' times, the adjacency matrix element \code{(i,j)} will be 2.
#'
#' Edges with incomplete information (missing data on \code{w} or \code{times}) are
#' not included on the graph. Incomplete cases are tagged using \code{\link{complete.cases}}
#' and can be retrieved by the user by accessing the attribute \code{incomplete}.
#'
#' Were the case that either ego or alter are missing (i.e. \code{NA} values), the
#' function will either way include the non-missing vertex. See below for an example
#' of this.
#'
#' The function performs several checks before starting to create the adjacency
#' matrix. These are:
#' \itemize{
#'  \item{Dimensions of the inputs, such as number of columns and length of vectors}
#'  \item{Having complete cases. If anly edge has a non-numeric value such as NAs or
#'  NULL in either \code{times} or \code{w}, it will be
#'  removed. A full list of such edges can be retrieved from the attribute
#'  \code{incomplete}}
#'  \item{Nodes and times ids coding}
#' }
#'
#' \code{recode.ids=FALSE} is useful when the vertices ids have already been
#' coded. For example, after having use \code{adjmat_to_edgelist}, ids are
#' correctly encoded, so when going back (using \code{edgelist_to_adjmat})
#' \code{recode.ids} should be FALSE.
#'
#'
#'
#' @return In the case of \code{edgelist_to_adjmat} either an adjacency matrix
#' (if times is NULL) or an array of these (if times is not null). For
#' \code{adjmat_to_edgelist} the output is an edgelist with the following columns:
#' \item{ego}{Origin of the tie.}
#' \item{alter}{Target of the tie.}
#' \item{value}{Value in the adjacency matrix.}
#' \item{time}{Either a 1 (if the network is static) or the time stamp of the tie.}
#' @export
#' @examples
#' # Base data
#' set.seed(123)
#' n <- 5
#' edgelist <- rgraph_er(n, as.edgelist=TRUE, p=.2)[,c("ego","alter")]
#' times <- sample.int(3, nrow(edgelist), replace=TRUE)
#' w <- abs(rnorm(nrow(edgelist)))
#'
#' # Simple example
#' edgelist_to_adjmat(edgelist)
#' edgelist_to_adjmat(edgelist, undirected = TRUE)
#'
#' # Using w
#' edgelist_to_adjmat(edgelist, w)
#' edgelist_to_adjmat(edgelist, w, undirected = TRUE)
#'
#' # Using times
#' edgelist_to_adjmat(edgelist, t0 = times)
#' edgelist_to_adjmat(edgelist, t0 = times, undirected = TRUE)
#'
#' # Using times and w
#' edgelist_to_adjmat(edgelist, t0 = times, w = w)
#' edgelist_to_adjmat(edgelist, t0 = times, undirected = TRUE, w = w)
#'
#' # Not recoding ----------------------------------------------------
#' # Notice that vertices 3, 4 and 5 are not present in this graph.
#' graph <- matrix(c(
#'  1,2,6,
#'  6,6,7
#' ), ncol=2)
#'
#' # Generates an adjmat of size 4 x 4
#' edgelist_to_adjmat(graph)
#'
#' # Generates an adjmat of size 7 x 7
#' edgelist_to_adjmat(graph, recode.ids=FALSE)
#'
#' # Dynamic with spells -------------------------------------------------------
#' edgelist <- rbind(
#'    c(1,2,NA,1990),
#'    c(2,3,NA,1991),
#'    c(3,4,1991,1992),
#'    c(4,1,1992,1993),
#'    c(1,2,1993,1993)
#' )
#'
#' graph <- edgelist_to_adjmat(edgelist[,1:2], t0=edgelist[,3], t1=edgelist[,4])
#'
#' # Creating a diffnet object with it so we can apply the plot_diffnet function
#' diffnet <- as_diffnet(graph, toa=1:4)
#' plot_diffnet(diffnet, label=rownames(diffnet))
#'
#' # Missing alter in the edgelist ---------------------------------------------
#' data(fakeEdgelist)
#'
#' # Notice that edge 202 is isolated
#' fakeEdgelist
#'
#' # The function still includes vertex 202
#' edgelist_to_adjmat(fakeEdgelist[,1:2])
#'
#' edgelist
#'
#' @keywords manip
#' @family data management functions
#' @include graph_data.r
#' @author George G. Vega Yon & Thomas W. Valente
edgelist_to_adjmat <- function(
  edgelist, w=NULL,
  t0=NULL, t1=NULL, t=NULL, simplify=TRUE,
  undirected=getOption("diffnet.undirected"), self=getOption("diffnet.self"), multiple=getOption("diffnet.multiple"),
  keep.isolates=TRUE, recode.ids=TRUE) {

  cls <- class(edgelist)
  if ("data.frame" %in% cls)
    edgelist_to_adjmat.data.frame(
      edgelist, w, t0, t1, t, simplify, undirected, self, multiple,
      keep.isolates, recode.ids
    )
  else if ("matrix" %in% cls)
    edgelist_to_adjmat.matrix(
      edgelist, w, t0, t1, t, simplify, undirected, self, multiple,
      keep.isolates, recode.ids)
  else stop("-edgelist- should be either a data.frame, or a matrix.")
}

# @rdname edgelist_to_adjmat
# @export
edgelist_to_adjmat.data.frame <- function(
  edgelist, w,
  t0,t1, t, simplify,
  undirected, self, multiple,
  keep.isolates, recode.ids) {

  edgelist_to_adjmat.matrix(as.matrix(edgelist), w, t0,t1, t, simplify,
                            undirected, self, multiple, keep.isolates,
                            recode.ids)
}

# @rdname edgelist_to_adjmat
# @export
edgelist_to_adjmat.matrix <- function(
  edgelist, w,
  t0, t1,
  t, simplify,
  undirected, self, multiple,
  keep.isolates, recode.ids) {

  # Step 0: Checking dimensions
  if (ncol(edgelist) !=2) stop("Edgelist must have 2 columns")
  if (length(t0) && nrow(edgelist) != length(t0))
    stop("-t0- should have the same length as number of rows in -edgelist-.",
         " Currently they are ",length(t0), " and ", nrow(edgelist),
         " respectively.")
  if (length(t1) && nrow(edgelist) != length(t1))
    stop("-t1- should have the same length as number of rows in -edgelist-.",
         " Currently they are ",length(t1), " and ", nrow(edgelist),
         " respectively.")
  if (length(w) && nrow(edgelist) != length(w))
    stop("-w- should have the same length as number of rows in -edgelist-.",
         " Currently they are ",length(w), " and ", nrow(edgelist),
         " respectively.")

  ##############################################################################
  # Step 1: Incomplete cases.
  # Finding incomplete cases. This is always done since we need to provide a
  # complete list of variables to the C++ function, otherwise it will throw
  # an error.
  if (length(w)) complete <- complete.cases( w)
  else complete <- rep(TRUE, nrow(edgelist))
  edgelist <- edgelist[complete,]

  incomplete <- which(!complete)

  # Getting the list of isolated vertices
  not.isolated <- which(!is.na(edgelist[,1]) & !is.na(edgelist[,2]))

  # If the user chooses to drop incomplete, then what changes is the selection
  # of ids in the graph.
  # Times and w MUST be removed since wont be used in the C++ function
  if (length(incomplete))
    warning("Some edges a had NA/NULL value on either -times- or -w-:\n\t",
            paste0(head(incomplete,20), collapse = ", "),
            ifelse(length(incomplete)>20,", ...", ""),
            "\nThese won't be included in the adjacency matrix. The complete list will be stored as an attribute of the resulting",
            " adjacency matrix, namely, -incomplete-.")

  # If no.incomplete is activated, then the vectors should be fixed
  if (!keep.isolates) edgelist <- edgelist[not.isolated,,drop=FALSE]

  ##############################################################################
  # Step 2: Recoding nodes ids
  # Recoding nodes ids
  if (recode.ids) {
    # Recoding
    dat <- recode(edgelist)
    n <- max(dat, na.rm = TRUE)

    # Retrieving codes + labels. If use.incomplete == FALSE, then the edgelist
    # has already been filtered
    recodedids <- attr(dat, "recode")
    if (keep.isolates) dat <- dat[not.isolated,]
    attr(dat, "recode") <- recodedids
    rm(recodedids)
  }
  else {
    dat <- edgelist
    n <- max(dat, na.rm = TRUE)
  }

  ##############################################################################
  # Step 3: Preparing -times- and -w- considering complete cases.
  # Times + recoding
  m <- nrow(dat)
  if (length(t0)) t0 <- t0[complete][not.isolated]
  else t0 <- rep(NA, m)

  if (length(t1)) t1 <- t1[complete][not.isolated]
  else t1 <- rep(NA, m)

  suppressWarnings(oldtimes <- range(c(t0,t1), na.rm=TRUE))
  if (all(!is.finite(oldtimes))) oldtimes <- rep(1,2)
  oldtimes <- oldtimes[1]:oldtimes[2]

  t0    <- t0 - oldtimes[1] + 1L
  t1    <- t1 - oldtimes[1] + 1L

  # Replacing NAs
  t0[is.na(t0)] <- 1
  if (!length(t)) t <- max(c(t0,t1), na.rm=TRUE)
  t1[is.na(t1)] <- t

  # Weights
  if (length(w)) w <- w[complete][not.isolated]
  else w <- rep(1, m)

  ##############################################################################
  # Computing the graph
  graph <- vector("list", t)

  if (recode.ids) labs <- attr(dat, "recode")[["label"]]
  else labs <- 1:n

  for(i in 1:t) {
    index <- which((t0 <= i) & (i <= t1))
    graph[[i]] <- edgelist_to_adjmat_cpp(
      dat[index,,drop=FALSE], w[index], n, undirected, self, multiple)

    # Naming
    dimnames(graph[[i]]) <- list(labs, labs)
  }

  # Times naming
  if (t>1 && (length(oldtimes) == 1))
    oldtimes <- 1:t

  names(graph) <- oldtimes

  if (t==1 & simplify) graph <- graph[[1]]

  attr(graph, "incomplete") <- incomplete

  return(graph)
}

#' @rdname edgelist_to_adjmat
#' @export
adjmat_to_edgelist <- function(
  graph,
  undirected=getOption("diffnet.undirected", FALSE),
  keep.isolates = getOption("diffnet.keep.isolates", TRUE)
  ) {

  cls <- class(graph)
  out <- if ("list" %in% cls) {
      adjmat_to_edgelist.list(graph, undirected, keep.isolates)
    } else if ("matrix" %in% cls) {
      cbind(adjmat_to_edgelist.matrix(graph, undirected, keep.isolates),1)
    } else if ("array" %in% cls) {
      adjmat_to_edgelist.array(graph, undirected, keep.isolates)
    } else if ("dgCMatrix" %in% cls) {
      cbind(adjmat_to_edgelist.dgCMatrix(graph, undirected, keep.isolates), 1)
    } else
      stopifnot_graph(graph)

  colnames(out) <- c("ego", "alter", "value", "time")
  out
}

# @rdname edgelist_to_adjmat
# @export
adjmat_to_edgelist.matrix <- function(graph, undirected, keep.isolates) {
  # as.integer(factor(diffnet$meta$ids[fakeDynEdgelist[,1]], diffnet$meta$ids))
  out <- adjmat_to_edgelist_cpp(methods::as(graph, "dgCMatrix"), undirected)

  # If keep isolates
  if (keep.isolates) {
    N <- 1:nvertices(graph)
    test <- which(!(N %in% unlist(out[,1:2])))

    # If there are isolates
    if (length(test)) out <- rbind(out, cbind(test, NA, NA))
  }

  return(out)
}

# @rdname edgelist_to_adjmat
# @export
adjmat_to_edgelist.dgCMatrix <- function(graph, undirected, keep.isolates) {
  out <- adjmat_to_edgelist_cpp(graph, undirected)

  # If keep isolates
  if (keep.isolates) {
    N <- 1:nvertices(graph)
    test <- which(!(N %in% unlist(out[,1:2])))

    # If there are isolates
    if (length(test)) out <- rbind(out, cbind(test, NA, NA))
  }

  return(out)
}

# @rdname edgelist_to_adjmat
# @export
adjmat_to_edgelist.array <- function(graph, undirected, keep.isolates) {
  edgelist <- matrix(ncol=3,nrow=0)
  times <- vector('integer',0L)

  # Getting the names
  tnames <- as.integer(dimnames(graph)[[3]])
  if (!length(tnames)) tnames <- 1:dim(graph)[3]

  for (i in 1:dim(graph)[3]) {
    x <- adjmat_to_edgelist.matrix(graph[,,i], undirected, keep.isolates)
    edgelist <- rbind(edgelist, x)
    times <- c(times, rep(tnames[i],nrow(x)))
  }

  return(cbind(edgelist, times=times))
}

# @rdname edgelist_to_adjmat
# @export
adjmat_to_edgelist.list <- function(graph, undirected, keep.isolates) {
  edgelist <- matrix(ncol=3,nrow=0)
  times <- vector('integer',0L)

  # Getting the names
  tnames <- as.integer(names(graph))
  if (!length(tnames)) tnames <- 1:dim(graph)[3]

  for (i in 1:length(graph)) {
    x <- adjmat_to_edgelist.dgCMatrix(graph[[i]], undirected, keep.isolates)
    edgelist <- rbind(edgelist, x)
    times <- c(times, rep(tnames[i],nrow(x)))
  }

  # # Adjusting the length
  # ids <- apply(edgelist, 1, paste0, collapse="")
  # times <- as.integer(unname(tapply(times, ids, min)))
  #
  # edgelist <- unique(edgelist)
  # edgelist <- edgelist[order(edgelist[,1],edgelist[,2]),]

  return(cbind(edgelist, times=times))
}

# # Benchmark with the previous version
# library(microbenchmark)
# library(netdiffuseR)
#
# dat <- as.data.frame(cbind(edgelist, w))
# colnames(dat) <- c('ego','alter','tie')
# microbenchmark(
#   adjmatbuild(dat,n,1:n),
#   edgelist_to_adjmat(edgelist, w), times=100)
#
# old <- adjmatbuild(dat[,-3],n,1:n)
# new <- (edgelist_to_adjmat(unique(edgelist), undirected = FALSE))[,,1]
# arrayInd(which(old!=new), dim(old), dimnames(old))
#
# ## Dynamic
# microbenchmark(
#   adjByTime(cbind(year=times,dat),n,max(times)),
#   edgelist_to_adjmat(edgelist, w, times), times=100)

#' Time of adoption matrix
#'
#' Creates two matrices recording times of adoption of the innovation. One matrix
#' records the time period of adoption for each node with zeros elsewhere. The
#' second records the cumulative time of adoption such that there are ones for
#' the time of adoption and every time period thereafter.
#'
#' @param obj Either an integer vector of size \eqn{n} containing time of adoption of the innovation,
#' or a \code{\link{diffnet}} object.
#' @param labels Character vector of size \eqn{n}. Labels (ids) of the vertices.
#' @param t0 Integer scalar. Sets the lower bound of the time window (e.g. 1955).
#' @param t1 Integer scalar. Sets the upper bound of the time window (e.g. 2000).
#' @details
#'
#' In order to be able to work with time ranges other than \eqn{1,\dots, T}{1,..., T}
#' the function receives as input the boundary labels of the time windows through
#' the variables \code{t0} and \code{t}. While by default the function assumes that
#' the the boundaries are given by the range of the \code{times} vector, the user
#' can set a personalized time range exceeding the one given by the \code{times}
#' vector. For instance, times of adoption may range between 2001 and 2005 but the
#' actual data, the network, is observed between 2000 and 2005 (so there is not
#' left censoring in the data), hence, the user could write:
#'
#' \preformatted{
#' adopmats <- toa_mat(times, t0=2000, t1=2005)
#' }
#'
#' That way the resulting \code{cumadopt} and \code{adopt} matrices would have
#' 2005 - 2000 + 1 = 6 columns instead of 2005 - 2001 + 1 = 5 columns, with the
#' first column of the two matrices containing only zeros (as the first adoption
#' happend after the year 2000).
#' @examples
#' # Random set of times of adoptions
#' times <- sample(c(NA, 2001:2005), 10, TRUE)
#'
#' toa_mat(times)
#'
#' # Now, suppose that we observe the graph from 2000 to 2006
#' toa_mat(times, t0=2000, t1=2006)
#'
#' @export
#' @return A list of two \eqn{n \times T}{n x T}
#'  \item{\code{cumadopt}}{has 1's for all years in which a node indicates having the innovation.}
#'  \item{\code{adopt}}{has 1's only for the year of adoption and 0 for the rest.}
#' @keywords manip
#' @include graph_data.r
#' @author George G. Vega Yon & Thomas W. Valente
toa_mat <- function(obj, labels=NULL, t0=NULL, t1=NULL) {

  if (!inherits(obj, "diffnet")) {
    if (!length(t0)) t0 <- min(obj, na.rm = TRUE)
    if (!length(t1)) t1 <- max(obj, na.rm = TRUE)
  }

  cls <- class(obj)
  ans <- if ("numeric" %in% cls) {
    toa_mat.numeric(obj, labels, t0, t1)
    } else if ("integer" %in% cls) {
    toa_mat.integer(obj, labels, t0, t1)
    } else if  ("diffnet" %in% cls) {
    with(obj, list(adopt=adopt,cumadopt=cumadopt))
    } else
      stopifnot_graph(obj)

  if (inherits(obj, "diffnet")) {
    dimnames(ans$adopt) <- with(obj$meta, list(ids,pers))
    dimnames(ans$cumadopt) <- with(obj$meta, list(ids,pers))
  }

  return(ans)
}

toa_mat.default <- function(per, t0, t1) {
  ans <- matrix(0L, ncol=t1-t0+1L, nrow=length(per))
  ans[cbind(1L:nrow(ans), per - t0 + 1L)] <- 1L

  list(
    adopt = ans,
    cumadopt = t(apply(ans, 1, cumsum))
  )
}

# @rdname toa_mat
# @export
toa_mat.numeric <- function(times, labels=NULL,
                            t0 = min(times, na.rm = TRUE),
                            t1 = max(times, na.rm=TRUE)) {
  if (inherits(times, 'numeric')) warning('-x- numeric. will be coersed to integer.')

  # Coercing into integer
  times <- as.integer(times)
  t0 <- as.integer(t0)
  t1 <- as.integer(t1)

  toa_mat.integer(times, labels, t0, t1)
}

# @rdname toa_mat
# @export
toa_mat.integer <- function(times, labels=NULL,
                            t0 = min(times, na.rm = TRUE),
                            t1 = max(times, na.rm=TRUE)) {
  # Rescaling
  output <- toa_mat.default(times, t0, t1)

  # Naming
  cn <- t0:t1
  if (length(labels)) rn <- labels
  else rn <- 1:length(times)

  dimnames(output[[1]]) <- list(rn, cn)
  dimnames(output[[2]]) <- list(rn, cn)

  output
}

# set.seed(123)
# x <- sample(2000:2005, 10, TRUE)
# y <- as.numeric(as.factor(x))
#
# new <- toa_mat(x)
# old <- adoptMat(y)
#
# sum(new[[1]] - old[[1]])
# sum(new[[2]] - old[[2]])
#
# microbenchmark(adoptMat(y), toa_mat_cpp(x), times=1000)
# Unit: microseconds
#             expr    min     lq      mean median      uq      max neval cld
# adoptMat(y)      43.876 51.010 61.133262 53.002 55.9400 4070.201 10000   b
# toa_mat_cpp(x)  4.620  6.226  7.921307  7.374  8.2605  114.874 10000  a

#' Difference in Time of Adoption (TOA) between individuals
#'
#' Creates \eqn{n \times n}{n * n} matrix indicating the difference in times of adoption between
#' each pair of nodes
#' @inheritParams toa_mat
#' @details Each cell ij of the resulting matrix is calculated as \eqn{toa_j - toa_i}{%
#' toa(j) - toa(i)}, so that whenever its positive it means that the j-th individual (alter)
#' adopted the innovation sooner.
#' @return An \eqn{n \times n}{n * n} symmetric matrix indicating the difference in times of
#' adoption between each pair of nodes.
#' @export
#' @examples
#' # Generating a random vector of time
#' set.seed(123)
#' times <- sample(2000:2005, 10, TRUE)
#'
#' # Computing the TOA differences
#' toa_diff(times)
#' @keywords manip
#' @include graph_data.r
#' @author George G. Vega Yon & Thomas W. Valente
toa_diff <- function(obj, t0=NULL, labels=NULL) {

  # Calculating t0 (if it was not provided)
  if (!inherits(obj, "diffnet") && !length(t0))
    t0 <- as.integer(min(obj, na.rm = TRUE))
  else
    t0 <- obj$meta$pers[1]

  # Computing the difference
  if (inherits(obj, "integer")) {
    out <- toa_diff_cpp(obj - t0 + 1L)
  } else if (inherits(obj, "numeric")) {
    warning("coercing -obj- to integer.")
    out <- toa_diff_cpp(as.integer(obj) - t0 + 1L)
  } else if (inherits(obj, "diffnet")) {
    out <- toa_diff_cpp(obj$toa - t0 + 1L)
  } else stop("No method defined for class -",class(obj),"-")

  out
}

# @rdname toa_diff
# @export
toa_diff.integer <- function(times, t0, labels) {
  # Rescaling
  times <- times - t0 + 1L
  toa_diff_cpp(times)
}

# set.seed(123)
# x <- sample(2000:2005, 10, TRUE)
# toa_diff(x)
#
# microbenchmark(toaMat(x), toa_diff_cpp(x), times=1000)
# Unit: microseconds
#           expr     min      lq       mean   median       uq      max neval cld
# toaMat(x)      227.279 247.679 291.940566 272.4290 283.6845 3667.118  1000   b
# toa_diff_cpp(x)   3.539   4.623   6.887954   6.3755   7.4645   54.817  1000  a
# > 291.940566/6.887954
# [1] 42.38422

#' Find and remove isolated vertices
#'
#' Find and remove unconnected vertices from the graph.
#' @templateVar undirected TRUE
#' @template graph_template
#' @templateVar undirected 1
#' @templateVar self 1
#' @export
#' @return
#' When \code{graph} is an adjacency matrix:
#'  \item{isolated}{an matrix of size \eqn{n\times 1}{n*1} with 1's where a node is isolated}
#'  \item{drop_isolated}{a modified graph excluding isolated vertices.}
#'
#' Otherwise, when \code{graph} is a list
#'  \item{isolated}{an matrix of size \eqn{n\times T}{n*T} with 1's where a node is isolated}
#'  \item{drop_isolated}{a modified graph excluding isolated vertices.}
#' @examples
#' # Generating random graph
#' set.seed(123)
#' adjmat <- rgraph_er()
#'
#' # Making nodes 1 and 4 isolated
#' adjmat[c(1,4),] <- 0
#' adjmat[,c(1,4)] <- 0
#' adjmat
#'
#' # Finding isolated nodes
#' iso <- isolated(adjmat)
#' iso
#'
#' # Removing isolated nodes
#' drop_isolated(adjmat)
#'
#'
#' # Now with a dynamic graph
#' graph <- rgraph_er(n=10, t=3)
#'
#' # Making 1 and 5 isolated
#' graph <- lapply(graph, "[<-", i=c(1,5), j=1:10, value=0)
#' graph <- lapply(graph, "[<-", i=1:10, j=c(1,5), value=0)
#' graph
#'
#' isolated(graph)
#' drop_isolated(graph)
#' @keywords manip
#' @family data management functions
#' @author George G. Vega Yon
isolated <- function(
  graph,
  undirected = getOption("diffnet.undirected", FALSE),
  self = getOption("diffnet.self", FALSE)
) {
  cls <- class(graph)
  ans <- if ("matrix" %in% cls) {
      isolated.default(methods::as(graph, "dgCMatrix"), undirected, self)
    } else if ("dgCMatrix" %in% cls) {
      isolated.default(graph, undirected, self)
    } else if ("array" %in% cls) {
      lapply(apply(graph, 3, methods::as, Class="dgCMatrix"), isolated.default,
                       undirected=undirected, self=self)
    } else if ("list" %in% cls) {
      lapply(graph, isolated.default, undirected=undirected, self=self)
    } else if ("diffnet" %in% cls) {
      lapply(graph$graph, isolated.default, undirected=undirected, self=self)
    } else
      stopifnot_graph(graph)

  if (any(class(graph) %in% c("list", "diffnet", "array")))
    apply(do.call(cbind, ans), 1, all)
  else ans
  # UseMethod("isolated")
}

# @export
# @rdname isolated
isolated.default <- function(
  graph,
  undirected = getOption("diffnet.undirected", FALSE),
  self = getOption("diffnet.self", FALSE)
) {

  graph@x <- rep(1.0, length(graph@x))
  d <- Matrix::rowSums(graph)
  if (undirected)
    d <- d + Matrix::colSums(graph)

  if (!self)
    d <- d - Matrix::diag(graph)

  unname(d == 0)
}

isolated.list <- function(
  graph,
  undirected = getOption("diffnet.undirected", FALSE),
  self = getOption("diffnet.self", FALSE)
  ) {

  ids <- lapply(graph, isolated.default, undirected=undirected, self=self)

  apply(do.call(cbind, ids), 1, all)

}

#' @export
#' @rdname isolated
drop_isolated <- function(
  graph,
  undirected = getOption("diffnet.undirected", FALSE),
  self = getOption("diffnet.self", FALSE)
) {

  # Find isolates
  ids <- which(!isolated(graph))

  if (inherits(graph, "list"))
    lapply(graph, "[", i=ids, j=ids, drop=FALSE)
  else if (inherits(graph, "diffnet"))
    graph[ids,]
  else if (inherits(graph, "dgCMatrix"))
    graph[ids,,drop=FALSE][,ids,drop=FALSE]
  else if (inherits(graph, "array"))
    graph[ids,,,drop=FALSE][,ids,,drop=FALSE]

}

simmelian_mat <- function(graph, ...) {
  tmethod <- if(isS4(graph)) getMethod("t", class(graph)) else t
  tmp <- graph & tmethod(graph)
  methods::as(tmp & (tmp %*% tmp), "dgCMatrix")
}

#' Approximate Geodesic Distances
#'
#' Computes approximate geodesic distance matrix using graph powers and keeping
#' the amount of memory used low.
#'
#' @template graph_template
#' @param n Integer scalar. Degree of approximation. Bigger values increase
#' precision (see details).
#' @param warn Logical scalar. When \code{TRUE}, it warns if the algorithm
#' performs less steps than required.
#'
#' @details
#'
#' While both \pkg{igraph} and \pkg{sna} offer very good and computationally
#' efficient routines for computing geodesic distances, both functions return
#' dense matrices, i.e. not sparse, which can be troublesome. Furthermore,
#' from the perspective of social network analysis, path lengths of more than 6 steps,
#' for example, may not be meaningful, or at least, relevant for the researcher.
#' In such cases, \code{approx_geodesic} serves as a solution to this problem,
#' computing geodesics up to the number of steps, \code{n}, desired, hence,
#' if \code{n = 6}, once the algorithm finds all paths of 6 or less steps it
#' will stop, returning a sparse matrix with zeros for those pairs of
#' vertices for which it was not able to find a path with less than \code{n}
#' steps.
#'
#' Depending on the graph size and density, \code{approx_geodesic}'s performance
#' can be compared to that of \code{\link[sna:geodist]{sna::geodist}}. Although,
#' as \code{n} increases, \code{geodist} becomes a better alternative.
#'
#' The algorithm was implemented using power graphs. At each itereation i the
#' power graph of order \code{i} is computed, and its values are compared
#' to the current values of the geodesic matrix (which is initialized in zero).
#'
#' \enumerate{
#' \item Initialize the output \code{ans(n, n)}
#' \item For \code{i=1} to \code{i < n} do
#' \enumerate{
#'   \item Iterate through the edges of \code{G^i}, if \code{ans} has a zero
#'   value in the corresponding row+column, replace it with \code{i}
#'   \item next
#' }
#' \item Replace all diagonal elements with a zero and return.
#' }
#'
#' This implementation can be more memory efficient that the aforementioned ones,
#' but at the same time it can be significant slower.
#'
#' \code{approx_geodist} is just an allias for \code{approx_geodesic}.
#'
#' @return A sparse matrix of class \code{\link[Matrix:dgCMatrix-class]{dgCMatrix}} of size
#' \code{nnodes(graph)^2} with geodesic distances up to \code{n}.
#'
#' @examples
#' # A very simple example -----------------------------------------------------
#' g <- ring_lattice(10, 3)
#' approx_geodesic(g, 6)
#' sna::geodist(as.matrix(g))[[2]]
#' igraph::distances(
#'   igraph::graph_from_adjacency_matrix(g, mode = "directed"),
#'   mode = "out"
#' )
#'
#' @aliases Geodesic Shortest-Path
#' @export
approx_geodesic <- function(graph, n = 6L, warn=FALSE) {
  cls <- class(graph)

  if ("dgCMatrix" %in% cls) {
    approx_geodesicCpp(graph, n, warn)
  } else if ("matrix" %in% cls) {
    approx_geodesicCpp(methods::as(graph, "dgCMatrix"), n, warn)
  } else if ("list" %in% cls) {
    lapply(graph, approx_geodesicCpp, n = n, warn = warn)
  } else if ("diffnet" %in% cls) {
    lapply(graph$graph, approx_geodesicCpp, n = n, warn = warn)
  } else if ("array" %in% cls) {
    apply(graph, 3, approx_geodesicCpp, n = n, warn = warn)
  } else stopifnot_graph(graph)
}

#' @rdname approx_geodesic
#' @export
approx_geodist <- approx_geodesic


R.version  #r version running

search()        # Shows the loaded packages

getOption("defaultPackages")

library()       # Shows the installed packages

#install.packages("ggplot2")
#install.packages("tidyr")

library(ggplot2)
search()

library("tidyr")
search()

#install.packages(c("tidyr", "devtools")) #tidyr for data handling

getwd()  #name of the working directory

dir()  # show files in the working directory

#to change working directory
#getting and setting the working directory
setwd("C:\\Users\\lenovo\\Desktop\\Rdatamining")

getwd()

#Kmeans clustering
data(iris)

#to get structure of data
str(iris)

iris2 <- iris
View(iris2)
str(iris2)

iris2$Species <- NULL #not to use species field
str(iris2)

km <- kmeans(iris2, 3)  # 3 clusters
km

?kmeans

km$size  #size of each cluster

km$centers

km$cluster

km$iter  #number of iterations used

iris2$cluster <- factor(km$cluster) #adding cluster label with each point
View(iris2)

km$withinss  #each cluster Sum of square error

#visulaizing clusters
I=iris2[c(1,2,5)]
View(I)  #data to plot

centers <- data.frame(cluster=factor(1:3), km$centers)
centers

ggplot(data=I, aes(x=Sepal.Length, y=Sepal.Width, color=cluster, shape=cluster)) +
  geom_point(alpha=.3)+
  geom_point(data=centers, aes(x=Sepal.Length, y=Sepal.Width), size=3, stroke=2)

#plotting mean of each variable within each cluster
centers=km$centers
t(centers)

centers <- as.data.frame(t(centers))
names(centers) <- paste("Cluster", 1:3)
centers

centers$Symbol <- row.names(centers)
centers$Symbol

centers <- gather(centers, "Cluster", "Mean", -Symbol)
centers$Color = centers$Mean > 0
ggplot(centers, aes(x=Symbol, y=Mean, fill=Color)) +
  geom_bar(stat='identity', position = "identity", width=.75) +
  facet_grid(Cluster ~ ., scales='free_y')

#comparing clusters with actual class species
table(iris$Species, km$cluster)

#other parameters setting
km1 <- kmeans(iris2, 2,5) #adding number of iteration
km1

table(iris$Species, km1$cluster)
#may create confusion matrix